~ubuntu-branches/ubuntu/saucy/gnudatalanguage/saucy-proposed : revision 16

1

/***************************************************************************

2

basic_fun.cpp - basic GDL library function

3

-------------------

4

begin : July 22 2002

5

6

email : m_schellens@users.sf.net

7

8

strtok_fun, getenv_fun, tag_names_fun, stregex_fun:

9

10

11

***************************************************************************/

12

13

/***************************************************************************

14

* *

15

* This program is free software; you can redistribute it and/or modify *

16

* it under the terms of the GNU General Public License as published by *

17

* the Free Software Foundation; either version 2 of the License, or *

18

* (at your option) any later version. *

19

* *

20

***************************************************************************/

21

22

#include "includefirst.hpp"

23

24

// get_kbrd patch

25

// http://sourceforge.net/forum/forum.php?thread_id=3292183&forum_id=338691

26

#include <termios.h>

27

#include <unistd.h>

28

#include <limits>

29

#include <string>

30

#include <fstream>

31

//#include <memory>

32

#include <regex.h> // stregex

33

34

#ifdef __APPLE__

35

# include <crt_externs.h>

36

# define environ (*_NSGetEnviron())

37

#else

38

#include <unistd.h>

39

#endif

40

41

#if defined(__FreeBSD__) || defined(__sun__) || defined(__OpenBSD__)

42

extern "C" char **environ;

43

#endif

44

45

#include "datatypes.hpp"

46

#include "envt.hpp"

47

#include "dpro.hpp"

48

#include "dinterpreter.hpp"

49

#include "basic_pro.hpp"

50

#include "terminfo.hpp"

51

#include "typedefs.hpp"

52

#include "base64.hpp"

53

54

#ifdef HAVE_LOCALE_H

55

# include <locale.h>

56

#endif

57

#include <sys/utsname.h>

58

59

/* max regexp error message length */

60

#define MAX_REGEXPERR_LENGTH 80

61

62

namespace lib {

63

64

using namespace std;

65

using namespace antlr;

66

67

// assumes all parameters from pOffs till end are dim

68

void arr( EnvT* e, dimension& dim, SizeT pOffs=0)

69

{

70

71

int nParam=e->NParam()-pOffs;

72

73

if( nParam <= 0)

74

e->Throw( "Incorrect number of arguments.");

75

76

const string BadDims="Array dimensions must be greater than 0.";

77

78

79

if( nParam == 1 ) {

80

81

BaseGDL* par = e->GetParDefined( pOffs);

82

83

SizeT newDim;

84

int ret = par->Scalar2index( newDim);

85

86

if (ret < 0) throw GDLException(BadDims);

87

88

if( ret > 0) { // single argument

89

if (newDim < 1) throw GDLException(BadDims);

90

dim << newDim;

91

return;

92

}

93

if( ret == 0) { // array argument

94

DLongGDL* ind =

95

static_cast<DLongGDL*>(par->Convert2(LONG, BaseGDL::COPY));

96

auto_ptr<DLongGDL> ind_guard( ind);

97

//e->Guard( ind);

98

99

for(SizeT i =0; i < par->N_Elements(); ++i){

100

if ((*ind)[i] < 1) throw GDLException(BadDims);

101

dim << (*ind)[i];

102

}

103

return;

104

}

105

e->Throw( "arr: should never arrive here.");

106

return;

107

}

108

109

// max number checked in interpreter

110

SizeT endIx=nParam+pOffs;

111

for( SizeT i=pOffs; i<endIx; i++)

112

{

113

BaseGDL* par=e->GetParDefined( i);

114

115

SizeT newDim;

116

int ret=par->Scalar2index( newDim);

117

if( ret < 1 || newDim == 0) throw GDLException(BadDims);

118

dim << newDim;

119

}

120

}

121

122

BaseGDL* bytarr( EnvT* e)

123

{

124

dimension dim;

125

// try{

126

arr( e, dim);

127

if (dim[0] == 0)

128

throw GDLException( "Array dimensions must be greater than 0");

129

130

if( e->KeywordSet(0)) return new DByteGDL(dim, BaseGDL::NOZERO);

131

return new DByteGDL(dim);

132

// }

133

// catch( GDLException& ex)

134

// {

135

// e->Throw( ex.getMessage());

136

// }

137

}

138

BaseGDL* intarr( EnvT* e)

139

{

140

dimension dim;

141

// try{

142

arr( e, dim);

143

if (dim[0] == 0)

144

throw GDLException( "Array dimensions must be greater than 0");

145

146

if( e->KeywordSet(0)) return new DIntGDL(dim, BaseGDL::NOZERO);

147

return new DIntGDL(dim);

148

// }

149

// catch( GDLException& ex)

150

// {

151

// e->Throw( "INTARR: "+ex.getMessage());

152

// }

153

}

154

BaseGDL* uintarr( EnvT* e)

155

{

156

dimension dim;

157

// try{

158

arr( e, dim);

159

if (dim[0] == 0)

160

throw GDLException( "Array dimensions must be greater than 0");

161

162

if( e->KeywordSet(0)) return new DUIntGDL(dim, BaseGDL::NOZERO);

163

return new DUIntGDL(dim);

164

// }

165

// catch( GDLException& ex)

166

// {

167

// e->Throw( "UINTARR: "+ex.getMessage());

168

// }

169

}

170

BaseGDL* lonarr( EnvT* e)

171

{

172

dimension dim;

173

// try{

174

arr( e, dim);

175

if (dim[0] == 0)

176

throw GDLException( "Array dimensions must be greater than 0");

177

178

if( e->KeywordSet(0)) return new DLongGDL(dim, BaseGDL::NOZERO);

179

return new DLongGDL(dim);

180

/* }

181

catch( GDLException& ex)

182

{

183

e->Throw( "LONARR: "+ex.getMessage());

184

}*/

185

}

186

BaseGDL* ulonarr( EnvT* e)

187

{

188

dimension dim;

189

// try{

190

arr( e, dim);

191

if (dim[0] == 0)

192

throw GDLException( "Array dimensions must be greater than 0");

193

194

if( e->KeywordSet(0)) return new DULongGDL(dim, BaseGDL::NOZERO);

195

return new DULongGDL(dim);

196

/* }

197

catch( GDLException& ex)

198

{

199

e->Throw( "ULONARR: "+ex.getMessage());

200

}

201

*/

202

}

203

BaseGDL* lon64arr( EnvT* e)

204

{

205

dimension dim;

206

// try{

207

arr( e, dim);

208

if (dim[0] == 0)

209

throw GDLException( "Array dimensions must be greater than 0");

210

211

if( e->KeywordSet(0)) return new DLong64GDL(dim, BaseGDL::NOZERO);

212

return new DLong64GDL(dim);

213

/* }

214

catch( GDLException& ex)

215

{

216

e->Throw( "LON64ARR: "+ex.getMessage());

217

}*/

218

}

219

BaseGDL* ulon64arr( EnvT* e)

220

{

221

dimension dim;

222

// try{

223

arr( e, dim);

224

if (dim[0] == 0)

225

throw GDLException( "Array dimensions must be greater than 0");

226

227

if( e->KeywordSet(0)) return new DULong64GDL(dim, BaseGDL::NOZERO);

228

return new DULong64GDL(dim);

229

/* }

230

catch( GDLException& ex)

231

{

232

e->Throw( "ULON64ARR: "+ex.getMessage());

233

}*/

234

}

235

BaseGDL* fltarr( EnvT* e)

236

{

237

dimension dim;

238

// try{

239

arr( e, dim);

240

if (dim[0] == 0)

241

throw GDLException( "Array dimensions must be greater than 0");

242

243

if( e->KeywordSet(0)) return new DFloatGDL(dim, BaseGDL::NOZERO);

244

return new DFloatGDL(dim);

245

/* }

246

catch( GDLException& ex)

247

{

248

e->Throw( "FLTARR: "+ex.getMessage());

249

}

250

*/}

251

BaseGDL* dblarr( EnvT* e)

252

{

253

dimension dim;

254

// try{

255

arr( e, dim);

256

if (dim[0] == 0)

257

throw GDLException( "Array dimensions must be greater than 0");

258

259

if( e->KeywordSet(0)) return new DDoubleGDL(dim, BaseGDL::NOZERO);

260

return new DDoubleGDL(dim);

261

/* }

262

catch( GDLException& ex)

263

{

264

e->Throw( "DBLARR: "+ex.getMessage());

265

}*/

266

}

267

BaseGDL* strarr( EnvT* e)

268

{

269

dimension dim;

270

// try{

271

arr( e, dim);

272

if (dim[0] == 0)

273

throw GDLException( "Array dimensions must be greater than 0");

274

275

if( e->KeywordSet(0))

276

e->Throw( "Keyword parameters not allowed in call.");

277

return new DStringGDL(dim);

278

/* }

279

catch( GDLException& ex)

280

{

281

e->Throw( "STRARR: "+ex.getMessage());

282

}

283

*/ }

284

BaseGDL* complexarr( EnvT* e)

285

{

286

dimension dim;

287

// try{

288

arr( e, dim);

289

if (dim[0] == 0)

290

throw GDLException( "Array dimensions must be greater than 0");

291

292

if( e->KeywordSet(0)) return new DComplexGDL(dim, BaseGDL::NOZERO);

293

return new DComplexGDL(dim);

294

/*}

295

catch( GDLException& ex)

296

{

297

e->Throw( "COMPLEXARR: "+ex.getMessage());

298

}

299

*/ }

300

BaseGDL* dcomplexarr( EnvT* e)

301

{

302

dimension dim;

303

// try{

304

arr( e, dim);

305

if (dim[0] == 0)

306

307

if( e->KeywordSet(0)) return new DComplexDblGDL(dim, BaseGDL::NOZERO);

308

return new DComplexDblGDL(dim);

309

/* }

310

catch( GDLException& ex)

311

{

312

e->Throw( "DCOMPLEXARR: "+ex.getMessage());

313

}

314

*/ }

315

BaseGDL* ptrarr( EnvT* e)

316

{

317

dimension dim;

318

// try{

319

arr( e, dim);

320

if (dim[0] == 0)

321

throw GDLException( "Array dimensions must be greater than 0");

322

323

DPtrGDL* ret;

324

325

// if( e->KeywordSet(0))

326

// ret= new DPtrGDL(dim);//, BaseGDL::NOZERO);

327

// else

328

// if( e->KeywordSet(1))

329

// ret= new DPtrGDL(dim, BaseGDL::NOZERO);

330

// else

331

// return new DPtrGDL(dim);

332

if( !e->KeywordSet(1))

333

return new DPtrGDL(dim);

334

335

ret= new DPtrGDL(dim, BaseGDL::NOZERO);

336

337

SizeT nEl=ret->N_Elements();

338

SizeT sIx=e->NewHeap(nEl);

339

// #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))

340

{

341

// #pragma omp for

342

for( SizeT i=0; i<nEl; i++)

343

(*ret)[i]=sIx+i;

344

}

345

return ret;

346

/* }

347

catch( GDLException& ex)

348

{

349

e->Throw( "PTRARR: "+ex.getMessage());

350

}*/

351

}

352

BaseGDL* objarr( EnvT* e)

353

{

354

dimension dim;

355

// try{

356

arr( e, dim);

357

if (dim[0] == 0)

358

throw GDLException( "Array dimensions must be greater than 0");

359

360

// reference counting if( e->KeywordSet(0)) return new DObjGDL(dim, BaseGDL::NOZERO);

361

return new DObjGDL(dim);

362

/* }

363

catch( GDLException& ex)

364

{

365

e->Throw( "OBJARR: "+ex.getMessage());

366

}

367

*/ }

368

369

BaseGDL* ptr_new( EnvT* e)

370

{

371

int nParam=e->NParam();

372

373

if( nParam > 0)

374

{

375

// new ptr from undefined variable is allowed as well

376

BaseGDL* p= e->GetPar( 0);

377

if( p == NULL)

378

{

379

DPtr heapID= e->NewHeap();

380

return new DPtrGDL( heapID);

381

}

382

383

if( e->KeywordSet(0)) // NO_COPY

384

{

385

BaseGDL** p= &e->GetPar( 0);

386

// if( *p == NULL)

387

// e->Throw( "Parameter undefined: "+

388

// e->GetParString(0));

389

390

DPtr heapID= e->NewHeap( 1, *p);

391

*p=NULL;

392

return new DPtrGDL( heapID);

393

}

394

else

395

{

396

BaseGDL* p= e->GetParDefined( 0);

397

398

DPtr heapID= e->NewHeap( 1, p->Dup());

399

return new DPtrGDL( heapID);

400

}

401

}

402

else

403

{

404

if( e->KeywordSet(1)) // ALLOCATE_HEAP

405

{

406

DPtr heapID= e->NewHeap();

407

return new DPtrGDL( heapID);

408

}

409

else

410

{

411

return new DPtrGDL( 0); // null ptr

412

}

413

}

414

}

415

416

BaseGDL* ptr_valid( EnvT* e)

417

{

418

int nParam=e->NParam();

419

420

if( e->KeywordPresent( 1)) // COUNT

421

{

422

e->SetKW( 1, new DLongGDL( e->Interpreter()->HeapSize()));

423

}

424

425

if( nParam == 0)

426

{

427

return e->Interpreter()->GetAllHeap();

428

}

429

430

BaseGDL* p = e->GetPar( 0);

431

if( p == NULL)

432

{

433

return new DByteGDL( 0);

434

}

435

436

if( e->KeywordSet( 0)) // CAST

437

{

438

DLongGDL* pL = dynamic_cast<DLongGDL*>( p);

439

auto_ptr<DLongGDL> pL_guard;

440

if( pL == NULL)

441

{

442

pL = static_cast<DLongGDL*>(p->Convert2(LONG,BaseGDL::COPY));

443

pL_guard.reset( pL);

444

}

445

446

SizeT nEl = pL->N_Elements();

447

DPtrGDL* ret = new DPtrGDL( pL->Dim()); // zero

448

GDLInterpreter* interpreter = e->Interpreter();

449

for( SizeT i=0; i<nEl; ++i)

450

{

451

if( interpreter->PtrValid( (*pL)[ i]))

452

(*ret)[ i] = (*pL)[ i];

453

}

454

return ret;

455

}

456

457

DPtrGDL* pPtr = dynamic_cast<DPtrGDL*>( p);

458

if( pPtr == NULL)

459

{

460

return new DByteGDL( p->Dim()); // zero

461

}

462

463

SizeT nEl = pPtr->N_Elements();

464

DByteGDL* ret = new DByteGDL( pPtr->Dim()); // zero

465

GDLInterpreter* interpreter = e->Interpreter();

466

for( SizeT i=0; i<nEl; ++i)

467

{

468

if( interpreter->PtrValid( (*pPtr)[ i]))

469

(*ret)[ i] = 1;

470

}

471

return ret;

472

}

473

474

BaseGDL* obj_valid( EnvT* e)

475

{

476

int nParam=e->NParam();

477

478

if( e->KeywordPresent( 1)) // COUNT

479

{

480

e->SetKW( 1, new DLongGDL( e->Interpreter()->ObjHeapSize()));

481

}

482

483

if( nParam == 0)

484

{

485

return e->Interpreter()->GetAllObjHeap();

486

}

487

488

BaseGDL* p = e->GetPar( 0);

489

if( p == NULL)

490

{

491

return new DByteGDL( 0);

492

}

493

494

if( e->KeywordSet( 0)) // CAST

495

{

496

DLongGDL* pL = dynamic_cast<DLongGDL*>( p);

497

auto_ptr<DLongGDL> pL_guard;

498

if( pL == NULL)

499

{

500

pL = static_cast<DLongGDL*>(p->Convert2(LONG,BaseGDL::COPY));

501

pL_guard.reset( pL);

502

// e->Guard( pL);

503

}

504

505

SizeT nEl = pL->N_Elements();

506

DObjGDL* ret = new DObjGDL( pL->Dim()); // zero

507

GDLInterpreter* interpreter = e->Interpreter();

508

for( SizeT i=0; i<nEl; ++i)

509

{

510

if( interpreter->ObjValid( (*pL)[ i]))

511

(*ret)[ i] = (*pL)[ i];

512

}

513

return ret;

514

}

515

516

DObjGDL* pObj = dynamic_cast<DObjGDL*>( p);

517

if( pObj == NULL)

518

{

519

return new DByteGDL( p->Dim()); // zero

520

}

521

522

SizeT nEl = pObj->N_Elements();

523

DByteGDL* ret = new DByteGDL( pObj->Dim()); // zero

524

GDLInterpreter* interpreter = e->Interpreter();

525

for( SizeT i=0; i<nEl; ++i)

526

{

527

if( interpreter->ObjValid( (*pObj)[ i]))

528

(*ret)[ i] = 1;

529

}

530

return ret;

531

}

532

533

BaseGDL* obj_new( EnvT* e)

534

{

535

StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());

536

537

int nParam=e->NParam();

538

539

if( nParam == 0)

540

{

541

return new DObjGDL( 0);

542

}

543

544

DString objName;

545

e->AssureScalarPar<DStringGDL>( 0, objName);

546

547

// this is a struct name -> convert to UPPERCASE

548

objName=StrUpCase(objName);

549

550

DStructDesc* objDesc=e->Interpreter()->GetStruct( objName, e->CallingNode());

551

552

DStructGDL* objStruct= new DStructGDL( objDesc, dimension());

553

554

DObj objID= e->NewObjHeap( 1, objStruct); // owns objStruct

555

556

BaseGDL* newObj = new DObjGDL( objID); // the object

557

558

try {

559

// call INIT function

560

DFun* objINIT= objDesc->GetFun( "INIT");

561

if( objINIT != NULL)

562

{

563

// morph to obj environment and push it onto the stack again

564

e->PushNewEnvUD( objINIT, 1, &newObj);

565

566

BaseGDL* res=e->Interpreter()->call_fun( objINIT->GetTree());

567

568

if( res == NULL || (!res->Scalar()) || res->False())

569

{

570

delete res;

571

return new DObjGDL( 0);

572

}

573

delete res;

574

}

575

} catch(...) {

576

e->FreeObjHeap( objID); // newObj might be changed

577

delete newObj;

578

throw;

579

}

580

581

return newObj;

582

}

583

584

BaseGDL* bindgen( EnvT* e)

585

{

586

dimension dim;

587

// try{

588

arr( e, dim);

589

if (dim[0] == 0)

590

throw GDLException( "Array dimensions must be greater than 0");

591

592

return new DByteGDL(dim, BaseGDL::INDGEN);

593

/* }

594

catch( GDLException& ex)

595

{

596

e->Throw( "BINDGEN: "+ex.getMessage());

597

}

598

*/ }

599

// keywords not supported yet

600

BaseGDL* indgen( EnvT* e)

601

{

602

dimension dim;

603

604

// Defaulting to INT

605

DType type = INT;

606

607

static int kwIx1 = e->KeywordIx("BYTE");

608

if (e->KeywordSet(kwIx1)){ type = BYTE; }

609

610

static int kwIx2 = e->KeywordIx("COMPLEX");

611

if (e->KeywordSet(kwIx2)){ type = COMPLEX; }

612

613

static int kwIx3 = e->KeywordIx("DCOMPLEX");

614

if (e->KeywordSet(kwIx3)){ type = COMPLEXDBL; }

615

616

static int kwIx4 = e->KeywordIx("DOUBLE");

617

if (e->KeywordSet(kwIx4)){ type = DOUBLE; }

618

619

static int kwIx5 = e->KeywordIx("FLOAT");

620

if (e->KeywordSet(kwIx5)){ type = FLOAT; }

621

622

static int kwIx6 = e->KeywordIx("L64");

623

if (e->KeywordSet(kwIx6)){ type = LONG64; }

624

625

static int kwIx7 = e->KeywordIx("LONG");

626

if (e->KeywordSet(kwIx7)){ type = LONG; }

627

628

static int kwIx8 = e->KeywordIx("STRING");

629

if (e->KeywordSet(kwIx8)){ type = STRING; }

630

631

static int kwIx9 = e->KeywordIx("UINT");

632

if (e->KeywordSet(kwIx9)){ type = UINT; }

633

634

static int kwIx10 = e->KeywordIx("UL64");

635

if (e->KeywordSet(kwIx10)){ type = ULONG64; }

636

637

static int kwIx11 = e->KeywordIx("ULONG");

638

if (e->KeywordSet(kwIx11)){ type = ULONG; }

639

640

/*try

641

{*/

642

// Seeing if the user passed in a TYPE code

643

static int kwIx12 = e->KeywordIx("TYPE");

644

if ( e->KeywordPresent(kwIx12)){

645

DLong temp_long;

646

e->AssureLongScalarKW(kwIx12, temp_long);

647

type = static_cast<DType>(temp_long);

648

}

649

650

arr(e, dim);

651

if (dim[0] == 0)

652

throw GDLException( "Array dimensions must be greater than 0");

653

654

switch(type)

655

{

656

case INT: return new DIntGDL(dim, BaseGDL::INDGEN);

657

case BYTE: return new DByteGDL(dim, BaseGDL::INDGEN);

658

case COMPLEX: return new DComplexGDL(dim, BaseGDL::INDGEN);

659

case COMPLEXDBL: return new DComplexDblGDL(dim, BaseGDL::INDGEN);

660

case DOUBLE: return new DDoubleGDL(dim, BaseGDL::INDGEN);

661

case FLOAT: return new DFloatGDL(dim, BaseGDL::INDGEN);

662

case LONG64: return new DLong64GDL(dim, BaseGDL::INDGEN);

663

case LONG: return new DLongGDL(dim, BaseGDL::INDGEN);

664

case STRING: {

665

DULongGDL* iGen = new DULongGDL(dim, BaseGDL::INDGEN);

666

return iGen->Convert2(STRING);

667

}

668

case UINT: return new DUIntGDL(dim, BaseGDL::INDGEN);

669

case ULONG64: return new DULong64GDL(dim, BaseGDL::INDGEN);

670

case ULONG: return new DULongGDL(dim, BaseGDL::INDGEN);

671

default:

672

e->Throw( "Invalid type code specified.");

673

break;

674

}

675

/* }

676

catch( GDLException& ex)

677

{

678

e->Throw( ex.getMessage());

679

}*/

680

}

681

682

BaseGDL* uindgen( EnvT* e)

683

{

684

dimension dim;

685

// try{

686

arr( e, dim);

687

if (dim[0] == 0)

688

throw GDLException( "Array dimensions must be greater than 0");

689

690

return new DUIntGDL(dim, BaseGDL::INDGEN);

691

/* }

692

catch( GDLException& ex)

693

{

694

e->Throw( "UINDGEN: "+ex.getMessage());

695

}

696

*/ }

697

BaseGDL* sindgen( EnvT* e)

698

{

699

dimension dim;

700

// try{

701

arr( e, dim);

702

if (dim[0] == 0)

703

throw GDLException( "Array dimensions must be greater than 0");

704

705

DULongGDL* iGen = new DULongGDL(dim, BaseGDL::INDGEN);

706

return iGen->Convert2( STRING);

707

/* }

708

catch( GDLException& ex)

709

{

710

e->Throw( "SINDGEN: "+ex.getMessage());

711

}*/

712

}

713

BaseGDL* lindgen( EnvT* e)

714

{

715

dimension dim;

716

// try{

717

arr( e, dim);

718

return new DLongGDL(dim, BaseGDL::INDGEN);

719

/* }

720

catch( GDLException& ex)

721

{

722

e->Throw( "LINDGEN: "+ex.getMessage());

723

}*/

724

}

725

BaseGDL* ulindgen( EnvT* e)

726

{

727

dimension dim;

728

// try{

729

arr( e, dim);

730

if (dim[0] == 0)

731

throw GDLException( "Array dimensions must be greater than 0");

732

733

return new DULongGDL(dim, BaseGDL::INDGEN);

734

/* }

735

catch( GDLException& ex)

736

{

737

e->Throw( "ULINDGEN: "+ex.getMessage());

738

}*/

739

}

740

BaseGDL* l64indgen( EnvT* e)

741

{

742

dimension dim;

743

// try{

744

arr( e, dim);

745

if (dim[0] == 0)

746

throw GDLException( "Array dimensions must be greater than 0");

747

748

return new DLong64GDL(dim, BaseGDL::INDGEN);

749

/* }

750

catch( GDLException& ex)

751

{

752

e->Throw( "L64INDGEN: "+ex.getMessage());

753

}*/

754

}

755

BaseGDL* ul64indgen( EnvT* e)

756

{

757

dimension dim;

758

// try{

759

arr( e, dim);

760

if (dim[0] == 0)

761

throw GDLException( "Array dimensions must be greater than 0");

762

763

return new DULong64GDL(dim, BaseGDL::INDGEN);

764

/* }

765

catch( GDLException& ex)

766

{

767

e->Throw( "UL64INDGEN: "+ex.getMessage());

768

}

769

*/ }

770

BaseGDL* findgen( EnvT* e)

771

{

772

dimension dim;

773

// try{

774

arr( e, dim);

775

if (dim[0] == 0)

776

throw GDLException( "Array dimensions must be greater than 0");

777

778

return new DFloatGDL(dim, BaseGDL::INDGEN);

779

/* }

780

catch( GDLException& ex)

781

{

782

e->Throw( "FINDGEN: "+ex.getMessage());

783

}*/

784

}

785

BaseGDL* dindgen( EnvT* e)

786

{

787

dimension dim;

788

// try{

789

arr( e, dim);

790

if (dim[0] == 0)

791

throw GDLException( "Array dimensions must be greater than 0");

792

793

return new DDoubleGDL(dim, BaseGDL::INDGEN);

794

/* }

795

catch( GDLException& ex)

796

{

797

e->Throw( "DINDGEN: "+ex.getMessage());

798

}*/

799

}

800

BaseGDL* cindgen( EnvT* e)

801

{

802

dimension dim;

803

// try{

804

arr( e, dim);

805

if (dim[0] == 0)

806

throw GDLException( "Array dimensions must be greater than 0");

807

808

return new DComplexGDL(dim, BaseGDL::INDGEN);

809

/* }

810

catch( GDLException& ex)

811

{

812

e->Throw( "CINDGEN: "+ex.getMessage());

813

}*/

814

}

815

BaseGDL* dcindgen( EnvT* e)

816

{

817

dimension dim;

818

// try{

819

arr( e, dim);

820

if (dim[0] == 0)

821

throw GDLException( "Array dimensions must be greater than 0");

822

823

return new DComplexDblGDL(dim, BaseGDL::INDGEN);

824

/* }

825

catch( GDLException& ex)

826

{

827

e->Throw( "DCINDGEN: "+ex.getMessage());

828

}

829

*/ }

830

831

BaseGDL* n_elements( EnvT* e)

832

{

833

SizeT nParam=e->NParam(1);

834

835

// if( nParam != 1)

836

// e->Throw( "Incorrect number of arguments.");

837

838

BaseGDL* p0=e->GetPar( 0);

839

840

if( p0 == NULL) return new DLongGDL( 0);

841

842

return new DLongGDL( p0->N_Elements());

843

}

844

845

template< typename ComplexGDL, typename Complex, typename Float>

846

BaseGDL* complex_fun_template( EnvT* e)

847

{

848

SizeT nParam=e->NParam( 1);

849

if( nParam <= 2)

850

{

851

if( nParam == 2)

852

{

853

BaseGDL* p0=e->GetParDefined( 0);

854

BaseGDL* p1=e->GetParDefined( 1);

855

auto_ptr<Float> p0Float( static_cast<Float*>

856

(p0->Convert2( Float::t,BaseGDL::COPY)));

857

auto_ptr<Float> p1Float( static_cast<Float*>

858

(p1->Convert2( Float::t,BaseGDL::COPY)));

859

if( p0Float->Rank() == 0)

860

{

861

ComplexGDL* res = new ComplexGDL( p1Float->Dim(),

862

BaseGDL::NOZERO);

863

864

SizeT nE=p1Float->N_Elements();

865

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

866

{

867

// #pragma omp for

868

for( SizeT i=0; i<nE; i++)

869

{

870

(*res)[i]=Complex( (*p0Float)[0], (*p1Float)[i]);

871

}

872

}

873

return res;

874

}

875

else if( p1Float->Rank() == 0)

876

{

877

ComplexGDL* res = new ComplexGDL( p0Float->Dim(),

878

BaseGDL::NOZERO);

879

880

SizeT nE=p0Float->N_Elements();

881

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

882

{

883

// #pragma omp for

884

for( SizeT i=0; i<nE; i++)

885

{

886

(*res)[i]=Complex( (*p0Float)[i], (*p1Float)[0]);

887

}

888

}

889

return res;

890

}

891

else if( p0Float->N_Elements() >= p1Float->N_Elements())

892

{

893

ComplexGDL* res = new ComplexGDL( p1Float->Dim(),

894

BaseGDL::NOZERO);

895

896

SizeT nE=p1Float->N_Elements();

897

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

898

{

899

// #pragma omp for

900

for( SizeT i=0; i<nE; i++)

901

{

902

(*res)[i]=Complex( (*p0Float)[i], (*p1Float)[i]);

903

}

904

}

905

return res;

906

}

907

else

908

{

909

ComplexGDL* res = new ComplexGDL( p0Float->Dim(),

910

BaseGDL::NOZERO);

911

912

SizeT nE=p0Float->N_Elements();

913

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

914

{

915

// #pragma omp for

916

for( SizeT i=0; i<nE; i++)

917

{

918

(*res)[i]=Complex( (*p0Float)[i], (*p1Float)[i]);

919

}

920

}

921

return res;

922

}

923

}

924

else

925

{

926

// SA: see tracker item 3151760

927

BaseGDL* p0 = e->GetParDefined( 0);

928

if (ComplexGDL::t == p0->Type() && e->GlobalPar(0)) return p0;

929

return p0->Convert2( ComplexGDL::t, BaseGDL::COPY);

930

}

931

}

932

else // COMPLEX( expr, offs, dim1,..,dim8)

933

{

934

BaseGDL* p0 = e->GetParDefined( 0);

935

// *** WRONG: with offs data is converted bytewise

936

auto_ptr<Float> p0Float(static_cast<Float*>

937

(p0->Convert2( Float::t,

938

BaseGDL::COPY)));

939

DLong offs;

940

e->AssureLongScalarPar( 1, offs);

941

942

dimension dim;

943

arr( e, dim, 2);

944

945

SizeT nElCreate=dim.NDimElements();

946

947

SizeT nElSource=p0->N_Elements();

948

949

if( (offs+2*nElCreate) > nElSource)

950

e->Throw( "Specified offset to"

951

" array is out of range: "+e->GetParString(0));

952

953

ComplexGDL* res=new ComplexGDL( dim, BaseGDL::NOZERO);

954

955

// #pragma omp parallel if (nElCreate >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nElCreate))

956

{

957

// #pragma omp for

958

for( SizeT i=0; i<nElCreate; i++)

959

{

960

SizeT srcIx=2*i+offs;

961

(*res)[i]=Complex( (*p0Float)[srcIx], (*p0Float)[srcIx+1]);

962

}

963

}

964

return res;

965

}

966

}

967

968

BaseGDL* complex_fun( EnvT* e)

969

{

970

return complex_fun_template< DComplexGDL, DComplex, DFloatGDL>( e);

971

}

972

BaseGDL* dcomplex_fun( EnvT* e)

973

{

974

return complex_fun_template< DComplexDblGDL, DComplexDbl, DDoubleGDL>( e);

975

}

976

977

template< class TargetClass>

978

BaseGDL* type_fun( EnvT* e)

979

{

980

SizeT nParam=e->NParam(1);

981

982

if( nParam == 1)

983

{

984

BaseGDL* p0=e->GetParDefined( 0);

985

986

assert( dynamic_cast< EnvUDT*>( e->Caller()) != NULL);

987

988

// type_fun( expr) just convert

989

if( static_cast< EnvUDT*>( e->Caller())->GetIOError() != NULL)

990

return p0->Convert2( TargetClass::t,

991

BaseGDL::COPY_THROWIOERROR);

992

// SA: see tracker item no. 3151760

993

else if (TargetClass::t == p0->Type() && e->GlobalPar(0))

994

return p0;

995

else

996

return p0->Convert2( TargetClass::t, BaseGDL::COPY);

997

}

998

999

BaseGDL* p0=e->GetNumericParDefined( 0);

1000

1001

// BYTE( expr, offs, dim1,..,dim8)

1002

DLong offs;

1003

e->AssureLongScalarPar( 1, offs);

1004

1005

dimension dim;

1006

1007

if( nParam > 2)

1008

arr( e, dim, 2);

1009

1010

TargetClass* res=new TargetClass( dim, BaseGDL::NOZERO);

1011

1012

SizeT nByteCreate=res->NBytes(); // net size of new data

1013

1014

SizeT nByteSource=p0->NBytes(); // net size of src

1015

1016

if( offs < 0 || (offs+nByteCreate) > nByteSource)

1017

{

1018

delete res;

1019

e->Throw( "Specified offset to"

1020

" expression is out of range: "+e->GetParString(0));

1021

}

1022

1023

//*** POSSIBLE ERROR because of alignment here

1024

void* srcAddr = static_cast<void*>( static_cast<char*>(p0->DataAddr()) +

1025

offs);

1026

void* dstAddr = static_cast<void*>(&(*res)[0]);

1027

memcpy( dstAddr, srcAddr, nByteCreate);

1028

1029

// char* srcAddr = reinterpret_cast<char*>(p0->DataAddr());

1030

// char* dstAddr = reinterpret_cast<char*>(&(*res)[0]);

1031

// copy( srcAddr, srcAddr+nByteCreate, dstAddr);

1032

1033

return res;

1034

}

1035

1036

BaseGDL* byte_fun( EnvT* e)

1037

{

1038

return type_fun<DByteGDL>( e);

1039

}

1040

BaseGDL* uint_fun( EnvT* e)

1041

{

1042

return type_fun<DUIntGDL>( e);

1043

}

1044

BaseGDL* long_fun( EnvT* e)

1045

{

1046

return type_fun<DLongGDL>( e);

1047

}

1048

BaseGDL* ulong_fun( EnvT* e)

1049

{

1050

return type_fun<DULongGDL>( e);

1051

}

1052

BaseGDL* long64_fun( EnvT* e)

1053

{

1054

return type_fun<DLong64GDL>( e);

1055

}

1056

BaseGDL* ulong64_fun( EnvT* e)

1057

{

1058

return type_fun<DULong64GDL>( e);

1059

}

1060

BaseGDL* float_fun( EnvT* e)

1061

{

1062

return type_fun<DFloatGDL>( e);

1063

}

1064

BaseGDL* double_fun( EnvT* e)

1065

{

1066

return type_fun<DDoubleGDL>( e);

1067

}

1068

// STRING function behaves different

1069

BaseGDL* string_fun( EnvT* e)

1070

{

1071

SizeT nParam=e->NParam();

1072

1073

if( nParam == 0)

1074

e->Throw( "Incorrect number of arguments.");

1075

1076

bool printKey = e->KeywordSet( 4);

1077

int parOffset = 0;

1078

1079

// SA: handling special VMS-compatibility syntax, e.g.: string(1,'$(F)')

1080

// (if nor FORMAT neither PRINT defined, >1 parameter, last param is scalar string

1081

// which begins with "$(" or "(" but is not "()" then last param [minus "$"] is treated as FORMAT)

1082

bool vmshack = false;

1083

if (!printKey && (e->GetKW(0) == NULL) && nParam > 1)

1084

{

1085

vmshack = true;

1086

BaseGDL* par = e->GetParDefined(nParam - 1);

1087

if (par->Type() == STRING && par->Scalar())

1088

{

1089

int dollar = (*static_cast<DStringGDL*>(par))[0].compare(0,2,"$(");

1090

if (dollar == 0 || ((*static_cast<DStringGDL*>(par))[0].compare(0,1,"(") == 0 && (*static_cast<DStringGDL*>(par))[0] != "()"))

1091

{

1092

e->SetKeyword("FORMAT", new DStringGDL(

1093

(*static_cast<DStringGDL*>(par))[0].c_str() + (dollar == 0 ? 1 : 0)

1094

));

1095

}

1096

}

1097

}

1098

1099

BaseGDL* format_kw = e->GetKW( 0);

1100

bool formatKey = format_kw != NULL;

1101

1102

if (formatKey && format_kw->Type() == STRING && (*static_cast<DStringGDL*>(format_kw))[0] == "") formatKey = false;

1103

1104

if( printKey || formatKey) // PRINT or FORMAT

1105

{

1106

stringstream os;

1107

1108

SizeT width = 0;

1109

if( printKey) // otherwise: FORMAT -> width is ignored

1110

{

1111

// for /PRINT always a terminal width of 80 is assumed

1112

width = 80;//TermWidth();

1113

}

1114

1115

if (vmshack)

1116

{

1117

parOffset = 1;

1118

e->ShiftParNumbering(1);

1119

}

1120

print_os( &os, e, parOffset, width);

1121

if (vmshack)

1122

{

1123

e->ShiftParNumbering(-1);

1124

}

1125

1126

deque<DString> buf;

1127

while( os.good())

1128

{

1129

string line;

1130

getline( os, line);

1131

if( os.good()) buf.push_back( line);

1132

}

1133

1134

SizeT bufSize = buf.size();

1135

if( bufSize == 0)

1136

e->Throw( "Internal error: print buffer empty.");

1137

1138

if( bufSize > 1)

1139

{

1140

DStringGDL* retVal =

1141

new DStringGDL( dimension( bufSize), BaseGDL::NOZERO);

1142

1143

for( SizeT i=0; i<bufSize; ++i)

1144

(*retVal)[ i] = buf[ i];

1145

1146

return retVal;

1147

}

1148

else

1149

return new DStringGDL( buf[0]);

1150

}

1151

else

1152

{

1153

if( nParam == 1) // nParam == 1 -> conversion

1154

{

1155

BaseGDL* p0 = e->GetParDefined( 0);

1156

// SA: see tracker item no. 3151760

1157

if (p0->Type() == STRING && e->GlobalPar(0)) return p0;

1158

return p0->Convert2( STRING, BaseGDL::COPY);

1159

}

1160

else // concatenation

1161

{

1162

DString s;

1163

for( SizeT i=0; i<nParam; ++i)

1164

{

1165

BaseGDL* p = e->GetParDefined( i);

1166

DStringGDL* sP = static_cast<DStringGDL*>

1167

( p->Convert2(STRING,

1168

BaseGDL::COPY_BYTE_AS_INT));

1169

1170

SizeT nEl = sP->N_Elements();

1171

for( SizeT e=0; e<nEl; ++e)

1172

s += (*sP)[ e];

1173

delete sP;

1174

}

1175

// IDL here breaks the string into tty-width substrings

1176

return new DStringGDL( s);

1177

}

1178

}

1179

}

1180

1181

BaseGDL* fix_fun( EnvT* e)

1182

{

1183

DIntGDL* type = e->IfDefGetKWAs<DIntGDL>( 0);

1184

if (type != NULL) {

1185

int typ = (*type)[0];

1186

if (typ == BYTE)

1187

{

1188

// SA: slow yet simple solution using BYTE->INT->BYTE conversion

1189

return (e->KeywordSet(1) && e->GetPar(0)->Type() == STRING)

1190

? type_fun<DIntGDL>( e)->Convert2(BYTE, BaseGDL::CONVERT)

1191

: type_fun<DByteGDL>( e);

1192

}

1193

if (typ == 0 || typ == INT) return type_fun<DIntGDL>( e);

1194

if (typ == UINT) return type_fun<DUIntGDL>( e);

1195

if (typ == LONG) return type_fun<DLongGDL>( e);

1196

if (typ == ULONG) return type_fun<DULongGDL>( e);

1197

if (typ == LONG64) return type_fun<DLong64GDL>( e);

1198

if (typ == ULONG64) return type_fun<DULong64GDL>( e);

1199

if (typ == FLOAT) return type_fun<DFloatGDL>( e);

1200

if (typ == DOUBLE) return type_fun<DDoubleGDL>( e);

1201

if (typ == COMPLEX) return type_fun<DComplexGDL>( e);

1202

if (typ == COMPLEXDBL) return type_fun<DComplexDblGDL>( e);

1203

if (typ == STRING)

1204

{

1205

// SA: calling STRING() with correct parameters

1206

static int stringIx = LibFunIx("STRING");

1207

EnvT* newEnv= new EnvT(e, libFunList[stringIx], NULL);

1208

newEnv->SetNextPar(&e->GetPar(0)); // pass as global

1209

if (e->KeywordSet(1) && e->GetPar(0)->Type() == BYTE)

1210

newEnv->SetKeyword("PRINT", new DIntGDL(1));

1211

e->Interpreter()->CallStack().push_back( newEnv);

1212

return static_cast<DLibFun*>(newEnv->GetPro())->Fun()(newEnv);

1213

}

1214

e->Throw( "Improper TYPE value.");

1215

}

1216

return type_fun<DIntGDL>( e);

1217

}

1218

1219

BaseGDL* call_function( EnvT* e)

1220

{

1221

StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());

1222

1223

int nParam=e->NParam();

1224

if( nParam == 0)

1225

e->Throw( "No function specified.");

1226

1227

DString callF;

1228

e->AssureScalarPar<DStringGDL>( 0, callF);

1229

1230

// this is a function name -> convert to UPPERCASE

1231

callF = StrUpCase( callF);

1232

1233

// first search library funcedures

1234

int funIx=LibFunIx( callF);

1235

if( funIx != -1)

1236

{

1237

e->PushNewEnv( libFunList[ funIx], 1);

1238

1239

// make the call

1240

EnvT* newEnv = static_cast<EnvT*>(e->Interpreter()->CallStack().back());

1241

return static_cast<DLibFun*>(newEnv->GetPro())->Fun()(newEnv);

1242

}

1243

else

1244

{

1245

funIx = GDLInterpreter::GetFunIx( callF);

1246

1247

e->PushNewEnvUD( funList[ funIx], 1);

1248

1249

// make the call

1250

EnvUDT* newEnv = static_cast<EnvUDT*>(e->Interpreter()->CallStack().back());

1251

return e->Interpreter()->

1252

call_fun(static_cast<DSubUD*>(newEnv->GetPro())->GetTree());

1253

}

1254

}

1255

1256

BaseGDL* call_method_function( EnvT* e)

1257

{

1258

StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());

1259

1260

int nParam=e->NParam();

1261

if( nParam < 2)

1262

e->Throw( "Name and object reference"

1263

" must be specified.");

1264

1265

DString callP;

1266

e->AssureScalarPar<DStringGDL>( 0, callP);

1267

1268

// this is a procedure name -> convert to UPPERCASE

1269

callP = StrUpCase( callP);

1270

1271

DStructGDL* oStruct = e->GetObjectPar( 1);

1272

1273

DFun* method= oStruct->Desc()->GetFun( callP);

1274

1275

if( method == NULL)

1276

e->Throw( "Method not found: "+callP);

1277

1278

e->PushNewEnv( method, 2, &e->GetPar( 1));

1279

1280

// make the call

1281

return e->Interpreter()->call_fun( method->GetTree());

1282

}

1283

1284

1285

1286

BaseGDL* execute( EnvT* e)

1287

{

1288

int nParam=e->NParam( 1);

1289

1290

bool quietCompile = false;

1291

if( nParam == 2)

1292

{

1293

BaseGDL* p1 = e->GetParDefined( 1);

1294

1295

if( !p1->Scalar())

1296

e->Throw( "Expression must be scalar in this context: "+

1297

e->GetParString(1));

1298

1299

quietCompile = p1->True();

1300

}

1301

1302

if (e->GetParDefined(0)->Rank() != 0)

1303

e->Throw("Expression must be scalar in this context: "+e->GetParString(0));

1304

1305

DString line;

1306

e->AssureScalarPar<DStringGDL>( 0, line);

1307

1308

// remove current environment (own one)

1309

assert( dynamic_cast<EnvUDT*>(e->Caller()) != NULL);

1310

EnvUDT* caller = static_cast<EnvUDT*>(e->Caller());

1311

e->Interpreter()->CallStack().pop_back();

1312

delete e;

1313

1314

istringstream istr(line+"\n");

1315

1316

RefDNode theAST;

1317

try {

1318

GDLLexer lexer(istr, "", caller->CompileOpt());

1319

GDLParser& parser=lexer.Parser();

1320

1321

parser.interactive();

1322

1323

theAST=parser.getAST();

1324

}

1325

catch( GDLException& ex)

1326

{

1327

if( !quietCompile) GDLInterpreter::ReportCompileError( ex);

1328

return new DIntGDL( 0);

1329

}

1330

catch( ANTLRException ex)

1331

{

1332

if( !quietCompile) cerr << "EXECUTE: Lexer/Parser exception: " <<

1333

ex.getMessage() << endl;

1334

return new DIntGDL( 0);

1335

}

1336

1337

if( theAST == NULL) return new DIntGDL( 1);

1338

1339

RefDNode trAST;

1340

try

1341

{

1342

GDLTreeParser treeParser( caller);

1343

1344

treeParser.interactive(theAST);

1345

1346

trAST=treeParser.getAST();

1347

}

1348

catch( GDLException& ex)

1349

{

1350

if( !quietCompile) GDLInterpreter::ReportCompileError( ex);

1351

return new DIntGDL( 0);

1352

}

1353

1354

catch( ANTLRException ex)

1355

{

1356

if( !quietCompile) cerr << "EXECUTE: Compiler exception: " <<

1357

ex.getMessage() << endl;

1358

return new DIntGDL( 0);

1359

}

1360

1361

if( trAST == NULL) return new DIntGDL( 1);

1362

1363

int nForLoopsIn = caller->NForLoops();

1364

try

1365

{

1366

ProgNodeP progAST = ProgNode::NewProgNode( trAST);

1367

auto_ptr< ProgNode> progAST_guard( progAST);

1368

1369

int nForLoops = ProgNode::NumberForLoops( progAST, nForLoopsIn);

1370

caller->ResizeForLoops( nForLoops);

1371

1372

progAST->setLine( e->GetLineNumber());

1373

1374

RetCode retCode = caller->Interpreter()->execute( progAST);

1375

1376

caller->ResizeForLoops( nForLoopsIn);

1377

1378

if( retCode == RC_OK)

1379

return new DIntGDL( 1);

1380

else

1381

return new DIntGDL( 0);

1382

}

1383

catch( GDLException& ex)

1384

{

1385

caller->ResizeForLoops( nForLoopsIn);

1386

// are we throwing to target environment?

1387

// if( ex.GetTargetEnv() == NULL)

1388

if( !quietCompile) cerr << "EXECUTE: " <<

1389

ex.getMessage() << endl;

1390

return new DIntGDL( 0);

1391

}

1392

catch( ANTLRException ex)

1393

{

1394

caller->ResizeForLoops( nForLoopsIn);

1395

1396

if( !quietCompile) cerr << "EXECUTE: Interpreter exception: " <<

1397

ex.getMessage() << endl;

1398

return new DIntGDL( 0);

1399

}

1400

1401

return new DIntGDL( 0); // control flow cannot reach here - compiler shut up

1402

}

1403

1404

BaseGDL* assoc( EnvT* e)

1405

{

1406

SizeT nParam=e->NParam( 2);

1407

1408

DLong lun;

1409

e->AssureLongScalarPar( 0, lun);

1410

1411

bool stdLun = check_lun( e, lun);

1412

if( stdLun)

1413

e->Throw( "File unit does not allow"

1414

" this operation. Unit: "+i2s( lun));

1415

1416

DLong offset = 0;

1417

if( nParam >= 3) e->AssureLongScalarPar( 2, offset);

1418

1419

BaseGDL* arr = e->GetParDefined( 1);

1420

1421

if( arr->StrictScalar())

1422

e->Throw( "Scalar variable not allowed in this"

1423

" context: "+e->GetParString(1));

1424

1425

return arr->AssocVar( lun, offset);

1426

}

1427

1428

// gdl_ naming because of weired namespace problem in MSVC

1429

BaseGDL* gdl_logical_and( EnvT* e)

1430

{

1431

SizeT nParam=e->NParam();

1432

if( nParam != 2)

1433

e->Throw(

1434

"Incorrect number of arguments.");

1435

1436

BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_AND");

1437

BaseGDL* e2=e->GetParDefined( 1);//, "LOGICAL_AND");

1438

1439

ULong nEl1 = e1->N_Elements();

1440

ULong nEl2 = e2->N_Elements();

1441

1442

Data_<SpDByte>* res;

1443

1444

if( e1->Scalar())

1445

{

1446

if( e1->LogTrue(0))

1447

{

1448

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1449

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1450

{

1451

// #pragma omp for

1452

for( SizeT i=0; i < nEl2; i++)

1453

(*res)[i] = e2->LogTrue( i) ? 1 : 0;

1454

}

1455

}

1456

else

1457

{

1458

return new Data_<SpDByte>( e2->Dim());

1459

}

1460

}

1461

else if( e2->Scalar())

1462

{

1463

if( e2->LogTrue(0))

1464

{

1465

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1466

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1467

{

1468

// #pragma omp for

1469

for( SizeT i=0; i < nEl1; i++)

1470

(*res)[i] = e1->LogTrue( i) ? 1 : 0;

1471

}

1472

}

1473

else

1474

{

1475

return new Data_<SpDByte>( e1->Dim());

1476

}

1477

}

1478

else if( nEl2 < nEl1)

1479

{

1480

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1481

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1482

{

1483

// #pragma omp for

1484

for( SizeT i=0; i < nEl2; i++)

1485

(*res)[i] = (e1->LogTrue( i) && e2->LogTrue( i)) ? 1 : 0;

1486

}

1487

}

1488

else // ( nEl2 >= nEl1)

1489

{

1490

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1491

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1492

{

1493

// #pragma omp for

1494

for( SizeT i=0; i < nEl1; i++)

1495

(*res)[i] = (e1->LogTrue( i) && e2->LogTrue( i)) ? 1 : 0;

1496

}

1497

}

1498

return res;

1499

}

1500

1501

// gdl_ naming because of weired namespace problem in MSVC

1502

BaseGDL* gdl_logical_or( EnvT* e)

1503

{

1504

SizeT nParam=e->NParam();

1505

if( nParam != 2)

1506

e->Throw(

1507

"Incorrect number of arguments.");

1508

1509

BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_OR");

1510

BaseGDL* e2=e->GetParDefined( 1);//, "LOGICAL_OR");

1511

1512

ULong nEl1 = e1->N_Elements();

1513

ULong nEl2 = e2->N_Elements();

1514

1515

Data_<SpDByte>* res;

1516

1517

if( e1->Scalar())

1518

{

1519

if( e1->LogTrue(0))

1520

{

1521

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1522

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1523

{

1524

// #pragma omp for

1525

for( SizeT i=0; i < nEl2; i++)

1526

(*res)[i] = 1;

1527

}

1528

}

1529

else

1530

{

1531

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1532

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1533

{

1534

// #pragma omp for

1535

for( SizeT i=0; i < nEl2; i++)

1536

(*res)[i] = e2->LogTrue( i) ? 1 : 0;

1537

}

1538

}

1539

}

1540

else if( e2->Scalar())

1541

{

1542

if( e2->LogTrue(0))

1543

{

1544

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1545

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1546

{

1547

// #pragma omp for

1548

for( SizeT i=0; i < nEl1; i++)

1549

(*res)[i] = 1;

1550

}

1551

}

1552

else

1553

{

1554

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1555

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1556

{

1557

// #pragma omp for

1558

for( SizeT i=0; i < nEl1; i++)

1559

(*res)[i] = e1->LogTrue( i) ? 1 : 0;

1560

}

1561

}

1562

}

1563

else if( nEl2 < nEl1)

1564

{

1565

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1566

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1567

{

1568

// #pragma omp for

1569

for( SizeT i=0; i < nEl2; i++)

1570

(*res)[i] = (e1->LogTrue( i) || e2->LogTrue( i)) ? 1 : 0;

1571

}

1572

}

1573

else // ( nEl2 >= nEl1)

1574

{

1575

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1576

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1577

{

1578

// #pragma omp for

1579

for( SizeT i=0; i < nEl1; i++)

1580

(*res)[i] = (e1->LogTrue( i) || e2->LogTrue( i)) ? 1 : 0;

1581

}

1582

}

1583

return res;

1584

}

1585

1586

BaseGDL* logical_true( EnvT* e)

1587

{

1588

SizeT nParam=e->NParam();

1589

if( nParam != 1)

1590

e->Throw(

1591

"Incorrect number of arguments.");

1592

1593

BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_TRUE");

1594

1595

ULong nEl1 = e1->N_Elements();

1596

1597

Data_<SpDByte>* res = new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1598

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1599

{

1600

// #pragma omp for

1601

for( SizeT i=0; i < nEl1; i++)

1602

(*res)[i] = e1->LogTrue( i) ? 1 : 0;

1603

}

1604

return res;

1605

}

1606

1607

BaseGDL* replicate( EnvT* e)

1608

{

1609

SizeT nParam=e->NParam();

1610

if( nParam < 2)

1611

e->Throw( "Incorrect number of arguments.");

1612

dimension dim;

1613

arr( e, dim, 1);

1614

1615

BaseGDL* p0=e->GetParDefined( 0);//, "REPLICATE");

1616

if( !p0->Scalar())

1617

e->Throw( "Expression must be a scalar in this context: "+

1618

e->GetParString(0));

1619

1620

return p0->New( dim, BaseGDL::INIT);

1621

}

1622

1623

BaseGDL* strtrim( EnvT* e)

1624

{

1625

SizeT nParam = e->NParam( 1);//, "STRTRIM");

1626

1627

BaseGDL* p0 = e->GetPar( 0);

1628

if( p0 == NULL)

1629

e->Throw(

1630

"Variable is undefined: "+

1631

e->GetParString(0));

1632

DStringGDL* p0S = static_cast<DStringGDL*>

1633

(p0->Convert2(STRING,BaseGDL::COPY));

1634

1635

DLong mode = 0;

1636

if( nParam == 2)

1637

{

1638

BaseGDL* p1 = e->GetPar( 1);

1639

if( p1 == NULL)

1640

e->Throw(

1641

"Variable is undefined: "+e->GetParString(1));

1642

if( !p1->Scalar())

1643

e->Throw(

1644

"Expression must be a "

1645

"scalar in this context: "+

1646

e->GetParString(1));

1647

DLongGDL* p1L = static_cast<DLongGDL*>

1648

(p1->Convert2(LONG,BaseGDL::COPY));

1649

1650

mode = (*p1L)[ 0];

1651

1652

delete p1L;

1653

1654

if( mode < 0 || mode > 2)

1655

{

1656

ostringstream os;

1657

p1->ToStream( os);

1658

e->Throw(

1659

"Value of <"+ p1->TypeStr() +

1660

" ("+os.str()+

1661

")> is out of allowed range.");

1662

}

1663

}

1664

1665

SizeT nEl = p0S->N_Elements();

1666

1667

if( mode == 2) // both

1668

{

1669

TRACEOMP( __FILE__, __LINE__)

1670

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1671

{

1672

#pragma omp for

1673

for( SizeT i=0; i<nEl; ++i)

1674

{

1675

unsigned long first= (*p0S)[ i].find_first_not_of(" \t");

1676

if( first == (*p0S)[ i].npos)

1677

{

1678

(*p0S)[ i] = "";

1679

}

1680

else

1681

{

1682

unsigned long last = (*p0S)[ i].find_last_not_of(" \t");

1683

(*p0S)[ i] = (*p0S)[ i].substr(first,last-first+1);

1684

}

1685

}

1686

}

1687

}

1688

else if( mode == 1) // leading

1689

{

1690

TRACEOMP( __FILE__, __LINE__)

1691

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1692

{

1693

#pragma omp for

1694

for( SizeT i=0; i<nEl; ++i)

1695

{

1696

unsigned long first= (*p0S)[ i].find_first_not_of(" \t");

1697

if( first == (*p0S)[ i].npos)

1698

{

1699

(*p0S)[ i] = "";

1700

}

1701

else

1702

{

1703

(*p0S)[ i] = (*p0S)[ i].substr(first);

1704

}

1705

}

1706

}

1707

}

1708

else // trailing

1709

{

1710

TRACEOMP( __FILE__, __LINE__)

1711

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1712

{

1713

#pragma omp for

1714

for( SizeT i=0; i<nEl; ++i)

1715

{

1716

unsigned long last = (*p0S)[ i].find_last_not_of(" \t");

1717

if( last == (*p0S)[ i].npos)

1718

{

1719

(*p0S)[ i] = "";

1720

}

1721

else

1722

{

1723

(*p0S)[ i] = (*p0S)[ i].substr(0,last+1);

1724

}

1725

}

1726

}

1727

}

1728

return p0S;

1729

}

1730

1731

BaseGDL* strcompress( EnvT* e)

1732

{

1733

e->NParam( 1);

1734

1735

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1736

1737

bool removeAll = e->KeywordSet(0);

1738

1739

DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

1740

1741

SizeT nEl = p0S->N_Elements();

1742

TRACEOMP( __FILE__, __LINE__)

1743

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1744

{

1745

#pragma omp for

1746

for( SizeT i=0; i<nEl; ++i)

1747

{

1748

(*res)[ i] = StrCompress((*p0S)[ i], removeAll);

1749

}

1750

}

1751

return res;

1752

}

1753

1754

BaseGDL* strpos( EnvT* e)

1755

{

1756

SizeT nParam = e->NParam( 2);//, "STRPOS");

1757

1758

bool reverseOffset = e->KeywordSet(0); // REVERSE_OFFSET

1759

bool reverseSearch = e->KeywordSet(1); // REVERSE_SEARCH

1760

1761

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1762

1763

DString searchString;

1764

// e->AssureScalarPar<DStringGDL>( 1, searchString);

1765

DStringGDL* sStr = e->GetParAs<DStringGDL>( 1);

1766

if( !sStr->Scalar( searchString))

1767

e->Throw( "Search string must be a scalar or one element array: "+

1768

e->GetParString( 1));

1769

1770

unsigned long pos = string::npos;

1771

if( nParam > 2)

1772

{

1773

BaseGDL* p2 = e->GetParDefined(2);

1774

// if( p2 != NULL) //e->AssureLongScalarPar( 2,posDLong);

1775

// {

1776

const SizeT pIx = 2;

1777

BaseGDL* p = e->GetParDefined( pIx);

1778

DLongGDL* lp = static_cast<DLongGDL*>(p->Convert2( LONG, BaseGDL::COPY));

1779

auto_ptr<DLongGDL> guard_lp( lp);

1780

DLong scalar;

1781

if( !lp->Scalar( scalar))

1782

throw GDLException("Parameter must be a scalar in this context: "+

1783

e->GetParString(pIx));

1784

pos = scalar;

1785

}

1786

1787

DLongGDL* res = new DLongGDL( p0S->Dim(), BaseGDL::NOZERO);

1788

1789

SizeT nSrcStr = p0S->N_Elements();

1790

TRACEOMP( __FILE__, __LINE__)

1791

#pragma omp parallel if ((nSrcStr*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nSrcStr*10)))

1792

{

1793

#pragma omp for

1794

for( long i=0; i<nSrcStr; ++i)

1795

{

1796

(*res)[ i] = StrPos((*p0S)[ i], searchString, pos,

1797

reverseOffset, reverseSearch);

1798

}

1799

}

1800

return res;

1801

}

1802

1803

BaseGDL* strmid( EnvT* e)

1804

{

1805

e->NParam( 2);//, "STRMID");

1806

1807

bool reverse = e->KeywordSet(0);

1808

1809

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1810

DLongGDL* p1L = e->GetParAs<DLongGDL>( 1);

1811

1812

BaseGDL* p2 = e->GetPar( 2);

1813

DLongGDL* p2L = NULL;

1814

if( p2 != NULL) p2L = e->GetParAs<DLongGDL>( 2);

1815

1816

DLong scVal1;

1817

bool sc1 = p1L->Scalar( scVal1);

1818

1819

DLong scVal2 = numeric_limits<DLong>::max();

1820

bool sc2 = true;

1821

if( p2L != NULL)

1822

{

1823

DLong scalar;

1824

sc2 = p2L->Scalar( scalar);

1825

scVal2 = scalar;

1826

}

1827

1828

DLong stride;

1829

if( !sc1 && !sc2)

1830

{

1831

stride = p1L->Dim( 0);

1832

if( stride != p2L->Dim( 0))

1833

e->Throw(

1834

"Starting offset and length arguments "

1835

"have incompatible first dimension.");

1836

}

1837

else

1838

{

1839

// at least one scalar, p2L possibly NULL

1840

if( p2L == NULL)

1841

stride = p1L->Dim( 0);

1842

else

1843

stride = max( p1L->Dim( 0), p2L->Dim( 0));

1844

1845

stride = (stride > 0)? stride : 1;

1846

}

1847

1848

dimension resDim( p0S->Dim());

1849

if( stride > 1)

1850

resDim >> stride;

1851

1852

DStringGDL* res = new DStringGDL( resDim, BaseGDL::NOZERO);

1853

1854

SizeT nEl1 = p1L->N_Elements();

1855

SizeT nEl2 = (sc2)? 1 : p2L->N_Elements();

1856

1857

SizeT nSrcStr = p0S->N_Elements();

1858

TRACEOMP( __FILE__, __LINE__)

1859

#pragma omp parallel if ((nSrcStr*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nSrcStr*10))) default( shared)

1860

{

1861

#pragma omp for

1862

for( long i=0; i<nSrcStr; ++i)

1863

{

1864

for( long ii=0; ii<stride; ++ii)

1865

{

1866

SizeT destIx = i * stride + ii;

1867

DLong actFirst = (sc1)? scVal1 : (*p1L)[ destIx % nEl1];

1868

DLong actLen = (sc2)? scVal2 : (*p2L)[ destIx % nEl2];

1869

if( actLen <= 0)

1870

(*res)[ destIx] = "";//StrMid((*p0S)[ i], actFirst, actLen, reverse);

1871

else

1872

(*res)[ destIx] = StrMid((*p0S)[ i], actFirst, actLen, reverse);

1873

}

1874

}

1875

}

1876

return res;

1877

}

1878

1879

BaseGDL* strlowcase( EnvT* e)

1880

{

1881

e->NParam( 1);//, "STRLOWCASE");

1882

1883

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1884

1885

DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

1886

1887

SizeT nEl = p0S->N_Elements();

1888

TRACEOMP( __FILE__, __LINE__)

1889

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1890

{

1891

#pragma omp for

1892

for( SizeT i=0; i<nEl; ++i)

1893

{

1894

(*res)[ i] = StrLowCase((*p0S)[ i]);

1895

}

1896

}

1897

return res;

1898

}

1899

1900

BaseGDL* strupcase( EnvT* e)

1901

{

1902

e->NParam( 1);//, "STRUPCASE");

1903

1904

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1905

1906

DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

1907

1908

SizeT nEl = p0S->N_Elements();

1909

TRACEOMP( __FILE__, __LINE__)

1910

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1911

{

1912

#pragma omp for

1913

for( SizeT i=0; i<nEl; ++i)

1914

{

1915

(*res)[ i] = StrUpCase((*p0S)[ i]);

1916

}

1917

}

1918

return res;

1919

}

1920

1921

BaseGDL* strlen( EnvT* e)

1922

{

1923

e->NParam( 1);//, "STRLEN");

1924

1925

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1926

1927

DLongGDL* res = new DLongGDL( p0S->Dim(), BaseGDL::NOZERO);

1928

1929

SizeT nEl = p0S->N_Elements();

1930

// #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))

1931

{

1932

// #pragma omp for

1933

for( SizeT i=0; i<nEl; ++i)

1934

{

1935

(*res)[ i] = (*p0S)[ i].length();

1936

}

1937

}

1938

return res;

1939

}

1940

1941

BaseGDL* strjoin( EnvT* e)

1942

{

1943

SizeT nParam = e->NParam( 1);

1944

1945

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1946

SizeT nEl = p0S->N_Elements();

1947

1948

DString delim = "";

1949

if( nParam > 1)

1950

e->AssureStringScalarPar( 1, delim);

1951

1952

bool single = e->KeywordSet( 0); // SINGLE

1953

1954

if( single)

1955

{

1956

DStringGDL* res = new DStringGDL( (*p0S)[0]);

1957

DString& scl = (*res)[0];

1958

1959

for( SizeT i=1; i<nEl; ++i)

1960

scl += delim + (*p0S)[i];

1961

1962

return res;

1963

}

1964

1965

dimension resDim( p0S->Dim());

1966

resDim.Purge();

1967

1968

SizeT stride = resDim.Stride( 1);

1969

1970

resDim.Remove( 0);

1971

1972

DStringGDL* res = new DStringGDL( resDim, BaseGDL::NOZERO);

1973

for( SizeT src=0, dst=0; src<nEl; ++dst)

1974

{

1975

(*res)[ dst] = (*p0S)[ src++];

1976

for(SizeT l=1; l<stride; ++l)

1977

(*res)[ dst] += delim + (*p0S)[ src++];

1978

}

1979

1980

return res;

1981

}

1982

1983

BaseGDL* where( EnvT* e)

1984

{

1985

SizeT nParam = e->NParam( 1);//, "WHERE");

1986

1987

BaseGDL* p0 = e->GetParDefined( 0);//, "WHERE");

1988

1989

SizeT nEl = p0->N_Elements();

1990

1991

SizeT count;

1992

1993

DLong* ixList = p0->Where( e->KeywordPresent( 0), count);

1994

ArrayGuard<DLong> guard( ixList);

1995

SizeT nCount = nEl - count;

1996

1997

if( e->KeywordPresent( 0)) // COMPLEMENT

1998

{

1999

if( nCount == 0)

2000

{

2001

e->SetKW( 0, new DLongGDL( -1));

2002

}

2003

else

2004

{

2005

DLongGDL* cIxList = new DLongGDL( dimension( &nCount, 1),

2006

BaseGDL::NOZERO);

2007

2008

SizeT cIx = nEl - 1;

2009

// #pragma omp parallel if (nCount >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nCount))

2010

{

2011

// #pragma omp for

2012

for( SizeT i=0; i<nCount; ++i)

2013

(*cIxList)[ i] = ixList[ cIx - i];

2014

// (*cIxList)[ i] = ixList[ --cIx];

2015

}

2016

e->SetKW( 0, cIxList);

2017

}

2018

}

2019

2020

if( e->KeywordPresent( 1)) // NCOMPLEMENT

2021

{

2022

e->SetKW( 1, new DLongGDL( nCount));

2023

}

2024

2025

if( nParam == 2)

2026

{

2027

e->SetPar( 1, new DLongGDL( count));

2028

}

2029

2030

if( count == 0) return new DLongGDL( -1);

2031

2032

return new DLongGDL( ixList, count);

2033

2034

// DLongGDL* res = new DLongGDL( dimension( &count, 1),

2035

// BaseGDL::NOZERO);

2036

// for( SizeT i=0; i<count; ++i)

2037

// (*res)[ i] = ixList[ i];

2038

2039

// return res;

2040

}

2041

2042

BaseGDL* n_params( EnvT* e)

2043

{

2044

EnvUDT* caller = static_cast<EnvUDT*>(e->Caller());

2045

if( caller == NULL) return new DLongGDL( 0);

2046

DLong nP = caller->NParam();

2047

if( caller->IsObject())

2048

return new DLongGDL( nP-1); // "self" is not counted

2049

return new DLongGDL( nP);

2050

}

2051

2052

BaseGDL* keyword_set( EnvT* e)

2053

{

2054

e->NParam( 1);//, "KEYWORD_SET");

2055

2056

BaseGDL* p0 = e->GetPar( 0);

2057

if( p0 == NULL) return new DIntGDL( 0);

2058

if( !p0->Scalar()) return new DIntGDL( 1);

2059

if( p0->Type() == STRUCT) return new DIntGDL( 1);

2060

if( p0->LogTrue()) return new DIntGDL( 1);

2061

return new DIntGDL( 0);

2062

}

2063

2064

// passing 2nd argument by value is slightly better for float and double,

2065

// but incur some overhead for the complex class.

2066

template<class T> inline void AddOmitNaN(T& dest, T value)

2067

{

2068

if (isfinite(value))

2069

{

2070

// #pragma omp atomic

2071

dest += value;

2072

}

2073

}

2074

template<class T> inline void AddOmitNaNCpx(T& dest, T value)

2075

{

2076

// #pragma omp atomic

2077

dest += T(isfinite(value.real())? value.real() : 0,

2078

isfinite(value.imag())? value.imag() : 0);

2079

}

2080

template<> inline void AddOmitNaN(DComplex& dest, DComplex value)

2081

{ AddOmitNaNCpx<DComplex>(dest, value); }

2082

template<> inline void AddOmitNaN(DComplexDbl& dest, DComplexDbl value)

2083

{ AddOmitNaNCpx<DComplexDbl>(dest, value); }

2084

2085

template<class T> inline void NaN2Zero(T& value)

2086

{ if (!isfinite(value)) value = 0; }

2087

template<class T> inline void NaN2ZeroCpx(T& value)

2088

{

2089

value = T(isfinite(value.real())? value.real() : 0,

2090

isfinite(value.imag())? value.imag() : 0);

2091

}

2092

template<> inline void NaN2Zero(DComplex& value)

2093

{ NaN2ZeroCpx< DComplex>(value); }

2094

template<> inline void NaN2Zero(DComplexDbl& value)

2095

{ NaN2ZeroCpx< DComplexDbl>(value); }

2096

2097

// total over all elements

2098

template<class T>

2099

BaseGDL* total_template( T* src, bool omitNaN)

2100

{

2101

if (!omitNaN) return new T(src->Sum());

2102

typename T::Ty sum = 0;

2103

SizeT nEl = src->N_Elements();

2104

TRACEOMP( __FILE__, __LINE__)

2105

#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(sum)

2106

{

2107

#pragma omp for

2108

for ( SizeT i=0; i<nEl; ++i)

2109

{

2110

AddOmitNaN(sum, (*src)[ i]);

2111

}

2112

}

2113

return new T(sum);

2114

}

2115

2116

// cumulative over all dims

2117

template<typename T>

2118

BaseGDL* total_cu_template( T* res, bool omitNaN)

2119

{

2120

SizeT nEl = res->N_Elements();

2121

if (omitNaN)

2122

{

2123

// #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))

2124

{

2125

// #pragma omp for

2126

for( SizeT i=0; i<nEl; ++i)

2127

NaN2Zero((*res)[i]);

2128

}

2129

}

2130

for( SizeT i=1,ii=0; i<nEl; ++i,++ii)

2131

(*res)[i] += (*res)[ii];

2132

return res;

2133

}

2134

2135

// total over one dim

2136

template< typename T>

2137

BaseGDL* total_over_dim_template( T* src,

2138

const dimension& srcDim,

2139

SizeT sumDimIx,

2140

bool omitNaN)

2141

{

2142

SizeT nEl = src->N_Elements();

2143

2144

// get dest dim and number of summations

2145

dimension destDim = srcDim;

2146

SizeT nSum = destDim.Remove( sumDimIx);

2147

2148

T* res = new T( destDim); // zero fields

2149

2150

// sumStride is also the number of linear src indexing

2151

SizeT sumStride = srcDim.Stride( sumDimIx);

2152

SizeT outerStride = srcDim.Stride( sumDimIx + 1);

2153

SizeT sumLimit = nSum * sumStride;

2154

SizeT rIx=0;

2155

for( SizeT o=0; o < nEl; o += outerStride)

2156

for( SizeT i=0; i < sumStride; ++i)

2157

{

2158

SizeT oi = o+i;

2159

SizeT oiLimit = sumLimit + oi;

2160

if( omitNaN)

2161

{

2162

for( SizeT s=oi; s<oiLimit; s += sumStride)

2163

AddOmitNaN((*res)[ rIx], (*src)[ s]);

2164

}

2165

else

2166

{

2167

for( SizeT s=oi; s<oiLimit; s += sumStride)

2168

(*res)[ rIx] += (*src)[ s];

2169

}

2170

++rIx;

2171

}

2172

return res;

2173

}

2174

2175

// cumulative over one dim

2176

template< typename T>

2177

BaseGDL* total_over_dim_cu_template( T* res,

2178

SizeT sumDimIx,

2179

bool omitNaN)

2180

{

2181

SizeT nEl = res->N_Elements();

2182

const dimension& resDim = res->Dim();

2183

if (omitNaN)

2184

{

2185

for( SizeT i=0; i<nEl; ++i)

2186

NaN2Zero((*res)[i]);

2187

}

2188

SizeT cumStride = resDim.Stride( sumDimIx);

2189

SizeT outerStride = resDim.Stride( sumDimIx + 1);

2190

for( SizeT o=0; o < nEl; o += outerStride)

2191

{

2192

SizeT cumLimit = o+outerStride;

2193

for( SizeT i=o+cumStride, ii=o; i<cumLimit; ++i, ++ii)

2194

(*res)[ i] += (*res)[ ii];

2195

}

2196

return res;

2197

}

2198

2199

2200

BaseGDL* total( EnvT* e)

2201

{

2202

SizeT nParam = e->NParam( 1);//, "TOTAL");

2203

2204

BaseGDL* p0 = e->GetParDefined( 0);//, "TOTAL");

2205

2206

SizeT nEl = p0->N_Elements();

2207

if( nEl == 0)

2208

e->Throw( "Variable is undefined: "+e->GetParString(0));

2209

2210

if( p0->Type() == STRING)

2211

e->Throw( "String expression not allowed "

2212

"in this context: "+e->GetParString(0));

2213

2214

static int cumIx = e->KeywordIx( "CUMULATIVE");

2215

static int intIx = e->KeywordIx("INTEGER");

2216

static int doubleIx = e->KeywordIx( "DOUBLE");

2217

static int nanIx = e->KeywordIx( "NAN");

2218

static int preserveIx = e->KeywordIx( "PRESERVE_TYPE");

2219

2220

bool cumulative = e->KeywordSet( cumIx);

2221

bool intRes = e->KeywordSet( intIx);

2222

bool doubleRes = e->KeywordSet( doubleIx);

2223

bool nan = e->KeywordSet( nanIx);

2224

bool preserve = e->KeywordSet( preserveIx);

2225

2226

DLong sumDim = 0;

2227

if( nParam == 2)

2228

e->AssureLongScalarPar( 1, sumDim);

2229

2230

if( sumDim == 0)

2231

{

2232

if( !cumulative)

2233

{

2234

if (preserve)

2235

{

2236

switch (p0->Type())

2237

{

2238

case BYTE: return total_template<DByteGDL>(static_cast<DByteGDL*>(p0), false);

2239

case INT: return total_template<DIntGDL>(static_cast<DIntGDL*>(p0), false);

2240

case UINT: return total_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), false);

2241

case LONG: return total_template<DLongGDL>(static_cast<DLongGDL*>(p0), false);

2242

case ULONG: return total_template<DULongGDL>(static_cast<DULongGDL*>(p0), false);

2243

case LONG64: return total_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), false);

2244

case ULONG64: return total_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), false);

2245

case FLOAT: return total_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), nan);

2246

case DOUBLE: return total_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), nan);

2247

case COMPLEX: return total_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), nan);

2248

case COMPLEXDBL: return total_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), nan);

2249

default: assert(false);

2250

}

2251

}

2252

2253

// Integer parts by Erin Sheldon

2254

// In IDL total(), the INTEGER keyword takes precedence

2255

if( intRes )

2256

{

2257

// We use LONG64 unless the input is ULONG64

2258

if ( p0->Type() == LONG64 )

2259

{

2260

return total_template<DLong64GDL>

2261

( static_cast<DLong64GDL*>(p0), nan );

2262

}

2263

if ( p0->Type() == ULONG64 )

2264

{

2265

return total_template<DULong64GDL>

2266

( static_cast<DULong64GDL*>(p0), nan );

2267

}

2268

2269

// Conver to Long64

2270

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2271

(p0->Convert2( LONG64, BaseGDL::COPY));

2272

auto_ptr<DLong64GDL> guard( p0L64);

2273

return total_template<DLong64GDL>( p0L64, nan);

2274

2275

} // integer results

2276

2277

2278

if( p0->Type() == DOUBLE)

2279

{

2280

return total_template<DDoubleGDL>

2281

( static_cast<DDoubleGDL*>(p0), nan);

2282

}

2283

if( p0->Type() == COMPLEXDBL)

2284

{

2285

return total_template<DComplexDblGDL>

2286

( static_cast<DComplexDblGDL*>(p0), nan);

2287

}

2288

2289

if( !doubleRes)

2290

{

2291

if( p0->Type() == FLOAT)

2292

{

2293

return total_template<DFloatGDL>

2294

( static_cast<DFloatGDL*>(p0), nan);

2295

}

2296

if( p0->Type() == COMPLEX)

2297

{

2298

return total_template<DComplexGDL>

2299

( static_cast<DComplexGDL*>(p0), nan);

2300

}

2301

DFloatGDL* p0F = static_cast<DFloatGDL*>

2302

(p0->Convert2( FLOAT,BaseGDL::COPY));

2303

auto_ptr<DFloatGDL> guard( p0F);

2304

return total_template<DFloatGDL>( p0F, false);

2305

}

2306

if( p0->Type() == COMPLEX)

2307

{

2308

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

2309

(p0->Convert2( COMPLEXDBL,BaseGDL::COPY));

2310

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

2311

return total_template<DComplexDblGDL>( p0D, nan);

2312

}

2313

2314

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

2315

(p0->Convert2( DOUBLE, BaseGDL::COPY));

2316

auto_ptr<DDoubleGDL> p0D_guard( p0D);

2317

return total_template<DDoubleGDL>( p0D, nan);

2318

}

2319

else // cumulative

2320

{

2321

if (preserve)

2322

{

2323

switch (p0->Type())

2324

{

2325

case BYTE: return total_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), false);

2326

case INT: return total_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), false);

2327

case UINT: return total_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), false);

2328

case LONG: return total_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), false);

2329

case ULONG: return total_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), false);

2330

case LONG64: return total_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), false);

2331

case ULONG64: return total_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), false);

2332

case FLOAT: return total_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), nan);

2333

case DOUBLE: return total_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), nan);

2334

case COMPLEX: return total_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), nan);

2335

case COMPLEXDBL: return total_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), nan);

2336

default: assert(false);

2337

}

2338

}

2339

2340

// INTEGER keyword takes precedence

2341

if( intRes )

2342

{

2343

// We use LONG64 unless the input is ULONG64

2344

if ( p0->Type() == LONG64 )

2345

{

2346

return total_cu_template<DLong64GDL>

2347

( static_cast<DLong64GDL*>(p0)->Dup(), nan );

2348

}

2349

if ( p0->Type() == ULONG64 )

2350

{

2351

return total_cu_template<DULong64GDL>

2352

( static_cast<DULong64GDL*>(p0)->Dup(), nan );

2353

}

2354

2355

// Convert to Long64

2356

return total_cu_template<DLong64GDL>

2357

( static_cast<DLong64GDL*>

2358

(p0->Convert2( LONG64, BaseGDL::COPY)), nan);

2359

2360

} // integer results

2361

2362

2363

// special case as DOUBLE type overrides /DOUBLE

2364

if( p0->Type() == DOUBLE)

2365

{

2366

return total_cu_template< DDoubleGDL>

2367

( static_cast<DDoubleGDL*>(p0)->Dup(), nan);

2368

}

2369

if( p0->Type() == COMPLEXDBL)

2370

{

2371

return total_cu_template< DComplexDblGDL>

2372

( static_cast<DComplexDblGDL*>(p0)->Dup(), nan);

2373

}

2374

2375

2376

2377

if( !doubleRes)

2378

{

2379

// special case for FLOAT has no advantage here

2380

if( p0->Type() == COMPLEX)

2381

{

2382

return total_cu_template< DComplexGDL>

2383

( static_cast<DComplexGDL*>(p0)->Dup(), nan);

2384

}

2385

return total_cu_template< DFloatGDL>

2386

( static_cast<DFloatGDL*>( p0->Convert2(FLOAT,

2387

BaseGDL::COPY)), nan);

2388

}

2389

if( p0->Type() == COMPLEX)

2390

{

2391

return total_cu_template< DComplexDblGDL>

2392

( static_cast<DComplexDblGDL*>(p0->Convert2( COMPLEXDBL,

2393

BaseGDL::COPY)), nan);

2394

}

2395

return total_cu_template< DDoubleGDL>

2396

( static_cast<DDoubleGDL*>(p0->Convert2( DOUBLE,

2397

BaseGDL::COPY)), nan);

2398

}

2399

}

2400

2401

// total over sumDim

2402

dimension srcDim = p0->Dim();

2403

SizeT srcRank = srcDim.Rank();

2404

2405

if( sumDim < 1 || sumDim > srcRank)

2406

e->Throw(

2407

"Array must have "+i2s(sumDim)+

2408

" dimensions: "+e->GetParString(0));

2409

2410

if( !cumulative)

2411

{

2412

if (preserve)

2413

{

2414

switch (p0->Type())

2415

{

2416

case BYTE: return total_over_dim_template<DByteGDL>(static_cast<DByteGDL*>(p0), srcDim, sumDim-1, false);

2417

case INT: return total_over_dim_template<DIntGDL>(static_cast<DIntGDL*>(p0), srcDim, sumDim-1, false);

2418

case UINT: return total_over_dim_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), srcDim, sumDim-1, false);

2419

case LONG: return total_over_dim_template<DLongGDL>(static_cast<DLongGDL*>(p0), srcDim, sumDim-1, false);

2420

case ULONG: return total_over_dim_template<DULongGDL>(static_cast<DULongGDL*>(p0), srcDim, sumDim-1, false);

2421

case LONG64: return total_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, false);

2422

case ULONG64: return total_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, false);

2423

case FLOAT: return total_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), srcDim, sumDim-1, nan);

2424

case DOUBLE: return total_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, nan);

2425

case COMPLEX: return total_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), srcDim, sumDim-1, nan);

2426

case COMPLEXDBL: return total_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, nan);

2427

default: assert(false);

2428

}

2429

}

2430

2431

// INTEGER keyword takes precedence

2432

if( intRes )

2433

{

2434

// We use LONG64 unless the input is ULONG64

2435

if ( p0->Type() == LONG64 )

2436

{

2437

return total_over_dim_template<DLong64GDL>

2438

( static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, nan );

2439

}

2440

if ( p0->Type() == ULONG64 )

2441

{

2442

return total_over_dim_template<DULong64GDL>

2443

( static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, nan );

2444

}

2445

2446

// Conver to Long64

2447

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2448

(p0->Convert2( LONG64, BaseGDL::COPY));

2449

2450

auto_ptr<DLong64GDL> p0L64_guard( p0L64);

2451

return total_over_dim_template<DLong64GDL>

2452

( p0L64, srcDim, sumDim-1, nan);

2453

2454

} // integer results

2455

2456

2457

if( p0->Type() == DOUBLE)

2458

{

2459

return total_over_dim_template< DDoubleGDL>

2460

( static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, nan);

2461

}

2462

if( p0->Type() == COMPLEXDBL)

2463

{

2464

return total_over_dim_template< DComplexDblGDL>

2465

( static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, nan);

2466

}

2467

if( !doubleRes)

2468

{

2469

if( p0->Type() == FLOAT)

2470

{

2471

return total_over_dim_template< DFloatGDL>

2472

( static_cast<DFloatGDL*>(p0), srcDim, sumDim-1, nan);

2473

}

2474

if( p0->Type() == COMPLEX)

2475

{

2476

return total_over_dim_template< DComplexGDL>

2477

( static_cast<DComplexGDL*>(p0), srcDim, sumDim-1, nan);

2478

}

2479

// default for NOT /DOUBLE

2480

DFloatGDL* p0F = static_cast<DFloatGDL*>

2481

(p0->Convert2( FLOAT,BaseGDL::COPY));

2482

auto_ptr<DFloatGDL> p0F_guard( p0F);

2483

// p0F_guard.reset( p0F);

2484

return total_over_dim_template< DFloatGDL>

2485

( p0F, srcDim, sumDim-1, false);

2486

}

2487

if( p0->Type() == COMPLEX)

2488

{

2489

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

2490

(p0->Convert2( COMPLEXDBL,BaseGDL::COPY));

2491

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

2492

// p0D_guard.reset( p0D);

2493

return total_over_dim_template< DComplexDblGDL>

2494

( p0D, srcDim, sumDim-1, nan);

2495

}

2496

// default for /DOUBLE

2497

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

2498

(p0->Convert2( DOUBLE,BaseGDL::COPY));

2499

auto_ptr<DDoubleGDL> p0D_guard( p0D);

2500

//p0D_guard.reset( p0D);

2501

return total_over_dim_template< DDoubleGDL>( p0D, srcDim, sumDim-1,nan);

2502

}

2503

else // cumulative

2504

{

2505

if (preserve)

2506

{

2507

switch (p0->Type())

2508

{

2509

case BYTE: return total_over_dim_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), sumDim-1, false);

2510

case INT: return total_over_dim_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), sumDim-1, false);

2511

case UINT: return total_over_dim_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), sumDim-1, false);

2512

case LONG: return total_over_dim_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), sumDim-1, false);

2513

case ULONG: return total_over_dim_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), sumDim-1, false);

2514

case LONG64: return total_over_dim_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, false);

2515

case ULONG64: return total_over_dim_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, false);

2516

case FLOAT: return total_over_dim_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), sumDim-1, nan);

2517

case DOUBLE: return total_over_dim_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, nan);

2518

case COMPLEX: return total_over_dim_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), sumDim-1, nan);

2519

case COMPLEXDBL: return total_over_dim_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, nan);

2520

default: assert(false);

2521

}

2522

}

2523

2524

// INTEGER keyword takes precedence

2525

if( intRes )

2526

{

2527

// We use LONG64 unless the input is ULONG64

2528

if ( p0->Type() == LONG64 )

2529

{

2530

return total_over_dim_cu_template<DLong64GDL>

2531

( static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, nan );

2532

}

2533

if ( p0->Type() == ULONG64 )

2534

{

2535

return total_over_dim_cu_template<DULong64GDL>

2536

( static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, nan );

2537

}

2538

2539

// Convert to Long64

2540

return total_over_dim_cu_template<DLong64GDL>

2541

( static_cast<DLong64GDL*>

2542

(p0->Convert2( LONG64, BaseGDL::COPY)), sumDim-1, nan);

2543

2544

} // integer results

2545

2546

2547

if( p0->Type() == DOUBLE)

2548

{

2549

return total_over_dim_cu_template< DDoubleGDL>

2550

( static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, nan);

2551

}

2552

if( p0->Type() == COMPLEXDBL)

2553

{

2554

return total_over_dim_cu_template< DComplexDblGDL>

2555

( static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, nan);

2556

}

2557

if( !doubleRes)

2558

{

2559

// special case for FLOAT has no advantage here

2560

if( p0->Type() == COMPLEX)

2561

{

2562

return total_over_dim_cu_template< DComplexGDL>

2563

( static_cast<DComplexGDL*>(p0)->Dup(), sumDim-1, nan);

2564

}

2565

// default for NOT /DOUBLE

2566

return total_over_dim_cu_template< DFloatGDL>

2567

( static_cast<DFloatGDL*>( p0->Convert2( FLOAT,

2568

BaseGDL::COPY)), sumDim-1, nan);

2569

}

2570

if( p0->Type() == COMPLEX)

2571

{

2572

return total_over_dim_cu_template< DComplexDblGDL>

2573

( static_cast<DComplexDblGDL*>(p0->Convert2( COMPLEXDBL,

2574

BaseGDL::COPY)), sumDim-1, nan);

2575

}

2576

// default for /DOUBLE

2577

return total_over_dim_cu_template< DDoubleGDL>

2578

( static_cast<DDoubleGDL*>(p0->Convert2( DOUBLE,

2579

BaseGDL::COPY)), sumDim-1, nan);

2580

}

2581

}

2582

2583

2584

// passing 2nd argument by value is slightly better for float and double,

2585

// but incur some overhead for the complex class.

2586

template<class T> inline void MultOmitNaN(T& dest, T value)

2587

{

2588

if (isfinite(value))

2589

{

2590

// #pragma omp atomic

2591

dest *= value;

2592

}

2593

}

2594

template<class T> inline void MultOmitNaNCpx(T& dest, T value)

2595

{

2596

dest *= T(isfinite(value.real())? value.real() : 1,

2597

isfinite(value.imag())? value.imag() : 1);

2598

}

2599

template<> inline void MultOmitNaN(DComplex& dest, DComplex value)

2600

{ MultOmitNaNCpx<DComplex>(dest, value); }

2601

template<> inline void MultOmitNaN(DComplexDbl& dest, DComplexDbl value)

2602

{ MultOmitNaNCpx<DComplexDbl>(dest, value); }

2603

2604

template<class T> inline void Nan2One(T& value)

2605

{ if (!isfinite(value)) value = 1; }

2606

template<class T> inline void Nan2OneCpx(T& value)

2607

{

2608

value = T(isfinite(value.real())? value.real() : 1,

2609

isfinite(value.imag())? value.imag() : 1);

2610

}

2611

template<> inline void Nan2One(DComplex& value)

2612

{ Nan2OneCpx< DComplex>(value); }

2613

template<> inline void Nan2One(DComplexDbl& value)

2614

{ Nan2OneCpx< DComplexDbl>(value); }

2615

2616

// product over all elements

2617

template<class T>

2618

BaseGDL* product_template( T* src, bool omitNaN)

2619

{

2620

typename T::Ty sum = 1;

2621

SizeT nEl = src->N_Elements();

2622

if( !omitNaN)

2623

{

2624

TRACEOMP( __FILE__, __LINE__)

2625

#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(sum)

2626

{

2627

#pragma omp for reduction(*:sum)

2628

for ( SizeT i=0; i<nEl; ++i)

2629

{

2630

sum *= (*src)[ i];

2631

}

2632

}

2633

}

2634

else

2635

{

2636

TRACEOMP( __FILE__, __LINE__)

2637

#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(sum)

2638

{

2639

#pragma omp for reduction(*:sum)

2640

for ( SizeT i=0; i<nEl; ++i)

2641

{

2642

MultOmitNaN( sum, (*src)[ i]);

2643

}

2644

}

2645

}

2646

return new T( sum);

2647

}

2648

2649

template<>

2650

BaseGDL* product_template( DComplexGDL* src, bool omitNaN)

2651

{

2652

DComplexGDL::Ty sum = 1;

2653

SizeT nEl = src->N_Elements();

2654

if( !omitNaN)

2655

{

2656

for ( SizeT i=0; i<nEl; ++i)

2657

{

2658

sum *= (*src)[ i];

2659

}

2660

}

2661

else

2662

{

2663

for ( SizeT i=0; i<nEl; ++i)

2664

{

2665

MultOmitNaN( sum, (*src)[ i]);

2666

}

2667

}

2668

return new DComplexGDL( sum);

2669

}

2670

2671

template<>

2672

BaseGDL* product_template( DComplexDblGDL* src, bool omitNaN)

2673

{

2674

DComplexDblGDL::Ty sum = 1;

2675

SizeT nEl = src->N_Elements();

2676

if( !omitNaN)

2677

{

2678

for ( SizeT i=0; i<nEl; ++i)

2679

{

2680

sum *= (*src)[ i];

2681

}

2682

}

2683

else

2684

{

2685

for ( SizeT i=0; i<nEl; ++i)

2686

{

2687

MultOmitNaN( sum, (*src)[ i]);

2688

}

2689

}

2690

return new DComplexDblGDL( sum);

2691

}

2692

2693

// cumulative over all dims

2694

template<typename T>

2695

BaseGDL* product_cu_template( T* res, bool omitNaN)

2696

{

2697

SizeT nEl = res->N_Elements();

2698

if( omitNaN)

2699

{

2700

for( SizeT i=0; i<nEl; ++i)

2701

Nan2One( (*res)[i]);

2702

}

2703

for( SizeT i=1,ii=0; i<nEl; ++i,++ii)

2704

(*res)[i] *= (*res)[ii];

2705

return res;

2706

}

2707

2708

// product over one dim

2709

template< typename T>

2710

BaseGDL* product_over_dim_template( T* src,

2711

const dimension& srcDim,

2712

SizeT sumDimIx,

2713

bool omitNaN)

2714

{

2715

SizeT nEl = src->N_Elements();

2716

2717

// get dest dim and number of summations

2718

dimension destDim = srcDim;

2719

SizeT nSum = destDim.Remove( sumDimIx);

2720

2721

T* res = new T( destDim, BaseGDL::NOZERO);

2722

2723

// sumStride is also the number of linear src indexing

2724

SizeT sumStride = srcDim.Stride( sumDimIx);

2725

SizeT outerStride = srcDim.Stride( sumDimIx + 1);

2726

SizeT sumLimit = nSum * sumStride;

2727

SizeT rIx=0;

2728

for( SizeT o=0; o < nEl; o += outerStride)

2729

for( SizeT i=0; i < sumStride; ++i)

2730

{

2731

(*res)[ rIx] = 1;

2732

SizeT oi = o+i;

2733

SizeT oiLimit = sumLimit + oi;

2734

if( omitNaN)

2735

{

2736

for( SizeT s=oi; s<oiLimit; s += sumStride)

2737

MultOmitNaN((*res)[ rIx], (*src)[ s]);

2738

}

2739

else

2740

{

2741

for( SizeT s=oi; s<oiLimit; s += sumStride)

2742

(*res)[ rIx] *= (*src)[ s];

2743

}

2744

++rIx;

2745

}

2746

return res;

2747

}

2748

2749

// cumulative over one dim

2750

template< typename T>

2751

BaseGDL* product_over_dim_cu_template( T* res,

2752

SizeT sumDimIx,

2753

bool omitNaN)

2754

{

2755

SizeT nEl = res->N_Elements();

2756

const dimension& resDim = res->Dim();

2757

if (omitNaN)

2758

{

2759

for( SizeT i=0; i<nEl; ++i)

2760

Nan2One((*res)[i]);

2761

}

2762

SizeT cumStride = resDim.Stride( sumDimIx);

2763

SizeT outerStride = resDim.Stride( sumDimIx + 1);

2764

for( SizeT o=0; o < nEl; o += outerStride)

2765

{

2766

SizeT cumLimit = o+outerStride;

2767

for( SizeT i=o+cumStride, ii=o; i<cumLimit; ++i, ++ii)

2768

(*res)[ i] *= (*res)[ ii];

2769

}

2770

return res;

2771

}

2772

2773

BaseGDL* product( EnvT* e)

2774

{

2775

SizeT nParam = e->NParam( 1);

2776

2777

BaseGDL* p0 = e->GetParDefined( 0);

2778

2779

SizeT nEl = p0->N_Elements();

2780

if( nEl == 0)

2781

e->Throw( "Variable is undefined: "+e->GetParString(0));

2782

2783

if( p0->Type() == STRING)

2784

e->Throw( "String expression not allowed "

2785

"in this context: "+e->GetParString(0));

2786

2787

static int cumIx = e->KeywordIx( "CUMULATIVE");

2788

static int nanIx = e->KeywordIx( "NAN");

2789

static int intIx = e->KeywordIx("INTEGER");

2790

static int preIx = e->KeywordIx("PRESERVE_TYPE");

2791

bool KwCumul = e->KeywordSet( cumIx);

2792

bool KwNaN = e->KeywordSet( nanIx);

2793

bool KwInt = e->KeywordSet( intIx);

2794

bool KwPre = e->KeywordSet( preIx);

2795

bool nanInt=false;

2796

2797

DLong sumDim = 0;

2798

if( nParam == 2)

2799

e->AssureLongScalarPar( 1, sumDim);

2800

2801

if( sumDim == 0) {

2802

if( !KwCumul) {

2803

if (KwPre)

2804

{

2805

switch (p0->Type())

2806

{

2807

case BYTE: return product_template<DByteGDL>(static_cast<DByteGDL*>(p0), nanInt);

2808

case INT: return product_template<DIntGDL>(static_cast<DIntGDL*>(p0), nanInt);

2809

case UINT: return product_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), nanInt);

2810

case LONG: return product_template<DLongGDL>(static_cast<DLongGDL*>(p0), nanInt);

2811

case ULONG: return product_template<DULongGDL>(static_cast<DULongGDL*>(p0), nanInt);

2812

case LONG64: return product_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), nanInt);

2813

case ULONG64: return product_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), nanInt);

2814

case FLOAT: return product_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), KwNaN);

2815

case DOUBLE: return product_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), KwNaN);

2816

case COMPLEX: return product_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), KwNaN);

2817

case COMPLEXDBL: return product_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), KwNaN);

2818

default: assert(false);

2819

}

2820

}

2821

2822

// Integer parts derivated from Total code by Erin Sheldon

2823

// In IDL PRODUCT(), the INTEGER keyword takes precedence

2824

if (KwInt) {

2825

// We use LONG64 unless the input is ULONG64

2826

if ((p0->Type() == LONG64) && (!KwNaN)) {

2827

return product_template<DLong64GDL>

2828

( static_cast<DLong64GDL*>(p0), nanInt );

2829

}

2830

if ((p0->Type() == ULONG64) && (!KwNaN)) {

2831

return product_template<DULong64GDL>

2832

(static_cast<DULong64GDL*>(p0), nanInt );

2833

}

2834

2835

// Convert to Long64

2836

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2837

(p0->Convert2( LONG64, BaseGDL::COPY));

2838

auto_ptr<DLong64GDL> guard( p0L64);

2839

if (KwNaN) {

2840

DFloatGDL* p0f = static_cast<DFloatGDL*>

2841

(p0->Convert2( FLOAT, BaseGDL::COPY));

2842

auto_ptr<DFloatGDL> guard( p0f);

2843

for( SizeT i=0; i<nEl; ++i) {

2844

if (!isfinite((*p0f)[i])) (*p0L64)[i]=1;

2845

}

2846

}

2847

return product_template<DLong64GDL>( p0L64, nanInt);

2848

} // integer results

2849

2850

if( p0->Type() == DOUBLE) {

2851

return product_template<DDoubleGDL>

2852

( static_cast<DDoubleGDL*>(p0), KwNaN);

2853

}

2854

if( p0->Type() == COMPLEXDBL) {

2855

return product_template<DComplexDblGDL>

2856

( static_cast<DComplexDblGDL*>(p0), KwNaN);

2857

}

2858

if( p0->Type() == COMPLEX) {

2859

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

2860

(p0->Convert2( COMPLEXDBL,BaseGDL::COPY));

2861

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

2862

//p0D_guard.reset( p0D);

2863

return product_template<DComplexDblGDL>( p0D, KwNaN);

2864

}

2865

2866

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

2867

(p0->Convert2( DOUBLE, BaseGDL::COPY));

2868

auto_ptr<DDoubleGDL> p0D_guard( p0D);

2869

// p0D_guard.reset( p0D);

2870

return product_template<DDoubleGDL>( p0D, KwNaN);

2871

}

2872

else

2873

{ // KwCumul

2874

2875

if (KwPre)

2876

{

2877

switch (p0->Type())

2878

{

2879

case BYTE: return product_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), nanInt);

2880

case INT: return product_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), nanInt);

2881

case UINT: return product_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), nanInt);

2882

case LONG: return product_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), nanInt);

2883

case ULONG: return product_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), nanInt);

2884

case LONG64: return product_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), nanInt);

2885

case ULONG64: return product_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), nanInt);

2886

case FLOAT: return product_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), KwNaN);

2887

case DOUBLE: return product_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), KwNaN);

2888

case COMPLEX: return product_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), KwNaN);

2889

case COMPLEXDBL: return product_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), KwNaN);

2890

default: assert(false);

2891

}

2892

}

2893

2894

// Integer parts derivated from Total code by Erin Sheldon

2895

// In IDL PRODUCT(), the INTEGER keyword takes precedence

2896

if (KwInt) {

2897

// We use LONG64 unless the input is ULONG64

2898

if ((p0->Type() == LONG64) && (!KwNaN)) {

2899

return product_cu_template<DLong64GDL>

2900

( static_cast<DLong64GDL*>(p0)->Dup(), nanInt);

2901

}

2902

if ((p0->Type() == ULONG64) && (!KwNaN)) {

2903

return product_cu_template<DULong64GDL>

2904

( static_cast<DULong64GDL*>(p0)->Dup(), nanInt);

2905

}

2906

// Convert to Long64

2907

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2908

(p0->Convert2( LONG64, BaseGDL::COPY));

2909

auto_ptr<DLong64GDL> guard( p0L64);

2910

if (KwNaN) {

2911

DFloatGDL* p0f = static_cast<DFloatGDL*>

2912

(p0->Convert2( FLOAT, BaseGDL::COPY));

2913

auto_ptr<DFloatGDL> guard( p0f);

2914

for( SizeT i=0; i<nEl; ++i) {

2915

if (!isfinite((*p0f)[i])) (*p0L64)[i]=1;

2916

}

2917

}

2918

return product_cu_template<DLong64GDL>

2919

((p0L64)->Dup(), nanInt);

2920

} // integer results

2921

2922

// special case as DOUBLE type overrides /DOUBLE

2923

if (p0->Type() == DOUBLE) {

2924

return product_cu_template< DDoubleGDL>

2925

( static_cast<DDoubleGDL*>(p0)->Dup(), KwNaN);

2926

}

2927

if (p0->Type() == COMPLEXDBL) {

2928

return product_cu_template< DComplexDblGDL>

2929

( static_cast<DComplexDblGDL*>(p0)->Dup(), KwNaN);

2930

}

2931

if (p0->Type() == COMPLEX) {

2932

return product_cu_template< DComplexDblGDL>

2933

( static_cast<DComplexDblGDL*>

2934

(p0->Convert2( COMPLEXDBL, BaseGDL::COPY)), KwNaN);

2935

}

2936

return product_cu_template< DDoubleGDL>

2937

( static_cast<DDoubleGDL*>

2938

(p0->Convert2( DOUBLE, BaseGDL::COPY)), KwNaN);

2939

}

2940

}

2941

2942

// product over sumDim

2943

dimension srcDim = p0->Dim();

2944

SizeT srcRank = srcDim.Rank();

2945

2946

if( sumDim < 1 || sumDim > srcRank)

2947

e->Throw( "Array must have "+i2s(sumDim)+

2948

" dimensions: "+e->GetParString(0));

2949

2950

if (!KwCumul) {

2951

2952

if (KwPre)

2953

{

2954

switch (p0->Type())

2955

{

2956

case BYTE: return product_over_dim_template<DByteGDL>(static_cast<DByteGDL*>(p0), srcDim, sumDim-1, nanInt);

2957

case INT: return product_over_dim_template<DIntGDL>(static_cast<DIntGDL*>(p0), srcDim, sumDim-1, nanInt);

2958

case UINT: return product_over_dim_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), srcDim, sumDim-1, nanInt);

2959

case LONG: return product_over_dim_template<DLongGDL>(static_cast<DLongGDL*>(p0), srcDim, sumDim-1, nanInt);

2960

case ULONG: return product_over_dim_template<DULongGDL>(static_cast<DULongGDL*>(p0), srcDim, sumDim-1, nanInt);

2961

case LONG64: return product_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, nanInt);

2962

case ULONG64: return product_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, nanInt);

2963

case FLOAT: return product_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), srcDim, sumDim-1, KwNaN);

2964

case DOUBLE: return product_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, KwNaN);

2965

case COMPLEX: return product_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), srcDim, sumDim-1, KwNaN);

2966

case COMPLEXDBL: return product_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, KwNaN);

2967

default: assert(false);

2968

}

2969

}

2970

2971

// Integer parts derivated from Total code by Erin Sheldon

2972

// In IDL PRODUCT(), the INTEGER keyword takes precedence

2973

if (KwInt) {

2974

// We use LONG64 unless the input is ULONG64

2975

if ((p0->Type() == LONG64 ) && (!KwNaN)) {

2976

return product_over_dim_template<DLong64GDL>

2977

( static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, nanInt);

2978

}

2979

if ((p0->Type() == ULONG64) && (!KwNaN)) {

2980

return product_over_dim_template<DULong64GDL>

2981

( static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, nanInt);

2982

}

2983

2984

// Conver to Long64

2985

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2986

(p0->Convert2( LONG64, BaseGDL::COPY));

2987

auto_ptr<DLong64GDL> guard( p0L64);

2988

if (KwNaN) {

2989

DFloatGDL* p0f = static_cast<DFloatGDL*>

2990

(p0->Convert2( FLOAT, BaseGDL::COPY));

2991

auto_ptr<DFloatGDL> guard( p0f);

2992

for( SizeT i=0; i<nEl; ++i) {

2993

if (!isfinite((*p0f)[i])) (*p0L64)[i]=1;

2994

}

2995

}

2996

return product_over_dim_template<DLong64GDL>

2997

( p0L64, srcDim, sumDim-1, nanInt);

2998

} // integer results

2999

3000

if( p0->Type() == DOUBLE) {

3001

return product_over_dim_template< DDoubleGDL>

3002

( static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, KwNaN);

3003

}

3004

if( p0->Type() == COMPLEXDBL) {

3005

return product_over_dim_template< DComplexDblGDL>

3006

( static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, KwNaN);

3007

}

3008

if( p0->Type() == COMPLEX) {

3009

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

3010

(p0->Convert2( COMPLEXDBL,BaseGDL::COPY));

3011

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

3012

// p0D_guard.reset( p0D);

3013

return product_over_dim_template< DComplexDblGDL>

3014

( p0D, srcDim, sumDim-1, KwNaN);

3015

}

3016

3017

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

3018

(p0->Convert2( DOUBLE,BaseGDL::COPY));

3019

auto_ptr<DDoubleGDL> p0D_guard( p0D);

3020

//p0D_guard.reset( p0D);

3021

return product_over_dim_template< DDoubleGDL>

3022

( p0D, srcDim, sumDim-1,KwNaN);

3023

}

3024

else

3025

{ // KwCumul

3026

3027

if (KwPre)

3028

{

3029

switch (p0->Type())

3030

{

3031

case BYTE: return product_over_dim_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), sumDim-1, nanInt);

3032

case INT: return product_over_dim_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), sumDim-1, nanInt);

3033

case UINT: return product_over_dim_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), sumDim-1, nanInt);

3034

case LONG: return product_over_dim_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), sumDim-1, nanInt);

3035

case ULONG: return product_over_dim_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), sumDim-1, nanInt);

3036

case LONG64: return product_over_dim_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3037

case ULONG64: return product_over_dim_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3038

case FLOAT: return product_over_dim_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3039

case DOUBLE: return product_over_dim_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3040

case COMPLEX: return product_over_dim_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3041

case COMPLEXDBL: return product_over_dim_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3042

default: assert(false);

3043

}

3044

}

3045

3046

// Integer parts derivated from Total code by Erin Sheldon

3047

// In IDL PRODUCT(), the INTEGER keyword takes precedence

3048

if (KwInt) {

3049

// We use LONG64 unless the input is ULONG64

3050

if ((p0->Type() == LONG64) && (!KwNaN)) {

3051

return product_over_dim_cu_template<DLong64GDL>

3052

( static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3053

}

3054

if ((p0->Type() == ULONG64 ) && (!KwNaN)) {

3055

return product_over_dim_cu_template<DULong64GDL>

3056

( static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3057

}

3058

3059

// Convert to Long64

3060

if (KwNaN) {

3061

DFloatGDL* p0f = static_cast<DFloatGDL*>

3062

(p0->Convert2( FLOAT, BaseGDL::COPY));

3063

auto_ptr<DFloatGDL> guard( p0f);

3064

for( SizeT i=0; i<nEl; ++i) {

3065

if (!isfinite((*p0f)[i])) (*p0f)[i]=1;

3066

}

3067

return product_over_dim_cu_template<DLong64GDL>

3068

( static_cast<DLong64GDL*>

3069

(p0f->Convert2( LONG64, BaseGDL::COPY)), sumDim-1, nanInt);

3070

} else {

3071

return product_over_dim_cu_template<DLong64GDL>

3072

( static_cast<DLong64GDL*>

3073

(p0->Convert2( LONG64, BaseGDL::COPY)), sumDim-1, nanInt);

3074

}

3075

} // integer results

3076

3077

if( p0->Type() == DOUBLE) {

3078

return product_over_dim_cu_template< DDoubleGDL>

3079

( static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3080

}

3081

if( p0->Type() == COMPLEXDBL) {

3082

return product_over_dim_cu_template< DComplexDblGDL>

3083

( static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3084

}

3085

if( p0->Type() == COMPLEX) {

3086

return product_over_dim_cu_template< DComplexDblGDL>

3087

( static_cast<DComplexDblGDL*>

3088

(p0->Convert2( COMPLEXDBL, BaseGDL::COPY)), sumDim-1, KwNaN);

3089

}

3090

3091

return product_over_dim_cu_template< DDoubleGDL>

3092

( static_cast<DDoubleGDL*>

3093

(p0->Convert2( DOUBLE, BaseGDL::COPY)), sumDim-1, KwNaN);

3094

}

3095

}

3096

3097

BaseGDL* array_equal( EnvT* e)

3098

{

3099

e->NParam( 2);//, "ARRAY_EQUAL");

3100

3101

BaseGDL* p0 = e->GetParDefined( 0);//, "ARRAY_EQUAL");

3102

BaseGDL* p1 = e->GetParDefined( 1);//, "ARRAY_EQUAL");

3103

3104

if( p0 == p1) return new DByteGDL( 1);

3105

3106

SizeT nEl0 = p0->N_Elements();

3107

SizeT nEl1 = p1->N_Elements();

3108

if( nEl0 != nEl1 && nEl0 != 1 && nEl1 != 1)

3109

return new DByteGDL( 0);

3110

3111

auto_ptr<BaseGDL> p0_guard;

3112

auto_ptr<BaseGDL> p1_guard;

3113

if( p0->Type() != p1->Type())

3114

{

3115

if( e->KeywordSet( 0)) // NO_TYPECONV

3116

return new DByteGDL( 0);

3117

else

3118

{

3119

DType aTy=p0->Type();

3120

DType bTy=p1->Type();

3121

if( DTypeOrder[aTy] >= DTypeOrder[bTy])

3122

{

3123

p1 = p1->Convert2( aTy, BaseGDL::COPY);

3124

p1_guard.reset( p1);

3125

}

3126

else

3127

{

3128

p0 = p0->Convert2( bTy, BaseGDL::COPY);

3129

p0_guard.reset( p0);

3130

}

3131

}

3132

}

3133

3134

if( p0->ArrayEqual( p1)) return new DByteGDL( 1);

3135

3136

return new DByteGDL( 0);

3137

}

3138

3139

BaseGDL* min_fun( EnvT* e)

3140

{

3141

SizeT nParam = e->NParam( 1);

3142

BaseGDL* searchArr = e->GetParDefined( 0);

3143

3144

bool omitNaN = e->KeywordSet( "NAN");

3145

3146

static int subIx = e->KeywordIx("SUBSCRIPT_MAX");

3147

bool subMax = e->KeywordPresent(subIx);

3148

3149

static int dimIx = e->KeywordIx("DIMENSION");

3150

bool dimSet = e->KeywordSet(dimIx);

3151

3152

static int maxIx = e->KeywordIx("MAX");

3153

bool maxSet = e->KeywordPresent(maxIx);

3154

3155

DLong searchDim;

3156

if (dimSet) {

3157

e->AssureLongScalarKW(dimIx, searchDim);

3158

if (searchDim < 0 || searchDim > searchArr->Rank())

3159

e->Throw("Illegal keyword value for DIMENSION");

3160

}

3161

3162

if (dimSet && searchArr->Rank() > 1)

3163

{

3164

searchDim -= 1; // user-supplied dimensions start with 1!

3165

3166

// here destDim is in fact the srcDim...

3167

dimension destDim = searchArr->Dim();

3168

SizeT searchStride = destDim.Stride(searchDim);

3169

SizeT outerStride = destDim.Stride(searchDim + 1);

3170

// ... and now becomes the destDim

3171

SizeT nSearch = destDim.Remove(searchDim);

3172

SizeT searchLimit = nSearch * searchStride;

3173

SizeT nEl = searchArr->N_Elements();

3174

3175

// memory allocation

3176

BaseGDL *maxVal, *resArr = searchArr->New(destDim, BaseGDL::NOZERO);

3177

DLongGDL *minElArr, *maxElArr;

3178

3179

if (maxSet)

3180

{

3181

e->AssureGlobalKW(maxIx); // instead of using a guard pointer

3182

maxVal = searchArr->New(destDim, BaseGDL::NOZERO);

3183

}

3184

3185

if (subMax)

3186

{

3187

e->AssureGlobalKW(subIx); // instead of using a guard pointer

3188

maxElArr = new DLongGDL(destDim);

3189

}

3190

3191

if (nParam == 2)

3192

{

3193

e->AssureGlobalPar(1); // instead of using a guard pointer

3194

minElArr = new DLongGDL(destDim);

3195

}

3196

3197

SizeT rIx = 0;

3198

for (SizeT o = 0; o < nEl; o += outerStride) for (SizeT i = 0; i < searchStride; ++i)

3199

{

3200

searchArr->MinMax(

3201

(nParam == 2 ? &((*minElArr)[rIx]) : NULL),

3202

(subMax ? &((*maxElArr)[rIx]) : NULL),

3203

&resArr,

3204

(maxSet ? &maxVal : NULL),

3205

omitNaN, o + i, searchLimit + o + i, searchStride, rIx

3206

);

3207

rIx++;

3208

}

3209

3210

if (nParam == 2) e->SetPar(1, minElArr);

3211

if (subMax) e->SetKW(subIx, maxElArr);

3212

if (maxSet) e->SetKW(maxIx, maxVal);

3213

3214

return resArr;

3215

}

3216

else

3217

{

3218

DLong minEl;

3219

BaseGDL* res;

3220

3221

if (maxSet) // MAX keyword given

3222

{

3223

e->AssureGlobalKW( 0);

3224

delete e->GetKW( 0);

3225

DLong maxEl;

3226

searchArr->MinMax( &minEl, &maxEl, &res, &e->GetKW( 0), omitNaN);

3227

if (subMax) e->SetKW(subIx, new DLongGDL(maxEl));

3228

}

3229

else // no MAX keyword

3230

{

3231

if (subMax)

3232

{

3233

DLong maxEl;

3234

searchArr->MinMax( &minEl, &maxEl, &res, NULL, omitNaN);

3235

e->SetKW(subIx, new DLongGDL(maxEl));

3236

}

3237

else searchArr->MinMax(&minEl, NULL, &res, NULL, omitNaN);

3238

}

3239

3240

// handle index

3241

if (nParam == 2) e->SetPar(1, new DLongGDL( minEl));

3242

else SysVar::SetC( minEl);

3243

return res;

3244

}

3245

}

3246

3247

BaseGDL* max_fun( EnvT* e)

3248

{

3249

SizeT nParam = e->NParam( 1);

3250

BaseGDL* searchArr = e->GetParDefined( 0);

3251

3252

bool omitNaN = e->KeywordSet( "NAN");

3253

3254

static int subIx = e->KeywordIx("SUBSCRIPT_MIN");

3255

bool subMin = e->KeywordPresent(subIx);

3256

3257

static int dimIx = e->KeywordIx("DIMENSION");

3258

bool dimSet = e->KeywordSet(dimIx);

3259

3260

static int minIx = e->KeywordIx("MIN");

3261

bool minSet = e->KeywordPresent(minIx);

3262

3263

DLong searchDim;

3264

if (dimSet)

3265

{

3266

e->AssureLongScalarKW(dimIx, searchDim);

3267

if (searchDim < 0 || searchDim > searchArr->Rank())

3268

e->Throw("Illegal keyword value for DIMENSION");

3269

}

3270

3271

if (dimSet && searchArr->Rank() > 1)

3272

{

3273

searchDim -= 1; // user-supplied dimensions start with 1!

3274

3275

// here destDim is in fact the srcDim...

3276

dimension destDim = searchArr->Dim();

3277

SizeT searchStride = destDim.Stride(searchDim);

3278

SizeT outerStride = destDim.Stride(searchDim + 1);

3279

// ... and now becomes the destDim

3280

SizeT nSearch = destDim.Remove(searchDim);

3281

SizeT searchLimit = nSearch * searchStride;

3282

SizeT nEl = searchArr->N_Elements();

3283

3284

// memory allocation

3285

BaseGDL *minVal, *resArr = searchArr->New(destDim, BaseGDL::NOZERO);

3286

DLongGDL *minElArr, *maxElArr;

3287

3288

if (minSet)

3289

{

3290

e->AssureGlobalKW(minIx); // instead of using a guard pointer

3291

minVal = searchArr->New(destDim, BaseGDL::NOZERO);

3292

}

3293

3294

if (subMin)

3295

{

3296

e->AssureGlobalKW(subIx); // instead of using a guard pointer

3297

minElArr = new DLongGDL(destDim);

3298

}

3299

3300

if (nParam == 2)

3301

{

3302

e->AssureGlobalPar(1); // instead of using a guard pointer

3303

maxElArr = new DLongGDL(destDim);

3304

}

3305

3306

SizeT rIx = 0;

3307

for (SizeT o = 0; o < nEl; o += outerStride) for (SizeT i = 0; i < searchStride; ++i)

3308

{

3309

searchArr->MinMax(

3310

(subMin ? &((*minElArr)[rIx]) : NULL),

3311

(nParam == 2 ? &((*maxElArr)[rIx]) : NULL),

3312

(minSet ? &minVal : NULL),

3313

&resArr,

3314

omitNaN, o + i, searchLimit + o + i, searchStride, rIx

3315

);

3316

rIx++;

3317

}

3318

3319

if (nParam == 2) e->SetPar(1, maxElArr);

3320

if (subMin) e->SetKW(subIx, minElArr);

3321

if (minSet) e->SetKW(minIx, minVal);

3322

3323

return resArr;

3324

}

3325

else

3326

{

3327

DLong maxEl;

3328

BaseGDL* res;

3329

3330

if (minSet) // MIN keyword given

3331

{

3332

e->AssureGlobalKW( 0);

3333

delete e->GetKW( 0);

3334

DLong minEl;

3335

searchArr->MinMax( &minEl, &maxEl, &e->GetKW( 0), &res, omitNaN);

3336

if (subMin) e->SetKW(subIx, new DLongGDL(minEl));

3337

}

3338

else // no MIN keyword

3339

{

3340

if (subMin)

3341

{

3342

DLong minEl;

3343

searchArr->MinMax( &minEl, &maxEl, NULL, &res, omitNaN);

3344

e->SetKW(subIx, new DLongGDL(minEl));

3345

}

3346

else searchArr->MinMax(NULL, &maxEl, NULL, &res, omitNaN);

3347

}

3348

3349

// handle index

3350

if (nParam == 2) e->SetPar(1, new DLongGDL( maxEl));

3351

else SysVar::SetC(maxEl);

3352

return res;

3353

}

3354

}

3355

3356

BaseGDL* transpose( EnvT* e)

3357

{

3358

SizeT nParam=e->NParam( 1);

3359

3360

BaseGDL* p0 = e->GetParDefined( 0);

3361

if( p0->Type() == STRUCT)

3362

e->Throw("Struct expression not allowed in this context: "+

3363

e->GetParString(0));

3364

3365

SizeT rank = p0->Rank();

3366

if( rank == 0)

3367

e->Throw( "Expression must be an array "

3368

"in this context: "+ e->GetParString(0));

3369

3370

if( nParam == 2)

3371

{

3372

3373

BaseGDL* p1 = e->GetParDefined( 1);

3374

if( p1->N_Elements() != rank)

3375

e->Throw("Incorrect number of elements in permutation.");

3376

3377

DUInt* perm = new DUInt[rank];

3378

auto_ptr<DUInt> perm_guard( perm);

3379

3380

DUIntGDL* p1L = static_cast<DUIntGDL*>

3381

(p1->Convert2( UINT, BaseGDL::COPY));

3382

for( SizeT i=0; i<rank; ++i) perm[i] = (*p1L)[ i];

3383

delete p1L;

3384

3385

// check permutaion vector

3386

for( SizeT i=0; i<rank; ++i)

3387

{

3388

DUInt j;

3389

for( j=0; j<rank; ++j) if( perm[j] == i) break;

3390

if (j == rank)

3391

e->Throw( "Incorrect permutation vector.");

3392

}

3393

return p0->Transpose( perm);

3394

}

3395

3396

return p0->Transpose( NULL);

3397

}

3398

3399

3400

// BaseGDL* matrix_multiply( EnvT* e)

3401

// {

3402

// SizeT nParam=e->NParam( 2);

3403

//

3404

// BaseGDL* a = e->GetNumericArrayParDefined( 0);

3405

// BaseGDL* b = e->GetNumericArrayParDefined( 1);

3406

//

3407

// static int aTIx = e->KeywordIx("ATRANSPOSE");

3408

// bool aT = e->KeywordPresent(aTIx);

3409

// static int bTIx = e->KeywordIx("BTRANSPOSE");

3410

// bool bT = e->KeywordPresent(bTIx);

3411

//

3412

// static int strassenIx = e->KeywordIx("STRASSEN_ALGORITHM");

3413

// bool strassen = e->KeywordPresent(strassenIx);

3414

//

3415

//

3416

// if( p1->N_Elements() != rank)

3417

// e->Throw("Incorrect number of elements in permutation.");

3418

//

3419

// DUInt* perm = new DUInt[rank];

3420

// auto_ptr<DUInt> perm_guard( perm);

3421

//

3422

// DUIntGDL* p1L = static_cast<DUIntGDL*>

3423

// (p1->Convert2( UINT, BaseGDL::COPY));

3424

// for( SizeT i=0; i<rank; ++i) perm[i] = (*p1L)[ i];

3425

// delete p1L;

3426

//

3427

// // check permutaion vector

3428

// for( SizeT i=0; i<rank; ++i)

3429

// {

3430

// DUInt j;

3431

// for( j=0; j<rank; ++j) if( perm[j] == i) break;

3432

// if (j == rank)

3433

// e->Throw( "Incorrect permutation vector.");

3434

// }

3435

// return p0->Transpose( perm);

3436

// }

3437

//

3438

// return a->Transpose( NULL);

3439

// }

3440

3441

// helper function for sort_fun, recursive

3442

// optimized version

3443

template< typename IndexT>

3444

void MergeSortOpt( BaseGDL* p0, IndexT* hhS, IndexT* h1, IndexT* h2,

3445

SizeT len)

3446

{

3447

if( len <= 1) return;

3448

3449

SizeT h1N = len / 2;

3450

SizeT h2N = len - h1N;

3451

3452

// 1st half

3453

MergeSortOpt(p0, hhS, h1, h2, h1N);

3454

3455

// 2nd half

3456

IndexT* hhM = &hhS[h1N];

3457

MergeSortOpt(p0, hhM, h1, h2, h2N);

3458

3459

SizeT i;

3460

for(i=0; i<h1N; ++i) h1[i] = hhS[ i];

3461

for(i=0; i<h2N; ++i) h2[i] = hhM[ i];

3462

3463

SizeT h1Ix = 0;

3464

SizeT h2Ix = 0;

3465

for( i=0; (h1Ix < h1N) && (h2Ix < h2N); ++i)

3466

{

3467

// the actual comparisson

3468

if( p0->Greater( h1[h1Ix], h2[h2Ix]))

3469

hhS[ i] = h2[ h2Ix++];

3470

else

3471

hhS[ i] = h1[ h1Ix++];

3472

}

3473

for(; h1Ix < h1N; ++i) hhS[ i] = h1[ h1Ix++];

3474

for(; h2Ix < h2N; ++i) hhS[ i] = h2[ h2Ix++];

3475

}

3476

3477

// helper function for sort_fun, recursive

3478

void MergeSort( BaseGDL* p0, SizeT* hh, SizeT* h1, SizeT* h2,

3479

SizeT start, SizeT end)

3480

{

3481

if( start+1 >= end) return;

3482

3483

SizeT middle = (start+end) / 2;

3484

3485

MergeSort(p0, hh, h1, h2, start, middle);

3486

MergeSort(p0, hh, h1, h2, middle, end);

3487

3488

SizeT h1N = middle - start;

3489

SizeT h2N = end - middle;

3490

3491

SizeT* hhS = &hh[start];

3492

3493

SizeT i;

3494

for(i=0; i<h1N; ++i) h1[i] = hhS[ i];

3495

for(i=0; i<h2N; ++i) h2[i] = hh[middle + i];

3496

3497

SizeT h1Ix = 0;

3498

SizeT h2Ix = 0;

3499

for( i=0; (h1Ix < h1N) && (h2Ix < h2N); ++i)

3500

{

3501

// the actual comparisson

3502

if( p0->Greater( h1[h1Ix], h2[h2Ix]))

3503

hhS[ i] = h2[ h2Ix++];

3504

else

3505

hhS[ i] = h1[ h1Ix++];

3506

}

3507

for(; h1Ix < h1N; ++i) hhS[ i] = h1[ h1Ix++];

3508

for(; h2Ix < h2N; ++i) hhS[ i] = h2[ h2Ix++];

3509

}

3510

3511

// sort function uses MergeSort

3512

BaseGDL* sort_fun( EnvT* e)

3513

{

3514

e->NParam( 1);

3515

3516

BaseGDL* p0 = e->GetParDefined( 0);

3517

3518

if( p0->Type() == STRUCT)

3519

e->Throw( "Struct expression not allowed in this context: "+

3520

e->GetParString(0));

3521

3522

static int l64Ix = e->KeywordIx( "L64");

3523

bool l64 = e->KeywordSet( l64Ix);

3524

3525

SizeT nEl = p0->N_Elements();

3526

3527

// helper arrays

3528

DLongGDL* res = new DLongGDL( dimension( nEl), BaseGDL::INDGEN);

3529

3530

DLong nanIx = nEl;

3531

if( p0->Type() == FLOAT)

3532

{

3533

DFloatGDL* p0F = static_cast<DFloatGDL*>(p0);

3534

for( DLong i=nEl-1; i >= 0; --i)

3535

{

3536

if( isnan((*p0F)[ i]) )//|| !isfinite((*p0F)[ i]))

3537

{

3538

--nanIx;

3539

(*res)[i] = (*res)[nanIx];

3540

(*res)[ nanIx] = i;

3541

3542

// cout << "swap " << i << " with " << nanIx << endl;

3543

// cout << "now: ";

3544

// for( DLong ii=0; ii < nEl; ++ii)

3545

// {

3546

// cout << (*res)[ii] << " ";

3547

// }

3548

// cout << endl;

3549

}

3550

}

3551

}

3552

else if( p0->Type() == DOUBLE)

3553

{

3554

DDoubleGDL* p0F = static_cast<DDoubleGDL*>(p0);

3555

for( DLong i=nEl-1; i >= 0; --i)

3556

{

3557

if( isnan((*p0F)[ i]))// || !isfinite((*p0F)[ i]))

3558

{

3559

--nanIx;

3560

(*res)[i] = (*res)[nanIx];

3561

(*res)[ nanIx] = i;

3562

}

3563

}

3564

}

3565

else if( p0->Type() == COMPLEX)

3566

{

3567

DComplexGDL* p0F = static_cast<DComplexGDL*>(p0);

3568

for( DLong i=nEl-1; i >= 0; --i)

3569

{

3570

if( isnan((*p0F)[ i].real()) || //!isfinite((*p0F)[ i].real()) ||

3571

isnan((*p0F)[ i].imag()))// || !isfinite((*p0F)[ i].imag()) )

3572

{

3573

--nanIx;

3574

(*res)[i] = (*res)[nanIx];

3575

(*res)[ nanIx] = i;

3576

}

3577

}

3578

}

3579

else if( p0->Type() == COMPLEXDBL)

3580

{

3581

DComplexDblGDL* p0F = static_cast<DComplexDblGDL*>(p0);

3582

for( DLong i=nEl-1; i >= 0; --i)

3583

{

3584

if( isnan((*p0F)[ i].real()) || //!isfinite((*p0F)[ i].real()) ||

3585

isnan((*p0F)[ i].imag()))// || !isfinite((*p0F)[ i].imag()) )

3586

{

3587

--nanIx;

3588

(*res)[i] = (*res)[nanIx];

3589

(*res)[ nanIx] = i;

3590

}

3591

}

3592

}

3593

3594

// cout << "nEl " << nEl << " nanIx " << nanIx << endl;

3595

nEl = nanIx;

3596

// cout << "sorting: ";

3597

// for( DLong ii=0; ii < nEl; ++ii)

3598

// {

3599

// cout << (*res)[ii] << " ";

3600

// }

3601

// cout << endl;

3602

3603

DLong *hh = static_cast<DLong*>(res->DataAddr());

3604

3605

DLong* h1 = new DLong[ nEl/2];

3606

DLong* h2 = new DLong[ (nEl+1)/2];

3607

// call the sort routine

3608

MergeSortOpt<DLong>( p0, hh, h1, h2, nEl);

3609

delete[] h1;

3610

delete[] h2;

3611

3612

if( l64)

3613

{

3614

// leave it this way, as sorting of more than 2^31

3615

// items seems not feasible in the future we might

3616

// use MergeSortOpt<DLong64>(...) for this

3617

return res->Convert2( LONG64);

3618

}

3619

3620

return res;

3621

}

3622

3623

// uses MergeSort

3624

BaseGDL* median( EnvT* e)

3625

{

3626

SizeT nParam = e->NParam( 1);

3627

3628

if( !(nParam > 1))

3629

{

3630

BaseGDL* p0 = e->GetParDefined( 0);

3631

3632

if( p0->Type() == PTR)

3633

e->Throw( "Pointer expression not allowed in this context: "+

3634

e->GetParString(0));

3635

if( p0->Type() == OBJECT)

3636

e->Throw( "Object expression not allowed in this context: "+

3637

e->GetParString(0));

3638

if( p0->Type() == STRUCT)

3639

e->Throw( "Struct expression not allowed in this context: "+

3640

e->GetParString(0));

3641

3642

if( p0->Rank() == 0)

3643

e->Throw( "Expression must be an array in this context: "+

3644

e->GetParString(0));

3645

3646

SizeT nEl = p0->N_Elements();

3647

3648

static int evenIx = e->KeywordIx( "EVEN");

3649

bool dbl =

3650

p0->Type() == DOUBLE ||

3651

p0->Type() == COMPLEXDBL ||

3652

e->KeywordSet(e->KeywordIx("DOUBLE"));

3653

DType type = dbl ? DOUBLE : FLOAT;

3654

bool noconv = (dbl && p0->Type() == DOUBLE) || (!dbl && p0->Type() == FLOAT);

3655

3656

// DIMENSION keyword

3657

DLong dim = 0;

3658

DLong nmed = 1;

3659

BaseGDL *res;

3660

e->AssureLongScalarKWIfPresent( "DIMENSION", dim);

3661

3662

if (dim > p0->Rank())

3663

e->Throw( "Illegal keyword value for DIMENSION.");

3664

3665

if (dim > 0) {

3666

DLong dims[8];

3667

DLong k = 0;

3668

for (SizeT i=0; i<p0->Rank(); ++i)

3669

if (i != (dim-1)) {

3670

nmed *= p0->Dim(i);

3671

dims[k++] = p0->Dim(i);

3672

}

3673

dimension dimRes((DLong *) dims, p0->Rank()-1);

3674

res = dbl

3675

? static_cast<BaseGDL*>(new DDoubleGDL(dimRes, BaseGDL::NOZERO))

3676

: static_cast<BaseGDL*>(new DFloatGDL(dimRes, BaseGDL::NOZERO));

3677

} else {

3678

res = dbl

3679

? static_cast<BaseGDL*>(new DDoubleGDL(1))

3680

: static_cast<BaseGDL*>(new DFloatGDL(1));

3681

}

3682

3683

// helper arrays

3684

if (nmed > 1) nEl = p0->N_Elements() / nmed;

3685

3686

DLong *hh = new DLong[ nEl];

3687

DLong* h1 = new DLong[ nEl/2];

3688

DLong* h2 = new DLong[ (nEl+1)/2];

3689

3690

DLong accumStride = 1;

3691

if (nmed > 1)

3692

for( DLong i=0; i<dim-1; ++i) accumStride *= p0->Dim(i);

3693

3694

BaseGDL *op1, *op2, *op3;

3695

if (dbl) op3 = new DDoubleGDL(2);

3696

else op3 = new DFloatGDL(2);

3697

3698

// Loop over all subarray medians

3699

for (SizeT k=0; k<nmed; ++k) {

3700

3701

if (nmed == 1) {

3702

for( DLong i=0; i<nEl; ++i) hh[i] = i;

3703

3704

DLong nanIx = nEl;

3705

if( p0->Type() == FLOAT)

3706

{

3707

DFloatGDL* p0F = static_cast<DFloatGDL*>(p0);

3708

for( DLong i=nEl-1; i >= 0; --i)

3709

{

3710

if( isnan((*p0F)[ i]) )//|| !isfinite((*p0F)[ i]))

3711

{

3712

--nanIx;

3713

hh[i] = hh[nanIx];

3714

hh[ nanIx] = i;

3715

3716

// cout << "swap " << i << " with " << nanIx << endl;

3717

// cout << "now: ";

3718

// for( DLong ii=0; ii < nEl; ++ii)

3719

// {

3720

// cout << hh[ii] << " ";

3721

// }

3722

// cout << endl;

3723

}

3724

}

3725

}

3726

else if( p0->Type() == DOUBLE)

3727

{

3728

DDoubleGDL* p0F = static_cast<DDoubleGDL*>(p0);

3729

for( DLong i=nEl-1; i >= 0; --i)

3730

{

3731

if( isnan((*p0F)[ i]))// || !isfinite((*p0F)[ i]))

3732

{

3733

--nanIx;

3734

hh[i] = hh[nanIx];

3735

hh[ nanIx] = i;

3736

}

3737

}

3738

}

3739

else if( p0->Type() == COMPLEX)

3740

{

3741

DComplexGDL* p0F = static_cast<DComplexGDL*>(p0);

3742

for( DLong i=nEl-1; i >= 0; --i)

3743

{

3744

if( isnan((*p0F)[ i].real()) || //!isfinite((*p0F)[ i].real()) ||

3745

isnan((*p0F)[ i].imag()))// || !isfinite((*p0F)[ i].imag()) )

3746

{

3747

--nanIx;

3748

hh[i] = hh[nanIx];

3749

hh[ nanIx] = i;

3750

}

3751

}

3752

}

3753

else if( p0->Type() == COMPLEXDBL)

3754

{

3755

DComplexDblGDL* p0F = static_cast<DComplexDblGDL*>(p0);

3756

for( DLong i=nEl-1; i >= 0; --i)

3757

{

3758

if( isnan((*p0F)[ i].real()) || //!isfinite((*p0F)[ i].real()) ||

3759

isnan((*p0F)[ i].imag()))// || !isfinite((*p0F)[ i].imag()) )

3760

{

3761

--nanIx;

3762

hh[i] = hh[nanIx];

3763

hh[ nanIx] = i;

3764

}

3765

}

3766

}

3767

3768

// cout << "nEl " << nEl << " nanIx " << nanIx << endl;

3769

nEl = nanIx;

3770

3771

} else {

3772

// Starting Element

3773

DLong start = accumStride * p0->Dim(dim-1) * (k / accumStride) +

3774

(k % accumStride);

3775

for( DLong i=0; i<nEl; ++i) hh[i] = start + i * accumStride;

3776

}

3777

3778

// call the sort routine

3779

MergeSortOpt<DLong>( p0, hh, h1, h2, nEl);

3780

DLong medEl = hh[ nEl/2];

3781

DLong medEl_1 = hh[ nEl/2 - 1];

3782

3783

if( (nEl % 2) == 1 || !e->KeywordSet( evenIx)) {

3784

if (nmed == 1)

3785

res = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);

3786

else {

3787

if (noconv)

3788

{

3789

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = (*static_cast<DDoubleGDL*>(p0))[medEl];

3790

else (*static_cast<DFloatGDL*>(res))[k] = (*static_cast<DFloatGDL*>(p0))[medEl];

3791

}

3792

else

3793

{

3794

op1 = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);

3795

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = (*static_cast<DDoubleGDL*>(op1))[0];

3796

else (*static_cast<DFloatGDL*>(res))[k] = (*static_cast<DFloatGDL*>(op1))[0];

3797

delete(op1);

3798

}

3799

}

3800

} else {

3801

if (noconv)

3802

{

3803

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = .5 * (

3804

(*static_cast<DDoubleGDL*>(p0))[medEl] +

3805

(*static_cast<DDoubleGDL*>(p0))[medEl_1]

3806

);

3807

else (*static_cast<DFloatGDL*>(res))[k] = .5 * (

3808

(*static_cast<DFloatGDL*>(p0))[medEl] +

3809

(*static_cast<DFloatGDL*>(p0))[medEl_1]

3810

);

3811

}

3812

else

3813

{

3814

op1 = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);

3815

op2 = p0->NewIx(medEl_1)->Convert2(type, BaseGDL::CONVERT);

3816

if (nmed == 1) res = op2->Add(op1)->Div(op3); // TODO: leak with res?

3817

else

3818

{

3819

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] =

3820

(*static_cast<DDoubleGDL*>((op2->Add(op1)->Div(op3))))[0];

3821

else (*static_cast<DFloatGDL*>(res))[k] =

3822

(*static_cast<DFloatGDL*>((op2->Add(op1)->Div(op3))))[0];

3823

delete(op2);

3824

}

3825

delete(op1);

3826

}

3827

}

3828

}

3829

delete(op3);

3830

delete[] h1;

3831

delete[] h2;

3832

delete[] hh;

3833

3834

return res;

3835

}

3836

else

3837

// with parameter Width : median filtering with no optimisation,

3838

// such as histogram algorithms.

3839

3840

{

3841

// basic checks on "vector/array" input

3842

DDoubleGDL* p0 = e->GetParAs<DDoubleGDL>( 0);

3843

3844

if( p0->Type() == STRUCT)

3845

e->Throw( "Struct expression not allowed in this context: "+ e->GetParString(0));

3846

if( p0->Rank() == 0)

3847

e->Throw( "Expression must be an array in this context: "+ e->GetParString(0));

3848

3849

if( p0->Rank() > 2)

3850

e->Throw( "Only 1 or 2 dimensions allowed: "+ e->GetParString(0));

3851

3852

// basic checks on "width" input

3853

DDoubleGDL* p1d = e->GetParAs<DDoubleGDL>(1);

3854

3855

if (p1d->N_Elements() > 1 || (*p1d)[0] <=0 )

3856

e->Throw( "Width must be a positive scalar or 1 (positive) element array in this context: "+ e->GetParString(0));

3857

DLong MaxAllowedWidth=0;

3858

if (p0->Rank() == 1) MaxAllowedWidth=p0->N_Elements();

3859

if (p0->Rank() == 2) {

3860

MaxAllowedWidth=p0->Dim(0);

3861

if (p0->Dim(1) < MaxAllowedWidth) MaxAllowedWidth=p0->Dim(1);

3862

}

3863

const int debug =0;

3864

if (debug == 1) {

3865

cout << "X dim " << p0->Dim(0) <<endl;

3866

cout << "y dim " << p0->Dim(1) <<endl;

3867

cout << "MaxAllowedWidth " << MaxAllowedWidth <<endl;

3868

}

3869

if (!isfinite( (*p1d)[0]))

3870

e->Throw("Width must be > 1, and < dimension of array (NaN or Inf)");

3871

3872

DLongGDL* p1 = e->GetParAs<DLongGDL>(1);

3873

3874

DDoubleGDL *tamp = new DDoubleGDL(p0->Dim(),BaseGDL::NOZERO);

3875

DDouble min=((*p0)[0]);

3876

DDouble max=min;

3877

3878

for (SizeT ii=0 ; ii<p0->N_Elements() ; ++ii)

3879

{(*tamp)[ii]=(*p0)[ii];

3880

if ( (*p0)[ii] < min ) min = ((*p0)[ii]);

3881

if ( (*p0)[ii] > max ) max = ((*p0)[ii]);

3882

}

3883

3884

//---------------------------- END d'acquisistion des paramètres -------------------------------------

3885

3886

3887

static int evenIx = e->KeywordIx( "EVEN");

3888

static int doubleIx = e->KeywordIx( "DOUBLE");

3889

static DStructGDL *Values = SysVar::Values();

3890

DDouble d_nan=(*static_cast<DDoubleGDL*>(Values->GetTag(Values->Desc()->TagIndex("D_NAN"), 0)))[0];

3891

DDouble d_infinity= (*static_cast<DDoubleGDL*>(Values->GetTag(Values->Desc()->TagIndex("D_INFINITY"), 0)))[0];

3892

3893

//------------------------------ Init variables and allocation ---------------------------------------

3894

SizeT width=(*p1)[0];

3895

SizeT N_MaskElem= width*width;

3896

SizeT larg = p0->Stride(1);

3897

SizeT haut = p0->Stride(2)/larg;

3898

SizeT lim= static_cast<SizeT>(round(width/2));

3899

SizeT init=(lim*larg+lim);

3900

3901

// we don't go further if dimension(s) versus not width OK

3902

3903

if (debug == 1) {cout << "ici" <<endl;}

3904

3905

if ( p0->Rank() == 1) {

3906

if (larg < width || width==1 ) e->Throw( "Width must be > 1, and < width of vector");

3907

}

3908

if ( p0->Rank() == 2) {

3909

if (larg < width || haut < width || width==1) e->Throw("Width must be > 1, and < dimension of array");

3910

}

3911

3912

// for 2D arrays, we use the algorithm described in paper

3913

// from T. Huang, G. Yang, and G. Tang, “A Fast Two-Dimensional Median

3914

// Filtering Algorithm,” IEEE Trans. Acoust., Speech, Signal Processing,

3915

// vol. 27, no. 1, pp. 13–18, 1979.

3916

3917

if ( (e->GetParDefined( 0)->Type() == BYTE ||

3918

e->GetParDefined( 0)->Type() == INT ||

3919

e->GetParDefined( 0)->Type() == UINT ||

3920

e->GetParDefined( 0)->Type() == LONG ||

3921

e->GetParDefined( 0)->Type() == ULONG ||

3922

e->GetParDefined( 0)->Type() == LONG64 ||

3923

e->GetParDefined( 0)->Type() == ULONG64) &&

3924

(haut>1))

3925

{

3926

SizeT taille=static_cast<SizeT>(abs(max)-min+1);

3927

DDoubleGDL* Histo = new DDoubleGDL(taille,BaseGDL::NOZERO);

3928

if (width % 2 ==0)

3929

{

3930

for(SizeT i=0 ; i<haut-2*lim ; ++i)

3931

{

3932

SizeT ltmed=0;

3933

SizeT med=0;

3934

SizeT initial=init+i*larg-lim*larg-lim;

3935

for(SizeT pp=0 ; pp<taille;++pp)(*Histo)[pp]=0;

3936

for (SizeT ii=initial ; ii <initial+ width ; ++ii)

3937

{

3938

for(SizeT yy=0;yy<width;yy++)

3939

(*Histo)[static_cast<SizeT>((*p0)[ii+yy*larg]-min)]++;

3940

}

3941

3942

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

3943

{

3944

ltmed+= static_cast<SizeT>((*Histo)[med]);

3945

++med;

3946

}

3947

if (e->KeywordSet( evenIx))

3948

{

3949

3950

SizeT EvenMed=med;

3951

//if ((*Histo)[EvenMed]==1 || (ltmed!=0 && ltmed !=(N_MaskElem /2) -1))

3952

if ((*Histo)[EvenMed]==1 || (ltmed!=0 && N_MaskElem /2- ltmed!=1) )

3953

{

3954

while ((*Histo)[EvenMed-1]==0)

3955

{ EvenMed--;}

3956

(*tamp)[init+i*larg]=((med+min)+(EvenMed-1+min))/2;

3957

}

3958

else

3959

(*tamp)[init+i*larg]=med+min;

3960

}

3961

else

3962

{(*tamp)[init+i*larg]=med+min; }

3963

3964

for(SizeT j=init+i*larg +1; j<init+(i+1)*larg-2*lim ;++ j)

3965

{

3966

SizeT initMask=j-lim*larg-lim;

3967

for(SizeT k=0;k<2*lim;++k)

3968

{

3969

(*Histo)[static_cast<SizeT>((*p0)[initMask-1+k*larg]-min)]--;

3970

if ((*p0)[initMask-1+k*larg]-min<med)ltmed--;

3971

3972

(*Histo)[static_cast<SizeT>((*p0)[initMask+k*larg+2*lim-1]-min)]++;

3973

if ((*p0)[initMask+k*larg+2*lim-1]-min<med)ltmed++;

3974

}

3975

if (ltmed>N_MaskElem /2)

3976

{

3977

while(ltmed>N_MaskElem /2)

3978

{

3979

--med;

3980

ltmed-=static_cast<SizeT>((*Histo)[med]);

3981

}

3982

}

3983

else

3984

{

3985

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

3986

{

3987

ltmed+= static_cast<SizeT>((*Histo)[med]);

3988

++med;

3989

}

3990

}

3991

3992

if (e->KeywordSet( evenIx))

3993

{

3994

SizeT EvenMed=med;

3995

if ((*Histo)[EvenMed]==1 || (ltmed!=0 &&N_MaskElem /2- ltmed!=1 ))

3996

{

3997

while ((*Histo)[EvenMed-1]==0)

3998

{ EvenMed--;}

3999

(*tamp)[j]=((med+min)+(EvenMed-1+min))/2;

4000

}

4001

else

4002

{(*tamp)[j]=med+min; }

4003

}

4004

else

4005

{(*tamp)[j]=med+min; }

4006

}

4007

}

4008

}

4009

else

4010

{

4011

for(SizeT i=0 ; i<haut-2*lim ; ++i)

4012

{

4013

SizeT ltmed=0;

4014

SizeT med=0;

4015

SizeT initial=init+i*larg-lim*larg-lim;

4016

for(SizeT pp=0 ; pp<taille;++pp)(*Histo)[pp]=0;

4017

for (SizeT ii=initial ; ii <initial+ width ; ++ii)

4018

{

4019

for(SizeT yy=0;yy<width;yy++)

4020

(*Histo)[static_cast<SizeT>((*p0)[ii+yy*larg]-min)]++;

4021

}

4022

4023

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

4024

{

4025

ltmed+= static_cast<SizeT>((*Histo)[med]);

4026

++med;

4027

}

4028

(*tamp)[init+i*larg]=med+min;

4029

4030

for(SizeT j=init+i*larg +1; j<init+(i+1)*larg-2*lim ;++ j)

4031

{

4032

4033

SizeT initMask=j-lim*larg-lim;

4034

for(SizeT k=0;k<=2*lim;++k)

4035

{

4036

(*Histo)[static_cast<SizeT>((*p0)[initMask-1+k*larg]-min)]--;

4037

if ((*p0)[initMask-1+k*larg]-min<med)ltmed--;

4038

4039

(*Histo)[static_cast<SizeT>((*p0)[initMask+k*larg+2*lim]-min)]++;

4040

if ((*p0)[initMask+k*larg+2*lim]-min<med)ltmed++;

4041

}

4042

if (ltmed>N_MaskElem /2)

4043

{

4044

while(ltmed>N_MaskElem /2)

4045

{

4046

--med;

4047

ltmed-=static_cast<SizeT>((*Histo)[med]);

4048

}

4049

}

4050

else

4051

{

4052

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

4053

{

4054

ltmed+= static_cast<SizeT>((*Histo)[med]);

4055

++med;

4056

}

4057

}

4058

4059

(*tamp)[j]=med+min;

4060

4061

}

4062

}

4063

}

4064

4065

}

4066

else

4067

{

4068

DLong* hh;

4069

DLong* h1;

4070

DLong* h2;

4071

DDoubleGDL* Mask,*Mask1D;

4072

if ( p0->Rank() != 1 )

4073

{

4074

hh = new DLong[ N_MaskElem];

4075

h1 = new DLong[ N_MaskElem/2];

4076

h2= new DLong[ (N_MaskElem+1)/2];

4077

Mask = new DDoubleGDL(N_MaskElem,BaseGDL::NOZERO);

4078

4079

for( DLong i=0; i<N_MaskElem; ++i) hh[i] = i;

4080

}

4081

else

4082

{

4083

hh = new DLong[ width];

4084

h1 = new DLong[ width/2];

4085

h2= new DLong[(width+1)/2];

4086

Mask1D = new DDoubleGDL(width,BaseGDL::NOZERO);

4087

4088

for( DLong i=0; i<width; ++i) hh[i] = i;

4089

}

4090

4091

//-------------------------------- END OF VARIABLES INIT ---------------------------------------------

4092

4093

//------------------------------ Median Filter Algorithms ---------------------------------------

4094

4095

if ( width % 2 ==0)

4096

{

4097

if ( p0->Rank() == 1 )//------------------------ For a vector with even width -------------------

4098

{

4099

for (SizeT col= lim ; col<larg-lim ; ++col)

4100

{

4101

SizeT ctl_NaN=0;

4102

SizeT kk=0;

4103

for (SizeT ind=col-lim ; ind<col+lim ; ++ind)

4104

{

4105

if( (*p0)[ind]!=d_infinity && (*p0)[ind]!=-d_infinity && isfinite((*p0)[ind])==0)

4106

ctl_NaN++;

4107

else

4108

{

4109

(*Mask1D)[kk]=(*p0)[ind];

4110

kk++;

4111

}

4112

}

4113

if (ctl_NaN!=0)

4114

{

4115

if(ctl_NaN==width)(*tamp)[col]= d_nan;

4116

else

4117

{

4118

DLong* hhbis = new DLong[ width-ctl_NaN];

4119

DLong* h1bis = new DLong[ width-ctl_NaN/2];

4120

DLong* h2bis= new DLong[(width-ctl_NaN+1)/2];

4121

DDoubleGDL *Mask1Dbis = new DDoubleGDL(width-ctl_NaN,BaseGDL::NOZERO);

4122

for( DLong t=0; t<width-ctl_NaN; ++t) hhbis[t] = t;

4123

for( DLong ii=0; ii<width-ctl_NaN; ++ii)(*Mask1Dbis)[ii]=(*Mask1D)[ii];

4124

BaseGDL* besort=static_cast<BaseGDL*>(Mask1Dbis);

4125

MergeSortOpt<DLong>( besort, hhbis, h1bis, h2bis,(width - ctl_NaN));

4126

if (e->KeywordSet( evenIx)&& (width - ctl_NaN) % 2 == 0)

4127

(*tamp)[col]=((*Mask1Dbis)[hhbis[ (width-ctl_NaN)/2]]+(*Mask1Dbis

4128

)[hhbis [ (width - ctl_NaN-1)/2]])/2;

4129

else

4130

(*tamp)[col]=(*Mask1Dbis)[hhbis[ (width- ctl_NaN)/2]];

4131

delete[]hhbis;

4132

delete[]h2bis;

4133

delete[]h1bis;

4134

}

4135

}

4136

else

4137

{

4138

BaseGDL* besort=static_cast<BaseGDL*>(Mask1D);

4139

MergeSortOpt<DLong>( besort, hh, h1, h2,width ); // call the sort routine

4140

4141

if (e->KeywordSet( evenIx))

4142

4143

(*tamp)[col]=((*Mask1D)[hh[ width/2]]+(*Mask1D)[hh[ (width-1)/2]])/2;

4144

else

4145

(*tamp)[col]=(*Mask1D)[hh[ width/2]];// replace value by Mask median

4146

}

4147

}

4148

4149

}

4150

else//------------------------ For an array with even width -------------------

4151

{

4152

SizeT jj;

4153

for(SizeT i=0 ; i<haut-2*lim ; ++i) // lines to replace

4154

{

4155

for(SizeT j=init+i*larg ; j<init+(i+1)*larg-2*lim ; ++j)// elements to replace

4156

{

4157

SizeT initMask=j-lim*larg-lim; // left corner of mask

4158

SizeT kk=0;

4159

SizeT ctl_NaN=0;

4160

for(SizeT k=0;k<2*lim;++k) // lines of mask

4161

{

4162

4163

for(jj=initMask+k*larg ; jj<(initMask+k*larg)+2*lim ; ++jj) // elements of mask

4164

{

4165

if( (*p0)[jj]!=d_infinity && (*p0)[jj]!=-d_infinity && isfinite((*p0)[jj])==0)

4166

ctl_NaN++;

4167

else

4168

{

4169

(*Mask)[kk]=(*p0)[jj];

4170

kk++;

4171

}

4172

}

4173

}

4174

if (ctl_NaN!=0)

4175

{

4176

if(ctl_NaN==N_MaskElem)(*tamp)[j]= d_nan;

4177

else {

4178

DLong* hhb = new DLong[ N_MaskElem-ctl_NaN];

4179

DLong* h1b = new DLong[ (N_MaskElem-ctl_NaN)/2];

4180

DLong* h2b = new DLong[(N_MaskElem-ctl_NaN+1)/2];

4181

DDoubleGDL *Maskb = new DDoubleGDL(N_MaskElem-ctl_NaN,BaseGDL::NOZERO);

4182

for( DLong t=0; t<N_MaskElem-ctl_NaN; ++t) hhb[t] = t;

4183

for( DLong ii=0; ii<N_MaskElem-ctl_NaN; ++ii)(*Maskb)[ii]=(*Mask)[ii];

4184

BaseGDL* besort=static_cast<BaseGDL*>(Maskb);

4185

MergeSortOpt<DLong>( besort, hhb, h1b, h2b,(N_MaskElem - ctl_NaN));

4186

if ((N_MaskElem - ctl_NaN) % 2 == 0 && e->KeywordSet( evenIx))

4187

(*tamp)[j]=((*Maskb)[hhb[ (N_MaskElem-ctl_NaN)/2]]+(*Maskb)[hhb

4188

[ (N_MaskElem -

4189

ctl_NaN-1)/2]])/2;

4190

else

4191

(*tamp)[j]=(*Maskb)[hhb[ (N_MaskElem- ctl_NaN)/2]];

4192

delete[]hhb;

4193

delete[]h2b;

4194

delete[]h1b;

4195

}

4196

}

4197

else

4198

{

4199

BaseGDL* besort=static_cast<BaseGDL*>(Mask);

4200

MergeSortOpt<DLong>( besort, hh, h1, h2, N_MaskElem); // call the sort routine

4201

if (e->KeywordSet( evenIx))

4202

(*tamp)[j]=((*Mask)[hh[ N_MaskElem/2]]+(*Mask)[hh[ (N_MaskElem-1)/2]])/2;

4203

else

4204

(*tamp)[j]=(*Mask)[hh[ N_MaskElem/2]];// replace value by median Mask one

4205

}

4206

}

4207

}

4208

}

4209

}

4210

4211

else

4212

{

4213

if ( p0->Rank() == 1 )//------------------------ For a vector with odd width -------------------

4214

4215

{

4216

for (SizeT col= lim ; col<larg-lim ; ++col)

4217

{

4218

SizeT kk=0;

4219

SizeT ctl_NaN=0;

4220

for (SizeT ind=col-lim ; ind<=col+lim ; ++ind)

4221

{if( (*p0)[ind]!=d_infinity && (*p0)[ind]!=-d_infinity && isfinite((*p0)[ind])==0)

4222

ctl_NaN++;

4223

else{

4224

(*Mask1D)[kk]=(*p0)[ind];

4225

kk++;

4226

}

4227

}

4228

if (ctl_NaN!=0)

4229

{

4230

if(ctl_NaN==width)(*tamp)[col]= d_nan;

4231

else {

4232

DLong* hhbis = new DLong[ width-ctl_NaN];

4233

DLong* h1bis = new DLong[ width-ctl_NaN/2];

4234

DLong* h2bis= new DLong[(width-ctl_NaN+1)/2];

4235

DDoubleGDL *Mask1Dbis = new DDoubleGDL(width-ctl_NaN,BaseGDL::NOZERO);

4236

for( DLong t=0; t<width-ctl_NaN; ++t) hhbis[t] = t;

4237

for( DLong ii=0; ii<width-ctl_NaN; ++ii)(*Mask1Dbis)[ii]=(*Mask1D)[ii];

4238

BaseGDL* besort=static_cast<BaseGDL*>(Mask1Dbis);

4239

MergeSortOpt<DLong>( besort, hhbis, h1bis, h2bis,(width - ctl_NaN));

4240

if (e->KeywordSet( evenIx)&& (width - ctl_NaN) % 2 == 0)

4241

(*tamp)[col]=((*Mask1Dbis)[hhbis[ (width-ctl_NaN)/2]]+(*Mask1Dbis

4242

)[hhbis [ (width - ctl_NaN-1)/2]])/2;

4243

else(*tamp)[col]=(*Mask1Dbis)[hhbis[ (width- ctl_NaN)/2]];

4244

delete[]hhbis;

4245

delete[]h2bis;

4246

delete[]h1bis;

4247

}

4248

}

4249

else

4250

{

4251

BaseGDL* besort=static_cast<BaseGDL*>(Mask1D);

4252

MergeSortOpt<DLong>( besort, hh, h1, h2,width ); // call the sort routine

4253

(*tamp)[col]=(*Mask1D)[hh[ (width)/2]]; // replace value by Mask median

4254

}

4255

}

4256

4257

}

4258

4259

else //----------------------------- For an array with odd width ---------------------------------

4260

{

4261

SizeT jj;

4262

for(SizeT i=0 ; i<haut-2*lim ; ++i) // lines to replace

4263

{

4264

4265

SizeT initial=init+i*larg-lim*larg-lim;

4266

SizeT dd=0;SizeT ctl_NaN_init=0;

4267

for(SizeT yy=0;yy<width;yy++)

4268

{

4269

for (SizeT ii=initial+yy*larg ; ii <initial+ yy*larg+ width; ++ii)

4270

{

4271

4272

if( (*p0)[ii]!=d_infinity && (*p0)[ii]!=-d_infinity && isfinite((*p0)[ii])==0)

4273

ctl_NaN_init++;

4274

else

4275

(*Mask)[dd]=(*p0)[ii];

4276

dd++;

4277

}

4278

}

4279

SizeT kk=0;

4280

4281

for(SizeT j=init+i*larg ; j<init+(i+1)*larg-2*lim ; ++j)// elements to replace

4282

{

4283

SizeT initMask=j-lim*larg-lim; // left corner of mask

4284

SizeT kk=0;

4285

SizeT ctl_NaN=0;

4286

for(SizeT k=0;k<=2*lim;++k) // lines of mask

4287

{

4288

4289

for(jj=initMask+k*larg ; jj<=(initMask+k*larg)+2*lim ; ++jj) // elements of mask

4290

{

4291

if( (*p0)[jj]!=d_infinity && (*p0)[jj]!=-d_infinity && isfinite((*p0)[jj])==0)

4292

ctl_NaN++;

4293

4294

else

4295

{

4296

(*Mask)[kk]=(*p0)[jj];

4297

kk++;

4298

}

4299

}

4300

4301

}

4302

4303

if (ctl_NaN!=0)

4304

{

4305

if(ctl_NaN==N_MaskElem)

4306

(*tamp)[j]= d_nan;

4307

else {

4308

DLong* hhb = new DLong[ N_MaskElem-ctl_NaN];

4309

DLong* h1b = new DLong[ (N_MaskElem-ctl_NaN)/2];

4310

DLong* h2b= new DLong[(N_MaskElem-ctl_NaN+1)/2];

4311

DDoubleGDL*Maskb = new DDoubleGDL(N_MaskElem-ctl_NaN,BaseGDL::NOZERO);

4312

for( DLong t=0; t<N_MaskElem-ctl_NaN; ++t) hhb[t] = t;

4313

for( DLong ii=0; ii<N_MaskElem-ctl_NaN; ++ii)(*Maskb)[ii]=(*Mask)[ii];

4314

BaseGDL* besort=static_cast<BaseGDL*>(Maskb);

4315

MergeSortOpt<DLong>( besort, hhb, h1b, h2b,(N_MaskElem - ctl_NaN));

4316

if ((N_MaskElem - ctl_NaN) % 2 == 0 && e->KeywordSet( evenIx))

4317

(*tamp)[j]=((*Maskb)[hhb[ (N_MaskElem-ctl_NaN)/2]]+(*Maskb)[hhb

4318

[ (N_MaskElem -

4319

ctl_NaN-1)/2]])/2;

4320

else(*tamp)[j]=(*Maskb)[hhb[(N_MaskElem- ctl_NaN)/2]];

4321

delete[]hhb;

4322

delete[]h2b;

4323

delete[]h1b;

4324

}

4325

}

4326

else

4327

{

4328

BaseGDL* besort=static_cast<BaseGDL*>(Mask);

4329

MergeSortOpt<DLong>( besort, hh, h1, h2, N_MaskElem); // call the sort routine

4330

(*tamp)[j]=(*Mask)[hh[ (N_MaskElem)/2]]; // replace value by Mask median

4331

}

4332

}

4333

}

4334

}

4335

}

4336

4337

//--------------------------- END OF MEDIAN FILTER ALOGORITHMS -----------------------------------

4338

4339

delete[] h1;

4340

delete[] h2;

4341

delete[] hh;

4342

}

4343

if ( e->GetParDefined( 0)->Type() == DOUBLE || p0->Type() == COMPLEXDBL ||e->KeywordSet( doubleIx) )

4344

return tamp;

4345

else if (e->GetParDefined( 0)->Type() == BYTE)

4346

return tamp->Convert2(BYTE,BaseGDL::CONVERT);

4347

4348

return tamp->Convert2(FLOAT,BaseGDL::CONVERT);

4349

4350

}// end if

4351

4352

}// end of median

4353

4354

BaseGDL* shift_fun( EnvT* e)

4355

{

4356

SizeT nParam = e->NParam( 2);

4357

4358

BaseGDL* p0 = e->GetParDefined( 0);

4359

4360

SizeT nShift = nParam - 1;

4361

if( nShift == 1)

4362

{

4363

DLong s1;

4364

e->AssureLongScalarPar( 1, s1);

4365

4366

return p0->CShift( s1);

4367

}

4368

4369

if( p0->Rank() != nShift)

4370

e->Throw( "Incorrect number of arguments.");

4371

4372

DLong sIx[ MAXRANK];

4373

for( SizeT i=0; i< nShift; i++)

4374

e->AssureLongScalarPar( i+1, sIx[ i]);

4375

4376

return p0->CShift( sIx);

4377

}

4378

4379

BaseGDL* arg_present( EnvT* e)

4380

{

4381

e->NParam( 1);

4382

4383

if( !e->GlobalPar( 0))

4384

return new DIntGDL( 0);

4385

4386

EnvBaseT* caller = e->Caller();

4387

if( caller == NULL)

4388

return new DIntGDL( 0);

4389

4390

BaseGDL** pp0 = &e->GetPar( 0);

4391

4392

int ix = caller->FindGlobalKW( pp0);

4393

if( ix == -1)

4394

return new DIntGDL( 0);

4395

4396

return new DIntGDL( 1);

4397

}

4398

4399

BaseGDL* eof_fun( EnvT* e)

4400

{

4401

e->NParam( 1);

4402

4403

DLong lun;

4404

e->AssureLongScalarPar( 0, lun);

4405

4406

bool stdLun = check_lun( e, lun);

4407

if( stdLun)

4408

return new DIntGDL( 0);

4409

4410

// nicer error message (Disregard if socket)

4411

if ( fileUnits[ lun-1].SockNum() == -1) {

4412

if( !fileUnits[ lun-1].IsOpen())

4413

throw GDLIOException( e->CallingNode(), "File unit is not open: "+i2s( lun)+".");

4414

4415

if( fileUnits[ lun-1].Eof())

4416

return new DIntGDL( 1);

4417

} else {

4418

// Socket

4419

string *recvBuf = &fileUnits[ lun-1].RecvBuf();

4420

if (recvBuf->size() == 0)

4421

return new DIntGDL( 1);

4422

}

4423

return new DIntGDL( 0);

4424

}

4425

4426

BaseGDL* convol( EnvT* e)

4427

{

4428

SizeT nParam=e->NParam( 2);

4429

4430

BaseGDL* p0 = e->GetNumericParDefined( 0);

4431

if( p0->Rank() == 0)

4432

e->Throw( "Expression must be an array in this context: "+

4433

e->GetParString(0));

4434

4435

BaseGDL* p1 = e->GetNumericParDefined( 1);

4436

if( p1->Rank() == 0)

4437

e->Throw( "Expression must be an array in this context: "+

4438

e->GetParString(1));

4439

4440

if( p0->N_Elements() <= p1->N_Elements())

4441

e->Throw( "Incompatible dimensions for Array and Kernel.");

4442

4443

// rank 1 for kernel works always

4444

if( p1->Rank() != 1)

4445

{

4446

SizeT rank = p0->Rank();

4447

if( rank != p1->Rank())

4448

e->Throw( "Incompatible dimensions for Array and Kernel.");

4449

4450

for( SizeT r=0; r<rank; ++r)

4451

if( p0->Dim( r) <= p1->Dim( r))

4452

e->Throw( "Incompatible dimensions for Array and Kernel.");

4453

}

4454

4455

// convert kernel to array type

4456

auto_ptr<BaseGDL> p1Guard;

4457

if( p0->Type() == BYTE)

4458

{

4459

if( p1->Type() != INT)

4460

{

4461

p1 = p1->Convert2( INT, BaseGDL::COPY);

4462

p1Guard.reset( p1);

4463

}

4464

}

4465

else if( p0->Type() != p1->Type())

4466

{

4467

p1 = p1->Convert2( p0->Type(), BaseGDL::COPY);

4468

p1Guard.reset( p1);

4469

}

4470

4471

BaseGDL* scale;

4472

auto_ptr<BaseGDL> scaleGuard;

4473

if( nParam > 2)

4474

{

4475

scale = e->GetParDefined( 2);

4476

if( scale->Rank() > 0)

4477

e->Throw( "Expression must be a scalar in this context: "+

4478

e->GetParString(2));

4479

4480

// p1 here handles BYTE case also

4481

if( p1->Type() != scale->Type())

4482

{

4483

scale = scale->Convert2( p1->Type(),BaseGDL::COPY);

4484

scaleGuard.reset( scale);

4485

}

4486

}

4487

else

4488

{

4489

scale = p1->New( dimension(), BaseGDL::ZERO);

4490

}

4491

4492

bool center = true;

4493

static int centerIx = e->KeywordIx( "CENTER");

4494

if( e->KeywordPresent( centerIx))

4495

{

4496

DLong c;

4497

e->AssureLongScalarKW( centerIx, c);

4498

center = (c != 0);

4499

}

4500

4501

// overrides EDGE_TRUNCATE

4502

static int edge_wrapIx = e->KeywordIx( "EDGE_WRAP");

4503

bool edge_wrap = e->KeywordSet( edge_wrapIx);

4504

static int edge_truncateIx = e->KeywordIx( "EDGE_TRUNCATE");

4505

bool edge_truncate = e->KeywordSet( edge_truncateIx);

4506

4507

int edgeMode = 0;

4508

if( edge_wrap)

4509

edgeMode = 1;

4510

else if( edge_truncate)

4511

edgeMode = 2;

4512

4513

// p0, p1 and scale have same type

4514

// p1 has rank of 1 or same rank as p0 with each dimension smaller than p0

4515

// scale is a scalar

4516

return p0->Convol( p1, scale, center, edgeMode);

4517

}

4518

4519

BaseGDL* rebin_fun( EnvT* e)

4520

{

4521

SizeT nParam = e->NParam( 2);

4522

4523

BaseGDL* p0 = e->GetNumericParDefined( 0);

4524

4525

SizeT rank = p0->Rank();

4526

4527

if( rank == 0)

4528

e->Throw( "Expression must be an array in this context: "+

4529

e->GetParString(0));

4530

4531

SizeT resDimInit[ MAXRANK];

4532

4533

DLongGDL* p1 = e->GetParAs<DLongGDL>(1);

4534

if (p1->Rank() > 0 && nParam > 2)

4535

e->Throw("The new dimensions must either be specified as an array or as a set of scalars.");

4536

SizeT np = p1->Rank() == 0 ? nParam : p1->N_Elements() + 1;

4537

4538

for( SizeT p=1; p<np; ++p)

4539

{

4540

DLong newDim;

4541

if (p1->Rank() == 0) e->AssureLongScalarPar( p, newDim);

4542

else newDim = (*p1)[p - 1];

4543

4544

if( newDim <= 0)

4545

e->Throw( "Array dimensions must be greater than 0.");

4546

4547

if( rank >= p)

4548

{

4549

SizeT oldDim = p0->Dim( p-1);

4550

4551

if( newDim > oldDim)

4552

{

4553

if( (newDim % oldDim) != 0)

4554

e->Throw( "Result dimensions must be integer factor "

4555

"of original dimensions.");

4556

}

4557

else

4558

{

4559

if( (oldDim % newDim) != 0)

4560

e->Throw( "Result dimensions must be integer factor "

4561

"of original dimensions.");

4562

}

4563

}

4564

4565

resDimInit[ p-1] = newDim;

4566

}

4567

4568

dimension resDim( resDimInit, np-1);

4569

4570

static int sampleIx = e->KeywordIx( "SAMPLE");

4571

bool sample = e->KeywordSet( sampleIx);

4572

4573

return p0->Rebin( resDim, sample);

4574

}

4575

4576

BaseGDL* obj_class( EnvT* e)

4577

{

4578

SizeT nParam = e->NParam();

4579

4580

static int countIx = e->KeywordIx( "COUNT");

4581

static int superIx = e->KeywordIx( "SUPERCLASS");

4582

4583

bool super = e->KeywordSet( superIx);

4584

4585

bool count = e->KeywordPresent( countIx);

4586

if( count)

4587

e->AssureGlobalKW( countIx);

4588

4589

if( nParam > 0)

4590

{

4591

BaseGDL* p0 = e->GetParDefined( 0);

4592

4593

if( p0->Type() != STRING && p0->Type() != OBJECT)

4594

e->Throw( "Argument must be a scalar object reference or string: "+

4595

e->GetParString(0));

4596

4597

if( !p0->Scalar())

4598

e->Throw( "Expression must be a scalar or 1 element "

4599

"array in this context: "+e->GetParString(0));

4600

4601

DStructDesc* objDesc;

4602

4603

if( p0->Type() == STRING)

4604

{

4605

DString objName;

4606

e->AssureScalarPar<DStringGDL>( 0, objName);

4607

objName = StrUpCase( objName);

4608

4609

objDesc = FindInStructList( structList, objName);

4610

if( objDesc == NULL)

4611

{

4612

if( count)

4613

e->SetKW( countIx, new DLongGDL( 0));

4614

return new DStringGDL( "");

4615

}

4616

}

4617

else // OBJECT

4618

{

4619

DObj objRef;

4620

e->AssureScalarPar<DObjGDL>( 0, objRef);

4621

4622

if( objRef == 0)

4623

{

4624

if( count)

4625

e->SetKW( countIx, new DLongGDL( 0));

4626

return new DStringGDL( "");

4627

}

4628

4629

DStructGDL* oStruct;

4630

try {

4631

oStruct = e->GetObjHeap( objRef);

4632

}

4633

catch ( GDLInterpreter::HeapException)

4634

{ // non valid object

4635

if( count)

4636

e->SetKW( countIx, new DLongGDL( 0));

4637

return new DStringGDL( "");

4638

}

4639

4640

objDesc = oStruct->Desc(); // cannot be NULL

4641

}

4642

4643

if( !super)

4644

{

4645

if( count)

4646

e->SetKW( countIx, new DLongGDL( 1));

4647

return new DStringGDL( objDesc->Name());

4648

}

4649

4650

deque< string> pNames;

4651

objDesc->GetParentNames( pNames);

4652

4653

SizeT nNames = pNames.size();

4654

4655

if( count)

4656

e->SetKW( countIx, new DLongGDL( nNames));

4657

4658

if( nNames == 0)

4659

{

4660

return new DStringGDL( "");

4661

}

4662

4663

DStringGDL* res = new DStringGDL( dimension( nNames),

4664

BaseGDL::NOZERO);

4665

4666

for( SizeT i=0; i<nNames; ++i)

4667

{

4668

(*res)[i] = pNames[i];

4669

}

4670

4671

return res;

4672

}

4673

4674

if( super)

4675

e->Throw( "Conflicting keywords.");

4676

4677

SizeT nObj = structList.size();

4678

4679

DStringGDL* res = new DStringGDL( dimension( nObj),

4680

BaseGDL::NOZERO);

4681

4682

for( SizeT i=0; i<nObj; ++i)

4683

{

4684

(*res)[i] = structList[i]->Name();

4685

}

4686

4687

return res;

4688

}

4689

4690

BaseGDL* obj_isa( EnvT* e)

4691

{

4692

SizeT nParam = e->NParam( 2);

4693

4694

BaseGDL* p0 = e->GetPar( 0);

4695

if( p0 == NULL || p0->Type() != OBJECT)

4696

e->Throw( "Object reference type required in this context: "+

4697

e->GetParString(0));

4698

4699

DString className;

4700

e->AssureScalarPar<DStringGDL>( 1, className);

4701

className = StrUpCase( className);

4702

4703

DObjGDL* pObj = static_cast<DObjGDL*>( p0);

4704

4705

DByteGDL* res = new DByteGDL( pObj->Dim()); // zero

4706

4707

GDLInterpreter* interpreter = e->Interpreter();

4708

4709

SizeT nElem = pObj->N_Elements();

4710

for( SizeT i=0; i<nElem; ++i)

4711

{

4712

if( interpreter->ObjValid( (*pObj)[ i]))

4713

{

4714

DStructGDL* oStruct = e->GetObjHeap( (*pObj)[i]);

4715

if( oStruct->Desc()->IsParent( className))

4716

(*res)[i] = 1;

4717

}

4718

}

4719

4720

return res;

4721

}

4722

4723

BaseGDL* n_tags( EnvT* e)

4724

{

4725

e->NParam( 1);

4726

4727

BaseGDL* p0 = e->GetPar( 0);

4728

if( p0 == NULL)

4729

return new DLongGDL( 0);

4730

4731

if( p0->Type() != STRUCT)

4732

return new DLongGDL( 0);

4733

4734

DStructGDL* s = static_cast<DStructGDL*>( p0);

4735

4736

//static int lengthIx = e->KeywordIx( "DATA_LENGTH");

4737

//bool length = e->KeywordSet( lengthIx);

4738

4739

// we don't know now how to distinghuis the 2 following cases

4740

if(e->KeywordSet("DATA_LENGTH"))

4741

return new DLongGDL( s->Sizeof());

4742

4743

if(e->KeywordSet("LENGTH"))

4744

return new DLongGDL( s->Sizeof());

4745

4746

return new DLongGDL( s->Desc()->NTags());

4747

}

4748

4749

BaseGDL* bytscl( EnvT* e)

4750

{

4751

SizeT nParam = e->NParam( 1);

4752

4753

BaseGDL* p0=e->GetNumericParDefined( 0);

4754

4755

static int minIx = e->KeywordIx( "MIN");

4756

static int maxIx = e->KeywordIx( "MAX");

4757

static int topIx = e->KeywordIx( "TOP");

4758

bool omitNaN = e->KeywordPresent( 3);

4759

4760

DLong topL=255;

4761

if( e->GetKW( topIx) != NULL)

4762

e->AssureLongScalarKW( topIx, topL);

4763

DByte top = static_cast<DByte>(topL);

4764

DDouble dTop = static_cast<DDouble>(top);

4765

4766

DDouble min;

4767

bool minSet = false;

4768

// SA: handling 3 parameters to emulate undocumented IDL behaviour

4769

// of translating second and third arguments to MIN and MAX, respectively

4770

// (parameters have precedence over keywords)

4771

if (nParam >= 2)

4772

{

4773

e->AssureDoubleScalarPar(1, min);

4774

minSet = true;

4775

}

4776

else if (e->GetKW(minIx) != NULL)

4777

{

4778

e->AssureDoubleScalarKW(minIx, min);

4779

minSet = true;

4780

}

4781

4782

DDouble max;

4783

bool maxSet = false;

4784

if (nParam == 3)

4785

{

4786

e->AssureDoubleScalarPar(2, max);

4787

maxSet = true;

4788

}

4789

else if (e->GetKW(maxIx) != NULL)

4790

{

4791

e->AssureDoubleScalarKW(maxIx, max);

4792

maxSet = true;

4793

}

4794

4795

DDoubleGDL* dRes =

4796

static_cast<DDoubleGDL*>(p0->Convert2( DOUBLE, BaseGDL::COPY));

4797

4798

DLong maxEl, minEl;

4799

if( !maxSet || !minSet)

4800

dRes->MinMax( &minEl, &maxEl, NULL, NULL, omitNaN);

4801

if( !minSet)

4802

min = (*dRes)[ minEl];

4803

if( !maxSet)

4804

max = (*dRes)[ maxEl];

4805

4806

SizeT nEl = dRes->N_Elements();

4807

for( SizeT i=0; i<nEl; ++i)

4808

{

4809

DDouble& d = (*dRes)[ i];

4810

if( d <= min) (*dRes)[ i] = 0;

4811

else if( d >= max) (*dRes)[ i] = dTop;

4812

else

4813

{

4814

// SA: floor is used for integer types to simulate manipulation on input data types

4815

if (IntType(p0->Type())) (*dRes)[ i] = floor(((dTop + 1.)*(d - min) - 1.) / (max-min));

4816

// SA (?): here floor is used (instead of round) to simulate IDL behaviour

4817

else (*dRes)[ i] = floor((d - min) / (max-min) * (dTop + .9999));

4818

}

4819

}

4820

4821

return dRes->Convert2( BYTE);

4822

}

4823

4824

BaseGDL* strtok_fun( EnvT* e)

4825

{

4826

SizeT nParam=e->NParam( 1);

4827

4828

DString stringIn;

4829

e->AssureStringScalarPar( 0, stringIn);

4830

4831

DString pattern = " \t";

4832

if(nParam > 1) {

4833

e->AssureStringScalarPar( 1, pattern);

4834

}

4835

4836

static int extractIx = e->KeywordIx( "EXTRACT");

4837

bool extract = e->KeywordSet( extractIx);

4838

4839

static int lengthIx = e->KeywordIx( "LENGTH");

4840

bool lengthPresent = e->KeywordPresent( lengthIx);

4841

4842

if( extract && lengthPresent)

4843

e->Throw( "Conflicting keywords.");

4844

4845

static int pre0Ix = e->KeywordIx( "PRESERVE_NULL");

4846

bool pre0 = e->KeywordSet( pre0Ix);

4847

4848

static int regexIx = e->KeywordIx( "REGEX");

4849

bool regex = e->KeywordPresent( regexIx);

4850

char err_msg[MAX_REGEXPERR_LENGTH];

4851

regex_t regexp;

4852

4853

deque<long> tokenStart;

4854

deque<long> tokenLen;

4855

4856

int strLen = stringIn.length();

4857

4858

DString escape = "";

4859

e->AssureStringScalarKWIfPresent( "ESCAPE", escape);

4860

deque<long> escList;

4861

long pos = 0;

4862

while(pos != string::npos)

4863

{

4864

pos = stringIn.find_first_of( escape, pos);

4865

if( pos != string::npos)

4866

{

4867

escList.push_back( pos+1); // remember escaped char

4868

pos += 2; // skip escaped char

4869

}

4870

}

4871

deque<long>::iterator escBeg = escList.begin();

4872

deque<long>::iterator escEnd = escList.end();

4873

4874

long tokB = 0;

4875

long tokE;

4876

long nextE = 0;

4877

long actLen;

4878

4879

// If regex then compile regex

4880

if( regex) {

4881

if (pattern == " \t") pattern = " "; // regcomp doesn't like "\t" JMG

4882

int compRes = regcomp( &regexp, pattern.c_str(), REG_EXTENDED);

4883

if (compRes) {

4884

regerror(compRes, &regexp, err_msg, MAX_REGEXPERR_LENGTH);

4885

e->Throw( "Error processing regular expression: "+

4886

pattern+"\n "+string(err_msg)+".");

4887

}

4888

}

4889

4890

for(;;)

4891

{

4892

regmatch_t pmatch[1];

4893

if( regex) {

4894

int matchres = regexec( &regexp, stringIn.c_str()+nextE, 1, pmatch, 0);

4895

tokE = matchres? -1:pmatch[0].rm_so;

4896

} else {

4897

tokE = stringIn.find_first_of( pattern, nextE);

4898

}

4899

4900

if( tokE == string::npos)

4901

{

4902

actLen = strLen - tokB;

4903

if( actLen > 0 || pre0)

4904

{

4905

tokenStart.push_back( tokB);

4906

tokenLen.push_back( actLen);

4907

}

4908

break;

4909

}

4910

4911

if( find( escBeg, escEnd, tokE) == escEnd)

4912

{

4913

if (regex) actLen = tokE; else actLen = tokE - tokB;

4914

if( actLen > 0 || pre0)

4915

{

4916

tokenStart.push_back( tokB);

4917

tokenLen.push_back( actLen);

4918

}

4919

if (regex) tokB += pmatch[0].rm_eo; else tokB = tokE + 1;

4920

}

4921

if (regex) nextE += pmatch[0].rm_eo; else nextE = tokE + 1;

4922

} // for(;;)

4923

4924

if (regex) regfree( &regexp);

4925

4926

SizeT nTok = tokenStart.size();

4927

4928

if( !extract)

4929

{

4930

if( lengthPresent)

4931

{

4932

e->AssureGlobalKW( lengthIx);

4933

4934

if( nTok > 0)

4935

{

4936

dimension dim(nTok);

4937

DLongGDL* len = new DLongGDL(dim);

4938

for(int i=0; i < nTok; i++)

4939

(*len)[i] = tokenLen[i];

4940

4941

e->SetKW( lengthIx, len);

4942

}

4943

else

4944

{

4945

e->SetKW( lengthIx, new DLongGDL( 0));

4946

}

4947

}

4948

4949

if( nTok == 0) return new DLongGDL( 0);

4950

4951

dimension dim(nTok);

4952

DLongGDL* d = new DLongGDL(dim);

4953

for(int i=0; i < nTok; i++)

4954

(*d)[i] = tokenStart[i];

4955

return d;

4956

}

4957

4958

// EXTRACT

4959

if( nTok == 0) return new DStringGDL( "");

4960

4961

dimension dim(nTok);

4962

DStringGDL *d = new DStringGDL(dim);

4963

for(int i=0; i < nTok; i++)

4964

{

4965

(*d)[i] = stringIn.substr(tokenStart[i], tokenLen[i]);

4966

4967

// remove escape

4968

DString& act = (*d)[i];

4969

long escPos = act.find_first_of( escape, 0);

4970

while( escPos != string::npos)

4971

{

4972

act = act.substr( 0, escPos)+act.substr( escPos+1);

4973

escPos = act.find_first_of( escape, escPos+1);

4974

}

4975

}

4976

return d;

4977

}

4978

4979

BaseGDL* getenv_fun( EnvT* e)

4980

{

4981

SizeT nParam=e->NParam();

4982

4983

static int environmentIx = e->KeywordIx( "ENVIRONMENT" );

4984

bool environment = e->KeywordSet( environmentIx );

4985

4986

SizeT nEnv;

4987

DStringGDL* env;

4988

4989

if( environment) {

4990

4991

if(nParam != 0)

4992

e->Throw( "Incorrect number of arguments.");

4993

4994

// determine number of environment entries

4995

for(nEnv = 0; environ[nEnv] != NULL ; ++nEnv);

4996

4997

dimension dim( nEnv );

4998

env = new DStringGDL(dim);

4999

5000

// copy stuff into local string array

5001

for(SizeT i=0; i < nEnv ; ++i)

5002

(*env)[i] = environ[i];

5003

5004

} else {

5005

5006

if(nParam != 1)

5007

e->Throw( "Incorrect number of arguments.");

5008

5009

DStringGDL* name = e->GetParAs<DStringGDL>(0);

5010

nEnv = name->N_Elements();

5011

5012

env = new DStringGDL( name->Dim());

5013

5014

// copy the stuff into local string only if param found

5015

char *resPtr;

5016

for(SizeT i=0; i < nEnv ; ++i)

5017

{

5018

// handle special environment variables

5019

// GDL_TMPDIR, IDL_TMPDIR

5020

if( (*name)[i] == "GDL_TMPDIR" || (*name)[i] == "IDL_TMPDIR")

5021

{

5022

resPtr = getenv((*name)[i].c_str());

5023

5024

if( resPtr != NULL)

5025

(*env)[i] = resPtr;

5026

else

5027

(*env)[i] = SysVar::Dir();

5028

5029

AppendIfNeeded( (*env)[i], "/");

5030

}

5031

else // normal environment variables

5032

if( (resPtr = getenv((*name)[i].c_str())) )

5033

(*env)[i] = resPtr;

5034

}

5035

}

5036

5037

return env;

5038

}

5039

5040

BaseGDL* tag_names_fun( EnvT* e)

5041

{

5042

SizeT nParam=e->NParam();

5043

DStructGDL* struc= e->GetParAs<DStructGDL>(0);

5044

5045

static int structureNameIx = e->KeywordIx( "STRUCTURE_NAME" );

5046

bool structureName = e->KeywordSet( structureNameIx );

5047

5048

DStringGDL* tagNames;

5049

5050

if(structureName){

5051

5052

if ((*struc).Desc()->Name() != "$truct")

5053

tagNames = new DStringGDL((*struc).Desc()->Name());

5054

else

5055

tagNames = new DStringGDL("");

5056

5057

} else {

5058

SizeT nTags = (*struc).Desc()->NTags();

5059

5060

tagNames = new DStringGDL(dimension(nTags));

5061

for(int i=0; i < nTags; ++i)

5062

(*tagNames)[i] = (*struc).Desc()->TagName(i);

5063

}

5064

5065

return tagNames;

5066

}

5067

5068

// AC 12-Oc-2011: better version for: len=len, /Extract and /Sub

5069

// but it is still not perfect

5070

5071

BaseGDL* stregex_fun( EnvT* e)

5072

{

5073

SizeT nParam=e->NParam( 2);

5074

5075

DStringGDL* stringExpr= e->GetParAs<DStringGDL>(0);

5076

dimension dim = stringExpr->Dim();

5077

5078

DString pattern;

5079

e->AssureStringScalarPar(1, pattern);

5080

if (pattern.size() <= 0)

5081

{

5082

e->Throw( "Error processing regular expression: "+pattern+

5083

"\n empty (sub)expression");

5084

}

5085

5086

static int booleanIx = e->KeywordIx( "BOOLEAN" );

5087

bool booleanKW = e->KeywordSet( booleanIx );

5088

5089

static int extractIx = e->KeywordIx( "EXTRACT" );

5090

bool extractKW = e->KeywordSet( extractIx );

5091

5092

static int foldCaseIx = e->KeywordIx( "FOLD_CASE" );

5093

bool foldCaseKW = e->KeywordSet( foldCaseIx );

5094

5095

//XXXpch: this is wrong, should check arg_present

5096

static int lengthIx = e->KeywordIx( "LENGTH" );

5097

bool lengthKW = e->KeywordPresent( lengthIx );

5098

5099

static int subexprIx = e->KeywordIx( "SUBEXPR" );

5100

bool subexprKW = e->KeywordSet( subexprIx );

5101

5102

if( booleanKW && (subexprKW || extractKW || lengthKW))

5103

e->Throw( "Conflicting keywords.");

5104

5105

char err_msg[MAX_REGEXPERR_LENGTH];

5106

5107

// set the compile flags

5108

int cflags = REG_EXTENDED;

5109

if (foldCaseKW)

5110

cflags |= REG_ICASE;

5111

if (booleanKW)

5112

cflags |= REG_NOSUB;

5113

5114

// compile the regular expression

5115

regex_t regexp;

5116

int compRes = regcomp( &regexp, pattern.c_str(), cflags);

5117

SizeT nSubExpr = regexp.re_nsub + 1;

5118

5119

// cout << regexp.re_nsub << endl;

5120

5121

if (compRes) {

5122

regerror(compRes, &regexp, err_msg, MAX_REGEXPERR_LENGTH);

5123

e->Throw( "Error processing regular expression: "+

5124

pattern+"\n "+string(err_msg)+".");

5125

}

5126

5127

BaseGDL* result;

5128

5129

if( booleanKW)

5130

result = new DByteGDL(dim);

5131

else if( extractKW && !subexprKW)

5132

{

5133

// cout << "my pb ! ? dim= " << dim << endl;

5134

result = new DStringGDL(dim);

5135

}

5136

else if( subexprKW)

5137

{

5138

// cout << "my pb 2 ? dim= " << dim << endl;

5139

dimension subExprDim = dim;

5140

subExprDim >> nSubExpr; // m_schellens: commented in, needed

5141

if( extractKW)

5142

result = new DStringGDL(subExprDim);

5143

else

5144

result = new DLongGDL(subExprDim);

5145

}

5146

else

5147

result = new DLongGDL(dim);

5148

5149

DLongGDL* len = NULL;

5150

if( lengthKW) {

5151

e->AssureGlobalKW( lengthIx);

5152

if( subexprKW)

5153

{

5154

dimension subExprDim = dim;

5155

subExprDim >> nSubExpr; // m_schellens: commented in, needed

5156

len = new DLongGDL(subExprDim);

5157

}

5158

else

5159

{

5160

len = new DLongGDL(dim);

5161

}

5162

for( SizeT i=0; i<len->N_Elements(); ++i)

5163

(*len)[i]= -1;

5164

}

5165

5166

int nmatch = 1;

5167

if( subexprKW) nmatch = nSubExpr;

5168

5169

regmatch_t* pmatch = new regmatch_t[nSubExpr];

5170

ArrayGuard<regmatch_t> pmatchGuard( pmatch);

5171

5172

// cout << "dim " << dim.NDimElements() << endl;

5173

for( SizeT s=0; s<dim.NDimElements(); ++s)

5174

{

5175

int eflags = 0;

5176

5177

for( SizeT sE=0; sE<nSubExpr; ++sE)

5178

pmatch[sE].rm_so = -1;

5179

5180

// now match towards the string

5181

int matchres = regexec( &regexp, (*stringExpr)[s].c_str(), nmatch, pmatch, eflags);

5182

5183

// subexpressions

5184

if ( extractKW && subexprKW) {

5185

5186

// Loop through subexpressions & fill output array

5187

for( SizeT i = 0; i<nSubExpr; ++i) {

5188

if (pmatch[i].rm_so != -1)

5189

(*static_cast<DStringGDL*>(result))[i+s*nSubExpr] =

5190

(*stringExpr)[s].substr( pmatch[i].rm_so, pmatch[i].rm_eo - pmatch[i].rm_so);

5191

// (*stringExpr)[i+s*nSubExpr].substr( pmatch[i].rm_so, pmatch[i].rm_eo - pmatch[i].rm_so);

5192

if( lengthKW)

5193

(*len)[i+s*nSubExpr] = pmatch[i].rm_so != -1 ? pmatch[i].rm_eo - pmatch[i].rm_so : -1;

5194

// (*len)[i+s*nSubExpr] = pmatch[i].rm_eo - pmatch[i].rm_so;

5195

}

5196

}

5197

else if ( subexprKW)

5198

{

5199

// cout << "je ne comprends pas v2: "<< nSubExpr << endl;

5200

5201

// Loop through subexpressions & fill output array

5202

for( SizeT i = 0; i<nSubExpr; ++i) {

5203

(* static_cast<DLongGDL*>(result))[i+s*nSubExpr] = pmatch[i].rm_so;

5204

if( lengthKW)

5205

(*len)[i+s*nSubExpr] = pmatch[i].rm_so != -1 ? pmatch[i].rm_eo - pmatch[i].rm_so : -1;

5206

}

5207

}

5208

else

5209

{

5210

if( booleanKW)

5211

(* static_cast<DByteGDL*>(result))[s] = (matchres == 0);

5212

else if ( extractKW) // !subExprKW

5213

{

5214

if( matchres == 0)

5215

(* static_cast<DStringGDL*>(result))[s] =

5216

(*stringExpr)[s].substr( pmatch[0].rm_so,

5217

pmatch[0].rm_eo - pmatch[0].rm_so);

5218

}

5219

else

5220

(*static_cast<DLongGDL*>(result))[s] = matchres ? -1 : pmatch[0].rm_so;

5221

}

5222

5223

if( lengthKW && !subexprKW)

5224

(*len)[s] = pmatch[0].rm_eo - pmatch[0].rm_so;

5225

}

5226

5227

regfree( &regexp);

5228

5229

if( lengthKW)

5230

e->SetKW( lengthIx, len);

5231

5232

return result;

5233

}

5234

5235

BaseGDL* routine_info( EnvT* e)

5236

{

5237

SizeT nParam=e->NParam();

5238

5239

static int functionsIx = e->KeywordIx( "FUNCTIONS" );

5240

bool functionsKW = e->KeywordSet( functionsIx );

5241

static int systemIx = e->KeywordIx( "SYSTEM" );

5242

bool systemKW = e->KeywordSet( systemIx );

5243

static int disabledIx = e->KeywordIx( "DISABLED" );

5244

bool disabledKW = e->KeywordSet( disabledIx );

5245

static int parametersIx = e->KeywordIx( "PARAMETERS" );

5246

bool parametersKW = e->KeywordSet( parametersIx );

5247

5248

if (parametersKW)

5249

{

5250

// sanity checks

5251

if (systemKW || disabledKW) e->Throw("Conflicting keywords.");

5252

if (nParam != 1) e->Throw("Incorrect number of arguments.");

5253

5254

// getting the routine name from the first parameter

5255

DString name;

5256

e->AssureScalarPar<DStringGDL>(0, name);

5257

name = StrUpCase(name);

5258

5259

DSubUD* routine = functionsKW

5260

? static_cast<DSubUD*>(funList[GDLInterpreter::GetFunIx(name)])

5261

: static_cast<DSubUD*>(proList[GDLInterpreter::GetProIx(name)]);

5262

SizeT np = routine->NPar(), nk = routine->NKey();

5263

5264

// creating the output anonymous structure

5265

DStructDesc* stru_desc = new DStructDesc("$truct");

5266

SpDLong aLong;

5267

stru_desc->AddTag("NUM_ARGS", &aLong);

5268

stru_desc->AddTag("NUM_KW_ARGS", &aLong);

5269

if (np > 0)

5270

{

5271

SpDString aStringArr(dimension((int)np));

5272

stru_desc->AddTag("ARGS", &aStringArr);

5273

}

5274

if (nk > 0)

5275

{

5276

SpDString aStringArr(dimension((int)nk));

5277

stru_desc->AddTag("KW_ARGS", &aStringArr);

5278

}

5279

DStructGDL* stru = new DStructGDL(stru_desc, dimension());

5280

5281

// filling the structure with information about the routine

5282

stru->InitTag("NUM_ARGS", DLongGDL(np));

5283

stru->InitTag("NUM_KW_ARGS", DLongGDL(nk));

5284

if (np > 0)

5285

{

5286

DStringGDL *pnames = new DStringGDL(dimension(np));

5287

for (SizeT p = 0; p < np; ++p) (*pnames)[p] = routine->GetVarName(nk + p);

5288

stru->InitTag("ARGS", *pnames);

5289

delete pnames;

5290

}

5291

if (nk > 0)

5292

{

5293

DStringGDL *knames = new DStringGDL(dimension(nk));

5294

for (SizeT k = 0; k < nk; ++k) (*knames)[k] = routine->GetKWName(k);

5295

stru->InitTag("KW_ARGS", *knames);

5296

delete knames;

5297

}

5298

5299

// returning

5300

return stru;

5301

}

5302

5303

// GDL does not have disabled routines

5304

if( disabledKW) return new DStringGDL("");

5305

5306

// if( functionsKW || systemKW || nParam == 0)

5307

// {

5308

deque<DString> subList;

5309

5310

if( functionsKW)

5311

{

5312

if( systemKW)

5313

{

5314

SizeT n = libFunList.size();

5315

if( n == 0) return new DStringGDL("");

5316

5317

DStringGDL* res = new DStringGDL( dimension( n), BaseGDL::NOZERO);

5318

for( SizeT i = 0; i<n; ++i)

5319

(*res)[i] = libFunList[ i]->ObjectName();

5320

5321

return res;

5322

}

5323

else

5324

{

5325

SizeT n = funList.size();

5326

if( n == 0) return new DStringGDL("");

5327

subList.resize( n);

5328

5329

for( SizeT i = 0; i<n; ++i)

5330

subList.push_back( funList[ i]->ObjectName());

5331

}

5332

}

5333

else

5334

{

5335

if( systemKW)

5336

{

5337

SizeT n = libProList.size();

5338

if( n == 0) return new DStringGDL("");

5339

5340

DStringGDL* res = new DStringGDL( dimension( n), BaseGDL::NOZERO);

5341

for( SizeT i = 0; i<n; ++i)

5342

(*res)[i] = libProList[ i]->ObjectName();

5343

5344

return res;

5345

}

5346

else

5347

{

5348

SizeT n = proList.size();

5349

if( n == 0) return new DStringGDL("");

5350

subList.resize( n);

5351

5352

for( SizeT i = 0; i<n; ++i)

5353

subList.push_back( proList[ i]->ObjectName());

5354

}

5355

}

5356

5357

sort( subList.begin(), subList.end());

5358

SizeT nS = subList.size();

5359

5360

DStringGDL* res = new DStringGDL( dimension( nS), BaseGDL::NOZERO);

5361

for( SizeT s=0; s<nS; ++s)

5362

(*res)[ s] = subList[ s];

5363

5364

return res;

5365

// }

5366

}

5367

5368

BaseGDL* get_kbrd( EnvT* e)

5369

{

5370

SizeT nParam=e->NParam();

5371

5372

bool doWait = true;

5373

if( nParam > 0)

5374

{

5375

doWait = false;

5376

DLong waitArg = 0;

5377

e->AssureLongScalarPar( 0, waitArg);

5378

if( waitArg != 0)

5379

{

5380

doWait = true;

5381

}

5382

}

5383

5384

// if( doWait)

5385

// {

5386

5387

// char c = cin.get();

5388

// DStringGDL* res = new DStringGDL( DString( i2s( c)));

5389

// return res;

5390

// }

5391

// else

5392

// {

5393

// char c = cin.get();

5394

// DStringGDL* res = new DStringGDL( DString( i2s( c)));

5395

// return res;

5396

// }

5397

5398

// https://sourceforge.net/forum/forum.php?thread_id=3292183&forum_id=338691

5399

// TODO Implement proper SCALAR parameter handling (doWait variable?).

5400

5401

struct termios orig, get;

5402

(void)tcgetattr(fileno(stdin), &orig);

5403

get = orig;

5404

5405

// Disable terminal echoing and set it to non-canonical mode.

5406

get.c_lflag &= ~(ECHO|ICANON);

5407

5408

(void)tcsetattr(fileno(stdin), TCSANOW, &get);

5409

5410

char c = cin.get();

5411

5412

// Restore original terminal settings.

5413

(void)tcsetattr(fileno(stdin), TCSANOW, &orig);

5414

5415

DStringGDL* res = new DStringGDL( DString( i2s( c)));

5416

return res;

5417

}

5418

5419

5420

BaseGDL* temporary( EnvT* e)

5421

{

5422

SizeT nParam=e->NParam(1);

5423

5424

BaseGDL** p0 = &e->GetParDefined( 0);

5425

5426

BaseGDL* ret = *p0;

5427

5428

*p0 = NULL; // make parameter undefined

5429

return ret;

5430

}

5431

5432

BaseGDL* memory( EnvT* e)

5433

{

5434

SizeT nParam=e->NParam( 0);

5435

5436

BaseGDL* ret;

5437

bool kw_l64 = e->KeywordSet(e->KeywordIx("L64"));

5438

// TODO: IDL-doc mentions about automatically switching to L64 if needed

5439

5440

if (e->KeywordSet(e->KeywordIx("STRUCTURE")))

5441

{

5442

// returning structure

5443

if (kw_l64)

5444

{

5445

ret = new DStructGDL("IDL_MEMORY64");

5446

DStructGDL* retStru = static_cast<DStructGDL*>(ret);

5447

(retStru->GetTag(retStru->Desc()->TagIndex("CURRENT")))->InitFrom( DLong64GDL(MemStats::GetCurrent()));

5448

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_ALLOC")))->InitFrom( DLong64GDL(MemStats::GetNumAlloc()));

5449

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_FREE")))->InitFrom( DLong64GDL(MemStats::GetNumFree()));

5450

(retStru->GetTag(retStru->Desc()->TagIndex("HIGHWATER")))->InitFrom( DLong64GDL(MemStats::GetHighWater()));

5451

}

5452

else

5453

{

5454

ret = new DStructGDL("IDL_MEMORY");

5455

DStructGDL* retStru = static_cast<DStructGDL*>(ret);

5456

(retStru->GetTag(retStru->Desc()->TagIndex("CURRENT")))->InitFrom( DLongGDL(MemStats::GetCurrent()));

5457

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_ALLOC")))->InitFrom( DLongGDL(MemStats::GetNumAlloc()));

5458

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_FREE")))->InitFrom( DLongGDL(MemStats::GetNumFree()));

5459

(retStru->GetTag(retStru->Desc()->TagIndex("HIGHWATER")))->InitFrom( DLongGDL(MemStats::GetHighWater()));

5460

}

5461

}

5462

else

5463

{

5464

bool kw_current = e->KeywordSet(e->KeywordIx("CURRENT"));

5465

bool kw_num_alloc = e->KeywordSet(e->KeywordIx("NUM_ALLOC"));

5466

bool kw_num_free = e->KeywordSet(e->KeywordIx("NUM_FREE"));

5467

bool kw_highwater = e->KeywordSet(e->KeywordIx("HIGHWATER"));

5468

5469

// Following the IDL documentation: mutually exclusive keywords

5470

// IDL behaves different, incl. segfaults with selected kw combinations

5471

if (kw_current + kw_num_alloc + kw_num_free + kw_highwater > 1)

5472

e->Throw("CURRENT, NUM_ALLOC, NUM_FREE & HIGHWATER keywords"

5473

" are mutually exclusive");

5474

5475

if (kw_current)

5476

{

5477

if (kw_l64) ret = new DLong64GDL(MemStats::GetCurrent());

5478

else ret = new DLongGDL(MemStats::GetCurrent());

5479

}

5480

else if (kw_num_alloc)

5481

{

5482

if (kw_l64) ret = new DLong64GDL(MemStats::GetNumAlloc());

5483

else ret = new DLongGDL(MemStats::GetNumAlloc());

5484

}

5485

else if (kw_num_free)

5486

{

5487

if (kw_l64) ret = new DLong64GDL(MemStats::GetNumFree());

5488

else ret = new DLongGDL(MemStats::GetNumFree());

5489

}

5490

else if (kw_highwater)

5491

{

5492

if (kw_l64) ret = new DLong64GDL(MemStats::GetHighWater());

5493

else ret = new DLongGDL(MemStats::GetHighWater());

5494

}

5495

else

5496

{

5497

// returning 4-element array

5498

if (kw_l64)

5499

{

5500

ret = new DLong64GDL(dimension(4));

5501

(*static_cast<DLong64GDL*>(ret))[0] = MemStats::GetCurrent();

5502

(*static_cast<DLong64GDL*>(ret))[1] = MemStats::GetNumAlloc();

5503

(*static_cast<DLong64GDL*>(ret))[2] = MemStats::GetNumFree();

5504

(*static_cast<DLong64GDL*>(ret))[3] = MemStats::GetHighWater();

5505

}

5506

else

5507

{

5508

ret = new DLongGDL(dimension(4));

5509

(*static_cast<DLongGDL*>(ret))[0] = MemStats::GetCurrent();

5510

(*static_cast<DLongGDL*>(ret))[1] = MemStats::GetNumAlloc();

5511

(*static_cast<DLongGDL*>(ret))[2] = MemStats::GetNumFree();

5512

(*static_cast<DLongGDL*>(ret))[3] = MemStats::GetHighWater();

5513

}

5514

}

5515

}

5516

5517

return ret;

5518

}

5519

5520

inline DByte StrCmp( const string& s1, const string& s2, DLong n)

5521

{

5522

if( n <= 0) return 1;

5523

if( s1.substr(0,n) == s2.substr(0,n)) return 1;

5524

return 0;

5525

}

5526

inline DByte StrCmp( const string& s1, const string& s2)

5527

{

5528

if( s1 == s2) return 1;

5529

return 0;

5530

}

5531

inline DByte StrCmpFold( const string& s1, const string& s2, DLong n)

5532

{

5533

if( n <= 0) return 1;

5534

if( StrUpCase( s1.substr(0,n)) == StrUpCase(s2.substr(0,n))) return 1;

5535

return 0;

5536

}

5537

inline DByte StrCmpFold( const string& s1, const string& s2)

5538

{

5539

if( StrUpCase( s1) == StrUpCase(s2)) return 1;

5540

return 0;

5541

}

5542

5543

BaseGDL* strcmp_fun( EnvT* e)

5544

{

5545

SizeT nParam=e->NParam(2);

5546

5547

DStringGDL* s0 = static_cast<DStringGDL*>( e->GetParAs< DStringGDL>( 0));

5548

DStringGDL* s1 = static_cast<DStringGDL*>( e->GetParAs< DStringGDL>( 1));

5549

5550

DLongGDL* l2 = NULL;

5551

if( nParam > 2)

5552

{

5553

l2 = static_cast<DLongGDL*>( e->GetParAs< DLongGDL>( 2));

5554

}

5555

5556

static int foldIx = e->KeywordIx( "FOLD_CASE");

5557

bool fold = e->KeywordSet( foldIx );

5558

5559

if( s0->Scalar() && s1->Scalar())

5560

{

5561

if( l2 == NULL)

5562

{

5563

if( fold)

5564

return new DByteGDL( StrCmpFold( (*s0)[0], (*s1)[0]));

5565

else

5566

return new DByteGDL( StrCmp( (*s0)[0], (*s1)[0]));

5567

}

5568

else

5569

{

5570

DByteGDL* res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5571

SizeT nEl = l2->N_Elements();

5572

if( fold)

5573

for( SizeT i=0; i<nEl; ++i)

5574

(*res)[i] = StrCmpFold( (*s0)[0], (*s1)[0], (*l2)[i]);

5575

else

5576

for( SizeT i=0; i<nEl; ++i)

5577

(*res)[i] = StrCmp( (*s0)[0], (*s1)[0], (*l2)[i]);

5578

return res;

5579

}

5580

}

5581

else // at least one array

5582

{

5583

if( l2 == NULL)

5584

{

5585

if( s0->Scalar())

5586

{

5587

DByteGDL* res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5588

SizeT nEl = s1->N_Elements();

5589

if( fold)

5590

for( SizeT i=0; i<nEl; ++i)

5591

(*res)[i] = StrCmpFold( (*s0)[0], (*s1)[i]);

5592

else

5593

for( SizeT i=0; i<nEl; ++i)

5594

(*res)[i] = StrCmp( (*s0)[0], (*s1)[i]);

5595

return res;

5596

}

5597

else if( s1->Scalar())

5598

{

5599

DByteGDL* res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5600

SizeT nEl = s0->N_Elements();

5601

if( fold)

5602

for( SizeT i=0; i<nEl; ++i)

5603

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[0]);

5604

else

5605

for( SizeT i=0; i<nEl; ++i)

5606

(*res)[i] = StrCmp( (*s0)[i], (*s1)[0]);

5607

return res;

5608

}

5609

else // both arrays

5610

{

5611

DByteGDL* res;

5612

SizeT nEl;

5613

if( s0->N_Elements() <= s1->N_Elements())

5614

{

5615

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5616

nEl = s0->N_Elements();

5617

}

5618

else

5619

{

5620

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5621

nEl = s1->N_Elements();

5622

}

5623

if( fold)

5624

for( SizeT i=0; i<nEl; ++i)

5625

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[i]);

5626

else

5627

for( SizeT i=0; i<nEl; ++i)

5628

(*res)[i] = StrCmp( (*s0)[i], (*s1)[i]);

5629

return res;

5630

}

5631

}

5632

else // l2 != NULL

5633

{

5634

DByteGDL* res;

5635

SizeT nEl;

5636

bool l2Scalar = l2->Scalar();

5637

if( s0->Scalar())

5638

{

5639

if( l2Scalar || s1->N_Elements() <= l2->N_Elements())

5640

{

5641

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5642

nEl = s1->N_Elements();

5643

}

5644

else

5645

{

5646

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5647

nEl = l2->N_Elements();

5648

}

5649

if( fold)

5650

for( SizeT i=0; i<nEl; ++i)

5651

(*res)[i] = StrCmpFold( (*s0)[0], (*s1)[i], (*l2)[l2Scalar?0:i]);

5652

else

5653

for( SizeT i=0; i<nEl; ++i)

5654

(*res)[i] = StrCmp( (*s0)[0], (*s1)[i], (*l2)[l2Scalar?0:i]);

5655

return res;

5656

}

5657

else if( s1->Scalar())

5658

{

5659

if( l2Scalar || s0->N_Elements() <= l2->N_Elements())

5660

{

5661

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5662

nEl = s0->N_Elements();

5663

}

5664

else

5665

{

5666

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5667

nEl = l2->N_Elements();

5668

}

5669

if( fold)

5670

for( SizeT i=0; i<nEl; ++i)

5671

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[0], (*l2)[l2Scalar?0:i]);

5672

else

5673

for( SizeT i=0; i<nEl; ++i)

5674

(*res)[i] = StrCmp( (*s0)[i], (*s1)[0], (*l2)[l2Scalar?0:i]);

5675

return res;

5676

}

5677

else // s1 and s2 are arrays

5678

{

5679

if( l2Scalar)

5680

if( s0->N_Elements() <= s1->N_Elements())

5681

{

5682

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5683

nEl = s0->N_Elements();

5684

}

5685

else

5686

{

5687

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5688

nEl = s1->N_Elements();

5689

}

5690

else

5691

{

5692

if( s0->N_Elements() <= s1->N_Elements())

5693

if( s0->N_Elements() <= l2->N_Elements())

5694

{

5695

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5696

nEl = s0->N_Elements();

5697

}

5698

else

5699

{

5700

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5701

nEl = l2->N_Elements();

5702

}

5703

else

5704

if( s1->N_Elements() <= l2->N_Elements())

5705

{

5706

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5707

nEl = s1->N_Elements();

5708

}

5709

else

5710

{

5711

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5712

nEl = l2->N_Elements();

5713

}

5714

}

5715

if( fold)

5716

for( SizeT i=0; i<nEl; ++i)

5717

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[i], (*l2)[l2Scalar?0:i]);

5718

else

5719

for( SizeT i=0; i<nEl; ++i)

5720

(*res)[i] = StrCmp( (*s0)[i], (*s1)[i], (*l2)[l2Scalar?0:i]);

5721

return res;

5722

}

5723

}

5724

}

5725

}

5726

5727

string TagName( EnvT* e, const string& name)

5728

{

5729

string n = StrUpCase( name);

5730

SizeT len = n.size();

5731

if( n[0] != '_' && n[0] != '!' && (n[0] < 'A' || n[0] > 'Z'))

5732

e->Throw( "Illegal tag name: "+name+".");

5733

for( SizeT i=1; i<len; ++i)

5734

{

5735

if( n[i] == ' ')

5736

n[i] = '_';

5737

else

5738

if( n[i] != '_' && n[i] != '$' && //n[0] != '!' &&

5739

(n[i] < 'A' || n[i] > 'Z') &&

5740

(n[i] < '0' || n[i] > '9'))

5741

e->Throw( "Illegal tag name: "+name+".");

5742

}

5743

return n;

5744

}

5745

5746

BaseGDL* create_struct( EnvT* e)

5747

{

5748

static int nameIx = e->KeywordIx( "NAME" );

5749

DString name = "$truct";

5750

if( e->KeywordPresent( nameIx)) {

5751

// Check if name exists, if not then treat as unnamed

5752

if (e->GetKW( nameIx) != NULL)

5753

e->AssureStringScalarKW( nameIx, name);

5754

}

5755

5756

if( name != "$truct") // named struct

5757

{

5758

name = StrUpCase( name);

5759

5760

SizeT nParam=e->NParam();

5761

5762

if( nParam == 0)

5763

{

5764

DStructDesc* desc =

5765

e->Interpreter()->GetStruct( name, e->CallingNode());

5766

5767

dimension dim( 1);

5768

return new DStructGDL( desc, dim);

5769

}

5770

5771

DStructDesc* nStructDesc;

5772

auto_ptr<DStructDesc> nStructDescGuard;

5773

5774

DStructDesc* oStructDesc=

5775

FindInStructList( structList, name);

5776

5777

if( oStructDesc == NULL || oStructDesc->NTags() > 0)

5778

{

5779

// not defined at all yet (-> define now)

5780

// or completely defined (-> define now and check equality)

5781

nStructDesc= new DStructDesc( name);

5782

5783

// guard it

5784

nStructDescGuard.reset( nStructDesc);

5785

}

5786

else

5787

{

5788

// NTags() == 0

5789

// not completely defined (only name in list)

5790

nStructDesc= oStructDesc;

5791

}

5792

5793

// the instance variable

5794

// dimension dim( 1);

5795

// DStructGDL* instance = new DStructGDL( nStructDesc, dim);

5796

DStructGDL* instance = new DStructGDL( nStructDesc);

5797

auto_ptr<DStructGDL> instance_guard(instance);

5798

5799

for( SizeT p=0; p<nParam; ++p)

5800

{

5801

BaseGDL* par = e->GetParDefined( p);

5802

DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);

5803

if( parStruct != NULL)

5804

{

5805

// add struct

5806

if( !parStruct->Scalar())

5807

e->Throw("Expression must be a scalar in this context: "+

5808

e->GetParString( p));

5809

5810

DStructDesc* desc = parStruct->Desc();

5811

for( SizeT t=0; t< desc->NTags(); ++t)

5812

{

5813

instance->NewTag( desc->TagName( t),

5814

parStruct->GetTag( t)->Dup());

5815

}

5816

}

5817

else

5818

{

5819

// add tag value pair

5820

DStringGDL* tagNames = e->GetParAs<DStringGDL>( p);

5821

SizeT nTags = tagNames->N_Elements();

5822

5823

SizeT tagStart = p+1;

5824

SizeT tagEnd = p+nTags;

5825

if( tagEnd >= nParam)

5826

e->Throw( "Incorrect number of arguments.");

5827

5828

do{

5829

++p;

5830

BaseGDL* value = e->GetParDefined( p);

5831

5832

// add

5833

instance->NewTag( TagName( e, (*tagNames)[ p-tagStart]),

5834

value->Dup());

5835

}

5836

while( p<tagEnd);

5837

}

5838

}

5839

5840

if( oStructDesc != NULL)

5841

{

5842

if( oStructDesc != nStructDesc)

5843

{

5844

oStructDesc->AssureIdentical(nStructDesc);

5845

instance->DStructGDL::SetDesc(oStructDesc);

5846

//delete nStructDesc; // auto_ptr

5847

}

5848

}

5849

else

5850

{

5851

// release from guard (if not NULL)

5852

nStructDescGuard.release();

5853

// insert into struct list

5854

structList.push_back(nStructDesc);

5855

}

5856

5857

instance_guard.release();

5858

return instance;

5859

}

5860

else

5861

{ // unnamed struc

5862

5863

// Handle case of single structure parameter

5864

SizeT nParam;

5865

nParam = e->NParam(1);

5866

BaseGDL* par = e->GetParDefined( 0);

5867

DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);

5868

if (nParam != 1 || parStruct == NULL)

5869

nParam=e->NParam(2);

5870

5871

DStructDesc* nStructDesc = new DStructDesc( "$truct");

5872

// instance takes care of nStructDesc since it is unnamed

5873

// dimension dim( 1);

5874

// DStructGDL* instance = new DStructGDL( nStructDesc, dim);

5875

DStructGDL* instance = new DStructGDL( nStructDesc);

5876

auto_ptr<DStructGDL> instance_guard(instance);

5877

5878

for( SizeT p=0; p<nParam;)

5879

{

5880

BaseGDL* par = e->GetParDefined( p);

5881

DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);

5882

if( parStruct != NULL)

5883

{

5884

// add struct

5885

if( !parStruct->Scalar())

5886

e->Throw("Expression must be a scalar in this context: "+

5887

e->GetParString( p));

5888

5889

DStructDesc* desc = parStruct->Desc();

5890

for( SizeT t=0; t< desc->NTags(); ++t)

5891

{

5892

instance->NewTag( desc->TagName( t),

5893

parStruct->GetTag( t)->Dup());

5894

}

5895

++p;

5896

}

5897

else

5898

{

5899

// add tag value pair

5900

DStringGDL* tagNames = e->GetParAs<DStringGDL>( p);

5901

SizeT nTags = tagNames->N_Elements();

5902

5903

SizeT tagStart = p+1;

5904

SizeT tagEnd = p+nTags;

5905

if( tagEnd >= nParam)

5906

e->Throw( "Incorrect number of arguments.");

5907

5908

for(++p; p<=tagEnd; ++p)

5909

{

5910

BaseGDL* value = e->GetParDefined( p);

5911

5912

// add

5913

instance->NewTag( TagName( e, (*tagNames)[ p-tagStart]),

5914

value->Dup());

5915

}

5916

}

5917

}

5918

5919

instance_guard.release();

5920

return instance;

5921

}

5922

}

5923

5924

BaseGDL* rotate( EnvT* e)

5925

{

5926

e->NParam(2);

5927

BaseGDL* p0 = e->GetParDefined( 0);

5928

5929

if( p0->Rank() == 0)

5930

e->Throw( "Expression must be an array in this context: " + e->GetParString( 0));

5931

5932

if( p0->Rank() != 1 && p0->Rank() != 2)

5933

e->Throw( "Only 1 or 2 dimensions allowed: " + e->GetParString( 0));

5934

5935

if( p0->Type() == STRUCT)

5936

e->Throw( "STRUCT expression not allowed in this context: "+

5937

e->GetParString( 0));

5938

5939

DLong dir;

5940

e->AssureLongScalarPar( 1, dir);

5941

5942

return p0->Rotate( dir);

5943

}

5944

5945

// SA: based on the code of rotate() (above)

5946

BaseGDL* reverse( EnvT* e)

5947

{

5948

e->NParam(1);

5949

BaseGDL* p0 = e->GetParDefined(0);

5950

if (p0->Rank() == 0) return p0->Dup();

5951

5952

DLong dim = 1;

5953

if (e->GetPar(1) != NULL)

5954

e->AssureLongScalarPar(1, dim);

5955

if (p0->Rank() != 0 && (dim > p0->Rank() || dim < 1))

5956

e->Throw("Subscript_index must be positive and less than or equal to number of dimensions.");

5957

5958

BaseGDL* ret;

5959

// IDL doc states that OVERWRITE is ignored for one- or two-dim. arrays

5960

// but it seems to behave differently

5961

// if (p0->Rank() > 2 && e->KeywordSet("OVERWRITE") && e->GlobalPar(0))

5962

if (e->KeywordSet("OVERWRITE"))

5963

{

5964

p0->Reverse(dim-1);

5965

bool stolen = e->StealLocalPar( 0);

5966

if( !stolen) e->GetPar(0) = NULL;

5967

return p0;

5968

}

5969

else ret = p0->DupReverse(dim - 1);

5970

return ret;

5971

}

5972

5973

// SA: parse_url based on the PHP parse_url() function code

5974

// by Jim Winstead / The PHP Group (PHP license v. 3.01)

5975

// (http://svn.php.net/viewvc/php/php-src/trunk/ext/standard/url.c)

5976

// PHP is free software available at http://www.php.net/software/

5977

//

5978

// notes:

5979

// - IDL does not support IPv6 URLs, GDL does

5980

// - IDL includes characters after '#' in the QUERY part, GDL

5981

// just skips them and issues a warning (perhaps not needed)

5982

// - IDL preserves controll characters in URLs, GDL preserves

5983

// them as well but a warning is issued

5984

// - IDL sets 80 as a default value for PORT, even if the url has

5985

// an ftp:// schema indicated - GDL does not have any default value

5986

// - IDL excludes the leading "/" from the path, GDL preserves it

5987

// ... these differences seem just rational for me but please do change

5988

// it if IDL-compatibility would be beneficial for any reason here

5989

5990

BaseGDL* parse_url(EnvT* env)

5991

{

5992

// sanity check for number of parameters

5993

SizeT nParam = env->NParam();

5994

5995

// 1-nd argument : the url string

5996

DString url;

5997

env->AssureScalarPar<DStringGDL>(0, url);

5998

5999

// sanity check for controll characters

6000

string::iterator it;

6001

for (it = url.begin(); it < url.end(); it++) if (iscntrl(*it))

6002

{

6003

Warning("PARSE_URL: URL contains a control character");

6004

break;

6005

}

6006

6007

// creating the output anonymous structure

6008

DStructDesc* urlstru_desc = new DStructDesc("$truct");

6009

SpDString aString;

6010

urlstru_desc->AddTag("SCHEME", &aString);

6011

static size_t ixSCHEME = 0;

6012

urlstru_desc->AddTag("USERNAME", &aString);

6013

urlstru_desc->AddTag("PASSWORD", &aString);

6014

urlstru_desc->AddTag("HOST", &aString);

6015

urlstru_desc->AddTag("PORT", &aString);

6016

static size_t ixPORT = 4;

6017

urlstru_desc->AddTag("PATH", &aString);

6018

urlstru_desc->AddTag("QUERY", &aString);

6019

DStructGDL* urlstru = new DStructGDL(urlstru_desc, dimension());

6020

auto_ptr<DStructGDL> urlstru_guard(urlstru);

6021

6022

// parsing the URL

6023

char const *str = url.c_str();

6024

size_t length = url.length();

6025

char port_buf[6];

6026

char const *s, *e, *p, *pp, *ue;

6027

6028

s = str;

6029

ue = s + length;

6030

6031

// parsing scheme

6032

if ((e = (const char*)memchr(s, ':', length)) && (e - s))

6033

{

6034

// validating scheme

6035

p = s;

6036

while (p < e)

6037

{

6038

// scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]

6039

if (!isalpha(*p) && !isdigit(*p) && *p != '+' && *p != '.' && *p != '-')

6040

{

6041

if (e + 1 < ue) goto parse_port;

6042

else goto just_path;

6043

}

6044

p++;

6045

}

6046

if (*(e + 1) == '\0')

6047

{

6048

// only scheme is available

6049

urlstru->InitTag("SCHEME", DStringGDL(string(s, (e - s))));

6050

goto end;

6051

}

6052

// schemas without '/' (like mailto: and zlib:)

6053

if (*(e+1) != '/')

6054

{

6055

// check if the data we get is a port this allows us to correctly parse things like a.com:80

6056

p = e + 1;

6057

while (isdigit(*p)) p++;

6058

if ((*p == '\0' || *p == '/') && (p - e) < 7) goto parse_port;

6059

urlstru->InitTag("SCHEME", DStringGDL(string(s, (e - s))));

6060

length -= ++e - s;

6061

s = e;

6062

goto just_path;

6063

}

6064

else

6065

{

6066

urlstru->InitTag("SCHEME", DStringGDL(string(s, (e - s))));

6067

if (*(e+2) == '/')

6068

{

6069

s = e + 3;

6070

if (!strncasecmp("file",

6071

(*static_cast<DStringGDL*>(urlstru->GetTag(ixSCHEME)))[0].c_str(),

6072

sizeof("file")

6073

))

6074

{

6075

if (*(e + 3) == '/')

6076

{

6077

// support windows drive letters as in: file:///c:/somedir/file.txt

6078

if (*(e + 5) == ':') s = e + 4;

6079

goto nohost;

6080

}

6081

}

6082

}

6083

else

6084

{

6085

if (!strncasecmp("file",

6086

(*static_cast<DStringGDL*>(urlstru->GetTag(ixSCHEME)))[0].c_str(),

6087

sizeof("file"))

6088

)

6089

{

6090

s = e + 1;

6091

goto nohost;

6092

}

6093

else

6094

{

6095

length -= ++e - s;

6096

s = e;

6097

goto just_path;

6098

}

6099

}

6100

}

6101

}

6102

else if (e)

6103

{

6104

// no scheme, look for port

6105

parse_port:

6106

p = e + 1;

6107

pp = p;

6108

while (pp-p < 6 && isdigit(*pp)) pp++;

6109

if (pp-p < 6 && (*pp == '/' || *pp == '\0'))

6110

{

6111

memcpy(port_buf, p, (pp-p));

6112

port_buf[pp-p] = '\0';

6113

urlstru->InitTag("PORT", DStringGDL(port_buf));

6114

}

6115

else goto just_path;

6116

}

6117

else

6118

{

6119

just_path:

6120

ue = s + length;

6121

goto nohost;

6122

}

6123

e = ue;

6124

if (!(p = (const char*)memchr(s, '/', (ue - s))))

6125

{

6126

if ((p = (const char*)memchr(s, '?', (ue - s)))) e = p;

6127

else if ((p = (const char*)memchr(s, '#', (ue - s)))) e = p;

6128

}

6129

else e = p;

6130

// check for login and password

6131

{

6132

size_t pos;

6133

if ((pos = string(s, e - s).find_last_of("@")) != string::npos)

6134

{

6135

p = s + pos;

6136

if ((pp = (const char*)memchr(s, ':', (p-s))))

6137

{

6138

if ((pp-s) > 0) urlstru->InitTag("USERNAME", DStringGDL(string(s, (pp - s))));

6139

pp++;

6140

if (p-pp > 0) urlstru->InitTag("PASSWORD", DStringGDL(string(pp, (p - pp))));

6141

}

6142

else urlstru->InitTag("USERNAME", DStringGDL(string(s, (p - s))));

6143

s = p + 1;

6144

}

6145

}

6146

// check for port

6147

if (*s == '[' && *(e-1) == ']') p = s; // IPv6 embedded address

6148

else for(p = e; *p != ':' && p >= s; p--); // memrchr is a GNU extension

6149

if (p >= s && *p == ':')

6150

{

6151

if ((*static_cast<DStringGDL*>(urlstru->GetTag(ixPORT)))[0].length() == 0)

6152

{

6153

p++;

6154

if (e-p > 5) env->Throw("port cannot be longer then 5 characters");

6155

else if (e - p > 0)

6156

{

6157

memcpy(port_buf, p, (e-p));

6158

port_buf[e-p] = '\0';

6159

urlstru->InitTag("PORT", DStringGDL(port_buf));

6160

}

6161

p--;

6162

}

6163

}

6164

else p = e;

6165

// check if we have a valid host, if we don't reject the string as url

6166

if ((p-s) < 1) env->Throw("invalid host");

6167

urlstru->InitTag("HOST", DStringGDL(string(s, (p - s))));

6168

if (e == ue) goto end;

6169

s = e;

6170

nohost:

6171

if ((p = (const char*)memchr(s, '?', (ue - s))))

6172

{

6173

pp = strchr(s, '#');

6174

if (pp && pp < p)

6175

{

6176

p = pp;

6177

pp = strchr(pp+2, '#');

6178

}

6179

if (p - s) urlstru->InitTag("PATH", DStringGDL(string(s, (p - s))));

6180

if (pp)

6181

{

6182

if (pp - ++p) urlstru->InitTag("QUERY", DStringGDL(string(p, (pp - p))));

6183

p = pp;

6184

goto label_parse;

6185

}

6186

else if (++p - ue) urlstru->InitTag("QUERY", DStringGDL(string(p, (ue - p))));

6187

}

6188

else if ((p = (const char*)memchr(s, '#', (ue - s))))

6189

{

6190

if (p - s) urlstru->InitTag("PATH", DStringGDL(string(s, (p - s))));

6191

label_parse:

6192

p++;

6193

if (ue - p) Warning("PARSE_URL: URL fragment left out: #" + string(p, (ue-p)));

6194

}

6195

else urlstru->InitTag("PATH", DStringGDL(string(s, (ue - s))));

6196

end:

6197

6198

// returning the result

6199

urlstru_guard.release();

6200

return urlstru;

6201

}

6202

6203

BaseGDL* locale_get(EnvT* e)

6204

{

6205

#ifdef HAVE_LOCALE_H

6206

6207

// make GDL inherit the calling process locale

6208

setlocale(LC_ALL, "");

6209

// note doen the inherited locale

6210

DStringGDL *locale = new DStringGDL(setlocale(LC_CTYPE, NULL));

6211

// return to the C locale

6212

setlocale(LC_ALL, "C");

6213

6214

return locale;

6215

#else

6216

e->Throw("OS does not provide locale information");

6217

#endif

6218

}

6219

6220

// SA: relies on the contents of the lib::command_line_args vector

6221

// defined and filled with data (pointers) in gdl.cpp

6222

BaseGDL* command_line_args_fun(EnvT* e)

6223

{

6224

#ifdef PYTHON_MODULE

6225

e->Throw("no command line arguments available (GDL built as a Python module)");

6226

#else

6227

static int countIx = e->KeywordIx("COUNT");

6228

extern std::vector<char*> command_line_args;

6229

6230

// setting the COUNT keyword value

6231

if (e->KeywordPresent(countIx))

6232

{

6233

e->AssureGlobalKW(countIx);

6234

e->SetKW(countIx, new DLongGDL(command_line_args.size()));

6235

}

6236

6237

// returning empty string or an array of arguments

6238

if (command_line_args.empty()) return new DStringGDL("");

6239

else

6240

{

6241

BaseGDL* ret = new DStringGDL(dimension(command_line_args.size()));

6242

for (size_t i = 0; i < command_line_args.size(); i++)

6243

(*static_cast<DStringGDL*>(ret))[i] = command_line_args[i];

6244

return ret;

6245

}

6246

#endif

6247

}

6248

6249

// SA: relies in the uname() from libc (must be there if POSIX)

6250

BaseGDL* get_login_info( EnvT* e)

6251

{

6252

// getting the info

6253

char* login = getlogin();

6254

if (login == NULL) e->Throw("Failed to get user name from the OS");

6255

struct utsname info;

6256

if (0 != uname(&info)) e->Throw("Failed to get machine name from the OS");

6257

6258

// creating the output anonymous structure

6259

DStructDesc* stru_desc = new DStructDesc("$truct");

6260

SpDString aString;

6261

stru_desc->AddTag("MACHINE_NAME", &aString);

6262

stru_desc->AddTag("USER_NAME", &aString);

6263

DStructGDL* stru = new DStructGDL(stru_desc, dimension());

6264

6265

// returning the info

6266

stru->InitTag("USER_NAME", DStringGDL(login));

6267

stru->InitTag("MACHINE_NAME", DStringGDL(info.nodename));

6268

return stru;

6269

}

6270

6271

// SA: base64 logic in base64.hpp, based on code by Bob Withers (consult base64.hpp)

6272

BaseGDL* idl_base64(EnvT* e)

6273

{

6274

BaseGDL* p0 = e->GetPar(0);

6275

if (p0 != NULL)

6276

{

6277

if (p0->Rank() == 0 && p0->Type() == STRING)

6278

{

6279

// decoding

6280

string* str = &((*static_cast<DStringGDL*>(p0))[0]);

6281

if (str->length() == 0) return new DByteGDL(0);

6282

if (str->length() % 4 != 0)

6283

e->Throw("Input string length must be a multiple of 4");

6284

unsigned int retlen = base64::decodeSize(*str);

6285

if (retlen == 0 || retlen > str->length()) e->Throw("No data in the input string");

6286

DByteGDL* ret = new DByteGDL(dimension(retlen));

6287

if (!base64::decode(*str, (char*)&((*ret)[0]), ret->N_Elements()))

6288

e->Throw("Base64 decoder failed");

6289

return ret;

6290

}

6291

if (p0->Rank() >= 1 && p0->Type() == BYTE)

6292

{

6293

// encoding

6294

return new DStringGDL(

6295

base64::encode((char*)&(*static_cast<DByteGDL*>(p0))[0], p0->N_Elements())

6296

);

6297

}

6298

}

6299

e->Throw("Expecting string or byte array as a first parameter");

6300

}

6301

6302

BaseGDL* get_drive_list(EnvT* e)

6303

{

6304

if (e->KeywordPresent(0)) e->SetKW(0, new DLongGDL(0));

6305

return new DStringGDL("");

6306

}

6307

6308

} // namespace

6309

1

/***************************************************************************

2

basic_fun.cpp - basic GDL library function

3

-------------------

4

begin : July 22 2002

5

6

email : m_schellens@users.sf.net

7

8

strtok_fun, getenv_fun, tag_names_fun, stregex_fun:

9

10

11

***************************************************************************/

12

13

/***************************************************************************

14

* *

15

* This program is free software; you can redistribute it and/or modify *

16

* it under the terms of the GNU General Public License as published by *

17

* the Free Software Foundation; either version 2 of the License, or *

18

* (at your option) any later version. *

19

* *

20

***************************************************************************/

21

22

#include "includefirst.hpp"

23

24

// get_kbrd patch

25

// http://sourceforge.net/forum/forum.php?thread_id=3292183&forum_id=338691

26

#ifndef _MSC_VER

27

#include <termios.h>

28

#include <unistd.h>

29

#endif

30

#include <limits>

31

#include <string>

32

#include <fstream>

33

//#include <memory>

34

#include <regex.h> // stregex

35

36

#ifdef __APPLE__

37

# include <crt_externs.h>

38

# define environ (*_NSGetEnviron())

39

#endif

40

41

#if defined(__FreeBSD__) || defined(__sun__) || defined(__OpenBSD__)

42

extern "C" char **environ;

43

#endif

44

45

#include "nullgdl.hpp"

46

#include "datatypes.hpp"

47

#include "envt.hpp"

48

#include "dpro.hpp"

49

#include "dinterpreter.hpp"

50

#include "basic_pro.hpp"

51

#include "terminfo.hpp"

52

#include "typedefs.hpp"

53

#include "base64.hpp"

54

55

#ifdef HAVE_LOCALE_H

56

# include <locale.h>

57

#endif

58

59

/* max regexp error message length */

60

#define MAX_REGEXPERR_LENGTH 80

61

62

#ifdef _MSC_VER

63

#define isfinite _finite

64

#define isnan _isnan

65

#define round(f) floor(f+0.5)

66

int strncasecmp(const char *s1, const char *s2, size_t n)

67

{

68

if (n == 0)

69

return 0;

70

while (n-- != 0 && tolower(*s1) == tolower(*s2))

71

{

72

if (n == 0 || *s1 == '\0' || *s2 == '\0')

73

break;

74

s1++;

75

s2++;

76

}

77

78

return tolower(*(unsigned char *) s1) - tolower(*(unsigned char *) s2);

79

}

80

#else

81

#include <sys/utsname.h>

82

#endif

83

84

namespace lib {

85

86

using namespace std;

87

using namespace antlr;

88

89

// assumes all parameters from pOffs till end are dim

90

void arr( EnvT* e, dimension& dim, SizeT pOffs=0)

91

{

92

93

int nParam=e->NParam()-pOffs;

94

95

if( nParam <= 0)

96

e->Throw( "Incorrect number of arguments.");

97

98

const string BadDims="Array dimensions must be greater than 0.";

99

100

101

if( nParam == 1 ) {

102

103

BaseGDL* par = e->GetParDefined( pOffs);

104

105

SizeT newDim;

106

int ret = par->Scalar2index( newDim);

107

108

if (ret < 0) throw GDLException(BadDims);

109

110

if( ret > 0) { // single argument

111

if (newDim < 1) throw GDLException(BadDims);

112

dim << newDim;

113

return;

114

}

115

if( ret == 0) { // array argument

116

DLongGDL* ind =

117

static_cast<DLongGDL*>(par->Convert2(GDL_LONG, BaseGDL::COPY));

118

auto_ptr<DLongGDL> ind_guard( ind);

119

//e->Guard( ind);

120

121

for(SizeT i =0; i < par->N_Elements(); ++i){

122

if ((*ind)[i] < 1) throw GDLException(BadDims);

123

dim << (*ind)[i];

124

}

125

return;

126

}

127

e->Throw( "arr: should never arrive here.");

128

return;

129

}

130

131

// max number checked in interpreter

132

SizeT endIx=nParam+pOffs;

133

for( SizeT i=pOffs; i<endIx; i++)

134

{

135

BaseGDL* par=e->GetParDefined( i);

136

137

SizeT newDim;

138

int ret=par->Scalar2index( newDim);

139

if( ret < 1 || newDim == 0) throw GDLException(BadDims);

140

dim << newDim;

141

}

142

}

143

144

BaseGDL* bytarr( EnvT* e)

145

{

146

dimension dim;

147

// try{

148

arr( e, dim);

149

if (dim[0] == 0)

150

throw GDLException( "Array dimensions must be greater than 0");

151

152

if( e->KeywordSet(0)) return new DByteGDL(dim, BaseGDL::NOZERO);

153

return new DByteGDL(dim);

154

// }

155

// catch( GDLException& ex)

156

// {

157

// e->Throw( ex.getMessage());

158

// }

159

}

160

BaseGDL* intarr( EnvT* e)

161

{

162

dimension dim;

163

// try{

164

arr( e, dim);

165

if (dim[0] == 0)

166

throw GDLException( "Array dimensions must be greater than 0");

167

168

if( e->KeywordSet(0)) return new DIntGDL(dim, BaseGDL::NOZERO);

169

return new DIntGDL(dim);

170

// }

171

// catch( GDLException& ex)

172

// {

173

// e->Throw( "INTARR: "+ex.getMessage());

174

// }

175

}

176

BaseGDL* uintarr( EnvT* e)

177

{

178

dimension dim;

179

// try{

180

arr( e, dim);

181

if (dim[0] == 0)

182

throw GDLException( "Array dimensions must be greater than 0");

183

184

if( e->KeywordSet(0)) return new DUIntGDL(dim, BaseGDL::NOZERO);

185

return new DUIntGDL(dim);

186

// }

187

// catch( GDLException& ex)

188

// {

189

// e->Throw( "UINTARR: "+ex.getMessage());

190

// }

191

}

192

BaseGDL* lonarr( EnvT* e)

193

{

194

dimension dim;

195

// try{

196

arr( e, dim);

197

if (dim[0] == 0)

198

throw GDLException( "Array dimensions must be greater than 0");

199

200

if( e->KeywordSet(0)) return new DLongGDL(dim, BaseGDL::NOZERO);

201

return new DLongGDL(dim);

202

/* }

203

catch( GDLException& ex)

204

{

205

e->Throw( "LONARR: "+ex.getMessage());

206

}*/

207

}

208

BaseGDL* ulonarr( EnvT* e)

209

{

210

dimension dim;

211

// try{

212

arr( e, dim);

213

if (dim[0] == 0)

214

throw GDLException( "Array dimensions must be greater than 0");

215

216

if( e->KeywordSet(0)) return new DULongGDL(dim, BaseGDL::NOZERO);

217

return new DULongGDL(dim);

218

/* }

219

catch( GDLException& ex)

220

{

221

e->Throw( "ULONARR: "+ex.getMessage());

222

}

223

*/

224

}

225

BaseGDL* lon64arr( EnvT* e)

226

{

227

dimension dim;

228

// try{

229

arr( e, dim);

230

if (dim[0] == 0)

231

throw GDLException( "Array dimensions must be greater than 0");

232

233

if( e->KeywordSet(0)) return new DLong64GDL(dim, BaseGDL::NOZERO);

234

return new DLong64GDL(dim);

235

/* }

236

catch( GDLException& ex)

237

{

238

e->Throw( "LON64ARR: "+ex.getMessage());

239

}*/

240

}

241

BaseGDL* ulon64arr( EnvT* e)

242

{

243

dimension dim;

244

// try{

245

arr( e, dim);

246

if (dim[0] == 0)

247

throw GDLException( "Array dimensions must be greater than 0");

248

249

if( e->KeywordSet(0)) return new DULong64GDL(dim, BaseGDL::NOZERO);

250

return new DULong64GDL(dim);

251

/* }

252

catch( GDLException& ex)

253

{

254

e->Throw( "ULON64ARR: "+ex.getMessage());

255

}*/

256

}

257

BaseGDL* fltarr( EnvT* e)

258

{

259

dimension dim;

260

// try{

261

arr( e, dim);

262

if (dim[0] == 0)

263

throw GDLException( "Array dimensions must be greater than 0");

264

265

if( e->KeywordSet(0)) return new DFloatGDL(dim, BaseGDL::NOZERO);

266

return new DFloatGDL(dim);

267

/* }

268

catch( GDLException& ex)

269

{

270

e->Throw( "FLTARR: "+ex.getMessage());

271

}

272

*/}

273

BaseGDL* dblarr( EnvT* e)

274

{

275

dimension dim;

276

// try{

277

arr( e, dim);

278

if (dim[0] == 0)

279

throw GDLException( "Array dimensions must be greater than 0");

280

281

if( e->KeywordSet(0)) return new DDoubleGDL(dim, BaseGDL::NOZERO);

282

return new DDoubleGDL(dim);

283

/* }

284

catch( GDLException& ex)

285

{

286

e->Throw( "DBLARR: "+ex.getMessage());

287

}*/

288

}

289

BaseGDL* strarr( EnvT* e)

290

{

291

dimension dim;

292

// try{

293

arr( e, dim);

294

if (dim[0] == 0)

295

throw GDLException( "Array dimensions must be greater than 0");

296

297

if( e->KeywordSet(0))

298

e->Throw( "Keyword parameters not allowed in call.");

299

return new DStringGDL(dim);

300

/* }

301

catch( GDLException& ex)

302

{

303

e->Throw( "STRARR: "+ex.getMessage());

304

}

305

*/ }

306

BaseGDL* complexarr( EnvT* e)

307

{

308

dimension dim;

309

// try{

310

arr( e, dim);

311

if (dim[0] == 0)

312

throw GDLException( "Array dimensions must be greater than 0");

313

314

if( e->KeywordSet(0)) return new DComplexGDL(dim, BaseGDL::NOZERO);

315

return new DComplexGDL(dim);

316

/*}

317

catch( GDLException& ex)

318

{

319

e->Throw( "COMPLEXARR: "+ex.getMessage());

320

}

321

*/ }

322

BaseGDL* dcomplexarr( EnvT* e)

323

{

324

dimension dim;

325

// try{

326

arr( e, dim);

327

if (dim[0] == 0)

328

329

if( e->KeywordSet(0)) return new DComplexDblGDL(dim, BaseGDL::NOZERO);

330

return new DComplexDblGDL(dim);

331

/* }

332

catch( GDLException& ex)

333

{

334

e->Throw( "DCOMPLEXARR: "+ex.getMessage());

335

}

336

*/ }

337

BaseGDL* ptrarr( EnvT* e)

338

{

339

dimension dim;

340

// try{

341

arr( e, dim);

342

if (dim[0] == 0)

343

throw GDLException( "Array dimensions must be greater than 0");

344

345

DPtrGDL* ret;

346

347

// if( e->KeywordSet(0))

348

// ret= new DPtrGDL(dim);//, BaseGDL::NOZERO);

349

// else

350

// if( e->KeywordSet(1))

351

// ret= new DPtrGDL(dim, BaseGDL::NOZERO);

352

// else

353

// return new DPtrGDL(dim);

354

if( !e->KeywordSet(1))

355

return new DPtrGDL(dim);

356

357

ret= new DPtrGDL(dim, BaseGDL::NOZERO);

358

359

SizeT nEl=ret->N_Elements();

360

SizeT sIx=e->NewHeap(nEl);

361

// #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))

362

{

363

// #pragma omp for

364

for( SizeT i=0; i<nEl; i++)

365

(*ret)[i]=sIx+i;

366

}

367

return ret;

368

/* }

369

catch( GDLException& ex)

370

{

371

e->Throw( "PTRARR: "+ex.getMessage());

372

}*/

373

}

374

BaseGDL* objarr( EnvT* e)

375

{

376

dimension dim;

377

// try{

378

arr( e, dim);

379

if (dim[0] == 0)

380

throw GDLException( "Array dimensions must be greater than 0");

381

382

// reference counting if( e->KeywordSet(0)) return new DObjGDL(dim, BaseGDL::NOZERO);

383

return new DObjGDL(dim);

384

/* }

385

catch( GDLException& ex)

386

{

387

e->Throw( "OBJARR: "+ex.getMessage());

388

}

389

*/ }

390

391

BaseGDL* ptr_new( EnvT* e)

392

{

393

int nParam=e->NParam();

394

395

if( nParam > 0)

396

{

397

// new ptr from undefined variable is allowed as well

398

BaseGDL* p= e->GetPar( 0);

399

if( p == NULL)

400

{

401

DPtr heapID= e->NewHeap();

402

return new DPtrGDL( heapID);

403

}

404

405

if( e->KeywordSet(0)) // NO_COPY

406

{

407

BaseGDL** p= &e->GetPar( 0);

408

// if( *p == NULL)

409

// e->Throw( "Parameter undefined: "+

410

// e->GetParString(0));

411

412

DPtr heapID= e->NewHeap( 1, *p);

413

*p=NULL;

414

return new DPtrGDL( heapID);

415

}

416

else

417

{

418

BaseGDL* p= e->GetParDefined( 0);

419

420

DPtr heapID= e->NewHeap( 1, p->Dup());

421

return new DPtrGDL( heapID);

422

}

423

}

424

else

425

{

426

if( e->KeywordSet(1)) // ALLOCATE_HEAP

427

{

428

DPtr heapID= e->NewHeap();

429

return new DPtrGDL( heapID);

430

}

431

else

432

{

433

return new DPtrGDL( 0); // null ptr

434

}

435

}

436

}

437

438

BaseGDL* ptr_valid( EnvT* e)

439

{

440

int nParam=e->NParam();

441

442

if( e->KeywordPresent( 1)) // COUNT

443

{

444

e->SetKW( 1, new DLongGDL( e->Interpreter()->HeapSize()));

445

}

446

447

if( nParam == 0)

448

{

449

return e->Interpreter()->GetAllHeap();

450

}

451

452

BaseGDL* p = e->GetPar( 0);

453

if( p == NULL)

454

{

455

return new DByteGDL( 0);

456

}

457

458

if( e->KeywordSet( 0)) // CAST

459

{

460

DLongGDL* pL = dynamic_cast<DLongGDL*>( p);

461

auto_ptr<DLongGDL> pL_guard;

462

if( pL == NULL)

463

{

464

pL = static_cast<DLongGDL*>(p->Convert2(GDL_LONG,BaseGDL::COPY));

465

pL_guard.reset( pL);

466

}

467

468

SizeT nEl = pL->N_Elements();

469

DPtrGDL* ret = new DPtrGDL( pL->Dim()); // zero

470

GDLInterpreter* interpreter = e->Interpreter();

471

for( SizeT i=0; i<nEl; ++i)

472

{

473

if( interpreter->PtrValid( (*pL)[ i]))

474

(*ret)[ i] = (*pL)[ i];

475

}

476

return ret;

477

}

478

479

DPtrGDL* pPtr = dynamic_cast<DPtrGDL*>( p);

480

if( pPtr == NULL)

481

{

482

return new DByteGDL( p->Dim()); // zero

483

}

484

485

SizeT nEl = pPtr->N_Elements();

486

DByteGDL* ret = new DByteGDL( pPtr->Dim()); // zero

487

GDLInterpreter* interpreter = e->Interpreter();

488

for( SizeT i=0; i<nEl; ++i)

489

{

490

if( interpreter->PtrValid( (*pPtr)[ i]))

491

(*ret)[ i] = 1;

492

}

493

return ret;

494

}

495

496

BaseGDL* obj_valid( EnvT* e)

497

{

498

int nParam=e->NParam();

499

500

if( e->KeywordPresent( 1)) // COUNT

501

{

502

e->SetKW( 1, new DLongGDL( e->Interpreter()->ObjHeapSize()));

503

}

504

505

if( nParam == 0)

506

{

507

return e->Interpreter()->GetAllObjHeap();

508

}

509

510

BaseGDL* p = e->GetPar( 0);

511

if( p == NULL)

512

{

513

return new DByteGDL( 0);

514

}

515

516

if( e->KeywordSet( 0)) // CAST

517

{

518

DLongGDL* pL = dynamic_cast<DLongGDL*>( p);

519

auto_ptr<DLongGDL> pL_guard;

520

if( pL == NULL)

521

{

522

pL = static_cast<DLongGDL*>(p->Convert2(GDL_LONG,BaseGDL::COPY));

523

pL_guard.reset( pL);

524

// e->Guard( pL);

525

}

526

527

SizeT nEl = pL->N_Elements();

528

DObjGDL* ret = new DObjGDL( pL->Dim()); // zero

529

GDLInterpreter* interpreter = e->Interpreter();

530

for( SizeT i=0; i<nEl; ++i)

531

{

532

if( interpreter->ObjValid( (*pL)[ i]))

533

(*ret)[ i] = (*pL)[ i];

534

}

535

return ret;

536

}

537

538

DObjGDL* pObj = dynamic_cast<DObjGDL*>( p);

539

if( pObj == NULL)

540

{

541

return new DByteGDL( p->Dim()); // zero

542

}

543

544

SizeT nEl = pObj->N_Elements();

545

DByteGDL* ret = new DByteGDL( pObj->Dim()); // zero

546

GDLInterpreter* interpreter = e->Interpreter();

547

for( SizeT i=0; i<nEl; ++i)

548

{

549

if( interpreter->ObjValid( (*pObj)[ i]))

550

(*ret)[ i] = 1;

551

}

552

return ret;

553

}

554

555

BaseGDL* obj_new( EnvT* e)

556

{

557

StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());

558

559

int nParam=e->NParam();

560

561

if( nParam == 0)

562

{

563

return new DObjGDL( 0);

564

}

565

566

DString objName;

567

e->AssureScalarPar<DStringGDL>( 0, objName);

568

569

// this is a struct name -> convert to UPPERCASE

570

objName=StrUpCase(objName);

571

if( objName == "IDL_OBJECT")

572

objName = GDL_OBJECT_NAME; // replacement also done in GDLParser

573

574

DStructDesc* objDesc=e->Interpreter()->GetStruct( objName, e->CallingNode());

575

576

DStructGDL* objStruct= new DStructGDL( objDesc, dimension());

577

578

DObj objID= e->NewObjHeap( 1, objStruct); // owns objStruct

579

580

BaseGDL* newObj = new DObjGDL( objID); // the object

581

582

try {

583

// call INIT function

584

DFun* objINIT= objDesc->GetFun( "INIT");

585

if( objINIT != NULL)

586

{

587

// morph to obj environment and push it onto the stack again

588

e->PushNewEnvUD( objINIT, 1, &newObj);

589

590

BaseGDL* res=e->Interpreter()->call_fun( objINIT->GetTree());

591

592

if( res == NULL || (!res->Scalar()) || res->False())

593

{

594

GDLDelete(res);

595

return new DObjGDL( 0);

596

}

597

GDLDelete(res);

598

}

599

} catch(...) {

600

e->FreeObjHeap( objID); // newObj might be changed

601

GDLDelete(newObj);

602

throw;

603

}

604

605

return newObj;

606

}

607

608

BaseGDL* bindgen( EnvT* e)

609

{

610

dimension dim;

611

// try{

612

arr( e, dim);

613

if (dim[0] == 0)

614

throw GDLException( "Array dimensions must be greater than 0");

615

616

return new DByteGDL(dim, BaseGDL::INDGEN);

617

/* }

618

catch( GDLException& ex)

619

{

620

e->Throw( "BINDGEN: "+ex.getMessage());

621

}

622

*/ }

623

// keywords not supported yet

624

BaseGDL* indgen( EnvT* e)

625

{

626

dimension dim;

627

628

// Defaulting to GDL_INT

629

DType type = GDL_INT;

630

631

static int kwIx1 = e->KeywordIx("BYTE");

632

if (e->KeywordSet(kwIx1)){ type = GDL_BYTE; }

633

634

static int kwIx2 = e->KeywordIx("COMPLEX");

635

if (e->KeywordSet(kwIx2)){ type = GDL_COMPLEX; }

636

637

static int kwIx3 = e->KeywordIx("DCOMPLEX");

638

if (e->KeywordSet(kwIx3)){ type = GDL_COMPLEXDBL; }

639

640

static int kwIx4 = e->KeywordIx("DOUBLE");

641

if (e->KeywordSet(kwIx4)){ type = GDL_DOUBLE; }

642

643

static int kwIx5 = e->KeywordIx("FLOAT");

644

if (e->KeywordSet(kwIx5)){ type = GDL_FLOAT; }

645

646

static int kwIx6 = e->KeywordIx("L64");

647

if (e->KeywordSet(kwIx6)){ type = GDL_LONG64; }

648

649

static int kwIx7 = e->KeywordIx("LONG");

650

if (e->KeywordSet(kwIx7)){ type = GDL_LONG; }

651

652

static int kwIx8 = e->KeywordIx("STRING");

653

if (e->KeywordSet(kwIx8)){ type = GDL_STRING; }

654

655

static int kwIx9 = e->KeywordIx("UINT");

656

if (e->KeywordSet(kwIx9)){ type = GDL_UINT; }

657

658

static int kwIx10 = e->KeywordIx("UL64");

659

if (e->KeywordSet(kwIx10)){ type = GDL_ULONG64; }

660

661

static int kwIx11 = e->KeywordIx("ULONG");

662

if (e->KeywordSet(kwIx11)){ type = GDL_ULONG; }

663

664

/*try

665

{*/

666

// Seeing if the user passed in a TYPE code

667

static int kwIx12 = e->KeywordIx("TYPE");

668

if ( e->KeywordPresent(kwIx12)){

669

DLong temp_long;

670

e->AssureLongScalarKW(kwIx12, temp_long);

671

type = static_cast<DType>(temp_long);

672

}

673

674

arr(e, dim);

675

if (dim[0] == 0)

676

throw GDLException( "Array dimensions must be greater than 0");

677

678

switch(type)

679

{

680

case GDL_INT: return new DIntGDL(dim, BaseGDL::INDGEN);

681

case GDL_BYTE: return new DByteGDL(dim, BaseGDL::INDGEN);

682

case GDL_COMPLEX: return new DComplexGDL(dim, BaseGDL::INDGEN);

683

case GDL_COMPLEXDBL: return new DComplexDblGDL(dim, BaseGDL::INDGEN);

684

case GDL_DOUBLE: return new DDoubleGDL(dim, BaseGDL::INDGEN);

685

case GDL_FLOAT: return new DFloatGDL(dim, BaseGDL::INDGEN);

686

case GDL_LONG64: return new DLong64GDL(dim, BaseGDL::INDGEN);

687

case GDL_LONG: return new DLongGDL(dim, BaseGDL::INDGEN);

688

case GDL_STRING: {

689

DULongGDL* iGen = new DULongGDL(dim, BaseGDL::INDGEN);

690

return iGen->Convert2(GDL_STRING);

691

}

692

case GDL_UINT: return new DUIntGDL(dim, BaseGDL::INDGEN);

693

case GDL_ULONG64: return new DULong64GDL(dim, BaseGDL::INDGEN);

694

case GDL_ULONG: return new DULongGDL(dim, BaseGDL::INDGEN);

695

default:

696

e->Throw( "Invalid type code specified.");

697

break;

698

}

699

/* }

700

catch( GDLException& ex)

701

{

702

e->Throw( ex.getMessage());

703

}*/

704

}

705

706

BaseGDL* uindgen( EnvT* e)

707

{

708

dimension dim;

709

// try{

710

arr( e, dim);

711

if (dim[0] == 0)

712

throw GDLException( "Array dimensions must be greater than 0");

713

714

return new DUIntGDL(dim, BaseGDL::INDGEN);

715

/* }

716

catch( GDLException& ex)

717

{

718

e->Throw( "UINDGEN: "+ex.getMessage());

719

}

720

*/ }

721

BaseGDL* sindgen( EnvT* e)

722

{

723

dimension dim;

724

// try{

725

arr( e, dim);

726

if (dim[0] == 0)

727

throw GDLException( "Array dimensions must be greater than 0");

728

729

DULongGDL* iGen = new DULongGDL(dim, BaseGDL::INDGEN);

730

return iGen->Convert2( GDL_STRING);

731

/* }

732

catch( GDLException& ex)

733

{

734

e->Throw( "SINDGEN: "+ex.getMessage());

735

}*/

736

}

737

BaseGDL* lindgen( EnvT* e)

738

{

739

dimension dim;

740

// try{

741

arr( e, dim);

742

return new DLongGDL(dim, BaseGDL::INDGEN);

743

/* }

744

catch( GDLException& ex)

745

{

746

e->Throw( "LINDGEN: "+ex.getMessage());

747

}*/

748

}

749

BaseGDL* ulindgen( EnvT* e)

750

{

751

dimension dim;

752

// try{

753

arr( e, dim);

754

if (dim[0] == 0)

755

throw GDLException( "Array dimensions must be greater than 0");

756

757

return new DULongGDL(dim, BaseGDL::INDGEN);

758

/* }

759

catch( GDLException& ex)

760

{

761

e->Throw( "ULINDGEN: "+ex.getMessage());

762

}*/

763

}

764

BaseGDL* l64indgen( EnvT* e)

765

{

766

dimension dim;

767

// try{

768

arr( e, dim);

769

if (dim[0] == 0)

770

throw GDLException( "Array dimensions must be greater than 0");

771

772

return new DLong64GDL(dim, BaseGDL::INDGEN);

773

/* }

774

catch( GDLException& ex)

775

{

776

e->Throw( "L64INDGEN: "+ex.getMessage());

777

}*/

778

}

779

BaseGDL* ul64indgen( EnvT* e)

780

{

781

dimension dim;

782

// try{

783

arr( e, dim);

784

if (dim[0] == 0)

785

throw GDLException( "Array dimensions must be greater than 0");

786

787

return new DULong64GDL(dim, BaseGDL::INDGEN);

788

/* }

789

catch( GDLException& ex)

790

{

791

e->Throw( "UL64INDGEN: "+ex.getMessage());

792

}

793

*/ }

794

BaseGDL* findgen( EnvT* e)

795

{

796

dimension dim;

797

// try{

798

arr( e, dim);

799

if (dim[0] == 0)

800

throw GDLException( "Array dimensions must be greater than 0");

801

802

return new DFloatGDL(dim, BaseGDL::INDGEN);

803

/* }

804

catch( GDLException& ex)

805

{

806

e->Throw( "FINDGEN: "+ex.getMessage());

807

}*/

808

}

809

BaseGDL* dindgen( EnvT* e)

810

{

811

dimension dim;

812

// try{

813

arr( e, dim);

814

if (dim[0] == 0)

815

throw GDLException( "Array dimensions must be greater than 0");

816

817

return new DDoubleGDL(dim, BaseGDL::INDGEN);

818

/* }

819

catch( GDLException& ex)

820

{

821

e->Throw( "DINDGEN: "+ex.getMessage());

822

}*/

823

}

824

BaseGDL* cindgen( EnvT* e)

825

{

826

dimension dim;

827

// try{

828

arr( e, dim);

829

if (dim[0] == 0)

830

throw GDLException( "Array dimensions must be greater than 0");

831

832

return new DComplexGDL(dim, BaseGDL::INDGEN);

833

/* }

834

catch( GDLException& ex)

835

{

836

e->Throw( "CINDGEN: "+ex.getMessage());

837

}*/

838

}

839

BaseGDL* dcindgen( EnvT* e)

840

{

841

dimension dim;

842

// try{

843

arr( e, dim);

844

if (dim[0] == 0)

845

throw GDLException( "Array dimensions must be greater than 0");

846

847

return new DComplexDblGDL(dim, BaseGDL::INDGEN);

848

/* }

849

catch( GDLException& ex)

850

{

851

e->Throw( "DCINDGEN: "+ex.getMessage());

852

}

853

*/ }

854

855

// only called from CALL_FUNCTION

856

// otherwise done directly in FCALL_LIB_N_ELEMENTSNode::Eval();

857

// (but must be defined anyway for LibInit() for correct parametrization)

858

// N_ELEMENTS is special because on error it just returns 0L

859

// (the error is just caught and dropped)

860

BaseGDL* n_elements( EnvT* e)

861

{

862

SizeT nParam=e->NParam(1);

863

864

BaseGDL* p0=e->GetPar( 0);

865

866

if( p0 == NULL) return new DLongGDL( 0);

867

return new DLongGDL( p0->N_Elements());

868

869

// assert( 0);

870

// e->Throw("Internal error: lib::n_elements called.");

871

// return NULL; // get rid of compiler warning

872

}

873

874

template< typename ComplexGDL, typename Complex, typename Float>

875

BaseGDL* complex_fun_template( EnvT* e)

876

{

877

SizeT nParam=e->NParam( 1);

878

if( nParam <= 2)

879

{

880

if( nParam == 2)

881

{

882

BaseGDL* p0=e->GetParDefined( 0);

883

BaseGDL* p1=e->GetParDefined( 1);

884

auto_ptr<Float> p0Float( static_cast<Float*>

885

(p0->Convert2( Float::t,BaseGDL::COPY)));

886

auto_ptr<Float> p1Float( static_cast<Float*>

887

(p1->Convert2( Float::t,BaseGDL::COPY)));

888

if( p0Float->Rank() == 0)

889

{

890

ComplexGDL* res = new ComplexGDL( p1Float->Dim(),

891

BaseGDL::NOZERO);

892

893

SizeT nE=p1Float->N_Elements();

894

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

895

{

896

// #pragma omp for

897

for( SizeT i=0; i<nE; i++)

898

{

899

(*res)[i]=Complex( (*p0Float)[0], (*p1Float)[i]);

900

}

901

}

902

return res;

903

}

904

else if( p1Float->Rank() == 0)

905

{

906

ComplexGDL* res = new ComplexGDL( p0Float->Dim(),

907

BaseGDL::NOZERO);

908

909

SizeT nE=p0Float->N_Elements();

910

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

911

{

912

// #pragma omp for

913

for( SizeT i=0; i<nE; i++)

914

{

915

(*res)[i]=Complex( (*p0Float)[i], (*p1Float)[0]);

916

}

917

}

918

return res;

919

}

920

else if( p0Float->N_Elements() >= p1Float->N_Elements())

921

{

922

ComplexGDL* res = new ComplexGDL( p1Float->Dim(),

923

BaseGDL::NOZERO);

924

925

SizeT nE=p1Float->N_Elements();

926

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

927

{

928

// #pragma omp for

929

for( SizeT i=0; i<nE; i++)

930

{

931

(*res)[i]=Complex( (*p0Float)[i], (*p1Float)[i]);

932

}

933

}

934

return res;

935

}

936

else

937

{

938

ComplexGDL* res = new ComplexGDL( p0Float->Dim(),

939

BaseGDL::NOZERO);

940

941

SizeT nE=p0Float->N_Elements();

942

// #pragma omp parallel if (nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE))

943

{

944

// #pragma omp for

945

for( SizeT i=0; i<nE; i++)

946

{

947

(*res)[i]=Complex( (*p0Float)[i], (*p1Float)[i]);

948

}

949

}

950

return res;

951

}

952

}

953

else

954

{

955

// SA: see tracker item 3151760

956

BaseGDL* p0 = e->GetParDefined( 0);

957

if (ComplexGDL::t == p0->Type() && e->GlobalPar(0)) return p0;

958

return p0->Convert2( ComplexGDL::t, BaseGDL::COPY);

959

}

960

}

961

else // GDL_COMPLEX( expr, offs, dim1,..,dim8)

962

{

963

BaseGDL* p0 = e->GetParDefined( 0);

964

// *** WRONG: with offs data is converted bytewise

965

auto_ptr<Float> p0Float(static_cast<Float*>

966

(p0->Convert2( Float::t,

967

BaseGDL::COPY)));

968

DLong offs;

969

e->AssureLongScalarPar( 1, offs);

970

971

dimension dim;

972

arr( e, dim, 2);

973

974

SizeT nElCreate=dim.NDimElements();

975

976

SizeT nElSource=p0->N_Elements();

977

978

if( (offs+2*nElCreate) > nElSource)

979

e->Throw( "Specified offset to"

980

" array is out of range: "+e->GetParString(0));

981

982

ComplexGDL* res=new ComplexGDL( dim, BaseGDL::NOZERO);

983

984

// #pragma omp parallel if (nElCreate >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nElCreate))

985

{

986

// #pragma omp for

987

for( SizeT i=0; i<nElCreate; i++)

988

{

989

SizeT srcIx=2*i+offs;

990

(*res)[i]=Complex( (*p0Float)[srcIx], (*p0Float)[srcIx+1]);

991

}

992

}

993

return res;

994

}

995

}

996

997

BaseGDL* complex_fun( EnvT* e)

998

{

999

if (e->KeywordSet("DOUBLE")) {

1000

return complex_fun_template< DComplexDblGDL, DComplexDbl, DDoubleGDL>( e);

1001

} else {

1002

return complex_fun_template< DComplexGDL, DComplex, DFloatGDL>( e);

1003

}

1004

}

1005

BaseGDL* dcomplex_fun( EnvT* e)

1006

{

1007

return complex_fun_template< DComplexDblGDL, DComplexDbl, DDoubleGDL>( e);

1008

}

1009

1010

template< class TargetClass>

1011

BaseGDL* type_fun( EnvT* e)

1012

{

1013

SizeT nParam=e->NParam(1);

1014

1015

if( nParam == 1)

1016

{

1017

BaseGDL* p0=e->GetParDefined( 0);

1018

1019

assert( dynamic_cast< EnvUDT*>( e->Caller()) != NULL);

1020

1021

// type_fun( expr) just convert

1022

if( static_cast< EnvUDT*>( e->Caller())->GetIOError() != NULL)

1023

return p0->Convert2( TargetClass::t,

1024

BaseGDL::COPY_THROWIOERROR);

1025

// SA: see tracker item no. 3151760

1026

else if (TargetClass::t == p0->Type() && e->GlobalPar(0))

1027

return p0;

1028

else

1029

return p0->Convert2( TargetClass::t, BaseGDL::COPY);

1030

}

1031

1032

BaseGDL* p0=e->GetNumericParDefined( 0);

1033

1034

// GDL_BYTE( expr, offs, dim1,..,dim8)

1035

DLong offs;

1036

e->AssureLongScalarPar( 1, offs);

1037

1038

dimension dim;

1039

1040

if( nParam > 2)

1041

arr( e, dim, 2);

1042

1043

TargetClass* res=new TargetClass( dim, BaseGDL::NOZERO);

1044

1045

SizeT nByteCreate=res->NBytes(); // net size of new data

1046

1047

SizeT nByteSource=p0->NBytes(); // net size of src

1048

1049

if( offs < 0 || (offs+nByteCreate) > nByteSource)

1050

{

1051

GDLDelete(res);

1052

e->Throw( "Specified offset to"

1053

" expression is out of range: "+e->GetParString(0));

1054

}

1055

1056

//*** POSSIBLE ERROR because of alignment here

1057

void* srcAddr = static_cast<void*>( static_cast<char*>(p0->DataAddr()) +

1058

offs);

1059

void* dstAddr = static_cast<void*>(&(*res)[0]);

1060

memcpy( dstAddr, srcAddr, nByteCreate);

1061

1062

// char* srcAddr = reinterpret_cast<char*>(p0->DataAddr());

1063

// char* dstAddr = reinterpret_cast<char*>(&(*res)[0]);

1064

// copy( srcAddr, srcAddr+nByteCreate, dstAddr);

1065

1066

return res;

1067

}

1068

1069

BaseGDL* byte_fun( EnvT* e)

1070

{

1071

return type_fun<DByteGDL>( e);

1072

}

1073

BaseGDL* uint_fun( EnvT* e)

1074

{

1075

return type_fun<DUIntGDL>( e);

1076

}

1077

BaseGDL* long_fun( EnvT* e)

1078

{

1079

return type_fun<DLongGDL>( e);

1080

}

1081

BaseGDL* ulong_fun( EnvT* e)

1082

{

1083

return type_fun<DULongGDL>( e);

1084

}

1085

BaseGDL* long64_fun( EnvT* e)

1086

{

1087

return type_fun<DLong64GDL>( e);

1088

}

1089

BaseGDL* ulong64_fun( EnvT* e)

1090

{

1091

return type_fun<DULong64GDL>( e);

1092

}

1093

BaseGDL* float_fun( EnvT* e)

1094

{

1095

return type_fun<DFloatGDL>( e);

1096

}

1097

BaseGDL* double_fun( EnvT* e)

1098

{

1099

return type_fun<DDoubleGDL>( e);

1100

}

1101

// GDL_STRING function behaves different

1102

BaseGDL* string_fun( EnvT* e)

1103

{

1104

SizeT nParam=e->NParam();

1105

1106

if( nParam == 0)

1107

e->Throw( "Incorrect number of arguments.");

1108

1109

bool printKey = e->KeywordSet( 4);

1110

int parOffset = 0;

1111

1112

// SA: handling special VMS-compatibility syntax, e.g.: string(1,'$(F)')

1113

// (if nor FORMAT neither PRINT defined, >1 parameter, last param is scalar string

1114

// which begins with "$(" or "(" but is not "()" then last param [minus "$"] is treated as FORMAT)

1115

bool vmshack = false;

1116

if (!printKey && (e->GetKW(0) == NULL) && nParam > 1)

1117

{

1118

vmshack = true;

1119

BaseGDL* par = e->GetParDefined(nParam - 1);

1120

if (par->Type() == GDL_STRING && par->Scalar())

1121

{

1122

int dollar = (*static_cast<DStringGDL*>(par))[0].compare(0,2,"$(");

1123

if (dollar == 0 || ((*static_cast<DStringGDL*>(par))[0].compare(0,1,"(") == 0 && (*static_cast<DStringGDL*>(par))[0] != "()"))

1124

{

1125

e->SetKeyword("FORMAT", new DStringGDL(

1126

(*static_cast<DStringGDL*>(par))[0].c_str() + (dollar == 0 ? 1 : 0)

1127

));

1128

}

1129

}

1130

}

1131

1132

BaseGDL* format_kw = e->GetKW( 0);

1133

bool formatKey = format_kw != NULL;

1134

1135

if (formatKey && format_kw->Type() == GDL_STRING && (*static_cast<DStringGDL*>(format_kw))[0] == "") formatKey = false;

1136

1137

if( printKey || formatKey) // PRINT or FORMAT

1138

{

1139

stringstream os;

1140

1141

SizeT width = 0;

1142

if( printKey) // otherwise: FORMAT -> width is ignored

1143

{

1144

// for /PRINT always a terminal width of 80 is assumed

1145

width = 80;//TermWidth();

1146

}

1147

1148

if (vmshack)

1149

{

1150

parOffset = 1;

1151

e->ShiftParNumbering(1);

1152

}

1153

print_os( &os, e, parOffset, width);

1154

if (vmshack)

1155

{

1156

e->ShiftParNumbering(-1);

1157

}

1158

1159

deque<DString> buf;

1160

while( os.good())

1161

{

1162

string line;

1163

getline( os, line);

1164

if( os.good()) buf.push_back( line);

1165

}

1166

1167

SizeT bufSize = buf.size();

1168

if( bufSize == 0)

1169

e->Throw( "Internal error: print buffer empty.");

1170

1171

if( bufSize > 1)

1172

{

1173

DStringGDL* retVal =

1174

new DStringGDL( dimension( bufSize), BaseGDL::NOZERO);

1175

1176

for( SizeT i=0; i<bufSize; ++i)

1177

(*retVal)[ i] = buf[ i];

1178

1179

return retVal;

1180

}

1181

else

1182

return new DStringGDL( buf[0]);

1183

}

1184

else

1185

{

1186

if( nParam == 1) // nParam == 1 -> conversion

1187

{

1188

BaseGDL* p0 = e->GetParDefined( 0);

1189

// SA: see tracker item no. 3151760

1190

if (p0->Type() == GDL_STRING && e->GlobalPar(0)) return p0;

1191

return p0->Convert2( GDL_STRING, BaseGDL::COPY);

1192

}

1193

else // concatenation

1194

{

1195

DString s;

1196

for( SizeT i=0; i<nParam; ++i)

1197

{

1198

BaseGDL* p = e->GetParDefined( i);

1199

DStringGDL* sP = static_cast<DStringGDL*>

1200

( p->Convert2(GDL_STRING,

1201

BaseGDL::COPY_BYTE_AS_INT));

1202

1203

SizeT nEl = sP->N_Elements();

1204

for( SizeT e=0; e<nEl; ++e)

1205

s += (*sP)[ e];

1206

GDLDelete(sP);

1207

}

1208

// IDL here breaks the string into tty-width substrings

1209

return new DStringGDL( s);

1210

}

1211

}

1212

}

1213

1214

BaseGDL* fix_fun( EnvT* e)

1215

{

1216

DIntGDL* type = e->IfDefGetKWAs<DIntGDL>( 0);

1217

if (type != NULL) {

1218

int typ = (*type)[0];

1219

if (typ == GDL_BYTE)

1220

{

1221

// SA: slow yet simple solution using GDL_BYTE->GDL_INT->GDL_BYTE conversion

1222

return (e->KeywordSet(1) && e->GetPar(0)->Type() == GDL_STRING)

1223

? type_fun<DIntGDL>( e)->Convert2(GDL_BYTE, BaseGDL::CONVERT)

1224

: type_fun<DByteGDL>( e);

1225

}

1226

if (typ == 0 || typ == GDL_INT) return type_fun<DIntGDL>( e);

1227

if (typ == GDL_UINT) return type_fun<DUIntGDL>( e);

1228

if (typ == GDL_LONG) return type_fun<DLongGDL>( e);

1229

if (typ == GDL_ULONG) return type_fun<DULongGDL>( e);

1230

if (typ == GDL_LONG64) return type_fun<DLong64GDL>( e);

1231

if (typ == GDL_ULONG64) return type_fun<DULong64GDL>( e);

1232

if (typ == GDL_FLOAT) return type_fun<DFloatGDL>( e);

1233

if (typ == GDL_DOUBLE) return type_fun<DDoubleGDL>( e);

1234

if (typ == GDL_COMPLEX) return type_fun<DComplexGDL>( e);

1235

if (typ == GDL_COMPLEXDBL) return type_fun<DComplexDblGDL>( e);

1236

if (typ == GDL_STRING)

1237

{

1238

// SA: calling GDL_STRING() with correct parameters

1239

static int stringIx = LibFunIx("STRING");

1240

1241

assert( stringIx >= 0);

1242

1243

EnvT* newEnv= new EnvT(e, libFunList[stringIx], NULL);

1244

1245

auto_ptr<EnvT> guard( newEnv);

1246

1247

newEnv->SetNextPar(&e->GetPar(0)); // pass as global

1248

if (e->KeywordSet(1) && e->GetPar(0)->Type() == GDL_BYTE)

1249

newEnv->SetKeyword("PRINT", new DIntGDL(1));

1250

// e->Interpreter()->CallStack().push_back( newEnv);

1251

return static_cast<DLibFun*>(newEnv->GetPro())->Fun()(newEnv);

1252

}

1253

e->Throw( "Improper TYPE value.");

1254

}

1255

return type_fun<DIntGDL>( e);

1256

}

1257

1258

BaseGDL* call_function( EnvT* e)

1259

{

1260

int nParam=e->NParam();

1261

if( nParam == 0)

1262

e->Throw( "No function specified.");

1263

1264

DString callF;

1265

e->AssureScalarPar<DStringGDL>( 0, callF);

1266

1267

// this is a function name -> convert to UPPERCASE

1268

callF = StrUpCase( callF);

1269

1270

// first search library funcedures

1271

int funIx=LibFunIx( callF);

1272

if( funIx != -1)

1273

{

1274

// e->PushNewEnv( libFunList[ funIx], 1);

1275

// make the call

1276

// EnvT* newEnv = static_cast<EnvT*>(e->Interpreter()->CallStack().back());

1277

1278

// handle direct call functions

1279

if( libFunList[ funIx]->DirectCall())

1280

{

1281

BaseGDL* directCallParameter = e->GetParDefined(1);

1282

BaseGDL* res =

1283

static_cast<DLibFunDirect*>(libFunList[ funIx])->FunDirect()(directCallParameter, true /*isReference*/);

1284

return res;

1285

}

1286

else

1287

{

1288

EnvT* newEnv = e->NewEnv( libFunList[ funIx], 1);

1289

auto_ptr<EnvT> guard( newEnv);

1290

return static_cast<DLibFun*>(newEnv->GetPro())->Fun()(newEnv);

1291

}

1292

}

1293

else

1294

{

1295

// no direct call here

1296

1297

StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());

1298

1299

funIx = GDLInterpreter::GetFunIx( callF);

1300

1301

e->PushNewEnvUD( funList[ funIx], 1);

1302

1303

// make the call

1304

EnvUDT* newEnv = static_cast<EnvUDT*>(e->Interpreter()->CallStack().back());

1305

return e->Interpreter()->call_fun(static_cast<DSubUD*>(newEnv->GetPro())->GetTree());

1306

}

1307

}

1308

1309

BaseGDL* call_method_function( EnvT* e)

1310

{

1311

StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());

1312

1313

int nParam=e->NParam();

1314

if( nParam < 2)

1315

e->Throw( "Name and object reference"

1316

" must be specified.");

1317

1318

DString callP;

1319

e->AssureScalarPar<DStringGDL>( 0, callP);

1320

1321

// this is a procedure name -> convert to UPPERCASE

1322

callP = StrUpCase( callP);

1323

1324

DStructGDL* oStruct = e->GetObjectPar( 1);

1325

1326

DFun* method= oStruct->Desc()->GetFun( callP);

1327

1328

if( method == NULL)

1329

e->Throw( "Method not found: "+callP);

1330

// // // /**/

1331

e->PushNewEnvUD( method, 2, &e->GetPar( 1));

1332

1333

// make the call

1334

return e->Interpreter()->call_fun( method->GetTree());

1335

}

1336

1337

1338

1339

BaseGDL* execute( EnvT* e)

1340

{

1341

int nParam=e->NParam( 1);

1342

1343

bool quietCompile = false;

1344

if( nParam == 2)

1345

{

1346

BaseGDL* p1 = e->GetParDefined( 1);

1347

1348

if( !p1->Scalar())

1349

e->Throw( "Expression must be scalar in this context: "+

1350

e->GetParString(1));

1351

1352

quietCompile = p1->True();

1353

}

1354

1355

if (e->GetParDefined(0)->Rank() != 0)

1356

e->Throw("Expression must be scalar in this context: "+e->GetParString(0));

1357

1358

DString line;

1359

e->AssureScalarPar<DStringGDL>( 0, line);

1360

1361

// remove current environment (own one)

1362

assert( dynamic_cast<EnvUDT*>(e->Caller()) != NULL);

1363

EnvUDT* caller = static_cast<EnvUDT*>(e->Caller());

1364

// e->Interpreter()->CallStack().pop_back();

1365

1366

// wrong: e is guarded, do not delete it here

1367

// delete e;

1368

1369

istringstream istr(line+"\n");

1370

1371

RefDNode theAST;

1372

try {

1373

GDLLexer lexer(istr, "", caller->CompileOpt());

1374

GDLParser& parser=lexer.Parser();

1375

1376

parser.interactive();

1377

1378

theAST=parser.getAST();

1379

}

1380

catch( GDLException& ex)

1381

{

1382

if( !quietCompile) GDLInterpreter::ReportCompileError( ex);

1383

return new DIntGDL( 0);

1384

}

1385

catch( ANTLRException ex)

1386

{

1387

if( !quietCompile) cerr << "EXECUTE: Lexer/Parser exception: " <<

1388

ex.getMessage() << endl;

1389

return new DIntGDL( 0);

1390

}

1391

1392

if( theAST == NULL) return new DIntGDL( 1);

1393

1394

RefDNode trAST;

1395

try

1396

{

1397

GDLTreeParser treeParser( caller);

1398

1399

treeParser.interactive(theAST);

1400

1401

trAST=treeParser.getAST();

1402

}

1403

catch( GDLException& ex)

1404

{

1405

if( !quietCompile) GDLInterpreter::ReportCompileError( ex);

1406

return new DIntGDL( 0);

1407

}

1408

1409

catch( ANTLRException ex)

1410

{

1411

if( !quietCompile) cerr << "EXECUTE: Compiler exception: " <<

1412

ex.getMessage() << endl;

1413

return new DIntGDL( 0);

1414

}

1415

1416

if( trAST == NULL) return new DIntGDL( 1);

1417

1418

int nForLoopsIn = caller->NForLoops();

1419

try

1420

{

1421

ProgNodeP progAST = ProgNode::NewProgNode( trAST);

1422

auto_ptr< ProgNode> progAST_guard( progAST);

1423

1424

int nForLoops = ProgNode::NumberForLoops( progAST, nForLoopsIn);

1425

caller->ResizeForLoops( nForLoops);

1426

1427

progAST->setLine( e->GetLineNumber());

1428

1429

RetCode retCode = caller->Interpreter()->execute( progAST);

1430

1431

caller->ResizeForLoops( nForLoopsIn);

1432

1433

if( retCode == RC_OK)

1434

return new DIntGDL( 1);

1435

else

1436

return new DIntGDL( 0);

1437

}

1438

catch( GDLException& ex)

1439

{

1440

caller->ResizeForLoops( nForLoopsIn);

1441

// are we throwing to target environment?

1442

// if( ex.GetTargetEnv() == NULL)

1443

if( !quietCompile) cerr << "EXECUTE: " <<

1444

ex.getMessage() << endl;

1445

return new DIntGDL( 0);

1446

}

1447

catch( ANTLRException ex)

1448

{

1449

caller->ResizeForLoops( nForLoopsIn);

1450

1451

if( !quietCompile) cerr << "EXECUTE: Interpreter exception: " <<

1452

ex.getMessage() << endl;

1453

return new DIntGDL( 0);

1454

}

1455

1456

return new DIntGDL( 0); // control flow cannot reach here - compiler shut up

1457

}

1458

1459

BaseGDL* assoc( EnvT* e)

1460

{

1461

SizeT nParam=e->NParam( 2);

1462

1463

DLong lun;

1464

e->AssureLongScalarPar( 0, lun);

1465

1466

bool stdLun = check_lun( e, lun);

1467

if( stdLun)

1468

e->Throw( "File unit does not allow"

1469

" this operation. Unit: "+i2s( lun));

1470

1471

DLong offset = 0;

1472

if( nParam >= 3) e->AssureLongScalarPar( 2, offset);

1473

1474

BaseGDL* arr = e->GetParDefined( 1);

1475

1476

if( arr->StrictScalar())

1477

e->Throw( "Scalar variable not allowed in this"

1478

" context: "+e->GetParString(1));

1479

1480

return arr->AssocVar( lun, offset);

1481

}

1482

1483

// gdl_ naming because of weired namespace problem in MSVC

1484

BaseGDL* gdl_logical_and( EnvT* e)

1485

{

1486

SizeT nParam=e->NParam();

1487

if( nParam != 2)

1488

e->Throw(

1489

"Incorrect number of arguments.");

1490

1491

BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_AND");

1492

BaseGDL* e2=e->GetParDefined( 1);//, "LOGICAL_AND");

1493

1494

ULong nEl1 = e1->N_Elements();

1495

ULong nEl2 = e2->N_Elements();

1496

1497

Data_<SpDByte>* res;

1498

1499

if( e1->Scalar())

1500

{

1501

if( e1->LogTrue(0))

1502

{

1503

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1504

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1505

{

1506

// #pragma omp for

1507

for( SizeT i=0; i < nEl2; i++)

1508

(*res)[i] = e2->LogTrue( i) ? 1 : 0;

1509

}

1510

}

1511

else

1512

{

1513

return new Data_<SpDByte>( e2->Dim());

1514

}

1515

}

1516

else if( e2->Scalar())

1517

{

1518

if( e2->LogTrue(0))

1519

{

1520

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1521

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1522

{

1523

// #pragma omp for

1524

for( SizeT i=0; i < nEl1; i++)

1525

(*res)[i] = e1->LogTrue( i) ? 1 : 0;

1526

}

1527

}

1528

else

1529

{

1530

return new Data_<SpDByte>( e1->Dim());

1531

}

1532

}

1533

else if( nEl2 < nEl1)

1534

{

1535

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1536

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1537

{

1538

// #pragma omp for

1539

for( SizeT i=0; i < nEl2; i++)

1540

(*res)[i] = (e1->LogTrue( i) && e2->LogTrue( i)) ? 1 : 0;

1541

}

1542

}

1543

else // ( nEl2 >= nEl1)

1544

{

1545

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1546

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1547

{

1548

// #pragma omp for

1549

for( SizeT i=0; i < nEl1; i++)

1550

(*res)[i] = (e1->LogTrue( i) && e2->LogTrue( i)) ? 1 : 0;

1551

}

1552

}

1553

return res;

1554

}

1555

1556

// gdl_ naming because of weired namespace problem in MSVC

1557

BaseGDL* gdl_logical_or( EnvT* e)

1558

{

1559

SizeT nParam=e->NParam();

1560

if( nParam != 2)

1561

e->Throw(

1562

"Incorrect number of arguments.");

1563

1564

BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_OR");

1565

BaseGDL* e2=e->GetParDefined( 1);//, "LOGICAL_OR");

1566

1567

ULong nEl1 = e1->N_Elements();

1568

ULong nEl2 = e2->N_Elements();

1569

1570

Data_<SpDByte>* res;

1571

1572

if( e1->Scalar())

1573

{

1574

if( e1->LogTrue(0))

1575

{

1576

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1577

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1578

{

1579

// #pragma omp for

1580

for( SizeT i=0; i < nEl2; i++)

1581

(*res)[i] = 1;

1582

}

1583

}

1584

else

1585

{

1586

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1587

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1588

{

1589

// #pragma omp for

1590

for( SizeT i=0; i < nEl2; i++)

1591

(*res)[i] = e2->LogTrue( i) ? 1 : 0;

1592

}

1593

}

1594

}

1595

else if( e2->Scalar())

1596

{

1597

if( e2->LogTrue(0))

1598

{

1599

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1600

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1601

{

1602

// #pragma omp for

1603

for( SizeT i=0; i < nEl1; i++)

1604

(*res)[i] = 1;

1605

}

1606

}

1607

else

1608

{

1609

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1610

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1611

{

1612

// #pragma omp for

1613

for( SizeT i=0; i < nEl1; i++)

1614

(*res)[i] = e1->LogTrue( i) ? 1 : 0;

1615

}

1616

}

1617

}

1618

else if( nEl2 < nEl1)

1619

{

1620

res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);

1621

// #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))

1622

{

1623

// #pragma omp for

1624

for( SizeT i=0; i < nEl2; i++)

1625

(*res)[i] = (e1->LogTrue( i) || e2->LogTrue( i)) ? 1 : 0;

1626

}

1627

}

1628

else // ( nEl2 >= nEl1)

1629

{

1630

res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1631

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1632

{

1633

// #pragma omp for

1634

for( SizeT i=0; i < nEl1; i++)

1635

(*res)[i] = (e1->LogTrue( i) || e2->LogTrue( i)) ? 1 : 0;

1636

}

1637

}

1638

return res;

1639

}

1640

1641

BaseGDL* logical_true( BaseGDL* e1, bool isReference)//( EnvT* e);

1642

{

1643

assert( e1 != NULL);

1644

assert( e1->N_Elements() > 0);

1645

1646

1647

// SizeT nParam=e->NParam();

1648

// if( nParam != 1)

1649

// e->Throw(

1650

// "Incorrect number of arguments.");

1651

//

1652

// BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_TRUE");

1653

//

1654

ULong nEl1 = e1->N_Elements();

1655

1656

Data_<SpDByte>* res = new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);

1657

// #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))

1658

{

1659

// #pragma omp for

1660

for( SizeT i=0; i < nEl1; i++)

1661

(*res)[i] = e1->LogTrue( i) ? 1 : 0;

1662

}

1663

return res;

1664

}

1665

1666

BaseGDL* replicate( EnvT* e)

1667

{

1668

SizeT nParam=e->NParam();

1669

if( nParam < 2)

1670

e->Throw( "Incorrect number of arguments.");

1671

dimension dim;

1672

arr( e, dim, 1);

1673

1674

BaseGDL* p0=e->GetParDefined( 0);//, "REPLICATE");

1675

if( !p0->Scalar())

1676

e->Throw( "Expression must be a scalar in this context: "+

1677

e->GetParString(0));

1678

1679

return p0->New( dim, BaseGDL::INIT);

1680

}

1681

1682

BaseGDL* strtrim( EnvT* e)

1683

{

1684

SizeT nParam = e->NParam( 1);//, "STRTRIM");

1685

1686

BaseGDL* p0 = e->GetPar( 0);

1687

if( p0 == NULL)

1688

e->Throw(

1689

"Variable is undefined: "+

1690

e->GetParString(0));

1691

DStringGDL* p0S = static_cast<DStringGDL*>

1692

(p0->Convert2(GDL_STRING,BaseGDL::COPY));

1693

1694

DLong mode = 0;

1695

if( nParam == 2)

1696

{

1697

BaseGDL* p1 = e->GetPar( 1);

1698

if( p1 == NULL)

1699

e->Throw(

1700

"Variable is undefined: "+e->GetParString(1));

1701

if( !p1->Scalar())

1702

e->Throw(

1703

"Expression must be a "

1704

"scalar in this context: "+

1705

e->GetParString(1));

1706

DLongGDL* p1L = static_cast<DLongGDL*>

1707

(p1->Convert2(GDL_LONG,BaseGDL::COPY));

1708

1709

mode = (*p1L)[ 0];

1710

1711

GDLDelete(p1L);

1712

1713

if( mode < 0 || mode > 2)

1714

{

1715

ostringstream os;

1716

p1->ToStream( os);

1717

e->Throw(

1718

"Value of <"+ p1->TypeStr() +

1719

" ("+os.str()+

1720

")> is out of allowed range.");

1721

}

1722

}

1723

1724

SizeT nEl = p0S->N_Elements();

1725

1726

if( mode == 2) // both

1727

{

1728

TRACEOMP( __FILE__, __LINE__)

1729

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1730

{

1731

#pragma omp for

1732

for( int i=0; i<nEl; ++i)

1733

{

1734

unsigned long first= (*p0S)[ i].find_first_not_of(" \t");

1735

if( first == (*p0S)[ i].npos)

1736

{

1737

(*p0S)[ i] = "";

1738

}

1739

else

1740

{

1741

unsigned long last = (*p0S)[ i].find_last_not_of(" \t");

1742

(*p0S)[ i] = (*p0S)[ i].substr(first,last-first+1);

1743

}

1744

}

1745

}

1746

}

1747

else if( mode == 1) // leading

1748

{

1749

TRACEOMP( __FILE__, __LINE__)

1750

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1751

{

1752

#pragma omp for

1753

for( int i=0; i<nEl; ++i)

1754

{

1755

unsigned long first= (*p0S)[ i].find_first_not_of(" \t");

1756

if( first == (*p0S)[ i].npos)

1757

{

1758

(*p0S)[ i] = "";

1759

}

1760

else

1761

{

1762

(*p0S)[ i] = (*p0S)[ i].substr(first);

1763

}

1764

}

1765

}

1766

}

1767

else // trailing

1768

{

1769

TRACEOMP( __FILE__, __LINE__)

1770

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1771

{

1772

#pragma omp for

1773

for( int i=0; i<nEl; ++i)

1774

{

1775

unsigned long last = (*p0S)[ i].find_last_not_of(" \t");

1776

if( last == (*p0S)[ i].npos)

1777

{

1778

(*p0S)[ i] = "";

1779

}

1780

else

1781

{

1782

(*p0S)[ i] = (*p0S)[ i].substr(0,last+1);

1783

}

1784

}

1785

}

1786

}

1787

return p0S;

1788

}

1789

1790

BaseGDL* strcompress( EnvT* e)

1791

{

1792

e->NParam( 1);

1793

1794

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1795

1796

bool removeAll = e->KeywordSet(0);

1797

1798

DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

1799

1800

SizeT nEl = p0S->N_Elements();

1801

TRACEOMP( __FILE__, __LINE__)

1802

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1803

{

1804

#pragma omp for

1805

for( int i=0; i<nEl; ++i)

1806

{

1807

(*res)[ i] = StrCompress((*p0S)[ i], removeAll);

1808

}

1809

}

1810

return res;

1811

}

1812

1813

BaseGDL* strpos( EnvT* e)

1814

{

1815

SizeT nParam = e->NParam( 2);//, "STRPOS");

1816

1817

bool reverseOffset = e->KeywordSet(0); // REVERSE_OFFSET

1818

bool reverseSearch = e->KeywordSet(1); // REVERSE_SEARCH

1819

1820

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1821

1822

DString searchString;

1823

// e->AssureScalarPar<DStringGDL>( 1, searchString);

1824

DStringGDL* sStr = e->GetParAs<DStringGDL>( 1);

1825

if( !sStr->Scalar( searchString))

1826

e->Throw( "Search string must be a scalar or one element array: "+

1827

e->GetParString( 1));

1828

1829

unsigned long pos = string::npos;

1830

if( nParam > 2)

1831

{

1832

BaseGDL* p2 = e->GetParDefined(2);

1833

// if( p2 != NULL) //e->AssureLongScalarPar( 2,posDLong);

1834

// {

1835

const SizeT pIx = 2;

1836

BaseGDL* p = e->GetParDefined( pIx);

1837

DLongGDL* lp = static_cast<DLongGDL*>(p->Convert2( GDL_LONG, BaseGDL::COPY));

1838

auto_ptr<DLongGDL> guard_lp( lp);

1839

DLong scalar;

1840

if( !lp->Scalar( scalar))

1841

throw GDLException("Parameter must be a scalar in this context: "+

1842

e->GetParString(pIx));

1843

pos = scalar;

1844

}

1845

1846

DLongGDL* res = new DLongGDL( p0S->Dim(), BaseGDL::NOZERO);

1847

1848

SizeT nSrcStr = p0S->N_Elements();

1849

TRACEOMP( __FILE__, __LINE__)

1850

#pragma omp parallel if ((nSrcStr*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nSrcStr*10)))

1851

{

1852

#pragma omp for

1853

for( long i=0; i<nSrcStr; ++i)

1854

{

1855

(*res)[ i] = StrPos((*p0S)[ i], searchString, pos,

1856

reverseOffset, reverseSearch);

1857

}

1858

}

1859

return res;

1860

}

1861

1862

BaseGDL* strmid( EnvT* e)

1863

{

1864

e->NParam( 2);//, "STRMID");

1865

1866

bool reverse = e->KeywordSet(0);

1867

1868

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1869

DLongGDL* p1L = e->GetParAs<DLongGDL>( 1);

1870

1871

BaseGDL* p2 = e->GetPar( 2);

1872

DLongGDL* p2L = NULL;

1873

if( p2 != NULL) p2L = e->GetParAs<DLongGDL>( 2);

1874

1875

DLong scVal1;

1876

bool sc1 = p1L->Scalar( scVal1);

1877

1878

DLong scVal2 = numeric_limits<DLong>::max();

1879

bool sc2 = true;

1880

if( p2L != NULL)

1881

{

1882

DLong scalar;

1883

sc2 = p2L->Scalar( scalar);

1884

scVal2 = scalar;

1885

}

1886

1887

DLong stride;

1888

if( !sc1 && !sc2)

1889

{

1890

stride = p1L->Dim( 0);

1891

if( stride != p2L->Dim( 0))

1892

e->Throw(

1893

"Starting offset and length arguments "

1894

"have incompatible first dimension.");

1895

}

1896

else

1897

{

1898

// at least one scalar, p2L possibly NULL

1899

if( p2L == NULL)

1900

stride = p1L->Dim( 0);

1901

else

1902

stride = max( p1L->Dim( 0), p2L->Dim( 0));

1903

1904

stride = (stride > 0)? stride : 1;

1905

}

1906

1907

dimension resDim( p0S->Dim());

1908

if( stride > 1)

1909

resDim >> stride;

1910

1911

DStringGDL* res = new DStringGDL( resDim, BaseGDL::NOZERO);

1912

1913

SizeT nEl1 = p1L->N_Elements();

1914

SizeT nEl2 = (sc2)? 1 : p2L->N_Elements();

1915

1916

SizeT nSrcStr = p0S->N_Elements();

1917

TRACEOMP( __FILE__, __LINE__)

1918

#pragma omp parallel if ((nSrcStr*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nSrcStr*10))) default( shared)

1919

{

1920

#pragma omp for

1921

for( long i=0; i<nSrcStr; ++i)

1922

{

1923

for( long ii=0; ii<stride; ++ii)

1924

{

1925

SizeT destIx = i * stride + ii;

1926

DLong actFirst = (sc1)? scVal1 : (*p1L)[ destIx % nEl1];

1927

DLong actLen = (sc2)? scVal2 : (*p2L)[ destIx % nEl2];

1928

if( actLen <= 0)

1929

(*res)[ destIx] = "";//StrMid((*p0S)[ i], actFirst, actLen, reverse);

1930

else

1931

(*res)[ destIx] = StrMid((*p0S)[ i], actFirst, actLen, reverse);

1932

}

1933

}

1934

}

1935

return res;

1936

}

1937

1938

BaseGDL* strlowcase( BaseGDL* p0, bool isReference)//( EnvT* e)

1939

{

1940

assert( p0 != NULL);

1941

assert( p0->N_Elements() > 0);

1942

1943

// e->NParam( 1);//, "STRLOWCASE");

1944

1945

// DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

1946

DStringGDL* p0S;

1947

DStringGDL* res;

1948

// auto_ptr<DStringGDL> guard;

1949

1950

if( p0->Type() == GDL_STRING)

1951

{

1952

p0S = static_cast<DStringGDL*>( p0);

1953

if( !isReference)

1954

res = p0S;

1955

else

1956

res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

1957

}

1958

else

1959

{

1960

p0S = static_cast<DStringGDL*>( p0->Convert2( GDL_STRING, BaseGDL::COPY));

1961

res = p0S;

1962

// guard.reset( p0S);

1963

}

1964

1965

// DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

1966

1967

SizeT nEl = p0S->N_Elements();

1968

1969

if( res == p0S)

1970

{

1971

TRACEOMP( __FILE__, __LINE__)

1972

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1973

{

1974

#pragma omp for

1975

for( int i=0; i<nEl; ++i)

1976

{

1977

StrLowCaseInplace((*p0S)[ i]);

1978

}

1979

}

1980

}

1981

else

1982

{

1983

TRACEOMP( __FILE__, __LINE__)

1984

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

1985

{

1986

#pragma omp for

1987

for( int i=0; i<nEl; ++i)

1988

{

1989

(*res)[ i] = StrLowCase((*p0S)[ i]);

1990

}

1991

}

1992

}

1993

return res;

1994

}

1995

1996

BaseGDL* strupcase( BaseGDL* p0, bool isReference)//( EnvT* e)

1997

{

1998

assert( p0 != NULL);

1999

assert( p0->N_Elements() > 0);

2000

2001

// e->NParam( 1);//, "STRLOWCASE");

2002

2003

// DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

2004

DStringGDL* p0S;

2005

DStringGDL* res;

2006

// auto_ptr<DStringGDL> guard;

2007

2008

if( p0->Type() == GDL_STRING)

2009

{

2010

p0S = static_cast<DStringGDL*>( p0);

2011

if( !isReference)

2012

res = p0S;

2013

else

2014

res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

2015

}

2016

else

2017

{

2018

p0S = static_cast<DStringGDL*>( p0->Convert2( GDL_STRING, BaseGDL::COPY));

2019

res = p0S;

2020

// guard.reset( p0S);

2021

}

2022

2023

// DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);

2024

2025

SizeT nEl = p0S->N_Elements();

2026

2027

if( res == p0S)

2028

{

2029

TRACEOMP( __FILE__, __LINE__)

2030

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

2031

{

2032

#pragma omp for

2033

for( int i=0; i<nEl; ++i)

2034

{

2035

StrUpCaseInplace((*p0S)[ i]);

2036

}

2037

}

2038

}

2039

else

2040

{

2041

TRACEOMP( __FILE__, __LINE__)

2042

#pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))

2043

{

2044

#pragma omp for

2045

for( int i=0; i<nEl; ++i)

2046

{

2047

(*res)[ i] = StrUpCase((*p0S)[ i]);

2048

}

2049

}

2050

}

2051

return res;

2052

}

2053

2054

BaseGDL* strlen( BaseGDL* p0, bool isReference)//( EnvT* e)

2055

{

2056

assert( p0 != NULL);

2057

assert( p0->N_Elements() > 0);

2058

2059

// e->NParam( 1);//, "STRLEN");

2060

2061

DStringGDL* p0S;

2062

auto_ptr<DStringGDL> guard;

2063

2064

if( p0->Type() == GDL_STRING)

2065

p0S = static_cast<DStringGDL*>( p0);

2066

else

2067

{

2068

p0S = static_cast<DStringGDL*>( p0->Convert2( GDL_STRING, BaseGDL::COPY));

2069

guard.reset( p0S);

2070

}

2071

2072

DLongGDL* res = new DLongGDL( p0S->Dim(), BaseGDL::NOZERO);

2073

2074

SizeT nEl = p0S->N_Elements();

2075

// #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))

2076

{

2077

// #pragma omp for

2078

for( SizeT i=0; i<nEl; ++i)

2079

{

2080

(*res)[ i] = (*p0S)[ i].length();

2081

}

2082

}

2083

return res;

2084

}

2085

2086

BaseGDL* strjoin( EnvT* e)

2087

{

2088

SizeT nParam = e->NParam( 1);

2089

2090

DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);

2091

SizeT nEl = p0S->N_Elements();

2092

2093

DString delim = "";

2094

if( nParam > 1)

2095

e->AssureStringScalarPar( 1, delim);

2096

2097

bool single = e->KeywordSet( 0); // SINGLE

2098

2099

if( single)

2100

{

2101

DStringGDL* res = new DStringGDL( (*p0S)[0]);

2102

DString& scl = (*res)[0];

2103

2104

for( SizeT i=1; i<nEl; ++i)

2105

scl += delim + (*p0S)[i];

2106

2107

return res;

2108

}

2109

2110

dimension resDim( p0S->Dim());

2111

resDim.Purge();

2112

2113

SizeT stride = resDim.Stride( 1);

2114

2115

resDim.Remove( 0);

2116

2117

DStringGDL* res = new DStringGDL( resDim, BaseGDL::NOZERO);

2118

for( SizeT src=0, dst=0; src<nEl; ++dst)

2119

{

2120

(*res)[ dst] = (*p0S)[ src++];

2121

for(SizeT l=1; l<stride; ++l)

2122

(*res)[ dst] += delim + (*p0S)[ src++];

2123

}

2124

2125

return res;

2126

}

2127

2128

BaseGDL* where( EnvT* e)

2129

{

2130

SizeT nParam = e->NParam( 1);//, "WHERE");

2131

2132

BaseGDL* p0 = e->GetParDefined( 0);//, "WHERE");

2133

2134

SizeT nEl = p0->N_Elements();

2135

2136

SizeT count;

2137

2138

static int nullIx = e->KeywordIx("NULL");

2139

bool nullKW = e->KeywordSet(nullIx);

2140

2141

DLong* ixList = p0->Where( e->KeywordPresent( 0), count);

2142

ArrayGuard<DLong> guard( ixList);

2143

SizeT nCount = nEl - count;

2144

2145

if( e->KeywordPresent( 0)) // COMPLEMENT

2146

{

2147

if( nCount == 0)

2148

{

2149

if( nullKW)

2150

e->SetKW( 0, NullGDL::GetSingleInstance());

2151

else

2152

e->SetKW( 0, new DLongGDL( -1));

2153

}

2154

else

2155

{

2156

DLongGDL* cIxList = new DLongGDL( dimension( &nCount, 1),

2157

BaseGDL::NOZERO);

2158

2159

SizeT cIx = nEl - 1;

2160

// #pragma omp parallel if (nCount >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nCount))

2161

{

2162

// #pragma omp for

2163

for( SizeT i=0; i<nCount; ++i)

2164

(*cIxList)[ i] = ixList[ cIx - i];

2165

// (*cIxList)[ i] = ixList[ --cIx];

2166

}

2167

e->SetKW( 0, cIxList);

2168

}

2169

}

2170

2171

if( e->KeywordPresent( 1)) // NCOMPLEMENT

2172

{

2173

e->SetKW( 1, new DLongGDL( nCount));

2174

}

2175

2176

if( nParam == 2)

2177

{

2178

e->SetPar( 1, new DLongGDL( count));

2179

}

2180

2181

if( count == 0)

2182

{

2183

if( nullKW)

2184

return NullGDL::GetSingleInstance();

2185

return new DLongGDL( -1);

2186

}

2187

2188

return new DLongGDL( ixList, count);

2189

2190

// DLongGDL* res = new DLongGDL( dimension( &count, 1),

2191

// BaseGDL::NOZERO);

2192

// for( SizeT i=0; i<count; ++i)

2193

// (*res)[ i] = ixList[ i];

2194

2195

// return res;

2196

}

2197

2198

BaseGDL* n_params( EnvT* e)

2199

{

2200

EnvUDT* caller = static_cast<EnvUDT*>(e->Caller());

2201

if( caller == NULL) return new DLongGDL( 0);

2202

DLong nP = caller->NParam();

2203

if( caller->IsObject())

2204

return new DLongGDL( nP-1); // "self" is not counted

2205

return new DLongGDL( nP);

2206

}

2207

2208

BaseGDL* keyword_set( EnvT* e)

2209

{

2210

e->NParam( 1);//, "KEYWORD_SET");

2211

2212

BaseGDL* p0 = e->GetPar( 0);

2213

if( p0 == NULL) return new DIntGDL( 0);

2214

if( !p0->Scalar()) return new DIntGDL( 1);

2215

if( p0->Type() == GDL_STRUCT) return new DIntGDL( 1);

2216

if( p0->LogTrue()) return new DIntGDL( 1);

2217

return new DIntGDL( 0);

2218

}

2219

2220

// passing 2nd argument by value is slightly better for float and double,

2221

// but incur some overhead for the complex class.

2222

template<class T> inline void AddOmitNaN(T& dest, T value)

2223

{

2224

if (isfinite(value))

2225

{

2226

// #pragma omp atomic

2227

dest += value;

2228

}

2229

}

2230

template<class T> inline void AddOmitNaNCpx(T& dest, T value)

2231

{

2232

// #pragma omp atomic

2233

dest += T(isfinite(value.real())? value.real() : 0,

2234

isfinite(value.imag())? value.imag() : 0);

2235

}

2236

template<> inline void AddOmitNaN(DComplex& dest, DComplex value)

2237

{ AddOmitNaNCpx<DComplex>(dest, value); }

2238

template<> inline void AddOmitNaN(DComplexDbl& dest, DComplexDbl value)

2239

{ AddOmitNaNCpx<DComplexDbl>(dest, value); }

2240

2241

template<class T> inline void NaN2Zero(T& value)

2242

{ if (!isfinite(value)) value = 0; }

2243

template<class T> inline void NaN2ZeroCpx(T& value)

2244

{

2245

value = T(isfinite(value.real())? value.real() : 0,

2246

isfinite(value.imag())? value.imag() : 0);

2247

}

2248

template<> inline void NaN2Zero(DComplex& value)

2249

{ NaN2ZeroCpx< DComplex>(value); }

2250

template<> inline void NaN2Zero(DComplexDbl& value)

2251

{ NaN2ZeroCpx< DComplexDbl>(value); }

2252

2253

// total over all elements

2254

template<class T>

2255

BaseGDL* total_template( T* src, bool omitNaN)

2256

{

2257

if (!omitNaN) return new T(src->Sum());

2258

typename T::Ty sum = 0;

2259

SizeT nEl = src->N_Elements();

2260

TRACEOMP( __FILE__, __LINE__)

2261

#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(sum)

2262

{

2263

#pragma omp for

2264

for ( int i=0; i<nEl; ++i)

2265

{

2266

AddOmitNaN(sum, (*src)[ i]);

2267

}

2268

}

2269

return new T(sum);

2270

}

2271

2272

// cumulative over all dims

2273

template<typename T>

2274

BaseGDL* total_cu_template( T* res, bool omitNaN)

2275

{

2276

SizeT nEl = res->N_Elements();

2277

if (omitNaN)

2278

{

2279

// #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))

2280

{

2281

// #pragma omp for

2282

for( SizeT i=0; i<nEl; ++i)

2283

NaN2Zero((*res)[i]);

2284

}

2285

}

2286

for( SizeT i=1,ii=0; i<nEl; ++i,++ii)

2287

(*res)[i] += (*res)[ii];

2288

return res;

2289

}

2290

2291

// total over one dim

2292

template< typename T>

2293

BaseGDL* total_over_dim_template( T* src,

2294

const dimension& srcDim,

2295

SizeT sumDimIx,

2296

bool omitNaN)

2297

{

2298

SizeT nEl = src->N_Elements();

2299

2300

// get dest dim and number of summations

2301

dimension destDim = srcDim;

2302

SizeT nSum = destDim.Remove( sumDimIx);

2303

2304

T* res = new T( destDim); // zero fields

2305

2306

// sumStride is also the number of linear src indexing

2307

SizeT sumStride = srcDim.Stride( sumDimIx);

2308

SizeT outerStride = srcDim.Stride( sumDimIx + 1);

2309

SizeT sumLimit = nSum * sumStride;

2310

SizeT rIx=0;

2311

for( SizeT o=0; o < nEl; o += outerStride)

2312

for( SizeT i=0; i < sumStride; ++i)

2313

{

2314

SizeT oi = o+i;

2315

SizeT oiLimit = sumLimit + oi;

2316

if( omitNaN)

2317

{

2318

for( SizeT s=oi; s<oiLimit; s += sumStride)

2319

AddOmitNaN((*res)[ rIx], (*src)[ s]);

2320

}

2321

else

2322

{

2323

for( SizeT s=oi; s<oiLimit; s += sumStride)

2324

(*res)[ rIx] += (*src)[ s];

2325

}

2326

++rIx;

2327

}

2328

return res;

2329

}

2330

2331

// cumulative over one dim

2332

template< typename T>

2333

BaseGDL* total_over_dim_cu_template( T* res,

2334

SizeT sumDimIx,

2335

bool omitNaN)

2336

{

2337

SizeT nEl = res->N_Elements();

2338

const dimension& resDim = res->Dim();

2339

if (omitNaN)

2340

{

2341

for( SizeT i=0; i<nEl; ++i)

2342

NaN2Zero((*res)[i]);

2343

}

2344

SizeT cumStride = resDim.Stride( sumDimIx);

2345

SizeT outerStride = resDim.Stride( sumDimIx + 1);

2346

for( SizeT o=0; o < nEl; o += outerStride)

2347

{

2348

SizeT cumLimit = o+outerStride;

2349

for( SizeT i=o+cumStride, ii=o; i<cumLimit; ++i, ++ii)

2350

(*res)[ i] += (*res)[ ii];

2351

}

2352

return res;

2353

}

2354

2355

2356

BaseGDL* total( EnvT* e)

2357

{

2358

SizeT nParam = e->NParam( 1);//, "TOTAL");

2359

2360

BaseGDL* p0 = e->GetParDefined( 0);//, "TOTAL");

2361

2362

SizeT nEl = p0->N_Elements();

2363

if( nEl == 0)

2364

e->Throw( "Variable is undefined: "+e->GetParString(0));

2365

2366

if( p0->Type() == GDL_STRING)

2367

e->Throw( "String expression not allowed "

2368

"in this context: "+e->GetParString(0));

2369

2370

static int cumIx = e->KeywordIx( "CUMULATIVE");

2371

static int intIx = e->KeywordIx("INTEGER");

2372

static int doubleIx = e->KeywordIx( "DOUBLE");

2373

static int nanIx = e->KeywordIx( "NAN");

2374

static int preserveIx = e->KeywordIx( "PRESERVE_TYPE");

2375

2376

bool cumulative = e->KeywordSet( cumIx);

2377

bool intRes = e->KeywordSet( intIx);

2378

bool doubleRes = e->KeywordSet( doubleIx);

2379

bool nan = e->KeywordSet( nanIx);

2380

bool preserve = e->KeywordSet( preserveIx);

2381

2382

DLong sumDim = 0;

2383

if( nParam == 2)

2384

e->AssureLongScalarPar( 1, sumDim);

2385

2386

if( sumDim == 0)

2387

{

2388

if( !cumulative)

2389

{

2390

if (preserve)

2391

{

2392

switch (p0->Type())

2393

{

2394

case GDL_BYTE: return total_template<DByteGDL>(static_cast<DByteGDL*>(p0), false);

2395

case GDL_INT: return total_template<DIntGDL>(static_cast<DIntGDL*>(p0), false);

2396

case GDL_UINT: return total_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), false);

2397

case GDL_LONG: return total_template<DLongGDL>(static_cast<DLongGDL*>(p0), false);

2398

case GDL_ULONG: return total_template<DULongGDL>(static_cast<DULongGDL*>(p0), false);

2399

case GDL_LONG64: return total_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), false);

2400

case GDL_ULONG64: return total_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), false);

2401

case GDL_FLOAT: return total_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), nan);

2402

case GDL_DOUBLE: return total_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), nan);

2403

case GDL_COMPLEX: return total_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), nan);

2404

case GDL_COMPLEXDBL: return total_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), nan);

2405

default: assert(false);

2406

}

2407

}

2408

2409

// Integer parts by Erin Sheldon

2410

// In IDL total(), the INTEGER keyword takes precedence

2411

if( intRes )

2412

{

2413

// We use GDL_LONG64 unless the input is GDL_ULONG64

2414

if ( p0->Type() == GDL_LONG64 )

2415

{

2416

return total_template<DLong64GDL>

2417

( static_cast<DLong64GDL*>(p0), nan );

2418

}

2419

if ( p0->Type() == GDL_ULONG64 )

2420

{

2421

return total_template<DULong64GDL>

2422

( static_cast<DULong64GDL*>(p0), nan );

2423

}

2424

2425

// Conver to Long64

2426

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2427

(p0->Convert2( GDL_LONG64, BaseGDL::COPY));

2428

auto_ptr<DLong64GDL> guard( p0L64);

2429

return total_template<DLong64GDL>( p0L64, nan);

2430

2431

} // integer results

2432

2433

2434

if( p0->Type() == GDL_DOUBLE)

2435

{

2436

return total_template<DDoubleGDL>

2437

( static_cast<DDoubleGDL*>(p0), nan);

2438

}

2439

if( p0->Type() == GDL_COMPLEXDBL)

2440

{

2441

return total_template<DComplexDblGDL>

2442

( static_cast<DComplexDblGDL*>(p0), nan);

2443

}

2444

2445

if( !doubleRes)

2446

{

2447

if( p0->Type() == GDL_FLOAT)

2448

{

2449

return total_template<DFloatGDL>

2450

( static_cast<DFloatGDL*>(p0), nan);

2451

}

2452

if( p0->Type() == GDL_COMPLEX)

2453

{

2454

return total_template<DComplexGDL>

2455

( static_cast<DComplexGDL*>(p0), nan);

2456

}

2457

DFloatGDL* p0F = static_cast<DFloatGDL*>

2458

(p0->Convert2( GDL_FLOAT,BaseGDL::COPY));

2459

auto_ptr<DFloatGDL> guard( p0F);

2460

return total_template<DFloatGDL>( p0F, false);

2461

}

2462

if( p0->Type() == GDL_COMPLEX)

2463

{

2464

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

2465

(p0->Convert2( GDL_COMPLEXDBL,BaseGDL::COPY));

2466

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

2467

return total_template<DComplexDblGDL>( p0D, nan);

2468

}

2469

2470

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

2471

(p0->Convert2( GDL_DOUBLE, BaseGDL::COPY));

2472

auto_ptr<DDoubleGDL> p0D_guard( p0D);

2473

return total_template<DDoubleGDL>( p0D, nan);

2474

}

2475

else // cumulative

2476

{

2477

if (preserve)

2478

{

2479

switch (p0->Type())

2480

{

2481

case GDL_BYTE: return total_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), false);

2482

case GDL_INT: return total_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), false);

2483

case GDL_UINT: return total_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), false);

2484

case GDL_LONG: return total_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), false);

2485

case GDL_ULONG: return total_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), false);

2486

case GDL_LONG64: return total_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), false);

2487

case GDL_ULONG64: return total_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), false);

2488

case GDL_FLOAT: return total_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), nan);

2489

case GDL_DOUBLE: return total_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), nan);

2490

case GDL_COMPLEX: return total_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), nan);

2491

case GDL_COMPLEXDBL: return total_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), nan);

2492

default: assert(false);

2493

}

2494

}

2495

2496

// INTEGER keyword takes precedence

2497

if( intRes )

2498

{

2499

// We use GDL_LONG64 unless the input is GDL_ULONG64

2500

if ( p0->Type() == GDL_LONG64 )

2501

{

2502

return total_cu_template<DLong64GDL>

2503

( static_cast<DLong64GDL*>(p0)->Dup(), nan );

2504

}

2505

if ( p0->Type() == GDL_ULONG64 )

2506

{

2507

return total_cu_template<DULong64GDL>

2508

( static_cast<DULong64GDL*>(p0)->Dup(), nan );

2509

}

2510

2511

// Convert to Long64

2512

return total_cu_template<DLong64GDL>

2513

( static_cast<DLong64GDL*>

2514

(p0->Convert2( GDL_LONG64, BaseGDL::COPY)), nan);

2515

2516

} // integer results

2517

2518

2519

// special case as GDL_DOUBLE type overrides /GDL_DOUBLE

2520

if( p0->Type() == GDL_DOUBLE)

2521

{

2522

return total_cu_template< DDoubleGDL>

2523

( static_cast<DDoubleGDL*>(p0)->Dup(), nan);

2524

}

2525

if( p0->Type() == GDL_COMPLEXDBL)

2526

{

2527

return total_cu_template< DComplexDblGDL>

2528

( static_cast<DComplexDblGDL*>(p0)->Dup(), nan);

2529

}

2530

2531

2532

2533

if( !doubleRes)

2534

{

2535

// special case for GDL_FLOAT has no advantage here

2536

if( p0->Type() == GDL_COMPLEX)

2537

{

2538

return total_cu_template< DComplexGDL>

2539

( static_cast<DComplexGDL*>(p0)->Dup(), nan);

2540

}

2541

return total_cu_template< DFloatGDL>

2542

( static_cast<DFloatGDL*>( p0->Convert2(GDL_FLOAT,

2543

BaseGDL::COPY)), nan);

2544

}

2545

if( p0->Type() == GDL_COMPLEX)

2546

{

2547

return total_cu_template< DComplexDblGDL>

2548

( static_cast<DComplexDblGDL*>(p0->Convert2( GDL_COMPLEXDBL,

2549

BaseGDL::COPY)), nan);

2550

}

2551

return total_cu_template< DDoubleGDL>

2552

( static_cast<DDoubleGDL*>(p0->Convert2( GDL_DOUBLE,

2553

BaseGDL::COPY)), nan);

2554

}

2555

}

2556

2557

// total over sumDim

2558

dimension srcDim = p0->Dim();

2559

SizeT srcRank = srcDim.Rank();

2560

2561

if( sumDim < 1 || sumDim > srcRank)

2562

e->Throw(

2563

"Array must have "+i2s(sumDim)+

2564

" dimensions: "+e->GetParString(0));

2565

2566

if( !cumulative)

2567

{

2568

if (preserve)

2569

{

2570

switch (p0->Type())

2571

{

2572

case GDL_BYTE: return total_over_dim_template<DByteGDL>(static_cast<DByteGDL*>(p0), srcDim, sumDim-1, false);

2573

case GDL_INT: return total_over_dim_template<DIntGDL>(static_cast<DIntGDL*>(p0), srcDim, sumDim-1, false);

2574

case GDL_UINT: return total_over_dim_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), srcDim, sumDim-1, false);

2575

case GDL_LONG: return total_over_dim_template<DLongGDL>(static_cast<DLongGDL*>(p0), srcDim, sumDim-1, false);

2576

case GDL_ULONG: return total_over_dim_template<DULongGDL>(static_cast<DULongGDL*>(p0), srcDim, sumDim-1, false);

2577

case GDL_LONG64: return total_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, false);

2578

case GDL_ULONG64: return total_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, false);

2579

case GDL_FLOAT: return total_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), srcDim, sumDim-1, nan);

2580

case GDL_DOUBLE: return total_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, nan);

2581

case GDL_COMPLEX: return total_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), srcDim, sumDim-1, nan);

2582

case GDL_COMPLEXDBL: return total_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, nan);

2583

default: assert(false);

2584

}

2585

}

2586

2587

// INTEGER keyword takes precedence

2588

if( intRes )

2589

{

2590

// We use GDL_LONG64 unless the input is GDL_ULONG64

2591

if ( p0->Type() == GDL_LONG64 )

2592

{

2593

return total_over_dim_template<DLong64GDL>

2594

( static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, nan );

2595

}

2596

if ( p0->Type() == GDL_ULONG64 )

2597

{

2598

return total_over_dim_template<DULong64GDL>

2599

( static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, nan );

2600

}

2601

2602

// Conver to Long64

2603

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2604

(p0->Convert2( GDL_LONG64, BaseGDL::COPY));

2605

2606

auto_ptr<DLong64GDL> p0L64_guard( p0L64);

2607

return total_over_dim_template<DLong64GDL>

2608

( p0L64, srcDim, sumDim-1, nan);

2609

2610

} // integer results

2611

2612

2613

if( p0->Type() == GDL_DOUBLE)

2614

{

2615

return total_over_dim_template< DDoubleGDL>

2616

( static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, nan);

2617

}

2618

if( p0->Type() == GDL_COMPLEXDBL)

2619

{

2620

return total_over_dim_template< DComplexDblGDL>

2621

( static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, nan);

2622

}

2623

if( !doubleRes)

2624

{

2625

if( p0->Type() == GDL_FLOAT)

2626

{

2627

return total_over_dim_template< DFloatGDL>

2628

( static_cast<DFloatGDL*>(p0), srcDim, sumDim-1, nan);

2629

}

2630

if( p0->Type() == GDL_COMPLEX)

2631

{

2632

return total_over_dim_template< DComplexGDL>

2633

( static_cast<DComplexGDL*>(p0), srcDim, sumDim-1, nan);

2634

}

2635

// default for NOT /GDL_DOUBLE

2636

DFloatGDL* p0F = static_cast<DFloatGDL*>

2637

(p0->Convert2( GDL_FLOAT,BaseGDL::COPY));

2638

auto_ptr<DFloatGDL> p0F_guard( p0F);

2639

// p0F_guard.reset( p0F);

2640

return total_over_dim_template< DFloatGDL>

2641

( p0F, srcDim, sumDim-1, false);

2642

}

2643

if( p0->Type() == GDL_COMPLEX)

2644

{

2645

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

2646

(p0->Convert2( GDL_COMPLEXDBL,BaseGDL::COPY));

2647

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

2648

// p0D_guard.reset( p0D);

2649

return total_over_dim_template< DComplexDblGDL>

2650

( p0D, srcDim, sumDim-1, nan);

2651

}

2652

// default for /GDL_DOUBLE

2653

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

2654

(p0->Convert2( GDL_DOUBLE,BaseGDL::COPY));

2655

auto_ptr<DDoubleGDL> p0D_guard( p0D);

2656

//p0D_guard.reset( p0D);

2657

return total_over_dim_template< DDoubleGDL>( p0D, srcDim, sumDim-1,nan);

2658

}

2659

else // cumulative

2660

{

2661

if (preserve)

2662

{

2663

switch (p0->Type())

2664

{

2665

case GDL_BYTE: return total_over_dim_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), sumDim-1, false);

2666

case GDL_INT: return total_over_dim_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), sumDim-1, false);

2667

case GDL_UINT: return total_over_dim_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), sumDim-1, false);

2668

case GDL_LONG: return total_over_dim_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), sumDim-1, false);

2669

case GDL_ULONG: return total_over_dim_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), sumDim-1, false);

2670

case GDL_LONG64: return total_over_dim_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, false);

2671

case GDL_ULONG64: return total_over_dim_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, false);

2672

case GDL_FLOAT: return total_over_dim_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), sumDim-1, nan);

2673

case GDL_DOUBLE: return total_over_dim_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, nan);

2674

case GDL_COMPLEX: return total_over_dim_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), sumDim-1, nan);

2675

case GDL_COMPLEXDBL: return total_over_dim_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, nan);

2676

default: assert(false);

2677

}

2678

}

2679

2680

// INTEGER keyword takes precedence

2681

if( intRes )

2682

{

2683

// We use GDL_LONG64 unless the input is GDL_ULONG64

2684

if ( p0->Type() == GDL_LONG64 )

2685

{

2686

return total_over_dim_cu_template<DLong64GDL>

2687

( static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, nan );

2688

}

2689

if ( p0->Type() == GDL_ULONG64 )

2690

{

2691

return total_over_dim_cu_template<DULong64GDL>

2692

( static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, nan );

2693

}

2694

2695

// Convert to Long64

2696

return total_over_dim_cu_template<DLong64GDL>

2697

( static_cast<DLong64GDL*>

2698

(p0->Convert2( GDL_LONG64, BaseGDL::COPY)), sumDim-1, nan);

2699

2700

} // integer results

2701

2702

2703

if( p0->Type() == GDL_DOUBLE)

2704

{

2705

return total_over_dim_cu_template< DDoubleGDL>

2706

( static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, nan);

2707

}

2708

if( p0->Type() == GDL_COMPLEXDBL)

2709

{

2710

return total_over_dim_cu_template< DComplexDblGDL>

2711

( static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, nan);

2712

}

2713

if( !doubleRes)

2714

{

2715

// special case for GDL_FLOAT has no advantage here

2716

if( p0->Type() == GDL_COMPLEX)

2717

{

2718

return total_over_dim_cu_template< DComplexGDL>

2719

( static_cast<DComplexGDL*>(p0)->Dup(), sumDim-1, nan);

2720

}

2721

// default for NOT /GDL_DOUBLE

2722

return total_over_dim_cu_template< DFloatGDL>

2723

( static_cast<DFloatGDL*>( p0->Convert2( GDL_FLOAT,

2724

BaseGDL::COPY)), sumDim-1, nan);

2725

}

2726

if( p0->Type() == GDL_COMPLEX)

2727

{

2728

return total_over_dim_cu_template< DComplexDblGDL>

2729

( static_cast<DComplexDblGDL*>(p0->Convert2( GDL_COMPLEXDBL,

2730

BaseGDL::COPY)), sumDim-1, nan);

2731

}

2732

// default for /GDL_DOUBLE

2733

return total_over_dim_cu_template< DDoubleGDL>

2734

( static_cast<DDoubleGDL*>(p0->Convert2( GDL_DOUBLE,

2735

BaseGDL::COPY)), sumDim-1, nan);

2736

}

2737

}

2738

2739

2740

// passing 2nd argument by value is slightly better for float and double,

2741

// but incur some overhead for the complex class.

2742

template<class T> inline void MultOmitNaN(T& dest, T value)

2743

{

2744

if (isfinite(value))

2745

{

2746

// #pragma omp atomic

2747

dest *= value;

2748

}

2749

}

2750

template<class T> inline void MultOmitNaNCpx(T& dest, T value)

2751

{

2752

dest *= T(isfinite(value.real())? value.real() : 1,

2753

isfinite(value.imag())? value.imag() : 1);

2754

}

2755

template<> inline void MultOmitNaN(DComplex& dest, DComplex value)

2756

{ MultOmitNaNCpx<DComplex>(dest, value); }

2757

template<> inline void MultOmitNaN(DComplexDbl& dest, DComplexDbl value)

2758

{ MultOmitNaNCpx<DComplexDbl>(dest, value); }

2759

2760

template<class T> inline void Nan2One(T& value)

2761

{ if (!isfinite(value)) value = 1; }

2762

template<class T> inline void Nan2OneCpx(T& value)

2763

{

2764

value = T(isfinite(value.real())? value.real() : 1,

2765

isfinite(value.imag())? value.imag() : 1);

2766

}

2767

template<> inline void Nan2One(DComplex& value)

2768

{ Nan2OneCpx< DComplex>(value); }

2769

template<> inline void Nan2One(DComplexDbl& value)

2770

{ Nan2OneCpx< DComplexDbl>(value); }

2771

2772

// product over all elements

2773

template<class T>

2774

BaseGDL* product_template( T* src, bool omitNaN)

2775

{

2776

typename T::Ty sum = 1;

2777

SizeT nEl = src->N_Elements();

2778

if( !omitNaN)

2779

{

2780

TRACEOMP( __FILE__, __LINE__)

2781

#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(sum)

2782

{

2783

#pragma omp for reduction(*:sum)

2784

for ( int i=0; i<nEl; ++i)

2785

{

2786

sum *= (*src)[ i];

2787

}

2788

}

2789

}

2790

else

2791

{

2792

TRACEOMP( __FILE__, __LINE__)

2793

#pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(sum)

2794

{

2795

#pragma omp for reduction(*:sum)

2796

for ( int i=0; i<nEl; ++i)

2797

{

2798

MultOmitNaN( sum, (*src)[ i]);

2799

}

2800

}

2801

}

2802

return new T( sum);

2803

}

2804

2805

template<>

2806

BaseGDL* product_template( DComplexGDL* src, bool omitNaN)

2807

{

2808

DComplexGDL::Ty sum = 1;

2809

SizeT nEl = src->N_Elements();

2810

if( !omitNaN)

2811

{

2812

for ( SizeT i=0; i<nEl; ++i)

2813

{

2814

sum *= (*src)[ i];

2815

}

2816

}

2817

else

2818

{

2819

for ( SizeT i=0; i<nEl; ++i)

2820

{

2821

MultOmitNaN( sum, (*src)[ i]);

2822

}

2823

}

2824

return new DComplexGDL( sum);

2825

}

2826

2827

template<>

2828

BaseGDL* product_template( DComplexDblGDL* src, bool omitNaN)

2829

{

2830

DComplexDblGDL::Ty sum = 1;

2831

SizeT nEl = src->N_Elements();

2832

if( !omitNaN)

2833

{

2834

for ( SizeT i=0; i<nEl; ++i)

2835

{

2836

sum *= (*src)[ i];

2837

}

2838

}

2839

else

2840

{

2841

for ( SizeT i=0; i<nEl; ++i)

2842

{

2843

MultOmitNaN( sum, (*src)[ i]);

2844

}

2845

}

2846

return new DComplexDblGDL( sum);

2847

}

2848

2849

// cumulative over all dims

2850

template<typename T>

2851

BaseGDL* product_cu_template( T* res, bool omitNaN)

2852

{

2853

SizeT nEl = res->N_Elements();

2854

if( omitNaN)

2855

{

2856

for( SizeT i=0; i<nEl; ++i)

2857

Nan2One( (*res)[i]);

2858

}

2859

for( SizeT i=1,ii=0; i<nEl; ++i,++ii)

2860

(*res)[i] *= (*res)[ii];

2861

return res;

2862

}

2863

2864

// product over one dim

2865

template< typename T>

2866

BaseGDL* product_over_dim_template( T* src,

2867

const dimension& srcDim,

2868

SizeT sumDimIx,

2869

bool omitNaN)

2870

{

2871

SizeT nEl = src->N_Elements();

2872

2873

// get dest dim and number of summations

2874

dimension destDim = srcDim;

2875

SizeT nSum = destDim.Remove( sumDimIx);

2876

2877

T* res = new T( destDim, BaseGDL::NOZERO);

2878

2879

// sumStride is also the number of linear src indexing

2880

SizeT sumStride = srcDim.Stride( sumDimIx);

2881

SizeT outerStride = srcDim.Stride( sumDimIx + 1);

2882

SizeT sumLimit = nSum * sumStride;

2883

SizeT rIx=0;

2884

for( SizeT o=0; o < nEl; o += outerStride)

2885

for( SizeT i=0; i < sumStride; ++i)

2886

{

2887

(*res)[ rIx] = 1;

2888

SizeT oi = o+i;

2889

SizeT oiLimit = sumLimit + oi;

2890

if( omitNaN)

2891

{

2892

for( SizeT s=oi; s<oiLimit; s += sumStride)

2893

MultOmitNaN((*res)[ rIx], (*src)[ s]);

2894

}

2895

else

2896

{

2897

for( SizeT s=oi; s<oiLimit; s += sumStride)

2898

(*res)[ rIx] *= (*src)[ s];

2899

}

2900

++rIx;

2901

}

2902

return res;

2903

}

2904

2905

// cumulative over one dim

2906

template< typename T>

2907

BaseGDL* product_over_dim_cu_template( T* res,

2908

SizeT sumDimIx,

2909

bool omitNaN)

2910

{

2911

SizeT nEl = res->N_Elements();

2912

const dimension& resDim = res->Dim();

2913

if (omitNaN)

2914

{

2915

for( SizeT i=0; i<nEl; ++i)

2916

Nan2One((*res)[i]);

2917

}

2918

SizeT cumStride = resDim.Stride( sumDimIx);

2919

SizeT outerStride = resDim.Stride( sumDimIx + 1);

2920

for( SizeT o=0; o < nEl; o += outerStride)

2921

{

2922

SizeT cumLimit = o+outerStride;

2923

for( SizeT i=o+cumStride, ii=o; i<cumLimit; ++i, ++ii)

2924

(*res)[ i] *= (*res)[ ii];

2925

}

2926

return res;

2927

}

2928

2929

BaseGDL* product( EnvT* e)

2930

{

2931

SizeT nParam = e->NParam( 1);

2932

2933

BaseGDL* p0 = e->GetParDefined( 0);

2934

2935

SizeT nEl = p0->N_Elements();

2936

if( nEl == 0)

2937

e->Throw( "Variable is undefined: "+e->GetParString(0));

2938

2939

if( p0->Type() == GDL_STRING)

2940

e->Throw( "String expression not allowed "

2941

"in this context: "+e->GetParString(0));

2942

2943

static int cumIx = e->KeywordIx( "CUMULATIVE");

2944

static int nanIx = e->KeywordIx( "NAN");

2945

static int intIx = e->KeywordIx("INTEGER");

2946

static int preIx = e->KeywordIx("PRESERVE_TYPE");

2947

bool KwCumul = e->KeywordSet( cumIx);

2948

bool KwNaN = e->KeywordSet( nanIx);

2949

bool KwInt = e->KeywordSet( intIx);

2950

bool KwPre = e->KeywordSet( preIx);

2951

bool nanInt=false;

2952

2953

DLong sumDim = 0;

2954

if( nParam == 2)

2955

e->AssureLongScalarPar( 1, sumDim);

2956

2957

if( sumDim == 0) {

2958

if( !KwCumul) {

2959

if (KwPre)

2960

{

2961

switch (p0->Type())

2962

{

2963

case GDL_BYTE: return product_template<DByteGDL>(static_cast<DByteGDL*>(p0), nanInt);

2964

case GDL_INT: return product_template<DIntGDL>(static_cast<DIntGDL*>(p0), nanInt);

2965

case GDL_UINT: return product_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), nanInt);

2966

case GDL_LONG: return product_template<DLongGDL>(static_cast<DLongGDL*>(p0), nanInt);

2967

case GDL_ULONG: return product_template<DULongGDL>(static_cast<DULongGDL*>(p0), nanInt);

2968

case GDL_LONG64: return product_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), nanInt);

2969

case GDL_ULONG64: return product_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), nanInt);

2970

case GDL_FLOAT: return product_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), KwNaN);

2971

case GDL_DOUBLE: return product_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), KwNaN);

2972

case GDL_COMPLEX: return product_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), KwNaN);

2973

case GDL_COMPLEXDBL: return product_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), KwNaN);

2974

default: assert(false);

2975

}

2976

}

2977

2978

// Integer parts derivated from Total code by Erin Sheldon

2979

// In IDL PRODUCT(), the INTEGER keyword takes precedence

2980

if (KwInt) {

2981

// We use GDL_LONG64 unless the input is GDL_ULONG64

2982

if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {

2983

return product_template<DLong64GDL>

2984

( static_cast<DLong64GDL*>(p0), nanInt );

2985

}

2986

if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {

2987

return product_template<DULong64GDL>

2988

(static_cast<DULong64GDL*>(p0), nanInt );

2989

}

2990

2991

// Convert to Long64

2992

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

2993

(p0->Convert2( GDL_LONG64, BaseGDL::COPY));

2994

auto_ptr<DLong64GDL> guard( p0L64);

2995

if (KwNaN) {

2996

DFloatGDL* p0f = static_cast<DFloatGDL*>

2997

(p0->Convert2( GDL_FLOAT, BaseGDL::COPY));

2998

auto_ptr<DFloatGDL> guard( p0f);

2999

for( SizeT i=0; i<nEl; ++i) {

3000

if (!isfinite((*p0f)[i])) (*p0L64)[i]=1;

3001

}

3002

}

3003

return product_template<DLong64GDL>( p0L64, nanInt);

3004

} // integer results

3005

3006

if( p0->Type() == GDL_DOUBLE) {

3007

return product_template<DDoubleGDL>

3008

( static_cast<DDoubleGDL*>(p0), KwNaN);

3009

}

3010

if( p0->Type() == GDL_COMPLEXDBL) {

3011

return product_template<DComplexDblGDL>

3012

( static_cast<DComplexDblGDL*>(p0), KwNaN);

3013

}

3014

if( p0->Type() == GDL_COMPLEX) {

3015

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

3016

(p0->Convert2( GDL_COMPLEXDBL,BaseGDL::COPY));

3017

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

3018

//p0D_guard.reset( p0D);

3019

return product_template<DComplexDblGDL>( p0D, KwNaN);

3020

}

3021

3022

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

3023

(p0->Convert2( GDL_DOUBLE, BaseGDL::COPY));

3024

auto_ptr<DDoubleGDL> p0D_guard( p0D);

3025

// p0D_guard.reset( p0D);

3026

return product_template<DDoubleGDL>( p0D, KwNaN);

3027

}

3028

else

3029

{ // KwCumul

3030

3031

if (KwPre)

3032

{

3033

switch (p0->Type())

3034

{

3035

case GDL_BYTE: return product_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), nanInt);

3036

case GDL_INT: return product_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), nanInt);

3037

case GDL_UINT: return product_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), nanInt);

3038

case GDL_LONG: return product_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), nanInt);

3039

case GDL_ULONG: return product_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), nanInt);

3040

case GDL_LONG64: return product_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), nanInt);

3041

case GDL_ULONG64: return product_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), nanInt);

3042

case GDL_FLOAT: return product_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), KwNaN);

3043

case GDL_DOUBLE: return product_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), KwNaN);

3044

case GDL_COMPLEX: return product_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), KwNaN);

3045

case GDL_COMPLEXDBL: return product_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), KwNaN);

3046

default: assert(false);

3047

}

3048

}

3049

3050

// Integer parts derivated from Total code by Erin Sheldon

3051

// In IDL PRODUCT(), the INTEGER keyword takes precedence

3052

if (KwInt) {

3053

// We use GDL_LONG64 unless the input is GDL_ULONG64

3054

if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {

3055

return product_cu_template<DLong64GDL>

3056

( static_cast<DLong64GDL*>(p0)->Dup(), nanInt);

3057

}

3058

if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {

3059

return product_cu_template<DULong64GDL>

3060

( static_cast<DULong64GDL*>(p0)->Dup(), nanInt);

3061

}

3062

// Convert to Long64

3063

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

3064

(p0->Convert2( GDL_LONG64, BaseGDL::COPY));

3065

auto_ptr<DLong64GDL> guard( p0L64);

3066

if (KwNaN) {

3067

DFloatGDL* p0f = static_cast<DFloatGDL*>

3068

(p0->Convert2( GDL_FLOAT, BaseGDL::COPY));

3069

auto_ptr<DFloatGDL> guard( p0f);

3070

for( SizeT i=0; i<nEl; ++i) {

3071

if (!isfinite((*p0f)[i])) (*p0L64)[i]=1;

3072

}

3073

}

3074

return product_cu_template<DLong64GDL>

3075

((p0L64)->Dup(), nanInt);

3076

} // integer results

3077

3078

// special case as GDL_DOUBLE type overrides /GDL_DOUBLE

3079

if (p0->Type() == GDL_DOUBLE) {

3080

return product_cu_template< DDoubleGDL>

3081

( static_cast<DDoubleGDL*>(p0)->Dup(), KwNaN);

3082

}

3083

if (p0->Type() == GDL_COMPLEXDBL) {

3084

return product_cu_template< DComplexDblGDL>

3085

( static_cast<DComplexDblGDL*>(p0)->Dup(), KwNaN);

3086

}

3087

if (p0->Type() == GDL_COMPLEX) {

3088

return product_cu_template< DComplexDblGDL>

3089

( static_cast<DComplexDblGDL*>

3090

(p0->Convert2( GDL_COMPLEXDBL, BaseGDL::COPY)), KwNaN);

3091

}

3092

return product_cu_template< DDoubleGDL>

3093

( static_cast<DDoubleGDL*>

3094

(p0->Convert2( GDL_DOUBLE, BaseGDL::COPY)), KwNaN);

3095

}

3096

}

3097

3098

// product over sumDim

3099

dimension srcDim = p0->Dim();

3100

SizeT srcRank = srcDim.Rank();

3101

3102

if( sumDim < 1 || sumDim > srcRank)

3103

e->Throw( "Array must have "+i2s(sumDim)+

3104

" dimensions: "+e->GetParString(0));

3105

3106

if (!KwCumul) {

3107

3108

if (KwPre)

3109

{

3110

switch (p0->Type())

3111

{

3112

case GDL_BYTE: return product_over_dim_template<DByteGDL>(static_cast<DByteGDL*>(p0), srcDim, sumDim-1, nanInt);

3113

case GDL_INT: return product_over_dim_template<DIntGDL>(static_cast<DIntGDL*>(p0), srcDim, sumDim-1, nanInt);

3114

case GDL_UINT: return product_over_dim_template<DUIntGDL>(static_cast<DUIntGDL*>(p0), srcDim, sumDim-1, nanInt);

3115

case GDL_LONG: return product_over_dim_template<DLongGDL>(static_cast<DLongGDL*>(p0), srcDim, sumDim-1, nanInt);

3116

case GDL_ULONG: return product_over_dim_template<DULongGDL>(static_cast<DULongGDL*>(p0), srcDim, sumDim-1, nanInt);

3117

case GDL_LONG64: return product_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, nanInt);

3118

case GDL_ULONG64: return product_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, nanInt);

3119

case GDL_FLOAT: return product_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*>(p0), srcDim, sumDim-1, KwNaN);

3120

case GDL_DOUBLE: return product_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, KwNaN);

3121

case GDL_COMPLEX: return product_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*>(p0), srcDim, sumDim-1, KwNaN);

3122

case GDL_COMPLEXDBL: return product_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, KwNaN);

3123

default: assert(false);

3124

}

3125

}

3126

3127

// Integer parts derivated from Total code by Erin Sheldon

3128

// In IDL PRODUCT(), the INTEGER keyword takes precedence

3129

if (KwInt) {

3130

// We use GDL_LONG64 unless the input is GDL_ULONG64

3131

if ((p0->Type() == GDL_LONG64 ) && (!KwNaN)) {

3132

return product_over_dim_template<DLong64GDL>

3133

( static_cast<DLong64GDL*>(p0), srcDim, sumDim-1, nanInt);

3134

}

3135

if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {

3136

return product_over_dim_template<DULong64GDL>

3137

( static_cast<DULong64GDL*>(p0), srcDim, sumDim-1, nanInt);

3138

}

3139

3140

// Conver to Long64

3141

DLong64GDL* p0L64 = static_cast<DLong64GDL*>

3142

(p0->Convert2( GDL_LONG64, BaseGDL::COPY));

3143

auto_ptr<DLong64GDL> guard( p0L64);

3144

if (KwNaN) {

3145

DFloatGDL* p0f = static_cast<DFloatGDL*>

3146

(p0->Convert2( GDL_FLOAT, BaseGDL::COPY));

3147

auto_ptr<DFloatGDL> guard( p0f);

3148

for( SizeT i=0; i<nEl; ++i) {

3149

if (!isfinite((*p0f)[i])) (*p0L64)[i]=1;

3150

}

3151

}

3152

return product_over_dim_template<DLong64GDL>

3153

( p0L64, srcDim, sumDim-1, nanInt);

3154

} // integer results

3155

3156

if( p0->Type() == GDL_DOUBLE) {

3157

return product_over_dim_template< DDoubleGDL>

3158

( static_cast<DDoubleGDL*>(p0), srcDim, sumDim-1, KwNaN);

3159

}

3160

if( p0->Type() == GDL_COMPLEXDBL) {

3161

return product_over_dim_template< DComplexDblGDL>

3162

( static_cast<DComplexDblGDL*>(p0), srcDim, sumDim-1, KwNaN);

3163

}

3164

if( p0->Type() == GDL_COMPLEX) {

3165

DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>

3166

(p0->Convert2( GDL_COMPLEXDBL,BaseGDL::COPY));

3167

auto_ptr<DComplexDblGDL> p0D_guard( p0D);

3168

// p0D_guard.reset( p0D);

3169

return product_over_dim_template< DComplexDblGDL>

3170

( p0D, srcDim, sumDim-1, KwNaN);

3171

}

3172

3173

DDoubleGDL* p0D = static_cast<DDoubleGDL*>

3174

(p0->Convert2( GDL_DOUBLE,BaseGDL::COPY));

3175

auto_ptr<DDoubleGDL> p0D_guard( p0D);

3176

//p0D_guard.reset( p0D);

3177

return product_over_dim_template< DDoubleGDL>

3178

( p0D, srcDim, sumDim-1,KwNaN);

3179

}

3180

else

3181

{ // KwCumul

3182

3183

if (KwPre)

3184

{

3185

switch (p0->Type())

3186

{

3187

case GDL_BYTE: return product_over_dim_cu_template<DByteGDL>(static_cast<DByteGDL*>(p0)->Dup(), sumDim-1, nanInt);

3188

case GDL_INT: return product_over_dim_cu_template<DIntGDL>(static_cast<DIntGDL*>(p0)->Dup(), sumDim-1, nanInt);

3189

case GDL_UINT: return product_over_dim_cu_template<DUIntGDL>(static_cast<DUIntGDL*>(p0)->Dup(), sumDim-1, nanInt);

3190

case GDL_LONG: return product_over_dim_cu_template<DLongGDL>(static_cast<DLongGDL*>(p0)->Dup(), sumDim-1, nanInt);

3191

case GDL_ULONG: return product_over_dim_cu_template<DULongGDL>(static_cast<DULongGDL*>(p0)->Dup(), sumDim-1, nanInt);

3192

case GDL_LONG64: return product_over_dim_cu_template<DLong64GDL>(static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3193

case GDL_ULONG64: return product_over_dim_cu_template<DULong64GDL>(static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3194

case GDL_FLOAT: return product_over_dim_cu_template<DFloatGDL>(static_cast<DFloatGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3195

case GDL_DOUBLE: return product_over_dim_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3196

case GDL_COMPLEX: return product_over_dim_cu_template<DComplexGDL>(static_cast<DComplexGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3197

case GDL_COMPLEXDBL: return product_over_dim_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3198

default: assert(false);

3199

}

3200

}

3201

3202

// Integer parts derivated from Total code by Erin Sheldon

3203

// In IDL PRODUCT(), the INTEGER keyword takes precedence

3204

if (KwInt) {

3205

// We use GDL_LONG64 unless the input is GDL_ULONG64

3206

if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {

3207

return product_over_dim_cu_template<DLong64GDL>

3208

( static_cast<DLong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3209

}

3210

if ((p0->Type() == GDL_ULONG64 ) && (!KwNaN)) {

3211

return product_over_dim_cu_template<DULong64GDL>

3212

( static_cast<DULong64GDL*>(p0)->Dup(), sumDim-1, nanInt);

3213

}

3214

3215

// Convert to Long64

3216

if (KwNaN) {

3217

DFloatGDL* p0f = static_cast<DFloatGDL*>

3218

(p0->Convert2( GDL_FLOAT, BaseGDL::COPY));

3219

auto_ptr<DFloatGDL> guard( p0f);

3220

for( SizeT i=0; i<nEl; ++i) {

3221

if (!isfinite((*p0f)[i])) (*p0f)[i]=1;

3222

}

3223

return product_over_dim_cu_template<DLong64GDL>

3224

( static_cast<DLong64GDL*>

3225

(p0f->Convert2( GDL_LONG64, BaseGDL::COPY)), sumDim-1, nanInt);

3226

} else {

3227

return product_over_dim_cu_template<DLong64GDL>

3228

( static_cast<DLong64GDL*>

3229

(p0->Convert2( GDL_LONG64, BaseGDL::COPY)), sumDim-1, nanInt);

3230

}

3231

} // integer results

3232

3233

if( p0->Type() == GDL_DOUBLE) {

3234

return product_over_dim_cu_template< DDoubleGDL>

3235

( static_cast<DDoubleGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3236

}

3237

if( p0->Type() == GDL_COMPLEXDBL) {

3238

return product_over_dim_cu_template< DComplexDblGDL>

3239

( static_cast<DComplexDblGDL*>(p0)->Dup(), sumDim-1, KwNaN);

3240

}

3241

if( p0->Type() == GDL_COMPLEX) {

3242

return product_over_dim_cu_template< DComplexDblGDL>

3243

( static_cast<DComplexDblGDL*>

3244

(p0->Convert2( GDL_COMPLEXDBL, BaseGDL::COPY)), sumDim-1, KwNaN);

3245

}

3246

3247

return product_over_dim_cu_template< DDoubleGDL>

3248

( static_cast<DDoubleGDL*>

3249

(p0->Convert2( GDL_DOUBLE, BaseGDL::COPY)), sumDim-1, KwNaN);

3250

}

3251

}

3252

3253

BaseGDL* array_equal( EnvT* e)

3254

{

3255

e->NParam( 2);//, "ARRAY_EQUAL");

3256

3257

BaseGDL* p0 = e->GetParDefined( 0);//, "ARRAY_EQUAL");

3258

BaseGDL* p1 = e->GetParDefined( 1);//, "ARRAY_EQUAL");

3259

3260

if( p0 == p1) return new DByteGDL( 1);

3261

3262

SizeT nEl0 = p0->N_Elements();

3263

SizeT nEl1 = p1->N_Elements();

3264

if( nEl0 != nEl1 && nEl0 != 1 && nEl1 != 1)

3265

return new DByteGDL( 0);

3266

3267

auto_ptr<BaseGDL> p0_guard;

3268

auto_ptr<BaseGDL> p1_guard;

3269

if( p0->Type() != p1->Type())

3270

{

3271

if( e->KeywordSet( 0)) // NO_TYPECONV

3272

return new DByteGDL( 0);

3273

else

3274

{

3275

DType aTy=p0->Type();

3276

DType bTy=p1->Type();

3277

if( DTypeOrder[aTy] >= DTypeOrder[bTy])

3278

{

3279

p1 = p1->Convert2( aTy, BaseGDL::COPY);

3280

p1_guard.reset( p1);

3281

}

3282

else

3283

{

3284

p0 = p0->Convert2( bTy, BaseGDL::COPY);

3285

p0_guard.reset( p0);

3286

}

3287

}

3288

}

3289

3290

if( p0->ArrayEqual( p1)) return new DByteGDL( 1);

3291

3292

return new DByteGDL( 0);

3293

}

3294

3295

BaseGDL* min_fun( EnvT* e)

3296

{

3297

SizeT nParam = e->NParam( 1);

3298

BaseGDL* searchArr = e->GetParDefined( 0);

3299

3300

bool omitNaN = e->KeywordSet( "NAN");

3301

3302

static int subIx = e->KeywordIx("SUBSCRIPT_MAX");

3303

bool subMax = e->KeywordPresent(subIx);

3304

3305

static int dimIx = e->KeywordIx("DIMENSION");

3306

bool dimSet = e->KeywordSet(dimIx);

3307

3308

static int maxIx = e->KeywordIx("MAX");

3309

bool maxSet = e->KeywordPresent(maxIx);

3310

3311

DLong searchDim;

3312

if (dimSet) {

3313

e->AssureLongScalarKW(dimIx, searchDim);

3314

if (searchDim < 0 || searchDim > searchArr->Rank())

3315

e->Throw("Illegal keyword value for DIMENSION");

3316

}

3317

3318

if (dimSet && searchArr->Rank() > 1)

3319

{

3320

searchDim -= 1; // user-supplied dimensions start with 1!

3321

3322

// here destDim is in fact the srcDim...

3323

dimension destDim = searchArr->Dim();

3324

SizeT searchStride = destDim.Stride(searchDim);

3325

SizeT outerStride = destDim.Stride(searchDim + 1);

3326

// ... and now becomes the destDim

3327

SizeT nSearch = destDim.Remove(searchDim);

3328

SizeT searchLimit = nSearch * searchStride;

3329

SizeT nEl = searchArr->N_Elements();

3330

3331

// memory allocation

3332

BaseGDL *maxVal, *resArr = searchArr->New(destDim, BaseGDL::NOZERO);

3333

DLongGDL *minElArr, *maxElArr;

3334

3335

if (maxSet)

3336

{

3337

e->AssureGlobalKW(maxIx); // instead of using a guard pointer

3338

maxVal = searchArr->New(destDim, BaseGDL::NOZERO);

3339

}

3340

3341

if (subMax)

3342

{

3343

e->AssureGlobalKW(subIx); // instead of using a guard pointer

3344

maxElArr = new DLongGDL(destDim);

3345

}

3346

3347

if (nParam == 2)

3348

{

3349

e->AssureGlobalPar(1); // instead of using a guard pointer

3350

minElArr = new DLongGDL(destDim);

3351

}

3352

3353

SizeT rIx = 0;

3354

for (SizeT o = 0; o < nEl; o += outerStride) for (SizeT i = 0; i < searchStride; ++i)

3355

{

3356

searchArr->MinMax(

3357

(nParam == 2 ? &((*minElArr)[rIx]) : NULL),

3358

(subMax ? &((*maxElArr)[rIx]) : NULL),

3359

&resArr,

3360

(maxSet ? &maxVal : NULL),

3361

omitNaN, o + i, searchLimit + o + i, searchStride, rIx

3362

);

3363

rIx++;

3364

}

3365

3366

if (nParam == 2) e->SetPar(1, minElArr);

3367

if (subMax) e->SetKW(subIx, maxElArr);

3368

if (maxSet) e->SetKW(maxIx, maxVal);

3369

3370

return resArr;

3371

}

3372

else

3373

{

3374

DLong minEl;

3375

BaseGDL* res;

3376

3377

if (maxSet) // MAX keyword given

3378

{

3379

e->AssureGlobalKW( 0);

3380

GDLDelete(e->GetKW( 0));

3381

DLong maxEl;

3382

searchArr->MinMax( &minEl, &maxEl, &res, &e->GetKW( 0), omitNaN);

3383

if (subMax) e->SetKW(subIx, new DLongGDL(maxEl));

3384

}

3385

else // no MAX keyword

3386

{

3387

if (subMax)

3388

{

3389

DLong maxEl;

3390

searchArr->MinMax( &minEl, &maxEl, &res, NULL, omitNaN);

3391

e->SetKW(subIx, new DLongGDL(maxEl));

3392

}

3393

else searchArr->MinMax(&minEl, NULL, &res, NULL, omitNaN);

3394

}

3395

3396

// handle index

3397

if (nParam == 2) e->SetPar(1, new DLongGDL( minEl));

3398

else SysVar::SetC( minEl);

3399

return res;

3400

}

3401

}

3402

3403

BaseGDL* max_fun( EnvT* e)

3404

{

3405

SizeT nParam = e->NParam( 1);

3406

BaseGDL* searchArr = e->GetParDefined( 0);

3407

3408

bool omitNaN = e->KeywordSet( "NAN");

3409

3410

static int subIx = e->KeywordIx("SUBSCRIPT_MIN");

3411

bool subMin = e->KeywordPresent(subIx);

3412

3413

static int dimIx = e->KeywordIx("DIMENSION");

3414

bool dimSet = e->KeywordSet(dimIx);

3415

3416

static int minIx = e->KeywordIx("MIN");

3417

bool minSet = e->KeywordPresent(minIx);

3418

3419

DLong searchDim;

3420

if (dimSet)

3421

{

3422

e->AssureLongScalarKW(dimIx, searchDim);

3423

if (searchDim < 0 || searchDim > searchArr->Rank())

3424

e->Throw("Illegal keyword value for DIMENSION");

3425

}

3426

3427

if (dimSet && searchArr->Rank() > 1)

3428

{

3429

searchDim -= 1; // user-supplied dimensions start with 1!

3430

3431

// here destDim is in fact the srcDim...

3432

dimension destDim = searchArr->Dim();

3433

SizeT searchStride = destDim.Stride(searchDim);

3434

SizeT outerStride = destDim.Stride(searchDim + 1);

3435

// ... and now becomes the destDim

3436

SizeT nSearch = destDim.Remove(searchDim);

3437

SizeT searchLimit = nSearch * searchStride;

3438

SizeT nEl = searchArr->N_Elements();

3439

3440

// memory allocation

3441

BaseGDL *minVal, *resArr = searchArr->New(destDim, BaseGDL::NOZERO);

3442

DLongGDL *minElArr, *maxElArr;

3443

3444

if (minSet)

3445

{

3446

e->AssureGlobalKW(minIx); // instead of using a guard pointer

3447

minVal = searchArr->New(destDim, BaseGDL::NOZERO);

3448

}

3449

3450

if (subMin)

3451

{

3452

e->AssureGlobalKW(subIx); // instead of using a guard pointer

3453

minElArr = new DLongGDL(destDim);

3454

}

3455

3456

if (nParam == 2)

3457

{

3458

e->AssureGlobalPar(1); // instead of using a guard pointer

3459

maxElArr = new DLongGDL(destDim);

3460

}

3461

3462

SizeT rIx = 0;

3463

for (SizeT o = 0; o < nEl; o += outerStride) for (SizeT i = 0; i < searchStride; ++i)

3464

{

3465

searchArr->MinMax(

3466

(subMin ? &((*minElArr)[rIx]) : NULL),

3467

(nParam == 2 ? &((*maxElArr)[rIx]) : NULL),

3468

(minSet ? &minVal : NULL),

3469

&resArr,

3470

omitNaN, o + i, searchLimit + o + i, searchStride, rIx

3471

);

3472

rIx++;

3473

}

3474

3475

if (nParam == 2) e->SetPar(1, maxElArr);

3476

if (subMin) e->SetKW(subIx, minElArr);

3477

if (minSet) e->SetKW(minIx, minVal);

3478

3479

return resArr;

3480

}

3481

else

3482

{

3483

DLong maxEl;

3484

BaseGDL* res;

3485

3486

if (minSet) // MIN keyword given

3487

{

3488

e->AssureGlobalKW( 0);

3489

GDLDelete(e->GetKW( 0));

3490

DLong minEl;

3491

searchArr->MinMax( &minEl, &maxEl, &e->GetKW( 0), &res, omitNaN);

3492

if (subMin) e->SetKW(subIx, new DLongGDL(minEl));

3493

}

3494

else // no MIN keyword

3495

{

3496

if (subMin)

3497

{

3498

DLong minEl;

3499

searchArr->MinMax( &minEl, &maxEl, NULL, &res, omitNaN);

3500

e->SetKW(subIx, new DLongGDL(minEl));

3501

}

3502

else searchArr->MinMax(NULL, &maxEl, NULL, &res, omitNaN);

3503

}

3504

3505

// handle index

3506

if (nParam == 2) e->SetPar(1, new DLongGDL( maxEl));

3507

else SysVar::SetC(maxEl);

3508

return res;

3509

}

3510

}

3511

3512

BaseGDL* transpose( EnvT* e)

3513

{

3514

SizeT nParam=e->NParam( 1);

3515

3516

BaseGDL* p0 = e->GetParDefined( 0);

3517

if( p0->Type() == GDL_STRUCT)

3518

e->Throw("Struct expression not allowed in this context: "+

3519

e->GetParString(0));

3520

3521

SizeT rank = p0->Rank();

3522

if( rank == 0)

3523

e->Throw( "Expression must be an array "

3524

"in this context: "+ e->GetParString(0));

3525

3526

if( nParam == 2)

3527

{

3528

3529

BaseGDL* p1 = e->GetParDefined( 1);

3530

if( p1->N_Elements() != rank)

3531

e->Throw("Incorrect number of elements in permutation.");

3532

3533

DUInt* perm = new DUInt[rank];

3534

auto_ptr<DUInt> perm_guard( perm);

3535

3536

DUIntGDL* p1L = static_cast<DUIntGDL*>

3537

(p1->Convert2( GDL_UINT, BaseGDL::COPY));

3538

for( SizeT i=0; i<rank; ++i) perm[i] = (*p1L)[ i];

3539

GDLDelete(p1L);

3540

3541

// check permutation vector

3542

for( SizeT i=0; i<rank; ++i)

3543

{

3544

DUInt j;

3545

for( j=0; j<rank; ++j) if( perm[j] == i) break;

3546

if (j == rank)

3547

e->Throw( "Incorrect permutation vector.");

3548

}

3549

return p0->Transpose( perm);

3550

}

3551

3552

return p0->Transpose( NULL);

3553

}

3554

3555

3556

// BaseGDL* matrix_multiply( EnvT* e)

3557

// {

3558

// SizeT nParam=e->NParam( 2);

3559

//

3560

// BaseGDL* a = e->GetNumericArrayParDefined( 0);

3561

// BaseGDL* b = e->GetNumericArrayParDefined( 1);

3562

//

3563

// static int aTIx = e->KeywordIx("ATRANSPOSE");

3564

// bool aT = e->KeywordPresent(aTIx);

3565

// static int bTIx = e->KeywordIx("BTRANSPOSE");

3566

// bool bT = e->KeywordPresent(bTIx);

3567

//

3568

// static int strassenIx = e->KeywordIx("STRASSEN_ALGORITHM");

3569

// bool strassen = e->KeywordPresent(strassenIx);

3570

//

3571

//

3572

// if( p1->N_Elements() != rank)

3573

// e->Throw("Incorrect number of elements in permutation.");

3574

//

3575

// DUInt* perm = new DUInt[rank];

3576

// auto_ptr<DUInt> perm_guard( perm);

3577

//

3578

// DUIntGDL* p1L = static_cast<DUIntGDL*>

3579

// (p1->Convert2( GDL_UINT, BaseGDL::COPY));

3580

// for( SizeT i=0; i<rank; ++i) perm[i] = (*p1L)[ i];

3581

// delete p1L;

3582

//

3583

// // check permutaion vector

3584

// for( SizeT i=0; i<rank; ++i)

3585

// {

3586

// DUInt j;

3587

// for( j=0; j<rank; ++j) if( perm[j] == i) break;

3588

// if (j == rank)

3589

// e->Throw( "Incorrect permutation vector.");

3590

// }

3591

// return p0->Transpose( perm);

3592

// }

3593

//

3594

// return a->Transpose( NULL);

3595

// }

3596

3597

// helper function for sort_fun, recursive

3598

// optimized version

3599

template< typename IndexT>

3600

void MergeSortOpt( BaseGDL* p0, IndexT* hhS, IndexT* h1, IndexT* h2,

3601

SizeT len)

3602

{

3603

if( len <= 1) return;

3604

3605

SizeT h1N = len / 2;

3606

SizeT h2N = len - h1N;

3607

3608

// 1st half

3609

MergeSortOpt(p0, hhS, h1, h2, h1N);

3610

3611

// 2nd half

3612

IndexT* hhM = &hhS[h1N];

3613

MergeSortOpt(p0, hhM, h1, h2, h2N);

3614

3615

SizeT i;

3616

for(i=0; i<h1N; ++i) h1[i] = hhS[ i];

3617

for(i=0; i<h2N; ++i) h2[i] = hhM[ i];

3618

3619

SizeT h1Ix = 0;

3620

SizeT h2Ix = 0;

3621

for( i=0; (h1Ix < h1N) && (h2Ix < h2N); ++i)

3622

{

3623

// the actual comparisson

3624

if( p0->Greater( h1[h1Ix], h2[h2Ix]))

3625

hhS[ i] = h2[ h2Ix++];

3626

else

3627

hhS[ i] = h1[ h1Ix++];

3628

}

3629

for(; h1Ix < h1N; ++i) hhS[ i] = h1[ h1Ix++];

3630

for(; h2Ix < h2N; ++i) hhS[ i] = h2[ h2Ix++];

3631

}

3632

3633

// helper function for sort_fun, recursive

3634

void MergeSort( BaseGDL* p0, SizeT* hh, SizeT* h1, SizeT* h2,

3635

SizeT start, SizeT end)

3636

{

3637

if( start+1 >= end) return;

3638

3639

SizeT middle = (start+end) / 2;

3640

3641

MergeSort(p0, hh, h1, h2, start, middle);

3642

MergeSort(p0, hh, h1, h2, middle, end);

3643

3644

SizeT h1N = middle - start;

3645

SizeT h2N = end - middle;

3646

3647

SizeT* hhS = &hh[start];

3648

3649

SizeT i;

3650

for(i=0; i<h1N; ++i) h1[i] = hhS[ i];

3651

for(i=0; i<h2N; ++i) h2[i] = hh[middle + i];

3652

3653

SizeT h1Ix = 0;

3654

SizeT h2Ix = 0;

3655

for( i=0; (h1Ix < h1N) && (h2Ix < h2N); ++i)

3656

{

3657

// the actual comparisson

3658

if( p0->Greater( h1[h1Ix], h2[h2Ix]))

3659

hhS[ i] = h2[ h2Ix++];

3660

else

3661

hhS[ i] = h1[ h1Ix++];

3662

}

3663

for(; h1Ix < h1N; ++i) hhS[ i] = h1[ h1Ix++];

3664

for(; h2Ix < h2N; ++i) hhS[ i] = h2[ h2Ix++];

3665

}

3666

3667

// sort function uses MergeSort

3668

BaseGDL* sort_fun( EnvT* e)

3669

{

3670

e->NParam( 1);

3671

3672

BaseGDL* p0 = e->GetParDefined( 0);

3673

3674

if( p0->Type() == GDL_STRUCT)

3675

e->Throw( "Struct expression not allowed in this context: "+

3676

e->GetParString(0));

3677

3678

static int l64Ix = e->KeywordIx( "L64");

3679

bool l64 = e->KeywordSet( l64Ix);

3680

3681

SizeT nEl = p0->N_Elements();

3682

3683

// helper arrays

3684

DLongGDL* res = new DLongGDL( dimension( nEl), BaseGDL::INDGEN);

3685

3686

DLong nanIx = nEl;

3687

if( p0->Type() == GDL_FLOAT)

3688

{

3689

DFloatGDL* p0F = static_cast<DFloatGDL*>(p0);

3690

for( DLong i=nEl-1; i >= 0; --i)

3691

{

3692

if( isnan((*p0F)[ i]) )//|| !isfinite((*p0F)[ i]))

3693

{

3694

--nanIx;

3695

(*res)[i] = (*res)[nanIx];

3696

(*res)[ nanIx] = i;

3697

3698

// cout << "swap " << i << " with " << nanIx << endl;

3699

// cout << "now: ";

3700

// for( DLong ii=0; ii < nEl; ++ii)

3701

// {

3702

// cout << (*res)[ii] << " ";

3703

// }

3704

// cout << endl;

3705

}

3706

}

3707

}

3708

else if( p0->Type() == GDL_DOUBLE)

3709

{

3710

DDoubleGDL* p0F = static_cast<DDoubleGDL*>(p0);

3711

for( DLong i=nEl-1; i >= 0; --i)

3712

{

3713

if( isnan((*p0F)[ i]))// || !isfinite((*p0F)[ i]))

3714

{

3715

--nanIx;

3716

(*res)[i] = (*res)[nanIx];

3717

(*res)[ nanIx] = i;

3718

}

3719

}

3720

}

3721

else if( p0->Type() == GDL_COMPLEX)

3722

{

3723

DComplexGDL* p0F = static_cast<DComplexGDL*>(p0);

3724

for( DLong i=nEl-1; i >= 0; --i)

3725

{

3726

if( isnan((*p0F)[ i].real()) || //!isfinite((*p0F)[ i].real()) ||

3727

isnan((*p0F)[ i].imag()))// || !isfinite((*p0F)[ i].imag()) )

3728

{

3729

--nanIx;

3730

(*res)[i] = (*res)[nanIx];

3731

(*res)[ nanIx] = i;

3732

}

3733

}

3734

}

3735

else if( p0->Type() == GDL_COMPLEXDBL)

3736

{

3737

DComplexDblGDL* p0F = static_cast<DComplexDblGDL*>(p0);

3738

for( DLong i=nEl-1; i >= 0; --i)

3739

{

3740

if( isnan((*p0F)[ i].real()) || //!isfinite((*p0F)[ i].real()) ||

3741

isnan((*p0F)[ i].imag()))// || !isfinite((*p0F)[ i].imag()) )

3742

{

3743

--nanIx;

3744

(*res)[i] = (*res)[nanIx];

3745

(*res)[ nanIx] = i;

3746

}

3747

}

3748

}

3749

3750

// cout << "nEl " << nEl << " nanIx " << nanIx << endl;

3751

nEl = nanIx;

3752

// cout << "sorting: ";

3753

// for( DLong ii=0; ii < nEl; ++ii)

3754

// {

3755

// cout << (*res)[ii] << " ";

3756

// }

3757

// cout << endl;

3758

3759

DLong *hh = static_cast<DLong*>(res->DataAddr());

3760

3761

DLong* h1 = new DLong[ nEl/2];

3762

DLong* h2 = new DLong[ (nEl+1)/2];

3763

// call the sort routine

3764

MergeSortOpt<DLong>( p0, hh, h1, h2, nEl);

3765

delete[] h1;

3766

delete[] h2;

3767

3768

if( l64)

3769

{

3770

// leave it this way, as sorting of more than 2^31

3771

// items seems not feasible in the future we might

3772

// use MergeSortOpt<DLong64>(...) for this

3773

return res->Convert2( GDL_LONG64);

3774

}

3775

3776

return res;

3777

}

3778

3779

// uses MergeSort

3780

// 2 parts in the code: without "width" or with "width" (limited to 1D and 2D)

3781

BaseGDL* median( EnvT* e) {

3782

3783

BaseGDL* p0 = e->GetParDefined( 0);

3784

3785

if( p0->Type() == GDL_PTR)

3786

e->Throw( "Pointer expression not allowed in this context: "+ e->GetParString(0));

3787

if( p0->Type() == GDL_OBJ)

3788

e->Throw( "Object expression not allowed in this context: "+ e->GetParString(0));

3789

if( p0->Type() == GDL_STRUCT)

3790

e->Throw( "Struct expression not allowed in this context: "+ e->GetParString(0));

3791

3792

if( p0->Rank() == 0)

3793

e->Throw( "Expression must be an array in this context: "+ e->GetParString(0));

3794

3795

SizeT nParam = e->NParam( 1);

3796

SizeT nEl = p0->N_Elements();

3797

3798

// "f_nan" and "d_nan" used by both parts ...

3799

static DStructGDL *Values = SysVar::Values();

3800

DFloat f_nan=(*static_cast<DFloatGDL*>(Values->GetTag(Values->Desc()->TagIndex("F_NAN"), 0)))[0];

3801

DDouble d_nan=(*static_cast<DDoubleGDL*>(Values->GetTag(Values->Desc()->TagIndex("D_NAN"), 0)))[0];

3802

3803

// --------------------------------------------------------

3804

// begin of the part 1: without "width" param

3805

if( nParam == 1) {

3806

3807

static int evenIx = e->KeywordIx( "EVEN");

3808

3809

// TYPE

3810

bool dbl =

3811

p0->Type() == GDL_DOUBLE ||

3812

p0->Type() == GDL_COMPLEXDBL ||

3813

e->KeywordSet(e->KeywordIx("DOUBLE"));

3814

DType type = dbl ? GDL_DOUBLE : GDL_FLOAT;

3815

bool noconv = (dbl && p0->Type() == GDL_DOUBLE) ||

3816

(!dbl && p0->Type() == GDL_FLOAT);

3817

3818

// DIMENSION keyword

3819

DLong dim = 0;

3820

DLong nmed = 1;

3821

BaseGDL *res;

3822

e->AssureLongScalarKWIfPresent( "DIMENSION", dim);

3823

3824

// cout << "dim : "<< dim << endl;

3825

3826

if (dim > p0->Rank())

3827

e->Throw( "Illegal keyword value for DIMENSION.");

3828

3829

if (dim > 0) {

3830

DLong dims[8];

3831

DLong k = 0;

3832

for (SizeT i=0; i<p0->Rank(); ++i)

3833

if (i != (dim-1)) {

3834

nmed *= p0->Dim(i);

3835

dims[k++] = p0->Dim(i);

3836

}

3837

dimension dimRes((DLong *) dims, p0->Rank()-1);

3838

res = dbl

3839

? static_cast<BaseGDL*>(new DDoubleGDL(dimRes, BaseGDL::NOZERO))

3840

: static_cast<BaseGDL*>(new DFloatGDL(dimRes, BaseGDL::NOZERO));

3841

} else {

3842

res = dbl

3843

? static_cast<BaseGDL*>(new DDoubleGDL(1))

3844

: static_cast<BaseGDL*>(new DFloatGDL(1));

3845

}

3846

3847

// conversion of Complex types

3848

if (p0->Type() == GDL_COMPLEX) p0 = p0->Convert2(GDL_FLOAT, BaseGDL::COPY);

3849

if (p0->Type() == GDL_COMPLEXDBL) p0 = p0->Convert2(GDL_DOUBLE, BaseGDL::COPY);

3850

3851

// helper arrays

3852

if (nmed > 1) nEl = p0->N_Elements() / nmed;

3853

3854

// cout << "hello2" << endl;

3855

3856

DLong *hh = new DLong[ nEl];

3857

DLong* h1 = new DLong[ nEl/2];

3858

DLong* h2 = new DLong[ (nEl+1)/2];

3859

3860

DLong accumStride = 1;

3861

if (nmed > 1)

3862

for( DLong i=0; i<dim-1; ++i) accumStride *= p0->Dim(i);

3863

3864

BaseGDL *op1, *op2, *op3;

3865

if (dbl) op3 = new DDoubleGDL(2);

3866

else op3 = new DFloatGDL(2);

3867

3868

// nEl_extern is used to store "nEl" initial value

3869

DLong nanIx, nEl_extern;

3870

nEl_extern=nEl;

3871

// if (nmed > 1) nEl_extern = p0->N_Elements() / nmed;

3872

//else nEl_extern = p0->N_Elements();

3873

3874

// cout << "hello type" << p0->Type() << endl;

3875

3876

// Loop over all subarray medians

3877

for (SizeT k=0; k<nmed; ++k) {

3878

3879

// nEl=nEl_extern;

3880

3881

if (nmed == 1) {

3882

//cout << "hello inside 1D" << endl;

3883

for( DLong i=0; i<nEl; ++i) hh[i] = i;

3884

nanIx = nEl;

3885

3886

if (p0->Type() == GDL_DOUBLE) {

3887

DDoubleGDL* p0F = static_cast<DDoubleGDL*>(p0);

3888

for( DLong i=nEl-1; i >= 0; --i) {

3889

if( isnan((*p0F)[i])) {

3890

--nanIx;

3891

hh[i] = hh[nanIx];

3892

hh[ nanIx] = i;

3893

}

3894

}

3895

}

3896

3897

if (p0->Type() == GDL_FLOAT) {

3898

DFloatGDL* p0F = static_cast<DFloatGDL*>(p0);

3899

for( DLong i=nEl-1; i >= 0; --i) {

3900

if( isnan((*p0F)[i])) {

3901

--nanIx;

3902

hh[i] = hh[nanIx];

3903

hh[ nanIx] = i;

3904

}

3905

}

3906

}

3907

3908

//cout << "nEl " << nEl << " nanIx " << nanIx << endl;

3909

nEl = nanIx;

3910

}

3911

else

3912

{

3913

nanIx = nEl;

3914

nEl=nEl_extern;

3915

3916

// DLong nanIx = nEl;

3917

// Starting Element

3918

DLong start = accumStride * p0->Dim(dim-1) * (k / accumStride) +

3919

(k % accumStride);

3920

for( DLong i=0; i<nEl; ++i) hh[i] = start + i * accumStride;

3921

DLong jj;

3922

nanIx = nEl;

3923

3924

if (p0->Type() == GDL_FLOAT) {

3925

DFloatGDL* p0F = static_cast<DFloatGDL*>(p0);

3926

for( DLong i=nEl-1; i >= 0; --i) {

3927

jj=start + i * accumStride;

3928

if( isnan((*p0F)[ jj]) ) {

3929

--nanIx;

3930

hh[i] = hh[nanIx];

3931

hh[ nanIx] = i;

3932

}

3933

}

3934

nEl = nanIx;

3935

}

3936

3937

if (p0->Type() == GDL_DOUBLE) {

3938

DDoubleGDL* p0F = static_cast<DDoubleGDL*>(p0);

3939

for( DLong i=nEl-1; i >= 0; --i) {

3940

jj=start + i * accumStride;

3941

if( isnan((*p0F)[ jj]) ) {

3942

--nanIx;

3943

hh[i] = hh[nanIx];

3944

hh[ nanIx] = i;

3945

}

3946

}

3947

//cout << "nanIx :" << nanIx << "nEl :" << nEl << endl;

3948

nEl = nanIx;

3949

}

3950

}

3951

DLong medEl, medEl_1;

3952

3953

// call the sort routine

3954

if (nEl > 1) {

3955

MergeSortOpt<DLong>( p0, hh, h1, h2, nEl);

3956

medEl = hh[ nEl/2];

3957

medEl_1 = hh[ nEl/2 - 1];

3958

} else {

3959

if (nEl == 1) {

3960

medEl = hh[0];

3961

medEl_1 = hh[0];

3962

} else

3963

{ // normal case, more than one element, nothing to do

3964

//cout << "gasp : no result ! " << endl;

3965

}

3966

}

3967

3968

if (nEl <= 0) { // we have a NaN

3969

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = d_nan;

3970

else (*static_cast<DFloatGDL*>(res))[k] = f_nan;

3971

} else {

3972

//cout << k << "" << (*static_cast<DFloatGDL*>(p0))[medEl] << " "

3973

// << (*static_cast<DFloatGDL*>(p0))[medEl_1] << endl;

3974

//cout << "k :" << k << endl;

3975

if( (nEl % 2) == 1 || !e->KeywordSet( evenIx)) {

3976

if (nmed == 1)

3977

res = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);

3978

else {

3979

if (noconv)

3980

{

3981

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = (*static_cast<DDoubleGDL*>(p0))[medEl];

3982

else (*static_cast<DFloatGDL*>(res))[k] = (*static_cast<DFloatGDL*>(p0))[medEl];

3983

}

3984

else

3985

{

3986

op1 = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);

3987

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = (*static_cast<DDoubleGDL*>(op1))[0];

3988

else (*static_cast<DFloatGDL*>(res))[k] = (*static_cast<DFloatGDL*>(op1))[0];

3989

delete(op1);

3990

}

3991

}

3992

} else {

3993

if (noconv)

3994

{

3995

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] = .5 * (

3996

(*static_cast<DDoubleGDL*>(p0))[medEl] +

3997

(*static_cast<DDoubleGDL*>(p0))[medEl_1]

3998

);

3999

else (*static_cast<DFloatGDL*>(res))[k] = .5 * (

4000

(*static_cast<DFloatGDL*>(p0))[medEl] +

4001

(*static_cast<DFloatGDL*>(p0))[medEl_1]

4002

);

4003

}

4004

else

4005

{

4006

op1 = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);

4007

op2 = p0->NewIx(medEl_1)->Convert2(type, BaseGDL::CONVERT);

4008

if (nmed == 1) res = op2->Add(op1)->Div(op3); // TODO: leak with res?

4009

else

4010

{

4011

if (dbl) (*static_cast<DDoubleGDL*>(res))[k] =

4012

(*static_cast<DDoubleGDL*>((op2->Add(op1)->Div(op3))))[0];

4013

else (*static_cast<DFloatGDL*>(res))[k] =

4014

(*static_cast<DFloatGDL*>((op2->Add(op1)->Div(op3))))[0];

4015

delete(op2);

4016

}

4017

delete(op1);

4018

}

4019

}

4020

}

4021

}

4022

delete(op3);

4023

delete[] h1;

4024

delete[] h2;

4025

delete[] hh;

4026

4027

return res;

4028

}

4029

4030

// begin of the part 2: with "width" param

4031

if( nParam == 2) {

4032

// with parameter Width : median filtering with no optimisation,

4033

// such as histogram algorithms.

4034

4035

4036

// basic checks on "vector/array" input

4037

DDoubleGDL* p0 = e->GetParAs<DDoubleGDL>( 0);

4038

4039

if( p0->Rank() > 2)

4040

e->Throw( "Only 1 or 2 dimensions allowed: "+ e->GetParString(0));

4041

4042

// basic checks on "width" input

4043

DDoubleGDL* p1d = e->GetParAs<DDoubleGDL>(1);

4044

4045

if (p1d->N_Elements() > 1 || (*p1d)[0] <=0 )

4046

e->Throw( "Width must be a positive scalar or 1 (positive) element array in this context: "+ e->GetParString(0));

4047

DLong MaxAllowedWidth=0;

4048

if (p0->Rank() == 1) MaxAllowedWidth=p0->N_Elements();

4049

if (p0->Rank() == 2) {

4050

MaxAllowedWidth=p0->Dim(0);

4051

if (p0->Dim(1) < MaxAllowedWidth) MaxAllowedWidth=p0->Dim(1);

4052

}

4053

const int debug =0;

4054

if (debug == 1) {

4055

cout << "X dim " << p0->Dim(0) <<endl;

4056

cout << "y dim " << p0->Dim(1) <<endl;

4057

cout << "MaxAllowedWidth " << MaxAllowedWidth <<endl;

4058

}

4059

if (!isfinite( (*p1d)[0]))

4060

e->Throw("Width must be > 1, and < dimension of array (NaN or Inf)");

4061

4062

DLongGDL* p1 = e->GetParAs<DLongGDL>(1);

4063

4064

DDoubleGDL *tamp = new DDoubleGDL(p0->Dim(),BaseGDL::NOZERO);

4065

DDouble min=((*p0)[0]);

4066

DDouble max=min;

4067

4068

for (SizeT ii=0 ; ii<p0->N_Elements() ; ++ii)

4069

{(*tamp)[ii]=(*p0)[ii];

4070

if ( (*p0)[ii] < min ) min = ((*p0)[ii]);

4071

if ( (*p0)[ii] > max ) max = ((*p0)[ii]);

4072

}

4073

4074

//---------------------------- END d'acquisistion des paramètres -------------------------------------

4075

4076

4077

static int evenIx = e->KeywordIx( "EVEN");

4078

static int doubleIx = e->KeywordIx( "DOUBLE");

4079

static DStructGDL *Values = SysVar::Values();

4080

DDouble d_nan=(*static_cast<DDoubleGDL*>(Values->GetTag(Values->Desc()->TagIndex("D_NAN"), 0)))[0];

4081

DDouble d_infinity= (*static_cast<DDoubleGDL*>(Values->GetTag(Values->Desc()->TagIndex("D_INFINITY"), 0)))[0];

4082

4083

//------------------------------ Init variables and allocation ---------------------------------------

4084

SizeT width=(*p1)[0];

4085

SizeT N_MaskElem= width*width;

4086

SizeT larg = p0->Stride(1);

4087

SizeT haut = p0->Stride(2)/larg;

4088

SizeT lim= static_cast<SizeT>(round(width/2));

4089

SizeT init=(lim*larg+lim);

4090

4091

// we don't go further if dimension(s) versus not width OK

4092

4093

if (debug == 1) {cout << "ici" <<endl;}

4094

4095

if ( p0->Rank() == 1) {

4096

if (larg < width || width==1 ) e->Throw( "Width must be > 1, and < width of vector");

4097

}

4098

if ( p0->Rank() == 2) {

4099

if (larg < width || haut < width || width==1) e->Throw("Width must be > 1, and < dimension of array");

4100

}

4101

4102

// for 2D arrays, we use the algorithm described in paper

4103

// from T. Huang, G. Yang, and G. Tang, “A Fast Two-Dimensional Median

4104

// Filtering Algorithm,” IEEE Trans. Acoust., Speech, Signal Processing,

4105

// vol. 27, no. 1, pp. 13–18, 1979.

4106

4107

if ( (e->GetParDefined( 0)->Type() == GDL_BYTE ||

4108

e->GetParDefined( 0)->Type() == GDL_INT ||

4109

e->GetParDefined( 0)->Type() == GDL_UINT ||

4110

e->GetParDefined( 0)->Type() == GDL_LONG ||

4111

e->GetParDefined( 0)->Type() == GDL_ULONG ||

4112

e->GetParDefined( 0)->Type() == GDL_LONG64 ||

4113

e->GetParDefined( 0)->Type() == GDL_ULONG64) &&

4114

(haut>1))

4115

{

4116

SizeT taille=static_cast<SizeT>(abs(max)-min+1);

4117

DDoubleGDL* Histo = new DDoubleGDL(taille,BaseGDL::NOZERO);

4118

if (width % 2 ==0)

4119

{

4120

for(SizeT i=0 ; i<haut-2*lim ; ++i)

4121

{

4122

SizeT ltmed=0;

4123

SizeT med=0;

4124

SizeT initial=init+i*larg-lim*larg-lim;

4125

for(SizeT pp=0 ; pp<taille;++pp)(*Histo)[pp]=0;

4126

for (SizeT ii=initial ; ii <initial+ width ; ++ii)

4127

{

4128

for(SizeT yy=0;yy<width;yy++)

4129

(*Histo)[static_cast<SizeT>((*p0)[ii+yy*larg]-min)]++;

4130

}

4131

4132

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

4133

{

4134

ltmed+= static_cast<SizeT>((*Histo)[med]);

4135

++med;

4136

}

4137

if (e->KeywordSet( evenIx))

4138

{

4139

4140

SizeT EvenMed=med;

4141

//if ((*Histo)[EvenMed]==1 || (ltmed!=0 && ltmed !=(N_MaskElem /2) -1))

4142

if ((*Histo)[EvenMed]==1 || (ltmed!=0 && N_MaskElem /2- ltmed!=1) )

4143

{

4144

while ((*Histo)[EvenMed-1]==0)

4145

{ EvenMed--;}

4146

(*tamp)[init+i*larg]=((med+min)+(EvenMed-1+min))/2;

4147

}

4148

else

4149

(*tamp)[init+i*larg]=med+min;

4150

}

4151

else

4152

{(*tamp)[init+i*larg]=med+min; }

4153

4154

for(SizeT j=init+i*larg +1; j<init+(i+1)*larg-2*lim ;++ j)

4155

{

4156

SizeT initMask=j-lim*larg-lim;

4157

for(SizeT k=0;k<2*lim;++k)

4158

{

4159

(*Histo)[static_cast<SizeT>((*p0)[initMask-1+k*larg]-min)]--;

4160

if ((*p0)[initMask-1+k*larg]-min<med)ltmed--;

4161

4162

(*Histo)[static_cast<SizeT>((*p0)[initMask+k*larg+2*lim-1]-min)]++;

4163

if ((*p0)[initMask+k*larg+2*lim-1]-min<med)ltmed++;

4164

}

4165

if (ltmed>N_MaskElem /2)

4166

{

4167

while(ltmed>N_MaskElem /2)

4168

{

4169

--med;

4170

ltmed-=static_cast<SizeT>((*Histo)[med]);

4171

}

4172

}

4173

else

4174

{

4175

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

4176

{

4177

ltmed+= static_cast<SizeT>((*Histo)[med]);

4178

++med;

4179

}

4180

}

4181

4182

if (e->KeywordSet( evenIx))

4183

{

4184

SizeT EvenMed=med;

4185

if ((*Histo)[EvenMed]==1 || (ltmed!=0 &&N_MaskElem /2- ltmed!=1 ))

4186

{

4187

while ((*Histo)[EvenMed-1]==0)

4188

{ EvenMed--;}

4189

(*tamp)[j]=((med+min)+(EvenMed-1+min))/2;

4190

}

4191

else

4192

{(*tamp)[j]=med+min; }

4193

}

4194

else

4195

{(*tamp)[j]=med+min; }

4196

}

4197

}

4198

}

4199

else

4200

{

4201

for(SizeT i=0 ; i<haut-2*lim ; ++i)

4202

{

4203

SizeT ltmed=0;

4204

SizeT med=0;

4205

SizeT initial=init+i*larg-lim*larg-lim;

4206

for(SizeT pp=0 ; pp<taille;++pp)(*Histo)[pp]=0;

4207

for (SizeT ii=initial ; ii <initial+ width ; ++ii)

4208

{

4209

for(SizeT yy=0;yy<width;yy++)

4210

(*Histo)[static_cast<SizeT>((*p0)[ii+yy*larg]-min)]++;

4211

}

4212

4213

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

4214

{

4215

ltmed+= static_cast<SizeT>((*Histo)[med]);

4216

++med;

4217

}

4218

(*tamp)[init+i*larg]=med+min;

4219

4220

for(SizeT j=init+i*larg +1; j<init+(i+1)*larg-2*lim ;++ j)

4221

{

4222

4223

SizeT initMask=j-lim*larg-lim;

4224

for(SizeT k=0;k<=2*lim;++k)

4225

{

4226

(*Histo)[static_cast<SizeT>((*p0)[initMask-1+k*larg]-min)]--;

4227

if ((*p0)[initMask-1+k*larg]-min<med)ltmed--;

4228

4229

(*Histo)[static_cast<SizeT>((*p0)[initMask+k*larg+2*lim]-min)]++;

4230

if ((*p0)[initMask+k*larg+2*lim]-min<med)ltmed++;

4231

}

4232

if (ltmed>N_MaskElem /2)

4233

{

4234

while(ltmed>N_MaskElem /2)

4235

{

4236

--med;

4237

ltmed-=static_cast<SizeT>((*Histo)[med]);

4238

}

4239

}

4240

else

4241

{

4242

while (ltmed+(*Histo)[med]<=(N_MaskElem /2))

4243

{

4244

ltmed+= static_cast<SizeT>((*Histo)[med]);

4245

++med;

4246

}

4247

}

4248

4249

(*tamp)[j]=med+min;

4250

4251

}

4252

}

4253

}

4254

4255

}

4256

else

4257

{

4258

DLong* hh;

4259

DLong* h1;

4260

DLong* h2;

4261

DDoubleGDL* Mask,*Mask1D;

4262

if ( p0->Rank() != 1 )

4263

{

4264

hh = new DLong[ N_MaskElem];

4265

h1 = new DLong[ N_MaskElem/2];

4266

h2= new DLong[ (N_MaskElem+1)/2];

4267

Mask = new DDoubleGDL(N_MaskElem,BaseGDL::NOZERO);

4268

4269

for( DLong i=0; i<N_MaskElem; ++i) hh[i] = i;

4270

}

4271

else

4272

{

4273

hh = new DLong[ width];

4274

h1 = new DLong[ width/2];

4275

h2= new DLong[(width+1)/2];

4276

Mask1D = new DDoubleGDL(width,BaseGDL::NOZERO);

4277

4278

for( DLong i=0; i<width; ++i) hh[i] = i;

4279

}

4280

4281

//-------------------------------- END OF VARIABLES INIT ---------------------------------------------

4282

4283

//------------------------------ Median Filter Algorithms ---------------------------------------

4284

4285

if ( width % 2 ==0)

4286

{

4287

if ( p0->Rank() == 1 )//------------------------ For a vector with even width -------------------

4288

{

4289

for (SizeT col= lim ; col<larg-lim ; ++col)

4290

{

4291

SizeT ctl_NaN=0;

4292

SizeT kk=0;

4293

for (SizeT ind=col-lim ; ind<col+lim ; ++ind)

4294

{

4295

if( (*p0)[ind]!=d_infinity && (*p0)[ind]!=-d_infinity && isfinite((*p0)[ind])==0)

4296

ctl_NaN++;

4297

else

4298

{

4299

(*Mask1D)[kk]=(*p0)[ind];

4300

kk++;

4301

}

4302

}

4303

if (ctl_NaN!=0)

4304

{

4305

if(ctl_NaN==width)(*tamp)[col]= d_nan;

4306

else

4307

{

4308

DLong* hhbis = new DLong[ width-ctl_NaN];

4309

DLong* h1bis = new DLong[ width-ctl_NaN/2];

4310

DLong* h2bis= new DLong[(width-ctl_NaN+1)/2];

4311

DDoubleGDL *Mask1Dbis = new DDoubleGDL(width-ctl_NaN,BaseGDL::NOZERO);

4312

for( DLong t=0; t<width-ctl_NaN; ++t) hhbis[t] = t;

4313

for( DLong ii=0; ii<width-ctl_NaN; ++ii)(*Mask1Dbis)[ii]=(*Mask1D)[ii];

4314

BaseGDL* besort=static_cast<BaseGDL*>(Mask1Dbis);

4315

MergeSortOpt<DLong>( besort, hhbis, h1bis, h2bis,(width - ctl_NaN));

4316

if (e->KeywordSet( evenIx)&& (width - ctl_NaN) % 2 == 0)

4317

(*tamp)[col]=((*Mask1Dbis)[hhbis[ (width-ctl_NaN)/2]]+(*Mask1Dbis

4318

)[hhbis [ (width - ctl_NaN-1)/2]])/2;

4319

else

4320

(*tamp)[col]=(*Mask1Dbis)[hhbis[ (width- ctl_NaN)/2]];

4321

delete[]hhbis;

4322

delete[]h2bis;

4323

delete[]h1bis;

4324

}

4325

}

4326

else

4327

{

4328

BaseGDL* besort=static_cast<BaseGDL*>(Mask1D);

4329

MergeSortOpt<DLong>( besort, hh, h1, h2,width ); // call the sort routine

4330

4331

if (e->KeywordSet( evenIx))

4332

4333

(*tamp)[col]=((*Mask1D)[hh[ width/2]]+(*Mask1D)[hh[ (width-1)/2]])/2;

4334

else

4335

(*tamp)[col]=(*Mask1D)[hh[ width/2]];// replace value by Mask median

4336

}

4337

}

4338

4339

}

4340

else//------------------------ For an array with even width -------------------

4341

{

4342

SizeT jj;

4343

for(SizeT i=0 ; i<haut-2*lim ; ++i) // lines to replace

4344

{

4345

for(SizeT j=init+i*larg ; j<init+(i+1)*larg-2*lim ; ++j)// elements to replace

4346

{

4347

SizeT initMask=j-lim*larg-lim; // left corner of mask

4348

SizeT kk=0;

4349

SizeT ctl_NaN=0;

4350

for(SizeT k=0;k<2*lim;++k) // lines of mask

4351

{

4352

4353

for(jj=initMask+k*larg ; jj<(initMask+k*larg)+2*lim ; ++jj) // elements of mask

4354

{

4355

if( (*p0)[jj]!=d_infinity && (*p0)[jj]!=-d_infinity && isfinite((*p0)[jj])==0)

4356

ctl_NaN++;

4357

else

4358

{

4359

(*Mask)[kk]=(*p0)[jj];

4360

kk++;

4361

}

4362

}

4363

}

4364

if (ctl_NaN!=0)

4365

{

4366

if(ctl_NaN==N_MaskElem)(*tamp)[j]= d_nan;

4367

else {

4368

DLong* hhb = new DLong[ N_MaskElem-ctl_NaN];

4369

DLong* h1b = new DLong[ (N_MaskElem-ctl_NaN)/2];

4370

DLong* h2b = new DLong[(N_MaskElem-ctl_NaN+1)/2];

4371

DDoubleGDL *Maskb = new DDoubleGDL(N_MaskElem-ctl_NaN,BaseGDL::NOZERO);

4372

for( DLong t=0; t<N_MaskElem-ctl_NaN; ++t) hhb[t] = t;

4373

for( DLong ii=0; ii<N_MaskElem-ctl_NaN; ++ii)(*Maskb)[ii]=(*Mask)[ii];

4374

BaseGDL* besort=static_cast<BaseGDL*>(Maskb);

4375

MergeSortOpt<DLong>( besort, hhb, h1b, h2b,(N_MaskElem - ctl_NaN));

4376

if ((N_MaskElem - ctl_NaN) % 2 == 0 && e->KeywordSet( evenIx))

4377

(*tamp)[j]=((*Maskb)[hhb[ (N_MaskElem-ctl_NaN)/2]]+(*Maskb)[hhb

4378

[ (N_MaskElem -

4379

ctl_NaN-1)/2]])/2;

4380

else

4381

(*tamp)[j]=(*Maskb)[hhb[ (N_MaskElem- ctl_NaN)/2]];

4382

delete[]hhb;

4383

delete[]h2b;

4384

delete[]h1b;

4385

}

4386

}

4387

else

4388

{

4389

BaseGDL* besort=static_cast<BaseGDL*>(Mask);

4390

MergeSortOpt<DLong>( besort, hh, h1, h2, N_MaskElem); // call the sort routine

4391

if (e->KeywordSet( evenIx))

4392

(*tamp)[j]=((*Mask)[hh[ N_MaskElem/2]]+(*Mask)[hh[ (N_MaskElem-1)/2]])/2;

4393

else

4394

(*tamp)[j]=(*Mask)[hh[ N_MaskElem/2]];// replace value by median Mask one

4395

}

4396

}

4397

}

4398

}

4399

}

4400

4401

else

4402

{

4403

if ( p0->Rank() == 1 )//------------------------ For a vector with odd width -------------------

4404

4405

{

4406

for (SizeT col= lim ; col<larg-lim ; ++col)

4407

{

4408

SizeT kk=0;

4409

SizeT ctl_NaN=0;

4410

for (SizeT ind=col-lim ; ind<=col+lim ; ++ind)

4411

{if( (*p0)[ind]!=d_infinity && (*p0)[ind]!=-d_infinity && isfinite((*p0)[ind])==0)

4412

ctl_NaN++;

4413

else{

4414

(*Mask1D)[kk]=(*p0)[ind];

4415

kk++;

4416

}

4417

}

4418

if (ctl_NaN!=0)

4419

{

4420

if(ctl_NaN==width)(*tamp)[col]= d_nan;

4421

else {

4422

DLong* hhbis = new DLong[ width-ctl_NaN];

4423

DLong* h1bis = new DLong[ width-ctl_NaN/2];

4424

DLong* h2bis= new DLong[(width-ctl_NaN+1)/2];

4425

DDoubleGDL *Mask1Dbis = new DDoubleGDL(width-ctl_NaN,BaseGDL::NOZERO);

4426

for( DLong t=0; t<width-ctl_NaN; ++t) hhbis[t] = t;

4427

for( DLong ii=0; ii<width-ctl_NaN; ++ii)(*Mask1Dbis)[ii]=(*Mask1D)[ii];

4428

BaseGDL* besort=static_cast<BaseGDL*>(Mask1Dbis);

4429

MergeSortOpt<DLong>( besort, hhbis, h1bis, h2bis,(width - ctl_NaN));

4430

if (e->KeywordSet( evenIx)&& (width - ctl_NaN) % 2 == 0)

4431

(*tamp)[col]=((*Mask1Dbis)[hhbis[ (width-ctl_NaN)/2]]+(*Mask1Dbis

4432

)[hhbis [ (width - ctl_NaN-1)/2]])/2;

4433

else(*tamp)[col]=(*Mask1Dbis)[hhbis[ (width- ctl_NaN)/2]];

4434

delete[]hhbis;

4435

delete[]h2bis;

4436

delete[]h1bis;

4437

}

4438

}

4439

else

4440

{

4441

BaseGDL* besort=static_cast<BaseGDL*>(Mask1D);

4442

MergeSortOpt<DLong>( besort, hh, h1, h2,width ); // call the sort routine

4443

(*tamp)[col]=(*Mask1D)[hh[ (width)/2]]; // replace value by Mask median

4444

}

4445

}

4446

4447

}

4448

4449

else //----------------------------- For an array with odd width ---------------------------------

4450

{

4451

SizeT jj;

4452

for(SizeT i=0 ; i<haut-2*lim ; ++i) // lines to replace

4453

{

4454

4455

SizeT initial=init+i*larg-lim*larg-lim;

4456

SizeT dd=0;SizeT ctl_NaN_init=0;

4457

for(SizeT yy=0;yy<width;yy++)

4458

{

4459

for (SizeT ii=initial+yy*larg ; ii <initial+ yy*larg+ width; ++ii)

4460

{

4461

4462

if( (*p0)[ii]!=d_infinity && (*p0)[ii]!=-d_infinity && isfinite((*p0)[ii])==0)

4463

ctl_NaN_init++;

4464

else

4465

(*Mask)[dd]=(*p0)[ii];

4466

dd++;

4467

}

4468

}

4469

SizeT kk=0;

4470

4471

for(SizeT j=init+i*larg ; j<init+(i+1)*larg-2*lim ; ++j)// elements to replace

4472

{

4473

SizeT initMask=j-lim*larg-lim; // left corner of mask

4474

SizeT kk=0;

4475

SizeT ctl_NaN=0;

4476

for(SizeT k=0;k<=2*lim;++k) // lines of mask

4477

{

4478

4479

for(jj=initMask+k*larg ; jj<=(initMask+k*larg)+2*lim ; ++jj) // elements of mask

4480

{

4481

if( (*p0)[jj]!=d_infinity && (*p0)[jj]!=-d_infinity && isfinite((*p0)[jj])==0)

4482

ctl_NaN++;

4483

4484

else

4485

{

4486

(*Mask)[kk]=(*p0)[jj];

4487

kk++;

4488

}

4489

}

4490

4491

}

4492

4493

if (ctl_NaN!=0)

4494

{

4495

if(ctl_NaN==N_MaskElem)

4496

(*tamp)[j]= d_nan;

4497

else {

4498

DLong* hhb = new DLong[ N_MaskElem-ctl_NaN];

4499

DLong* h1b = new DLong[ (N_MaskElem-ctl_NaN)/2];

4500

DLong* h2b= new DLong[(N_MaskElem-ctl_NaN+1)/2];

4501

DDoubleGDL*Maskb = new DDoubleGDL(N_MaskElem-ctl_NaN,BaseGDL::NOZERO);

4502

for( DLong t=0; t<N_MaskElem-ctl_NaN; ++t) hhb[t] = t;

4503

for( DLong ii=0; ii<N_MaskElem-ctl_NaN; ++ii)(*Maskb)[ii]=(*Mask)[ii];

4504

BaseGDL* besort=static_cast<BaseGDL*>(Maskb);

4505

MergeSortOpt<DLong>( besort, hhb, h1b, h2b,(N_MaskElem - ctl_NaN));

4506

if ((N_MaskElem - ctl_NaN) % 2 == 0 && e->KeywordSet( evenIx))

4507

(*tamp)[j]=((*Maskb)[hhb[ (N_MaskElem-ctl_NaN)/2]]+(*Maskb)[hhb

4508

[ (N_MaskElem -

4509

ctl_NaN-1)/2]])/2;

4510

else(*tamp)[j]=(*Maskb)[hhb[(N_MaskElem- ctl_NaN)/2]];

4511

delete[]hhb;

4512

delete[]h2b;

4513

delete[]h1b;

4514

}

4515

}

4516

else

4517

{

4518

BaseGDL* besort=static_cast<BaseGDL*>(Mask);

4519

MergeSortOpt<DLong>( besort, hh, h1, h2, N_MaskElem); // call the sort routine

4520

(*tamp)[j]=(*Mask)[hh[ (N_MaskElem)/2]]; // replace value by Mask median

4521

}

4522

}

4523

}

4524

}

4525

}

4526

4527

//--------------------------- END OF MEDIAN FILTER ALOGORITHMS -----------------------------------

4528

4529

delete[] h1;

4530

delete[] h2;

4531

delete[] hh;

4532

}

4533

if ( e->GetParDefined( 0)->Type() == GDL_DOUBLE || p0->Type() == GDL_COMPLEXDBL ||e->KeywordSet( doubleIx) )

4534

return tamp;

4535

else if (e->GetParDefined( 0)->Type() == GDL_BYTE)

4536

return tamp->Convert2(GDL_BYTE,BaseGDL::CONVERT);

4537

4538

return tamp->Convert2(GDL_FLOAT,BaseGDL::CONVERT);

4539

4540

}// end if

4541

4542

}// end of median

4543

4544

BaseGDL* shift_fun( EnvT* e)

4545

{

4546

SizeT nParam = e->NParam( 2);

4547

4548

BaseGDL* p0 = e->GetParDefined( 0);

4549

4550

SizeT nShift = nParam - 1;

4551

if( nShift == 1)

4552

{

4553

DLong s1;

4554

e->AssureLongScalarPar( 1, s1);

4555

4556

// IncRef[Obj] done for GDL_PTR and GDL_OBJ

4557

return p0->CShift( s1);

4558

}

4559

4560

if( p0->Rank() != nShift)

4561

e->Throw( "Incorrect number of arguments.");

4562

4563

DLong sIx[ MAXRANK];

4564

for( SizeT i=0; i< nShift; i++)

4565

e->AssureLongScalarPar( i+1, sIx[ i]);

4566

4567

if( p0->Type() == GDL_OBJ)

4568

GDLInterpreter::IncRefObj( static_cast<DObjGDL*>(p0));

4569

else if( p0->Type() == GDL_PTR)

4570

GDLInterpreter::IncRef( static_cast<DPtrGDL*>(p0));

4571

4572

return p0->CShift( sIx);

4573

}

4574

4575

BaseGDL* arg_present( EnvT* e)

4576

{

4577

e->NParam( 1);

4578

4579

if( !e->GlobalPar( 0))

4580

return new DIntGDL( 0);

4581

4582

EnvBaseT* caller = e->Caller();

4583

if( caller == NULL)

4584

return new DIntGDL( 0);

4585

4586

BaseGDL** pp0 = &e->GetPar( 0);

4587

4588

int ix = caller->FindGlobalKW( pp0);

4589

if( ix == -1)

4590

return new DIntGDL( 0);

4591

4592

return new DIntGDL( 1);

4593

}

4594

4595

BaseGDL* eof_fun( EnvT* e)

4596

{

4597

e->NParam( 1);

4598

4599

DLong lun;

4600

e->AssureLongScalarPar( 0, lun);

4601

4602

bool stdLun = check_lun( e, lun);

4603

if( stdLun)

4604

return new DIntGDL( 0);

4605

4606

// nicer error message (Disregard if socket)

4607

if ( fileUnits[ lun-1].SockNum() == -1) {

4608

if( !fileUnits[ lun-1].IsOpen())

4609

throw GDLIOException( e->CallingNode(), "File unit is not open: "+i2s( lun)+".");

4610

4611

if( fileUnits[ lun-1].Eof())

4612

return new DIntGDL( 1);

4613

} else {

4614

// Socket

4615

string *recvBuf = &fileUnits[ lun-1].RecvBuf();

4616

if (recvBuf->size() == 0)

4617

return new DIntGDL( 1);

4618

}

4619

return new DIntGDL( 0);

4620

}

4621

4622

BaseGDL* convol( EnvT* e)

4623

{

4624

SizeT nParam=e->NParam( 2);

4625

4626

BaseGDL* p0 = e->GetNumericParDefined( 0);

4627

if( p0->Rank() == 0)

4628

e->Throw( "Expression must be an array in this context: "+

4629

e->GetParString(0));

4630

4631

BaseGDL* p1 = e->GetNumericParDefined( 1);

4632

if( p1->Rank() == 0)

4633

e->Throw( "Expression must be an array in this context: "+

4634

e->GetParString(1));

4635

4636

if( p0->N_Elements() <= p1->N_Elements())

4637

e->Throw( "Incompatible dimensions for Array and Kernel.");

4638

4639

// rank 1 for kernel works always

4640

if( p1->Rank() != 1)

4641

{

4642

SizeT rank = p0->Rank();

4643

if( rank != p1->Rank())

4644

e->Throw( "Incompatible dimensions for Array and Kernel.");

4645

4646

for( SizeT r=0; r<rank; ++r)

4647

if( p0->Dim( r) <= p1->Dim( r))

4648

e->Throw( "Incompatible dimensions for Array and Kernel.");

4649

}

4650

4651

// convert kernel to array type

4652

auto_ptr<BaseGDL> p1Guard;

4653

if( p0->Type() == GDL_BYTE)

4654

{

4655

if( p1->Type() != GDL_INT)

4656

{

4657

p1 = p1->Convert2( GDL_INT, BaseGDL::COPY);

4658

p1Guard.reset( p1);

4659

}

4660

}

4661

else if( p0->Type() != p1->Type())

4662

{

4663

p1 = p1->Convert2( p0->Type(), BaseGDL::COPY);

4664

p1Guard.reset( p1);

4665

}

4666

4667

BaseGDL* scale;

4668

auto_ptr<BaseGDL> scaleGuard;

4669

if( nParam > 2)

4670

{

4671

scale = e->GetParDefined( 2);

4672

if( scale->Rank() > 0)

4673

e->Throw( "Expression must be a scalar in this context: "+

4674

e->GetParString(2));

4675

4676

// p1 here handles GDL_BYTE case also

4677

if( p1->Type() != scale->Type())

4678

{

4679

scale = scale->Convert2( p1->Type(),BaseGDL::COPY);

4680

scaleGuard.reset( scale);

4681

}

4682

}

4683

else

4684

{

4685

scale = p1->New( dimension(), BaseGDL::ZERO);

4686

}

4687

4688

bool center = true;

4689

static int centerIx = e->KeywordIx( "CENTER");

4690

if( e->KeywordPresent( centerIx))

4691

{

4692

DLong c;

4693

e->AssureLongScalarKW( centerIx, c);

4694

center = (c != 0);

4695

}

4696

4697

// overrides EDGE_TRUNCATE

4698

static int edge_wrapIx = e->KeywordIx( "EDGE_WRAP");

4699

bool edge_wrap = e->KeywordSet( edge_wrapIx);

4700

static int edge_truncateIx = e->KeywordIx( "EDGE_TRUNCATE");

4701

bool edge_truncate = e->KeywordSet( edge_truncateIx);

4702

4703

int edgeMode = 0;

4704

if( edge_wrap)

4705

edgeMode = 1;

4706

else if( edge_truncate)

4707

edgeMode = 2;

4708

4709

// p0, p1 and scale have same type

4710

// p1 has rank of 1 or same rank as p0 with each dimension smaller than p0

4711

// scale is a scalar

4712

return p0->Convol( p1, scale, center, edgeMode);

4713

}

4714

4715

BaseGDL* rebin_fun( EnvT* e)

4716

{

4717

SizeT nParam = e->NParam( 2);

4718

4719

BaseGDL* p0 = e->GetNumericParDefined( 0);

4720

4721

SizeT rank = p0->Rank();

4722

4723

if( rank == 0)

4724

e->Throw( "Expression must be an array in this context: "+

4725

e->GetParString(0));

4726

4727

SizeT resDimInit[ MAXRANK];

4728

4729

DLongGDL* p1 = e->GetParAs<DLongGDL>(1);

4730

if (p1->Rank() > 0 && nParam > 2)

4731

e->Throw("The new dimensions must either be specified as an array or as a set of scalars.");

4732

SizeT np = p1->Rank() == 0 ? nParam : p1->N_Elements() + 1;

4733

4734

for( SizeT p=1; p<np; ++p)

4735

{

4736

DLong newDim;

4737

if (p1->Rank() == 0) e->AssureLongScalarPar( p, newDim);

4738

else newDim = (*p1)[p - 1];

4739

4740

if( newDim <= 0)

4741

e->Throw( "Array dimensions must be greater than 0.");

4742

4743

if( rank >= p)

4744

{

4745

SizeT oldDim = p0->Dim( p-1);

4746

4747

if( newDim > oldDim)

4748

{

4749

if( (newDim % oldDim) != 0)

4750

e->Throw( "Result dimensions must be integer factor "

4751

"of original dimensions.");

4752

}

4753

else

4754

{

4755

if( (oldDim % newDim) != 0)

4756

e->Throw( "Result dimensions must be integer factor "

4757

"of original dimensions.");

4758

}

4759

}

4760

4761

resDimInit[ p-1] = newDim;

4762

}

4763

4764

dimension resDim( resDimInit, np-1);

4765

4766

static int sampleIx = e->KeywordIx( "SAMPLE");

4767

bool sample = e->KeywordSet( sampleIx);

4768

4769

return p0->Rebin( resDim, sample);

4770

}

4771

4772

BaseGDL* obj_class( EnvT* e)

4773

{

4774

SizeT nParam = e->NParam();

4775

4776

static int countIx = e->KeywordIx( "COUNT");

4777

static int superIx = e->KeywordIx( "SUPERCLASS");

4778

4779

bool super = e->KeywordSet( superIx);

4780

4781

bool count = e->KeywordPresent( countIx);

4782

if( count)

4783

e->AssureGlobalKW( countIx);

4784

4785

if( nParam > 0)

4786

{

4787

BaseGDL* p0 = e->GetParDefined( 0);

4788

4789

if( p0->Type() != GDL_STRING && p0->Type() != GDL_OBJ)

4790

e->Throw( "Argument must be a scalar object reference or string: "+

4791

e->GetParString(0));

4792

4793

if( !p0->Scalar())

4794

e->Throw( "Expression must be a scalar or 1 element "

4795

"array in this context: "+e->GetParString(0));

4796

4797

DStructDesc* objDesc;

4798

4799

if( p0->Type() == GDL_STRING)

4800

{

4801

DString objName;

4802

e->AssureScalarPar<DStringGDL>( 0, objName);

4803

objName = StrUpCase( objName);

4804

4805

objDesc = FindInStructList( structList, objName);

4806

if( objDesc == NULL)

4807

{

4808

if( count)

4809

e->SetKW( countIx, new DLongGDL( 0));

4810

return new DStringGDL( "");

4811

}

4812

}

4813

else // GDL_OBJ

4814

{

4815

DObj objRef;

4816

e->AssureScalarPar<DObjGDL>( 0, objRef);

4817

4818

if( objRef == 0)

4819

{

4820

if( count)

4821

e->SetKW( countIx, new DLongGDL( 0));

4822

return new DStringGDL( "");

4823

}

4824

4825

DStructGDL* oStruct;

4826

try {

4827

oStruct = e->GetObjHeap( objRef);

4828

}

4829

catch ( GDLInterpreter::HeapException)

4830

{ // non valid object

4831

if( count)

4832

e->SetKW( countIx, new DLongGDL( 0));

4833

return new DStringGDL( "");

4834

}

4835

4836

objDesc = oStruct->Desc(); // cannot be NULL

4837

}

4838

4839

if( !super)

4840

{

4841

if( count)

4842

e->SetKW( countIx, new DLongGDL( 1));

4843

return new DStringGDL( objDesc->Name());

4844

}

4845

4846

deque< string> pNames;

4847

objDesc->GetParentNames( pNames);

4848

4849

SizeT nNames = pNames.size();

4850

4851

if( count)

4852

e->SetKW( countIx, new DLongGDL( nNames));

4853

4854

if( nNames == 0)

4855

{

4856

return new DStringGDL( "");

4857

}

4858

4859

DStringGDL* res = new DStringGDL( dimension( nNames),

4860

BaseGDL::NOZERO);

4861

4862

for( SizeT i=0; i<nNames; ++i)

4863

{

4864

(*res)[i] = pNames[i];

4865

}

4866

4867

return res;

4868

}

4869

4870

if( super)

4871

e->Throw( "Conflicting keywords.");

4872

4873

SizeT nObj = structList.size();

4874

4875

DStringGDL* res = new DStringGDL( dimension( nObj),

4876

BaseGDL::NOZERO);

4877

4878

for( SizeT i=0; i<nObj; ++i)

4879

{

4880

(*res)[i] = structList[i]->Name();

4881

}

4882

4883

return res;

4884

}

4885

4886

BaseGDL* obj_isa( EnvT* e)

4887

{

4888

SizeT nParam = e->NParam( 2);

4889

4890

BaseGDL* p0 = e->GetPar( 0);

4891

if( p0 == NULL || p0->Type() != GDL_OBJ)

4892

e->Throw( "Object reference type required in this context: "+

4893

e->GetParString(0));

4894

4895

DString className;

4896

e->AssureScalarPar<DStringGDL>( 1, className);

4897

className = StrUpCase( className);

4898

4899

DObjGDL* pObj = static_cast<DObjGDL*>( p0);

4900

4901

DByteGDL* res = new DByteGDL( pObj->Dim()); // zero

4902

4903

GDLInterpreter* interpreter = e->Interpreter();

4904

4905

SizeT nElem = pObj->N_Elements();

4906

for( SizeT i=0; i<nElem; ++i)

4907

{

4908

if( interpreter->ObjValid( (*pObj)[ i]))

4909

{

4910

DStructGDL* oStruct = e->GetObjHeap( (*pObj)[i]);

4911

if( oStruct->Desc()->IsParent( className))

4912

(*res)[i] = 1;

4913

}

4914

}

4915

4916

return res;

4917

}

4918

4919

BaseGDL* n_tags( EnvT* e)

4920

{

4921

e->NParam( 1);

4922

4923

BaseGDL* p0 = e->GetPar( 0);

4924

if( p0 == NULL)

4925

return new DLongGDL( 0);

4926

4927

if( p0->Type() != GDL_STRUCT)

4928

return new DLongGDL( 0);

4929

4930

DStructGDL* s = static_cast<DStructGDL*>( p0);

4931

4932

//static int lengthIx = e->KeywordIx( "DATA_LENGTH");

4933

//bool length = e->KeywordSet( lengthIx);

4934

4935

// we don't know now how to distinghuis the 2 following cases

4936

if(e->KeywordSet("DATA_LENGTH"))

4937

return new DLongGDL( s->Sizeof());

4938

4939

if(e->KeywordSet("LENGTH"))

4940

return new DLongGDL( s->Sizeof());

4941

4942

return new DLongGDL( s->Desc()->NTags());

4943

}

4944

4945

BaseGDL* bytscl( EnvT* e)

4946

{

4947

SizeT nParam = e->NParam( 1);

4948

4949

BaseGDL* p0=e->GetNumericParDefined( 0);

4950

4951

static int minIx = e->KeywordIx( "MIN");

4952

static int maxIx = e->KeywordIx( "MAX");

4953

static int topIx = e->KeywordIx( "TOP");

4954

bool omitNaN = e->KeywordPresent( 3);

4955

4956

DLong topL=255;

4957

if( e->GetKW( topIx) != NULL)

4958

e->AssureLongScalarKW( topIx, topL);

4959

DByte top = static_cast<DByte>(topL);

4960

DDouble dTop = static_cast<DDouble>(top);

4961

4962

DDouble min;

4963

bool minSet = false;

4964

// SA: handling 3 parameters to emulate undocumented IDL behaviour

4965

// of translating second and third arguments to MIN and MAX, respectively

4966

// (parameters have precedence over keywords)

4967

if (nParam >= 2)

4968

{

4969

e->AssureDoubleScalarPar(1, min);

4970

minSet = true;

4971

}

4972

else if (e->GetKW(minIx) != NULL)

4973

{

4974

e->AssureDoubleScalarKW(minIx, min);

4975

minSet = true;

4976

}

4977

4978

DDouble max;

4979

bool maxSet = false;

4980

if (nParam == 3)

4981

{

4982

e->AssureDoubleScalarPar(2, max);

4983

maxSet = true;

4984

}

4985

else if (e->GetKW(maxIx) != NULL)

4986

{

4987

e->AssureDoubleScalarKW(maxIx, max);

4988

maxSet = true;

4989

}

4990

4991

DDoubleGDL* dRes =

4992

static_cast<DDoubleGDL*>(p0->Convert2( GDL_DOUBLE, BaseGDL::COPY));

4993

4994

DLong maxEl, minEl;

4995

if( !maxSet || !minSet)

4996

dRes->MinMax( &minEl, &maxEl, NULL, NULL, omitNaN);

4997

if( !minSet)

4998

min = (*dRes)[ minEl];

4999

if( !maxSet)

5000

max = (*dRes)[ maxEl];

5001

5002

SizeT nEl = dRes->N_Elements();

5003

for( SizeT i=0; i<nEl; ++i)

5004

{

5005

DDouble& d = (*dRes)[ i];

5006

if( d <= min) (*dRes)[ i] = 0;

5007

else if( d >= max) (*dRes)[ i] = dTop;

5008

else

5009

{

5010

// SA: floor is used for integer types to simulate manipulation on input data types

5011

if (IntType(p0->Type())) (*dRes)[ i] = floor(((dTop + 1.)*(d - min) - 1.) / (max-min));

5012

// SA (?): here floor is used (instead of round) to simulate IDL behaviour

5013

else (*dRes)[ i] = floor((d - min) / (max-min) * (dTop + .9999));

5014

}

5015

}

5016

5017

return dRes->Convert2( GDL_BYTE);

5018

}

5019

5020

BaseGDL* strtok_fun( EnvT* e)

5021

{

5022

SizeT nParam=e->NParam( 1);

5023

5024

DString stringIn;

5025

e->AssureStringScalarPar( 0, stringIn);

5026

5027

DString pattern = " \t";

5028

if(nParam > 1) {

5029

e->AssureStringScalarPar( 1, pattern);

5030

}

5031

5032

static int extractIx = e->KeywordIx( "EXTRACT");

5033

bool extract = e->KeywordSet( extractIx);

5034

5035

static int lengthIx = e->KeywordIx( "LENGTH");

5036

bool lengthPresent = e->KeywordPresent( lengthIx);

5037

5038

if( extract && lengthPresent)

5039

e->Throw( "Conflicting keywords.");

5040

5041

static int pre0Ix = e->KeywordIx( "PRESERVE_NULL");

5042

bool pre0 = e->KeywordSet( pre0Ix);

5043

5044

static int regexIx = e->KeywordIx( "REGEX");

5045

bool regex = e->KeywordPresent( regexIx);

5046

char err_msg[MAX_REGEXPERR_LENGTH];

5047

regex_t regexp;

5048

5049

deque<long> tokenStart;

5050

deque<long> tokenLen;

5051

5052

int strLen = stringIn.length();

5053

5054

DString escape = "";

5055

e->AssureStringScalarKWIfPresent( "ESCAPE", escape);

5056

deque<long> escList;

5057

long pos = 0;

5058

while(pos != string::npos)

5059

{

5060

pos = stringIn.find_first_of( escape, pos);

5061

if( pos != string::npos)

5062

{

5063

escList.push_back( pos+1); // remember escaped char

5064

pos += 2; // skip escaped char

5065

}

5066

}

5067

deque<long>::iterator escBeg = escList.begin();

5068

deque<long>::iterator escEnd = escList.end();

5069

5070

long tokB = 0;

5071

long tokE;

5072

long nextE = 0;

5073

long actLen;

5074

5075

// If regex then compile regex

5076

if( regex) {

5077

if (pattern == " \t") pattern = " "; // regcomp doesn't like "\t" JMG

5078

int compRes = regcomp( &regexp, pattern.c_str(), REG_EXTENDED);

5079

if (compRes) {

5080

regerror(compRes, &regexp, err_msg, MAX_REGEXPERR_LENGTH);

5081

e->Throw( "Error processing regular expression: "+

5082

pattern+"\n "+string(err_msg)+".");

5083

}

5084

}

5085

5086

for(;;)

5087

{

5088

regmatch_t pmatch[1];

5089

if( regex) {

5090

int matchres = regexec( &regexp, stringIn.c_str()+nextE, 1, pmatch, 0);

5091

tokE = matchres? -1:pmatch[0].rm_so;

5092

} else {

5093

tokE = stringIn.find_first_of( pattern, nextE);

5094

}

5095

5096

if( tokE == string::npos)

5097

{

5098

actLen = strLen - tokB;

5099

if( actLen > 0 || pre0)

5100

{

5101

tokenStart.push_back( tokB);

5102

tokenLen.push_back( actLen);

5103

}

5104

break;

5105

}

5106

5107

if( find( escBeg, escEnd, tokE) == escEnd)

5108

{

5109

if (regex) actLen = tokE; else actLen = tokE - tokB;

5110

if( actLen > 0 || pre0)

5111

{

5112

tokenStart.push_back( tokB);

5113

tokenLen.push_back( actLen);

5114

}

5115

if (regex) tokB += pmatch[0].rm_eo; else tokB = tokE + 1;

5116

}

5117

if (regex) nextE += pmatch[0].rm_eo; else nextE = tokE + 1;

5118

} // for(;;)

5119

5120

if (regex) regfree( &regexp);

5121

5122

SizeT nTok = tokenStart.size();

5123

5124

if( !extract)

5125

{

5126

if( lengthPresent)

5127

{

5128

e->AssureGlobalKW( lengthIx);

5129

5130

if( nTok > 0)

5131

{

5132

dimension dim(nTok);

5133

DLongGDL* len = new DLongGDL(dim);

5134

for(int i=0; i < nTok; i++)

5135

(*len)[i] = tokenLen[i];

5136

5137

e->SetKW( lengthIx, len);

5138

}

5139

else

5140

{

5141

e->SetKW( lengthIx, new DLongGDL( 0));

5142

}

5143

}

5144

5145

if( nTok == 0) return new DLongGDL( 0);

5146

5147

dimension dim(nTok);

5148

DLongGDL* d = new DLongGDL(dim);

5149

for(int i=0; i < nTok; i++)

5150

(*d)[i] = tokenStart[i];

5151

return d;

5152

}

5153

5154

// EXTRACT

5155

if( nTok == 0) return new DStringGDL( "");

5156

5157

dimension dim(nTok);

5158

DStringGDL *d = new DStringGDL(dim);

5159

for(int i=0; i < nTok; i++)

5160

{

5161

(*d)[i] = stringIn.substr(tokenStart[i], tokenLen[i]);

5162

5163

// remove escape

5164

DString& act = (*d)[i];

5165

long escPos = act.find_first_of( escape, 0);

5166

while( escPos != string::npos)

5167

{

5168

act = act.substr( 0, escPos)+act.substr( escPos+1);

5169

escPos = act.find_first_of( escape, escPos+1);

5170

}

5171

}

5172

return d;

5173

}

5174

5175

BaseGDL* getenv_fun( EnvT* e)

5176

{

5177

SizeT nParam=e->NParam();

5178

5179

static int environmentIx = e->KeywordIx( "ENVIRONMENT" );

5180

bool environment = e->KeywordSet( environmentIx );

5181

5182

SizeT nEnv;

5183

DStringGDL* env;

5184

5185

if( environment) {

5186

5187

if(nParam != 0)

5188

e->Throw( "Incorrect number of arguments.");

5189

5190

// determine number of environment entries

5191

for(nEnv = 0; environ[nEnv] != NULL ; ++nEnv);

5192

5193

dimension dim( nEnv );

5194

env = new DStringGDL(dim);

5195

5196

// copy stuff into local string array

5197

for(SizeT i=0; i < nEnv ; ++i)

5198

(*env)[i] = environ[i];

5199

5200

} else {

5201

5202

if(nParam != 1)

5203

e->Throw( "Incorrect number of arguments.");

5204

5205

DStringGDL* name = e->GetParAs<DStringGDL>(0);

5206

nEnv = name->N_Elements();

5207

5208

env = new DStringGDL( name->Dim());

5209

5210

// copy the stuff into local string only if param found

5211

char *resPtr;

5212

for(SizeT i=0; i < nEnv ; ++i)

5213

{

5214

// handle special environment variables

5215

// GDL_TMPDIR, IDL_TMPDIR

5216

if( (*name)[i] == "GDL_TMPDIR" || (*name)[i] == "IDL_TMPDIR")

5217

{

5218

resPtr = getenv((*name)[i].c_str());

5219

5220

if( resPtr != NULL)

5221

(*env)[i] = resPtr;

5222

else

5223

(*env)[i] = SysVar::Dir();

5224

5225

AppendIfNeeded( (*env)[i], "/");

5226

}

5227

else // normal environment variables

5228

if( (resPtr = getenv((*name)[i].c_str())) )

5229

(*env)[i] = resPtr;

5230

}

5231

}

5232

5233

return env;

5234

}

5235

5236

BaseGDL* tag_names_fun( EnvT* e)

5237

{

5238

SizeT nParam=e->NParam();

5239

DStructGDL* struc= e->GetParAs<DStructGDL>(0);

5240

5241

static int structureNameIx = e->KeywordIx( "STRUCTURE_NAME" );

5242

bool structureName = e->KeywordSet( structureNameIx );

5243

5244

DStringGDL* tagNames;

5245

5246

if(structureName){

5247

5248

if ((*struc).Desc()->Name() != "$truct")

5249

tagNames = new DStringGDL((*struc).Desc()->Name());

5250

else

5251

tagNames = new DStringGDL("");

5252

5253

} else {

5254

SizeT nTags = (*struc).Desc()->NTags();

5255

5256

tagNames = new DStringGDL(dimension(nTags));

5257

for(int i=0; i < nTags; ++i)

5258

(*tagNames)[i] = (*struc).Desc()->TagName(i);

5259

}

5260

5261

return tagNames;

5262

}

5263

5264

// AC 12-Oc-2011: better version for: len=len, /Extract and /Sub

5265

// but it is still not perfect

5266

5267

BaseGDL* stregex_fun( EnvT* e)

5268

{

5269

SizeT nParam=e->NParam( 2);

5270

5271

DStringGDL* stringExpr= e->GetParAs<DStringGDL>(0);

5272

dimension dim = stringExpr->Dim();

5273

5274

DString pattern;

5275

e->AssureStringScalarPar(1, pattern);

5276

if (pattern.size() <= 0)

5277

{

5278

e->Throw( "Error processing regular expression: "+pattern+

5279

"\n empty (sub)expression");

5280

}

5281

5282

static int booleanIx = e->KeywordIx( "BOOLEAN" );

5283

bool booleanKW = e->KeywordSet( booleanIx );

5284

5285

static int extractIx = e->KeywordIx( "EXTRACT" );

5286

bool extractKW = e->KeywordSet( extractIx );

5287

5288

static int foldCaseIx = e->KeywordIx( "FOLD_CASE" );

5289

bool foldCaseKW = e->KeywordSet( foldCaseIx );

5290

5291

//XXXpch: this is wrong, should check arg_present

5292

static int lengthIx = e->KeywordIx( "LENGTH" );

5293

bool lengthKW = e->KeywordPresent( lengthIx );

5294

5295

static int subexprIx = e->KeywordIx( "SUBEXPR" );

5296

bool subexprKW = e->KeywordSet( subexprIx );

5297

5298

if( booleanKW && (subexprKW || extractKW || lengthKW))

5299

e->Throw( "Conflicting keywords.");

5300

5301

char err_msg[MAX_REGEXPERR_LENGTH];

5302

5303

// set the compile flags

5304

int cflags = REG_EXTENDED;

5305

if (foldCaseKW)

5306

cflags |= REG_ICASE;

5307

if (booleanKW)

5308

cflags |= REG_NOSUB;

5309

5310

// compile the regular expression

5311

regex_t regexp;

5312

int compRes = regcomp( &regexp, pattern.c_str(), cflags);

5313

SizeT nSubExpr = regexp.re_nsub + 1;

5314

5315

// cout << regexp.re_nsub << endl;

5316

5317

if (compRes) {

5318

regerror(compRes, &regexp, err_msg, MAX_REGEXPERR_LENGTH);

5319

e->Throw( "Error processing regular expression: "+

5320

pattern+"\n "+string(err_msg)+".");

5321

}

5322

5323

BaseGDL* result;

5324

5325

if( booleanKW)

5326

result = new DByteGDL(dim);

5327

else if( extractKW && !subexprKW)

5328

{

5329

// cout << "my pb ! ? dim= " << dim << endl;

5330

result = new DStringGDL(dim);

5331

}

5332

else if( subexprKW)

5333

{

5334

// cout << "my pb 2 ? dim= " << dim << endl;

5335

dimension subExprDim = dim;

5336

subExprDim >> nSubExpr; // m_schellens: commented in, needed

5337

if( extractKW)

5338

result = new DStringGDL(subExprDim);

5339

else

5340

result = new DLongGDL(subExprDim);

5341

}

5342

else

5343

result = new DLongGDL(dim);

5344

5345

DLongGDL* len = NULL;

5346

if( lengthKW) {

5347

e->AssureGlobalKW( lengthIx);

5348

if( subexprKW)

5349

{

5350

dimension subExprDim = dim;

5351

subExprDim >> nSubExpr; // m_schellens: commented in, needed

5352

len = new DLongGDL(subExprDim);

5353

}

5354

else

5355

{

5356

len = new DLongGDL(dim);

5357

}

5358

for( SizeT i=0; i<len->N_Elements(); ++i)

5359

(*len)[i]= -1;

5360

}

5361

5362

int nmatch = 1;

5363

if( subexprKW) nmatch = nSubExpr;

5364

5365

regmatch_t* pmatch = new regmatch_t[nSubExpr];

5366

ArrayGuard<regmatch_t> pmatchGuard( pmatch);

5367

5368

// cout << "dim " << dim.NDimElements() << endl;

5369

for( SizeT s=0; s<dim.NDimElements(); ++s)

5370

{

5371

int eflags = 0;

5372

5373

for( SizeT sE=0; sE<nSubExpr; ++sE)

5374

pmatch[sE].rm_so = -1;

5375

5376

// now match towards the string

5377

int matchres = regexec( &regexp, (*stringExpr)[s].c_str(), nmatch, pmatch, eflags);

5378

5379

// subexpressions

5380

if ( extractKW && subexprKW) {

5381

5382

// Loop through subexpressions & fill output array

5383

for( SizeT i = 0; i<nSubExpr; ++i) {

5384

if (pmatch[i].rm_so != -1)

5385

(*static_cast<DStringGDL*>(result))[i+s*nSubExpr] =

5386

(*stringExpr)[s].substr( pmatch[i].rm_so, pmatch[i].rm_eo - pmatch[i].rm_so);

5387

// (*stringExpr)[i+s*nSubExpr].substr( pmatch[i].rm_so, pmatch[i].rm_eo - pmatch[i].rm_so);

5388

if( lengthKW)

5389

(*len)[i+s*nSubExpr] = pmatch[i].rm_so != -1 ? pmatch[i].rm_eo - pmatch[i].rm_so : -1;

5390

// (*len)[i+s*nSubExpr] = pmatch[i].rm_eo - pmatch[i].rm_so;

5391

}

5392

}

5393

else if ( subexprKW)

5394

{

5395

// cout << "je ne comprends pas v2: "<< nSubExpr << endl;

5396

5397

// Loop through subexpressions & fill output array

5398

for( SizeT i = 0; i<nSubExpr; ++i) {

5399

(* static_cast<DLongGDL*>(result))[i+s*nSubExpr] = pmatch[i].rm_so;

5400

if( lengthKW)

5401

(*len)[i+s*nSubExpr] = pmatch[i].rm_so != -1 ? pmatch[i].rm_eo - pmatch[i].rm_so : -1;

5402

}

5403

}

5404

else

5405

{

5406

if( booleanKW)

5407

(* static_cast<DByteGDL*>(result))[s] = (matchres == 0);

5408

else if ( extractKW) // !subExprKW

5409

{

5410

if( matchres == 0)

5411

(* static_cast<DStringGDL*>(result))[s] =

5412

(*stringExpr)[s].substr( pmatch[0].rm_so,

5413

pmatch[0].rm_eo - pmatch[0].rm_so);

5414

}

5415

else

5416

(*static_cast<DLongGDL*>(result))[s] = matchres ? -1 : pmatch[0].rm_so;

5417

}

5418

5419

if( lengthKW && !subexprKW)

5420

(*len)[s] = pmatch[0].rm_eo - pmatch[0].rm_so;

5421

}

5422

5423

regfree( &regexp);

5424

5425

if( lengthKW)

5426

e->SetKW( lengthIx, len);

5427

5428

return result;

5429

}

5430

5431

BaseGDL* routine_info( EnvT* e)

5432

{

5433

SizeT nParam=e->NParam();

5434

5435

static int functionsIx = e->KeywordIx( "FUNCTIONS" );

5436

bool functionsKW = e->KeywordSet( functionsIx );

5437

static int systemIx = e->KeywordIx( "SYSTEM" );

5438

bool systemKW = e->KeywordSet( systemIx );

5439

static int disabledIx = e->KeywordIx( "DISABLED" );

5440

bool disabledKW = e->KeywordSet( disabledIx );

5441

static int parametersIx = e->KeywordIx( "PARAMETERS" );

5442

bool parametersKW = e->KeywordSet( parametersIx );

5443

5444

if (parametersKW)

5445

{

5446

// sanity checks

5447

if (systemKW || disabledKW) e->Throw("Conflicting keywords.");

5448

if (nParam != 1) e->Throw("Incorrect number of arguments.");

5449

5450

// getting the routine name from the first parameter

5451

DString name;

5452

e->AssureScalarPar<DStringGDL>(0, name);

5453

name = StrUpCase(name);

5454

5455

DSubUD* routine = functionsKW

5456

? static_cast<DSubUD*>(funList[GDLInterpreter::GetFunIx(name)])

5457

: static_cast<DSubUD*>(proList[GDLInterpreter::GetProIx(name)]);

5458

SizeT np = routine->NPar(), nk = routine->NKey();

5459

5460

// creating the output anonymous structure

5461

DStructDesc* stru_desc = new DStructDesc("$truct");

5462

SpDLong aLong;

5463

stru_desc->AddTag("NUM_ARGS", &aLong);

5464

stru_desc->AddTag("NUM_KW_ARGS", &aLong);

5465

if (np > 0)

5466

{

5467

SpDString aStringArr(dimension((int)np));

5468

stru_desc->AddTag("ARGS", &aStringArr);

5469

}

5470

if (nk > 0)

5471

{

5472

SpDString aStringArr(dimension((int)nk));

5473

stru_desc->AddTag("KW_ARGS", &aStringArr);

5474

}

5475

DStructGDL* stru = new DStructGDL(stru_desc, dimension());

5476

5477

// filling the structure with information about the routine

5478

stru->InitTag("NUM_ARGS", DLongGDL(np));

5479

stru->InitTag("NUM_KW_ARGS", DLongGDL(nk));

5480

if (np > 0)

5481

{

5482

DStringGDL *pnames = new DStringGDL(dimension(np));

5483

for (SizeT p = 0; p < np; ++p) (*pnames)[p] = routine->GetVarName(nk + p);

5484

stru->InitTag("ARGS", *pnames);

5485

GDLDelete(pnames);

5486

}

5487

if (nk > 0)

5488

{

5489

DStringGDL *knames = new DStringGDL(dimension(nk));

5490

for (SizeT k = 0; k < nk; ++k) (*knames)[k] = routine->GetKWName(k);

5491

stru->InitTag("KW_ARGS", *knames);

5492

GDLDelete(knames);

5493

}

5494

5495

// returning

5496

return stru;

5497

}

5498

5499

// GDL does not have disabled routines

5500

if( disabledKW) return new DStringGDL("");

5501

5502

// if( functionsKW || systemKW || nParam == 0)

5503

// {

5504

deque<DString> subList;

5505

5506

if( functionsKW)

5507

{

5508

if( systemKW)

5509

{

5510

SizeT n = libFunList.size();

5511

if( n == 0) return new DStringGDL("");

5512

5513

DStringGDL* res = new DStringGDL( dimension( n), BaseGDL::NOZERO);

5514

for( SizeT i = 0; i<n; ++i)

5515

(*res)[i] = libFunList[ i]->ObjectName();

5516

5517

return res;

5518

}

5519

else

5520

{

5521

SizeT n = funList.size();

5522

if( n == 0) return new DStringGDL("");

5523

subList.resize( n);

5524

5525

for( SizeT i = 0; i<n; ++i)

5526

subList.push_back( funList[ i]->ObjectName());

5527

}

5528

}

5529

else

5530

{

5531

if( systemKW)

5532

{

5533

SizeT n = libProList.size();

5534

if( n == 0) return new DStringGDL("");

5535

5536

DStringGDL* res = new DStringGDL( dimension( n), BaseGDL::NOZERO);

5537

for( SizeT i = 0; i<n; ++i)

5538

(*res)[i] = libProList[ i]->ObjectName();

5539

5540

return res;

5541

}

5542

else

5543

{

5544

SizeT n = proList.size();

5545

if( n == 0) return new DStringGDL("");

5546

subList.resize( n);

5547

5548

for( SizeT i = 0; i<n; ++i)

5549

subList.push_back( proList[ i]->ObjectName());

5550

}

5551

}

5552

5553

sort( subList.begin(), subList.end());

5554

SizeT nS = subList.size();

5555

5556

DStringGDL* res = new DStringGDL( dimension( nS), BaseGDL::NOZERO);

5557

for( SizeT s=0; s<nS; ++s)

5558

(*res)[ s] = subList[ s];

5559

5560

return res;

5561

// }

5562

}

5563

5564

BaseGDL* get_kbrd( EnvT* e)

5565

{

5566

#if defined(HAVE_LIBREADLINE)

5567

#include <readline/readline.h>

5568

rl_prep_terminal (0);

5569

#endif

5570

5571

SizeT nParam=e->NParam();

5572

5573

bool doWait = true;

5574

if( nParam > 0)

5575

{

5576

doWait = false;

5577

DLong waitArg = 0;

5578

e->AssureLongScalarPar( 0, waitArg);

5579

if( waitArg != 0)

5580

{

5581

doWait = true;

5582

}

5583

}

5584

5585

// https://sourceforge.net/forum/forum.php?thread_id=3292183&forum_id=338691

5586

// DONE: Implement proper SCALAR parameter handling (doWait variable)

5587

// which is/was not blocking in the original program.

5588

// note: multi-byte input is not supported here.

5589

5590

char c='\0'; //initialize is never a bad idea...

5591

5592

int fd=fileno(stdin);

5593

#ifndef _MSC_VER

5594

struct termios orig, get;

5595

#endif

5596

// Get terminal setup to revert to it at end.

5597

#ifndef _MSC_VER

5598

(void)tcgetattr(fd, &orig);

5599

// New terminal setup, non-canonical.

5600

get.c_lflag = ISIG;

5601

#endif

5602

if (doWait)

5603

{

5604

// will wait for a character

5605

#ifndef _MSC_VER

5606

get.c_cc[VTIME]=0;

5607

get.c_cc[VMIN]=1;

5608

(void)tcsetattr(fd, TCSANOW, &get);

5609

#endif

5610

cin.get(c);

5611

}

5612

else

5613

{

5614

// will not wait, but return EOF or next character in terminal buffer if present

5615

#ifndef _MSC_VER

5616

get.c_cc[VTIME]=0;

5617

get.c_cc[VMIN]=0;

5618

(void)tcsetattr(fd, TCSANOW, &get);

5619

#endif

5620

//the trick is *not to use C++ functions here. cin.get would wait.*

5621

c=std::fgetc(stdin);

5622

//and to convert EOF to null (otherwise GDL may exit if not compiled with

5623

//[lib][n]curses)

5624

if(c==EOF) c='\0';

5625

}

5626

5627

// Restore original terminal settings.

5628

#ifndef _MSC_VER

5629

(void)tcsetattr(fd, TCSANOW, &orig);

5630

#endif

5631

#if defined(HAVE_LIBREADLINE)

5632

rl_deprep_terminal ();

5633

#endif

5634

5635

DStringGDL* res = new DStringGDL( DString( i2s( c)));

5636

5637

return res;

5638

5639

}

5640

5641

5642

BaseGDL* temporary( EnvT* e)

5643

{

5644

SizeT nParam=e->NParam(1);

5645

5646

BaseGDL** p0 = &e->GetParDefined( 0);

5647

5648

BaseGDL* ret = *p0;

5649

5650

*p0 = NULL; // make parameter undefined

5651

return ret;

5652

}

5653

5654

BaseGDL* memory( EnvT* e)

5655

{

5656

SizeT nParam=e->NParam( 0);

5657

5658

BaseGDL* ret;

5659

bool kw_l64 = e->KeywordSet(e->KeywordIx("L64"));

5660

// TODO: IDL-doc mentions about automatically switching to L64 if needed

5661

5662

if (e->KeywordSet(e->KeywordIx("STRUCTURE")))

5663

{

5664

// returning structure

5665

if (kw_l64)

5666

{

5667

ret = new DStructGDL("IDL_MEMORY64");

5668

DStructGDL* retStru = static_cast<DStructGDL*>(ret);

5669

(retStru->GetTag(retStru->Desc()->TagIndex("CURRENT")))->InitFrom( DLong64GDL(MemStats::GetCurrent()));

5670

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_ALLOC")))->InitFrom( DLong64GDL(MemStats::GetNumAlloc()));

5671

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_FREE")))->InitFrom( DLong64GDL(MemStats::GetNumFree()));

5672

(retStru->GetTag(retStru->Desc()->TagIndex("HIGHWATER")))->InitFrom( DLong64GDL(MemStats::GetHighWater()));

5673

}

5674

else

5675

{

5676

ret = new DStructGDL("IDL_MEMORY");

5677

DStructGDL* retStru = static_cast<DStructGDL*>(ret);

5678

(retStru->GetTag(retStru->Desc()->TagIndex("CURRENT")))->InitFrom( DLongGDL(MemStats::GetCurrent()));

5679

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_ALLOC")))->InitFrom( DLongGDL(MemStats::GetNumAlloc()));

5680

(retStru->GetTag(retStru->Desc()->TagIndex("NUM_FREE")))->InitFrom( DLongGDL(MemStats::GetNumFree()));

5681

(retStru->GetTag(retStru->Desc()->TagIndex("HIGHWATER")))->InitFrom( DLongGDL(MemStats::GetHighWater()));

5682

}

5683

}

5684

else

5685

{

5686

bool kw_current = e->KeywordSet(e->KeywordIx("CURRENT"));

5687

bool kw_num_alloc = e->KeywordSet(e->KeywordIx("NUM_ALLOC"));

5688

bool kw_num_free = e->KeywordSet(e->KeywordIx("NUM_FREE"));

5689

bool kw_highwater = e->KeywordSet(e->KeywordIx("HIGHWATER"));

5690

5691

// Following the IDL documentation: mutually exclusive keywords

5692

// IDL behaves different, incl. segfaults with selected kw combinations

5693

if (kw_current + kw_num_alloc + kw_num_free + kw_highwater > 1)

5694

e->Throw("CURRENT, NUM_ALLOC, NUM_FREE & HIGHWATER keywords"

5695

" are mutually exclusive");

5696

5697

if (kw_current)

5698

{

5699

if (kw_l64) ret = new DLong64GDL(MemStats::GetCurrent());

5700

else ret = new DLongGDL(MemStats::GetCurrent());

5701

}

5702

else if (kw_num_alloc)

5703

{

5704

if (kw_l64) ret = new DLong64GDL(MemStats::GetNumAlloc());

5705

else ret = new DLongGDL(MemStats::GetNumAlloc());

5706

}

5707

else if (kw_num_free)

5708

{

5709

if (kw_l64) ret = new DLong64GDL(MemStats::GetNumFree());

5710

else ret = new DLongGDL(MemStats::GetNumFree());

5711

}

5712

else if (kw_highwater)

5713

{

5714

if (kw_l64) ret = new DLong64GDL(MemStats::GetHighWater());

5715

else ret = new DLongGDL(MemStats::GetHighWater());

5716

}

5717

else

5718

{

5719

// returning 4-element array

5720

if (kw_l64)

5721

{

5722

ret = new DLong64GDL(dimension(4));

5723

(*static_cast<DLong64GDL*>(ret))[0] = MemStats::GetCurrent();

5724

(*static_cast<DLong64GDL*>(ret))[1] = MemStats::GetNumAlloc();

5725

(*static_cast<DLong64GDL*>(ret))[2] = MemStats::GetNumFree();

5726

(*static_cast<DLong64GDL*>(ret))[3] = MemStats::GetHighWater();

5727

}

5728

else

5729

{

5730

ret = new DLongGDL(dimension(4));

5731

(*static_cast<DLongGDL*>(ret))[0] = MemStats::GetCurrent();

5732

(*static_cast<DLongGDL*>(ret))[1] = MemStats::GetNumAlloc();

5733

(*static_cast<DLongGDL*>(ret))[2] = MemStats::GetNumFree();

5734

(*static_cast<DLongGDL*>(ret))[3] = MemStats::GetHighWater();

5735

}

5736

}

5737

}

5738

5739

return ret;

5740

}

5741

5742

inline DByte StrCmp( const string& s1, const string& s2, DLong n)

5743

{

5744

if( n <= 0) return 1;

5745

if( s1.substr(0,n) == s2.substr(0,n)) return 1;

5746

return 0;

5747

}

5748

inline DByte StrCmp( const string& s1, const string& s2)

5749

{

5750

if( s1 == s2) return 1;

5751

return 0;

5752

}

5753

inline DByte StrCmpFold( const string& s1, const string& s2, DLong n)

5754

{

5755

if( n <= 0) return 1;

5756

if( StrUpCase( s1.substr(0,n)) == StrUpCase(s2.substr(0,n))) return 1;

5757

return 0;

5758

}

5759

inline DByte StrCmpFold( const string& s1, const string& s2)

5760

{

5761

if( StrUpCase( s1) == StrUpCase(s2)) return 1;

5762

return 0;

5763

}

5764

5765

BaseGDL* strcmp_fun( EnvT* e)

5766

{

5767

SizeT nParam=e->NParam(2);

5768

5769

DStringGDL* s0 = static_cast<DStringGDL*>( e->GetParAs< DStringGDL>( 0));

5770

DStringGDL* s1 = static_cast<DStringGDL*>( e->GetParAs< DStringGDL>( 1));

5771

5772

DLongGDL* l2 = NULL;

5773

if( nParam > 2)

5774

{

5775

l2 = static_cast<DLongGDL*>( e->GetParAs< DLongGDL>( 2));

5776

}

5777

5778

static int foldIx = e->KeywordIx( "FOLD_CASE");

5779

bool fold = e->KeywordSet( foldIx );

5780

5781

if( s0->Scalar() && s1->Scalar())

5782

{

5783

if( l2 == NULL)

5784

{

5785

if( fold)

5786

return new DByteGDL( StrCmpFold( (*s0)[0], (*s1)[0]));

5787

else

5788

return new DByteGDL( StrCmp( (*s0)[0], (*s1)[0]));

5789

}

5790

else

5791

{

5792

DByteGDL* res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5793

SizeT nEl = l2->N_Elements();

5794

if( fold)

5795

for( SizeT i=0; i<nEl; ++i)

5796

(*res)[i] = StrCmpFold( (*s0)[0], (*s1)[0], (*l2)[i]);

5797

else

5798

for( SizeT i=0; i<nEl; ++i)

5799

(*res)[i] = StrCmp( (*s0)[0], (*s1)[0], (*l2)[i]);

5800

return res;

5801

}

5802

}

5803

else // at least one array

5804

{

5805

if( l2 == NULL)

5806

{

5807

if( s0->Scalar())

5808

{

5809

DByteGDL* res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5810

SizeT nEl = s1->N_Elements();

5811

if( fold)

5812

for( SizeT i=0; i<nEl; ++i)

5813

(*res)[i] = StrCmpFold( (*s0)[0], (*s1)[i]);

5814

else

5815

for( SizeT i=0; i<nEl; ++i)

5816

(*res)[i] = StrCmp( (*s0)[0], (*s1)[i]);

5817

return res;

5818

}

5819

else if( s1->Scalar())

5820

{

5821

DByteGDL* res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5822

SizeT nEl = s0->N_Elements();

5823

if( fold)

5824

for( SizeT i=0; i<nEl; ++i)

5825

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[0]);

5826

else

5827

for( SizeT i=0; i<nEl; ++i)

5828

(*res)[i] = StrCmp( (*s0)[i], (*s1)[0]);

5829

return res;

5830

}

5831

else // both arrays

5832

{

5833

DByteGDL* res;

5834

SizeT nEl;

5835

if( s0->N_Elements() <= s1->N_Elements())

5836

{

5837

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5838

nEl = s0->N_Elements();

5839

}

5840

else

5841

{

5842

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5843

nEl = s1->N_Elements();

5844

}

5845

if( fold)

5846

for( SizeT i=0; i<nEl; ++i)

5847

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[i]);

5848

else

5849

for( SizeT i=0; i<nEl; ++i)

5850

(*res)[i] = StrCmp( (*s0)[i], (*s1)[i]);

5851

return res;

5852

}

5853

}

5854

else // l2 != NULL

5855

{

5856

DByteGDL* res;

5857

SizeT nEl;

5858

bool l2Scalar = l2->Scalar();

5859

if( s0->Scalar())

5860

{

5861

if( l2Scalar || s1->N_Elements() <= l2->N_Elements())

5862

{

5863

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5864

nEl = s1->N_Elements();

5865

}

5866

else

5867

{

5868

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5869

nEl = l2->N_Elements();

5870

}

5871

if( fold)

5872

for( SizeT i=0; i<nEl; ++i)

5873

(*res)[i] = StrCmpFold( (*s0)[0], (*s1)[i], (*l2)[l2Scalar?0:i]);

5874

else

5875

for( SizeT i=0; i<nEl; ++i)

5876

(*res)[i] = StrCmp( (*s0)[0], (*s1)[i], (*l2)[l2Scalar?0:i]);

5877

return res;

5878

}

5879

else if( s1->Scalar())

5880

{

5881

if( l2Scalar || s0->N_Elements() <= l2->N_Elements())

5882

{

5883

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5884

nEl = s0->N_Elements();

5885

}

5886

else

5887

{

5888

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5889

nEl = l2->N_Elements();

5890

}

5891

if( fold)

5892

for( SizeT i=0; i<nEl; ++i)

5893

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[0], (*l2)[l2Scalar?0:i]);

5894

else

5895

for( SizeT i=0; i<nEl; ++i)

5896

(*res)[i] = StrCmp( (*s0)[i], (*s1)[0], (*l2)[l2Scalar?0:i]);

5897

return res;

5898

}

5899

else // s1 and s2 are arrays

5900

{

5901

if( l2Scalar)

5902

if( s0->N_Elements() <= s1->N_Elements())

5903

{

5904

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5905

nEl = s0->N_Elements();

5906

}

5907

else

5908

{

5909

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5910

nEl = s1->N_Elements();

5911

}

5912

else

5913

{

5914

if( s0->N_Elements() <= s1->N_Elements())

5915

if( s0->N_Elements() <= l2->N_Elements())

5916

{

5917

res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);

5918

nEl = s0->N_Elements();

5919

}

5920

else

5921

{

5922

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5923

nEl = l2->N_Elements();

5924

}

5925

else

5926

if( s1->N_Elements() <= l2->N_Elements())

5927

{

5928

res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);

5929

nEl = s1->N_Elements();

5930

}

5931

else

5932

{

5933

res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);

5934

nEl = l2->N_Elements();

5935

}

5936

}

5937

if( fold)

5938

for( SizeT i=0; i<nEl; ++i)

5939

(*res)[i] = StrCmpFold( (*s0)[i], (*s1)[i], (*l2)[l2Scalar?0:i]);

5940

else

5941

for( SizeT i=0; i<nEl; ++i)

5942

(*res)[i] = StrCmp( (*s0)[i], (*s1)[i], (*l2)[l2Scalar?0:i]);

5943

return res;

5944

}

5945

}

5946

}

5947

}

5948

5949

string TagName( EnvT* e, const string& name)

5950

{

5951

string n = StrUpCase( name);

5952

SizeT len = n.size();

5953

if( n[0] != '_' && n[0] != '!' && (n[0] < 'A' || n[0] > 'Z'))

5954

e->Throw( "Illegal tag name: "+name+".");

5955

for( SizeT i=1; i<len; ++i)

5956

{

5957

if( n[i] == ' ')

5958

n[i] = '_';

5959

else

5960

if( n[i] != '_' && n[i] != '$' && //n[0] != '!' &&

5961

(n[i] < 'A' || n[i] > 'Z') &&

5962

(n[i] < '0' || n[i] > '9'))

5963

e->Throw( "Illegal tag name: "+name+".");

5964

}

5965

return n;

5966

}

5967

5968

BaseGDL* create_struct( EnvT* e)

5969

{

5970

static int nameIx = e->KeywordIx( "NAME" );

5971

DString name = "$truct";

5972

if( e->KeywordPresent( nameIx)) {

5973

// Check if name exists, if not then treat as unnamed

5974

if (e->GetKW( nameIx) != NULL)

5975

e->AssureStringScalarKW( nameIx, name);

5976

}

5977

5978

if( name != "$truct") // named struct

5979

{

5980

name = StrUpCase( name);

5981

5982

SizeT nParam=e->NParam();

5983

5984

if( nParam == 0)

5985

{

5986

DStructDesc* desc =

5987

e->Interpreter()->GetStruct( name, e->CallingNode());

5988

5989

dimension dim( 1);

5990

return new DStructGDL( desc, dim);

5991

}

5992

5993

DStructDesc* nStructDesc;

5994

auto_ptr<DStructDesc> nStructDescGuard;

5995

5996

DStructDesc* oStructDesc=

5997

FindInStructList( structList, name);

5998

5999

if( oStructDesc == NULL || oStructDesc->NTags() > 0)

6000

{

6001

// not defined at all yet (-> define now)

6002

// or completely defined (-> define now and check equality)

6003

nStructDesc= new DStructDesc( name);

6004

6005

// guard it

6006

nStructDescGuard.reset( nStructDesc);

6007

}

6008

else

6009

{

6010

// NTags() == 0

6011

// not completely defined (only name in list)

6012

nStructDesc= oStructDesc;

6013

}

6014

6015

// the instance variable

6016

// dimension dim( 1);

6017

// DStructGDL* instance = new DStructGDL( nStructDesc, dim);

6018

DStructGDL* instance = new DStructGDL( nStructDesc);

6019

auto_ptr<DStructGDL> instance_guard(instance);

6020

6021

for( SizeT p=0; p<nParam; ++p)

6022

{

6023

BaseGDL* par = e->GetParDefined( p);

6024

DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);

6025

if( parStruct != NULL)

6026

{

6027

// add struct

6028

if( !parStruct->Scalar())

6029

e->Throw("Expression must be a scalar in this context: "+

6030

e->GetParString( p));

6031

6032

DStructDesc* desc = parStruct->Desc();

6033

for( SizeT t=0; t< desc->NTags(); ++t)

6034

{

6035

instance->NewTag( desc->TagName( t),

6036

parStruct->GetTag( t)->Dup());

6037

}

6038

}

6039

else

6040

{

6041

// add tag value pair

6042

DStringGDL* tagNames = e->GetParAs<DStringGDL>( p);

6043

SizeT nTags = tagNames->N_Elements();

6044

6045

SizeT tagStart = p+1;

6046

SizeT tagEnd = p+nTags;

6047

if( tagEnd >= nParam)

6048

e->Throw( "Incorrect number of arguments.");

6049

6050

do{

6051

++p;

6052

BaseGDL* value = e->GetParDefined( p);

6053

6054

// add

6055

instance->NewTag( TagName( e, (*tagNames)[ p-tagStart]),

6056

value->Dup());

6057

}

6058

while( p<tagEnd);

6059

}

6060

}

6061

6062

if( oStructDesc != NULL)

6063

{

6064

if( oStructDesc != nStructDesc)

6065

{

6066

oStructDesc->AssureIdentical(nStructDesc);

6067

instance->DStructGDL::SetDesc(oStructDesc);

6068

//delete nStructDesc; // auto_ptr

6069

}

6070

}

6071

else

6072

{

6073

// release from guard (if not NULL)

6074

nStructDescGuard.release();

6075

// insert into struct list

6076

structList.push_back(nStructDesc);

6077

}

6078

6079

instance_guard.release();

6080

return instance;

6081

}

6082

else

6083

{ // unnamed struc

6084

6085

// Handle case of single structure parameter

6086

SizeT nParam;

6087

nParam = e->NParam(1);

6088

BaseGDL* par = e->GetParDefined( 0);

6089

DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);

6090

if (nParam != 1 || parStruct == NULL)

6091

nParam=e->NParam(2);

6092

6093

DStructDesc* nStructDesc = new DStructDesc( "$truct");

6094

// instance takes care of nStructDesc since it is unnamed

6095

// dimension dim( 1);

6096

// DStructGDL* instance = new DStructGDL( nStructDesc, dim);

6097

DStructGDL* instance = new DStructGDL( nStructDesc);

6098

auto_ptr<DStructGDL> instance_guard(instance);

6099

6100

for( SizeT p=0; p<nParam;)

6101

{

6102

BaseGDL* par = e->GetParDefined( p);

6103

DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);

6104

if( parStruct != NULL)

6105

{

6106

// add struct

6107

if( !parStruct->Scalar())

6108

e->Throw("Expression must be a scalar in this context: "+

6109

e->GetParString( p));

6110

6111

DStructDesc* desc = parStruct->Desc();

6112

for( SizeT t=0; t< desc->NTags(); ++t)

6113

{

6114

instance->NewTag( desc->TagName( t),

6115

parStruct->GetTag( t)->Dup());

6116

}

6117

++p;

6118

}

6119

else

6120

{

6121

// add tag value pair

6122

DStringGDL* tagNames = e->GetParAs<DStringGDL>( p);

6123

SizeT nTags = tagNames->N_Elements();

6124

6125

SizeT tagStart = p+1;

6126

SizeT tagEnd = p+nTags;

6127

if( tagEnd >= nParam)

6128

e->Throw( "Incorrect number of arguments.");

6129

6130

for(++p; p<=tagEnd; ++p)

6131

{

6132

BaseGDL* value = e->GetParDefined( p);

6133

6134

// add

6135

instance->NewTag( TagName( e, (*tagNames)[ p-tagStart]),

6136

value->Dup());

6137

}

6138

}

6139

}

6140

6141

instance_guard.release();

6142

return instance;

6143

}

6144

}

6145

6146

BaseGDL* rotate( EnvT* e)

6147

{

6148

e->NParam(2);

6149

BaseGDL* p0 = e->GetParDefined( 0);

6150

6151

if( p0->Rank() == 0)

6152

e->Throw( "Expression must be an array in this context: " + e->GetParString( 0));

6153

6154

if( p0->Rank() != 1 && p0->Rank() != 2)

6155

e->Throw( "Only 1 or 2 dimensions allowed: " + e->GetParString( 0));

6156

6157

if( p0->Type() == GDL_STRUCT)

6158

e->Throw( "STRUCT expression not allowed in this context: "+

6159

e->GetParString( 0));

6160

6161

DLong dir;

6162

e->AssureLongScalarPar( 1, dir);

6163

6164

return p0->Rotate( dir);

6165

}

6166

6167

// SA: based on the code of rotate() (above)

6168

BaseGDL* reverse( EnvT* e)

6169

{

6170

e->NParam(1);

6171

BaseGDL* p0 = e->GetParDefined(0);

6172

if (p0->Rank() == 0) return p0->Dup();

6173

6174

DLong dim = 1;

6175

if (e->GetPar(1) != NULL)

6176

e->AssureLongScalarPar(1, dim);

6177

if (p0->Rank() != 0 && (dim > p0->Rank() || dim < 1))

6178

e->Throw("Subscript_index must be positive and less than or equal to number of dimensions.");

6179

6180

BaseGDL* ret;

6181

// IDL doc states that OVERWRITE is ignored for one- or two-dim. arrays

6182

// but it seems to behave differently

6183

// if (p0->Rank() > 2 && e->KeywordSet("OVERWRITE") && e->GlobalPar(0))

6184

if (e->KeywordSet("OVERWRITE"))

6185

{

6186

p0->Reverse(dim-1);

6187

bool stolen = e->StealLocalPar( 0);

6188

if( !stolen) e->GetPar(0) = NULL;

6189

return p0;

6190

}

6191

else ret = p0->DupReverse(dim - 1);

6192

return ret;

6193

}

6194

6195

// SA: parse_url based on the PHP parse_url() function code

6196

// by Jim Winstead / The PHP Group (PHP license v. 3.01)

6197

// (http://svn.php.net/viewvc/php/php-src/trunk/ext/standard/url.c)

6198

// PHP is free software available at http://www.php.net/software/

6199

//

6200

// notes:

6201

// - IDL does not support IPv6 URLs, GDL does

6202

// - IDL includes characters after '#' in the QUERY part, GDL

6203

// just skips them and issues a warning (perhaps not needed)

6204

// - IDL preserves controll characters in URLs, GDL preserves

6205

// them as well but a warning is issued

6206

// - IDL sets 80 as a default value for PORT, even if the url has

6207

// an ftp:// schema indicated - GDL does not have any default value

6208

// - IDL excludes the leading "/" from the path, GDL preserves it

6209

// ... these differences seem just rational for me but please do change

6210

// it if IDL-compatibility would be beneficial for any reason here

6211

6212

BaseGDL* parse_url(EnvT* env)

6213

{

6214

// sanity check for number of parameters

6215

SizeT nParam = env->NParam();

6216

6217

// 1-nd argument : the url string

6218

DString url;

6219

env->AssureScalarPar<DStringGDL>(0, url);

6220

6221

// sanity check for controll characters

6222

string::iterator it;

6223

for (it = url.begin(); it < url.end(); it++) if (iscntrl(*it))

6224

{

6225

Warning("PARSE_URL: URL contains a control character");

6226

break;

6227

}

6228

6229

// creating the output anonymous structure

6230

DStructDesc* urlstru_desc = new DStructDesc("$truct");

6231

SpDString aString;

6232

urlstru_desc->AddTag("SCHEME", &aString);

6233

static size_t ixSCHEME = 0;

6234

urlstru_desc->AddTag("USERNAME", &aString);

6235

urlstru_desc->AddTag("PASSWORD", &aString);

6236

urlstru_desc->AddTag("HOST", &aString);

6237

urlstru_desc->AddTag("PORT", &aString);

6238

static size_t ixPORT = 4;

6239

urlstru_desc->AddTag("PATH", &aString);

6240

urlstru_desc->AddTag("QUERY", &aString);

6241

DStructGDL* urlstru = new DStructGDL(urlstru_desc, dimension());

6242

auto_ptr<DStructGDL> urlstru_guard(urlstru);

6243

6244

// parsing the URL

6245

char const *str = url.c_str();

6246

size_t length = url.length();

6247

char port_buf[6];

6248

char const *s, *e, *p, *pp, *ue;

6249

6250

s = str;

6251

ue = s + length;

6252

6253

// parsing scheme

6254

if ((e = (const char*)memchr(s, ':', length)) && (e - s))

6255

{

6256

// validating scheme

6257

p = s;

6258

while (p < e)

6259

{

6260

// scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]

6261

if (!isalpha(*p) && !isdigit(*p) && *p != '+' && *p != '.' && *p != '-')

6262

{

6263

if (e + 1 < ue) goto parse_port;

6264

else goto just_path;

6265

}

6266

p++;

6267

}

6268

if (*(e + 1) == '\0')

6269

{

6270

// only scheme is available

6271

urlstru->InitTag("SCHEME", DStringGDL(string(s, (e - s))));

6272

goto end;

6273

}

6274

// schemas without '/' (like mailto: and zlib:)

6275

if (*(e+1) != '/')

6276

{

6277

// check if the data we get is a port this allows us to correctly parse things like a.com:80

6278

p = e + 1;

6279

while (isdigit(*p)) p++;

6280

if ((*p == '\0' || *p == '/') && (p - e) < 7) goto parse_port;

6281

urlstru->InitTag("SCHEME", DStringGDL(string(s, (e - s))));

6282

length -= ++e - s;

6283

s = e;

6284

goto just_path;

6285

}

6286

else

6287

{

6288

urlstru->InitTag("SCHEME", DStringGDL(string(s, (e - s))));

6289

if (*(e+2) == '/')

6290

{

6291

s = e + 3;

6292

if (!strncasecmp("file",

6293

(*static_cast<DStringGDL*>(urlstru->GetTag(ixSCHEME)))[0].c_str(),

6294

sizeof("file")

6295

))

6296

{

6297

if (*(e + 3) == '/')

6298

{

6299

// support windows drive letters as in: file:///c:/somedir/file.txt

6300

if (*(e + 5) == ':') s = e + 4;

6301

goto nohost;

6302

}

6303

}

6304

}

6305

else

6306

{

6307

if (!strncasecmp("file",

6308

(*static_cast<DStringGDL*>(urlstru->GetTag(ixSCHEME)))[0].c_str(),

6309

sizeof("file"))

6310

)

6311

{

6312

s = e + 1;

6313

goto nohost;

6314

}

6315

else

6316

{

6317

length -= ++e - s;

6318

s = e;

6319

goto just_path;

6320

}

6321

}

6322

}

6323

}

6324

else if (e)

6325

{

6326

// no scheme, look for port

6327

parse_port:

6328

p = e + 1;

6329

pp = p;

6330

while (pp-p < 6 && isdigit(*pp)) pp++;

6331

if (pp-p < 6 && (*pp == '/' || *pp == '\0'))

6332

{

6333

memcpy(port_buf, p, (pp-p));

6334

port_buf[pp-p] = '\0';

6335

urlstru->InitTag("PORT", DStringGDL(port_buf));

6336

}

6337

else goto just_path;

6338

}

6339

else

6340

{

6341

just_path:

6342

ue = s + length;

6343

goto nohost;

6344

}

6345

e = ue;

6346

if (!(p = (const char*)memchr(s, '/', (ue - s))))

6347

{

6348

if ((p = (const char*)memchr(s, '?', (ue - s)))) e = p;

6349

else if ((p = (const char*)memchr(s, '#', (ue - s)))) e = p;

6350

}

6351

else e = p;

6352

// check for login and password

6353

{

6354

size_t pos;

6355

if ((pos = string(s, e - s).find_last_of("@")) != string::npos)

6356

{

6357

p = s + pos;

6358

if ((pp = (const char*)memchr(s, ':', (p-s))))

6359

{

6360

if ((pp-s) > 0) urlstru->InitTag("USERNAME", DStringGDL(string(s, (pp - s))));

6361

pp++;

6362

if (p-pp > 0) urlstru->InitTag("PASSWORD", DStringGDL(string(pp, (p - pp))));

6363

}

6364

else urlstru->InitTag("USERNAME", DStringGDL(string(s, (p - s))));

6365

s = p + 1;

6366

}

6367

}

6368

// check for port

6369

if (*s == '[' && *(e-1) == ']') p = s; // IPv6 embedded address

6370

else for(p = e; *p != ':' && p >= s; p--); // memrchr is a GNU extension

6371

if (p >= s && *p == ':')

6372

{

6373

if ((*static_cast<DStringGDL*>(urlstru->GetTag(ixPORT)))[0].length() == 0)

6374

{

6375

p++;

6376

if (e-p > 5) env->Throw("port cannot be longer then 5 characters");

6377

else if (e - p > 0)

6378

{

6379

memcpy(port_buf, p, (e-p));

6380

port_buf[e-p] = '\0';

6381

urlstru->InitTag("PORT", DStringGDL(port_buf));

6382

}

6383

p--;

6384

}

6385

}

6386

else p = e;

6387

// check if we have a valid host, if we don't reject the string as url

6388

if ((p-s) < 1) env->Throw("invalid host");

6389

urlstru->InitTag("HOST", DStringGDL(string(s, (p - s))));

6390

if (e == ue) goto end;

6391

s = e;

6392

nohost:

6393

if ((p = (const char*)memchr(s, '?', (ue - s))))

6394

{

6395

pp = strchr(s, '#');

6396

if (pp && pp < p)

6397

{

6398

p = pp;

6399

pp = strchr(pp+2, '#');

6400

}

6401

if (p - s) urlstru->InitTag("PATH", DStringGDL(string(s, (p - s))));

6402

if (pp)

6403

{

6404

if (pp - ++p) urlstru->InitTag("QUERY", DStringGDL(string(p, (pp - p))));

6405

p = pp;

6406

goto label_parse;

6407

}

6408

else if (++p - ue) urlstru->InitTag("QUERY", DStringGDL(string(p, (ue - p))));

6409

}

6410

else if ((p = (const char*)memchr(s, '#', (ue - s))))

6411

{

6412

if (p - s) urlstru->InitTag("PATH", DStringGDL(string(s, (p - s))));

6413

label_parse:

6414

p++;

6415

if (ue - p) Warning("PARSE_URL: URL fragment left out: #" + string(p, (ue-p)));

6416

}

6417

else urlstru->InitTag("PATH", DStringGDL(string(s, (ue - s))));

6418

end:

6419

6420

// returning the result

6421

urlstru_guard.release();

6422

return urlstru;

6423

}

6424

6425

BaseGDL* locale_get(EnvT* e)

6426

{

6427

#ifdef HAVE_LOCALE_H

6428

6429

// make GDL inherit the calling process locale

6430

setlocale(LC_ALL, "");

6431

// note doen the inherited locale

6432

DStringGDL *locale = new DStringGDL(setlocale(LC_CTYPE, NULL));

6433

// return to the C locale

6434

setlocale(LC_ALL, "C");

6435

6436

return locale;

6437

#else

6438

e->Throw("OS does not provide locale information");

6439

#endif

6440

}

6441

6442

// SA: relies on the contents of the lib::command_line_args vector

6443

// defined and filled with data (pointers) in gdl.cpp

6444

BaseGDL* command_line_args_fun(EnvT* e)

6445

{

6446

#ifdef PYTHON_MODULE

6447

e->Throw("no command line arguments available (GDL built as a Python module)");

6448

#else

6449

static int countIx = e->KeywordIx("COUNT");

6450

extern std::vector<char*> command_line_args;

6451

6452

// setting the COUNT keyword value

6453

if (e->KeywordPresent(countIx))

6454

{

6455

e->AssureGlobalKW(countIx);

6456

e->SetKW(countIx, new DLongGDL(command_line_args.size()));

6457

}

6458

6459

// returning empty string or an array of arguments

6460

if (command_line_args.empty()) return new DStringGDL("");

6461

else

6462

{

6463

BaseGDL* ret = new DStringGDL(dimension(command_line_args.size()));

6464

for (size_t i = 0; i < command_line_args.size(); i++)

6465

(*static_cast<DStringGDL*>(ret))[i] = command_line_args[i];

6466

return ret;

6467

}

6468

#endif

6469

}

6470

6471

// SA: relies in the uname() from libc (must be there if POSIX)

6472

BaseGDL* get_login_info( EnvT* e)

6473

{

6474

// getting the info

6475

#ifdef _MSC_VER

6476

#define MAX_TCHAR_BUF 256

6477

6478

char login[MAX_TCHAR_BUF];

6479

char info[MAX_TCHAR_BUF];

6480

6481

DWORD N_TCHAR = MAX_TCHAR_BUF;

6482

6483

#ifdef _UNICODE

6484

TCHAR t_buf[MAX_TCHAR_BUF];

6485

GetUserName(t_buf, &N_TCHAR);

6486

WideCharToMultiByte(CP_ACP, 0, t_buf, N_TCHAR, login, N_TCHAR, NULL, NULL);

6487

GetComputerName( t_buf, &N_TCHAR );

6488

WideCharToMultiByte(CP_ACP, 0, t_buf, N_TCHAR, info, N_TCHAR, NULL, NULL);

6489

#else

6490

GetUserName(login, &N_TCHAR);

6491

GetComputerName(info, &N_TCHAR);

6492

#endif

6493

#else

6494

char* login = getlogin();

6495

if (login == NULL) e->Throw("Failed to get user name from the OS");

6496

struct utsname info;

6497

if (0 != uname(&info)) e->Throw("Failed to get machine name from the OS");

6498

#endif

6499

// creating the output anonymous structure

6500

DStructDesc* stru_desc = new DStructDesc("$truct");

6501

SpDString aString;

6502

stru_desc->AddTag("MACHINE_NAME", &aString);

6503

stru_desc->AddTag("USER_NAME", &aString);

6504

DStructGDL* stru = new DStructGDL(stru_desc, dimension());

6505

6506

// returning the info

6507

stru->InitTag("USER_NAME", DStringGDL(login));

6508

#ifdef _MSC_VER

6509

stru->InitTag("MACHINE_NAME", DStringGDL(info));

6510

#else

6511

stru->InitTag("MACHINE_NAME", DStringGDL(info.nodename));

6512

#endif

6513

return stru;

6514

}

6515

6516

// SA: base64 logic in base64.hpp, based on code by Bob Withers (consult base64.hpp)

6517

BaseGDL* idl_base64(EnvT* e)

6518

{

6519

BaseGDL* p0 = e->GetPar(0);

6520

if (p0 != NULL)

6521

{

6522

if (p0->Rank() == 0 && p0->Type() == GDL_STRING)

6523

{

6524

// decoding

6525

string* str = &((*static_cast<DStringGDL*>(p0))[0]);

6526

if (str->length() == 0) return new DByteGDL(0);

6527

if (str->length() % 4 != 0)

6528

e->Throw("Input string length must be a multiple of 4");

6529

unsigned int retlen = base64::decodeSize(*str);

6530

if (retlen == 0 || retlen > str->length()) e->Throw("No data in the input string");

6531

DByteGDL* ret = new DByteGDL(dimension(retlen));

6532

if (!base64::decode(*str, (char*)&((*ret)[0]), ret->N_Elements()))

6533

e->Throw("Base64 decoder failed");

6534

return ret;

6535

}

6536

if (p0->Rank() >= 1 && p0->Type() == GDL_BYTE)

6537

{

6538

// encoding

6539

return new DStringGDL(

6540

base64::encode((char*)&(*static_cast<DByteGDL*>(p0))[0], p0->N_Elements())

6541

);

6542

}

6543

}

6544

e->Throw("Expecting string or byte array as a first parameter");

6545

}

6546

6547

BaseGDL* get_drive_list(EnvT* e)

6548

{

6549

if (e->KeywordPresent(0)) e->SetKW(0, new DLongGDL(0));

6550

return new DStringGDL("");

6551

}

6552

6553

// note: changes here MUST be reflected in scope_varfetch_reference() as well

6554

// because DLibFun of this function is used for scope_varfetch_reference() the keyword

6555

// indices must match

6556

BaseGDL* scope_varfetch_value( EnvT* e)

6557

{

6558

SizeT nParam=e->NParam();

6559

6560

EnvStackT& callStack = e->Interpreter()->CallStack();

6561

// DLong curlevnum = callStack.size()-1;

6562

// 'e' is not on the stack

6563

DLong curlevnum = callStack.size();

6564

6565

// static int variablesIx = e->KeywordIx( "VARIABLES" );

6566

static int levelIx = e->KeywordIx( "LEVEL" );

6567

6568

DLongGDL* level = e->IfDefGetKWAs<DLongGDL>( levelIx);

6569

6570

DLong desiredlevnum = 0;

6571

6572

if (level != NULL)

6573

desiredlevnum = (*level)[0];

6574

6575

if (desiredlevnum <= 0) desiredlevnum += curlevnum;

6576

if (desiredlevnum < 1) desiredlevnum = 1;

6577

else if (desiredlevnum > curlevnum) desiredlevnum = curlevnum;

6578

6579

DSubUD* pro = static_cast<DSubUD*>(callStack[desiredlevnum-1]->GetPro());

6580

6581

SizeT nVar = pro->Size(); // # var in GDL for desired level

6582

int nKey = pro->NKey();

6583

6584

DString varName;

6585

6586

e->AssureScalarPar<DStringGDL>( 0, varName);

6587

varName = StrUpCase( varName);

6588

6589

int xI = pro->FindVar( varName);

6590

if (xI != -1)

6591

{

6592

// BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI);

6593

BaseGDL*& par = callStack[desiredlevnum-1]->GetKW( xI);

6594

6595

if( par == NULL)

6596

e->Throw( "Variable is undefined: " + varName);

6597

6598

return par->Dup();

6599

}

6600

6601

e->Throw( "Variable not found: " + varName);

6602

return new DLongGDL(0); // compiler shut-up

6603

}

6604

6605

// this routine is special, only called as an l-function (from FCALL_LIB::LEval())

6606

// it MUST use an EnvT set up for scope_varfetch_value

6607

BaseGDL** scope_varfetch_reference( EnvT* e)

6608

{

6609

SizeT nParam=e->NParam();

6610

6611

EnvStackT& callStack = e->Interpreter()->CallStack();

6612

// DLong curlevnum = callStack.size()-1;

6613

// 'e' is not on the stack

6614

DLong curlevnum = callStack.size();

6615

6616

// static int variablesIx = e->KeywordIx( "VARIABLES" );

6617

static int levelIx = e->KeywordIx( "LEVEL" );

6618

6619

DLongGDL* level = e->IfDefGetKWAs<DLongGDL>( levelIx);

6620

6621

DLong desiredlevnum = 0;

6622

6623

if (level != NULL)

6624

desiredlevnum = (*level)[0];

6625

6626

if (desiredlevnum <= 0) desiredlevnum += curlevnum;

6627

if (desiredlevnum < 1) desiredlevnum = 1;

6628

else if (desiredlevnum > curlevnum) desiredlevnum = curlevnum;

6629

6630

DSubUD* pro = static_cast<DSubUD*>(callStack[desiredlevnum-1]->GetPro());

6631

6632

SizeT nVar = pro->Size(); // # var in GDL for desired level

6633

int nKey = pro->NKey();

6634

6635

DString varName;

6636

6637

e->AssureScalarPar<DStringGDL>( 0, varName);

6638

varName = StrUpCase( varName);

6639

int xI = pro->FindVar( varName);

6640

if (xI != -1)

6641

{

6642

// BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI);

6643

BaseGDL*& par = callStack[desiredlevnum-1]->GetKW( xI);

6644

6645

// if( par == NULL)

6646

// e->Throw( "Variable is undefined: " + varName);

6647

6648

return &par;

6649

}

6650

6651

e->Throw( "LVariable not found: " + varName);

6652

return NULL; // compiler shut-up

6653

}

6654

6655

6656

} // namespace

6657