1 /***************************************************************************
2 basic_fun.cpp - basic GDL library function
3 -------------------
4 begin : July 22 2002
5 copyright : (C) 2002 by Marc Schellens (exceptions see below)
6 email : m_schellens@users.sf.net
7
8 strtok_fun, getenv_fun, tag_names_fun, stregex_fun:
9 (C) 2004 by Peter Messmer
10
11 20150506 Jacco A. de Zwart, National Institutes of Health, Bethesda, MD, USA
12 Changed behavior of COMPLEX() and DCOMPLEX() called with three arguments,
13 aka where type casting is the expected behavoir.
14
15 2017 September
16 Greg Jung mods to unbug pointer, object treatments. Also:
17 Updated with new Where(), cosmetics
18 #ifndef _WIN32 replaces #if !defined(_WIN32) || defined(__CYGWIN__)
19 Mods to array_equal() and array_never_equal (new)
20 routine_filepath moved to here.
21 command_line_args uses strings instead of char*
22
23 2017 July gilles-duvert New version of Where() twice as fast as previous
24 ***************************************************************************/
25 // AC 2018-feb
26
27 /***************************************************************************
28 * *
29 * This program is free software; you can redistribute it and/or modify *
30 * it under the terms of the GNU General Public License as published by *
31 * the Free Software Foundation; either version 2 of the License, or *
32 * (at your option) any later version. *
33 * *
34 ***************************************************************************/
35
36 #include "includefirst.hpp"
37
38 #ifndef _WIN32
39 #include <unistd.h>
40 #endif
41
42 // used to defined GDL_TMPDIR: may have trouble on MSwin, help welcome
43 #ifndef _WIN32
44 #include <paths.h>
45 #endif
46
47 #include <limits>
48 #include <string>
49 #include <fstream>
50 //#include <memory>
51 #include <regex.h> // stregex
52
53 #ifdef __APPLE__
54 # include <crt_externs.h>
55 # define environ (*_NSGetEnviron())
56 #endif
57
58 #if defined(__DragonFly__) || defined(__FreeBSD__) || defined(__sun__) || defined(__OpenBSD__)
59 extern "C" char **environ;
60 #endif
61
62 #include "nullgdl.hpp"
63 #include "datatypes.hpp"
64 #include "envt.hpp"
65 #include "dpro.hpp"
66 #include "dinterpreter.hpp"
67 #include "basic_pro.hpp"
68 #include "typedefs.hpp"
69 #include "base64.hpp"
70 #include "objects.hpp"
71 //#include "file.hpp"
72
73
74 #ifdef HAVE_LOCALE_H
75 # include <locale.h>
76 #endif
77
78 /* max regexp error message length */
79 #define MAX_REGEXPERR_LENGTH 80
80
81 #ifdef _MSC_VER
82 #if _MSC_VER < 1800
83 #define std::isfinite _finite
84 #define isnan _isnan
85 #define round(f) floor(f+0.5)
86 #endif
87 #define std::isfinite(x) std::isfinite((double) x)
strncasecmp(const char * s1,const char * s2,size_t n)88 int strncasecmp(const char *s1, const char *s2, size_t n)
89 {
90 if (n == 0)
91 return 0;
92 while (n-- != 0 && tolower(*s1) == tolower(*s2))
93 {
94 if (n == 0 || *s1 == '\0' || *s2 == '\0')
95 break;
96 s1++;
97 s2++;
98 }
99
100 return tolower(*(unsigned char *) s1) - tolower(*(unsigned char *) s2);
101 }
102 #endif
103
104 #ifndef _WIN32
105 #include <sys/utsname.h>
106 #endif
GetObjStruct(BaseGDL * Objptr,EnvT * e)107 static DStructGDL* GetObjStruct( BaseGDL* Objptr, EnvT* e)
108 {
109 if( Objptr == 0 || Objptr->Type() != GDL_OBJ)
110 e->Throw( "Objptr not of type OBJECT. Please report.");
111 if( !Objptr->Scalar())
112 e->Throw( "Objptr must be a scalar. Please report.");
113 DObjGDL* Object = static_cast<DObjGDL*>( Objptr);
114 DObj ID = (*Object)[0];
115 try {
116 return BaseGDL::interpreter->GetObjHeap( ID);
117 }
118 catch( GDLInterpreter::HeapException& hEx)
119 {
120 e->Throw( "Object ID <"+i2s(ID)+"> not found.");
121 }
122 assert(false);
123 return NULL;
124 }
125
126 static bool trace_me(false);
127
128 namespace lib {
129 bool trace_arg();
130 bool gdlarg_present(const char* s);
131 SizeT HASH_count( DStructGDL* oStructGDL);
132 SizeT LIST_count( DStructGDL* oStructGDL);
133
134 // for use in COMMAND_LINE_ARGS()
135 std::vector<std::string> command_line_args;
136
137
138 // using namespace std;
139 using std::isinf;
140 using std::isnan;
141 using namespace antlr;
142
143 DULong SHA256Constants[] = {
144 0x428a2f98,0x71374491,0xb5c0fbcf,0xe9b5dba5,0x3956c25b,0x59f111f1,0x923f82a4,0xab1c5ed5
145 ,0xd807aa98,0x12835b01,0x243185be,0x550c7dc3,0x72be5d74,0x80deb1fe,0x9bdc06a7,0xc19bf174
146 ,0xe49b69c1,0xefbe4786,0x0fc19dc6,0x240ca1cc,0x2de92c6f,0x4a7484aa,0x5cb0a9dc,0x76f988da
147 ,0x983e5152,0xa831c66d,0xb00327c8,0xbf597fc7,0xc6e00bf3,0xd5a79147,0x06ca6351,0x14292967
148 ,0x27b70a85,0x2e1b2138,0x4d2c6dfc,0x53380d13,0x650a7354,0x766a0abb,0x81c2c92e,0x92722c85
149 ,0xa2bfe8a1,0xa81a664b,0xc24b8b70,0xc76c51a3,0xd192e819,0xd6990624,0xf40e3585,0x106aa070
150 ,0x19a4c116,0x1e376c08,0x2748774c,0x34b0bcb5,0x391c0cb3,0x4ed8aa4a,0x5b9cca4f,0x682e6ff3
151 ,0x748f82ee,0x78a5636f,0x84c87814,0x8cc70208,0x90befffa,0xa4506ceb,0xbef9a3f7,0xc67178f2};
152
153 DULong SHAH0[] = {
154 0x6a09e667 // H0_0
155 ,0xbb67ae85
156 ,0x3c6ef372
157 ,0xa54ff53a
158 ,0x510e527f
159 ,0x9b05688c
160 ,0x1f83d9ab
161 ,0x5be0cd19 // H0_7
162 };
163
164
165
166 // assumes all parameters from pOffs till end are dim
arr(EnvT * e,dimension & dim,SizeT pOffs=0)167 void arr( EnvT* e, dimension& dim, SizeT pOffs=0)
168 {
169
170 int nParam=e->NParam()-pOffs;
171
172 if( nParam <= 0)
173 e->Throw( "Incorrect number of arguments.");
174
175 const string BadDims="Array dimensions must be greater than 0.";
176
177
178 if( nParam == 1 ) {
179
180 BaseGDL* par = e->GetParDefined( pOffs);
181
182 SizeT newDim;
183 int ret = par->Scalar2Index( newDim);
184
185 if (ret < 0) throw GDLException(BadDims);
186
187 if( ret > 0) { // single argument
188 if (newDim < 1) throw GDLException(BadDims);
189 dim << newDim;
190 return;
191 }
192 if( ret == 0) { // array argument
193 DLongGDL* ind =
194 static_cast<DLongGDL*>(par->Convert2(GDL_LONG, BaseGDL::COPY));
195 Guard<DLongGDL> ind_guard( ind);
196 //e->Guard( ind);
197
198 for(SizeT i =0; i < par->N_Elements(); ++i){
199 if ((*ind)[i] < 1) throw GDLException(BadDims);
200 dim << (*ind)[i];
201 }
202 return;
203 }
204 e->Throw( "arr: should never arrive here.");
205 return;
206 }
207
208 // max number checked in interpreter
209 SizeT endIx=nParam+pOffs;
210 for( SizeT i=pOffs; i<endIx; i++)
211 {
212 BaseGDL* par=e->GetParDefined( i);
213
214 SizeT newDim;
215 int ret=par->Scalar2Index( newDim);
216 if( ret < 1 || newDim == 0) throw GDLException(BadDims);
217 dim << newDim;
218 }
219 }
220
bytarr(EnvT * e)221 BaseGDL* bytarr( EnvT* e)
222 {
223 dimension dim;
224
225 arr( e, dim);
226 if (dim[0] == 0)
227 throw GDLException( "Array dimensions must be greater than 0");
228
229 if( e->KeywordSet(0)) return new DByteGDL(dim, BaseGDL::NOZERO);
230 return new DByteGDL(dim);
231 }
232
intarr(EnvT * e)233 BaseGDL* intarr( EnvT* e)
234 {
235 dimension dim;
236 // try{
237 arr( e, dim);
238 if (dim[0] == 0)
239 throw GDLException( "Array dimensions must be greater than 0");
240
241 if( e->KeywordSet(0)) return new DIntGDL(dim, BaseGDL::NOZERO);
242 return new DIntGDL(dim);
243 // }
244 // catch( GDLException& ex)
245 // {
246 // e->Throw( "INTARR: "+ex.getMessage());
247 // }
248 }
uintarr(EnvT * e)249 BaseGDL* uintarr( EnvT* e)
250 {
251 dimension dim;
252 // try{
253 arr( e, dim);
254 if (dim[0] == 0)
255 throw GDLException( "Array dimensions must be greater than 0");
256
257 if( e->KeywordSet(0)) return new DUIntGDL(dim, BaseGDL::NOZERO);
258 return new DUIntGDL(dim);
259 // }
260 // catch( GDLException& ex)
261 // {
262 // e->Throw( "UINTARR: "+ex.getMessage());
263 // }
264 }
lonarr(EnvT * e)265 BaseGDL* lonarr( EnvT* e)
266 {
267 dimension dim;
268 // try{
269 arr( e, dim);
270 if (dim[0] == 0)
271 throw GDLException( "Array dimensions must be greater than 0");
272
273 if( e->KeywordSet(0)) return new DLongGDL(dim, BaseGDL::NOZERO);
274 return new DLongGDL(dim);
275 /* }
276 catch( GDLException& ex)
277 {
278 e->Throw( "LONARR: "+ex.getMessage());
279 }*/
280 }
ulonarr(EnvT * e)281 BaseGDL* ulonarr( EnvT* e)
282 {
283 dimension dim;
284 // try{
285 arr( e, dim);
286 if (dim[0] == 0)
287 throw GDLException( "Array dimensions must be greater than 0");
288
289 if( e->KeywordSet(0)) return new DULongGDL(dim, BaseGDL::NOZERO);
290 return new DULongGDL(dim);
291 /* }
292 catch( GDLException& ex)
293 {
294 e->Throw( "ULONARR: "+ex.getMessage());
295 }
296 */
297 }
lon64arr(EnvT * e)298 BaseGDL* lon64arr( EnvT* e)
299 {
300 dimension dim;
301 // try{
302 arr( e, dim);
303 if (dim[0] == 0)
304 throw GDLException( "Array dimensions must be greater than 0");
305
306 if( e->KeywordSet(0)) return new DLong64GDL(dim, BaseGDL::NOZERO);
307 return new DLong64GDL(dim);
308 /* }
309 catch( GDLException& ex)
310 {
311 e->Throw( "LON64ARR: "+ex.getMessage());
312 }*/
313 }
ulon64arr(EnvT * e)314 BaseGDL* ulon64arr( EnvT* e)
315 {
316 dimension dim;
317 // try{
318 arr( e, dim);
319 if (dim[0] == 0)
320 throw GDLException( "Array dimensions must be greater than 0");
321
322 if( e->KeywordSet(0)) return new DULong64GDL(dim, BaseGDL::NOZERO);
323 return new DULong64GDL(dim);
324 /* }
325 catch( GDLException& ex)
326 {
327 e->Throw( "ULON64ARR: "+ex.getMessage());
328 }*/
329 }
fltarr(EnvT * e)330 BaseGDL* fltarr( EnvT* e)
331 {
332 dimension dim;
333 // try{
334 arr( e, dim);
335 if (dim[0] == 0)
336 throw GDLException( "Array dimensions must be greater than 0");
337
338 if( e->KeywordSet(0)) return new DFloatGDL(dim, BaseGDL::NOZERO);
339 return new DFloatGDL(dim);
340 /* }
341 catch( GDLException& ex)
342 {
343 e->Throw( "FLTARR: "+ex.getMessage());
344 }
345 */}
dblarr(EnvT * e)346 BaseGDL* dblarr( EnvT* e)
347 {
348 dimension dim;
349 // try{
350 arr( e, dim);
351 if (dim[0] == 0)
352 throw GDLException( "Array dimensions must be greater than 0");
353
354 if( e->KeywordSet(0)) return new DDoubleGDL(dim, BaseGDL::NOZERO);
355 return new DDoubleGDL(dim);
356 /* }
357 catch( GDLException& ex)
358 {
359 e->Throw( "DBLARR: "+ex.getMessage());
360 }*/
361 }
strarr(EnvT * e)362 BaseGDL* strarr( EnvT* e)
363 {
364 dimension dim;
365 // try{
366 arr( e, dim);
367 if (dim[0] == 0)
368 throw GDLException( "Array dimensions must be greater than 0");
369
370 if( e->KeywordSet(0))
371 e->Throw( "Keyword parameters not allowed in call.");
372 return new DStringGDL(dim);
373 /* }
374 catch( GDLException& ex)
375 {
376 e->Throw( "STRARR: "+ex.getMessage());
377 }
378 */ }
complexarr(EnvT * e)379 BaseGDL* complexarr( EnvT* e)
380 {
381 dimension dim;
382 // try{
383 arr( e, dim);
384 if (dim[0] == 0)
385 throw GDLException( "Array dimensions must be greater than 0");
386
387 if( e->KeywordSet(0)) return new DComplexGDL(dim, BaseGDL::NOZERO);
388 return new DComplexGDL(dim);
389 /*}
390 catch( GDLException& ex)
391 {
392 e->Throw( "COMPLEXARR: "+ex.getMessage());
393 }
394 */ }
dcomplexarr(EnvT * e)395 BaseGDL* dcomplexarr( EnvT* e)
396 {
397 dimension dim;
398 // try{
399 arr( e, dim);
400 if (dim[0] == 0)
401
402 if( e->KeywordSet(0)) return new DComplexDblGDL(dim, BaseGDL::NOZERO);
403 return new DComplexDblGDL(dim);
404 /* }
405 catch( GDLException& ex)
406 {
407 e->Throw( "DCOMPLEXARR: "+ex.getMessage());
408 }
409 */ }
ptrarr(EnvT * e)410 BaseGDL* ptrarr( EnvT* e)
411 {
412 dimension dim;
413 // try{
414 arr( e, dim);
415 if (dim[0] == 0)
416 throw GDLException( "Array dimensions must be greater than 0");
417
418 DPtrGDL* ret;
419
420 if( !e->KeywordSet(0))
421 return new DPtrGDL(dim);
422
423 // ALLOCATE_HEAP
424 ret= new DPtrGDL(dim, BaseGDL::NOZERO);
425
426 SizeT nEl=ret->N_Elements();
427 SizeT sIx=e->NewHeap(nEl, NullGDL::GetSingleInstance());
428 // not a thread pool function #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
429 {
430 // #pragma omp for
431 for( SizeT i=0; i<nEl; i++) (*ret)[i]=sIx+i;
432 }
433 return ret;
434 }
objarr(EnvT * e)435 BaseGDL* objarr( EnvT* e)
436 {
437 dimension dim;
438 // try{
439 arr( e, dim);
440 if (dim[0] == 0)
441 throw GDLException( "Array dimensions must be greater than 0");
442
443 // reference counting if( e->KeywordSet(0)) return new DObjGDL(dim, BaseGDL::NOZERO);
444 return new DObjGDL(dim);
445 }
446
ptr_new(EnvT * e)447 BaseGDL* ptr_new( EnvT* e)
448 {
449 int nParam=e->NParam();
450 if( nParam > 0)
451 {
452 BaseGDL* p= e->GetPar( 0);
453
454 // new ptr from undefined variable is allowed as well
455 // this case was discovered by chance by Leva, July 16, 2014
456 // p=ptr_new(), p=ptr_new(!null), p=ptr_new(undef_var) should work
457
458 if ((p == NULL) || (p->Type() == GDL_UNDEF))
459 {
460 DPtr heapID= e->NewHeap(1, NullGDL::GetSingleInstance()); //same as /ALLOCATE_HEAP
461 return new DPtrGDL( heapID);
462 }
463 static int no_copyIx=e->KeywordIx("NO_COPY");
464 if (e->KeywordSet(no_copyIx)) // NO_COPY
465 {
466 BaseGDL** p= &e->GetPar( 0);
467
468 DPtr heapID= e->NewHeap( 1, *p);
469 *p=NULL;
470 return new DPtrGDL( heapID);
471 }
472 else
473 {
474 BaseGDL* p= e->GetParDefined( 0);
475
476 DPtr heapID= e->NewHeap( 1, p->Dup());
477 return new DPtrGDL( heapID);
478 }
479 }
480 else
481 {
482 if( e->KeywordSet(1)) // ALLOCATE_HEAP
483 {
484 DPtr heapID= e->NewHeap(1, NullGDL::GetSingleInstance()); //allocate a !NULL, not a null ptr!!
485 return new DPtrGDL( heapID);
486 }
487 else
488 {
489 return new DPtrGDL( 0); // null ptr
490 }
491 }
492 }
493
ptr_valid(EnvT * e)494 BaseGDL* ptr_valid(EnvT* e)
495 {
496 int nParam = e->NParam( );
497 static int CASTIx = e->KeywordIx( "CAST" );
498 static int COUNTIx = e->KeywordIx( "COUNT" );
499 static int GET_HEAP_IDENTIFIERIx = e->KeywordIx( "GET_HEAP_IDENTIFIER" );
500
501 if ( e->KeywordPresent( COUNTIx ) )
502 {
503 e->SetKW( COUNTIx, new DLongGDL( e->Interpreter( )->HeapSize( ) ) );
504 }
505
506 if ( nParam == 0 )
507 {
508 return e->Interpreter( )->GetAllHeap( );
509 }
510
511 BaseGDL* p = e->GetPar( 0 );
512 if ( p == NULL )
513 {
514 return new DByteGDL( 0 );
515 }
516
517 DType pType = p->Type( );
518 bool isscalar = p->StrictScalar( );
519
520
521 GDLInterpreter* interpreter = e->Interpreter( );
522
523 //if called with CAST return either a new pointer if arg is a pointer, or a pointer to the heap variable whose arg is an index to.
524 if ( e->KeywordSet( CASTIx ) )
525 {
526 if ( pType == GDL_PTR ) return p->Dup( );
527 //else: only integer or array thereof authorized:
528 DULongGDL* pL = static_cast<DULongGDL*> ( p->Convert2( GDL_ULONG, BaseGDL::COPY ) );
529 Guard<DULongGDL> pL_guard( pL );
530 if ( isscalar )
531 {
532 DULong p0 = ( *pL )[0];
533 if ( interpreter->PtrValid( p0 ) )
534 {
535 interpreter->IncRef( p0 );
536 return new DPtrGDL( p0 );
537 }
538 else return new DPtrGDL( 0 );
539 }
540 else
541 {
542 DPtrGDL* ret = new DPtrGDL( pL->Dim( ) );
543 for ( SizeT i = 0; i < pL->N_Elements( ); ++i )
544 if ( interpreter->PtrValid( ( *pL )[ i] ) )
545 {
546 interpreter->IncRef( ( *pL )[ i] );
547 ( *ret )[ i] = ( *pL )[ i];
548 }
549 return ret;
550 }
551 }
552 //no CAST. If PTR type, return true of false, or heap index if GET_HEAP_IDENTIFIER is used.
553 if ( pType == GDL_PTR )
554 {
555 DPtrGDL* pPtr = static_cast<DPtrGDL*> ( p );
556
557 if ( e->KeywordSet( GET_HEAP_IDENTIFIERIx ) )
558 {
559 DULongGDL* pL = new DULongGDL( p->Dim( ) );
560 Guard<DULongGDL> pL_guard( pL );
561 for ( SizeT i = 0; i < pL->N_Elements( ); ++i ) ( *pL ) [i] = ( *pPtr )[i]; //heap indexes
562 if ( isscalar ) return new DULongGDL( ( *pL )[0] );
563 else
564 {
565 pL_guard.release( );
566 return pL;
567 }
568 }
569 else
570 {
571 if ( isscalar )
572 {
573 return new DByteGDL( interpreter->PtrValid( (*pPtr)[ 0] ));
574 }
575 else
576 {
577 DByteGDL* ret= new DByteGDL( p->Dim( ));
578 for (SizeT i=0; i< ret->N_Elements(); ++i) (*ret)[i]=interpreter->PtrValid( (*pPtr)[ i] );
579 return ret;
580 }
581 }
582 }
583 else
584 { // pType!=GDL_PTR: return false = 0 always.
585 if ( isscalar )
586 {
587 if ( e->KeywordSet( GET_HEAP_IDENTIFIERIx )) return new DULongGDL( 0 ); else return new DByteGDL( 0 );
588 }
589 else
590 {
591 if ( e->KeywordSet( GET_HEAP_IDENTIFIERIx )) return new DULongGDL( p->Dim( ) ); else return new DByteGDL( p->Dim( ) );
592 }
593 }
594 }
595 //
596 // 2018 May 29 G. Jung: Note there is an inordinate separation of scalar and non-scalar treament.
597 // This was my last line of attempt to quash an error, due to an assert
598 // in gdlarray.cpp (line 210) which obj_valid() triggered in Travis tests.
599 // I am now convinced that this error is due to the incorrect hack in GDL
600 // that, for "SizeT nEl = p->N_Elements();" returns instead the count() of the list
601 // so in fact, a list is not a true object.
602 // Merge "legacy_list" branch to remedy this.
603 //
obj_valid(EnvT * e)604 BaseGDL* obj_valid( EnvT* e)
605 {
606 int nParam = e->NParam( );
607 static int CASTIx = e->KeywordIx( "CAST" );
608 static int COUNTIx = e->KeywordIx( "COUNT" );
609 static int GET_HEAP_IDENTIFIERIx = e->KeywordIx( "GET_HEAP_IDENTIFIER" );
610
611 if( e->KeywordPresent( COUNTIx)) // COUNT
612 {
613 e->SetKW( COUNTIx, new DLongGDL( e->Interpreter( )->ObjHeapSize() ) );
614 }
615
616 if ( nParam == 0 )
617 {
618 return e->Interpreter( )->GetAllObjHeap();
619 }
620
621 BaseGDL* p = e->GetPar( 0 );
622 if ( p == NULL )
623 {
624 return new DByteGDL( 0 );
625 }
626
627 DType pType = p->Type( );
628 bool isscalar = p->StrictScalar( );
629
630 GDLInterpreter* interpreter = e->Interpreter( );
631
632 //if called with CAST return either a new pointer if arg is a pointer, or a pointer to the ObjHeap variable whose arg is an index to.
633 if ( e->KeywordSet( CASTIx ) )
634 {
635 if ( pType == GDL_OBJ ) return p->Dup( );
636 //else: only integer or array thereof authorized:
637 DULongGDL* pL = static_cast<DULongGDL*> ( p->Convert2( GDL_ULONG, BaseGDL::COPY ) );
638 Guard<DULongGDL> pL_guard( pL );
639 if ( isscalar ) {
640 DULong p0 = (*pL)[0];
641 if ( interpreter->ObjValid( p0 )) {
642 interpreter->IncRefObj( p0 );
643 return new DObjGDL( p0 );
644 } else return new DObjGDL( 0 );
645 }
646 else
647 {
648 DObjGDL* ret = new DObjGDL( pL->Dim( ) );
649 for ( SizeT i = 0; i < pL->N_Elements( ); ++i )
650 if ( interpreter->ObjValid( ( *pL )[ i] ) ) {
651 interpreter->IncRefObj( ( *pL )[ i] );
652 ( *ret )[ i] = ( *pL )[ i];
653 }
654 return ret;
655 }
656 }
657 //no CAST. If OBJ type, return true of false, or ObjHeap index if GET_HEAP_IDENTIFIER is used.
658 if ( pType == GDL_OBJ )
659 {
660 DObjGDL* pObj = static_cast<DObjGDL*> ( p );
661
662 if ( e->KeywordSet( GET_HEAP_IDENTIFIERIx ) )
663 {
664 DULongGDL* pL = new DULongGDL( p->Dim( ) );
665 Guard<DULongGDL> pL_guard( pL );
666 for ( SizeT i = 0; i < pL->N_Elements( ); ++i ) ( *pL ) [i] = ( *pObj )[i]; //heap indexes
667 if ( isscalar ) return new DULongGDL( ( *pL )[0] );
668 else
669 {
670 pL_guard.release( );
671 return pL;
672 }
673 }
674 else
675 {
676 if ( isscalar )
677 {
678 return new DByteGDL( interpreter->ObjValid( (*pObj)[ 0] ));
679 }
680 else
681 {
682 DByteGDL* ret= new DByteGDL( p->Dim( ));
683 for (SizeT i=0; i< ret->N_Elements(); ++i) (*ret)[i]=interpreter->ObjValid( (*pObj)[ i] );
684 return ret;
685 }
686 }
687 }
688 else
689 { // pType!=GDL_OBJ: return false = 0 always.
690 if ( isscalar )
691 {
692 if ( e->KeywordSet( GET_HEAP_IDENTIFIERIx )) return new DULongGDL( 0 ); else return new DByteGDL( 0 );
693 }
694 else
695 {
696 if ( e->KeywordSet( GET_HEAP_IDENTIFIERIx )) return new DULongGDL( p->Dim( ) ); else return new DByteGDL( p->Dim( ) );
697 }
698 }
699 }
700
701
702 // {
703 // int nParam=e->NParam();
704 // static int CASTIx = e->KeywordIx("CAST");
705 // static int COUNTIx = e->KeywordIx("COUNT");
706 // static int GET_HEAP_IDENTIFIERIx = e->KeywordIx("GET_HEAP_IDENTIFIER");
707 //
708 // if( e->KeywordPresent( COUNTIx)) // COUNT
709 // {
710 // e->SetKW( COUNTIx, new DLongGDL( e->Interpreter()->ObjHeapSize()));
711 // }
712 //
713 // if( nParam == 0)
714 // {
715 // return e->Interpreter()->GetAllObjHeap();
716 // }
717 //
718 // BaseGDL* p = e->GetPar( 0);
719 // if( p == NULL)
720 // {
721 // return new DByteGDL( 0);
722 // }
723 //
724 // DType pType = p->Type();
725 // bool isscalar = p->StrictScalar();
726 // DLongGDL* pL;
727 // Guard<DLongGDL> pL_guard;
728 //
729 // GDLInterpreter* interpreter = e->Interpreter();
730 // if( pType == GDL_OBJ) {
731 // DObjGDL* pObj = static_cast<DObjGDL*>( p);
732 // pL = new DLongGDL( p->Dim());
733 // for( SizeT i=0; i < pL->N_Elements(); ++i) (*pL) [i] = (*pObj)[i];
734 // if( e->KeywordSet( GET_HEAP_IDENTIFIERIx)) {
735 // if(isscalar) return new DLongGDL( (*pL)[0] );
736 // else return pL;
737 // }
738 // }
739 // else { // pType == GDL_OBJ
740 // pL = static_cast<DLongGDL*>(p->Convert2(GDL_LONG,BaseGDL::COPY));
741 // pL_guard.Init( pL);
742 // if( e->KeywordSet( CASTIx)) {
743 // if(isscalar) {
744 // DLong p0 = (*pL)[0];
745 // if( interpreter->ObjValid( p0 )) {
746 // interpreter->IncRefObj( p0);
747 // return new DObjGDL( p0);
748 // } else return new DObjGDL( 0);
749 // }
750 // DObjGDL* ret = new DObjGDL( pL->Dim());
751 // for( SizeT i=0; i < pL->N_Elements(); ++i)
752 // if( interpreter->ObjValid( (*pL)[ i])) {
753 // interpreter->IncRefObj((*pL)[ i]);
754 // (*ret)[ i] = (*pL)[ i];
755 // }
756 // return ret;
757 // }
758 // }
759 //
760 // DByteGDL* ret = new DByteGDL( pL->Dim()); // zero
761 // for( SizeT i=0; i<pL->N_Elements(); ++i)
762 // {
763 // if( interpreter->ObjValid( (*pL)[ i]))
764 // (*ret)[ i] = 1;
765 // }
766 //
767 // if(isscalar) return new DByteGDL( (*ret)[0] );
768 // else return ret;
769 // }
770
obj_new(EnvT * e)771 BaseGDL* obj_new( EnvT* e)
772 {
773 // StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());
774
775 int nParam=e->NParam();
776
777 if( nParam == 0)
778 {
779 return new DObjGDL( 0);
780 }
781
782 DString objName;
783 e->AssureScalarPar<DStringGDL>( 0, objName);
784
785 // this is a struct name -> convert to UPPERCASE
786 objName=StrUpCase(objName);
787 if( objName == "IDL_OBJECT")
788 objName = GDL_OBJECT_NAME; // replacement also done in GDLParser
789 else if( objName == "IDL_CONTAINER" )
790 objName = GDL_CONTAINER_NAME;
791 DStructDesc* objDesc=e->Interpreter()->GetStruct( objName, e->CallingNode());
792
793 DStructGDL* objStruct= new DStructGDL( objDesc, dimension(1));
794
795 DObj objID= e->NewObjHeap( 1, objStruct); // owns objStruct
796
797 DObjGDL* newObj = new DObjGDL( objID); // the object
798
799 try {
800 // call INIT function
801 DFun* objINIT= objDesc->GetFun( "INIT");
802 if( objINIT != NULL)
803 {
804 StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());
805
806 // morph to obj environment and push it onto the stack again
807 e->PushNewEnvUD( objINIT, 1, &newObj);
808
809 BaseGDL* res=e->Interpreter()->call_fun( objINIT->GetTree());
810
811 if( res == NULL || (!res->Scalar()) || res->False())
812 {
813 GDLDelete(res);
814 return new DObjGDL( 0);
815 }
816 GDLDelete(res);
817 }
818 } catch(...) {
819 e->FreeObjHeap( objID); // newObj might be changed
820 GDLDelete(newObj);
821 throw;
822 }
823
824 return newObj;
825 }
826
heap_refcount(EnvT * e)827 BaseGDL* heap_refcount( EnvT* e)
828 {
829 static int DISABLEIx = e->KeywordIx("DISABLE");
830 static int ENABLEIx = e->KeywordIx("ENABLE");
831 static int IS_ENABLEDIx = e->KeywordIx("IS_ENABLED");
832 // trace_me = trace_arg();
833 int nParam=e->NParam();
834
835 GDLInterpreter* interpreter = e->Interpreter();
836
837 if( nParam == 0) {
838 if( e->KeywordSet(DISABLEIx)) {
839 EnableGC(false);
840 }
841 else if( e->KeywordSet(ENABLEIx)) {
842 EnableGC(true);
843 interpreter->EnableAllGC();
844 }
845 if(e->KeywordPresent(IS_ENABLEDIx))
846 e->SetKW( IS_ENABLEDIx,
847 new DByteGDL( IsEnabledGC()) );
848 return new DIntGDL( 0);
849 }
850
851 BaseGDL* p = e->GetPar( 0);
852 if( p == NULL)
853 {
854 return new DIntGDL( 0);
855 }
856
857 DIntGDL* ret = new DIntGDL(p->Dim());
858 Guard<DIntGDL> ret_guard(ret);
859 DType pType = p->Type();
860 SizeT nEl = p->N_Elements();
861 if(pType == GDL_OBJ) {
862 DObjGDL* pObj = static_cast<DObjGDL*>( p);
863 for( SizeT i=0; i<nEl; ++i)
864 (*ret)[ i] = interpreter->RefCountHeapObj( (*pObj)[ i]);
865 if( e->KeywordSet(DISABLEIx) or
866 e->KeywordSet(ENABLEIx) ) {
867 bool set = e->KeywordSet(ENABLEIx) ? true: false;
868 interpreter->EnableGCObj( pObj, set);
869 }
870 }
871 else {
872 if( pType == GDL_PTR) {
873
874 DPtrGDL* pPtr = static_cast<DPtrGDL*>( p);
875 for( SizeT i=0; i<nEl; ++i)
876 (*ret)[ i] = interpreter->RefCountHeap( (*pPtr)[ i]);
877 if( e->KeywordSet(DISABLEIx) or
878 e->KeywordSet(ENABLEIx) ) {
879 bool set = e->KeywordSet(ENABLEIx) ? true: false;
880 // if(trace_me) cout <<" GC set? "<<set<<endl;
881 interpreter->EnableGC( pPtr, set);
882 }
883 } else {
884 DLongGDL* pL;
885 Guard<DLongGDL> pL_guard(pL);
886 if( pType != GDL_LONG)
887 {
888 pL = static_cast<DLongGDL*>(p->Convert2(GDL_LONG,BaseGDL::COPY));
889 pL_guard.Init( pL);
890 }
891 else
892 {
893 pL = static_cast<DLongGDL*>(p);
894 }
895 for( SizeT i=0; i<nEl; ++i)
896 (*ret)[ i] = interpreter->RefCountHeap( (*pL)[ i]);
897 }
898 }
899 // #if 1
900 if(e->KeywordPresent(IS_ENABLEDIx)) {
901 DByteGDL* enabled;
902 // if(trace_me)
903 // cout << " heap_refcount( prm, KeywordPresent(IS_ENABLEDIx)) "<< endl;
904 if(pType == GDL_OBJ) {
905 enabled = interpreter->IsEnabledGCObj(static_cast<DObjGDL*>( p));
906 }
907 else {
908 if( pType == GDL_PTR) {
909 enabled = interpreter->IsEnabledGC(static_cast<DPtrGDL*>( p));
910 } else {
911 // if(trace_me)
912 // cout << " heap_refcount(prm=lonarr, KeywordPresent(IS_ENABLEDIx) "<< endl;
913 DLongGDL* pL;
914 Guard<DLongGDL> pL_guard(pL);
915 if( pType != GDL_LONG)
916 {
917 pL = static_cast<DLongGDL*>(p->Convert2(GDL_LONG,BaseGDL::COPY));
918 pL_guard.Init( pL);
919 }
920 else
921 {
922 pL = static_cast<DLongGDL*>(p);
923 }
924 DPtrGDL* ptr = new DPtrGDL( p->Dim());
925 Guard<DPtrGDL> ptr_guard(ptr);
926 for( SizeT i=0; i<nEl; ++i)
927 (*ptr)[ i] = (*pL)[ i];
928
929 enabled = interpreter->IsEnabledGC(ptr);
930 }
931 }
932 e->SetKW( IS_ENABLEDIx, enabled);
933 }
934 // #endif
935 return ret_guard.release();
936 }
937
bindgen(EnvT * e)938 BaseGDL* bindgen( EnvT* e)
939 {
940 dimension dim;
941 DDouble off = 0, inc = 1;
942 // try{
943 arr( e, dim);
944 if (dim[0] == 0)
945 throw GDLException( "Array dimensions must be greater than 0");
946
947 e->AssureDoubleScalarKWIfPresent("START", off);
948 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
949 return new DByteGDL(dim, BaseGDL::INDGEN, off, inc);
950 /* }
951 catch( GDLException& ex)
952 {
953 e->Throw( "BINDGEN: "+ex.getMessage());
954 }
955 */ }
indgen(EnvT * e)956 BaseGDL* indgen( EnvT* e)
957 {
958 dimension dim;
959 DDouble off = 0, inc = 1;
960 DType type = GDL_INT;
961
962 static int kwIx1 = e->KeywordIx("BYTE");
963 if (e->KeywordSet(kwIx1)){ type = GDL_BYTE; }
964
965 static int kwIx2 = e->KeywordIx("COMPLEX");
966 if (e->KeywordSet(kwIx2)){ type = GDL_COMPLEX; }
967
968 static int kwIx3 = e->KeywordIx("DCOMPLEX");
969 if (e->KeywordSet(kwIx3)){ type = GDL_COMPLEXDBL; }
970
971 static int kwIx4 = e->KeywordIx("DOUBLE");
972 if (e->KeywordSet(kwIx4)){ type = GDL_DOUBLE; }
973
974 static int kwIx5 = e->KeywordIx("FLOAT");
975 if (e->KeywordSet(kwIx5)){ type = GDL_FLOAT; }
976
977 static int kwIx6 = e->KeywordIx("L64");
978 if (e->KeywordSet(kwIx6)){ type = GDL_LONG64; }
979
980 static int kwIx7 = e->KeywordIx("LONG");
981 if (e->KeywordSet(kwIx7)){ type = GDL_LONG; }
982
983 static int kwIx8 = e->KeywordIx("STRING");
984 if (e->KeywordSet(kwIx8)){ type = GDL_STRING; }
985
986 static int kwIx9 = e->KeywordIx("UINT");
987 if (e->KeywordSet(kwIx9)){ type = GDL_UINT; }
988
989 static int kwIx10 = e->KeywordIx("UL64");
990 if (e->KeywordSet(kwIx10)){ type = GDL_ULONG64; }
991
992 static int kwIx11 = e->KeywordIx("ULONG");
993 if (e->KeywordSet(kwIx11)){ type = GDL_ULONG; }
994
995 /*try
996 {*/
997 // Seeing if the user passed in a TYPE code
998 static int kwIx12 = e->KeywordIx("TYPE");
999 if ( e->KeywordPresent(kwIx12)){
1000 DLong temp_long;
1001 e->AssureLongScalarKW(kwIx12, temp_long);
1002 type = static_cast<DType>(temp_long);
1003 }
1004
1005 arr(e, dim);
1006 if (dim[0] == 0)
1007 throw GDLException( "Array dimensions must be greater than 0");
1008
1009 e->AssureDoubleScalarKWIfPresent("START", off);
1010 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1011
1012 switch(type)
1013 {
1014 case GDL_INT: return new DIntGDL(dim, BaseGDL::INDGEN, off, inc);
1015 case GDL_BYTE: return new DByteGDL(dim, BaseGDL::INDGEN, off, inc);
1016 case GDL_COMPLEX: return new DComplexGDL(dim, BaseGDL::INDGEN, off, inc);
1017 case GDL_COMPLEXDBL: return new DComplexDblGDL(dim, BaseGDL::INDGEN, off, inc);
1018 case GDL_DOUBLE: return new DDoubleGDL(dim, BaseGDL::INDGEN, off, inc);
1019 case GDL_FLOAT: return new DFloatGDL(dim, BaseGDL::INDGEN, off, inc);
1020 case GDL_LONG64: return new DLong64GDL(dim, BaseGDL::INDGEN, off, inc);
1021 case GDL_LONG: return new DLongGDL(dim, BaseGDL::INDGEN, off, inc);
1022 case GDL_STRING: {
1023 DULongGDL* iGen = new DULongGDL(dim, BaseGDL::INDGEN, off, inc);
1024 return iGen->Convert2(GDL_STRING);
1025 }
1026 case GDL_UINT: return new DUIntGDL(dim, BaseGDL::INDGEN, off, inc);
1027 case GDL_ULONG64: return new DULong64GDL(dim, BaseGDL::INDGEN, off, inc);
1028 case GDL_ULONG: return new DULongGDL(dim, BaseGDL::INDGEN, off, inc);
1029 default:
1030 e->Throw( "Invalid type code specified.");
1031 break;
1032 }
1033 /* }
1034 catch( GDLException& ex)
1035 {
1036 e->Throw( ex.getMessage());
1037 }*/
1038 assert(false);
1039 return NULL;
1040 }
1041
uindgen(EnvT * e)1042 BaseGDL* uindgen( EnvT* e)
1043 {
1044 dimension dim;
1045 DDouble off = 0, inc = 1;
1046 // try{
1047 arr( e, dim);
1048 if (dim[0] == 0)
1049 throw GDLException( "Array dimensions must be greater than 0");
1050
1051 e->AssureDoubleScalarKWIfPresent("START", off);
1052 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1053 return new DUIntGDL(dim, BaseGDL::INDGEN, off, inc);
1054 /* }
1055 catch( GDLException& ex)
1056 {
1057 e->Throw( "UINDGEN: "+ex.getMessage());
1058 }
1059 */ }
sindgen(EnvT * e)1060 BaseGDL* sindgen( EnvT* e)
1061 {
1062 dimension dim;
1063 DDouble off = 0, inc = 1;
1064 // try{
1065 arr( e, dim);
1066 if (dim[0] == 0)
1067 throw GDLException( "Array dimensions must be greater than 0");
1068
1069 e->AssureDoubleScalarKWIfPresent("START", off);
1070 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1071 DULongGDL* iGen = new DULongGDL(dim, BaseGDL::INDGEN, off, inc);
1072 return iGen->Convert2( GDL_STRING);
1073 /* }
1074 catch( GDLException& ex)
1075 {
1076 e->Throw( "SINDGEN: "+ex.getMessage());
1077 }*/
1078 }
lindgen(EnvT * e)1079 BaseGDL* lindgen( EnvT* e)
1080 {
1081 dimension dim;
1082 DDouble off = 0, inc = 1;
1083 // try{
1084 arr( e, dim);
1085 if (dim[0] == 0)
1086 throw GDLException( "Array dimensions must be greater than 0");
1087
1088 e->AssureDoubleScalarKWIfPresent("START", off);
1089 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1090 return new DLongGDL(dim, BaseGDL::INDGEN, off, inc);
1091 /* }
1092 catch( GDLException& ex)
1093 {
1094 e->Throw( "LINDGEN: "+ex.getMessage());
1095 }*/
1096 }
ulindgen(EnvT * e)1097 BaseGDL* ulindgen( EnvT* e)
1098 {
1099 dimension dim;
1100 DDouble off = 0, inc = 1;
1101 // try{
1102 arr( e, dim);
1103 if (dim[0] == 0)
1104 throw GDLException( "Array dimensions must be greater than 0");
1105
1106 e->AssureDoubleScalarKWIfPresent("START", off);
1107 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1108 return new DULongGDL(dim, BaseGDL::INDGEN, off, inc);
1109 /* }
1110 catch( GDLException& ex)
1111 {
1112 e->Throw( "ULINDGEN: "+ex.getMessage());
1113 }*/
1114 }
l64indgen(EnvT * e)1115 BaseGDL* l64indgen( EnvT* e)
1116 {
1117 dimension dim;
1118 DDouble off = 0, inc = 1;
1119 // try{
1120 arr( e, dim);
1121 if (dim[0] == 0)
1122 throw GDLException( "Array dimensions must be greater than 0");
1123
1124 e->AssureDoubleScalarKWIfPresent("START", off);
1125 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1126 return new DLong64GDL(dim, BaseGDL::INDGEN, off, inc);
1127 /* }
1128 catch( GDLException& ex)
1129 {
1130 e->Throw( "L64INDGEN: "+ex.getMessage());
1131 }*/
1132 }
ul64indgen(EnvT * e)1133 BaseGDL* ul64indgen( EnvT* e)
1134 {
1135 dimension dim;
1136 DDouble off = 0, inc = 1;
1137 // try{
1138 arr( e, dim);
1139 if (dim[0] == 0)
1140 throw GDLException( "Array dimensions must be greater than 0");
1141
1142 e->AssureDoubleScalarKWIfPresent("START", off);
1143 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1144 return new DULong64GDL(dim, BaseGDL::INDGEN, off, inc);
1145 /* }
1146 catch( GDLException& ex)
1147 {
1148 e->Throw( "UL64INDGEN: "+ex.getMessage());
1149 }
1150 */ }
findgen(EnvT * e)1151 BaseGDL* findgen( EnvT* e)
1152 {
1153 dimension dim;
1154 DDouble off = 0, inc = 1;
1155 // try{
1156 arr( e, dim);
1157 if (dim[0] == 0)
1158 throw GDLException( "Array dimensions must be greater than 0");
1159
1160 e->AssureDoubleScalarKWIfPresent("START", off);
1161 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1162 return new DFloatGDL(dim, BaseGDL::INDGEN, off, inc);
1163 /* }
1164 catch( GDLException& ex)
1165 {
1166 e->Throw( "FINDGEN: "+ex.getMessage());
1167 }*/
1168 }
dindgen(EnvT * e)1169 BaseGDL* dindgen( EnvT* e)
1170 {
1171 dimension dim;
1172 DDouble off = 0, inc = 1;
1173 // try{
1174 arr( e, dim);
1175 if (dim[0] == 0)
1176 throw GDLException( "Array dimensions must be greater than 0");
1177
1178 e->AssureDoubleScalarKWIfPresent("START", off);
1179 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1180 return new DDoubleGDL(dim, BaseGDL::INDGEN, off, inc);
1181 /* }
1182 catch( GDLException& ex)
1183 {
1184 e->Throw( "DINDGEN: "+ex.getMessage());
1185 }*/
1186 }
cindgen(EnvT * e)1187 BaseGDL* cindgen( EnvT* e)
1188 {
1189 dimension dim;
1190 DDouble off = 0, inc = 1;
1191 // try{
1192 arr( e, dim);
1193 if (dim[0] == 0)
1194 throw GDLException( "Array dimensions must be greater than 0");
1195
1196 e->AssureDoubleScalarKWIfPresent("START", off);
1197 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1198 return new DComplexGDL(dim, BaseGDL::INDGEN, off, inc);
1199 /* }
1200 catch( GDLException& ex)
1201 {
1202 e->Throw( "CINDGEN: "+ex.getMessage());
1203 }*/
1204 }
dcindgen(EnvT * e)1205 BaseGDL* dcindgen( EnvT* e)
1206 {
1207 dimension dim;
1208 DDouble off = 0, inc = 1;
1209 // try{
1210 arr( e, dim);
1211 if (dim[0] == 0)
1212 throw GDLException( "Array dimensions must be greater than 0");
1213
1214 e->AssureDoubleScalarKWIfPresent("START", off);
1215 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc);
1216 return new DComplexDblGDL(dim, BaseGDL::INDGEN, off, inc);
1217 /* }
1218 catch( GDLException& ex)
1219 {
1220 e->Throw( "DCINDGEN: "+ex.getMessage());
1221 }
1222 */ }
1223
1224 // only called from CALL_FUNCTION
1225 // otherwise done directly in FCALL_LIB_N_ELEMENTSNode::Eval();
1226 // (but must be defined anyway for LibInit() for correct parametrization)
1227 // N_ELEMENTS is special because on error it just returns 0L
1228 // (the error is just caught and dropped)
n_elements(EnvT * e)1229 BaseGDL* n_elements( EnvT* e)
1230 {
1231 SizeT nParam=e->NParam(1);
1232
1233 BaseGDL* p0=e->GetPar( 0);
1234
1235 if( p0 == NULL)
1236 return new DLongGDL( 0);
1237 if( p0->IsAssoc())
1238 return new DLongGDL( 1);
1239 if(p0->Type() == GDL_OBJ)
1240 {
1241 DStructGDL* s = GetObjStruct(p0, e);
1242 if( s->Desc()->IsParent("LIST"))
1243 return new DLongGDL( LIST_count(s));
1244 else
1245 if( s->Desc()->IsParent("HASH"))
1246 return new DLongGDL( HASH_count(s));
1247 }
1248 if (p0->N_Elements() > 2147483647UL)
1249 return new DLong64GDL( p0->N_Elements());
1250 else
1251 return new DLongGDL( p0->N_Elements());
1252 }
1253
1254 // GD Rewrote complex_fun_template_twopar for gain speed > 10.
1255 // compiler optimization, including openmp inner loops, depends terribly on the knowledge at the compilation time
1256 // of the exact nature of every value --- typenames do not help if they do not quickly resolve to known PODs.
1257 // the following construction has speeds on par with IDL's C . Note the test to avoid completely the openmp loop,
1258 // which seems to gain some time (?) and the use of auto and decltype() in std::complex.
1259 template< typename TypOutGDL, typename TypInGDL>
complex_fun_template_twopar(EnvT * e)1260 BaseGDL* complex_fun_template_twopar(EnvT* e) {
1261 TypInGDL* re=e->GetParAs<TypInGDL>(0);
1262 TypInGDL* im=e->GetParAs<TypInGDL>(1);
1263 auto t=(*re)[0]; //a Float or Double
1264 if (re->Rank() == 0) {
1265 TypOutGDL* res = new TypOutGDL(im->Dim(), BaseGDL::NOZERO);
1266 SizeT nE = im->N_Elements();
1267 bool parallelize = (CpuTPOOL_NTHREADS > 1 && nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE));
1268 if (parallelize) {
1269 SizeT i;
1270 #pragma omp parallel for private(i)
1271 for (i = 0; i < nE; ++i) (*res)[i] = std::complex<decltype(t)>((*re)[0], (*im)[i]);
1272 } else
1273 for (SizeT i = 0; i < nE; i++) (*res)[i] = std::complex<decltype(t)>((*re)[0], (*im)[i]);
1274 return res;
1275 } else if (im->Rank() == 0) {
1276 TypOutGDL* res = new TypOutGDL(re->Dim(), BaseGDL::NOZERO);
1277 SizeT nE = re->N_Elements();
1278 bool parallelize = (CpuTPOOL_NTHREADS > 1 && nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE));
1279 if (parallelize) {
1280 SizeT i;
1281 #pragma omp parallel for private(i)
1282 for (i = 0; i < nE; ++i) (*res)[i] = std::complex<decltype(t)>((*re)[i], (*im)[0]);
1283 } else
1284 for (SizeT i = 0; i < nE; i++) (*res)[i] = std::complex<decltype(t)>((*re)[i], (*im)[0]);
1285 return res;
1286 } else if (re->N_Elements() >= im->N_Elements()) {
1287 TypOutGDL* res = new TypOutGDL(im->Dim(), BaseGDL::NOZERO);
1288 SizeT nE = im->N_Elements();
1289 bool parallelize = (CpuTPOOL_NTHREADS > 1 && nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE));
1290 if (parallelize) {
1291 SizeT i;
1292 #pragma omp parallel for private(i)
1293 for (i = 0; i < nE; ++i) (*res)[i] = std::complex<decltype(t)>((*re)[i], (*im)[i]);
1294 } else
1295 for (SizeT i = 0; i < nE; i++) (*res)[i] = std::complex<decltype(t)>((*re)[i], (*im)[i]);
1296 return res;
1297 } else {
1298 TypOutGDL* res = new TypOutGDL(re->Dim(), BaseGDL::NOZERO);
1299 SizeT nE = re->N_Elements();
1300 bool parallelize = (CpuTPOOL_NTHREADS > 1 && nE >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nE));
1301 if (parallelize) {
1302 SizeT i;
1303 #pragma omp parallel for private(i)
1304 for (i = 0; i < nE; ++i) (*res)[i] = std::complex<decltype(t)>((*re)[i], (*im)[i]);
1305 } else
1306 for (SizeT i = 0; i < nE; i++) (*res)[i] = std::complex<decltype(t)>((*re)[i], (*im)[i]);
1307 return res;
1308 }
1309 }
1310
1311 template< class TargetClass>
type_fun(EnvT * e)1312 BaseGDL* type_fun(EnvT* e) { //nParam > 1
1313 SizeT nParam = e->NParam(1);
1314 BaseGDL* p0 = e->GetNumericParDefined(0);
1315
1316 // GDL_BYTE( expr, offs, dim1,..,dim8)
1317 DLong offs;
1318 e->AssureLongScalarPar(1, offs);
1319
1320 dimension dim;
1321
1322 if (nParam > 2) arr(e, dim, 2);
1323
1324 TargetClass* res = new TargetClass(dim, BaseGDL::NOZERO);
1325
1326 SizeT nByteCreate = res->NBytes(); // net size of new data
1327
1328 SizeT nByteSource = p0->NBytes(); // net size of src
1329
1330 if (offs < 0 || (offs + nByteCreate) > nByteSource) {
1331 GDLDelete(res);
1332 e->Throw("Specified offset to"
1333 " expression is out of range: " + e->GetParString(0));
1334 }
1335
1336 //*** POSSIBLE ERROR because of alignment here -- probably no?
1337 void* srcAddr = static_cast<void*> (static_cast<char*> (p0->DataAddr()) +
1338 offs);
1339 void* dstAddr = static_cast<void*> (&(*res)[0]);
1340 memcpy(dstAddr, srcAddr, nByteCreate);
1341
1342 return res;
1343 }
1344
1345 template< class TargetClass>
type_fun_single(EnvT * e)1346 BaseGDL* type_fun_single(EnvT* e) { //nParam=1
1347 BaseGDL* p0 = e->GetParDefined(0);
1348
1349 assert(dynamic_cast<EnvUDT*> (e->Caller()) != NULL);
1350
1351 // type_fun( expr) just convert
1352 if (static_cast<EnvUDT*> (e->Caller())->GetIOError() != NULL)
1353 return p0->Convert2(TargetClass::t,
1354 BaseGDL::COPY_THROWIOERROR);
1355 // SA: see tracker item no. 3151760
1356 else if (TargetClass::t == p0->Type() && e->GlobalPar(0))
1357 // HERE THE INPUT VARIABLE IS RETURNED
1358 {
1359 e->SetPtrToReturnValue(&e->GetPar(0));
1360 return p0;
1361 } else
1362 return p0->Convert2(TargetClass::t, BaseGDL::COPY);
1363 throw;
1364 }
1365
byte_fun(EnvT * e)1366 BaseGDL* byte_fun( EnvT* e)
1367 {
1368 if (e->NParam()==1) return type_fun_single<DByteGDL>( e);
1369 return type_fun<DByteGDL>( e);
1370 }
int_fun(EnvT * e)1371 BaseGDL* int_fun( EnvT* e) //not registered, use FIX instead.
1372 {
1373 if (e->NParam()==1) return type_fun_single<DIntGDL>( e);
1374 return type_fun<DIntGDL>( e);
1375 }
uint_fun(EnvT * e)1376 BaseGDL* uint_fun( EnvT* e)
1377 {
1378 if (e->NParam()==1) return type_fun_single<DUIntGDL>( e);
1379 return type_fun<DUIntGDL>( e);
1380 }
long_fun(EnvT * e)1381 BaseGDL* long_fun( EnvT* e)
1382 {
1383 if (e->NParam()==1) return type_fun_single<DLongGDL>( e);
1384 return type_fun<DLongGDL>( e);
1385 }
ulong_fun(EnvT * e)1386 BaseGDL* ulong_fun( EnvT* e)
1387 {
1388 if (e->NParam()==1) return type_fun_single<DULongGDL>( e);
1389 return type_fun<DULongGDL>( e);
1390 }
long64_fun(EnvT * e)1391 BaseGDL* long64_fun( EnvT* e)
1392 {
1393 if (e->NParam()==1) return type_fun_single<DLong64GDL>( e);
1394 return type_fun<DLong64GDL>( e);
1395 }
ulong64_fun(EnvT * e)1396 BaseGDL* ulong64_fun( EnvT* e)
1397 {
1398 if (e->NParam()==1) return type_fun_single<DULong64GDL>( e);
1399 return type_fun<DULong64GDL>( e);
1400 }
float_fun(EnvT * e)1401 BaseGDL* float_fun( EnvT* e)
1402 {
1403 if (e->NParam()==1) return type_fun_single<DFloatGDL>( e);
1404 return type_fun<DFloatGDL>( e);
1405 }
double_fun(EnvT * e)1406 BaseGDL* double_fun( EnvT* e)
1407 {
1408 if (e->NParam()==1) return type_fun_single<DDoubleGDL>( e);
1409 return type_fun<DDoubleGDL>( e);
1410 }
1411
complex_fun(EnvT * e)1412 BaseGDL* complex_fun(EnvT* e) {
1413 SizeT nParam = e->NParam(1);
1414 static int doubleIx = e->KeywordIx("DOUBLE");
1415 bool noDouble=(!e->KeywordSet(doubleIx));
1416 if (noDouble) {
1417 if (nParam==1) return type_fun_single<DComplexGDL>( e);
1418 if (nParam == 2) return complex_fun_template_twopar< DComplexGDL, DFloatGDL>(e);
1419 return type_fun<DComplexGDL>( e);
1420 } else {
1421 if (nParam==1) return type_fun_single<DComplexDblGDL>( e);
1422 if (nParam == 2) return complex_fun_template_twopar< DComplexDblGDL, DDoubleGDL>(e);
1423 return type_fun<DComplexDblGDL>( e);
1424 }
1425 }
1426
dcomplex_fun(EnvT * e)1427 BaseGDL* dcomplex_fun(EnvT* e) {
1428 SizeT nParam = e->NParam(1);
1429 if (nParam==1) return type_fun_single<DComplexDblGDL>( e);
1430 if (nParam == 2) return complex_fun_template_twopar< DComplexDblGDL, DDoubleGDL>(e);
1431 return type_fun<DComplexDblGDL>(e);
1432 }
1433 // STRING function behaves different
1434
string_fun(EnvT * e)1435 BaseGDL* string_fun(EnvT* e)
1436 {
1437 SizeT nParam = e->NParam();
1438
1439 if (nParam == 0)
1440 e->Throw("Incorrect number of arguments.");
1441
1442 // AC 2016/02/12 we check now here if params are defined to avoid future problems
1443 // print, string(kk, 12, ee) said "ee" undefined because of VMS hack (should say kk undefined before !)
1444 // print, string(kk, 12, ee, format='()') did not complains
1445 //
1446 for (SizeT i = 0; i < nParam; ++i)
1447 BaseGDL * p = e->GetParDefined(i);
1448 static int printKeyIx = e->KeywordIx("PRINT");
1449 bool printKey = e->KeywordSet(printKeyIx);
1450 int parOffset = 0;
1451
1452 // SA: handling special VMS-compatibility syntax, e.g.: string(1,'$(F)')
1453 // (if nor FORMAT neither PRINT defined, >1 parameter, last param is scalar string
1454 // which begins with "$(" or "(" but is not "()" then last param [minus "$"] is treated as FORMAT)
1455 bool vmshack = false;
1456 if (!printKey && (e->GetKW(0) == NULL) && nParam > 1) {
1457 vmshack = true;
1458 BaseGDL* par = e->GetParDefined(nParam - 1);
1459 if (par->Type() == GDL_STRING && par->Scalar()) {
1460 int dollar = (*static_cast<DStringGDL*> (par))[0].compare(0, 2, "$(");
1461 if (dollar == 0 || ((*static_cast<DStringGDL*> (par))[0].compare(0, 1, "(") == 0 && (*static_cast<DStringGDL*> (par))[0] != "()")) {
1462 e->SetKeyword("FORMAT", new DStringGDL(
1463 (*static_cast<DStringGDL*> (par))[0].c_str() + (dollar == 0 ? 1 : 0)
1464 ));
1465 }
1466 }
1467 }
1468
1469 static int formatIx = e->KeywordIx("FORMAT");
1470 BaseGDL* format_kw = e->GetKW(formatIx);
1471 bool formatKey = format_kw != NULL;
1472
1473 if (formatKey && format_kw->Type() == GDL_STRING && (*static_cast<DStringGDL*> (format_kw))[0] == "") formatKey = false;
1474
1475 if (printKey || formatKey) // PRINT or FORMAT
1476 {
1477 stringstream os;
1478
1479 SizeT width = 0;
1480 if (printKey) // otherwise: FORMAT -> width is ignored
1481 {
1482 // for /PRINT always a terminal width of 80 is assumed
1483 width = 80; //TermWidth();
1484 }
1485
1486 if (vmshack) {
1487 parOffset = 1;
1488 e->ShiftParNumbering(1);
1489 }
1490 print_os(&os, e, parOffset, width);
1491 if (vmshack) {
1492 e->ShiftParNumbering(-1);
1493 }
1494
1495 vector<DString> buf;
1496 while (os.good()) {
1497 string line;
1498 getline(os, line);
1499 if (!line.empty()) buf.push_back(line); //should save the day for the formats with '$' at end.
1500 }
1501
1502 SizeT bufSize = buf.size();
1503 if (bufSize == 0) return new DStringGDL("");
1504
1505 if (bufSize > 1) {
1506 DStringGDL* retVal =
1507 new DStringGDL(dimension(bufSize), BaseGDL::NOZERO);
1508
1509 for (SizeT i = 0; i < bufSize; ++i)
1510 (*retVal)[ i] = buf[ i];
1511
1512 return retVal;
1513 } else
1514 return new DStringGDL(buf[0]);
1515 } else {
1516 if (nParam == 1) // nParam == 1 -> conversion
1517 {
1518 BaseGDL* p0 = e->GetParDefined(0);
1519 // SA: see tracker item no. 3151760
1520
1521 // HERE INPUT VARIABLE IS RETURNED
1522 if (p0->Type() == GDL_STRING && e->GlobalPar(0)) {
1523 e->SetPtrToReturnValue(&e->GetPar(0));
1524 return p0;
1525 }
1526 return p0->Convert2(GDL_STRING, BaseGDL::COPY);
1527 } else // concatenation
1528 {
1529 DString s;
1530 for (SizeT i = 0; i < nParam; ++i) {
1531 BaseGDL* p = e->GetParDefined(i);
1532 DStringGDL* sP = static_cast<DStringGDL*>
1533 (p->Convert2(GDL_STRING,
1534 BaseGDL::COPY_BYTE_AS_INT));
1535
1536 SizeT nEl = sP->N_Elements();
1537 for (SizeT e = 0; e < nEl; ++e)
1538 s += (*sP)[ e];
1539 GDLDelete(sP);
1540 }
1541 // IDL here breaks the string into tty-width substrings
1542 return new DStringGDL(s);
1543 }
1544 }
1545 }
1546
fix_fun(EnvT * e)1547 BaseGDL* fix_fun( EnvT* e)
1548 {
1549 SizeT np=e->NParam(1);
1550
1551 DIntGDL* type = e->IfDefGetKWAs<DIntGDL>(0); //"TYPE" keyword
1552
1553 int typ=0;
1554 if (type != NULL) { //see IDL's behaviour.
1555 typ = (*type)[0];
1556 if (typ > 15) typ=0;
1557 if (typ < 0) typ=0;
1558 }
1559 if (typ > 0) {
1560 if (typ == GDL_INT) return int_fun(e);
1561 if (typ == GDL_UINT) return uint_fun(e);
1562 if (typ == GDL_LONG) return long_fun(e);
1563 if (typ == GDL_ULONG) return ulong_fun(e);
1564 if (typ == GDL_LONG64) return long64_fun(e);
1565 if (typ == GDL_ULONG64) return ulong64_fun(e);
1566 if (typ == GDL_FLOAT) return float_fun(e);
1567 if (typ == GDL_DOUBLE) return double_fun(e);
1568 if (typ == GDL_COMPLEX) { //avoid problem with unexisting keyword "DOUBLE" in FIX's list of kws.
1569 if (np == 1) return type_fun_single<DComplexGDL>(e);
1570 return type_fun<DComplexGDL>(e);
1571 }
1572 if (typ == GDL_COMPLEXDBL) return dcomplex_fun(e);
1573 // 2 cases where PRINT has to be taken into account
1574 if (typ == GDL_BYTE) {
1575 static int printIx = e->KeywordIx("PRINT");
1576 if (e->KeywordSet(printIx) && e->GetPar(0)->Type() == GDL_STRING) {
1577 DLong64GDL* temp=static_cast<DLong64GDL*>(e->GetPar(0)->Convert2(GDL_LONG64,BaseGDL::COPY));
1578 SizeT nEl=temp->N_Elements();
1579 DByteGDL* ret=new DByteGDL(dimension(nEl));
1580 for (SizeT i=0; i< nEl; ++i) {
1581 (*ret)[i]=(*temp)[i];
1582 }
1583 (static_cast<BaseGDL*>(ret))->SetDim(e->GetPar(0)->Dim());
1584 GDLDelete(temp);
1585 return ret;
1586 } else
1587 return byte_fun(e);
1588 }
1589 if(typ == GDL_STRUCT) e->Throw("Unable to convert variable to type struct.");
1590 if(typ == GDL_PTR) e->Throw("Unable to convert variable to type pointer.");
1591 if(typ == GDL_OBJ) e->Throw("Unable to convert variable to type object reference.");
1592
1593 if (typ == GDL_STRING) {
1594 // SA: calling GDL_STRING() with correct parameters
1595 static int stringIx = LibFunIx("STRING");
1596 //assert(stringIx >= 0);
1597
1598 EnvT* newEnv = new EnvT(e, libFunList[stringIx], NULL);
1599
1600 Guard<EnvT> guard(newEnv);
1601
1602 newEnv->SetNextPar(&e->GetPar(0)); // pass as global
1603
1604 static int printIx = e->KeywordIx("PRINT");
1605
1606 if (e->KeywordSet(printIx) && e->GetPar(0)->Type() == GDL_BYTE){
1607 newEnv->SetKeyword("PRINT", new DIntGDL(1));
1608 }
1609
1610 return static_cast<DLibFun*> (newEnv->GetPro())->Fun()(newEnv);
1611 }
1612 }
1613 return int_fun(e);
1614 }
1615
call_function(EnvT * e)1616 BaseGDL* call_function( EnvT* e)
1617 {
1618 int nParam=e->NParam();
1619 if( nParam == 0)
1620 e->Throw( "No function specified.");
1621
1622 DString callF;
1623 e->AssureScalarPar<DStringGDL>( 0, callF);
1624
1625 // this is a function name -> convert to UPPERCASE
1626 callF = StrUpCase( callF);
1627
1628 // first search library funcedures
1629 int funIx=LibFunIx( callF);
1630 if( funIx != -1)
1631 {
1632 // e->PushNewEnv( libFunList[ funIx], 1);
1633 // make the call
1634 // EnvT* newEnv = static_cast<EnvT*>(e->Interpreter()->CallStack().back());
1635
1636 // handle direct call functions
1637 if( libFunList[ funIx]->DirectCall())
1638 {
1639 BaseGDL* directCallParameter = e->GetParDefined(1);
1640 BaseGDL* res =
1641 static_cast<DLibFunDirect*>(libFunList[ funIx])->FunDirect()(directCallParameter, true /*isReference*/);
1642 return res;
1643 }
1644 else
1645 {
1646 EnvT* newEnv = e->NewEnv( libFunList[ funIx], 1);
1647 Guard<EnvT> guard( newEnv);
1648 BaseGDL* res = static_cast<DLibFun*>(newEnv->GetPro())->Fun()(newEnv);
1649 e->SetPtrToReturnValue( newEnv->GetPtrToReturnValue());
1650 return res;
1651 }
1652 }
1653 else
1654 {
1655 // no direct call here
1656
1657 funIx = GDLInterpreter::GetFunIx( callF);
1658
1659 StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());
1660
1661 EnvUDT* newEnv = e->PushNewEnvUD( funList[ funIx], 1);
1662
1663 // make the call
1664 // EnvUDT* newEnv = static_cast<EnvUDT*>(e->Interpreter()->CallStack().back());
1665 //GD: changed LRFUNCTION to RFUNCTION and removed e->SetPtrToReturnValue() below.
1666 //this solved bug #706
1667 newEnv->SetCallContext( EnvUDT::RFUNCTION);
1668 BaseGDL* res = e->Interpreter()->call_fun(static_cast<DSubUD*>(newEnv->GetPro())->GetTree());
1669 //GD: removed e->SetPtrToReturnValue( newEnv->GetPtrToReturnValue());
1670 // BaseGDL* ppp = res->Dup();
1671 // cout << " res = " << res << " p to res = " << newEnv->GetPtrToReturnValue() << endl;
1672 return res;
1673 }
1674 }
1675
call_method_function(EnvT * e)1676 BaseGDL* call_method_function( EnvT* e)
1677 {
1678 int nParam=e->NParam();
1679 if( nParam < 2)
1680 e->Throw( "Name and object reference must be specified.");
1681
1682 DString callP;
1683 e->AssureScalarPar<DStringGDL>( 0, callP);
1684
1685 // this is a procedure name -> convert to UPPERCASE
1686 callP = StrUpCase( callP);
1687
1688 DStructGDL* oStruct = e->GetObjectPar( 1);
1689
1690 DFun* method= oStruct->Desc()->GetFun( callP);
1691
1692 if( method == NULL)
1693 e->Throw( "Method not found: "+callP);
1694
1695 StackGuard<EnvStackT> guard( e->Interpreter()->CallStack());
1696
1697 EnvUDT* newEnv = e->PushNewEnvUD( method, 2, (DObjGDL**) &e->GetPar( 1));
1698
1699 // make the call
1700 // return e->Interpreter()->call_fun( method->GetTree());
1701 newEnv->SetCallContext( EnvUDT::LRFUNCTION);
1702 BaseGDL* res = e->Interpreter()->call_fun( method->GetTree());
1703 e->SetPtrToReturnValue( newEnv->GetPtrToReturnValue());
1704 return res;
1705 }
1706
1707
1708
execute_fun(EnvT * e)1709 BaseGDL* execute_fun( EnvT* e)
1710 {
1711 int nParam=e->NParam( 1);
1712
1713 bool compileFlags = false;
1714 if( nParam >= 2)
1715 {
1716 BaseGDL* p1 = e->GetParDefined( 1);
1717
1718 if( !p1->Scalar())
1719 e->Throw( "Expression must be scalar in this context: "+
1720 e->GetParString(1));
1721
1722 // we do not enforce the case of Implied Print, then only 2 states
1723 compileFlags = p1->LogTrue();
1724 }
1725
1726 bool quietExecution = false;
1727 if( nParam == 3)
1728 {
1729 BaseGDL* p2 = e->GetParDefined( 2);
1730
1731 if( !p2->Scalar())
1732 e->Throw( "Expression must be scalar in this context: "+
1733 e->GetParString(2));
1734
1735 quietExecution = p2->LogTrue();
1736 Warning("The QuietExecution argument of execute() is not yet supported by GDL.");
1737 }
1738
1739 if (e->GetParDefined(0)->Rank() != 0)
1740 e->Throw("Expression must be scalar in this context: "+e->GetParString(0));
1741
1742 DString line;
1743 e->AssureScalarPar<DStringGDL>( 0, line);
1744
1745 // remove current environment (own one)
1746 assert( dynamic_cast<EnvUDT*>(e->Caller()) != NULL);
1747 EnvUDT* caller = static_cast<EnvUDT*>(e->Caller());
1748 // e->Interpreter()->CallStack().pop_back();
1749
1750 // wrong: e is guarded, do not delete it here
1751 // delete e;
1752
1753 istringstream istr(line+"\n");
1754
1755 RefDNode theAST;
1756 try {
1757 GDLLexer lexer(istr, "", caller->CompileOpt());
1758 GDLParser& parser=lexer.Parser();
1759
1760 parser.interactive();
1761
1762 theAST=parser.getAST();
1763 }
1764 catch( GDLException& ex)
1765 {
1766 if( !compileFlags) GDLInterpreter::ReportCompileError( ex);
1767 return new DIntGDL( 0);
1768 }
1769 catch( ANTLRException& ex)
1770 {
1771 if( !compileFlags) cerr << "EXECUTE: Lexer/Parser exception: " <<
1772 ex.getMessage() << endl;
1773 return new DIntGDL( 0);
1774 }
1775
1776 if( theAST == NULL) return new DIntGDL( 1);
1777
1778 RefDNode trAST;
1779 try
1780 {
1781 GDLTreeParser treeParser( caller);
1782
1783 treeParser.interactive(theAST);
1784
1785 trAST=treeParser.getAST();
1786 }
1787 catch( GDLException& ex)
1788 {
1789 if( !compileFlags) GDLInterpreter::ReportCompileError( ex);
1790 return new DIntGDL( 0);
1791 }
1792
1793 catch( ANTLRException& ex)
1794 {
1795 if( !compileFlags) cerr << "EXECUTE: Compiler exception: " <<
1796 ex.getMessage() << endl;
1797 return new DIntGDL( 0);
1798 }
1799
1800 if( trAST == NULL) return new DIntGDL( 1);
1801
1802 int nForLoopsIn = caller->NForLoops();
1803 try
1804 {
1805 ProgNodeP progAST = ProgNode::NewProgNode( trAST);
1806 Guard< ProgNode> progAST_guard( progAST);
1807
1808 int nForLoops = ProgNode::NumberForLoops( progAST, nForLoopsIn);
1809 caller->ResizeForLoops( nForLoops);
1810
1811 progAST->setLine( e->GetLineNumber());
1812
1813 // AC 2016-02-26 : bug report #692 always verbose in EXECUTE()
1814 // Do we have a way not to *always* issue a message here
1815 // in case of problem ???
1816 RetCode retCode = caller->Interpreter()->execute( progAST);
1817
1818 caller->ResizeForLoops( nForLoopsIn);
1819
1820 if( retCode == RC_OK)
1821 return new DIntGDL( 1);
1822 else
1823 return new DIntGDL( 0);
1824 }
1825 catch( GDLException& ex)
1826 {
1827 caller->ResizeForLoops( nForLoopsIn);
1828 // are we throwing to target environment?
1829 // if( ex.GetTargetEnv() == NULL)
1830 if( !compileFlags) cerr << "EXECUTE: " <<
1831 ex.getMessage() << endl;
1832 return new DIntGDL( 0);
1833 }
1834 catch( ANTLRException& ex)
1835 {
1836 caller->ResizeForLoops( nForLoopsIn);
1837
1838 if( !compileFlags) cerr << "EXECUTE: Interpreter exception: " <<
1839 ex.getMessage() << endl;
1840 return new DIntGDL( 0);
1841 }
1842
1843 return new DIntGDL( 0); // control flow cannot reach here - compiler shut up
1844 }
1845
assoc(EnvT * e)1846 BaseGDL* assoc( EnvT* e)
1847 {
1848 SizeT nParam=e->NParam( 2);
1849
1850 DLong lun;
1851 e->AssureLongScalarPar( 0, lun);
1852
1853 bool stdLun = check_lun( e, lun);
1854 if( stdLun)
1855 e->Throw( "File unit does not allow"
1856 " this operation. Unit: "+i2s( lun));
1857
1858 DLong offset = 0;
1859 if( nParam >= 3) e->AssureLongScalarPar( 2, offset);
1860
1861 BaseGDL* arr = e->GetParDefined( 1);
1862
1863 if( arr->StrictScalar())
1864 e->Throw( "Scalar variable not allowed in this"
1865 " context: "+e->GetParString(1));
1866
1867 return arr->AssocVar( lun, offset);
1868 }
1869
1870 // gdl_ naming because of weired namespace problem in MSVC
gdl_logical_and(EnvT * e)1871 BaseGDL* gdl_logical_and( EnvT* e)
1872 {
1873 SizeT nParam=e->NParam();
1874 if( nParam != 2)
1875 e->Throw(
1876 "Incorrect number of arguments.");
1877
1878 BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_AND");
1879 BaseGDL* e2=e->GetParDefined( 1);//, "LOGICAL_AND");
1880
1881 ULong nEl1 = e1->N_Elements();
1882 ULong nEl2 = e2->N_Elements();
1883
1884 Data_<SpDByte>* res;
1885
1886 if( e1->Scalar())
1887 {
1888 if( e1->LogTrue(0))
1889 {
1890 res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);
1891 // #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))
1892 {
1893 // #pragma omp for
1894 for( SizeT i=0; i < nEl2; i++)
1895 (*res)[i] = e2->LogTrue( i) ? 1 : 0;
1896 }
1897 }
1898 else
1899 {
1900 return new Data_<SpDByte>( e2->Dim());
1901 }
1902 }
1903 else if( e2->Scalar())
1904 {
1905 if( e2->LogTrue(0))
1906 {
1907 res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);
1908 // #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))
1909 {
1910 // #pragma omp for
1911 for( SizeT i=0; i < nEl1; i++)
1912 (*res)[i] = e1->LogTrue( i) ? 1 : 0;
1913 }
1914 }
1915 else
1916 {
1917 return new Data_<SpDByte>( e1->Dim());
1918 }
1919 }
1920 else if( nEl2 <= nEl1)
1921 {
1922 res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);
1923 // #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))
1924 {
1925 // #pragma omp for
1926 for( SizeT i=0; i < nEl2; i++)
1927 (*res)[i] = (e1->LogTrue( i) && e2->LogTrue( i)) ? 1 : 0;
1928 }
1929 }
1930 else // ( nEl2 > nEl1)
1931 {
1932 res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);
1933 // #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))
1934 {
1935 // #pragma omp for
1936 for( SizeT i=0; i < nEl1; i++)
1937 (*res)[i] = (e1->LogTrue( i) && e2->LogTrue( i)) ? 1 : 0;
1938 }
1939 }
1940 return res;
1941 }
1942
1943 // gdl_ naming because of weired namespace problem in MSVC
gdl_logical_or(EnvT * e)1944 BaseGDL* gdl_logical_or( EnvT* e)
1945 {
1946 SizeT nParam=e->NParam();
1947 if( nParam != 2)
1948 e->Throw(
1949 "Incorrect number of arguments.");
1950
1951 BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_OR");
1952 BaseGDL* e2=e->GetParDefined( 1);//, "LOGICAL_OR");
1953
1954 ULong nEl1 = e1->N_Elements();
1955 ULong nEl2 = e2->N_Elements();
1956
1957 Data_<SpDByte>* res;
1958
1959 if( e1->Scalar())
1960 {
1961 if( e1->LogTrue(0))
1962 {
1963 res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);
1964 // #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))
1965 {
1966 // #pragma omp for
1967 for( SizeT i=0; i < nEl2; i++)
1968 (*res)[i] = 1;
1969 }
1970 }
1971 else
1972 {
1973 res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);
1974 // #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))
1975 {
1976 // #pragma omp for
1977 for( SizeT i=0; i < nEl2; i++)
1978 (*res)[i] = e2->LogTrue( i) ? 1 : 0;
1979 }
1980 }
1981 }
1982 else if( e2->Scalar())
1983 {
1984 if( e2->LogTrue(0))
1985 {
1986 res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);
1987 // #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))
1988 {
1989 // #pragma omp for
1990 for( SizeT i=0; i < nEl1; i++)
1991 (*res)[i] = 1;
1992 }
1993 }
1994 else
1995 {
1996 res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);
1997 // #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))
1998 {
1999 // #pragma omp for
2000 for( SizeT i=0; i < nEl1; i++)
2001 (*res)[i] = e1->LogTrue( i) ? 1 : 0;
2002 }
2003 }
2004 }
2005 else if( nEl2 < nEl1)
2006 {
2007 res= new Data_<SpDByte>( e2->Dim(), BaseGDL::NOZERO);
2008 // #pragma omp parallel if (nEl2 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl2))
2009 {
2010 // #pragma omp for
2011 for( SizeT i=0; i < nEl2; i++)
2012 (*res)[i] = (e1->LogTrue( i) || e2->LogTrue( i)) ? 1 : 0;
2013 }
2014 }
2015 else // ( nEl2 >= nEl1)
2016 {
2017 res= new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);
2018 // #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))
2019 {
2020 // #pragma omp for
2021 for( SizeT i=0; i < nEl1; i++)
2022 (*res)[i] = (e1->LogTrue( i) || e2->LogTrue( i)) ? 1 : 0;
2023 }
2024 }
2025 return res;
2026 }
2027
logical_true(BaseGDL * e1,bool isReference)2028 BaseGDL* logical_true( BaseGDL* e1, bool isReference)//( EnvT* e);
2029 {
2030 assert( e1 != NULL);
2031 assert( e1->N_Elements() > 0);
2032
2033
2034 // SizeT nParam=e->NParam();
2035 // if( nParam != 1)
2036 // e->Throw(
2037 // "Incorrect number of arguments.");
2038 //
2039 // BaseGDL* e1=e->GetParDefined( 0);//, "LOGICAL_TRUE");
2040 //
2041 ULong nEl1 = e1->N_Elements();
2042
2043 Data_<SpDByte>* res = new Data_<SpDByte>( e1->Dim(), BaseGDL::NOZERO);
2044 // #pragma omp parallel if (nEl1 >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl1))
2045 {
2046 // #pragma omp for
2047 for( SizeT i=0; i < nEl1; i++)
2048 (*res)[i] = e1->LogTrue( i) ? 1 : 0;
2049 }
2050 return res;
2051 }
2052
replicate(EnvT * e)2053 BaseGDL* replicate( EnvT* e)
2054 {
2055 SizeT nParam=e->NParam();
2056 if( nParam < 2)
2057 e->Throw( "Incorrect number of arguments.");
2058 dimension dim;
2059 arr( e, dim, 1);
2060
2061 BaseGDL* p0=e->GetParDefined( 0);//, "REPLICATE");
2062 if( !p0->Scalar())
2063 e->Throw( "Expression must be a scalar in this context: "+
2064 e->GetParString(0));
2065
2066 return p0->New( dim, BaseGDL::INIT);
2067 }
2068
strtrim(EnvT * e)2069 BaseGDL* strtrim( EnvT* e)
2070 {
2071 SizeT nParam = e->NParam( 1);//, "STRTRIM");
2072
2073 BaseGDL* p0 = e->GetPar( 0);
2074 if( p0 == NULL)
2075 e->Throw("Variable is undefined: " + e->GetParString(0));
2076 DStringGDL* p0S = static_cast<DStringGDL*>(p0->Convert2(GDL_STRING,BaseGDL::COPY));
2077
2078 DLong mode = 0;
2079 if( nParam == 2)
2080 {
2081 BaseGDL* p1 = e->GetPar( 1);
2082 if( p1 == NULL)
2083 e->Throw("Variable is undefined: "+e->GetParString(1));
2084 if( !p1->Scalar())
2085 e->Throw("Expression must be a scalar in this context: "+
2086 e->GetParString(1));
2087 DLongGDL* p1L = static_cast<DLongGDL*>
2088 (p1->Convert2(GDL_LONG,BaseGDL::COPY));
2089
2090 mode = (*p1L)[ 0];
2091
2092 GDLDelete(p1L);
2093
2094 if( mode < 0 || mode > 2)
2095 {
2096 ostringstream os;
2097 p1->ToStream( os);
2098 e->Throw( "Value of <"+ p1->TypeStr() + " ("+ os.str() +
2099 ")> is out of allowed range.");
2100 }
2101 }
2102
2103 SizeT nEl = p0S->N_Elements();
2104
2105 if( mode == 2) // both
2106 {
2107 TRACEOMP( __FILE__, __LINE__)
2108 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2109 {
2110 #pragma omp for
2111 for( OMPInt i=0; i<nEl; ++i)
2112 {
2113 unsigned long first= (*p0S)[ i].find_first_not_of(" \t");
2114 // if( first == (*p0S)[ i].npos)
2115 if (first >= (*p0S)[i].length())
2116 {
2117 (*p0S)[ i] = "";
2118 }
2119 else
2120 {
2121 unsigned long last = (*p0S)[ i].find_last_not_of(" \t");
2122 (*p0S)[ i] = (*p0S)[ i].substr(first,last-first+1);
2123 }
2124 }
2125 }
2126 }
2127 else if( mode == 1) // leading
2128 {
2129 TRACEOMP( __FILE__, __LINE__)
2130 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2131 {
2132 #pragma omp for
2133 for( OMPInt i=0; i<nEl; ++i)
2134 {
2135 unsigned long first= (*p0S)[ i].find_first_not_of(" \t");
2136 // if( first == (*p0S)[ i].npos)
2137 if (first >= (*p0S)[i].length())
2138 {
2139 (*p0S)[ i] = "";
2140 }
2141 else
2142 {
2143 (*p0S)[ i] = (*p0S)[ i].substr(first);
2144 }
2145 }
2146 }
2147 }
2148 else // trailing
2149 {
2150 TRACEOMP( __FILE__, __LINE__)
2151 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2152 {
2153 #pragma omp for
2154 for( OMPInt i=0; i<nEl; ++i)
2155 {
2156 unsigned long last = (*p0S)[ i].find_last_not_of(" \t");
2157 // if( last == (*p0S)[ i].npos)
2158 if (last >= (*p0S)[i].length())
2159 {
2160 (*p0S)[ i] = "";
2161 }
2162 else
2163 {
2164 (*p0S)[ i] = (*p0S)[ i].substr(0,last+1);
2165 }
2166 }
2167 }
2168 }
2169 return p0S;
2170 }
2171
strcompress(EnvT * e)2172 BaseGDL* strcompress( EnvT* e)
2173 {
2174 e->NParam( 1);
2175
2176 DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);
2177
2178 bool removeAll = e->KeywordSet(0);
2179
2180 DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);
2181
2182 SizeT nEl = p0S->N_Elements();
2183 TRACEOMP( __FILE__, __LINE__)
2184 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2185 {
2186 #pragma omp for
2187 for( OMPInt i=0; i<nEl; ++i)
2188 {
2189 (*res)[ i] = StrCompress((*p0S)[ i], removeAll);
2190 }
2191 }
2192 return res;
2193 }
2194
strpos(EnvT * e)2195 BaseGDL* strpos( EnvT* e)
2196 {
2197 SizeT nParam = e->NParam( 2);//, "STRPOS");
2198
2199 bool reverseOffset = e->KeywordSet(0); // REVERSE_OFFSET
2200 bool reverseSearch = e->KeywordSet(1); // REVERSE_SEARCH
2201
2202 DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);
2203
2204 DString searchString;
2205 // e->AssureScalarPar<DStringGDL>( 1, searchString);
2206 DStringGDL* sStr = e->GetParAs<DStringGDL>( 1);
2207 if( !sStr->Scalar( searchString))
2208 e->Throw( "Search string must be a scalar or one element array: "+
2209 e->GetParString( 1));
2210
2211 long pos = -1; //string::npos
2212 if( nParam > 2)
2213 {
2214 BaseGDL* p2 = e->GetParDefined(2);
2215 const SizeT pIx = 2;
2216 BaseGDL* p = e->GetParDefined( pIx);
2217 DLongGDL* lp = static_cast<DLongGDL*>(p->Convert2( GDL_LONG, BaseGDL::COPY));
2218 Guard<DLongGDL> guard_lp( lp);
2219 DLong scalar;
2220 if( !lp->Scalar( scalar))
2221 throw GDLException("Parameter must be a scalar in this context: "+
2222 e->GetParString(pIx));
2223 pos = scalar;
2224 }
2225
2226 DLongGDL* res = new DLongGDL( p0S->Dim(), BaseGDL::NOZERO);
2227
2228 SizeT nSrcStr = p0S->N_Elements();
2229 TRACEOMP( __FILE__, __LINE__)
2230 #pragma omp parallel if ((nSrcStr*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nSrcStr*10)))
2231 {
2232 #pragma omp for
2233 for( OMPInt i=0; i<nSrcStr; ++i)
2234 {
2235 (*res)[ i] = StrPos((*p0S)[ i], searchString, pos,
2236 reverseOffset, reverseSearch);
2237 }
2238 }
2239 return res;
2240 }
2241
strmid(EnvT * e)2242 BaseGDL* strmid( EnvT* e)
2243 {
2244 SizeT nParam = e->NParam( 2);//, "STRMID");
2245
2246 bool reverse = e->KeywordSet(0);
2247
2248 DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);
2249 DLongGDL* p1L = e->GetParAs<DLongGDL>( 1);
2250
2251 // BaseGDL* p2 = e->GetPar( 2);
2252 DLongGDL* p2L = NULL;
2253 if( nParam > 2) p2L = e->GetParAs<DLongGDL>( 2);
2254
2255 DLong scVal1;
2256 bool sc1 = p1L->Scalar( scVal1);
2257
2258 DLong scVal2 = numeric_limits<DLong>::max();
2259 bool sc2 = true;
2260 if( p2L != NULL)
2261 {
2262 DLong scalar;
2263 sc2 = p2L->Scalar( scalar);
2264 scVal2 = scalar;
2265 }
2266
2267 DLong stride;
2268 if( !sc1 && !sc2)
2269 {
2270 stride = p1L->Dim( 0);
2271 if( stride != p2L->Dim( 0))
2272 e->Throw( "Starting offset and length arguments "
2273 "have incompatible first dimension.");
2274 }
2275 else
2276 {
2277 // at least one scalar, p2L possibly NULL
2278 if( p2L == NULL)
2279 stride = p1L->Dim( 0);
2280 else
2281 stride = max( p1L->Dim( 0), p2L->Dim( 0));
2282
2283 stride = (stride > 0)? stride : 1;
2284 }
2285
2286 dimension resDim( p0S->Dim());
2287 if( stride > 1)
2288 resDim >> stride;
2289
2290 DStringGDL* res = new DStringGDL( resDim, BaseGDL::NOZERO);
2291
2292 SizeT nEl1 = p1L->N_Elements();
2293 SizeT nEl2 = (sc2)? 1 : p2L->N_Elements();
2294
2295 SizeT nSrcStr = p0S->N_Elements();
2296 if( nSrcStr == 1)
2297 {
2298 // possibly this optimization is not worth the longer code (as the gain can only be a small fraction
2299 // of the overall time), but then this is a very common use
2300 for( long ii=0; ii<stride; ++ii)
2301 {
2302 SizeT destIx = ii;
2303 DLong actFirst = (sc1)? scVal1 : (*p1L)[ destIx % nEl1];
2304 DLong actLen = (sc2)? scVal2 : (*p2L)[ destIx % nEl2];
2305 if( actLen <= 0)
2306 (*res)[ destIx] = "";//StrMid((*p0S)[ i], actFirst, actLen, reverse);
2307 else
2308 (*res)[ destIx] = StrMid((*p0S)[ 0], actFirst, actLen, reverse);
2309 }
2310 return res;
2311 }
2312 TRACEOMP( __FILE__, __LINE__)
2313 #pragma omp parallel if ((nSrcStr*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nSrcStr*10))) default( shared)
2314 {
2315 #pragma omp for
2316 for( OMPInt i=0; i<nSrcStr; ++i)
2317 {
2318 for( long ii=0; ii<stride; ++ii)
2319 {
2320 SizeT destIx = i * stride + ii;
2321 DLong actFirst = (sc1)? scVal1 : (*p1L)[ destIx % nEl1];
2322 DLong actLen = (sc2)? scVal2 : (*p2L)[ destIx % nEl2];
2323 if( actLen <= 0)
2324 (*res)[ destIx] = "";//StrMid((*p0S)[ i], actFirst, actLen, reverse);
2325 else
2326 (*res)[ destIx] = StrMid((*p0S)[ i], actFirst, actLen, reverse);
2327 }
2328 }
2329 }
2330 return res;
2331 }
2332
strlowcase(BaseGDL * p0,bool isReference)2333 BaseGDL* strlowcase( BaseGDL* p0, bool isReference)//( EnvT* e)
2334 {
2335 assert( p0 != NULL);
2336 assert( p0->N_Elements() > 0);
2337
2338 // e->NParam( 1);//, "STRLOWCASE");
2339
2340 // DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);
2341 DStringGDL* p0S;
2342 DStringGDL* res;
2343 // Guard<DStringGDL> guard;
2344
2345 if( p0->Type() == GDL_STRING)
2346 {
2347 p0S = static_cast<DStringGDL*>( p0);
2348 if( !isReference)
2349 res = p0S;
2350 else
2351 res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);
2352 }
2353 else
2354 {
2355 p0S = static_cast<DStringGDL*>( p0->Convert2( GDL_STRING, BaseGDL::COPY));
2356 res = p0S;
2357 // guard.Reset( p0S);
2358 }
2359
2360 // DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);
2361
2362 SizeT nEl = p0S->N_Elements();
2363
2364 if( res == p0S)
2365 {
2366 TRACEOMP( __FILE__, __LINE__)
2367 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2368 {
2369 #pragma omp for
2370 for( OMPInt i=0; i<nEl; ++i)
2371 {
2372 StrLowCaseInplace((*p0S)[ i]);
2373 }
2374 }
2375 }
2376 else
2377 {
2378 TRACEOMP( __FILE__, __LINE__)
2379 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2380 {
2381 #pragma omp for
2382 for( OMPInt i=0; i<nEl; ++i)
2383 {
2384 (*res)[ i] = StrLowCase((*p0S)[ i]);
2385 }
2386 }
2387 }
2388 return res;
2389 }
2390
strupcase(BaseGDL * p0,bool isReference)2391 BaseGDL* strupcase( BaseGDL* p0, bool isReference)//( EnvT* e)
2392 {
2393 assert( p0 != NULL);
2394 assert( p0->N_Elements() > 0);
2395
2396 // e->NParam( 1);//, "STRLOWCASE");
2397
2398 // DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);
2399 DStringGDL* p0S;
2400 DStringGDL* res;
2401 // Guard<DStringGDL> guard;
2402
2403 if( p0->Type() == GDL_STRING)
2404 {
2405 p0S = static_cast<DStringGDL*>( p0);
2406 if( !isReference)
2407 res = p0S;
2408 else
2409 res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);
2410 }
2411 else
2412 {
2413 p0S = static_cast<DStringGDL*>( p0->Convert2( GDL_STRING, BaseGDL::COPY));
2414 res = p0S;
2415 // guard.Reset( p0S);
2416 }
2417
2418 // DStringGDL* res = new DStringGDL( p0S->Dim(), BaseGDL::NOZERO);
2419
2420 SizeT nEl = p0S->N_Elements();
2421
2422 if( res == p0S)
2423 {
2424 TRACEOMP( __FILE__, __LINE__)
2425 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2426 {
2427 #pragma omp for
2428 for( OMPInt i=0; i<nEl; ++i)
2429 {
2430 StrUpCaseInplace((*p0S)[ i]);
2431 }
2432 }
2433 }
2434 else
2435 {
2436 TRACEOMP( __FILE__, __LINE__)
2437 #pragma omp parallel if ((nEl*10) >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl*10)))
2438 {
2439 #pragma omp for
2440 for( OMPInt i=0; i<nEl; ++i)
2441 {
2442 (*res)[ i] = StrUpCase((*p0S)[ i]);
2443 }
2444 }
2445 }
2446 return res;
2447 }
2448
strlen(BaseGDL * p0,bool isReference)2449 BaseGDL* strlen( BaseGDL* p0, bool isReference)//( EnvT* e)
2450 {
2451 assert( p0 != NULL);
2452 assert( p0->N_Elements() > 0);
2453
2454 // e->NParam( 1);//, "STRLEN");
2455
2456 DStringGDL* p0S;
2457 Guard<DStringGDL> guard;
2458
2459 if( p0->Type() == GDL_STRING)
2460 p0S = static_cast<DStringGDL*>( p0);
2461 else
2462 {
2463 p0S = static_cast<DStringGDL*>( p0->Convert2( GDL_STRING, BaseGDL::COPY));
2464 guard.Reset( p0S);
2465 }
2466
2467 DLongGDL* res = new DLongGDL( p0S->Dim(), BaseGDL::NOZERO);
2468
2469 SizeT nEl = p0S->N_Elements();
2470 // #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2471 {
2472 // #pragma omp for
2473 for( SizeT i=0; i<nEl; ++i)
2474 {
2475 (*res)[ i] = (*p0S)[ i].length();
2476 }
2477 }
2478 return res;
2479 }
2480
strjoin(EnvT * e)2481 BaseGDL* strjoin( EnvT* e)
2482 {
2483 SizeT nParam = e->NParam( 1);
2484
2485 DStringGDL* p0S = e->GetParAs<DStringGDL>( 0);
2486 SizeT nEl = p0S->N_Elements();
2487
2488 DString delim = "";
2489 if( nParam > 1)
2490 e->AssureStringScalarPar( 1, delim);
2491
2492 bool single = e->KeywordSet( 0); // SINGLE
2493
2494 if( single)
2495 {
2496 DStringGDL* res = new DStringGDL( (*p0S)[0]);
2497 DString& scl = (*res)[0];
2498
2499 for( SizeT i=1; i<nEl; ++i)
2500 scl += delim + (*p0S)[i];
2501
2502 return res;
2503 }
2504
2505 dimension resDim( p0S->Dim());
2506 resDim.Purge();
2507
2508 SizeT stride = resDim.Stride( 1);
2509
2510 resDim.Remove( 0);
2511
2512 DStringGDL* res = new DStringGDL( resDim, BaseGDL::NOZERO);
2513 for( SizeT src=0, dst=0; src<nEl; ++dst)
2514 {
2515 (*res)[ dst] = (*p0S)[ src++];
2516 for(SizeT l=1; l<stride; ++l)
2517 (*res)[ dst] += delim + (*p0S)[ src++];
2518 }
2519
2520 return res;
2521 }
2522
2523
n_params(EnvT * e)2524 BaseGDL* n_params( EnvT* e)
2525 {
2526 EnvUDT* caller = static_cast<EnvUDT*>(e->Caller());
2527 if( caller == NULL) return new DLongGDL( 0);
2528 DLong nP = caller->NParam();
2529 if( caller->IsObject())
2530 return new DLongGDL( nP-1); // "self" is not counted
2531 return new DLongGDL( nP);
2532 }
2533 //keyword_set returns 1 (true) if:
2534 //
2535 // Expression is a scalar or 1-element array with a non-zero value.
2536 // Expression is a structure or a n-element array, n>1
2537 // Expression is an ASSOC file variable. ---> not done?
2538 //
2539 //KEYWORD_SET returns 0 (false) if:
2540 //
2541 // Expression is undefined.
2542 // Expression is a scalar or 1-element array with a zero value.
2543
keyword_set(EnvT * e)2544 BaseGDL* keyword_set( EnvT* e)
2545 {
2546 e->NParam( 1);//, "KEYWORD_SET");
2547
2548 BaseGDL* p0 = e->GetPar( 0);
2549 if( p0 == NULL) return new DIntGDL( 0);
2550 if( p0->Type() == GDL_UNDEF) return new DIntGDL( 0);
2551 if( !p0->Scalar()) return new DIntGDL( 1);
2552 if( p0->Type() == GDL_STRUCT) return new DIntGDL( 1);
2553 if( p0->LogTrue()) return new DIntGDL( 1);
2554 return new DIntGDL( 0);
2555 }
2556
2557 // passing 2nd argument by value is slightly better for float and double,
2558 // but incur some overhead for the complex class.
2559
AddOmitNaN(T & dest,T value)2560 template<class T> inline void AddOmitNaN(T& dest, T value)
2561 {
2562 if (std::isfinite(value)) {
2563 // #pragma omp atomic
2564 dest += value;
2565 }
2566 }
2567
AddOmitNaNCpx(T & dest,T value)2568 template<class T> inline void AddOmitNaNCpx(T& dest, T value)
2569 {
2570 // #pragma omp atomic
2571 dest += T(std::isfinite(value.real()) ? value.real() : 0,
2572 std::isfinite(value.imag()) ? value.imag() : 0);
2573 }
2574
AddOmitNaN(DComplex & dest,DComplex value)2575 template<> inline void AddOmitNaN(DComplex& dest, DComplex value)
2576 {
2577 AddOmitNaNCpx<DComplex>(dest, value);
2578 }
2579
AddOmitNaN(DComplexDbl & dest,DComplexDbl value)2580 template<> inline void AddOmitNaN(DComplexDbl& dest, DComplexDbl value)
2581 {
2582 AddOmitNaNCpx<DComplexDbl>(dest, value);
2583 }
2584
NaN2Zero(T & value)2585 template<class T> inline void NaN2Zero(T& value)
2586 {
2587 if (!std::isfinite(value)) value = 0;
2588 }
2589
NaN2ZeroCpx(T & value)2590 template<class T> inline void NaN2ZeroCpx(T& value)
2591 {
2592 value = T(std::isfinite(value.real()) ? value.real() : 0,
2593 std::isfinite(value.imag()) ? value.imag() : 0);
2594 }
2595
NaN2Zero(DComplex & value)2596 template<> inline void NaN2Zero(DComplex& value)
2597 {
2598 NaN2ZeroCpx< DComplex>(value);
2599 }
2600
NaN2Zero(DComplexDbl & value)2601 template<> inline void NaN2Zero(DComplexDbl& value)
2602 {
2603 NaN2ZeroCpx< DComplexDbl>(value);
2604 }
2605
2606 // total over all elements, preserve type
2607
2608 template<class T>
total_template_generic(T * src,bool omitNaN)2609 BaseGDL* total_template_generic(T* src, bool omitNaN)
2610 {
2611 SizeT nEl = src->N_Elements();
2612 typename T::Ty sum = 0;
2613 bool parallelize=(CpuTPOOL_NTHREADS> 1 && nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl));
2614 if (parallelize) {
2615 SizeT i;
2616 if (!omitNaN) {
2617 #pragma omp parallel for reduction(+:sum) private(i)
2618 for (i = 0; i < nEl; ++i) sum += (*src)[ i];
2619 } else {
2620 #pragma omp parallel
2621 {
2622 typename T::Ty localsum = 0;
2623 #pragma omp for nowait
2624 for (SizeT i = 0; i < nEl; ++i) if (isfinite((*src)[i])) localsum += (*src)[ i];
2625 #pragma omp atomic
2626 sum += localsum;
2627 }
2628 }
2629 } else {
2630 if (!omitNaN) for (SizeT i = 0; i < nEl; ++i) sum += (*src)[ i];
2631 else for (SizeT i = 0; i < nEl; ++i) if (isfinite((*src)[i])) sum += (*src)[ i];
2632 }
2633 return new T(sum);
2634 }
2635
2636 template<>
total_template_generic(DComplexGDL * src,bool omitNaN)2637 BaseGDL* total_template_generic(DComplexGDL* src, bool omitNaN)
2638 {
2639 // std::cerr << " total_template_generic_DComplexGdl " << std::endl;
2640 SizeT nEl = src->N_Elements();
2641 DFloat sr = 0;
2642 DFloat si = 0;
2643 if (!omitNaN) {
2644 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) reduction(+:sr,si)
2645 for (SizeT i = 0; i < nEl; ++i) {
2646 sr += (*src)[i].real();
2647 si += (*src)[i].imag();
2648 }
2649 } else {
2650 #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2651 {
2652 DFloat lsr = 0;
2653 DFloat lsi = 0;
2654 #pragma omp for nowait
2655 for (SizeT i = 0; i < nEl; ++i) {
2656 if (isfinite((*src)[i].real())) lsr += (*src)[i].real();
2657 if (isfinite((*src)[i].imag())) lsi += (*src)[i].imag();
2658 }
2659 #pragma omp atomic
2660 sr += lsr;
2661 si += lsi;
2662 }
2663 }
2664 return new DComplexGDL(std::complex<float>(sr, si));
2665 }
2666
2667 template<>
total_template_generic(DComplexDblGDL * src,bool omitNaN)2668 BaseGDL* total_template_generic(DComplexDblGDL* src, bool omitNaN)
2669 {
2670 // std::cerr << " total_template_generic_DcomplexGDlDbl " << std::endl;
2671 SizeT nEl = src->N_Elements();
2672 DDouble sr = 0;
2673 DDouble si = 0;
2674 if (!omitNaN) {
2675 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) reduction(+:sr,si)
2676 for (SizeT i = 0; i < nEl; ++i) {
2677 sr += (*src)[i].real();
2678 si += (*src)[i].imag();
2679 }
2680 } else {
2681 #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2682 {
2683 DDouble lsr = 0;
2684 DDouble lsi = 0;
2685 #pragma omp for nowait
2686 for (SizeT i = 0; i < nEl; ++i) {
2687 if (isfinite((*src)[i].real())) lsr += (*src)[i].real();
2688 if (isfinite((*src)[i].imag())) lsi += (*src)[i].imag();
2689 }
2690 #pragma omp atomic
2691 sr += lsr;
2692 si += lsi;
2693 }
2694 }
2695 return new DComplexDblGDL(std::complex<double>(sr, si));
2696 }
2697
2698 // total over all elements, done on Double. Avoids costly convert!
2699
2700 template<class T>
total_template_double(T * src,bool omitNaN)2701 DDoubleGDL* total_template_double(T* src, bool omitNaN)
2702 {
2703 // std::cerr<<" total_template_double "<<std::endl;
2704 SizeT nEl = src->N_Elements();
2705 DDouble sum = 0;
2706 if (!omitNaN) {
2707 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) reduction(+:sum)
2708 for (SizeT i = 0; i < nEl; ++i) sum += (*src)[ i];
2709 } else {
2710 #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2711 {
2712 DDouble localsum = 0;
2713 #pragma omp for nowait
2714 for (SizeT i = 0; i < nEl; ++i) {
2715 if (isfinite((*src)[i])) localsum += (*src)[ i];
2716 }
2717 #pragma omp atomic
2718 sum += localsum;
2719 }
2720 }
2721 return new DDoubleGDL(sum);
2722 }
2723
2724 template<class T>
total_template_single(T * src,bool omitNaN)2725 DFloatGDL* total_template_single(T* src, bool omitNaN)
2726 {
2727 // std::cerr<<" total_template_single "<<std::endl;
2728 SizeT nEl = src->N_Elements();
2729 DDouble sum = 0;
2730 if (!omitNaN) {
2731 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) reduction(+:sum)
2732 for (SizeT i = 0; i < nEl; ++i) sum += (*src)[ i];
2733 } else {
2734 #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2735 {
2736 DDouble localsum = 0;
2737 #pragma omp for nowait
2738 for (SizeT i = 0; i < nEl; ++i) {
2739 if (isfinite((*src)[i])) localsum += (*src)[ i];
2740 }
2741 #pragma omp atomic
2742 sum += localsum;
2743 }
2744 }
2745 return new DFloatGDL(sum);
2746 }
2747
2748 //special case for /INT using LONG64
2749
2750 template<class T>
total_template_integer(T * src)2751 DLong64GDL* total_template_integer(T* src)
2752 {
2753 // std::cerr<<" total_template_integer "<<std::endl;
2754 SizeT nEl = src->N_Elements();
2755 DLong64 sum = 0;
2756 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) reduction(+:sum)
2757 for (SizeT i = 0; i < nEl; ++i) sum += (*src)[ i];
2758 return new DLong64GDL(sum);
2759 }
2760
2761 // cumulative over all dims
2762
2763 // template<typename T>
2764 // BaseGDL* total_cu_template(T* res, bool omitNaN)
2765 // {
2766 // SizeT nEl = res->N_Elements();
2767 // if (omitNaN) {
2768 // // #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2769 // {
2770 // // #pragma omp for
2771 // for (SizeT i = 0; i < nEl; ++i)
2772 // NaN2Zero((*res)[i]);
2773 // }
2774 // }
2775 // for (SizeT i = 1, ii = 0; i < nEl; ++i, ++ii)
2776 // (*res)[i] += (*res)[ii];
2777 // return res;
2778 // }
2779 //this is twice faster than above version, probably by exposing the POD (T1::Ty) to the loop to be optimized by the compiler
2780 template<typename T1, typename T2>
total_cu_template(T1 * val,bool omitNaN)2781 BaseGDL* total_cu_template(T1* val, bool omitNaN)
2782 {
2783 typename T1::Ty *res;
2784 SizeT nEl=val->N_Elements();
2785 res=static_cast<T2*>(val->DataAddr());
2786 if (omitNaN) {
2787 #pragma omp parallel for if (CpuTPOOL_NTHREADS >1 && nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
2788 for (SizeT i = 0; i < nEl; ++i) NaN2Zero(res[i]);
2789 }
2790 //this formulation is slightly faster on my machine
2791 for (SizeT i = 1, ii = 0; i < nEl; ++i, ++ii) res[i] += res[ii];
2792 // for (SizeT i = 1; i < nEl; ++i) res[i] += res[i-1];
2793 return val;
2794 }
2795
2796 // total over one dim
2797
2798 template< typename T>
total_over_dim_template(T * src,const dimension & srcDim,SizeT sumDimIx,bool omitNaN)2799 BaseGDL* total_over_dim_template(T* src,
2800 const dimension& srcDim,
2801 SizeT sumDimIx, bool omitNaN)
2802 {
2803 SizeT nEl = src->N_Elements();
2804
2805 // get dest dim and number of summations
2806 dimension destDim = srcDim;
2807 SizeT nSum = destDim.Remove(sumDimIx);
2808
2809 T* res = new T(destDim); // zero fields
2810
2811 // sumStride is also the number of linear src indexing
2812 SizeT sumStride = srcDim.Stride(sumDimIx);
2813 SizeT outerStride = srcDim.Stride(sumDimIx + 1);
2814 SizeT sumLimit = nSum * sumStride;
2815
2816 if (omitNaN) {
2817 #pragma omp parallel if ((nEl/outerStride)*sumStride >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl/outerStride)*sumStride))
2818 {
2819 #pragma omp for
2820 for (SizeT o = 0; o < nEl; o += outerStride) {
2821 SizeT rIx = (o / outerStride) * sumStride;
2822 for (SizeT i = 0; i < sumStride; ++i) {
2823 SizeT oi = o + i;
2824 SizeT oiLimit = sumLimit + oi;
2825 for (SizeT s = oi; s < oiLimit; s += sumStride) AddOmitNaN((*res)[ rIx], (*src)[ s]);
2826 ++rIx;
2827 }
2828 }
2829 }
2830 } else {
2831 #pragma omp parallel if ((nEl/outerStride)*sumStride >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl/outerStride)*sumStride))
2832 {
2833 #pragma omp for
2834 for (SizeT o = 0; o < nEl; o += outerStride) {
2835 SizeT rIx = (o / outerStride) * sumStride;
2836 for (SizeT i = 0; i < sumStride; ++i) {
2837 SizeT oi = o + i;
2838 SizeT oiLimit = sumLimit + oi;
2839 for (SizeT s = oi; s < oiLimit; s += sumStride) (*res)[ rIx] += (*src)[ s];
2840 ++rIx;
2841 }
2842 }
2843 }
2844 }
2845 return res;
2846 }
2847
2848 // cumulative over one dim
2849
2850 template< typename T1, typename T2>
total_over_dim_cu_template(T1 * val,SizeT sumDimIx,bool omitNaN)2851 BaseGDL* total_over_dim_cu_template(T1* val,
2852 SizeT sumDimIx,
2853 bool omitNaN)
2854 {
2855 SizeT nEl = val->N_Elements();
2856 typename T1::Ty *res;
2857 res=static_cast<T2*>(val->DataAddr());
2858 const dimension& valDim = val->Dim();
2859 if (omitNaN) {
2860 for (SizeT i = 0; i < nEl; ++i)
2861 NaN2Zero(res[i]);
2862 }
2863 SizeT cumStride = valDim.Stride(sumDimIx);
2864 SizeT outerStride = valDim.Stride(sumDimIx + 1);
2865 for (SizeT o = 0; o < nEl; o += outerStride) {
2866 SizeT cumLimit = o + outerStride;
2867 for (SizeT i = o + cumStride, ii = o; i < cumLimit; ++i, ++ii)
2868 res[ i] += res[ ii];
2869 }
2870 return val;
2871 }
2872
total_fun(EnvT * e)2873 BaseGDL* total_fun(EnvT* e)
2874 {
2875
2876 // Integer parts initially by Erin Sheldon
2877
2878 SizeT nParam = e->NParam(1); //, "TOTAL");
2879
2880 BaseGDL* p0 = e->GetParDefined(0); //, "TOTAL");
2881
2882 SizeT nEl = p0->N_Elements();
2883 if (nEl == 0)
2884 e->Throw("Variable is undefined: " + e->GetParString(0));
2885
2886 if (p0->Type() == GDL_STRING)
2887 e->Throw("String expression not allowed "
2888 "in this context: " + e->GetParString(0));
2889
2890 static int cumIx = e->KeywordIx("CUMULATIVE");
2891 static int intIx = e->KeywordIx("INTEGER");
2892 static int doubleIx = e->KeywordIx("DOUBLE");
2893 static int nanIx = e->KeywordIx("NAN");
2894 static int preserveIx = e->KeywordIx("PRESERVE_TYPE");
2895
2896 bool cumulative = e->KeywordSet(cumIx);
2897 bool useIntegerArithmetic = e->KeywordSet(intIx);
2898 // if double is set to ZERO, then DOUBLE things are converted IN THE END to SINGLE
2899 // if double is set to 1, SINGLE things are converted to double before summing, then total is reconverted to single:
2900 // DL> a=FINDGEN(10LL^7) & z=total(a) & help,z
2901 // Z FLOAT = 4.98246e+13
2902 // DL> a=FINDGEN(10LL^7) & z=total(a,/doub) & help,z
2903 // Z DOUBLE = 4.9999995e+13
2904 // DL> a=DINDGEN(10LL^7) & z=total(a,doub=0) & help,z
2905 // Z FLOAT = 5.00000e+13
2906
2907 // PRESERVE takes precedence.
2908 // Next, INTEGER arithmetic takes precedence, and floats are individually converted to integers:
2909 // 1) ULONG64 are treated "as is" and result is like "preserve"
2910 // 2) Others are converted to LONG64 and result is LONG64. Complex values uses only real part.
2911 // /double converts individually values to doubles before summing and double=0 converts THE RESULT ONLY to single.
2912 // CUMULATIVE: If the input array is a temporary variable or an expression, and the result type matches the input type
2913 // the cumulative sum should be made in place to save memory.
2914
2915 bool doublePrecision = false;
2916 bool downgradeDoubleResult = false;
2917
2918 if (e->KeywordPresent(doubleIx)) {
2919 doublePrecision = e->KeywordSet(doubleIx);
2920 downgradeDoubleResult = !doublePrecision;
2921 }
2922
2923 bool nan = e->KeywordSet(nanIx);
2924 bool preserve = e->KeywordSet(preserveIx);
2925
2926 DLong sumDim = 0;
2927 if (nParam == 2)
2928 e->AssureLongScalarPar(1, sumDim);
2929
2930 if (sumDim == 0) {
2931 if (preserve) {
2932 if (!cumulative) {
2933 switch (p0->Type()) {
2934 case GDL_BYTE: return total_template_generic<DByteGDL>(static_cast<DByteGDL*> (p0), false);
2935 case GDL_INT: return total_template_generic<DIntGDL>(static_cast<DIntGDL*> (p0), false);
2936 case GDL_UINT: return total_template_generic<DUIntGDL>(static_cast<DUIntGDL*> (p0), false);
2937 case GDL_LONG: return total_template_generic<DLongGDL>(static_cast<DLongGDL*> (p0), false);
2938 case GDL_ULONG: return total_template_generic<DULongGDL>(static_cast<DULongGDL*> (p0), false);
2939 case GDL_LONG64: return total_template_generic<DLong64GDL>(static_cast<DLong64GDL*> (p0), false);
2940 case GDL_ULONG64: return total_template_generic<DULong64GDL>(static_cast<DULong64GDL*> (p0), false);
2941 case GDL_FLOAT: return total_template_generic<DFloatGDL>(static_cast<DFloatGDL*> (p0), nan);
2942 case GDL_DOUBLE: return total_template_generic<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), nan);
2943 case GDL_COMPLEX: return total_template_generic<DComplexGDL>(static_cast<DComplexGDL*> (p0), nan);
2944 case GDL_COMPLEXDBL: return total_template_generic<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), nan);
2945 default: assert(false);
2946 }
2947 } else {
2948 switch (p0->Type()) {
2949 case GDL_BYTE: return total_cu_template<DByteGDL,DByte>(static_cast<DByteGDL*> (p0->Dup()), false);
2950 case GDL_INT: return total_cu_template<DIntGDL,DInt>(static_cast<DIntGDL*> (p0->Dup()), false);
2951 case GDL_UINT: return total_cu_template<DUIntGDL,DUInt>(static_cast<DUIntGDL*> (p0->Dup()), false);
2952 case GDL_LONG: return total_cu_template<DLongGDL,DLong>(static_cast<DLongGDL*> (p0->Dup()), false);
2953 case GDL_ULONG: return total_cu_template<DULongGDL,DULong>(static_cast<DULongGDL*> (p0->Dup()), false);
2954 case GDL_LONG64: return total_cu_template<DLong64GDL,DLong64>(static_cast<DLong64GDL*> (p0->Dup()), false);
2955 case GDL_ULONG64: return total_cu_template<DULong64GDL,DULong64>(static_cast<DULong64GDL*> (p0->Dup()), false);
2956 case GDL_FLOAT: return total_cu_template<DFloatGDL,DFloat>(static_cast<DFloatGDL*> (p0->Dup()), nan);
2957 case GDL_DOUBLE: return total_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), nan);
2958 case GDL_COMPLEX: return total_cu_template<DComplexGDL,DComplex>(static_cast<DComplexGDL*> (p0->Dup()), nan);
2959 case GDL_COMPLEXDBL: return total_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), nan);
2960 default: assert(false);
2961 }
2962 }
2963 }
2964
2965 // Next, Integer Aritmetic
2966 if (useIntegerArithmetic) {
2967 if (!cumulative) {
2968 switch (p0->Type()) {
2969 // We use GDL_LONG64 unless the input is GDL_ULONG64
2970 case GDL_ULONG64: return total_template_generic<DULong64GDL>(static_cast<DULong64GDL*> (p0), false);
2971 case GDL_LONG64: return total_template_generic<DLong64GDL>(static_cast<DLong64GDL*> (p0), false);
2972 case GDL_BYTE: return total_template_integer<DByteGDL>(static_cast<DByteGDL*> (p0));
2973 case GDL_INT: return total_template_integer<DIntGDL>(static_cast<DIntGDL*> (p0));
2974 case GDL_UINT: return total_template_integer<DUIntGDL>(static_cast<DUIntGDL*> (p0));
2975 case GDL_LONG: return total_template_integer<DLongGDL>(static_cast<DLongGDL*> (p0));
2976 case GDL_ULONG: return total_template_integer<DULongGDL>(static_cast<DULongGDL*> (p0));
2977 case GDL_FLOAT: return total_template_integer<DFloatGDL>(static_cast<DFloatGDL*> (p0));
2978 case GDL_DOUBLE: return total_template_integer<DDoubleGDL>(static_cast<DDoubleGDL*> (p0));
2979 case GDL_COMPLEX:
2980 case GDL_COMPLEXDBL:
2981 // Convert to Long64 OR write a variant of total_template_integer...
2982 {
2983 DLong64GDL* p0L64 = static_cast<DLong64GDL*> (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
2984 Guard<DLong64GDL> guard(p0L64);
2985 return total_template_generic<DLong64GDL>(p0L64, false);
2986 }
2987 default: assert(false);
2988 }
2989
2990 } else {
2991 switch (p0->Type()) {
2992 case GDL_ULONG64: return total_cu_template<DULong64GDL,DULong64>(static_cast<DULong64GDL*> (p0->Dup()), false);
2993 case GDL_LONG64: return total_cu_template<DLong64GDL,DLong64>(static_cast<DLong64GDL*> (p0->Dup()), false);
2994 case GDL_BYTE:
2995 case GDL_INT:
2996 case GDL_UINT:
2997 case GDL_LONG:
2998 case GDL_ULONG:
2999 case GDL_FLOAT:
3000 case GDL_DOUBLE:
3001 case GDL_COMPLEX:
3002 case GDL_COMPLEXDBL:
3003 {
3004 DLong64GDL* p0L64 = static_cast<DLong64GDL*> (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
3005 return total_cu_template<DLong64GDL,DLong64>(p0L64, false);
3006 }
3007 default: assert(false);
3008 }
3009 }
3010 } // integer result
3011
3012 // Next, upgrade single values, and downgrade result if needed
3013 if (doublePrecision) {
3014 if (!cumulative) {
3015 switch (p0->Type()) {
3016 case GDL_DOUBLE: return total_template_generic<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), nan);
3017 case GDL_COMPLEXDBL: return total_template_generic<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), nan);
3018 // We use GDL_DOUBLE for others
3019 case GDL_ULONG64:
3020 return total_template_double<DULong64GDL>(static_cast<DULong64GDL*> (p0), false);
3021 case GDL_LONG64:
3022 return total_template_double<DLong64GDL>(static_cast<DLong64GDL*> (p0), false);
3023 case GDL_BYTE:
3024 return total_template_double<DByteGDL>(static_cast<DByteGDL*> (p0), false);
3025 case GDL_INT:
3026 return total_template_double<DIntGDL>(static_cast<DIntGDL*> (p0), false);
3027 case GDL_UINT:
3028 return total_template_double<DUIntGDL>(static_cast<DUIntGDL*> (p0), false);
3029 case GDL_LONG:
3030 return total_template_double<DLongGDL>(static_cast<DLongGDL*> (p0), false);
3031 case GDL_ULONG:
3032 return total_template_double<DULongGDL>(static_cast<DULongGDL*> (p0), false);
3033 case GDL_FLOAT:
3034 return total_template_double<DFloatGDL>(static_cast<DFloatGDL*> (p0), nan);
3035 case GDL_COMPLEX:
3036 {
3037 DComplexDblGDL* p0Double = static_cast<DComplexDblGDL*> (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY));
3038 Guard<DComplexDblGDL> guard(p0Double);
3039 return total_template_generic<DComplexDblGDL>(p0Double, nan);
3040 }
3041 default: assert(false);
3042 }
3043 } else {
3044 switch (p0->Type()) {
3045 case GDL_DOUBLE: return total_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), nan);
3046 case GDL_COMPLEXDBL: return total_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), nan);
3047 // We use GDL_DOUBLE for others
3048 case GDL_FLOAT:
3049 // Conver to Double
3050 {
3051 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3052 return total_cu_template<DDoubleGDL,DDouble>(p0Double, nan);
3053 }
3054 case GDL_ULONG64:
3055 case GDL_LONG64:
3056 case GDL_BYTE:
3057 case GDL_INT:
3058 case GDL_UINT:
3059 case GDL_LONG:
3060 case GDL_ULONG:
3061 // Conver to Double
3062 {
3063 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3064 return total_cu_template<DDoubleGDL,DDouble>(p0Double, false);
3065 }
3066 case GDL_COMPLEX:
3067 {
3068 DComplexDblGDL* p0Double = static_cast<DComplexDblGDL*> (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY));
3069 return total_cu_template<DComplexDblGDL,DComplexDbl>(p0Double, nan);
3070 }
3071 default: assert(false);
3072 }
3073 }
3074 }
3075 else { //does not promote, but eventually downgrade double results if downgradeDoubleResult is true
3076 // note integer conversion is in doubles, not floats (verified).
3077 if (!cumulative) {
3078 switch (p0->Type()) {
3079 case GDL_FLOAT: return total_template_generic<DFloatGDL>(static_cast<DFloatGDL*> (p0), nan);
3080 case GDL_DOUBLE:
3081 {
3082 if (downgradeDoubleResult) {
3083 return (total_template_generic<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), nan))->Convert2(GDL_FLOAT, BaseGDL::COPY);
3084 } else return total_template_generic<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), nan);
3085 }
3086 case GDL_COMPLEX: return total_template_generic<DComplexGDL>(static_cast<DComplexGDL*> (p0), nan);
3087 case GDL_COMPLEXDBL: if (downgradeDoubleResult) {
3088 return (total_template_generic<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), nan))->Convert2(GDL_COMPLEX, BaseGDL::COPY);
3089 } else return total_template_generic<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), nan);
3090 // convert to double, total then return double or float...
3091 case GDL_ULONG64:
3092 {
3093 DDoubleGDL* res = total_template_double<DULong64GDL>(static_cast<DULong64GDL*> (p0), false);
3094 if (downgradeDoubleResult) {
3095 return res->Convert2(GDL_FLOAT, BaseGDL::CONVERT);
3096 } else return res;
3097 }
3098 case GDL_LONG64:
3099 {
3100 DDoubleGDL* res = total_template_double<DLong64GDL>(static_cast<DLong64GDL*> (p0), false);
3101 if (downgradeDoubleResult) {
3102 return res->Convert2(GDL_FLOAT, BaseGDL::CONVERT);
3103 } else return res;
3104 }
3105 // We use GDL_FLOAT for others
3106 case GDL_BYTE:
3107 return total_template_single<DByteGDL>(static_cast<DByteGDL*> (p0), false);
3108 case GDL_INT:
3109 return total_template_single<DIntGDL>(static_cast<DIntGDL*> (p0), false);
3110 case GDL_UINT:
3111 return total_template_single<DUIntGDL>(static_cast<DUIntGDL*> (p0), false);
3112 case GDL_LONG:
3113 return total_template_single<DLongGDL>(static_cast<DLongGDL*> (p0), false);
3114 case GDL_ULONG:
3115 return total_template_single<DULongGDL>(static_cast<DULongGDL*> (p0), false);
3116 default: assert(false);
3117 }
3118 } else {
3119 switch (p0->Type()) {
3120 case GDL_FLOAT: return total_cu_template<DFloatGDL,DFloat>(static_cast<DFloatGDL*> (p0->Dup()), nan);
3121 case GDL_DOUBLE:
3122 {
3123 if (downgradeDoubleResult) {
3124 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (total_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), nan));
3125 Guard<DDoubleGDL> guard(p0Double);
3126 return (p0Double)->Convert2(GDL_FLOAT, BaseGDL::COPY);
3127 } else
3128 return total_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), nan);
3129 }
3130 case GDL_COMPLEX: return total_cu_template<DComplexGDL,DComplex>(static_cast<DComplexGDL*> (p0->Dup()), nan);
3131 case GDL_COMPLEXDBL: if (downgradeDoubleResult) {
3132 DComplexGDL* p0Cpx = static_cast<DComplexGDL*> (total_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), nan));
3133 Guard<DComplexGDL> guard(p0Cpx);
3134 return (p0Cpx)->Convert2(GDL_COMPLEX, BaseGDL::COPY);
3135 } else
3136 return total_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), nan);
3137 // convert to double, total then return double or float...
3138 case GDL_ULONG64:
3139 case GDL_LONG64:
3140 {
3141 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3142 if (downgradeDoubleResult) {
3143 DDoubleGDL* tmp = static_cast<DDoubleGDL*> (total_cu_template<DDoubleGDL,DDouble>(p0Double, false));
3144 Guard<DDoubleGDL> guard(tmp);
3145 return (tmp)->Convert2(GDL_FLOAT, BaseGDL::COPY);
3146 } else
3147 return total_cu_template<DDoubleGDL,DDouble>(p0Double, false);
3148 }
3149 // We use GDL_FLOAT for others
3150 case GDL_BYTE:
3151 case GDL_INT:
3152 case GDL_UINT:
3153 case GDL_LONG:
3154 case GDL_ULONG:
3155 {
3156 DFloatGDL* p0Single = static_cast<DFloatGDL*> (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3157 return total_cu_template<DFloatGDL,DFloat>(p0Single, false);
3158 }
3159 default: assert(false);
3160 }
3161 }
3162 }
3163 assert(false);
3164 }
3165
3166 // SUM Over a dimension.
3167
3168 // total over sumDim
3169 dimension srcDim = p0->Dim();
3170 SizeT srcRank = srcDim.Rank();
3171
3172 if (sumDim < 1 || sumDim > srcRank)
3173 e->Throw(
3174 "Array must have " + i2s(sumDim) +
3175 " dimensions: " + e->GetParString(0));
3176
3177 // Preserve , fast , has preference .
3178 if (preserve) {
3179 if (!cumulative) {
3180 switch (p0->Type()) {
3181 case GDL_BYTE: return total_over_dim_template<DByteGDL>(static_cast<DByteGDL*> (p0), srcDim, sumDim - 1, false);
3182 case GDL_INT: return total_over_dim_template<DIntGDL>(static_cast<DIntGDL*> (p0), srcDim, sumDim - 1, false);
3183 case GDL_UINT: return total_over_dim_template<DUIntGDL>(static_cast<DUIntGDL*> (p0), srcDim, sumDim - 1, false);
3184 case GDL_LONG: return total_over_dim_template<DLongGDL>(static_cast<DLongGDL*> (p0), srcDim, sumDim - 1, false);
3185 case GDL_ULONG: return total_over_dim_template<DULongGDL>(static_cast<DULongGDL*> (p0), srcDim, sumDim - 1, false);
3186 case GDL_LONG64: return total_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*> (p0), srcDim, sumDim - 1, false);
3187 case GDL_ULONG64: return total_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*> (p0), srcDim, sumDim - 1, false);
3188 case GDL_FLOAT: return total_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*> (p0), srcDim, sumDim - 1, nan);
3189 case GDL_DOUBLE: return total_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), srcDim, sumDim - 1, nan);
3190 case GDL_COMPLEX: return total_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*> (p0), srcDim, sumDim - 1, nan);
3191 case GDL_COMPLEXDBL: return total_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), srcDim, sumDim - 1, nan);
3192 default: assert(false);
3193 }
3194 } else {
3195 switch (p0->Type()) {
3196 case GDL_BYTE: return total_over_dim_cu_template<DByteGDL,DByte>(static_cast<DByteGDL*> (p0->Dup()), sumDim - 1, false);
3197 case GDL_INT: return total_over_dim_cu_template<DIntGDL,DInt>(static_cast<DIntGDL*> (p0->Dup()), sumDim - 1, false);
3198 case GDL_UINT: return total_over_dim_cu_template<DUIntGDL,DUInt>(static_cast<DUIntGDL*> (p0->Dup()), sumDim - 1, false);
3199 case GDL_LONG: return total_over_dim_cu_template<DLongGDL,DLong>(static_cast<DLongGDL*> (p0->Dup()), sumDim - 1, false);
3200 case GDL_ULONG: return total_over_dim_cu_template<DULongGDL,DULong>(static_cast<DULongGDL*> (p0->Dup()), sumDim - 1, false);
3201 case GDL_LONG64: return total_over_dim_cu_template<DLong64GDL,DLong64>(static_cast<DLong64GDL*> (p0->Dup()), sumDim - 1, false);
3202 case GDL_ULONG64: return total_over_dim_cu_template<DULong64GDL,DULong64>(static_cast<DULong64GDL*> (p0->Dup()), sumDim - 1, false);
3203 case GDL_FLOAT: return total_over_dim_cu_template<DFloatGDL,DFloat>(static_cast<DFloatGDL*> (p0->Dup()), sumDim - 1, nan);
3204 case GDL_DOUBLE: return total_over_dim_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), sumDim - 1, nan);
3205 case GDL_COMPLEX: return total_over_dim_cu_template<DComplexGDL,DComplex>(static_cast<DComplexGDL*> (p0->Dup()), sumDim - 1, nan);
3206 case GDL_COMPLEXDBL: return total_over_dim_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), sumDim - 1, nan);
3207 default: assert(false);
3208 }
3209 }
3210 }
3211 // Next, Integer Aritmetic
3212 if (useIntegerArithmetic) {
3213 if (!cumulative) {
3214 switch (p0->Type()) {
3215 case GDL_ULONG64: return total_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*> (p0), srcDim, sumDim - 1, false);
3216 case GDL_LONG64: return total_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*> (p0), srcDim, sumDim - 1, false);
3217 // We use GDL_LONG64 unless the input is GDL_ULONG64
3218 case GDL_BYTE:
3219 case GDL_INT:
3220 case GDL_UINT:
3221 case GDL_LONG:
3222 case GDL_ULONG:
3223 case GDL_FLOAT:
3224 case GDL_DOUBLE:
3225 case GDL_COMPLEX:
3226 case GDL_COMPLEXDBL:
3227 // Conver to Long64
3228 {
3229 DLong64GDL* p0L64 = static_cast<DLong64GDL*> (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
3230 Guard<DLong64GDL> guard(p0L64);
3231 return total_over_dim_template<DLong64GDL>(p0L64, srcDim, sumDim - 1, false);
3232 }
3233 default: assert(false);
3234 }
3235
3236 } else {
3237 switch (p0->Type()) {
3238 case GDL_ULONG64: return total_over_dim_cu_template<DULong64GDL,DULong64>(static_cast<DULong64GDL*> (p0->Dup()), sumDim - 1, false);
3239 case GDL_LONG64: return total_over_dim_cu_template<DLong64GDL,DLong64>(static_cast<DLong64GDL*> (p0->Dup()), sumDim - 1, false);
3240 case GDL_BYTE:
3241 case GDL_INT:
3242 case GDL_UINT:
3243 case GDL_LONG:
3244 case GDL_ULONG:
3245 case GDL_FLOAT:
3246 case GDL_DOUBLE:
3247 case GDL_COMPLEX:
3248 case GDL_COMPLEXDBL:
3249 {
3250 DLong64GDL* p0L64 = static_cast<DLong64GDL*> (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
3251 return total_over_dim_cu_template<DLong64GDL,DLong64>(p0L64, sumDim - 1, false);
3252 }
3253 default: assert(false);
3254 }
3255 }
3256 } // integer result
3257
3258 // Next, upgrade single values, and downgrade result if needed
3259 if (doublePrecision) {
3260 if (!cumulative) {
3261 switch (p0->Type()) {
3262 case GDL_DOUBLE: return total_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), srcDim, sumDim - 1, nan);
3263 case GDL_COMPLEXDBL: return total_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), srcDim, sumDim - 1, nan);
3264 // We use GDL_DOUBLE for others
3265 case GDL_FLOAT:
3266 // Conver to Double
3267 {
3268 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3269 Guard<DDoubleGDL> guard(p0Double);
3270 return total_over_dim_template<DDoubleGDL>(p0Double, srcDim, sumDim - 1, nan);
3271 }
3272 case GDL_ULONG64:
3273 case GDL_LONG64:
3274 case GDL_BYTE:
3275 case GDL_INT:
3276 case GDL_UINT:
3277 case GDL_LONG:
3278 case GDL_ULONG:
3279 // Conver to Double
3280 {
3281 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3282 Guard<DDoubleGDL> guard(p0Double);
3283 return total_over_dim_template<DDoubleGDL>(p0Double, srcDim, sumDim - 1, false);
3284 }
3285 case GDL_COMPLEX:
3286 {
3287 DComplexDblGDL* p0Double = static_cast<DComplexDblGDL*> (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY));
3288 Guard<DComplexDblGDL> guard(p0Double);
3289 return total_over_dim_template<DComplexDblGDL>(p0Double, srcDim, sumDim - 1, nan);
3290 }
3291 default: assert(false);
3292 }
3293 } else {
3294 switch (p0->Type()) {
3295 case GDL_DOUBLE: return total_over_dim_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), sumDim - 1, nan);
3296 case GDL_COMPLEXDBL: return total_over_dim_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), sumDim - 1, nan);
3297 // We use GDL_DOUBLE for others
3298 case GDL_FLOAT:
3299 // Conver to Double
3300 {
3301 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3302 return total_over_dim_cu_template<DDoubleGDL,DDouble>(p0Double, sumDim - 1, nan);
3303 }
3304 case GDL_ULONG64:
3305 case GDL_LONG64:
3306 case GDL_BYTE:
3307 case GDL_INT:
3308 case GDL_UINT:
3309 case GDL_LONG:
3310 case GDL_ULONG:
3311 // Conver to Double
3312 {
3313 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3314 return total_over_dim_cu_template<DDoubleGDL,DDouble>(p0Double, sumDim - 1, false);
3315 }
3316 case GDL_COMPLEX:
3317 {
3318 DComplexDblGDL* p0Cpx = static_cast<DComplexDblGDL*> (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY));
3319 return total_over_dim_cu_template<DComplexDblGDL,DComplexDbl>(p0Cpx, sumDim - 1, nan);
3320 }
3321 default: assert(false);
3322 }
3323 }
3324 }// promote to double
3325 else { //does not promote, but eventually downgrade double results if downgradeDoubleResult is true
3326 if (!cumulative) {
3327 switch (p0->Type()) {
3328 case GDL_FLOAT: return total_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*> (p0), srcDim, sumDim - 1, nan);
3329 case GDL_DOUBLE:
3330 {
3331 if (downgradeDoubleResult) {
3332 return (total_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), srcDim, sumDim - 1, nan))->Convert2(GDL_FLOAT, BaseGDL::COPY);
3333 } else return total_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), srcDim, sumDim - 1, nan);
3334 }
3335 case GDL_COMPLEX: return total_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*> (p0), srcDim, sumDim - 1, nan);
3336 case GDL_COMPLEXDBL: if (downgradeDoubleResult) {
3337 return (total_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), srcDim, sumDim - 1, nan))->Convert2(GDL_COMPLEX, BaseGDL::COPY);
3338 } else return total_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), srcDim, sumDim - 1, nan);
3339 // convert to double, total_over_dim then return double or float...
3340 case GDL_ULONG64:
3341 case GDL_LONG64:
3342 {
3343 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3344 Guard<DDoubleGDL> guard(p0Double);
3345 if (downgradeDoubleResult) {
3346 return (total_over_dim_template<DDoubleGDL>(p0Double, srcDim, sumDim - 1, false))->Convert2(GDL_FLOAT, BaseGDL::COPY);
3347 } else return total_over_dim_template<DDoubleGDL>(p0Double, srcDim, sumDim - 1, false);
3348 }
3349 // We use GDL_FLOAT for others
3350 case GDL_BYTE:
3351 case GDL_INT:
3352 case GDL_UINT:
3353 case GDL_LONG:
3354 case GDL_ULONG:
3355 {
3356 DFloatGDL* p0Single = static_cast<DFloatGDL*> (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3357 Guard<DFloatGDL> guard(p0Single);
3358 return total_over_dim_template<DFloatGDL>(p0Single, srcDim, sumDim - 1, false);
3359 }
3360 default: assert(false);
3361 }
3362 } else {
3363 switch (p0->Type()) {
3364 case GDL_FLOAT: return total_over_dim_cu_template<DFloatGDL,DFloat>(static_cast<DFloatGDL*> (p0->Dup()), sumDim - 1, nan);
3365 case GDL_DOUBLE:
3366 {
3367 if (downgradeDoubleResult) {
3368 DDoubleGDL* tmp = static_cast<DDoubleGDL*> (total_over_dim_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), sumDim - 1, nan));
3369 Guard<DDoubleGDL> guard(tmp);
3370 return tmp->Convert2(GDL_FLOAT, BaseGDL::COPY);
3371 } else return total_over_dim_cu_template<DDoubleGDL,DDouble>(static_cast<DDoubleGDL*> (p0->Dup()), sumDim - 1, nan);
3372 }
3373 case GDL_COMPLEX: return total_over_dim_cu_template<DComplexGDL,DComplex>(static_cast<DComplexGDL*> (p0->Dup()), sumDim - 1, nan);
3374 case GDL_COMPLEXDBL: if (downgradeDoubleResult) {
3375 DComplexDblGDL* tmp = static_cast<DComplexDblGDL*> (total_over_dim_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), sumDim - 1, nan));
3376 Guard<DComplexDblGDL> guard(tmp);
3377 return tmp->Convert2(GDL_COMPLEX, BaseGDL::COPY);
3378 } else return total_over_dim_cu_template<DComplexDblGDL,DComplexDbl>(static_cast<DComplexDblGDL*> (p0->Dup()), sumDim - 1, nan);
3379 // convert to double, total_over_dim then return double or float...
3380 case GDL_ULONG64:
3381 case GDL_LONG64:
3382 {
3383 DDoubleGDL* p0Double = static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3384 if (downgradeDoubleResult) {
3385 Guard<DDoubleGDL> guard(p0Double);
3386 return (total_over_dim_cu_template<DDoubleGDL,DDouble>(p0Double, sumDim - 1, false))->Convert2(GDL_FLOAT, BaseGDL::COPY);
3387 } else return total_over_dim_cu_template<DDoubleGDL,DDouble>(p0Double, sumDim - 1, false);
3388 }
3389 // We use GDL_FLOAT for others
3390 case GDL_BYTE:
3391 case GDL_INT:
3392 case GDL_UINT:
3393 case GDL_LONG:
3394 case GDL_ULONG:
3395 {
3396 DFloatGDL* p0Single = static_cast<DFloatGDL*> (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3397 return total_over_dim_cu_template<DFloatGDL,DFloat>(p0Single, sumDim - 1, false);
3398 }
3399 default: assert(false);
3400 }
3401 }
3402 }
3403 assert(false);
3404 return NULL;
3405 }
3406
3407
3408 // passing 2nd argument by value is slightly better for float and double,
3409 // but incur some overhead for the complex class.
MultOmitNaN(T & dest,T value)3410 template<class T> inline void MultOmitNaN(T& dest, T value)
3411 {
3412 if (std::isfinite(value))
3413 {
3414 // #pragma omp atomic
3415 dest *= value;
3416 }
3417 }
MultOmitNaNCpx(T & dest,T value)3418 template<class T> inline void MultOmitNaNCpx(T& dest, T value)
3419 {
3420 dest *= T(std::isfinite(value.real())? value.real() : 1,
3421 std::isfinite(value.imag())? value.imag() : 1);
3422 }
MultOmitNaN(DComplex & dest,DComplex value)3423 template<> inline void MultOmitNaN(DComplex& dest, DComplex value)
3424 { MultOmitNaNCpx<DComplex>(dest, value); }
MultOmitNaN(DComplexDbl & dest,DComplexDbl value)3425 template<> inline void MultOmitNaN(DComplexDbl& dest, DComplexDbl value)
3426 { MultOmitNaNCpx<DComplexDbl>(dest, value); }
3427
Nan2One(T & value)3428 template<class T> inline void Nan2One(T& value)
3429 { if (!std::isfinite(value)) value = 1; }
Nan2OneCpx(T & value)3430 template<class T> inline void Nan2OneCpx(T& value)
3431 {
3432 value = T(std::isfinite(value.real())? value.real() : 1,
3433 std::isfinite(value.imag())? value.imag() : 1);
3434 }
Nan2One(DComplex & value)3435 template<> inline void Nan2One(DComplex& value)
3436 { Nan2OneCpx< DComplex>(value); }
Nan2One(DComplexDbl & value)3437 template<> inline void Nan2One(DComplexDbl& value)
3438 { Nan2OneCpx< DComplexDbl>(value); }
3439
3440 // product over all elements
3441 template<class T>
product_template(T * src,bool omitNaN)3442 BaseGDL* product_template(T* src, bool omitNaN) {
3443 typename T::Ty prod = 1;
3444 SizeT nEl = src->N_Elements();
3445 if (!omitNaN) {
3446
3447 TRACEOMP(__FILE__, __LINE__)
3448 #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(prod)
3449 {
3450 #pragma omp for reduction(*:prod)
3451 for (OMPInt i = 0; i < nEl; ++i) {
3452 prod *= (*src)[ i];
3453 }
3454 }
3455 } else {
3456
3457 TRACEOMP(__FILE__, __LINE__)
3458 #pragma omp parallel if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl)) shared(prod)
3459 {
3460 #pragma omp for reduction(*:prod)
3461 for (OMPInt i = 0; i < nEl; ++i) {
3462 MultOmitNaN(prod, (*src)[ i]);
3463 }
3464 }
3465 }
3466 return new T(prod);
3467 }
3468
3469 template<>
product_template(DComplexGDL * src,bool omitNaN)3470 BaseGDL* product_template( DComplexGDL* src, bool omitNaN) {
3471 DComplexGDL::Ty prod = 1;
3472 SizeT nEl = src->N_Elements();
3473 if (!omitNaN) {
3474 for (SizeT i = 0; i < nEl; ++i) {
3475 prod *= (*src)[ i];
3476 }
3477 } else {
3478 for (SizeT i = 0; i < nEl; ++i) {
3479 MultOmitNaN(prod, (*src)[ i]);
3480 }
3481 }
3482 return new DComplexGDL(prod);
3483 }
3484
3485 template<>
product_template(DComplexDblGDL * src,bool omitNaN)3486 BaseGDL* product_template( DComplexDblGDL* src, bool omitNaN) {
3487 DComplexDblGDL::Ty prod = 1;
3488 SizeT nEl = src->N_Elements();
3489 if (!omitNaN) {
3490 for (SizeT i = 0; i < nEl; ++i) {
3491 prod *= (*src)[ i];
3492 }
3493 } else {
3494 for (SizeT i = 0; i < nEl; ++i) {
3495 MultOmitNaN(prod, (*src)[ i]);
3496 }
3497 }
3498 return new DComplexDblGDL(prod);
3499 }
3500
3501 // cumulative over all dims
3502 template<typename T>
product_cu_template(T * res,bool omitNaN)3503 BaseGDL* product_cu_template( T* res, bool omitNaN) {
3504 SizeT nEl = res->N_Elements();
3505 if (omitNaN) {
3506 for (SizeT i = 0; i < nEl; ++i)
3507 Nan2One((*res)[i]);
3508 }
3509 for (SizeT i = 1, ii = 0; i < nEl; ++i, ++ii)
3510 (*res)[i] *= (*res)[ii];
3511 return res;
3512 }
3513
3514 // product over one dim
3515 template< typename T>
product_over_dim_template(T * src,const dimension & srcDim,SizeT prodDimIx,bool omitNaN)3516 BaseGDL* product_over_dim_template( T* src,
3517 const dimension& srcDim,
3518 SizeT prodDimIx,
3519 bool omitNaN) {
3520 SizeT nEl = src->N_Elements();
3521
3522 // get dest dim and number of products
3523 dimension destDim = srcDim;
3524 SizeT nProd = destDim.Remove(prodDimIx);
3525
3526 T* res = new T(destDim, BaseGDL::NOZERO);
3527
3528 // prodStride is also the number of linear src indexing
3529 SizeT prodStride = srcDim.Stride(prodDimIx);
3530 SizeT outerStride = srcDim.Stride(prodDimIx + 1);
3531 SizeT prodLimit = nProd * prodStride;
3532 if (omitNaN) {
3533 #pragma omp parallel if ((nEl/outerStride)*prodStride >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl/outerStride)*prodStride))
3534 {
3535 #pragma omp for
3536 for (SizeT o = 0; o < nEl; o += outerStride) {
3537 SizeT rIx = (o / outerStride) * prodStride;
3538 for (SizeT i = 0; i < prodStride; ++i) {
3539 (*res)[ rIx] = 1;
3540 SizeT oi = o + i;
3541 SizeT oiLimit = prodLimit + oi;
3542 for (SizeT s = oi; s < oiLimit; s += prodStride) MultOmitNaN((*res)[ rIx], (*src)[ s]);
3543 ++rIx;
3544 }
3545 }
3546 }
3547 } else {
3548 #pragma omp parallel if ((nEl/outerStride)*prodStride >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl/outerStride)*prodStride))
3549 {
3550 #pragma omp for
3551 for (SizeT o = 0; o < nEl; o += outerStride) {
3552 SizeT rIx = (o / outerStride) * prodStride;
3553 for (SizeT i = 0; i < prodStride; ++i) {
3554 (*res)[ rIx] = 1;
3555 SizeT oi = o + i;
3556 SizeT oiLimit = prodLimit + oi;
3557 for (SizeT s = oi; s < oiLimit; s += prodStride) (*res)[ rIx] *= (*src)[ s];
3558 ++rIx;
3559 }
3560 }
3561 }
3562 }
3563 return res;
3564 }
3565
3566 // cumulative over one dim
3567 template< typename T>
product_over_dim_cu_template(T * res,SizeT sumDimIx,bool omitNaN)3568 BaseGDL* product_over_dim_cu_template( T* res,
3569 SizeT sumDimIx,
3570 bool omitNaN) {
3571 SizeT nEl = res->N_Elements();
3572 const dimension& resDim = res->Dim();
3573 if (omitNaN) {
3574 for (SizeT i = 0; i < nEl; ++i)
3575 Nan2One((*res)[i]);
3576 }
3577 SizeT cumStride = resDim.Stride(sumDimIx);
3578 SizeT outerStride = resDim.Stride(sumDimIx + 1);
3579 for (SizeT o = 0; o < nEl; o += outerStride) {
3580 SizeT cumLimit = o + outerStride;
3581 for (SizeT i = o + cumStride, ii = o; i < cumLimit; ++i, ++ii)
3582 (*res)[ i] *= (*res)[ ii];
3583 }
3584 return res;
3585 }
3586
product_fun(EnvT * e)3587 BaseGDL* product_fun( EnvT* e) {
3588 SizeT nParam = e->NParam(1);
3589
3590 BaseGDL* p0 = e->GetParDefined(0);
3591
3592 SizeT nEl = p0->N_Elements();
3593 if (nEl == 0)
3594 e->Throw("Variable is undefined: " + e->GetParString(0));
3595
3596 if (p0->Type() == GDL_STRING)
3597 e->Throw("String expression not allowed "
3598 "in this context: " + e->GetParString(0));
3599
3600 static int cumIx = e->KeywordIx("CUMULATIVE");
3601 static int nanIx = e->KeywordIx("NAN");
3602 static int intIx = e->KeywordIx("INTEGER");
3603 static int preIx = e->KeywordIx("PRESERVE_TYPE");
3604 bool KwCumul = e->KeywordSet(cumIx);
3605 bool KwNaN = e->KeywordSet(nanIx);
3606 bool KwInt = e->KeywordSet(intIx);
3607 bool KwPre = e->KeywordSet(preIx);
3608 bool nanInt = false;
3609
3610 DLong sumDim = 0;
3611 if (nParam == 2)
3612 e->AssureLongScalarPar(1, sumDim);
3613
3614 if (sumDim == 0) {
3615 if (!KwCumul) {
3616 if (KwPre) {
3617 switch (p0->Type()) {
3618 case GDL_BYTE: return product_template<DByteGDL>(static_cast<DByteGDL*> (p0), nanInt);
3619 case GDL_INT: return product_template<DIntGDL>(static_cast<DIntGDL*> (p0), nanInt);
3620 case GDL_UINT: return product_template<DUIntGDL>(static_cast<DUIntGDL*> (p0), nanInt);
3621 case GDL_LONG: return product_template<DLongGDL>(static_cast<DLongGDL*> (p0), nanInt);
3622 case GDL_ULONG: return product_template<DULongGDL>(static_cast<DULongGDL*> (p0), nanInt);
3623 case GDL_LONG64: return product_template<DLong64GDL>(static_cast<DLong64GDL*> (p0), nanInt);
3624 case GDL_ULONG64: return product_template<DULong64GDL>(static_cast<DULong64GDL*> (p0), nanInt);
3625 case GDL_FLOAT: return product_template<DFloatGDL>(static_cast<DFloatGDL*> (p0), KwNaN);
3626 case GDL_DOUBLE: return product_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), KwNaN);
3627 case GDL_COMPLEX: return product_template<DComplexGDL>(static_cast<DComplexGDL*> (p0), KwNaN);
3628 case GDL_COMPLEXDBL: return product_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), KwNaN);
3629 default: assert(false);
3630 }
3631 }
3632
3633 // Integer parts derivated from Total code by Erin Sheldon
3634 // In IDL PRODUCT(), the INTEGER keyword takes precedence
3635 if (KwInt) {
3636 // We use GDL_LONG64 unless the input is GDL_ULONG64
3637 if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {
3638 return product_template<DLong64GDL>
3639 (static_cast<DLong64GDL*> (p0), nanInt);
3640 }
3641 if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {
3642 return product_template<DULong64GDL>
3643 (static_cast<DULong64GDL*> (p0), nanInt);
3644 }
3645
3646 // Convert to Long64
3647 DLong64GDL* p0L64 = static_cast<DLong64GDL*>
3648 (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
3649 Guard<DLong64GDL> guard(p0L64);
3650 if (KwNaN) {
3651 DFloatGDL* p0f = static_cast<DFloatGDL*>
3652 (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3653 Guard<DFloatGDL> guard(p0f);
3654 for (SizeT i = 0; i < nEl; ++i) {
3655 if (!std::isfinite((*p0f)[i])) (*p0L64)[i] = 1;
3656 }
3657 }
3658 return product_template<DLong64GDL>(p0L64, nanInt);
3659 } // integer results
3660
3661 if (p0->Type() == GDL_DOUBLE) {
3662 return product_template<DDoubleGDL>
3663 (static_cast<DDoubleGDL*> (p0), KwNaN);
3664 }
3665 if (p0->Type() == GDL_COMPLEXDBL) {
3666 return product_template<DComplexDblGDL>
3667 (static_cast<DComplexDblGDL*> (p0), KwNaN);
3668 }
3669 if (p0->Type() == GDL_COMPLEX) {
3670 DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>
3671 (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY));
3672 Guard<DComplexDblGDL> p0D_guard(p0D);
3673 //p0D_guard.Reset( p0D);
3674 return product_template<DComplexDblGDL>(p0D, KwNaN);
3675 }
3676
3677 DDoubleGDL* p0D = static_cast<DDoubleGDL*>
3678 (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3679 Guard<DDoubleGDL> p0D_guard(p0D);
3680 // p0D_guard.Reset( p0D);
3681 return product_template<DDoubleGDL>(p0D, KwNaN);
3682 }
3683 else { // KwCumul
3684
3685 if (KwPre) {
3686 switch (p0->Type()) {
3687 case GDL_BYTE: return product_cu_template<DByteGDL>(static_cast<DByteGDL*> (p0->Dup()), nanInt);
3688 case GDL_INT: return product_cu_template<DIntGDL>(static_cast<DIntGDL*> (p0->Dup()), nanInt);
3689 case GDL_UINT: return product_cu_template<DUIntGDL>(static_cast<DUIntGDL*> (p0->Dup()), nanInt);
3690 case GDL_LONG: return product_cu_template<DLongGDL>(static_cast<DLongGDL*> (p0->Dup()), nanInt);
3691 case GDL_ULONG: return product_cu_template<DULongGDL>(static_cast<DULongGDL*> (p0->Dup()), nanInt);
3692 case GDL_LONG64: return product_cu_template<DLong64GDL>(static_cast<DLong64GDL*> (p0->Dup()), nanInt);
3693 case GDL_ULONG64: return product_cu_template<DULong64GDL>(static_cast<DULong64GDL*> (p0->Dup()), nanInt);
3694 case GDL_FLOAT: return product_cu_template<DFloatGDL>(static_cast<DFloatGDL*> (p0->Dup()), KwNaN);
3695 case GDL_DOUBLE: return product_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0->Dup()), KwNaN);
3696 case GDL_COMPLEX: return product_cu_template<DComplexGDL>(static_cast<DComplexGDL*> (p0->Dup()), KwNaN);
3697 case GDL_COMPLEXDBL: return product_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0->Dup()), KwNaN);
3698 default: assert(false);
3699 }
3700 }
3701
3702 // Integer parts derivated from Total code by Erin Sheldon
3703 // In IDL PRODUCT(), the INTEGER keyword takes precedence
3704 if (KwInt) {
3705 // We use GDL_LONG64 unless the input is GDL_ULONG64
3706 if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {
3707 return product_cu_template<DLong64GDL>
3708 (static_cast<DLong64GDL*> (p0->Dup()), nanInt);
3709 }
3710 if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {
3711 return product_cu_template<DULong64GDL>
3712 (static_cast<DULong64GDL*> (p0->Dup()), nanInt);
3713 }
3714 // Convert to Long64
3715 DLong64GDL* p0L64 = static_cast<DLong64GDL*>
3716 (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
3717 Guard<DLong64GDL> guard(p0L64);
3718 if (KwNaN) {
3719 DFloatGDL* p0f = static_cast<DFloatGDL*>
3720 (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3721 Guard<DFloatGDL> guard(p0f);
3722 for (SizeT i = 0; i < nEl; ++i) {
3723 if (!std::isfinite((*p0f)[i])) (*p0L64)[i] = 1;
3724 }
3725 }
3726 return product_cu_template<DLong64GDL>
3727 (static_cast<DLong64GDL*> (p0L64->Dup()), nanInt);
3728 } // integer results
3729
3730 // special case as GDL_DOUBLE type overrides /GDL_DOUBLE
3731 if (p0->Type() == GDL_DOUBLE) {
3732 return product_cu_template< DDoubleGDL>
3733 (static_cast<DDoubleGDL*> (p0->Dup()), KwNaN);
3734 }
3735 if (p0->Type() == GDL_COMPLEXDBL) {
3736 return product_cu_template< DComplexDblGDL>
3737 (static_cast<DComplexDblGDL*> (p0->Dup()), KwNaN);
3738 }
3739 if (p0->Type() == GDL_COMPLEX) {
3740 return product_cu_template< DComplexDblGDL>
3741 (static_cast<DComplexDblGDL*>
3742 (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY)), KwNaN);
3743 }
3744 return product_cu_template< DDoubleGDL>
3745 (static_cast<DDoubleGDL*>
3746 (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY)), KwNaN);
3747 }
3748 }
3749
3750 // product over sumDim
3751 dimension srcDim = p0->Dim();
3752 SizeT srcRank = srcDim.Rank();
3753
3754 if (sumDim < 1 || sumDim > srcRank)
3755 e->Throw("Array must have " + i2s(sumDim) +
3756 " dimensions: " + e->GetParString(0));
3757
3758 if (!KwCumul) {
3759
3760 if (KwPre) {
3761 switch (p0->Type()) {
3762 case GDL_BYTE: return product_over_dim_template<DByteGDL>(static_cast<DByteGDL*> (p0), srcDim, sumDim - 1, nanInt);
3763 case GDL_INT: return product_over_dim_template<DIntGDL>(static_cast<DIntGDL*> (p0), srcDim, sumDim - 1, nanInt);
3764 case GDL_UINT: return product_over_dim_template<DUIntGDL>(static_cast<DUIntGDL*> (p0), srcDim, sumDim - 1, nanInt);
3765 case GDL_LONG: return product_over_dim_template<DLongGDL>(static_cast<DLongGDL*> (p0), srcDim, sumDim - 1, nanInt);
3766 case GDL_ULONG: return product_over_dim_template<DULongGDL>(static_cast<DULongGDL*> (p0), srcDim, sumDim - 1, nanInt);
3767 case GDL_LONG64: return product_over_dim_template<DLong64GDL>(static_cast<DLong64GDL*> (p0), srcDim, sumDim - 1, nanInt);
3768 case GDL_ULONG64: return product_over_dim_template<DULong64GDL>(static_cast<DULong64GDL*> (p0), srcDim, sumDim - 1, nanInt);
3769 case GDL_FLOAT: return product_over_dim_template<DFloatGDL>(static_cast<DFloatGDL*> (p0), srcDim, sumDim - 1, KwNaN);
3770 case GDL_DOUBLE: return product_over_dim_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0), srcDim, sumDim - 1, KwNaN);
3771 case GDL_COMPLEX: return product_over_dim_template<DComplexGDL>(static_cast<DComplexGDL*> (p0), srcDim, sumDim - 1, KwNaN);
3772 case GDL_COMPLEXDBL: return product_over_dim_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0), srcDim, sumDim - 1, KwNaN);
3773 default: assert(false);
3774 }
3775 }
3776
3777 // Integer parts derivated from Total code by Erin Sheldon
3778 // In IDL PRODUCT(), the INTEGER keyword takes precedence
3779 if (KwInt) {
3780 // We use GDL_LONG64 unless the input is GDL_ULONG64
3781 if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {
3782 return product_over_dim_template<DLong64GDL>
3783 (static_cast<DLong64GDL*> (p0), srcDim, sumDim - 1, nanInt);
3784 }
3785 if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {
3786 return product_over_dim_template<DULong64GDL>
3787 (static_cast<DULong64GDL*> (p0), srcDim, sumDim - 1, nanInt);
3788 }
3789
3790 // Conver to Long64
3791 DLong64GDL* p0L64 = static_cast<DLong64GDL*>
3792 (p0->Convert2(GDL_LONG64, BaseGDL::COPY));
3793 Guard<DLong64GDL> guard(p0L64);
3794 if (KwNaN) {
3795 DFloatGDL* p0f = static_cast<DFloatGDL*>
3796 (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3797 Guard<DFloatGDL> guard(p0f);
3798 for (SizeT i = 0; i < nEl; ++i) {
3799 if (!std::isfinite((*p0f)[i])) (*p0L64)[i] = 1;
3800 }
3801 }
3802 return product_over_dim_template<DLong64GDL>
3803 (p0L64, srcDim, sumDim - 1, nanInt);
3804 } // integer results
3805
3806 if (p0->Type() == GDL_DOUBLE) {
3807 return product_over_dim_template< DDoubleGDL>
3808 (static_cast<DDoubleGDL*> (p0), srcDim, sumDim - 1, KwNaN);
3809 }
3810 if (p0->Type() == GDL_COMPLEXDBL) {
3811 return product_over_dim_template< DComplexDblGDL>
3812 (static_cast<DComplexDblGDL*> (p0), srcDim, sumDim - 1, KwNaN);
3813 }
3814 if (p0->Type() == GDL_COMPLEX) {
3815 DComplexDblGDL* p0D = static_cast<DComplexDblGDL*>
3816 (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY));
3817 Guard<DComplexDblGDL> p0D_guard(p0D);
3818 // p0D_guard.Reset( p0D);
3819 return product_over_dim_template< DComplexDblGDL>
3820 (p0D, srcDim, sumDim - 1, KwNaN);
3821 }
3822
3823 DDoubleGDL* p0D = static_cast<DDoubleGDL*>
3824 (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
3825 Guard<DDoubleGDL> p0D_guard(p0D);
3826 //p0D_guard.Reset( p0D);
3827 return product_over_dim_template< DDoubleGDL>
3828 (p0D, srcDim, sumDim - 1, KwNaN);
3829 }
3830 else { // KwCumul
3831
3832 if (KwPre) {
3833 switch (p0->Type()) {
3834 case GDL_BYTE: return product_over_dim_cu_template<DByteGDL>(static_cast<DByteGDL*> (p0->Dup()), sumDim - 1, nanInt);
3835 case GDL_INT: return product_over_dim_cu_template<DIntGDL>(static_cast<DIntGDL*> (p0->Dup()), sumDim - 1, nanInt);
3836 case GDL_UINT: return product_over_dim_cu_template<DUIntGDL>(static_cast<DUIntGDL*> (p0->Dup()), sumDim - 1, nanInt);
3837 case GDL_LONG: return product_over_dim_cu_template<DLongGDL>(static_cast<DLongGDL*> (p0->Dup()), sumDim - 1, nanInt);
3838 case GDL_ULONG: return product_over_dim_cu_template<DULongGDL>(static_cast<DULongGDL*> (p0->Dup()), sumDim - 1, nanInt);
3839 case GDL_LONG64: return product_over_dim_cu_template<DLong64GDL>(static_cast<DLong64GDL*> (p0->Dup()), sumDim - 1, nanInt);
3840 case GDL_ULONG64: return product_over_dim_cu_template<DULong64GDL>(static_cast<DULong64GDL*> (p0->Dup()), sumDim - 1, nanInt);
3841 case GDL_FLOAT: return product_over_dim_cu_template<DFloatGDL>(static_cast<DFloatGDL*> (p0->Dup()), sumDim - 1, KwNaN);
3842 case GDL_DOUBLE: return product_over_dim_cu_template<DDoubleGDL>(static_cast<DDoubleGDL*> (p0->Dup()), sumDim - 1, KwNaN);
3843 case GDL_COMPLEX: return product_over_dim_cu_template<DComplexGDL>(static_cast<DComplexGDL*> (p0->Dup()), sumDim - 1, KwNaN);
3844 case GDL_COMPLEXDBL: return product_over_dim_cu_template<DComplexDblGDL>(static_cast<DComplexDblGDL*> (p0->Dup()), sumDim - 1, KwNaN);
3845 default: assert(false);
3846 }
3847 }
3848
3849 // Integer parts derivated from Total code by Erin Sheldon
3850 // In IDL PRODUCT(), the INTEGER keyword takes precedence
3851 if (KwInt) {
3852 // We use GDL_LONG64 unless the input is GDL_ULONG64
3853 if ((p0->Type() == GDL_LONG64) && (!KwNaN)) {
3854 return product_over_dim_cu_template<DLong64GDL>
3855 (static_cast<DLong64GDL*> (p0->Dup()), sumDim - 1, nanInt);
3856 }
3857 if ((p0->Type() == GDL_ULONG64) && (!KwNaN)) {
3858 return product_over_dim_cu_template<DULong64GDL>
3859 (static_cast<DULong64GDL*> (p0->Dup()), sumDim - 1, nanInt);
3860 }
3861
3862 // Convert to Long64
3863 if (KwNaN) {
3864 DFloatGDL* p0f = static_cast<DFloatGDL*>
3865 (p0->Convert2(GDL_FLOAT, BaseGDL::COPY));
3866 Guard<DFloatGDL> guard(p0f);
3867 for (SizeT i = 0; i < nEl; ++i) {
3868 if (!std::isfinite((*p0f)[i])) (*p0f)[i] = 1;
3869 }
3870 return product_over_dim_cu_template<DLong64GDL>
3871 (static_cast<DLong64GDL*>
3872 (p0f->Convert2(GDL_LONG64, BaseGDL::COPY)), sumDim - 1, nanInt);
3873 } else {
3874 return product_over_dim_cu_template<DLong64GDL>
3875 (static_cast<DLong64GDL*>
3876 (p0->Convert2(GDL_LONG64, BaseGDL::COPY)), sumDim - 1, nanInt);
3877 }
3878 } // integer results
3879
3880 if (p0->Type() == GDL_DOUBLE) {
3881 return product_over_dim_cu_template< DDoubleGDL>
3882 (static_cast<DDoubleGDL*> (p0->Dup()), sumDim - 1, KwNaN);
3883 }
3884 if (p0->Type() == GDL_COMPLEXDBL) {
3885 return product_over_dim_cu_template< DComplexDblGDL>
3886 (static_cast<DComplexDblGDL*> (p0->Dup()), sumDim - 1, KwNaN);
3887 }
3888 if (p0->Type() == GDL_COMPLEX) {
3889 return product_over_dim_cu_template< DComplexDblGDL>
3890 (static_cast<DComplexDblGDL*>
3891 (p0->Convert2(GDL_COMPLEXDBL, BaseGDL::COPY)), sumDim - 1, KwNaN);
3892 }
3893
3894 return product_over_dim_cu_template< DDoubleGDL>
3895 (static_cast<DDoubleGDL*>
3896 (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY)), sumDim - 1, KwNaN);
3897 }
3898 }
3899 // servicing array_equal and also gdl_container::equals
array_equal_bool(BaseGDL * p0,BaseGDL * p1,bool notypeconv=false,bool not_equal=false,bool quiet=true)3900 bool array_equal_bool( BaseGDL* p0, BaseGDL* p1,
3901 bool notypeconv=false, bool not_equal=false,
3902 bool quiet=true)
3903 {
3904
3905 if( p0 == p1) return true;
3906 if( p0==0 or p1==0) return false;
3907 SizeT nEl0 = p0->N_Elements();
3908 SizeT nEl1 = p1->N_Elements();
3909
3910 // first case : arrays with differents size (>1)
3911 if (nEl0 != nEl1 && nEl0 != 1 && nEl1 != 1)
3912 return false;
3913
3914 // if one of input has only one element, it should NOt be an array
3915 // ARRAY_EQUAL(1,[1,1]) True, ARRAY_EQUAL([1],[1,1]) False !!
3916 if (nEl0 != nEl1) {
3917 if (nEl0 == 1 && nEl1 != 1) {
3918 if (!p0->StrictScalar()) return false;
3919 }
3920 if (nEl0 != 1 && nEl1 == 1) {
3921 if (!p1->StrictScalar()) return false;
3922 }
3923 }
3924
3925 //cout << "pO "<< p0->Dim() << " p1 "<< p1->Dim() << endl;
3926 //cout << "pO "<< p0->StrictScalar() << " p1 "<< p1->StrictScalar() << endl;
3927 DType aTy=p0->Type();
3928 DType bTy=p1->Type();
3929
3930 if( aTy==GDL_STRUCT or bTy==GDL_STRUCT) {
3931 if(quiet) return false;
3932 throw GDLException("array_equal: inconvertable GDL_STRUCT");
3933 }
3934
3935 Guard<BaseGDL> p0_guard;
3936 Guard<BaseGDL> p1_guard;
3937
3938 if( ( aTy==GDL_PTR and bTy==GDL_PTR) or
3939 ( aTy==GDL_OBJ and bTy==GDL_OBJ) ) {
3940 Data_<SpDULong64>* p0t =
3941 static_cast<Data_<SpDULong64>* >( p0);
3942 if( not_equal) return p0t->ArrayNeverEqual( p1);
3943 else return p0t->ArrayEqual( p1);
3944 }
3945 else if( aTy==GDL_PTR or bTy==GDL_PTR) {
3946 if(quiet) return false;
3947 throw GDLException("array_equal: GDL_PTR only with PTR");
3948 }
3949 else if( aTy==GDL_OBJ or bTy==GDL_OBJ) {
3950 if(quiet) return false;
3951 throw GDLException("array_equal: GDL_OBJ only with OBJ");
3952 }
3953 else if( aTy != bTy)
3954 {
3955 if( notypeconv) // NO_TYPECONV
3956 return false;
3957 else
3958 {
3959 if( !ConvertableType( aTy) or !ConvertableType( bTy)) {
3960 if(quiet) return false;
3961 throw GDLException("array_equal: inconvertable type");
3962 }
3963 else if( DTypeOrder[aTy] >= DTypeOrder[bTy])
3964 {
3965 p1 = p1->Convert2(aTy, BaseGDL::COPY);
3966 p1_guard.Reset(p1);
3967 } else {
3968 p0 = p0->Convert2(bTy, BaseGDL::COPY);
3969 p0_guard.Reset(p0);
3970 }
3971 }
3972 }
3973 if( not_equal) return p0->ArrayNeverEqual( p1);
3974 else return p0->ArrayEqual( p1);
3975 }
3976
array_equal(EnvT * e)3977 BaseGDL* array_equal( EnvT* e)
3978 {
3979 e->NParam( 2);
3980 // trace_me = trace_arg();
3981 static int notypeconvIx = e->KeywordIx("NO_TYPECONV");
3982 static int notequalIx = e->KeywordIx("NOT_EQUAL");
3983 static int quietIx = e->KeywordIx("QUIET");
3984 // if(trace_me) cout << " array=? ";
3985 BaseGDL* p0 = e->GetParDefined( 0);
3986 BaseGDL* p1 = e->GetParDefined( 1);
3987
3988 bool result = array_equal_bool(p0, p1,
3989 e->KeywordSet( notypeconvIx), e->KeywordSet( notequalIx),
3990 e->KeywordSet( quietIx));
3991 // if(trace_me) cout << result<< endl;
3992 return new DByteGDL( result ? 1 : 0 );
3993 }
3994
min_fun(EnvT * e)3995 BaseGDL* min_fun( EnvT* e) {
3996 SizeT nParam = e->NParam(1);
3997 BaseGDL* searchArr = e->GetParDefined(0);
3998
3999 static int omitNaNIx = e->KeywordIx("NAN");
4000 bool omitNaN = e->KeywordSet(omitNaNIx);
4001
4002 static int subIx = e->KeywordIx("SUBSCRIPT_MAX");
4003 bool subMax = e->KeywordPresent(subIx);
4004
4005 static int dimIx = e->KeywordIx("DIMENSION");
4006 bool dimSet = e->KeywordSet(dimIx);
4007
4008 static int maxIx = e->KeywordIx("MAX");
4009 bool maxSet = e->KeywordPresent(maxIx);
4010
4011 static int absIx= e->KeywordIx("ABSOLUTE");
4012 bool absSet = e->KeywordSet(absIx); // not KeywordPresent as it should be ignored if not set.
4013
4014 DLong searchDim;
4015 if (dimSet) {
4016 e->AssureLongScalarKW(dimIx, searchDim);
4017 if (searchDim < 0 || searchDim > searchArr->Rank())
4018 e->Throw("Illegal keyword value for DIMENSION");
4019 }
4020
4021 if (dimSet && searchArr->Rank() > 1) {
4022 searchDim -= 1; // user-supplied dimensions start with 1!
4023
4024 // here destDim is in fact the srcDim...
4025 dimension destDim = searchArr->Dim();
4026 SizeT searchStride = destDim.Stride(searchDim);
4027 SizeT outerStride = destDim.Stride(searchDim + 1);
4028 // ... and now becomes the destDim
4029 SizeT nSearch = destDim.Remove(searchDim);
4030 SizeT searchLimit = nSearch * searchStride;
4031 SizeT nEl = searchArr->N_Elements();
4032
4033 // memory allocation
4034 BaseGDL *maxVal, *resArr = searchArr->New(destDim, BaseGDL::NOZERO);
4035 DLongGDL *minElArr=NULL, *maxElArr=NULL;
4036
4037 if (maxSet) {
4038 e->AssureGlobalKW(maxIx); // instead of using a guard pointer
4039 maxVal = searchArr->New(destDim, BaseGDL::NOZERO);
4040 }
4041
4042 if (subMax) {
4043 e->AssureGlobalKW(subIx); // instead of using a guard pointer
4044 maxElArr = new DLongGDL(destDim);
4045 }
4046
4047 if (nParam == 2) {
4048 e->AssureGlobalPar(1); // instead of using a guard pointer
4049 minElArr = new DLongGDL(destDim);
4050 }
4051
4052 SizeT rIx = 0;
4053 #pragma omp parallel if ((nEl/outerStride)*searchStride >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl/outerStride)*searchStride))
4054 {
4055 #pragma omp for
4056 for (SizeT o = 0; o < nEl; o += outerStride) {
4057 SizeT rIx = (o / outerStride) * searchStride;
4058 for (SizeT i = 0; i < searchStride; ++i) {
4059 searchArr->MinMax(
4060 (nParam == 2 ? &((*minElArr)[rIx]) : NULL),
4061 (subMax ? &((*maxElArr)[rIx]) : NULL),
4062 &resArr,
4063 (maxSet ? &maxVal : NULL),
4064 omitNaN, o + i, searchLimit + o + i, searchStride, rIx, absSet
4065 );
4066 rIx++;
4067 }
4068 }
4069 }
4070 if (nParam == 2) e->SetPar(1, minElArr);
4071 if (subMax) e->SetKW(subIx, maxElArr);
4072 if (maxSet) e->SetKW(maxIx, maxVal);
4073
4074 return resArr;
4075 }
4076 else {
4077 DLong minEl;
4078 BaseGDL* res;
4079
4080 if (maxSet) // MAX keyword given
4081 {
4082 e->AssureGlobalKW(0);
4083 GDLDelete(e->GetKW(0));
4084 DLong maxEl;
4085 searchArr->MinMax(&minEl, &maxEl, &res, &e->GetKW(0), omitNaN, 0, 0, 1, -1, absSet);
4086 if (subMax) e->SetKW(subIx, new DLongGDL(maxEl));
4087 } else // no MAX keyword
4088 {
4089 if (subMax) {
4090 DLong maxEl;
4091 searchArr->MinMax(&minEl, &maxEl, &res, NULL, omitNaN, 0, 0, 1, -1, absSet);
4092 e->SetKW(subIx, new DLongGDL(maxEl));
4093 } else searchArr->MinMax(&minEl, NULL, &res, NULL, omitNaN, 0, 0, 1, -1, absSet);
4094 }
4095
4096 // handle index
4097 if (nParam == 2) e->SetPar(1, new DLongGDL(minEl));
4098 else SysVar::SetC(minEl);
4099 return res;
4100 }
4101 }
4102
max_fun(EnvT * e)4103 BaseGDL* max_fun( EnvT* e) {
4104 SizeT nParam = e->NParam(1);
4105 BaseGDL* searchArr = e->GetParDefined(0);
4106
4107 static int omitNaNIx = e->KeywordIx("NAN");
4108 bool omitNaN = e->KeywordSet(omitNaNIx);
4109
4110 static int subIx = e->KeywordIx("SUBSCRIPT_MIN");
4111 bool subMin = e->KeywordPresent(subIx);
4112
4113 static int dimIx = e->KeywordIx("DIMENSION");
4114 bool dimSet = e->KeywordSet(dimIx);
4115
4116 static int minIx = e->KeywordIx("MIN");
4117 bool minSet = e->KeywordPresent(minIx);
4118
4119 static int absIx= e->KeywordIx("ABSOLUTE");
4120 bool absSet = e->KeywordSet(absIx); // not KeywordPresent as it should be ignored if not set.
4121
4122 DLong searchDim;
4123 if (dimSet) {
4124 e->AssureLongScalarKW(dimIx, searchDim);
4125 if (searchDim < 0 || searchDim > searchArr->Rank())
4126 e->Throw("Illegal keyword value for DIMENSION");
4127 }
4128
4129 if (dimSet && searchArr->Rank() > 1) {
4130 searchDim -= 1; // user-supplied dimensions start with 1!
4131
4132 // here destDim is in fact the srcDim...
4133 dimension destDim = searchArr->Dim();
4134 SizeT searchStride = destDim.Stride(searchDim);
4135 SizeT outerStride = destDim.Stride(searchDim + 1);
4136 // ... and now becomes the destDim
4137 SizeT nSearch = destDim.Remove(searchDim);
4138 SizeT searchLimit = nSearch * searchStride;
4139 SizeT nEl = searchArr->N_Elements();
4140
4141 // memory allocation
4142 BaseGDL *minVal, *resArr = searchArr->New(destDim, BaseGDL::NOZERO);
4143 DLongGDL *minElArr=NULL, *maxElArr=NULL;
4144
4145 if (minSet) {
4146 e->AssureGlobalKW(minIx); // instead of using a guard pointer
4147 minVal = searchArr->New(destDim, BaseGDL::NOZERO);
4148 }
4149
4150 if (subMin) {
4151 e->AssureGlobalKW(subIx); // instead of using a guard pointer
4152 minElArr = new DLongGDL(destDim);
4153 }
4154
4155 if (nParam == 2) {
4156 e->AssureGlobalPar(1); // instead of using a guard pointer
4157 maxElArr = new DLongGDL(destDim);
4158 }
4159
4160 #pragma omp parallel if ((nEl/outerStride)*searchStride >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= (nEl/outerStride)*searchStride))
4161 {
4162 #pragma omp for
4163 for (SizeT o = 0; o < nEl; o += outerStride) {
4164 SizeT rIx = (o/outerStride)*searchStride;
4165 for (SizeT i = 0; i < searchStride; ++i) {
4166 searchArr->MinMax(
4167 (subMin ? &((*minElArr)[rIx]) : NULL),
4168 (nParam == 2 ? &((*maxElArr)[rIx]) : NULL),
4169 (minSet ? &minVal : NULL),
4170 &resArr,
4171 omitNaN, o + i, searchLimit + o + i, searchStride, rIx, absSet
4172 );
4173 rIx++;
4174 }
4175 }
4176 }
4177 if (nParam == 2) e->SetPar(1, maxElArr);
4178 if (subMin) e->SetKW(subIx, minElArr);
4179 if (minSet) e->SetKW(minIx, minVal);
4180
4181 return resArr;
4182 } else {
4183 DLong maxEl;
4184 BaseGDL* res;
4185
4186 if (minSet) // MIN keyword given
4187 {
4188 e->AssureGlobalKW(0);
4189 GDLDelete(e->GetKW(0));
4190 DLong minEl;
4191 searchArr->MinMax(&minEl, &maxEl, &e->GetKW(0), &res, omitNaN, 0, 0, 1, -1, absSet);
4192 if (subMin) e->SetKW(subIx, new DLongGDL(minEl));
4193 } else // no MIN keyword
4194 {
4195 if (subMin) {
4196 DLong minEl;
4197 searchArr->MinMax(&minEl, &maxEl, NULL, &res, omitNaN, 0, 0, 1, -1, absSet);
4198 e->SetKW(subIx, new DLongGDL(minEl));
4199 } else searchArr->MinMax(NULL, &maxEl, NULL, &res, omitNaN, 0, 0, 1, -1, absSet);
4200 }
4201
4202 // handle index
4203 if (nParam == 2) e->SetPar(1, new DLongGDL(maxEl));
4204 else SysVar::SetC(maxEl);
4205 return res;
4206 }
4207 }
4208
transpose(EnvT * e)4209 BaseGDL* transpose( EnvT* e)
4210 {
4211 SizeT nParam=e->NParam( 1);
4212
4213 BaseGDL* p0 = e->GetParDefined( 0);
4214 if( p0->Type() == GDL_STRUCT)
4215 e->Throw("Struct expression not allowed in this context: "+
4216 e->GetParString(0));
4217
4218 SizeT rank = p0->Rank();
4219 if( rank == 0)
4220 e->Throw( "Expression must be an array "
4221 "in this context: "+ e->GetParString(0));
4222
4223 if( nParam == 2)
4224 {
4225
4226 BaseGDL* p1 = e->GetParDefined( 1);
4227 if( p1->N_Elements() != rank)
4228 e->Throw("Incorrect number of elements in permutation.");
4229
4230 DUInt* perm = new DUInt[rank];
4231 ArrayGuard<DUInt> perm_guard( perm);
4232
4233 DUIntGDL* p1L = static_cast<DUIntGDL*>
4234 (p1->Convert2( GDL_UINT, BaseGDL::COPY));
4235 for( SizeT i=0; i<rank; ++i) perm[i] = (*p1L)[ i];
4236 GDLDelete(p1L);
4237
4238 // check permutation vector
4239 for( SizeT i=0; i<rank; ++i)
4240 {
4241 DUInt j;
4242 for( j=0; j<rank; ++j) if( perm[j] == i) break;
4243 if (j == rank)
4244 e->Throw( "Incorrect permutation vector.");
4245 }
4246 return p0->Transpose( perm);
4247 }
4248
4249 return p0->Transpose( NULL);
4250 }
4251
4252
4253 // BaseGDL* matrix_multiply( EnvT* e)
4254 // {
4255 // SizeT nParam=e->NParam( 2);
4256 //
4257 // BaseGDL* a = e->GetNumericArrayParDefined( 0);
4258 // BaseGDL* b = e->GetNumericArrayParDefined( 1);
4259 //
4260 // static int aTIx = e->KeywordIx("ATRANSPOSE");
4261 // bool aT = e->KeywordPresent(aTIx);
4262 // static int bTIx = e->KeywordIx("BTRANSPOSE");
4263 // bool bT = e->KeywordPresent(bTIx);
4264 //
4265 // static int strassenIx = e->KeywordIx("STRASSEN_ALGORITHM");
4266 // bool strassen = e->KeywordPresent(strassenIx);
4267 //
4268 //
4269 // if( p1->N_Elements() != rank)
4270 // e->Throw("Incorrect number of elements in permutation.");
4271 //
4272 // DUInt* perm = new DUInt[rank];
4273 // Guard<DUInt> perm_guard( perm);
4274 //
4275 // DUIntGDL* p1L = static_cast<DUIntGDL*>
4276 // (p1->Convert2( GDL_UINT, BaseGDL::COPY));
4277 // for( SizeT i=0; i<rank; ++i) perm[i] = (*p1L)[ i];
4278 // delete p1L;
4279 //
4280 // // check permutaion vector
4281 // for( SizeT i=0; i<rank; ++i)
4282 // {
4283 // DUInt j;
4284 // for( j=0; j<rank; ++j) if( perm[j] == i) break;
4285 // if (j == rank)
4286 // e->Throw( "Incorrect permutation vector.");
4287 // }
4288 // return p0->Transpose( perm);
4289 // }
4290 //
4291 // return a->Transpose( NULL);
4292 // }
4293
4294 // helper function for sort_fun, recursive
4295 // optimized version
4296 template< typename IndexT>
MergeSortOpt(BaseGDL * p0,IndexT * hhS,IndexT * h1,IndexT * h2,SizeT len)4297 void MergeSortOpt( BaseGDL* p0, IndexT* hhS, IndexT* h1, IndexT* h2,
4298 SizeT len)
4299 {
4300 if( len <= 1) return;
4301
4302 SizeT h1N = len / 2;
4303 SizeT h2N = len - h1N;
4304
4305 // 1st half
4306 MergeSortOpt(p0, hhS, h1, h2, h1N);
4307
4308 // 2nd half
4309 IndexT* hhM = &hhS[h1N];
4310 MergeSortOpt(p0, hhM, h1, h2, h2N);
4311
4312 SizeT i;
4313 for(i=0; i<h1N; ++i) h1[i] = hhS[ i];
4314 for(i=0; i<h2N; ++i) h2[i] = hhM[ i];
4315
4316 SizeT h1Ix = 0;
4317 SizeT h2Ix = 0;
4318 for( i=0; (h1Ix < h1N) && (h2Ix < h2N); ++i)
4319 {
4320 // the actual comparisson
4321 if( p0->Greater( h1[h1Ix], h2[h2Ix]))
4322 hhS[ i] = h2[ h2Ix++];
4323 else
4324 hhS[ i] = h1[ h1Ix++];
4325 }
4326 for(; h1Ix < h1N; ++i) hhS[ i] = h1[ h1Ix++];
4327 for(; h2Ix < h2N; ++i) hhS[ i] = h2[ h2Ix++];
4328 }
4329
4330 // start of highly-optimized median code. 1D and 2D fast medians are in medianfilter.cpp, gathered from
4331 // recent sources. see the include file for explanations & copyrights.
4332 #include "medianfilter.cpp"
4333 /*
4334 * Following routines are variants of the algorithm described in
4335 * "Numerical recipes in C", Second Edition,
4336 * Cambridge University Press, 1992, Section 8.5, ISBN 0-521-43108-5
4337 * Original code by Nicolas Devillard - 1998. Public domain.
4338 * Modified by G. Duvert, 2017, for NaN/INF handling and correction of Nicolas's code
4339 * which gave erroneous results when two or more elements were identical.
4340 */
4341 #define ELEM_SWAP(a,b) { DDouble t=(a);(a)=(b);(b)=t; }
4342
quick_select_d(DDouble array[],SizeT arraySize,int even)4343 DDouble quick_select_d(DDouble array[], SizeT arraySize, int even) {
4344
4345 if (arraySize==1) return array[0];
4346
4347 SizeT high, low, middle;
4348 SizeT median=(arraySize)/2;
4349 SizeT ll, hh;
4350 DDouble pivot;
4351 low = 0;
4352 high = arraySize-1;
4353 for (;;) {
4354 if (high <= low + 1) {
4355 if (high == low + 1 && array[high] < array[low]) {
4356 ELEM_SWAP(array[low], array[high])
4357 }
4358 if (even) return 0.5*(array[median]+array[median-1]); else return array[median];
4359 } else {
4360 middle = (low + high) /2 ;
4361 ELEM_SWAP(array[middle], array[low + 1])
4362 if (array[low] > array[high]) {
4363 ELEM_SWAP(array[low], array[high])
4364 }
4365 if (array[low + 1] > array[high]) {
4366 ELEM_SWAP(array[low + 1], array[high])
4367 }
4368 if (array[low] > array[low + 1]) {
4369 ELEM_SWAP(array[low], array[low + 1])
4370 }
4371 ll = low + 1;
4372 hh = high;
4373 pivot = array[low + 1];
4374 for (;;) {
4375 do ll++; while (array[ll] < pivot);
4376 do hh--; while (array[hh] > pivot);
4377 if (hh < ll) break;
4378 ELEM_SWAP(array[ll], array[hh])
4379 }
4380 array[low + 1] = array[hh];
4381 array[hh] = pivot;
4382 if (hh >= median) high = hh - 1;
4383 if (hh <= median) low = ll;
4384 }
4385 }
4386
4387 }
4388
4389 #undef ELEM_SWAP
4390 #define ELEM_SWAP(a,b) { DFloat t=(a);(a)=(b);(b)=t; }
4391
quick_select_f(DFloat array[],SizeT arraySize,int even)4392 DFloat quick_select_f(DFloat array[], SizeT arraySize, int even) {
4393
4394 if (arraySize==1) return array[0];
4395
4396 SizeT high, low, middle;
4397 SizeT median=(arraySize)/2;
4398 SizeT ll, hh;
4399 DFloat pivot;
4400 low = 0;
4401 high = arraySize-1;
4402 for (;;) {
4403 if (high <= low + 1) {
4404 if (high == low + 1 && array[high] < array[low]) {
4405 ELEM_SWAP(array[low], array[high])
4406 }
4407 if (even) return 0.5*(array[median]+array[median-1]); else return array[median];
4408 } else {
4409 middle = (low + high) /2 ;
4410 ELEM_SWAP(array[middle], array[low + 1])
4411 if (array[low] > array[high]) {
4412 ELEM_SWAP(array[low], array[high])
4413 }
4414 if (array[low + 1] > array[high]) {
4415 ELEM_SWAP(array[low + 1], array[high])
4416 }
4417 if (array[low] > array[low + 1]) {
4418 ELEM_SWAP(array[low], array[low + 1])
4419 }
4420 ll = low + 1;
4421 hh = high;
4422 pivot = array[low + 1];
4423 for (;;) {
4424 do ll++; while (array[ll] < pivot);
4425 do hh--; while (array[hh] > pivot);
4426 if (hh < ll) break;
4427 ELEM_SWAP(array[ll], array[hh])
4428 }
4429 array[low + 1] = array[hh];
4430 array[hh] = pivot;
4431 if (hh >= median) high = hh - 1;
4432 if (hh <= median) low = ll;
4433 }
4434 }
4435
4436 }
4437
4438 #undef ELEM_SWAP
4439 //input-protected versions of above
quick_select_f_protect_input(const DFloat data[],SizeT arraySize,int even)4440 DFloat quick_select_f_protect_input(const DFloat data[], SizeT arraySize, int even) {
4441 DFloat * array=(DFloat*)malloc(arraySize*sizeof(DFloat));
4442 for (SizeT i = 0; i < arraySize; ++i) array[i]=data[i];
4443 DFloat res=quick_select_f(array, arraySize, even);
4444 free(array);
4445 return res;
4446 }
quick_select_d_protect_input(const DDouble data[],SizeT arraySize,int even)4447 DDouble quick_select_d_protect_input(const DDouble data[], SizeT arraySize, int even) {
4448 DDouble * array=(DDouble*)malloc(arraySize*sizeof(DDouble));
4449 for (SizeT i = 0; i < arraySize; ++i) array[i]=data[i];
4450 DDouble res=quick_select_d(array, arraySize, even);
4451 free(array);
4452 return res;
4453 }
4454
4455 //simple median for double arrays with no NaNs.
mymedian_d(EnvT * e)4456 inline BaseGDL* mymedian_d(EnvT* e) {
4457 DDoubleGDL* array = e->GetParAs<DDoubleGDL>(0)->Dup(); //original array is protected
4458 SizeT nEl = array->N_Elements();
4459 static int evenIx = e->KeywordIx("EVEN");
4460 int iseven = ((nEl % 2) == 0 && e->KeywordSet(evenIx));
4461 BaseGDL *res = new DDoubleGDL(quick_select_d((DDouble*) array->DataAddr(), nEl, iseven));
4462
4463 delete array;
4464
4465 return res;
4466 }
4467
4468 //simple median for double arrays whith NaNs. Remove the Nans before doing the median.
mymedian_d_nan(EnvT * e)4469 inline BaseGDL* mymedian_d_nan(EnvT* e) {
4470 DDoubleGDL* data = e->GetParAs<DDoubleGDL>(0); //original array is protected
4471 SizeT nEl = data->N_Elements();
4472 DLong iEl = 0;
4473 DDouble * array=(DDouble*)malloc(nEl*sizeof(DDouble));
4474 for (SizeT i = 0; i < data->N_Elements(); ++i) {
4475 if(!isnan( (*data)[i]) ) {
4476 array[iEl] = (*data)[i];
4477 iEl++;
4478 }
4479 }
4480 if (iEl == 0) {
4481 free(array);
4482 return new DDoubleGDL(std::numeric_limits<double>::quiet_NaN());
4483 }
4484 static int evenIx = e->KeywordIx("EVEN");
4485 int iseven = (((iEl + 1) % 2) == 0 && e->KeywordSet(evenIx));
4486 BaseGDL *res = new DDoubleGDL(quick_select_d(array, iEl, iseven));
4487 free(array);
4488 return res;
4489 }
4490 //simple median for double arrays whith NaNs. Remove the Nans before doing the median.
quick_select_d_filter_nan(const DDouble * arr,SizeT nEl,int even)4491 inline DDouble quick_select_d_filter_nan( const DDouble* arr, SizeT nEl, int even) {
4492 DLong iEl = 0;
4493 DDouble* array=(DDouble*)malloc(nEl*sizeof(DDouble));
4494 for (SizeT i = 0; i < nEl; ++i) {
4495 if (!isnan( arr[i]) ) {
4496 array[iEl] = arr[i];
4497 iEl++;
4498 }
4499 }
4500 if (iEl == 0) {
4501 free(array);
4502 return std::numeric_limits<double>::quiet_NaN();
4503 }
4504 DDouble res=quick_select_d(array, iEl, even);
4505 free(array);
4506 return res;
4507 }
4508
hasnan_d(DDouble * arr,SizeT nEl)4509 inline bool hasnan_d( DDouble* arr, SizeT nEl) {
4510 for (SizeT i=0; i< nEl; ++i) if (isnan( arr[i])) return true;
4511 return false;
4512 }
4513
mymedian_f(EnvT * e)4514 inline BaseGDL* mymedian_f(EnvT* e) {
4515 DFloatGDL* array = e->GetParAs<DFloatGDL>(0)->Dup(); //original array is protected
4516 SizeT nEl = array->N_Elements();
4517
4518 static int evenIx = e->KeywordIx("EVEN");
4519 int iseven=((nEl % 2) == 0 && e->KeywordSet(evenIx));
4520 BaseGDL *res = new DFloatGDL(quick_select_f((DFloat*) array->DataAddr(), nEl, iseven));
4521
4522 delete array;
4523
4524 return res;
4525 }
4526
mymedian_f_nan(EnvT * e)4527 inline BaseGDL* mymedian_f_nan(EnvT* e) {
4528 DFloatGDL* data = e->GetParAs<DFloatGDL>(0); //original array is protected
4529 SizeT nEl = data->N_Elements();
4530 DLong iEl = 0;
4531 DFloat * array=(DFloat*)malloc(nEl*sizeof(DFloat));
4532 for (SizeT i = 0; i < data->N_Elements(); ++i) {
4533 if (!isnan( (*data)[i]) ) {
4534 array[iEl] = (*data)[i];
4535 iEl++;
4536 }
4537 }
4538 if (iEl == 0) {
4539 free(array);
4540 return new DFloatGDL(std::numeric_limits<float>::quiet_NaN());
4541 }
4542 static int evenIx = e->KeywordIx("EVEN");
4543 int iseven = (((iEl + 1) % 2) == 0 && e->KeywordSet(evenIx));
4544 BaseGDL *res = new DFloatGDL(quick_select_f(array, iEl, iseven));
4545 free(array);
4546 return res;
4547 }
4548
quick_select_f_filter_nan(const DFloat * arr,SizeT nEl,int even)4549 inline DFloat quick_select_f_filter_nan(const DFloat* arr, SizeT nEl, int even){
4550 DLong iEl = 0;
4551 DFloat * array=(DFloat*)malloc(nEl*sizeof(DFloat));
4552 for (SizeT i = 0; i < nEl; ++i) {
4553 if (!isnan( arr[i]) ) {
4554 array[iEl] = arr[i];
4555 iEl++;
4556 }
4557 }
4558 if (iEl == 0) {
4559 free(array);
4560 return std::numeric_limits<float>::quiet_NaN();
4561 }
4562 DFloat res = quick_select_f(array, iEl, even);
4563 free(array);
4564 return res;
4565 }
4566
hasnan_f(DFloat * arr,SizeT nEl)4567 inline bool hasnan_f(DFloat* arr, SizeT nEl) {
4568 for (SizeT i = 0; i < nEl; ++i) if (isnan(arr[i])) return true;
4569 return false;
4570 }
4571
4572 BaseGDL* SlowReliableMedian(EnvT* e); //see below.
4573
median(EnvT * e)4574 BaseGDL* median(EnvT* e) {
4575 BaseGDL* p0 = e->GetParDefined(0);
4576 SizeT nParam = e->NParam(1); //get number of parameters, must be >=1.
4577
4578 if (p0->Rank() == 0)
4579 e->Throw("Expression must be an array in this context: " + e->GetParString(0));
4580
4581 if (p0->Type() == GDL_PTR)
4582 e->Throw("Pointer expression not allowed in this context: " + e->GetParString(0));
4583 if (p0->Type() == GDL_OBJ)
4584 e->Throw("Object expression not allowed in this context: " + e->GetParString(0));
4585 if (p0->Type() == GDL_STRUCT)
4586 e->Throw("Struct expression not allowed in this context: " + e->GetParString(0));
4587
4588 static int doubleIx = e->KeywordIx("DOUBLE");
4589 bool dbl =
4590 (p0->Type() == GDL_DOUBLE ||
4591 p0->Type() == GDL_COMPLEXDBL ||
4592 e->KeywordSet(doubleIx));
4593 //contrary to doc (?) EVEN is useable everywhere, 1D or 2D.
4594
4595 static int evenIx = e->KeywordIx("EVEN");
4596
4597 if (nParam == 1) {
4598 // Check conversion to real or double:
4599
4600 // Check possibility of Nan (not useful to speed down medians on integer data which
4601 // will never produce NaNs).
4602 bool possibleNaN = (p0->Type() == GDL_DOUBLE ||
4603 p0->Type() == GDL_FLOAT ||
4604 p0->Type() == GDL_COMPLEX ||
4605 p0->Type() == GDL_COMPLEXDBL);
4606
4607 //DIMENSION Kw
4608 static int dimIx = e->KeywordIx("DIMENSION");
4609 bool dimSet = e->KeywordSet(dimIx);
4610
4611 DLong medianDim;
4612 if (dimSet) {
4613 e->AssureLongScalarKW(dimIx, medianDim);
4614 if (medianDim < 0 || medianDim > p0->Rank())
4615 e->Throw("Illegal keyword value for DIMENSION");
4616 }
4617
4618 if (dimSet && p0->Rank() > 1) {
4619 medianDim -= 1; // user-supplied dimensions start with 1!
4620
4621
4622 // input/output dimensions: copy srcDim to destDim
4623 dimension destDim = p0->Dim();
4624 // make array of dims for transpose
4625 DUInt* perm = new DUInt[p0->Rank()];
4626 ArrayGuard<DUInt> perm_guard(perm);
4627 //useful to reorder dims for transpose to order data in continuous 'medianing' order.
4628 DUInt i = 0, j = 0;
4629 for (i = 0; i < p0->Rank(); ++i) if (i != medianDim) {
4630 perm[j + 1] = i;
4631 j++;
4632 }
4633 perm[0] = medianDim;
4634 // resize destDim
4635 destDim.Remove(medianDim);
4636 //compute stride and number of elements of result:
4637 SizeT stride = p0->Dim(medianDim);
4638 int iseven = ((stride % 2) == 0 && e->KeywordSet(evenIx));
4639
4640 SizeT nEl = destDim.NDimElementsConst();
4641
4642 //transpose p0 to arrange dimensions if medianDim is > 0. Do not forget to remove transposed array.
4643 bool clean_array = false;
4644 if (possibleNaN) {
4645 bool hasnan = false;
4646 if (dbl) {
4647 DDoubleGDL* input = e->GetParAs<DDoubleGDL>(0);
4648 if (medianDim != 0) {
4649 input = static_cast<DDoubleGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
4650 clean_array = true;
4651 }
4652 DDoubleGDL* res = new DDoubleGDL(destDim, BaseGDL::NOZERO);
4653 //probably overkill to start multithreading in some easy cases. TBD.
4654 #pragma omp for private(i,hasnan)
4655 for (SizeT i = 0; i < nEl; ++i) {
4656 if (hasnan_d(&(*input)[i * stride], stride)) (*res)[i] = quick_select_d_filter_nan(&(*input)[i * stride], stride, iseven); //special if nan.
4657 else (*res)[i] = quick_select_d_protect_input(&(*input)[i * stride], stride, iseven);
4658 }
4659 if (clean_array) delete input;
4660 return res;
4661 } else {
4662 DFloatGDL* input = e->GetParAs<DFloatGDL>(0);
4663 if (medianDim != 0) {
4664 input = static_cast<DFloatGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
4665 clean_array = true;
4666 }
4667 DFloatGDL* res = new DFloatGDL(destDim, BaseGDL::NOZERO);
4668 //probably overkill to start multithreading in some easy cases. TBD.
4669 #pragma omp for private(i)
4670 for (SizeT i = 0; i < nEl; ++i) {
4671 if (hasnan_f(&(*input)[i * stride], stride)) (*res)[i] = quick_select_f_filter_nan(&(*input)[i * stride], stride, iseven); //special if nan.
4672 else (*res)[i] = quick_select_f_protect_input(&(*input)[i * stride], stride, iseven); }
4673 if (clean_array) delete input;
4674 return res;
4675 }
4676 } else { //faster since no NaN handling needed.
4677 if (dbl) {
4678 DDoubleGDL* input = e->GetParAs<DDoubleGDL>(0);
4679 if (medianDim != 0) {
4680 input = static_cast<DDoubleGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
4681 clean_array = true;
4682 }
4683 DDoubleGDL* res = new DDoubleGDL(destDim, BaseGDL::NOZERO);
4684 #pragma omp for private(i)
4685 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = quick_select_d_protect_input(&(*input)[i * stride], stride, iseven);
4686 if (clean_array) delete input;
4687 return res;
4688 } else {
4689 DFloatGDL* input = e->GetParAs<DFloatGDL>(0);
4690 if (medianDim != 0) {
4691 input = static_cast<DFloatGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
4692 clean_array = true;
4693 }
4694 DFloatGDL* res = new DFloatGDL(destDim, BaseGDL::NOZERO);
4695 #pragma omp for private(i)
4696 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = quick_select_f_protect_input(&(*input)[i * stride], stride, iseven);
4697 if (clean_array) delete input;
4698 return res;
4699 }
4700 }
4701 } else {
4702 if (possibleNaN) {
4703 if (dbl) {
4704 return mymedian_d_nan(e);
4705 } else {
4706 return mymedian_f_nan(e);
4707 }
4708 } else {
4709 if (dbl) return mymedian_d(e);
4710 else return mymedian_f(e);
4711 }
4712 }
4713 } else if (nParam == 2) {
4714
4715 if (p0->Rank() > 2)
4716 e->Throw("Only 1 or 2 dimensions allowed: " + e->GetParString(0));
4717 //rank is important as fast algos are different!
4718 bool twoD = (p0->Rank() == 2);
4719
4720 // basic checks on "width" input
4721 DDoubleGDL* p1d = e->GetParAs<DDoubleGDL>(1);
4722
4723 if (p1d->N_Elements() > 1 || (*p1d)[0] <= 0)
4724 e->Throw("Width must be a positive scalar or 1 (positive) element array in this context: " + e->GetParString(0));
4725 DLong MaxAllowedWidth = 0;
4726 if (twoD) {
4727 MaxAllowedWidth = p0->Dim(0);
4728 if (p0->Dim(1) < MaxAllowedWidth) MaxAllowedWidth = p0->Dim(1);
4729 } else MaxAllowedWidth = p0->N_Elements();
4730
4731 if (!std::isfinite((*p1d)[0]))
4732 e->Throw("Width must be > 1, and < dimension of array (NaN or Inf)");
4733 if ((*p1d)[0] < 2 || (*p1d)[0] > MaxAllowedWidth)
4734 e->Throw("Width must be > 1, and < dimensions: <INT (" + i2s(MaxAllowedWidth) + ")>.");
4735 DIntGDL* p1 = e->GetParAs<DIntGDL>(1);
4736
4737 int width = p0->Dim(0);
4738 int height = twoD ? p0->Dim(1) : 1;
4739 int size = (*p1)[0];
4740 int radius = (size-1) / 2;
4741 bool oddsize = (size % 2 == 1);
4742
4743 bool iseven = ((size % 2) == 0 && e->KeywordSet(evenIx));
4744
4745 if (p0->Type() == GDL_BYTE && twoD && oddsize) {
4746 // for this special case we apply the constant-time algorithm described in Perreault et al,
4747 // Published in the September 2007 issue of IEEE Transactions on Image Processing. DOI: 10.1109/TIP.2007.902329
4748 DByteGDL* data = e->GetParAs<DByteGDL>(0);
4749 BaseGDL* res = new DByteGDL(data->Dim(), BaseGDL::NOZERO);
4750 fastmedian::ctmf(
4751 (unsigned char*) data->DataAddr(), (unsigned char*) res->DataAddr(),
4752 width, height,
4753 width, width,
4754 radius, 1, 32 * 1024); //for a 32K cache. FIXME-> get cache size value!!!
4755 return res;
4756 } else {
4757 //here we adapt according to problem using various solutions found in the literature.
4758 if (dbl) {
4759 DDoubleGDL* data = e->GetParAs<DDoubleGDL>(0);
4760 if (twoD) {
4761 if (oddsize) { //2D fast routines are programmed with odd sizes (2*radius+1)
4762 BaseGDL* res = new DDoubleGDL(data->Dim(), BaseGDL::NOZERO);
4763 fastmedian::median_filter_2d(width, height, radius, radius, 0, (DDouble*) data->DataAddr(), (DDouble*) res->DataAddr());
4764 return res;
4765 } else { //for quite a large number of pixels (100=10^2), use the next ODD value. Results are compatible within 1% for random values.
4766 //to be tested, but should be better for natural values.
4767 if (size > 10) {
4768 radius=size/2; //1 more
4769 BaseGDL* res = new DDoubleGDL(data->Dim(), BaseGDL::NOZERO);
4770 fastmedian::median_filter_2d(width, height, radius, radius, 0, (DDouble*) data->DataAddr(), (DDouble*) res->DataAddr());
4771 if (p0->Type() == GDL_BYTE) return res->Convert2(GDL_BYTE, BaseGDL::CONVERT);
4772 else return res;
4773 } else return SlowReliableMedian(e); //until we rewrite a fast non-odd 2 d filter.
4774 }
4775 } else {
4776 if (oddsize) {
4777 BaseGDL* res = new DDoubleGDL(data->Dim(), BaseGDL::NOZERO);
4778 fastmedian::median_filter_1d(width, radius, 0, (DDouble*) data->DataAddr(), (DDouble*) res->DataAddr());
4779 return res;
4780 } else { //this oneD fast routine accepts odd and even sizes, but is slower than Jukka's
4781 BaseGDL* res = data->Dup();
4782 fastmedian::filter((DDouble*) res->DataAddr(), width, size, iseven);
4783 return res;
4784 }
4785 }
4786 } else {
4787 DFloatGDL* data = e->GetParAs<DFloatGDL>(0);
4788 if (twoD) {
4789 if (oddsize) { //2D fast routines are programmed with odd sizes (2*radius+1).
4790 BaseGDL* res = new DFloatGDL(data->Dim(), BaseGDL::NOZERO);
4791 fastmedian::median_filter_2d(width, height, radius, radius, 0, (DFloat*) data->DataAddr(), (DFloat*) res->DataAddr());
4792 return res;
4793 } else { //for quite a large number of pixels (100=10^2), use the next ODD value. Results are compatible within 1% for random values.
4794 //to be tested, but should be better for natural values.
4795 if (size > 10) {
4796 radius=size/2; //1 more
4797 BaseGDL* res = new DFloatGDL(data->Dim(), BaseGDL::NOZERO);
4798 fastmedian::median_filter_2d(width, height, radius, radius, 0, (DFloat*) data->DataAddr(), (DFloat*) res->DataAddr());
4799 if (p0->Type() == GDL_BYTE) return res->Convert2(GDL_BYTE, BaseGDL::CONVERT);
4800 else return res;
4801 } else return SlowReliableMedian(e); //until we rewrite a fast non-odd 2 d filter.
4802 }
4803 } else {
4804 if (oddsize) { //Jukka's version is faster.
4805 BaseGDL* res = new DFloatGDL(data->Dim(), BaseGDL::NOZERO);
4806 fastmedian::median_filter_1d(width, radius, 0, (DFloat*) data->DataAddr(), (DFloat*) res->DataAddr());
4807 return res;
4808 } else { //this oneD fast routine accepts odd an even sizes.
4809 BaseGDL* res = data->Dup();
4810 fastmedian::filter((DFloat*) res->DataAddr(), width, size, iseven);
4811 if (p0->Type() == GDL_BYTE) return res->Convert2(GDL_BYTE, BaseGDL::CONVERT);
4812 else return res;
4813 }
4814 }
4815 }
4816 }
4817 }
4818 return NULL; //pacifies dumm compilers.
4819 }
4820 // uses MergeSort
4821 // 2 parts in the code: without "width" or with "width" (limited to 1D and 2D)
4822
SlowReliableMedian(EnvT * e)4823 BaseGDL* SlowReliableMedian(EnvT* e) {
4824
4825 BaseGDL* p0 = e->GetParDefined(0);
4826
4827 if (p0->Type() == GDL_PTR)
4828 e->Throw("Pointer expression not allowed in this context: " + e->GetParString(0));
4829 if (p0->Type() == GDL_OBJ)
4830 e->Throw("Object expression not allowed in this context: " + e->GetParString(0));
4831 if (p0->Type() == GDL_STRUCT)
4832 e->Throw("Struct expression not allowed in this context: " + e->GetParString(0));
4833
4834 if (p0->Rank() == 0)
4835 e->Throw("Expression must be an array in this context: " + e->GetParString(0));
4836
4837 SizeT nParam = e->NParam(1);
4838 SizeT nEl = p0->N_Elements();
4839
4840 // "f_nan" and "d_nan" used by both parts ...
4841 DStructGDL *Values = SysVar::Values(); //MUST NOT BE STATIC, due to .reset
4842 DFloat f_nan = (*static_cast<DFloatGDL*> (Values->GetTag(Values->Desc()->TagIndex("F_NAN"), 0)))[0];
4843 DDouble d_nan = (*static_cast<DDoubleGDL*> (Values->GetTag(Values->Desc()->TagIndex("D_NAN"), 0)))[0];
4844
4845 // --------------------------------------------------------
4846 // begin of the part 1: without "width" param
4847 if (nParam == 1) {
4848
4849 static int evenIx = e->KeywordIx("EVEN");
4850
4851 // TYPE
4852 static int doubleIx = e->KeywordIx("DOUBLE");
4853 bool dbl =
4854 p0->Type() == GDL_DOUBLE ||
4855 p0->Type() == GDL_COMPLEXDBL ||
4856 e->KeywordSet(doubleIx);
4857 DType type = dbl ? GDL_DOUBLE : GDL_FLOAT;
4858 bool noconv = (dbl && p0->Type() == GDL_DOUBLE) ||
4859 (!dbl && p0->Type() == GDL_FLOAT);
4860
4861 // DIMENSION keyword
4862 DLong dim = 0;
4863 DLong nmed = 1;
4864 BaseGDL *res;
4865
4866 static int dimensionIx = e->KeywordIx("DIMENSION");
4867 e->AssureLongScalarKWIfPresent(dimensionIx, dim);
4868
4869 // cout << "dim : "<< dim << endl;
4870
4871 if (dim > p0->Rank())
4872 e->Throw("Illegal keyword value for DIMENSION.");
4873
4874 if (dim > 0) {
4875 DLong dims[8];
4876 DLong k = 0;
4877 for (SizeT i = 0; i < p0->Rank(); ++i)
4878 if (i != (dim - 1)) {
4879 nmed *= p0->Dim(i);
4880 dims[k++] = p0->Dim(i);
4881 }
4882 dimension dimRes((DLong *) dims, p0->Rank() - 1);
4883 res = dbl
4884 ? static_cast<BaseGDL*> (new DDoubleGDL(dimRes, BaseGDL::NOZERO))
4885 : static_cast<BaseGDL*> (new DFloatGDL(dimRes, BaseGDL::NOZERO));
4886 } else {
4887 res = dbl
4888 ? static_cast<BaseGDL*> (new DDoubleGDL(1))
4889 : static_cast<BaseGDL*> (new DFloatGDL(1));
4890 }
4891
4892 // conversion of Complex types
4893 if (p0->Type() == GDL_COMPLEX) p0 = p0->Convert2(GDL_FLOAT, BaseGDL::COPY);
4894 if (p0->Type() == GDL_COMPLEXDBL) p0 = p0->Convert2(GDL_DOUBLE, BaseGDL::COPY);
4895
4896 // helper arrays
4897 if (nmed > 1) nEl = p0->N_Elements() / nmed;
4898
4899 // cout << "hello2" << endl;
4900
4901 DLong *hh = new DLong[ nEl];
4902 DLong* h1 = new DLong[ nEl / 2];
4903 DLong* h2 = new DLong[ (nEl + 1) / 2];
4904
4905 DLong accumStride = 1;
4906 if (nmed > 1)
4907 for (DLong i = 0; i < dim - 1; ++i) accumStride *= p0->Dim(i);
4908
4909 BaseGDL *op1, *op2, *op3;
4910 if (dbl) op3 = new DDoubleGDL(2);
4911 else op3 = new DFloatGDL(2);
4912
4913 // nEl_extern is used to store "nEl" initial value
4914 DLong nanIx, nEl_extern;
4915 nEl_extern = nEl;
4916 // if (nmed > 1) nEl_extern = p0->N_Elements() / nmed;
4917 //else nEl_extern = p0->N_Elements();
4918
4919 // cout << "hello type" << p0->Type() << endl;
4920
4921 // Loop over all subarray medians
4922 for (SizeT k = 0; k < nmed; ++k) {
4923
4924 // nEl=nEl_extern;
4925
4926 if (nmed == 1) {
4927 //cout << "hello inside 1D" << endl;
4928 for (DLong i = 0; i < nEl; ++i) hh[i] = i;
4929 nanIx = nEl;
4930
4931 if (p0->Type() == GDL_DOUBLE) {
4932 DDoubleGDL* p0F = static_cast<DDoubleGDL*> (p0);
4933 for (DLong i = nEl - 1; i >= 0; --i) {
4934 if (isnan((*p0F)[i])) {
4935 --nanIx;
4936 hh[i] = hh[nanIx];
4937 hh[ nanIx] = i;
4938 }
4939 }
4940 }
4941
4942 if (p0->Type() == GDL_FLOAT) {
4943 DFloatGDL* p0F = static_cast<DFloatGDL*> (p0);
4944 for (DLong i = nEl - 1; i >= 0; --i) {
4945 if (isnan((*p0F)[i])) {
4946 --nanIx;
4947 hh[i] = hh[nanIx];
4948 hh[ nanIx] = i;
4949 }
4950 }
4951 }
4952
4953 //cout << "nEl " << nEl << " nanIx " << nanIx << endl;
4954 nEl = nanIx;
4955 } else {
4956 nanIx = nEl;
4957 nEl = nEl_extern;
4958
4959 // DLong nanIx = nEl;
4960 // Starting Element
4961 DLong start = accumStride * p0->Dim(dim - 1) * (k / accumStride) +
4962 (k % accumStride);
4963 for (DLong i = 0; i < nEl; ++i) hh[i] = start + i * accumStride;
4964 DLong jj;
4965 nanIx = nEl;
4966
4967 if (p0->Type() == GDL_FLOAT) {
4968 DFloatGDL* p0F = static_cast<DFloatGDL*> (p0);
4969 for (DLong i = nEl - 1; i >= 0; --i) {
4970 jj = start + i * accumStride;
4971 if (isnan((*p0F)[ jj])) {
4972 --nanIx;
4973 hh[i] = hh[nanIx];
4974 hh[ nanIx] = i;
4975 }
4976 }
4977 nEl = nanIx;
4978 }
4979
4980 if (p0->Type() == GDL_DOUBLE) {
4981 DDoubleGDL* p0F = static_cast<DDoubleGDL*> (p0);
4982 for (DLong i = nEl - 1; i >= 0; --i) {
4983 jj = start + i * accumStride;
4984 if (isnan((*p0F)[ jj])) {
4985 --nanIx;
4986 hh[i] = hh[nanIx];
4987 hh[ nanIx] = i;
4988 }
4989 }
4990 //cout << "nanIx :" << nanIx << "nEl :" << nEl << endl;
4991 nEl = nanIx;
4992 }
4993 }
4994 DLong medEl, medEl_1;
4995
4996 // call the sort routine
4997 if (nEl > 1) {
4998 MergeSortOpt<DLong>(p0, hh, h1, h2, nEl);
4999 medEl = hh[ nEl / 2];
5000 medEl_1 = hh[ nEl / 2 - 1];
5001 } else {
5002 if (nEl == 1) {
5003 medEl = hh[0];
5004 medEl_1 = hh[0];
5005 } else { // normal case, more than one element, nothing to do
5006 //cout << "gasp : no result ! " << endl;
5007 }
5008 }
5009
5010 if (nEl <= 0) { // we have a NaN
5011 if (dbl) (*static_cast<DDoubleGDL*> (res))[k] = d_nan;
5012 else (*static_cast<DFloatGDL*> (res))[k] = f_nan;
5013 } else {
5014 //cout << k << "" << (*static_cast<DFloatGDL*>(p0))[medEl] << " "
5015 // << (*static_cast<DFloatGDL*>(p0))[medEl_1] << endl;
5016 //cout << "k :" << k << endl;
5017 if ((nEl % 2) == 1 || !e->KeywordSet(evenIx)) {
5018 if (nmed == 1)
5019 res = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);
5020 else {
5021 if (noconv) {
5022 if (dbl) (*static_cast<DDoubleGDL*> (res))[k] = (*static_cast<DDoubleGDL*> (p0))[medEl];
5023 else (*static_cast<DFloatGDL*> (res))[k] = (*static_cast<DFloatGDL*> (p0))[medEl];
5024 } else {
5025 op1 = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);
5026 if (dbl) (*static_cast<DDoubleGDL*> (res))[k] = (*static_cast<DDoubleGDL*> (op1))[0];
5027 else (*static_cast<DFloatGDL*> (res))[k] = (*static_cast<DFloatGDL*> (op1))[0];
5028 delete(op1);
5029 }
5030 }
5031 } else {
5032 if (noconv) {
5033 if (dbl) (*static_cast<DDoubleGDL*> (res))[k] = .5 * (
5034 (*static_cast<DDoubleGDL*> (p0))[medEl] +
5035 (*static_cast<DDoubleGDL*> (p0))[medEl_1]
5036 );
5037 else (*static_cast<DFloatGDL*> (res))[k] = .5 * (
5038 (*static_cast<DFloatGDL*> (p0))[medEl] +
5039 (*static_cast<DFloatGDL*> (p0))[medEl_1]
5040 );
5041 } else {
5042 op1 = p0->NewIx(medEl)->Convert2(type, BaseGDL::CONVERT);
5043 op2 = p0->NewIx(medEl_1)->Convert2(type, BaseGDL::CONVERT);
5044 if (nmed == 1) res = op2->Add(op1)->Div(op3); // TODO: leak with res?
5045 else {
5046 if (dbl) (*static_cast<DDoubleGDL*> (res))[k] =
5047 (*static_cast<DDoubleGDL*> ((op2->Add(op1)->Div(op3))))[0];
5048 else (*static_cast<DFloatGDL*> (res))[k] =
5049 (*static_cast<DFloatGDL*> ((op2->Add(op1)->Div(op3))))[0];
5050 delete(op2);
5051 }
5052 delete(op1);
5053 }
5054 }
5055 }
5056 }
5057 delete(op3);
5058 delete[] h1;
5059 delete[] h2;
5060 delete[] hh;
5061
5062 return res;
5063 }
5064
5065 // begin of the part 2: with "width" param
5066 if (nParam == 2) {
5067 // with parameter Width : median filtering with no optimisation,
5068 // such as histogram algorithms.
5069 // Copyright: (C) 2008 by Nicolas Galmiche
5070
5071 // basic checks on "vector/array" input
5072 DDoubleGDL* p0 = e->GetParAs<DDoubleGDL>(0);
5073
5074 if (p0->Rank() > 2)
5075 e->Throw("Only 1 or 2 dimensions allowed: " + e->GetParString(0));
5076
5077 // basic checks on "width" input
5078 DDoubleGDL* p1d = e->GetParAs<DDoubleGDL>(1);
5079
5080 if (p1d->N_Elements() > 1 || (*p1d)[0] <= 0)
5081 e->Throw("Width must be a positive scalar or 1 (positive) element array in this context: " + e->GetParString(0));
5082 DLong MaxAllowedWidth = 0;
5083 if (p0->Rank() == 1) MaxAllowedWidth = p0->N_Elements();
5084 if (p0->Rank() == 2) {
5085 MaxAllowedWidth = p0->Dim(0);
5086 if (p0->Dim(1) < MaxAllowedWidth) MaxAllowedWidth = p0->Dim(1);
5087 }
5088 const int debug = 0;
5089 if (debug == 1) {
5090 cout << "X dim " << p0->Dim(0) << endl;
5091 cout << "y dim " << p0->Dim(1) << endl;
5092 cout << "MaxAllowedWidth " << MaxAllowedWidth << endl;
5093 }
5094 if (!std::isfinite((*p1d)[0]))
5095 e->Throw("Width must be > 1, and < dimension of array (NaN or Inf)");
5096
5097 DLongGDL* p1 = e->GetParAs<DLongGDL>(1);
5098
5099 DDoubleGDL *tamp = new DDoubleGDL(p0->Dim(), BaseGDL::NOZERO);
5100 DDouble min = ((*p0)[0]);
5101 DDouble max = min;
5102
5103 for (SizeT ii = 0; ii < p0->N_Elements(); ++ii) {
5104 (*tamp)[ii] = (*p0)[ii];
5105 if ((*p0)[ii] < min) min = ((*p0)[ii]);
5106 if ((*p0)[ii] > max) max = ((*p0)[ii]);
5107 }
5108
5109 //---------------------------- END d'acquisistion des parametres -------------------------------------
5110
5111
5112 static int evenIx = e->KeywordIx("EVEN");
5113 static int doubleIx = e->KeywordIx("DOUBLE");
5114 DStructGDL *Values = SysVar::Values(); //MUST NOT BE STATIC, due to .reset
5115 DDouble d_nan = (*static_cast<DDoubleGDL*> (Values->GetTag(Values->Desc()->TagIndex("D_NAN"), 0)))[0];
5116 DDouble d_infinity = (*static_cast<DDoubleGDL*> (Values->GetTag(Values->Desc()->TagIndex("D_INFINITY"), 0)))[0];
5117
5118 //------------------------------ Init variables and allocation ---------------------------------------
5119 SizeT width = (*p1)[0];
5120 SizeT N_MaskElem = width*width;
5121 SizeT larg = p0->Stride(1);
5122 SizeT haut = p0->Stride(2) / larg;
5123 SizeT lim = static_cast<SizeT> (round(width / 2));
5124 SizeT init = (lim * larg + lim);
5125
5126 // we don't go further if dimension(s) versus not width OK
5127
5128 if (debug == 1) {
5129 cout << "ici" << endl;
5130 }
5131
5132 if (p0->Rank() == 1) {
5133 if (larg < width || width == 1) e->Throw("Width must be > 1, and < width of vector");
5134 }
5135 if (p0->Rank() == 2) {
5136 if (larg < width || haut < width || width == 1) e->Throw("Width must be > 1, and < dimension of array");
5137 }
5138
5139 // for 2D arrays, we use the algorithm described in paper
5140 // from T. Huang, G. Yang, and G. Tang, Fast Two-Dimensional Median Filtering Algorithm,
5141 // IEEE Trans. Acoust., Speech, Signal Processing,
5142 // vol. 27, no. 1, pp. 13--18, 1979.
5143
5144 if ((e->GetParDefined(0)->Type() == GDL_BYTE ||
5145 e->GetParDefined(0)->Type() == GDL_INT ||
5146 e->GetParDefined(0)->Type() == GDL_UINT ||
5147 e->GetParDefined(0)->Type() == GDL_LONG ||
5148 e->GetParDefined(0)->Type() == GDL_ULONG ||
5149 e->GetParDefined(0)->Type() == GDL_LONG64 ||
5150 e->GetParDefined(0)->Type() == GDL_ULONG64) &&
5151 (haut > 1)) {
5152 SizeT taille = static_cast<SizeT> (abs(max) - min + 1);
5153 DDoubleGDL* Histo = new DDoubleGDL(taille, BaseGDL::NOZERO);
5154 if (width % 2 == 0) {
5155 for (SizeT i = 0; i < haut - 2 * lim; ++i) {
5156 SizeT ltmed = 0;
5157 SizeT med = 0;
5158 SizeT initial = init + i * larg - lim * larg - lim;
5159 for (SizeT pp = 0; pp < taille; ++pp)(*Histo)[pp] = 0;
5160 for (SizeT ii = initial; ii < initial + width; ++ii) {
5161 for (SizeT yy = 0; yy < width; yy++)
5162 (*Histo)[static_cast<SizeT> ((*p0)[ii + yy * larg] - min)]++;
5163 }
5164
5165 while (ltmed + (*Histo)[med] <= (N_MaskElem / 2)) {
5166 ltmed += static_cast<SizeT> ((*Histo)[med]);
5167 ++med;
5168 }
5169 if (e->KeywordSet(evenIx)) {
5170
5171 SizeT EvenMed = med;
5172 //if ((*Histo)[EvenMed]==1 || (ltmed!=0 && ltmed !=(N_MaskElem /2) -1))
5173 if ((*Histo)[EvenMed] == 1 || (ltmed != 0 && N_MaskElem / 2 - ltmed != 1)) {
5174 while ((*Histo)[EvenMed - 1] == 0) {
5175 EvenMed--;
5176 }
5177 (*tamp)[init + i * larg] = ((med + min)+(EvenMed - 1 + min)) / 2;
5178 } else
5179 (*tamp)[init + i * larg] = med + min;
5180 } else {
5181 (*tamp)[init + i * larg] = med + min;
5182 }
5183
5184 for (SizeT j = init + i * larg + 1; j < init + (i + 1) * larg - 2 * lim; ++j) {
5185 SizeT initMask = j - lim * larg - lim;
5186 for (SizeT k = 0; k < 2 * lim; ++k) {
5187 (*Histo)[static_cast<SizeT> ((*p0)[initMask - 1 + k * larg] - min)]--;
5188 if ((*p0)[initMask - 1 + k * larg] - min < med)ltmed--;
5189
5190 (*Histo)[static_cast<SizeT> ((*p0)[initMask + k * larg + 2 * lim - 1] - min)]++;
5191 if ((*p0)[initMask + k * larg + 2 * lim - 1] - min < med)ltmed++;
5192 }
5193 if (ltmed > N_MaskElem / 2) {
5194 while (ltmed > N_MaskElem / 2) {
5195 --med;
5196 ltmed -= static_cast<SizeT> ((*Histo)[med]);
5197 }
5198 } else {
5199 while (ltmed + (*Histo)[med] <= (N_MaskElem / 2)) {
5200 ltmed += static_cast<SizeT> ((*Histo)[med]);
5201 ++med;
5202 }
5203 }
5204
5205 if (e->KeywordSet(evenIx)) {
5206 SizeT EvenMed = med;
5207 if ((*Histo)[EvenMed] == 1 || (ltmed != 0 && N_MaskElem / 2 - ltmed != 1)) {
5208 while ((*Histo)[EvenMed - 1] == 0) {
5209 EvenMed--;
5210 }
5211 (*tamp)[j] = ((med + min)+(EvenMed - 1 + min)) / 2;
5212 } else {
5213 (*tamp)[j] = med + min;
5214 }
5215 } else {
5216 (*tamp)[j] = med + min;
5217 }
5218 }
5219 }
5220 } else {
5221 for (SizeT i = 0; i < haut - 2 * lim; ++i) {
5222 SizeT ltmed = 0;
5223 SizeT med = 0;
5224 SizeT initial = init + i * larg - lim * larg - lim;
5225 for (SizeT pp = 0; pp < taille; ++pp)(*Histo)[pp] = 0;
5226 for (SizeT ii = initial; ii < initial + width; ++ii) {
5227 for (SizeT yy = 0; yy < width; yy++)
5228 (*Histo)[static_cast<SizeT> ((*p0)[ii + yy * larg] - min)]++;
5229 }
5230
5231 while (ltmed + (*Histo)[med] <= (N_MaskElem / 2)) {
5232 ltmed += static_cast<SizeT> ((*Histo)[med]);
5233 ++med;
5234 }
5235 (*tamp)[init + i * larg] = med + min;
5236
5237 for (SizeT j = init + i * larg + 1; j < init + (i + 1) * larg - 2 * lim; ++j) {
5238
5239 SizeT initMask = j - lim * larg - lim;
5240 for (SizeT k = 0; k <= 2 * lim; ++k) {
5241 (*Histo)[static_cast<SizeT> ((*p0)[initMask - 1 + k * larg] - min)]--;
5242 if ((*p0)[initMask - 1 + k * larg] - min < med)ltmed--;
5243
5244 (*Histo)[static_cast<SizeT> ((*p0)[initMask + k * larg + 2 * lim] - min)]++;
5245 if ((*p0)[initMask + k * larg + 2 * lim] - min < med)ltmed++;
5246 }
5247 if (ltmed > N_MaskElem / 2) {
5248 while (ltmed > N_MaskElem / 2) {
5249 --med;
5250 ltmed -= static_cast<SizeT> ((*Histo)[med]);
5251 }
5252 } else {
5253 while (ltmed + (*Histo)[med] <= (N_MaskElem / 2)) {
5254 ltmed += static_cast<SizeT> ((*Histo)[med]);
5255 ++med;
5256 }
5257 }
5258
5259 (*tamp)[j] = med + min;
5260
5261 }
5262 }
5263 }
5264
5265 } else {
5266 DLong* hh;
5267 DLong* h1;
5268 DLong* h2;
5269 DDoubleGDL* Mask, *Mask1D;
5270 if (p0->Rank() != 1) {
5271 hh = new DLong[ N_MaskElem];
5272 h1 = new DLong[ N_MaskElem / 2];
5273 h2 = new DLong[ (N_MaskElem + 1) / 2];
5274 Mask = new DDoubleGDL(N_MaskElem, BaseGDL::NOZERO);
5275
5276 for (DLong i = 0; i < N_MaskElem; ++i) hh[i] = i;
5277 } else {
5278 hh = new DLong[ width];
5279 h1 = new DLong[ width / 2];
5280 h2 = new DLong[(width + 1) / 2];
5281 Mask1D = new DDoubleGDL(width, BaseGDL::NOZERO);
5282
5283 for (DLong i = 0; i < width; ++i) hh[i] = i;
5284 }
5285
5286 //-------------------------------- END OF VARIABLES INIT ---------------------------------------------
5287
5288 //------------------------------ Median Filter Algorithms ---------------------------------------
5289
5290 if (width % 2 == 0) {
5291 if (p0->Rank() == 1)//------------------------ For a vector with even width -------------------
5292 {
5293 for (SizeT col = lim; col < larg - lim; ++col) {
5294 SizeT ctl_NaN = 0;
5295 SizeT kk = 0;
5296 for (SizeT ind = col - lim; ind < col + lim; ++ind) {
5297 if ((*p0)[ind] != d_infinity && (*p0)[ind] != -d_infinity && std::isfinite((*p0)[ind]) == 0)
5298 ctl_NaN++;
5299 else {
5300 (*Mask1D)[kk] = (*p0)[ind];
5301 kk++;
5302 }
5303 }
5304 if (ctl_NaN != 0) {
5305 if (ctl_NaN == width)(*tamp)[col] = d_nan;
5306 else {
5307 DLong* hhbis = new DLong[ width - ctl_NaN];
5308 DLong* h1bis = new DLong[ width - ctl_NaN / 2];
5309 DLong* h2bis = new DLong[(width - ctl_NaN + 1) / 2];
5310 DDoubleGDL *Mask1Dbis = new DDoubleGDL(width - ctl_NaN, BaseGDL::NOZERO);
5311 for (DLong t = 0; t < width - ctl_NaN; ++t) hhbis[t] = t;
5312 for (DLong ii = 0; ii < width - ctl_NaN; ++ii)(*Mask1Dbis)[ii] = (*Mask1D)[ii];
5313 BaseGDL* besort = static_cast<BaseGDL*> (Mask1Dbis);
5314 MergeSortOpt<DLong>(besort, hhbis, h1bis, h2bis, (width - ctl_NaN));
5315 if (e->KeywordSet(evenIx)&& (width - ctl_NaN) % 2 == 0)
5316 (*tamp)[col] = ((*Mask1Dbis)[hhbis[ (width - ctl_NaN) / 2]]+(*Mask1Dbis
5317 )[hhbis [ (width - ctl_NaN - 1) / 2]]) / 2;
5318 else
5319 (*tamp)[col] = (*Mask1Dbis)[hhbis[ (width - ctl_NaN) / 2]];
5320 delete[]hhbis;
5321 delete[]h2bis;
5322 delete[]h1bis;
5323 }
5324 }
5325 else {
5326 BaseGDL* besort = static_cast<BaseGDL*> (Mask1D);
5327 MergeSortOpt<DLong>(besort, hh, h1, h2, width); // call the sort routine
5328
5329 if (e->KeywordSet(evenIx))
5330
5331 (*tamp)[col] = ((*Mask1D)[hh[ width / 2]]+(*Mask1D)[hh[ (width - 1) / 2]]) / 2;
5332 else
5333 (*tamp)[col] = (*Mask1D)[hh[ width / 2]]; // replace value by Mask median
5334 }
5335 }
5336
5337 } else//------------------------ For an array with even width -------------------
5338 {
5339 SizeT jj;
5340 for (SizeT i = 0; i < haut - 2 * lim; ++i) // lines to replace
5341 {
5342 for (SizeT j = init + i * larg; j < init + (i + 1) * larg - 2 * lim; ++j)// elements to replace
5343 {
5344 SizeT initMask = j - lim * larg - lim; // left corner of mask
5345 SizeT kk = 0;
5346 SizeT ctl_NaN = 0;
5347 for (SizeT k = 0; k < 2 * lim; ++k) // lines of mask
5348 {
5349
5350 for (jj = initMask + k * larg; jj < (initMask + k * larg) + 2 * lim; ++jj) // elements of mask
5351 {
5352 if ((*p0)[jj] != d_infinity && (*p0)[jj] != -d_infinity && std::isfinite((*p0)[jj]) == 0)
5353 ctl_NaN++;
5354 else {
5355 (*Mask)[kk] = (*p0)[jj];
5356 kk++;
5357 }
5358 }
5359 }
5360 if (ctl_NaN != 0) {
5361 if (ctl_NaN == N_MaskElem)(*tamp)[j] = d_nan;
5362 else {
5363 DLong* hhb = new DLong[ N_MaskElem - ctl_NaN];
5364 DLong* h1b = new DLong[ (N_MaskElem - ctl_NaN) / 2];
5365 DLong* h2b = new DLong[(N_MaskElem - ctl_NaN + 1) / 2];
5366 DDoubleGDL *Maskb = new DDoubleGDL(N_MaskElem - ctl_NaN, BaseGDL::NOZERO);
5367 for (DLong t = 0; t < N_MaskElem - ctl_NaN; ++t) hhb[t] = t;
5368 for (DLong ii = 0; ii < N_MaskElem - ctl_NaN; ++ii)(*Maskb)[ii] = (*Mask)[ii];
5369 BaseGDL* besort = static_cast<BaseGDL*> (Maskb);
5370 MergeSortOpt<DLong>(besort, hhb, h1b, h2b, (N_MaskElem - ctl_NaN));
5371 if ((N_MaskElem - ctl_NaN) % 2 == 0 && e->KeywordSet(evenIx))
5372 (*tamp)[j] = ((*Maskb)[hhb[ (N_MaskElem - ctl_NaN) / 2]]+(*Maskb)[hhb
5373 [ (N_MaskElem -
5374 ctl_NaN - 1) / 2]]) / 2;
5375 else
5376 (*tamp)[j] = (*Maskb)[hhb[ (N_MaskElem - ctl_NaN) / 2]];
5377 delete[]hhb;
5378 delete[]h2b;
5379 delete[]h1b;
5380 }
5381 }
5382 else {
5383 BaseGDL* besort = static_cast<BaseGDL*> (Mask);
5384 MergeSortOpt<DLong>(besort, hh, h1, h2, N_MaskElem); // call the sort routine
5385 if (e->KeywordSet(evenIx))
5386 (*tamp)[j] = ((*Mask)[hh[ N_MaskElem / 2]]+(*Mask)[hh[ (N_MaskElem - 1) / 2]]) / 2;
5387 else
5388 (*tamp)[j] = (*Mask)[hh[ N_MaskElem / 2]]; // replace value by median Mask one
5389 }
5390 }
5391 }
5392 }
5393 }
5394 else {
5395 if (p0->Rank() == 1)//------------------------ For a vector with odd width -------------------
5396 {
5397 for (SizeT col = lim; col < larg - lim; ++col) {
5398 SizeT kk = 0;
5399 SizeT ctl_NaN = 0;
5400 for (SizeT ind = col - lim; ind <= col + lim; ++ind) {
5401 if ((*p0)[ind] != d_infinity && (*p0)[ind] != -d_infinity && std::isfinite((*p0)[ind]) == 0)
5402 ctl_NaN++;
5403 else {
5404 (*Mask1D)[kk] = (*p0)[ind];
5405 kk++;
5406 }
5407 }
5408 if (ctl_NaN != 0) {
5409 if (ctl_NaN == width)(*tamp)[col] = d_nan;
5410 else {
5411 DLong* hhbis = new DLong[ width - ctl_NaN];
5412 DLong* h1bis = new DLong[ width - ctl_NaN / 2];
5413 DLong* h2bis = new DLong[(width - ctl_NaN + 1) / 2];
5414 DDoubleGDL *Mask1Dbis = new DDoubleGDL(width - ctl_NaN, BaseGDL::NOZERO);
5415 for (DLong t = 0; t < width - ctl_NaN; ++t) hhbis[t] = t;
5416 for (DLong ii = 0; ii < width - ctl_NaN; ++ii)(*Mask1Dbis)[ii] = (*Mask1D)[ii];
5417 BaseGDL* besort = static_cast<BaseGDL*> (Mask1Dbis);
5418 MergeSortOpt<DLong>(besort, hhbis, h1bis, h2bis, (width - ctl_NaN));
5419 if (e->KeywordSet(evenIx)&& (width - ctl_NaN) % 2 == 0)
5420 (*tamp)[col] = ((*Mask1Dbis)[hhbis[ (width - ctl_NaN) / 2]]+(*Mask1Dbis
5421 )[hhbis [ (width - ctl_NaN - 1) / 2]]) / 2;
5422 else(*tamp)[col] = (*Mask1Dbis)[hhbis[ (width - ctl_NaN) / 2]];
5423 delete[]hhbis;
5424 delete[]h2bis;
5425 delete[]h1bis;
5426 }
5427 }
5428 else {
5429 BaseGDL* besort = static_cast<BaseGDL*> (Mask1D);
5430 MergeSortOpt<DLong>(besort, hh, h1, h2, width); // call the sort routine
5431 (*tamp)[col] = (*Mask1D)[hh[ (width) / 2]]; // replace value by Mask median
5432 }
5433 }
5434
5435 }
5436 else //----------------------------- For an array with odd width ---------------------------------
5437 {
5438 SizeT jj;
5439 for (SizeT i = 0; i < haut - 2 * lim; ++i) // lines to replace
5440 {
5441
5442 SizeT initial = init + i * larg - lim * larg - lim;
5443 SizeT dd = 0;
5444 SizeT ctl_NaN_init = 0;
5445 for (SizeT yy = 0; yy < width; yy++) {
5446 for (SizeT ii = initial + yy * larg; ii < initial + yy * larg + width; ++ii) {
5447
5448 if ((*p0)[ii] != d_infinity && (*p0)[ii] != -d_infinity && std::isfinite((*p0)[ii]) == 0)
5449 ctl_NaN_init++;
5450 else
5451 (*Mask)[dd] = (*p0)[ii];
5452 dd++;
5453 }
5454 }
5455 SizeT kk = 0;
5456
5457 for (SizeT j = init + i * larg; j < init + (i + 1) * larg - 2 * lim; ++j)// elements to replace
5458 {
5459 SizeT initMask = j - lim * larg - lim; // left corner of mask
5460 SizeT kk = 0;
5461 SizeT ctl_NaN = 0;
5462 for (SizeT k = 0; k <= 2 * lim; ++k) // lines of mask
5463 {
5464
5465 for (jj = initMask + k * larg; jj <= (initMask + k * larg) + 2 * lim; ++jj) // elements of mask
5466 {
5467 if ((*p0)[jj] != d_infinity && (*p0)[jj] != -d_infinity && std::isfinite((*p0)[jj]) == 0)
5468 ctl_NaN++;
5469
5470 else {
5471 (*Mask)[kk] = (*p0)[jj];
5472 kk++;
5473 }
5474 }
5475
5476 }
5477
5478 if (ctl_NaN != 0) {
5479 if (ctl_NaN == N_MaskElem)
5480 (*tamp)[j] = d_nan;
5481 else {
5482 DLong* hhb = new DLong[ N_MaskElem - ctl_NaN];
5483 DLong* h1b = new DLong[ (N_MaskElem - ctl_NaN) / 2];
5484 DLong* h2b = new DLong[(N_MaskElem - ctl_NaN + 1) / 2];
5485 DDoubleGDL*Maskb = new DDoubleGDL(N_MaskElem - ctl_NaN, BaseGDL::NOZERO);
5486 for (DLong t = 0; t < N_MaskElem - ctl_NaN; ++t) hhb[t] = t;
5487 for (DLong ii = 0; ii < N_MaskElem - ctl_NaN; ++ii)(*Maskb)[ii] = (*Mask)[ii];
5488 BaseGDL* besort = static_cast<BaseGDL*> (Maskb);
5489 MergeSortOpt<DLong>(besort, hhb, h1b, h2b, (N_MaskElem - ctl_NaN));
5490 if ((N_MaskElem - ctl_NaN) % 2 == 0 && e->KeywordSet(evenIx))
5491 (*tamp)[j] = ((*Maskb)[hhb[ (N_MaskElem - ctl_NaN) / 2]]+(*Maskb)[hhb
5492 [ (N_MaskElem -
5493 ctl_NaN - 1) / 2]]) / 2;
5494 else(*tamp)[j] = (*Maskb)[hhb[(N_MaskElem - ctl_NaN) / 2]];
5495 delete[]hhb;
5496 delete[]h2b;
5497 delete[]h1b;
5498 }
5499 }
5500 else {
5501 BaseGDL* besort = static_cast<BaseGDL*> (Mask);
5502 MergeSortOpt<DLong>(besort, hh, h1, h2, N_MaskElem); // call the sort routine
5503 (*tamp)[j] = (*Mask)[hh[ (N_MaskElem) / 2]]; // replace value by Mask median
5504 }
5505 }
5506 }
5507 }
5508 }
5509
5510 //--------------------------- END OF MEDIAN FILTER ALOGORITHMS -----------------------------------
5511
5512 delete[] h1;
5513 delete[] h2;
5514 delete[] hh;
5515 }
5516 if (e->GetParDefined(0)->Type() == GDL_DOUBLE || p0->Type() == GDL_COMPLEXDBL || e->KeywordSet(doubleIx))
5517 return tamp;
5518 else if (e->GetParDefined(0)->Type() == GDL_BYTE)
5519 return tamp->Convert2(GDL_BYTE, BaseGDL::CONVERT);
5520
5521 return tamp->Convert2(GDL_FLOAT, BaseGDL::CONVERT);
5522
5523 }// end if
5524 e->Throw("More than 2 parameters not handled.");
5525 return NULL;
5526
5527 }// end of median
5528
5529 //template <typename Ty> static inline Ty do_max(const Ty* data, const SizeT sz) {
5530 // Ty maxval = data[0];
5531 //
5532 //#if OMP_HAS_MAX
5533 //#pragma omp parallel
5534 // {
5535 //#pragma omp for reduction(max:maxval)
5536 //#endif
5537 // for (SizeT i = 1; i < sz; ++i) maxval = max(maxval,data[i]);
5538 //#if OMP_HAS_MAX
5539 // }
5540 //#endif
5541 // return maxval;
5542 // }
5543 //template <typename Ty> static inline Ty do_max_nan(const Ty* data, const SizeT sz) {
5544 // Ty maxval = data[0];
5545 //#if OMP_HAS_MAX
5546 //#pragma omp parallel
5547 // {
5548 //#pragma omp for reduction(max:maxval)
5549 //#endif
5550 // for (SizeT i = 1; i < sz; ++i) maxval = max(maxval,data[i]);
5551 //#if OMP_HAS_MAX
5552 // }
5553 //#endif
5554 // return maxval;
5555 // }
5556
do_mean(const Ty * data,const SizeT sz)5557 template <typename Ty> static inline Ty do_mean(const Ty* data, const SizeT sz) {
5558 Ty mean = 0;
5559 #pragma omp parallel
5560 {
5561 #pragma omp for reduction(+:mean)
5562 for (SizeT i = 0; i < sz; ++i) mean += data[i];
5563 }
5564 return mean/sz;
5565 }
5566
do_mean_cpx(const Ty * data,const SizeT sz)5567 template <typename Ty, typename T2> static inline Ty do_mean_cpx(const Ty* data, const SizeT sz) {
5568 T2 meanr = 0;
5569 T2 meani = 0;
5570 #pragma omp parallel
5571 {
5572 #pragma omp for reduction(+:meanr)
5573 for (SizeT i = 0; i < sz; ++i) meanr += data[i].real();
5574 #pragma omp for reduction(+:meani)
5575 for (SizeT i = 0; i < sz; ++i) meani += data[i].imag();
5576 }
5577 return std::complex<T2>(meanr/sz,meani/sz);
5578 }
5579
do_mean_nan(const Ty * data,const SizeT sz)5580 template <typename Ty> static inline Ty do_mean_nan(const Ty* data, const SizeT sz) {
5581 Ty mean = 0;
5582 SizeT n = 0;
5583 #pragma omp parallel //if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5584 {
5585 #pragma omp for reduction(+:mean,n)
5586 for (SizeT i = 0; i < sz; ++i) {
5587 Ty v = data[i];
5588 if (std::isfinite(v)) {
5589 n++,
5590 mean += v;
5591 }
5592 }
5593 }
5594 return mean/n;
5595 }
5596
do_mean_cpx_nan(const Ty * data,const SizeT sz)5597 template <typename Ty, typename T2> static inline Ty do_mean_cpx_nan(const Ty* data, const SizeT sz) {
5598 T2 meanr = 0;
5599 T2 meani = 0;
5600 SizeT nr = 0;
5601 SizeT ni = 0;
5602 #pragma omp parallel //if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5603 {
5604 #pragma omp for reduction(+:meanr,nr)
5605 for (SizeT i = 0; i < sz; ++i) {
5606 T2 v = data[i].real();
5607 if (std::isfinite(v)) {
5608 nr++,
5609 meanr += v;
5610 }
5611 }
5612 #pragma omp for reduction(+:meani,ni)
5613 for (SizeT i = 0; i < sz; ++i) {
5614 T2 v = data[i].imag();
5615 if (std::isfinite(v)) {
5616 ni++,
5617 meani += v;
5618 }
5619 }
5620 }
5621 return std::complex<T2>(meanr/nr,meani/ni);
5622 }
5623
mean_fun(EnvT * e)5624 BaseGDL* mean_fun(EnvT* e) {
5625 BaseGDL* p0 = e->GetParDefined(0);
5626
5627 if (p0->Type() == GDL_PTR)
5628 e->Throw("Pointer expression not allowed in this context: " + e->GetParString(0));
5629 if (p0->Type() == GDL_OBJ)
5630 e->Throw("Object expression not allowed in this context: " + e->GetParString(0));
5631 if (p0->Type() == GDL_STRUCT)
5632 e->Throw("Struct expression not allowed in this context: " + e->GetParString(0));
5633
5634 static int doubleIx = e->KeywordIx("DOUBLE");
5635 bool dbl =
5636 (p0->Type() == GDL_DOUBLE ||
5637 p0->Type() == GDL_COMPLEXDBL ||
5638 e->KeywordSet(doubleIx));
5639
5640 static int nanIx = e->KeywordIx("NAN");
5641 // Check possibility of Nan (not useful to speed down mean on integer data which
5642 // will never produce NaNs).
5643 bool possibleNaN = (p0->Type() == GDL_DOUBLE ||
5644 p0->Type() == GDL_FLOAT ||
5645 p0->Type() == GDL_COMPLEX ||
5646 p0->Type() == GDL_COMPLEXDBL);
5647 bool omitNaN = (e->KeywordPresent(nanIx) && possibleNaN);
5648
5649 //DIMENSION Kw
5650 static int dimIx = e->KeywordIx("DIMENSION");
5651 bool dimSet = e->KeywordSet(dimIx);
5652
5653 DLong meanDim;
5654 if (dimSet) {
5655 e->AssureLongScalarKW(dimIx, meanDim);
5656 if (meanDim < 0 || meanDim > p0->Rank())
5657 e->Throw("Illegal keyword value for DIMENSION");
5658 }
5659
5660 if (dimSet && p0->Rank() > 1) {
5661 meanDim -= 1; // user-supplied dimensions start with 1!
5662
5663 // output dimension: copy srcDim to destDim
5664 dimension destDim = p0->Dim();
5665 // make array of dims for transpose
5666 DUInt* perm = new DUInt[p0->Rank()];
5667 ArrayGuard<DUInt> perm_guard(perm);
5668 //useful to reorder dims for transpose to order data in continuous order.
5669 DUInt i = 0, j = 0;
5670 for (i = 0; i < p0->Rank(); ++i) if (i != meanDim) {
5671 perm[j + 1] = i;
5672 j++;
5673 }
5674 perm[0] = meanDim;
5675 // resize destDim
5676 destDim.Remove(meanDim); //will be one dimension less
5677 //compute stride and number of elements of result:
5678 SizeT stride = p0->Dim(meanDim);
5679
5680 SizeT nEl = destDim.NDimElementsConst();
5681
5682 //transpose p0 to arrange dimensions if meanDim is > 0. Do not forget to remove transposed array.
5683 bool clean_array = false;
5684 if (p0->Type() == GDL_COMPLEXDBL || (p0->Type() == GDL_COMPLEX && dbl)) {
5685 DComplexDblGDL* input = e->GetParAs<DComplexDblGDL>(0);
5686 if (meanDim != 0) {
5687 input = static_cast<DComplexDblGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
5688 clean_array = true;
5689 }
5690 DComplexDblGDL* res = new DComplexDblGDL(destDim, BaseGDL::NOZERO);
5691 if (omitNaN) {
5692 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5693 {
5694 #pragma omp for
5695 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean_cpx_nan<DComplexDbl, double>(&(*input)[i * stride], stride);
5696 }
5697 } else {
5698 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5699 {
5700 #pragma omp for
5701 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean_cpx<DComplexDbl, double>(&(*input)[i * stride], stride);
5702 }
5703 }
5704 if (clean_array) delete input;
5705 return res;
5706 } else if (p0->Type() == GDL_COMPLEX) {
5707 DComplexGDL* input = e->GetParAs<DComplexGDL>(0);
5708 if (meanDim != 0) {
5709 input = static_cast<DComplexGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
5710 clean_array = true;
5711 }
5712 DComplexGDL* res = new DComplexGDL(destDim, BaseGDL::NOZERO);
5713 if (omitNaN) {
5714 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5715 {
5716 #pragma omp for
5717 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean_cpx_nan<DComplex, float>(&(*input)[i * stride], stride);
5718 }
5719 } else {
5720 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5721 {
5722 #pragma omp for
5723 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean_cpx<DComplex, float>(&(*input)[i * stride], stride);
5724 }
5725 }
5726 if (clean_array) delete input;
5727 return res;
5728 } else {
5729 if (dbl) {
5730 DDoubleGDL* input = e->GetParAs<DDoubleGDL>(0);
5731 if (meanDim != 0) {
5732 input = static_cast<DDoubleGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
5733 clean_array = true;
5734 }
5735 DDoubleGDL* res = new DDoubleGDL(destDim, BaseGDL::NOZERO);
5736 if (omitNaN) {
5737 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5738 {
5739 #pragma omp for
5740 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean_nan(&(*input)[i * stride], stride);
5741 }
5742 } else {
5743 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5744 {
5745 #pragma omp for
5746 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean(&(*input)[i * stride], stride);
5747 }
5748 }
5749 if (clean_array) delete input;
5750 return res;
5751 } else {
5752 DFloatGDL* input = e->GetParAs<DFloatGDL>(0);
5753
5754 if (meanDim != 0) {
5755 input = static_cast<DFloatGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
5756 clean_array = true;
5757 }
5758 DFloatGDL* res = new DFloatGDL(destDim, BaseGDL::NOZERO);
5759 if (omitNaN) {
5760 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5761 {
5762 #pragma omp for
5763 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean_nan(&(*input)[i * stride], stride);
5764 }
5765 } else {
5766 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
5767 {
5768 #pragma omp for
5769 for (SizeT i = 0; i < nEl; ++i) (*res)[i] = do_mean(&(*input)[i * stride], stride);
5770 }
5771 }
5772 if (clean_array) delete input;
5773 return res;
5774 }
5775 }
5776 } else {
5777 if (p0->Type() == GDL_COMPLEXDBL || (p0->Type() == GDL_COMPLEX && dbl)) {
5778 DComplexDblGDL* input = e->GetParAs<DComplexDblGDL>(0);
5779 if (omitNaN) return new DComplexDblGDL(do_mean_cpx_nan<DComplexDbl, double>(&(*input)[0], input->N_Elements()));
5780 else return new DComplexDblGDL(do_mean_cpx<DComplexDbl, double>(&(*input)[0], input->N_Elements()));
5781 } else if (p0->Type() == GDL_COMPLEX) {
5782 DComplexGDL* input = e->GetParAs<DComplexGDL>(0);
5783 if (omitNaN) return new DComplexGDL(do_mean_cpx_nan<DComplex, float>(&(*input)[0], input->N_Elements()));
5784 else return new DComplexGDL(do_mean_cpx<DComplex, float>(&(*input)[0], input->N_Elements()));
5785 } else {
5786 if (dbl) {
5787 DDoubleGDL* input = e->GetParAs<DDoubleGDL>(0);
5788 if (omitNaN) return new DDoubleGDL(do_mean_nan(&(*input)[0], input->N_Elements()));
5789 else return new DDoubleGDL(do_mean(&(*input)[0], input->N_Elements()));
5790 } else {
5791 DFloatGDL* input = e->GetParAs<DFloatGDL>(0);
5792 if (omitNaN) return new DFloatGDL(do_mean_nan(&(*input)[0], input->N_Elements()));
5793 else return new DFloatGDL(do_mean(&(*input)[0], input->N_Elements()));
5794 }
5795 }
5796 }
5797 }
5798
5799 template<typename Ty>
do_moment(const Ty * data,const SizeT sz,Ty & mean,Ty & variance,Ty & skewness,Ty & kurtosis,Ty & mdev,Ty & sdev,const int maxmoment)5800 static inline void do_moment(const Ty* data, const SizeT sz, Ty &mean, Ty &variance, Ty &skewness,
5801 Ty &kurtosis, Ty &mdev, Ty &sdev, const int maxmoment){
5802 Ty meanl=do_mean(data,sz);
5803 mean=meanl;
5804 if (maxmoment==1) {
5805 variance=skewness=kurtosis=mdev=sdev=std::numeric_limits<float>::quiet_NaN();
5806 return;
5807 }
5808
5809 Ty var=0;
5810 Ty md=0;
5811 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5812 {
5813 #pragma omp for reduction(+:var,md)
5814 for (SizeT i = 0; i < sz; ++i) { Ty cdata=data[i]-meanl; var += cdata*cdata; md+=fabs(cdata);}
5815 }
5816 var/=(sz-1);
5817 variance=var;
5818 sdev=sqrt(var);
5819 mdev=md/sz;
5820
5821 if (maxmoment==2 || var==0 ) {
5822 skewness=kurtosis=std::numeric_limits<float>::quiet_NaN();
5823 return;
5824 }
5825 Ty skew=0;
5826 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5827 {
5828 #pragma omp for reduction(+:skew)
5829 for (SizeT i = 0; i < sz; ++i) { Ty cdata=data[i]-meanl; skew += (cdata*cdata*cdata)/(var*sdev); }
5830 }
5831 skewness=skew/sz;
5832 if (maxmoment==3) {
5833 kurtosis=std::numeric_limits<float>::quiet_NaN();
5834 return;
5835 }
5836 Ty kurt=0;
5837 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5838 {
5839 #pragma omp for reduction(+:kurt)
5840 for (SizeT i = 0; i < sz; ++i) { Ty cdata=data[i]-meanl; kurt += (cdata*cdata*cdata*cdata)/(var*var);}
5841 }
5842 kurtosis=(kurt/sz)-3;
5843 }
5844
5845 template<typename Ty, typename T2>
do_moment_cpx(const Ty * data,const SizeT sz,Ty & mean,Ty & variance,Ty & skewness,Ty & kurtosis,T2 & mdev,Ty & sdev,const int maxmoment)5846 static inline void do_moment_cpx(const Ty* data, const SizeT sz, Ty &mean, Ty &variance, Ty &skewness,
5847 Ty &kurtosis, T2 &mdev, Ty &sdev, const int maxmoment){
5848 Ty meanl=do_mean_cpx<Ty, T2>(data,sz);
5849 mean=meanl;
5850 if (maxmoment == 1) {
5851 variance = skewness = kurtosis = sdev =
5852 std::complex<T2>(std::numeric_limits<T2>::quiet_NaN(), std::numeric_limits<T2>::quiet_NaN());
5853 mdev = std::numeric_limits<T2>::quiet_NaN();
5854 return;
5855 }
5856
5857 T2 mdr=0;
5858 T2 varr=0;
5859 T2 vari=0;
5860 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5861 {
5862 #pragma omp for reduction(+:varr,vari,mdr)
5863 for (SizeT i = 0; i < sz; ++i) {
5864 Ty cdata=data[i]-meanl;
5865 T2 cdatar=cdata.real();
5866 T2 cdatai=cdata.imag();
5867 varr += (cdatar*cdatar)-(cdatai*cdatai);
5868 vari += 2*cdatar*cdatai;
5869 mdr += sqrt(cdatar*cdatar+cdatai*cdatai);
5870 }
5871 }
5872 varr/=(sz-1);
5873 vari/=(sz-1);
5874 mdr/=sz;
5875 variance=std::complex<T2>(varr,vari);
5876 sdev=sqrt(variance);
5877 mdev=mdr;
5878
5879 if (maxmoment==2) {
5880 skewness=kurtosis=
5881 std::complex<T2>(std::numeric_limits<T2>::quiet_NaN(),std::numeric_limits<T2>::quiet_NaN());
5882 return;
5883 }
5884 T2 skewr=0;
5885 T2 skewi=0;
5886 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5887 {
5888 #pragma omp for reduction(+:skewr,skewi)
5889 for (SizeT i = 0; i < sz; ++i) {
5890 Ty cdata=data[i]-meanl;
5891 T2 cdatar=cdata.real();
5892 T2 cdatai=cdata.imag();
5893 skewr += (cdatar*cdatar*cdatar-3.0*cdatar*cdatai*cdatai)*
5894 exp(-0.75*log(varr*varr+vari*vari))*
5895 cos(0.15E1*atan2(vari,varr))+(3.0*cdatar*cdatar*cdatai-cdatai*cdatai*cdatai)*
5896 exp(-0.75*log(varr*varr+vari*vari))*sin(1.5*atan2(vari,varr));
5897
5898 skewi += (3.0*cdatar*cdatar*cdatai-cdatai*cdatai*cdatai)*
5899 exp(-0.75*log(varr*varr+vari*vari))*cos(1.5*atan2(vari,varr))-
5900 (cdatar*cdatar*cdatar-3.0*cdatar*cdatai*cdatai)*
5901 exp(-0.75*log(varr*varr+vari*vari))*sin(1.5*atan2(vari,varr));
5902 }
5903 }
5904 skewness=std::complex<T2>(skewr/sz,skewi/sz);
5905 if (maxmoment==3) {
5906 kurtosis=std::complex<T2>(std::numeric_limits<T2>::quiet_NaN(),std::numeric_limits<T2>::quiet_NaN());
5907 return;
5908 }
5909 T2 kurtr=0;
5910 T2 kurti=0;
5911 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5912 {
5913 #pragma omp for reduction(+:kurtr,kurti)
5914 for (SizeT i = 0; i < sz; ++i) {
5915 Ty cdata=data[i]-meanl;
5916 T2 cdatar=cdata.real();
5917 T2 cdatai=cdata.imag();
5918 kurtr += (cdatar*cdatar*cdatar*cdatar-6.0*cdatar*cdatar*cdatai*cdatai+cdatai*
5919 cdatai*cdatai*cdatai)*(varr*varr-vari*vari)/(pow(varr*varr-vari*vari,2.0)+
5920 4.0*varr*varr*vari*vari)+2.0*(4.0*cdatar*cdatar*cdatar*cdatai-
5921 4.0*cdatar*cdatai*cdatai*cdatai)*varr*vari/
5922 (pow(varr*varr-vari*vari,2.0)+
5923 4.0*varr*varr*vari*vari);
5924 kurti += (4.0*cdatar*cdatar*cdatar*cdatai-4.0*cdatar*cdatai*cdatai*cdatai)*
5925 (varr*varr-vari*vari)/(pow(varr*varr-vari*vari,2.0)+4.0*varr*varr*vari*vari)-
5926 2.0*(cdatar*cdatar*cdatar*cdatar-
5927 6.0*cdatar*cdatar*cdatai*cdatai+cdatai*cdatai*cdatai*cdatai)*varr*vari/
5928 (pow(varr*varr-vari*vari,2.0)+
5929 4.0*varr*varr*vari*vari);
5930 }
5931 }
5932 kurtosis=std::complex<T2>((kurtr/sz)-3,(kurti/sz)-3);
5933 }
5934
5935 template<typename Ty>
do_moment_nan(const Ty * data,const SizeT sz,Ty & mean,Ty & variance,Ty & skewness,Ty & kurtosis,Ty & mdev,Ty & sdev,const int maxmoment)5936 static inline void do_moment_nan(const Ty* data, const SizeT sz, Ty &mean, Ty &variance, Ty &skewness,
5937 Ty &kurtosis, Ty &mdev, Ty &sdev, const int maxmoment){
5938 Ty meanl=do_mean_nan(data,sz);
5939 mean=meanl;
5940 if (maxmoment==1 || !std::isfinite(mean)) {
5941 variance=skewness=kurtosis=mdev=sdev=std::numeric_limits<float>::quiet_NaN();
5942 return;
5943 }
5944
5945 Ty var=0;
5946 Ty md=0;
5947 SizeT k=0;
5948 #pragma omp parallel //if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5949 {
5950 #pragma omp for reduction(+:var,md,k)
5951 for (SizeT i = 0; i < sz; ++i) { Ty cdata=data[i]-meanl; if (std::isfinite(cdata)) {var += cdata*cdata; md+=fabs(cdata); k+=1;} }
5952 }
5953 if (k>1) var/=(k-1); else {
5954 variance=skewness=kurtosis=mdev=sdev=std::numeric_limits<float>::quiet_NaN();
5955 return;
5956 }
5957 variance=var;
5958 sdev=sqrt(var);
5959 mdev=md/k;
5960 if (maxmoment==2 || var==0 ) {
5961 skewness=kurtosis=std::numeric_limits<float>::quiet_NaN();
5962 return;
5963 }
5964 Ty skew=0;
5965 #pragma omp parallel //if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5966 {
5967 #pragma omp for reduction(+:skew)
5968 for (SizeT i = 0; i < sz; ++i) { Ty cdata=data[i]-meanl; if (std::isfinite(cdata)) skew += (cdata*cdata*cdata)/(var*sdev); }
5969 }
5970 skewness=skew/k;
5971 if (maxmoment==3) {
5972 kurtosis=std::numeric_limits<float>::quiet_NaN();
5973 return;
5974 }
5975 Ty kurt=0;
5976 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
5977 {
5978 #pragma omp for reduction(+:kurt)
5979 for (SizeT i = 0; i < sz; ++i) { Ty cdata=data[i]-meanl; if (std::isfinite(cdata)) kurt += (cdata*cdata*cdata*cdata)/(var*var);}
5980 }
5981 kurtosis=(kurt/k)-3;
5982 }
5983
5984 template<typename Ty, typename T2>
do_moment_cpx_nan(const Ty * data,const SizeT sz,Ty & mean,Ty & variance,Ty & skewness,Ty & kurtosis,T2 & mdev,Ty & sdev,const int maxmoment)5985 static inline void do_moment_cpx_nan(const Ty* data, const SizeT sz, Ty &mean, Ty &variance, Ty &skewness,
5986 Ty &kurtosis, T2 &mdev, Ty &sdev, const int maxmoment){
5987 Ty meanl=do_mean_cpx_nan<Ty, T2>(data,sz);
5988 mean=meanl;
5989 if (maxmoment==1) {
5990 variance=skewness=kurtosis=sdev=
5991 std::complex<T2>(std::numeric_limits<T2>::quiet_NaN(),std::numeric_limits<T2>::quiet_NaN());
5992 mdev=std::numeric_limits<T2>::quiet_NaN();
5993 return;
5994 }
5995 SizeT kr=0;
5996 SizeT ki=0;
5997 T2 mdr=0;
5998 T2 varr=0;
5999 T2 vari=0;
6000 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
6001 {
6002 #pragma omp for reduction(+:varr,vari,mdr,kr,ki)
6003 for (SizeT i = 0; i < sz; ++i) {
6004 Ty cdata=data[i]-meanl;
6005 T2 cdatar=cdata.real();
6006 T2 cdatai=cdata.imag();
6007 if (std::isfinite(cdatar)) {varr += cdatar*cdatar; kr++;}
6008 if (std::isfinite(cdatai)) {vari += cdatai*cdatai; ki++;}
6009 if (std::isfinite(cdatar)) mdr += sqrt(cdatar*cdatar+cdatai*cdatai);
6010 }
6011 }
6012 varr/=(kr-1);
6013 vari/=(ki-1);
6014 mdr/=kr;
6015 variance=std::complex<T2>(varr,vari);
6016 sdev=sqrt(variance);
6017 mdev=mdr;
6018
6019 if (maxmoment==2) {
6020 skewness=kurtosis=
6021 std::complex<T2>(std::numeric_limits<T2>::quiet_NaN(),std::numeric_limits<T2>::quiet_NaN());
6022 return;
6023 }
6024 T2 skewr=0;
6025 T2 skewi=0;
6026 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
6027 {
6028 #pragma omp for reduction(+:skewr,skewi)
6029 for (SizeT i = 0; i < sz; ++i) {
6030 Ty cdata=data[i]-meanl;
6031 T2 cdatar=cdata.real();
6032 T2 cdatai=cdata.imag();
6033 if (std::isfinite(cdatar)) skewr += (cdatar*cdatar*cdatar-3.0*cdatar*cdatai*cdatai)*
6034 exp(-0.75*log(varr*varr+vari*vari))*
6035 cos(0.15E1*atan2(vari,varr))+(3.0*cdatar*cdatar*cdatai-cdatai*cdatai*cdatai)*
6036 exp(-0.75*log(varr*varr+vari*vari))*sin(1.5*atan2(vari,varr));
6037
6038 if (std::isfinite(cdatai)) skewi += (3.0*cdatar*cdatar*cdatai-cdatai*cdatai*cdatai)*
6039 exp(-0.75*log(varr*varr+vari*vari))*cos(1.5*atan2(vari,varr))-
6040 (cdatar*cdatar*cdatar-3.0*cdatar*cdatai*cdatai)*
6041 exp(-0.75*log(varr*varr+vari*vari))*sin(1.5*atan2(vari,varr));
6042 }
6043 }
6044 skewness=std::complex<T2>(skewr/kr,skewi/ki);
6045 if (maxmoment==3) {
6046 kurtosis=std::complex<T2>(std::numeric_limits<T2>::quiet_NaN(),std::numeric_limits<T2>::quiet_NaN());
6047 return;
6048 }
6049 T2 kurtr=0;
6050 T2 kurti=0;
6051 #pragma omp parallel // if (sz >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= sz))
6052 {
6053 #pragma omp for reduction(+:kurtr,kurti)
6054 for (SizeT i = 0; i < sz; ++i) {
6055 Ty cdata=data[i]-meanl;
6056 T2 cdatar=cdata.real();
6057 T2 cdatai=cdata.imag();
6058 if (std::isfinite(cdatar)) kurtr += (cdatar*cdatar*cdatar*cdatar-6.0*cdatar*cdatar*cdatai*cdatai+cdatai*
6059 cdatai*cdatai*cdatai)*(varr*varr-vari*vari)/(pow(varr*varr-vari*vari,2.0)+
6060 4.0*varr*varr*vari*vari)+2.0*(4.0*cdatar*cdatar*cdatar*cdatai-
6061 4.0*cdatar*cdatai*cdatai*cdatai)*varr*vari/
6062 (pow(varr*varr-vari*vari,2.0)+
6063 4.0*varr*varr*vari*vari);
6064 if (std::isfinite(cdatai)) kurti += (4.0*cdatar*cdatar*cdatar*cdatai-4.0*cdatar*cdatai*cdatai*cdatai)*
6065 (varr*varr-vari*vari)/(pow(varr*varr-vari*vari,2.0)+4.0*varr*varr*vari*vari)-
6066 2.0*(cdatar*cdatar*cdatar*cdatar-
6067 6.0*cdatar*cdatar*cdatai*cdatai+cdatai*cdatai*cdatai*cdatai)*varr*vari/
6068 (pow(varr*varr-vari*vari,2.0)+
6069 4.0*varr*varr*vari*vari);
6070 }
6071 }
6072 kurtosis=std::complex<T2>((kurtr/kr)-3,(kurti/kr)-3);
6073 }
6074
moment_fun(EnvT * e)6075 BaseGDL* moment_fun(EnvT* e) {
6076 BaseGDL* p0 = e->GetParDefined(0);
6077
6078 if (p0->Type() == GDL_PTR)
6079 e->Throw("Pointer expression not allowed in this context: " + e->GetParString(0));
6080 if (p0->Type() == GDL_OBJ)
6081 e->Throw("Object expression not allowed in this context: " + e->GetParString(0));
6082 if (p0->Type() == GDL_STRUCT)
6083 e->Throw("Struct expression not allowed in this context: " + e->GetParString(0));
6084
6085 static int doubleIx = e->KeywordIx("DOUBLE");
6086 bool dbl =
6087 (p0->Type() == GDL_DOUBLE ||
6088 p0->Type() == GDL_COMPLEXDBL ||
6089 e->KeywordSet(doubleIx));
6090
6091 static int nanIx = e->KeywordIx("NAN");
6092 // Check possibility of Nan (not useful to speed down moment on integer data which
6093 // will never produce NaNs).
6094 bool possibleNaN = (p0->Type() == GDL_DOUBLE ||
6095 p0->Type() == GDL_FLOAT ||
6096 p0->Type() == GDL_COMPLEX ||
6097 p0->Type() == GDL_COMPLEXDBL);
6098 bool omitNaN = (e->KeywordPresent(nanIx) && possibleNaN);
6099
6100 //DIMENSION Kw
6101 static int dimIx = e->KeywordIx("DIMENSION");
6102 bool dimSet = e->KeywordSet(dimIx);
6103
6104 //MAXMOMENT Kw. It limits the computation, even if a modifying kw of higher moment, such as "kurtosis" is present
6105
6106 static int maxmIx = e->KeywordIx("MAXMOMENT");
6107 DLong maxmoment = 4;
6108 if (e->KeywordPresent(maxmIx)) e->AssureLongScalarKW(maxmIx, maxmoment);
6109 if (maxmoment > 4) maxmoment=4;
6110 if (maxmoment < 1) maxmoment=4;
6111
6112 //MEAN Kw
6113 static int meanIx = e->KeywordIx("MEAN");
6114 int domean = e->KeywordPresent(meanIx);
6115 //KURTOSIS Kw
6116 static int kurtIx = e->KeywordIx("KURTOSIS");
6117 int dokurt = e->KeywordPresent(kurtIx);
6118 //SDEV Kw
6119 static int sdevIx = e->KeywordIx("SDEV");
6120 int dosdev = e->KeywordPresent(sdevIx);
6121 //MDEV Kw
6122 static int mdevIx = e->KeywordIx("MDEV");
6123 int domdev = e->KeywordPresent(mdevIx);
6124 //VARIANCE Kw
6125 static int varIx = e->KeywordIx("VARIANCE");
6126 int dovar = e->KeywordPresent(varIx);
6127 //SKEWNESS Kw
6128 static int skewIx = e->KeywordIx("SKEWNESS");
6129 int doskew = e->KeywordPresent(skewIx);
6130
6131
6132 DLong momentDim;
6133 if (dimSet) {
6134 e->AssureLongScalarKW(dimIx, momentDim);
6135 if (momentDim < 0 || momentDim > p0->Rank())
6136 e->Throw("Illegal keyword value for DIMENSION");
6137 }
6138
6139 if (dimSet && p0->Rank() > 1) {
6140 momentDim -= 1; // user-supplied dimensions start with 1!
6141
6142 // output dimension: copy srcDim to destDim
6143 dimension destDim = p0->Dim();
6144 dimension auxiliaryDim;
6145 // make array of dims for transpose
6146 DUInt* perm = new DUInt[p0->Rank()];
6147 ArrayGuard<DUInt> perm_guard(perm);
6148 //useful to reorder dims for transpose to order data in continuous order.
6149 DUInt i = 0, j = 0;
6150 for (i = 0; i < p0->Rank(); ++i) if (i != momentDim) {
6151 perm[j + 1] = i;
6152 j++;
6153 }
6154 perm[0] = momentDim;
6155 // resize destDim
6156 destDim.Remove(momentDim); //will be one dimension less
6157 SizeT nEl = destDim.NDimElementsConst(); //need to compute that here, before adding last dim.
6158 auxiliaryDim=destDim;
6159
6160 destDim<<4; //add 4 as last dim
6161 //compute stride and number of elements of result:
6162 SizeT stride = p0->Dim(momentDim);
6163
6164
6165 //transpose p0 to arrange dimensions if momentDim is > 0. Do not forget to remove transposed array.
6166 bool clean_array = false;
6167 if (p0->Type() == GDL_COMPLEXDBL || (p0->Type() == GDL_COMPLEX && dbl)) {
6168 DComplexDblGDL* input = e->GetParAs<DComplexDblGDL>(0);
6169 if (momentDim != 0) {
6170 input = static_cast<DComplexDblGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
6171 clean_array = true;
6172 }
6173 DComplexDblGDL* res = new DComplexDblGDL(destDim, BaseGDL::NOZERO);
6174 DComplexDblGDL* mean;
6175 DComplexDblGDL* var;
6176 DComplexDblGDL* skew;
6177 DComplexDblGDL* kurt;
6178 DComplexDblGDL* sdev;
6179 DDoubleGDL* mdev;
6180 if (domean) mean = new DComplexDblGDL(auxiliaryDim, BaseGDL::NOZERO);
6181 if (dovar) var = new DComplexDblGDL(auxiliaryDim, BaseGDL::NOZERO);
6182 if (doskew) skew = new DComplexDblGDL(auxiliaryDim, BaseGDL::NOZERO);
6183 if (dokurt) kurt = new DComplexDblGDL(auxiliaryDim, BaseGDL::NOZERO);
6184 if (dosdev) sdev = new DComplexDblGDL(auxiliaryDim, BaseGDL::NOZERO);
6185 if (domdev) mdev = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6186 if (omitNaN) {
6187 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6188 {
6189 #pragma omp for
6190 for (SizeT i = 0; i < nEl; ++i) {
6191 DDouble mdevl;
6192 DComplexDbl sdevl;
6193 do_moment_cpx_nan<DComplexDbl, double>(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl], (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6194 if (domean) (*mean)[i]=(*res)[i];
6195 if (dovar ) (*var )[i]=(*res)[i+nEl];
6196 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6197 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6198 if (dosdev) (*sdev)[i]=sdevl;
6199 if (domdev) (*mdev)[i]=mdevl;
6200 }
6201 }
6202 } else {
6203 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6204 {
6205 #pragma omp for
6206 for (SizeT i = 0; i < nEl; ++i) {
6207 DDouble mdevl;
6208 DComplexDbl sdevl;
6209 do_moment_cpx<DComplexDbl, double>(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl], (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6210 if (domean) (*mean)[i]=(*res)[i];
6211 if (dovar ) (*var )[i]=(*res)[i+nEl];
6212 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6213 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6214 if (dosdev) (*sdev)[i]=sdevl;
6215 if (domdev) (*mdev)[i]=mdevl;
6216 }
6217 }
6218 }
6219 if (clean_array) delete input;
6220 if (domean) e->SetKW( meanIx, mean );
6221 if (dovar ) e->SetKW( varIx, var );
6222 if (doskew) e->SetKW( skewIx, skew );
6223 if (dokurt) e->SetKW( kurtIx, kurt );
6224 if (dosdev) e->SetKW( sdevIx, sdev );
6225 if (domdev) e->SetKW( mdevIx, mdev );
6226 return res;
6227 } else if (p0->Type() == GDL_COMPLEX) {
6228 DComplexGDL* input = e->GetParAs<DComplexGDL>(0);
6229 if (momentDim != 0) {
6230 input = static_cast<DComplexGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
6231 clean_array = true;
6232 }
6233 DComplexGDL* res = new DComplexGDL(destDim, BaseGDL::NOZERO);
6234 DComplexGDL* mean;
6235 DComplexGDL* var;
6236 DComplexGDL* skew;
6237 DComplexGDL* kurt;
6238 DComplexGDL* sdev;
6239 DFloatGDL* mdev;
6240 if (domean) mean = new DComplexGDL(auxiliaryDim, BaseGDL::NOZERO);
6241 if (dovar) var = new DComplexGDL(auxiliaryDim, BaseGDL::NOZERO);
6242 if (doskew) skew = new DComplexGDL(auxiliaryDim, BaseGDL::NOZERO);
6243 if (dokurt) kurt = new DComplexGDL(auxiliaryDim, BaseGDL::NOZERO);
6244 if (dosdev) sdev = new DComplexGDL(auxiliaryDim, BaseGDL::NOZERO);
6245 if (domdev) mdev = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6246 if (omitNaN) {
6247 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6248 {
6249 #pragma omp for
6250 for (SizeT i = 0; i < nEl; ++i) {
6251 DFloat mdevl;
6252 DComplex sdevl;
6253 do_moment_cpx_nan<DComplex, float>(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl], (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6254 if (domean) (*mean)[i]=(*res)[i];
6255 if (dovar ) (*var )[i]=(*res)[i+nEl];
6256 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6257 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6258 if (dosdev) (*sdev)[i]=sdevl;
6259 if (domdev) (*mdev)[i]=mdevl;
6260 }
6261 }
6262 } else {
6263 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6264 {
6265 #pragma omp for
6266 for (SizeT i = 0; i < nEl; ++i) {
6267 DFloat mdevl;
6268 DComplex sdevl;
6269 do_moment_cpx<DComplex, float>(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl], (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6270 if (domean) (*mean)[i]=(*res)[i];
6271 if (dovar ) (*var )[i]=(*res)[i+nEl];
6272 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6273 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6274 if (dosdev) (*sdev)[i]=sdevl;
6275 if (domdev) (*mdev)[i]=mdevl;
6276 }
6277 }
6278 }
6279 if (clean_array) delete input;
6280 if (domean) e->SetKW( meanIx, mean );
6281 if (dovar ) e->SetKW( varIx, var );
6282 if (doskew) e->SetKW( skewIx, skew );
6283 if (dokurt) e->SetKW( kurtIx, kurt );
6284 if (dosdev) e->SetKW( sdevIx, sdev );
6285 if (domdev) e->SetKW( mdevIx, mdev );
6286 return res;
6287 } else {
6288 if (dbl) {
6289 DDoubleGDL* input = e->GetParAs<DDoubleGDL>(0);
6290 if (momentDim != 0) {
6291 input = static_cast<DDoubleGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
6292 clean_array = true;
6293 }
6294 DDoubleGDL* res = new DDoubleGDL(destDim, BaseGDL::NOZERO);
6295 DDoubleGDL* mean;
6296 DDoubleGDL* var;
6297 DDoubleGDL* skew;
6298 DDoubleGDL* kurt;
6299 DDoubleGDL* sdev;
6300 DDoubleGDL* mdev;
6301 if (domean) mean = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6302 if (dovar) var = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6303 if (doskew) skew = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6304 if (dokurt) kurt = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6305 if (dosdev) sdev = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6306 if (domdev) mdev = new DDoubleGDL(auxiliaryDim, BaseGDL::NOZERO);
6307 if (omitNaN) {
6308 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6309 {
6310 #pragma omp for
6311 for (SizeT i = 0; i < nEl; ++i) {
6312 DDouble mdevl;
6313 DDouble sdevl;
6314 do_moment_nan(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl],
6315 (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6316 if (domean) (*mean)[i]=(*res)[i];
6317 if (dovar ) (*var )[i]=(*res)[i+nEl];
6318 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6319 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6320 if (dosdev) (*sdev)[i]=sdevl;
6321 if (domdev) (*mdev)[i]=mdevl;
6322 }
6323 }
6324 } else {
6325 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6326 {
6327 #pragma omp for
6328 for (SizeT i = 0; i < nEl; ++i) {
6329 DDouble mdevl;
6330 DDouble sdevl;
6331 do_moment(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl],
6332 (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6333 if (domean) (*mean)[i]=(*res)[i];
6334 if (dovar ) (*var )[i]=(*res)[i+nEl];
6335 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6336 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6337 if (dosdev) (*sdev)[i]=sdevl;
6338 if (domdev) (*mdev)[i]=mdevl;
6339 }
6340 }
6341 }
6342 if (clean_array) delete input;
6343 if (domean) e->SetKW( meanIx, mean );
6344 if (dovar ) e->SetKW( varIx, var );
6345 if (doskew) e->SetKW( skewIx, skew );
6346 if (dokurt) e->SetKW( kurtIx, kurt );
6347 if (dosdev) e->SetKW( sdevIx, sdev );
6348 if (domdev) e->SetKW( mdevIx, mdev );
6349 return res;
6350 } else {
6351 DFloatGDL* input = e->GetParAs<DFloatGDL>(0);
6352 if (momentDim != 0) {
6353 input = static_cast<DFloatGDL*> (static_cast<BaseGDL*> (input)->Transpose(perm));
6354 clean_array = true;
6355 }
6356 DFloatGDL* res = new DFloatGDL(destDim, BaseGDL::NOZERO);
6357 DFloatGDL* mean;
6358 DFloatGDL* var;
6359 DFloatGDL* skew;
6360 DFloatGDL* kurt;
6361 DFloatGDL* sdev;
6362 DFloatGDL* mdev;
6363 if (domean) mean = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6364 if (dovar) var = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6365 if (doskew) skew = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6366 if (dokurt) kurt = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6367 if (dosdev) sdev = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6368 if (domdev) mdev = new DFloatGDL(auxiliaryDim, BaseGDL::NOZERO);
6369 if (omitNaN) {
6370 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6371 {
6372 #pragma omp for
6373 for (SizeT i = 0; i < nEl; ++i) {
6374 DFloat mdevl;
6375 DFloat sdevl;
6376 do_moment_nan(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl],
6377 (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6378 if (domean) (*mean)[i]=(*res)[i];
6379 if (dovar ) (*var )[i]=(*res)[i+nEl];
6380 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6381 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6382 if (dosdev) (*sdev)[i]=sdevl;
6383 if (domdev) (*mdev)[i]=mdevl;
6384 }
6385 }
6386 } else {
6387 #pragma omp parallel //if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
6388 {
6389 #pragma omp for
6390 for (SizeT i = 0; i < nEl; ++i) {
6391 DFloat mdevl;
6392 DFloat sdevl;
6393 do_moment(&(*input)[i * stride], stride, (*res)[i], (*res)[i+nEl],
6394 (*res)[i+2*nEl], (*res)[i+3*nEl], mdevl, sdevl, maxmoment);
6395 if (domean) (*mean)[i]=(*res)[i];
6396 if (dovar ) (*var )[i]=(*res)[i+nEl];
6397 if (doskew) (*skew)[i]=(*res)[i+2*nEl];
6398 if (dokurt) (*kurt)[i]=(*res)[i+3*nEl];
6399 if (dosdev) (*sdev)[i]=sdevl;
6400 if (domdev) (*mdev)[i]=mdevl;
6401 }
6402 }
6403 }
6404 if (clean_array) delete input;
6405 if (domean) e->SetKW( meanIx, mean );
6406 if (dovar ) e->SetKW( varIx, var );
6407 if (doskew) e->SetKW( skewIx, skew );
6408 if (dokurt) e->SetKW( kurtIx, kurt );
6409 if (dosdev) e->SetKW( sdevIx, sdev );
6410 if (domdev) e->SetKW( mdevIx, mdev );
6411 return res;
6412 }
6413 }
6414 } else {
6415 if (p0->Type() == GDL_COMPLEXDBL || (p0->Type() == GDL_COMPLEX && dbl)) {
6416 DComplexDblGDL* input = e->GetParAs<DComplexDblGDL>(0);
6417 DComplexDbl mean;
6418 DComplexDbl var;
6419 DComplexDbl skew;
6420 DComplexDbl kurt;
6421 DComplexDbl sdev;
6422 DDouble mdev;
6423 if (omitNaN) do_moment_cpx_nan<DComplexDbl, double>(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6424 else do_moment_cpx<DComplexDbl, double>(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6425 if (domean) e->SetKW( meanIx,new DComplexDblGDL( mean) );
6426 if (dovar ) e->SetKW( varIx, new DComplexDblGDL( var ) );
6427 if (doskew) e->SetKW( skewIx,new DComplexDblGDL( skew) );
6428 if (dokurt) e->SetKW( kurtIx,new DComplexDblGDL( kurt) );
6429 if (dosdev) e->SetKW( sdevIx,new DComplexDblGDL( sdev) );
6430 if (domdev) e->SetKW( mdevIx,new DDoubleGDL( mdev) );
6431 DComplexDblGDL* res = new DComplexDblGDL(4, BaseGDL::NOZERO);
6432 (*res)[0]=mean;
6433 (*res)[1]=var;
6434 (*res)[2]=skew;
6435 (*res)[3]=kurt;
6436 return res;
6437 } else if (p0->Type() == GDL_COMPLEX) {
6438 DComplexGDL* input = e->GetParAs<DComplexGDL>(0);
6439 DComplex mean;
6440 DComplex var;
6441 DComplex skew;
6442 DComplex kurt;
6443 DComplex sdev;
6444 DFloat mdev;
6445 if (omitNaN) do_moment_cpx_nan<DComplex, float>(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6446 else do_moment_cpx<DComplex, float>(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6447 if (domean) e->SetKW( meanIx,new DComplexGDL( mean) );
6448 if (dovar ) e->SetKW( varIx, new DComplexGDL( var ) );
6449 if (doskew) e->SetKW( skewIx,new DComplexGDL( skew) );
6450 if (dokurt) e->SetKW( kurtIx,new DComplexGDL( kurt) );
6451 if (dosdev) e->SetKW( sdevIx,new DComplexGDL( sdev) );
6452 if (domdev) e->SetKW( mdevIx,new DFloatGDL( mdev) );
6453 DComplexGDL* res = new DComplexGDL(4, BaseGDL::NOZERO);
6454 (*res)[0]=mean;
6455 (*res)[1]=var;
6456 (*res)[2]=skew;
6457 (*res)[3]=kurt;
6458 return res;
6459 } else {
6460 if (dbl) {
6461 DDoubleGDL* input = e->GetParAs<DDoubleGDL>(0);
6462 DDouble mean;
6463 DDouble var;
6464 DDouble skew;
6465 DDouble kurt;
6466 DDouble sdev;
6467 DDouble mdev;
6468 if (omitNaN) do_moment_nan(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6469 else do_moment(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6470 if (domean) e->SetKW( meanIx,new DDoubleGDL( mean) );
6471 if (dovar ) e->SetKW( varIx, new DDoubleGDL( var ) );
6472 if (doskew) e->SetKW( skewIx,new DDoubleGDL( skew) );
6473 if (dokurt) e->SetKW( kurtIx,new DDoubleGDL( kurt) );
6474 if (dosdev) e->SetKW( sdevIx,new DDoubleGDL( sdev) );
6475 if (domdev) e->SetKW( mdevIx,new DDoubleGDL( mdev) );
6476 DDoubleGDL* res = new DDoubleGDL(4, BaseGDL::NOZERO);
6477 (*res)[0]=mean;
6478 (*res)[1]=var;
6479 (*res)[2]=skew;
6480 (*res)[3]=kurt;
6481 return res;
6482 } else {
6483 DFloatGDL* input = e->GetParAs<DFloatGDL>(0);
6484 DFloat mean;
6485 DFloat var;
6486 DFloat skew;
6487 DFloat kurt;
6488 DFloat sdev;
6489 DFloat mdev;
6490 if (omitNaN) do_moment_nan(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6491 else do_moment(&(*input)[0], input->N_Elements(), mean, var, skew, kurt, mdev, sdev, maxmoment);
6492 if (domean) e->SetKW( meanIx,new DFloatGDL( mean) );
6493 if (dovar ) e->SetKW( varIx, new DFloatGDL( var ) );
6494 if (doskew) e->SetKW( skewIx,new DFloatGDL( skew) );
6495 if (dokurt) e->SetKW( kurtIx,new DFloatGDL( kurt) );
6496 if (dosdev) e->SetKW( sdevIx,new DFloatGDL( sdev) );
6497 if (domdev) e->SetKW( mdevIx,new DFloatGDL( mdev) );
6498 DFloatGDL* res = new DFloatGDL(4, BaseGDL::NOZERO);
6499 (*res)[0]=mean;
6500 (*res)[1]=var;
6501 (*res)[2]=skew;
6502 (*res)[3]=kurt;
6503 return res;
6504 }
6505 }
6506 }
6507 }
pos_ishft_s(T * out,const SizeT n,const char s)6508 template<typename T> void pos_ishft_s(T* out, const SizeT n, const char s) {
6509 // parallelization is marginally useful as the loop is well paralleized by compiler.
6510 #pragma omp parallel for if ((CpuTPOOL_NTHREADS > 1) && (n >= CpuTPOOL_MIN_ELTS) && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= n))
6511 for (SizeT i=0; i < n; ++i) out[i] <<= s;
6512 }
6513
neg_ishft_s(T * out,const SizeT n,const char s)6514 template<typename T> void neg_ishft_s(T* out, const SizeT n, const char s) {
6515 // parallelization is marginally useful as the loop is well paralleized by compiler.
6516 #pragma omp parallel for if ((CpuTPOOL_NTHREADS > 1) && (n >= CpuTPOOL_MIN_ELTS) && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= n))
6517 for (SizeT i = 0; i < n; ++i) out[i] >>= s;
6518 }
6519
ishft_m(T * out,const SizeT n,const DLong * s)6520 template<typename T> void ishft_m(T* out, const SizeT n, const DLong* s) {
6521 #pragma omp parallel for if ((CpuTPOOL_NTHREADS > 1) && (n >= CpuTPOOL_MIN_ELTS) && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= n))
6522 for (SizeT i = 0; i < n; ++i) {
6523 if (s[i] >= 0 ) out[i] <<= s[i]; else out[i] >>= s[i];
6524 }
6525 }
6526
ishft_single(BaseGDL * in,SizeT n,char s,bool pos)6527 BaseGDL* ishft_single(BaseGDL* in, SizeT n, char s, bool pos) {
6528 BaseGDL* out = in->Dup();
6529 switch (in->Type()) {
6530 case GDL_BYTE:
6531 {
6532 DByte* _out = static_cast<DByte*> (out->DataAddr());
6533 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s(_out, n, s);
6534 }
6535 break;
6536 case GDL_UINT:
6537 {
6538 DUInt* _out = static_cast<DUInt*> (out->DataAddr());
6539 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s( _out, n, s);
6540 }
6541 break;
6542 case GDL_INT:
6543 {
6544 DInt* _out = static_cast<DInt*> (out->DataAddr());
6545 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s(_out, n, s);
6546 }
6547 break;
6548 case GDL_LONG:
6549 {
6550 DLong* _out = static_cast<DLong*> (out->DataAddr());
6551 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s(_out, n, s);
6552 }
6553 break;
6554 case GDL_ULONG:
6555 {
6556 DULong* _out = static_cast<DULong*> (out->DataAddr());
6557 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s(_out, n, s);
6558 }
6559 break;
6560 case GDL_LONG64:
6561 {
6562 DULong64* _out = static_cast<DULong64*> (out->DataAddr());
6563 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s(_out, n, s);
6564 }
6565 break;
6566 case GDL_ULONG64:
6567 {
6568 DLong64* _out = static_cast<DLong64*> (out->DataAddr());
6569 if (pos) pos_ishft_s(_out, n, s); else neg_ishft_s(_out, n, s);
6570 }
6571 break;
6572 default:
6573 throw;
6574 }
6575 return out;
6576 }
6577
ishft_multiple(BaseGDL * in,DLongGDL * _s,SizeT n)6578 BaseGDL* ishft_multiple(BaseGDL* in, DLongGDL* _s, SizeT n) {
6579 BaseGDL* out = in->Dup(); //New(n, BaseGDL::NOZERO);
6580 DLong* s=static_cast<DLong*> (_s->DataAddr());
6581 switch (in->Type()) {
6582 case GDL_BYTE:
6583 {
6584 DByte* _out = static_cast<DByte*> (out->DataAddr());
6585 ishft_m(_out, n, s);
6586 }
6587 break;
6588 case GDL_UINT:
6589 {
6590 DUInt* _out = static_cast<DUInt*> (out->DataAddr());
6591 ishft_m( _out, n, s);
6592 }
6593 break;
6594 case GDL_INT:
6595 {
6596 DInt* _out = static_cast<DInt*> (out->DataAddr());
6597 ishft_m(_out, n, s);
6598 }
6599 break;
6600 case GDL_LONG:
6601 {
6602 DLong* _out = static_cast<DLong*> (out->DataAddr());
6603 ishft_m(_out, n, s);
6604 }
6605 break;
6606 case GDL_ULONG:
6607 {
6608 DULong* _out = static_cast<DULong*> (out->DataAddr());
6609 ishft_m(_out, n, s);
6610 }
6611 break;
6612 case GDL_LONG64:
6613 {
6614 DULong64* _out = static_cast<DULong64*> (out->DataAddr());
6615 ishft_m(_out, n, s);
6616 }
6617 break;
6618 case GDL_ULONG64:
6619 {
6620 DLong64* _out = static_cast<DLong64*> (out->DataAddr());
6621 ishft_m(_out, n, s);
6622 }
6623 break;
6624 default:
6625 throw;
6626 }
6627 return out;
6628 }
6629
ishft_fun(EnvT * e)6630 BaseGDL* ishft_fun(EnvT* e) {
6631 Guard<BaseGDL>guard;
6632
6633 BaseGDL* in=(e->GetParDefined(0));
6634 DType typ = in->Type();
6635 //types are normally correct, so do not loose time looking for wrong types
6636 if (IntType(typ)) {
6637 dimension finalDim;
6638 //behaviour: minimum set of dimensions of arrays. singletons expanded to dimension,
6639 //keep array trace.
6640 SizeT nEl, maxEl = 1, minEl, finalN = 1;
6641 for (int i = 0; i < 2; ++i) {
6642 nEl = e->GetPar(i)->N_Elements();
6643 if ((nEl > 1) && (nEl > maxEl)) {
6644 maxEl = nEl;
6645 finalN = maxEl;
6646 finalDim = e->GetPar(i)->Dim();
6647 }
6648 } //first max - but we need first min:
6649 minEl = maxEl;
6650 for (int i = 0; i < 2; ++i) {
6651 nEl = e->GetPar(i)->N_Elements();
6652 if ((nEl > 1) && (nEl < minEl)) {
6653 minEl = nEl;
6654 finalN = minEl;
6655 finalDim = e->GetPar(i)->Dim();
6656 }
6657 }
6658 //note: res is always 0's type:
6659 //fill shift, using a large type Long as apparently IDL does
6660 DLongGDL* sss=e->GetParAs<DLongGDL>(1);
6661 //if sss is a singleton, or not:
6662 if (sss->N_Elements() == 1) {
6663 char shift;
6664 if ((*sss)[0] ==0) return in->Dup();
6665 else if ((*sss)[0] > 0) {
6666 if ((*sss)[0] > 254) shift = -1; else shift = (*sss)[0];
6667 return ishft_single(in, finalN, shift, true);
6668 } else {
6669 if ( (*sss)[0] < -254 ) shift = -1; else shift = -(*sss)[0];
6670 return ishft_single(in, finalN, shift, false);
6671 }
6672 } else {
6673 if (in->Scalar()) {in=in->New( finalN, BaseGDL::INIT); guard.Reset(in);} //expand to return element size, for parallel processing
6674 return ishft_multiple(in, sss, finalN);
6675 }
6676 } else e->Throw("Operand must be integer:" + e->GetParString(0));
6677 return NULL; //pacify dumb compilers.
6678 }
6679
shift_fun(EnvT * e)6680 BaseGDL* shift_fun( EnvT* e) {
6681 SizeT nParam = e->NParam(2);
6682
6683 BaseGDL* p0 = e->GetParDefined(0);
6684
6685 SizeT nShift = nParam - 1;
6686
6687 DLong sIx[ MAXRANK];
6688
6689 // in fact, the second param can be a singleton or an array ...
6690 if (nShift == 1) {
6691 DLongGDL* s1v = e->GetParAs<DLongGDL>(1);
6692
6693 if (s1v->N_Elements() == 1) {
6694 DLong s1;
6695 e->AssureLongScalarPar(1, s1);
6696
6697 // IncRef[Obj] done for GDL_PTR and GDL_OBJ
6698 return p0->CShift(s1);
6699 }
6700
6701 if (p0->Rank() != s1v->N_Elements())
6702 e->Throw("Incorrect number of arguments.");
6703
6704 for (SizeT i = 0; i < s1v->N_Elements(); i++)
6705 sIx[ i] = (*s1v)[i];
6706 } else {
6707
6708 if (p0->Rank() != nShift)
6709 e->Throw("Incorrect number of arguments.");
6710
6711 // DLong sIx[ MAXRANK];
6712 for (SizeT i = 0; i < nShift; i++)
6713 e->AssureLongScalarPar(i + 1, sIx[ i]);
6714
6715 if (p0->Type() == GDL_OBJ)
6716 GDLInterpreter::IncRefObj(static_cast<DObjGDL*> (p0));
6717 else if (p0->Type() == GDL_PTR)
6718 GDLInterpreter::IncRef(static_cast<DPtrGDL*> (p0));
6719
6720 }
6721
6722 return p0->CShift(sIx);
6723 }
6724
arg_present(EnvT * e)6725 BaseGDL* arg_present( EnvT* e)
6726 {
6727 e->NParam( 1);
6728
6729 if( !e->GlobalPar( 0))
6730 return new DIntGDL( 0);
6731
6732 EnvBaseT* caller = e->Caller();
6733 if( caller == NULL)
6734 return new DIntGDL( 0);
6735
6736 BaseGDL** pp0 = &e->GetPar( 0);
6737
6738 int ix = caller->FindGlobalKW( pp0);
6739 if( ix == -1)
6740 return new DIntGDL( 0);
6741
6742 return new DIntGDL( 1);
6743 }
6744
eof_fun(EnvT * e)6745 BaseGDL* eof_fun( EnvT* e)
6746 {
6747 e->NParam( 1);
6748
6749 DLong lun;
6750 e->AssureLongScalarPar( 0, lun);
6751
6752 bool stdLun = check_lun( e, lun);
6753 if( stdLun)
6754 return new DIntGDL( 0);
6755
6756 // nicer error message (Disregard if socket)
6757 if ( fileUnits[ lun-1].SockNum() == -1) {
6758 if( !fileUnits[ lun-1].IsOpen())
6759 throw GDLIOException( e->CallingNode(), "File unit is not open: "+i2s( lun)+".");
6760
6761 if( fileUnits[ lun-1].Eof())
6762 return new DIntGDL( 1);
6763 } else {
6764 // Socket
6765 string *recvBuf = &fileUnits[ lun-1].RecvBuf();
6766 if (recvBuf->size() == 0)
6767 return new DIntGDL( 1);
6768 }
6769 return new DIntGDL( 0);
6770 }
6771
rebin_fun(EnvT * e)6772 BaseGDL* rebin_fun( EnvT* e)
6773 {
6774 SizeT nParam = e->NParam( 2);
6775
6776 BaseGDL* p0 = e->GetNumericParDefined( 0);
6777
6778 SizeT rank = p0->Rank();
6779
6780 if( rank == 0)
6781 e->Throw( "Expression must be an array in this context: "+
6782 e->GetParString(0));
6783
6784 SizeT resDimInit[ MAXRANK];
6785
6786 DLongGDL* p1 = e->GetParAs<DLongGDL>(1);
6787 if (p1->Rank() > 0 && nParam > 2)
6788 e->Throw("The new dimensions must either be specified as an array or as a set of scalars.");
6789 SizeT np = p1->Rank() == 0 ? nParam : p1->N_Elements() + 1;
6790
6791 for( SizeT p=1; p<np; ++p)
6792 {
6793 DLong newDim;
6794 if (p1->Rank() == 0) e->AssureLongScalarPar( p, newDim);
6795 else newDim = (*p1)[p - 1];
6796
6797 if( newDim <= 0)
6798 e->Throw( "Array dimensions must be greater than 0.");
6799
6800 if( rank >= p)
6801 {
6802 SizeT oldDim = p0->Dim( p-1);
6803
6804 if( newDim > oldDim)
6805 {
6806 if( (newDim % oldDim) != 0)
6807 e->Throw( "Result dimensions must be integer factor "
6808 "of original dimensions.");
6809 }
6810 else
6811 {
6812 if( (oldDim % newDim) != 0)
6813 e->Throw( "Result dimensions must be integer factor "
6814 "of original dimensions.");
6815 }
6816 }
6817
6818 resDimInit[ p-1] = newDim;
6819 }
6820
6821 dimension resDim( resDimInit, np-1);
6822
6823 static int sampleIx = e->KeywordIx( "SAMPLE");
6824 bool sample = e->KeywordSet( sampleIx);
6825
6826 return p0->Rebin( resDim, sample);
6827 }
6828
obj_class(EnvT * e)6829 BaseGDL* obj_class(EnvT* e)
6830 {
6831 SizeT nParam = e->NParam();
6832
6833 static int countIx = e->KeywordIx("COUNT");
6834 static int superIx = e->KeywordIx("SUPERCLASS");
6835
6836 bool super = e->KeywordSet(superIx);
6837
6838 bool count = e->KeywordPresent(countIx);
6839 if (count)
6840 e->AssureGlobalKW(countIx);
6841
6842 if (nParam > 0) {
6843 BaseGDL* p0 = e->GetParDefined(0);
6844
6845 if (p0->Type() != GDL_STRING && p0->Type() != GDL_OBJ)
6846 e->Throw("Argument must be a scalar object reference or string: " +
6847 e->GetParString(0));
6848
6849 if (!p0->Scalar())
6850 e->Throw("Expression must be a scalar or 1 element "
6851 "array in this context: " + e->GetParString(0));
6852
6853 DStructDesc* objDesc;
6854
6855 if (p0->Type() == GDL_STRING) {
6856 DString objName;
6857 e->AssureScalarPar<DStringGDL>(0, objName);
6858 objName = StrUpCase(objName);
6859
6860 objDesc = FindObjectInStructList(structList, objName);
6861 if (objDesc == NULL) {
6862 if (count)
6863 e->SetKW(countIx, new DLongGDL(0));
6864 return new DStringGDL("");
6865 }
6866 } else // GDL_OBJ
6867 {
6868 DObj objRef;
6869 e->AssureScalarPar<DObjGDL>(0, objRef);
6870
6871 if (objRef == 0) {
6872 if (count)
6873 e->SetKW(countIx, new DLongGDL(0));
6874 return new DStringGDL("");
6875 }
6876
6877 DStructGDL* oStruct;
6878 try {
6879 oStruct = e->GetObjHeap(objRef);
6880 } catch (GDLInterpreter::HeapException&) { // non valid object
6881 if (count)
6882 e->SetKW(countIx, new DLongGDL(0));
6883 return new DStringGDL("");
6884 }
6885
6886 objDesc = oStruct->Desc(); // cannot be NULL
6887 }
6888
6889 if (!super) {
6890 if (count)
6891 e->SetKW(countIx, new DLongGDL(1));
6892 return new DStringGDL(objDesc->Name());
6893 }
6894
6895 vector< string> pNames;
6896 objDesc->GetParentNames(pNames);
6897
6898 SizeT nNames = pNames.size();
6899
6900 if (count)
6901 e->SetKW(countIx, new DLongGDL(nNames));
6902
6903 if (nNames == 0) {
6904 return new DStringGDL("");
6905 }
6906
6907 DStringGDL* res = new DStringGDL(dimension(nNames),
6908 BaseGDL::NOZERO);
6909
6910 for (SizeT i = 0; i < nNames; ++i) {
6911 (*res)[i] = pNames[i];
6912 }
6913
6914 return res;
6915 }
6916
6917 if (super)
6918 e->Throw("Conflicting keywords.");
6919
6920 vector< string> objNames;
6921 for (SizeT i = 0; i < structList.size(); ++i) {
6922 if ((structList[i]->FunList().size() + structList[i]->ProList().size()) == 0) continue;
6923 objNames.push_back(structList[i]->Name());
6924 }
6925 SizeT nObj = objNames.size();
6926 if (count) e->SetKW(countIx, new DLongGDL(nObj));
6927 if (nObj > 0) {
6928 DStringGDL* res = new DStringGDL(dimension(nObj), BaseGDL::NOZERO);
6929
6930 for (SizeT i = 0; i < nObj; ++i) {
6931 (*res)[i] = objNames[i];
6932 }
6933 return res;
6934 } else return new DStringGDL("");
6935
6936 }
obj_hasmethod(EnvT * e)6937 BaseGDL* obj_hasmethod( EnvT* e)
6938 {
6939 SizeT nParam = e->NParam( 2);
6940 //trace_me = trace_arg();
6941 BaseGDL*& p0 = e->GetPar( 0);
6942 if( p0 == NULL || p0->Type() != GDL_OBJ)
6943 e->Throw( "Object reference type required in this context: "+
6944 e->GetParString(0));
6945
6946 BaseGDL* p1 = e->GetParDefined( 1);
6947 if( p1->Type() != GDL_STRING)
6948 e->Throw( "Methods can be referenced only with names (strings)");
6949 DStringGDL* p1S = static_cast<DStringGDL*>( p1);
6950 DObjGDL* pObj = static_cast<DObjGDL*>( p0);
6951 SizeT nObj = p0->StrictScalar() ? 1 : p0->N_Elements();
6952 DByteGDL* res = new DByteGDL( dimension(nObj));
6953 Guard<DByteGDL> res_guard(res);
6954 DByteGDL* altres = new DByteGDL( dimension(nObj));
6955 Guard<DByteGDL> altres_guard(altres);
6956 GDLInterpreter* interpreter = e->Interpreter();
6957
6958 for( SizeT iobj=0; iobj<nObj; ++iobj)
6959 {
6960 if( ((*res)[iobj] != 0) || ((*altres)[iobj] != 0)) continue;
6961 DObj s = (*static_cast<DObjGDL*>( p0))[iobj];
6962 if( s != 0)
6963 {
6964 // DStructGDL* oStruct = e->GetObjHeap( (*pObj)[iobj]);
6965 DStructGDL* oStruct = e->GetObjHeap( s);
6966 //if(trace_me) std::cout << " oStruct";
6967 DStructDesc* odesc = oStruct->Desc();
6968 int passed = 1;
6969 for( SizeT m=0; m<p1->N_Elements(); m++)
6970 {
6971 DString method = StrUpCase((*p1S)[m]);
6972 // if(trace_me) std::cout << method;
6973 if( odesc->GetFun( method) != NULL) continue;
6974 if( odesc->GetPro( method) != NULL) continue;
6975 passed = 0; break;
6976 }
6977 (*res)[iobj] = passed;
6978 for( SizeT i=iobj+1; i<nObj; ++i) {
6979 if( interpreter->ObjValid( (*pObj)[ i]))
6980 if( e->GetObjHeap( (*pObj)[i])->Desc() == odesc) {
6981 (*res)[i] = passed;
6982 (*altres)[i] = 1-passed;
6983 }
6984 }
6985 } // else if(trace_me) std::cout << " 0 ";
6986 }
6987 if( p0->StrictScalar())
6988 return new DByteGDL((*res)[0]);
6989 else return res_guard.release();
6990 }
6991
obj_isa(EnvT * e)6992 BaseGDL* obj_isa(EnvT* e) {
6993 DString className;
6994 e->AssureScalarPar<DStringGDL>(1, className);
6995 className = StrUpCase(className);
6996 if( className == "IDL_OBJECT")
6997 className = GDL_OBJECT_NAME;
6998 else if( className == "IDL_CONTAINER" )
6999 className = GDL_CONTAINER_NAME;
7000 BaseGDL* p0 = e->GetPar(0);
7001 //nObjects is the number of objects or strings passed in array format.
7002 SizeT nElem = p0->N_Elements();
7003
7004 DByteGDL* res = new DByteGDL(p0->Dim()); // zero
7005
7006 if (p0->Type() == GDL_OBJ) {
7007 DObjGDL* pObj = static_cast<DObjGDL*> (p0);
7008 if (pObj) { //pObj protection probably overkill.
7009 for (SizeT i = 0; i < nElem; ++i) {
7010 if (e->Interpreter()->ObjValid((*pObj)[ i])) {
7011 DStructGDL* oStruct = e->GetObjHeap((*pObj)[i]);
7012 if (oStruct->Desc()->IsParent(className))
7013 (*res)[i] = 1;
7014 }
7015 }
7016 return res;
7017 }
7018 } else if (p0->Type() == GDL_STRING) {
7019 std::cerr << "OBJ_ISA: not implemented for strings, only objects (FIXME)." << endl;
7020 for (SizeT i = 0; i < nElem; ++i) {
7021 (*res)[i] = 0;
7022 }
7023 return res;
7024 } else e->Throw("Object reference type required in this context: " + e->GetParString(0)); return NULL;
7025 }
7026
n_tags(EnvT * e)7027 BaseGDL* n_tags( EnvT* e)
7028 {
7029 e->NParam( 1);
7030
7031 BaseGDL* p0 = e->GetPar( 0);
7032 if( p0 == NULL)
7033 return new DLongGDL( 0);
7034
7035 if( p0->Type() != GDL_STRUCT)
7036 return new DLongGDL( 0);
7037
7038 DStructGDL* s = static_cast<DStructGDL*>( p0);
7039
7040 //static int lengthIx = e->KeywordIx( "DATA_LENGTH");
7041 //bool length = e->KeywordSet( lengthIx);
7042
7043 // we don't know now how to distinguish the 2 following cases
7044 static int datalengthIx=e->KeywordIx("DATA_LENGTH");
7045 static int lengthIx=e->KeywordIx("LENGTH");
7046
7047 if(e->KeywordSet(datalengthIx))
7048 return new DLongGDL( s->SizeofTags());
7049
7050 if(e->KeywordSet(lengthIx))
7051 return new DLongGDL( s->Sizeof());
7052
7053 return new DLongGDL( s->Desc()->NTags());
7054 }
7055
bytscl(EnvT * e)7056 BaseGDL* bytscl(EnvT* e) {
7057 SizeT nParam = e->NParam(1);
7058
7059 BaseGDL* p0 = e->GetNumericParDefined(0);
7060
7061 static int minIx = e->KeywordIx("MIN");
7062 static int maxIx = e->KeywordIx("MAX");
7063 static int topIx = e->KeywordIx("TOP");
7064 static int nanIx = e->KeywordIx("NAN");
7065 bool omitNaN = e->KeywordPresent(nanIx);
7066
7067 //the following is going to be wrong in cases where TOP is so negative that a Long does not suffice.
7068 //Besides, a template version for each different type would be faster and probably the only solution to get the
7069 //correct behavior in all cases.
7070 DLong topL = 255;
7071 if (e->GetKW(topIx) != NULL)
7072 e->AssureLongScalarKW(topIx, topL);
7073 if (topL > 255) topL = 255; // Bug corrected: Topl cannot be > 255.
7074 DDouble dTop = static_cast<DDouble> (topL); //Topl can be extremely negative.
7075
7076 DDouble min;
7077 bool minSet = false;
7078 // SA: handling 3 parameters to emulate undocumented IDL behaviour
7079 // of translating second and third arguments to MIN and MAX, respectively
7080 // (parameters have precedence over keywords)
7081 if (nParam >= 2) {
7082 e->AssureDoubleScalarPar(1, min);
7083 minSet = true;
7084 }
7085 else if (e->GetKW(minIx) != NULL) {
7086 e->AssureDoubleScalarKW(minIx, min);
7087 minSet = true;
7088 }
7089
7090 DDouble max;
7091 bool maxSet = false;
7092 if (nParam == 3) {
7093 e->AssureDoubleScalarPar(2, max);
7094 maxSet = true;
7095 } else if (e->GetKW(maxIx) != NULL) {
7096 e->AssureDoubleScalarKW(maxIx, max);
7097 maxSet = true;
7098 }
7099
7100 DDoubleGDL* dRes =
7101 static_cast<DDoubleGDL*> (p0->Convert2(GDL_DOUBLE, BaseGDL::COPY));
7102
7103 DLong maxEl, minEl;
7104 if (!maxSet || !minSet)
7105 dRes->MinMax(&minEl, &maxEl, NULL, NULL, omitNaN);
7106 if (!minSet)
7107 min = (*dRes)[ minEl];
7108 if (!maxSet)
7109 max = (*dRes)[ maxEl];
7110
7111 // cout << "Min/max :" << min << " " << max << endl;
7112
7113 SizeT nEl = dRes->N_Elements();
7114
7115 if (IntType(p0->Type())) {
7116 //Is a thread pool function
7117 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
7118 for (SizeT i = 0; i < nEl; ++i) {
7119 DDouble& d = (*dRes)[ i];
7120 if (omitNaN && (isnan(d) || isinf(d))) (*dRes)[ i] = 0;
7121 else if (d <= min) (*dRes)[ i] = 0;
7122 else if (d >= max) (*dRes)[ i] = dTop;
7123 else {
7124 // SA: floor is used for integer types to simulate manipulation on input data types
7125 (*dRes)[ i] = floor(((dTop + 1.)*(d - min) - 1.) / (max - min));
7126 }
7127 }
7128 } else {
7129 #pragma omp parallel for if (nEl >= CpuTPOOL_MIN_ELTS && (CpuTPOOL_MAX_ELTS == 0 || CpuTPOOL_MAX_ELTS <= nEl))
7130 for (SizeT i = 0; i < nEl; ++i) {
7131 DDouble& d = (*dRes)[ i];
7132 if (omitNaN && (isnan(d) || isinf(d))) (*dRes)[ i] = 0;
7133 else if (d <= min) (*dRes)[ i] = 0;
7134 else if (d >= max) (*dRes)[ i] = dTop;
7135 else {
7136 // SA (?): here floor is used (instead of round) to simulate IDL behaviour
7137 (*dRes)[ i] = floor(((dTop + .9999)*(d - min)) / (max - min) );
7138 }
7139 }
7140 }
7141 return dRes->Convert2(GDL_BYTE);
7142 }
7143
strtok_fun(EnvT * e)7144 BaseGDL* strtok_fun(EnvT* e) {
7145 SizeT nParam = e->NParam(1);
7146
7147 DString stringIn;
7148 e->AssureStringScalarPar(0, stringIn);
7149
7150 DString pattern = " \t";
7151 if (nParam > 1) {
7152 e->AssureStringScalarPar(1, pattern);
7153 }
7154
7155 static int extractIx = e->KeywordIx( "EXTRACT");
7156 bool extract = e->KeywordSet( extractIx);
7157
7158 static int countIx = e->KeywordIx( "COUNT");
7159 bool countPresent = e->KeywordPresent( countIx);
7160
7161 static int lengthIx = e->KeywordIx( "LENGTH");
7162 bool lengthPresent = e->KeywordPresent( lengthIx);
7163
7164 static int pre0Ix = e->KeywordIx("PRESERVE_NULL");
7165 bool pre0 = e->KeywordSet(pre0Ix);
7166
7167 static int regexIx = e->KeywordIx("REGEX");
7168 bool regex = e->KeywordSet(regexIx);
7169 char err_msg[MAX_REGEXPERR_LENGTH];
7170 regex_t regexp;
7171
7172 static int foldCaseIx = e->KeywordIx( "FOLD_CASE" );
7173 bool foldCaseKW = e->KeywordSet( foldCaseIx );
7174 //FOLD_CASE can only be specified if the REGEX keyword is set
7175 if (!regex && foldCaseKW) e->Throw("Conflicting keywords.");
7176
7177 vector<long> tokenStart;
7178 vector<long> tokenLen;
7179
7180 int strLen = stringIn.length();
7181
7182 DString escape = "";
7183 static int ESCAPEIx=e->KeywordIx("ESCAPE");
7184
7185 //ESCAPE cannot be specified with the FOLD_CASE or REGEX keywords.
7186 if (regex && e->KeywordPresent(ESCAPEIx)) e->Throw("Conflicting keywords.");
7187 if (foldCaseKW && e->KeywordPresent(ESCAPEIx)) e->Throw("Conflicting keywords.");
7188
7189 e->AssureStringScalarKWIfPresent(ESCAPEIx, escape);
7190 vector<long> escList;
7191 long pos = 0;
7192 while (pos != string::npos) {
7193 pos = stringIn.find_first_of(escape, pos);
7194 if (pos != string::npos) {
7195 escList.push_back(pos + 1); // remember escaped char
7196 pos += 2; // skip escaped char
7197 }
7198 }
7199 vector<long>::iterator escBeg = escList.begin();
7200 vector<long>::iterator escEnd = escList.end();
7201
7202 long tokB = 0;
7203 long tokE;
7204 long nextE = 0;
7205 long actLen;
7206 //special case: pattern void string
7207 if (pattern.size()==0) {
7208 if (lengthPresent) {
7209 e->AssureGlobalKW(lengthIx);
7210 e->SetKW(lengthIx, new DLongGDL(0));
7211 }
7212 if (countPresent) {
7213 e->AssureGlobalKW(countIx);
7214 e->SetKW(countIx, new DLongGDL(0));
7215 }
7216 if (!extract) return new DLongGDL(0); else return new DStringGDL("");
7217 }
7218
7219 // If regex then compile regex.
7220 // set the compile flags to use the REG_ICASE facility in case /FOLD_CASE is given.
7221 int cflags = REG_EXTENDED;
7222 if (foldCaseKW)
7223 cflags |= REG_ICASE;
7224
7225 if (regex) {
7226 if (pattern == " \t") pattern = " "; // regcomp doesn't like "\t" JMG
7227 int compRes = regcomp(®exp, pattern.c_str(), cflags);
7228 if (compRes) {
7229 regerror(compRes, ®exp, err_msg, MAX_REGEXPERR_LENGTH);
7230 e->Throw("Error processing regular expression: " +
7231 pattern + "\n " + string(err_msg) + ".");
7232 }
7233 }
7234
7235 if (foldCaseKW && !regex) { //duplicate pattern with ascii chars upcased
7236 pattern=pattern+StrUpCase(pattern);
7237 }
7238 for (;;) {
7239 regmatch_t pmatch[1];
7240 if (regex) {
7241 int matchres = regexec(®exp, stringIn.c_str() + nextE, 1, pmatch, 0);
7242 tokE = matchres ? -1 : pmatch[0].rm_so;
7243 } else {
7244 tokE = stringIn.find_first_of(pattern, nextE);
7245 }
7246
7247 if (tokE == string::npos) {
7248 actLen = strLen - tokB;
7249 if (actLen > 0 || pre0) {
7250 tokenStart.push_back(tokB);
7251 tokenLen.push_back(actLen);
7252 }
7253 break;
7254 }
7255
7256 if (find(escBeg, escEnd, tokE) == escEnd) {
7257 if (regex) actLen = tokE;
7258 else actLen = tokE - tokB;
7259 if (actLen > 0 || pre0) {
7260 tokenStart.push_back(tokB);
7261 tokenLen.push_back(actLen);
7262 }
7263 if (regex) tokB += pmatch[0].rm_eo;
7264 else tokB = tokE + 1;
7265 }
7266 if (regex) nextE += pmatch[0].rm_eo;
7267 else nextE = tokE + 1;
7268 } // for(;;)
7269
7270 if (regex) regfree(®exp);
7271
7272 SizeT nTok = tokenStart.size();
7273 if (countPresent) {
7274 e->AssureGlobalKW(countIx);
7275 if (nTok > 0) {
7276 DLongGDL* count = new DLongGDL(nTok);
7277 e->SetKW(countIx, count);
7278 } else {
7279 e->SetKW(countIx, new DLongGDL(0));
7280 }
7281 }
7282
7283 if (lengthPresent) {
7284 e->AssureGlobalKW(lengthIx);
7285
7286 if (nTok > 0) {
7287 dimension dim(nTok);
7288 DLongGDL* len = new DLongGDL(dim);
7289 for (int i = 0; i < nTok; i++)
7290 (*len)[i] = tokenLen[i];
7291
7292 e->SetKW(lengthIx, len);
7293 } else {
7294 e->SetKW(lengthIx, new DLongGDL(0));
7295 }
7296 }
7297
7298 if (!extract) {
7299
7300 if (nTok == 0) return new DLongGDL(0);
7301
7302 dimension dim(nTok);
7303 DLongGDL* d = new DLongGDL(dim);
7304 for (int i = 0; i < nTok; i++)
7305 (*d)[i] = tokenStart[i];
7306 return d;
7307 } else {
7308
7309 // EXTRACT
7310 if (nTok == 0) return new DStringGDL("");
7311
7312 dimension dim(nTok);
7313 DStringGDL *d = new DStringGDL(dim);
7314 for (int i = 0; i < nTok; i++) {
7315 (*d)[i] = stringIn.substr(tokenStart[i], tokenLen[i]);
7316
7317 // remove escape
7318 DString& act = (*d)[i];
7319 long escPos = act.find_first_of(escape, 0);
7320 while (escPos != string::npos) {
7321 act = act.substr(0, escPos) + act.substr(escPos + 1);
7322 escPos = act.find_first_of(escape, escPos + 1);
7323 }
7324 }
7325 return d;
7326 }
7327 }
7328
getenv_fun(EnvT * e)7329 BaseGDL* getenv_fun( EnvT* e)
7330 {
7331 SizeT nParam=e->NParam();
7332
7333 static int environmentIx = e->KeywordIx( "ENVIRONMENT" );
7334 bool environment = e->KeywordSet( environmentIx );
7335
7336 SizeT nEnv;
7337 DStringGDL* env;
7338
7339 if( environment) {
7340
7341 if(nParam != 0)
7342 e->Throw( "Incorrect number of arguments.");
7343
7344 // determine number of environment entries
7345 for(nEnv = 0; environ[nEnv] != NULL ; ++nEnv);
7346
7347 dimension dim( nEnv );
7348 env = new DStringGDL(dim);
7349
7350 // copy stuff into local string array
7351 for(SizeT i=0; i < nEnv ; ++i)
7352 (*env)[i] = environ[i];
7353
7354 } else {
7355
7356 if(nParam != 1)
7357 e->Throw( "Incorrect number of arguments.");
7358
7359 DStringGDL* name = e->GetParAs<DStringGDL>(0);
7360 nEnv = name->N_Elements();
7361
7362 env = new DStringGDL( name->Dim());
7363
7364 // copy the stuff into local string only if param found
7365 char *resPtr;
7366 for(SizeT i=0; i < nEnv ; ++i)
7367 {
7368 // handle special environment variables
7369 // GDL_TMPDIR, IDL_TMPDIR
7370 if( (*name)[i] == "GDL_TMPDIR" || (*name)[i] == "IDL_TMPDIR")
7371 {
7372 resPtr = getenv((*name)[i].c_str());
7373
7374 if (resPtr != NULL)
7375 {
7376 (*env)[i] = resPtr;
7377 }
7378 else
7379 {
7380 // (*env)[i] = SysVar::Dir();
7381 #ifdef _WIN32
7382 WCHAR tmpBuf[MAX_PATH];
7383 GetTempPathW(MAX_PATH, tmpBuf);
7384 char c_tmpBuf[MAX_PATH];
7385 WideCharToMultiByte(CP_ACP, 0, tmpBuf, MAX_PATH, c_tmpBuf, MAX_PATH, NULL, NULL);
7386 (*env)[i] = c_tmpBuf;
7387 #else
7388 // AC 2017/10/19 : why _PATH_VARTMP_, not just _PATH_TMP_
7389 (*env)[i] = _PATH_TMP ;
7390 #endif
7391 }
7392 AppendIfNeeded( (*env)[i], lib::PathSeparator());
7393 }
7394 else // normal environment variables
7395 if( (resPtr = getenv((*name)[i].c_str())) )
7396 (*env)[i] = resPtr;
7397 }
7398 }
7399
7400 return env;
7401 }
7402
tag_names_fun(EnvT * e)7403 BaseGDL* tag_names_fun( EnvT* e)
7404 {
7405 SizeT nParam=e->NParam();
7406 BaseGDL* p = e->GetParDefined(0);
7407 DStructGDL* struc = nullptr;
7408 if( p->Type() == DObjGDL::t ) {
7409 DObjGDL* obj = static_cast<DObjGDL*>( p);
7410 DObj objRef;
7411 if( obj && obj->Scalar( objRef ) ) {
7412 try {
7413 struc = e->GetObjHeap( objRef );
7414 } catch ( GDLInterpreter::HeapException& ) { }
7415 }
7416 } else if( p->Type() == DStructGDL::t ) {
7417 struc = static_cast<DStructGDL*>( p);
7418 }
7419
7420 if( !struc ) {
7421 e->Throw( "Error: Failed to obtain structure. Input type: " + p->TypeStr() );
7422 }
7423
7424 static int structureNameIx = e->KeywordIx( "STRUCTURE_NAME" );
7425 bool structureName = e->KeywordSet( structureNameIx );
7426
7427 DStringGDL* tagNames;
7428
7429 if(structureName){
7430
7431 if ((*struc).Desc()->Name() != "$truct") {
7432 tagNames = new DStringGDL((*struc).Desc()->Name());
7433 } else {
7434 tagNames = new DStringGDL("");
7435 }
7436 } else {
7437 SizeT nTags = (*struc).Desc()->NTags();
7438 tagNames = new DStringGDL(dimension(nTags));
7439 for(int i=0; i < nTags; ++i) {
7440 (*tagNames)[i] = (*struc).Desc()->TagName(i);
7441 }
7442 }
7443
7444 return tagNames;
7445
7446 }
7447
7448 // AC 12-Oc-2011: better version for: len=len, /Extract and /Sub
7449 // but it is still not perfect
7450
stregex_fun(EnvT * e)7451 BaseGDL* stregex_fun( EnvT* e)
7452 {
7453 SizeT nParam=e->NParam( 2);
7454
7455 DStringGDL* stringExpr= e->GetParAs<DStringGDL>(0);
7456 dimension dim = stringExpr->Dim();
7457
7458 DString pattern;
7459 e->AssureStringScalarPar(1, pattern);
7460 if (pattern.size() <= 0)
7461 {
7462 e->Throw( "Error processing regular expression: "+pattern+
7463 "\n empty (sub)expression");
7464 }
7465
7466 static int booleanIx = e->KeywordIx( "BOOLEAN" );
7467 bool booleanKW = e->KeywordSet( booleanIx );
7468
7469 static int extractIx = e->KeywordIx( "EXTRACT" );
7470 bool extractKW = e->KeywordSet( extractIx );
7471
7472 static int foldCaseIx = e->KeywordIx( "FOLD_CASE" );
7473 bool foldCaseKW = e->KeywordSet( foldCaseIx );
7474
7475 //XXXpch: this is wrong, should check arg_present
7476 static int lengthIx = e->KeywordIx( "LENGTH" );
7477 bool lengthKW = e->KeywordPresent( lengthIx );
7478
7479 static int subexprIx = e->KeywordIx( "SUBEXPR" );
7480 bool subexprKW = e->KeywordSet( subexprIx );
7481
7482 if( booleanKW && (subexprKW || extractKW || lengthKW))
7483 e->Throw( "Conflicting keywords.");
7484
7485 char err_msg[MAX_REGEXPERR_LENGTH];
7486
7487 // set the compile flags
7488 int cflags = REG_EXTENDED;
7489 if (foldCaseKW)
7490 cflags |= REG_ICASE;
7491 if (booleanKW)
7492 cflags |= REG_NOSUB;
7493
7494 // compile the regular expression
7495 regex_t regexp;
7496 int compRes = regcomp( ®exp, pattern.c_str(), cflags);
7497 SizeT nSubExpr = regexp.re_nsub + 1;
7498
7499 // cout << regexp.re_nsub << endl;
7500
7501 if (compRes) {
7502 regerror(compRes, ®exp, err_msg, MAX_REGEXPERR_LENGTH);
7503 e->Throw( "Error processing regular expression: "+
7504 pattern+"\n "+string(err_msg)+".");
7505 }
7506
7507 BaseGDL* result;
7508
7509 if( booleanKW)
7510 result = new DByteGDL(dim);
7511 else if( extractKW && !subexprKW)
7512 {
7513 // cout << "my pb ! ? dim= " << dim << endl;
7514 result = new DStringGDL(dim);
7515 }
7516 else if( subexprKW)
7517 {
7518 // cout << "my pb 2 ? dim= " << dim << endl;
7519 dimension subExprDim = dim;
7520 subExprDim >> nSubExpr; // m_schellens: commented in, needed
7521 if( extractKW)
7522 result = new DStringGDL(subExprDim);
7523 else
7524 result = new DLongGDL(subExprDim);
7525 }
7526 else
7527 result = new DLongGDL(dim);
7528
7529 DLongGDL* len = NULL;
7530 if( lengthKW) {
7531 e->AssureGlobalKW( lengthIx);
7532 if( subexprKW)
7533 {
7534 dimension subExprDim = dim;
7535 subExprDim >> nSubExpr; // m_schellens: commented in, needed
7536 len = new DLongGDL(subExprDim);
7537 }
7538 else
7539 {
7540 len = new DLongGDL(dim);
7541 }
7542 for( SizeT i=0; i<len->N_Elements(); ++i)
7543 (*len)[i]= -1;
7544 }
7545
7546 int nmatch = 1;
7547 if( subexprKW) nmatch = nSubExpr;
7548
7549 regmatch_t* pmatch = new regmatch_t[nSubExpr];
7550 ArrayGuard<regmatch_t> pmatchGuard( pmatch);
7551
7552 // cout << "dim " << dim.NDimElements() << endl;
7553 for( SizeT s=0; s<dim.NDimElements(); ++s)
7554 {
7555 int eflags = 0;
7556
7557 for( SizeT sE=0; sE<nSubExpr; ++sE)
7558 pmatch[sE].rm_so = -1;
7559
7560 // now match towards the string
7561 int matchres = regexec( ®exp, (*stringExpr)[s].c_str(), nmatch, pmatch, eflags);
7562
7563 // subexpressions
7564 if ( extractKW && subexprKW) {
7565
7566 // Loop through subexpressions & fill output array
7567 for( SizeT i = 0; i<nSubExpr; ++i) {
7568 if (pmatch[i].rm_so != -1)
7569 (*static_cast<DStringGDL*>(result))[i+s*nSubExpr] =
7570 (*stringExpr)[s].substr( pmatch[i].rm_so, pmatch[i].rm_eo - pmatch[i].rm_so);
7571 // (*stringExpr)[i+s*nSubExpr].substr( pmatch[i].rm_so, pmatch[i].rm_eo - pmatch[i].rm_so);
7572 if( lengthKW)
7573 (*len)[i+s*nSubExpr] = pmatch[i].rm_so != -1 ? pmatch[i].rm_eo - pmatch[i].rm_so : -1;
7574 // (*len)[i+s*nSubExpr] = pmatch[i].rm_eo - pmatch[i].rm_so;
7575 }
7576 }
7577 else if ( subexprKW)
7578 {
7579 // cout << "je ne comprends pas v2: "<< nSubExpr << endl;
7580
7581 // Loop through subexpressions & fill output array
7582 for( SizeT i = 0; i<nSubExpr; ++i) {
7583 (* static_cast<DLongGDL*>(result))[i+s*nSubExpr] = pmatch[i].rm_so;
7584 if( lengthKW)
7585 (*len)[i+s*nSubExpr] = pmatch[i].rm_so != -1 ? pmatch[i].rm_eo - pmatch[i].rm_so : -1;
7586 }
7587 }
7588 else
7589 {
7590 if( booleanKW)
7591 (* static_cast<DByteGDL*>(result))[s] = (matchres == 0);
7592 else if ( extractKW) // !subExprKW
7593 {
7594 if( matchres == 0)
7595 (* static_cast<DStringGDL*>(result))[s] =
7596 (*stringExpr)[s].substr( pmatch[0].rm_so,
7597 pmatch[0].rm_eo - pmatch[0].rm_so);
7598 }
7599 else
7600 (*static_cast<DLongGDL*>(result))[s] = matchres ? -1 : pmatch[0].rm_so;
7601 }
7602
7603 if( lengthKW && !subexprKW)
7604 //(*len)[s] = pmatch[0].rm_eo - pmatch[0].rm_so;
7605 (*len)[s] = pmatch[0].rm_so != -1 ? pmatch[0].rm_eo - pmatch[0].rm_so : -1;
7606
7607 }
7608
7609 regfree( ®exp);
7610
7611 if( lengthKW)
7612 e->SetKW( lengthIx, len);
7613
7614 return result;
7615 }
7616
routine_filepath(EnvT * e)7617 BaseGDL* routine_filepath( EnvT* e)
7618 {
7619 SizeT nParam=e->NParam();
7620 DStringGDL* p0S;
7621 Guard<DStringGDL> p0S_guard;
7622 if (nParam > 1) e->Throw("Incorrect number of arguments.");
7623 if( nParam > 0) {
7624 BaseGDL* p0 = e->GetParDefined( 0);
7625 if( p0->Type() != GDL_STRING)
7626 e->Throw("String expression required in this context: " + e->GetParString(0));
7627 p0S = static_cast<DStringGDL*>( p0);
7628 } else { // routine_filepath()
7629 p0S = new DStringGDL( dynamic_cast<DSubUD*>((e->Caller())->GetPro())->ObjectName() );
7630 p0S_guard.Init(p0S);
7631 }
7632
7633 static int is_functionIx = e->KeywordIx( "IS_FUNCTION" );
7634 bool is_functionKW = e->KeywordSet( is_functionIx );
7635 static int eitherIx = e->KeywordIx( "EITHER" );
7636 bool eitherKW = e->KeywordSet( eitherIx );
7637
7638 SizeT nPath = p0S->N_Elements();
7639 DStringGDL* res = new DStringGDL(p0S->Dim(), BaseGDL::NOZERO);
7640 Guard<DStringGDL> res_guard(res);
7641
7642 DString name;
7643 string FullFileName;
7644 for(int i = 0; i < nPath; i++) {
7645
7646 name = StrUpCase((*p0S)[i]);
7647
7648 bool found=false;
7649 FullFileName = "";
7650
7651 size_t pos(0);
7652 if( (pos=name.find("::")) != DString::npos ) {
7653 DString struct_tag = name.substr( 0, pos );
7654 DString method_name = name.substr( pos+2 );
7655 for( auto& s: structList ) {
7656 if( s && (s->Name() != struct_tag) ) continue;
7657 if( eitherKW || !is_functionKW ) {
7658 DPro* pp = s->FindInProList(method_name);
7659 if( pp ) {
7660 found = true;
7661 FullFileName = pp->GetFilename();
7662 break;
7663 }
7664 }
7665 if( !found && (is_functionKW || eitherKW) ) {
7666 DFun* fp = s->FindInFunList(method_name);
7667 if( fp ) {
7668 found = true;
7669 FullFileName = fp->GetFilename();
7670 break;
7671 }
7672 }
7673 }
7674 } else {
7675 if( eitherKW || !is_functionKW) {
7676 for(ProListT::iterator i=proList.begin();
7677 i != proList.end(); ++i)
7678 if ((*i)->ObjectName() == name) {
7679 found=true;
7680 FullFileName=(*i)->GetFilename();
7681 break;
7682 }
7683 }
7684 if (!found && (is_functionKW || eitherKW)) {
7685 for(FunListT::iterator i=funList.begin();
7686 i != funList.end(); ++i)
7687 if ((*i)->ObjectName() == name) {
7688 found=true;
7689 FullFileName=(*i)->GetFilename();
7690 break;
7691 }
7692 }
7693 }
7694
7695 (*res)[i] = FullFileName;
7696 }
7697 // if(nParam == 0) return new DStringGDL(FullFileName);
7698 return res_guard.release();
7699 }
7700
7701 //AC 2019 (see "routine_name.pro". Here another way to catch the name ...)
routine_name_fun(EnvT * e)7702 BaseGDL* routine_name_fun( EnvT* e)
7703 {
7704 EnvStackT& callStack = e->Interpreter()->CallStack();
7705 string name=callStack.back()->GetProName();
7706 return new DStringGDL(name);
7707 }
7708
routine_info(EnvT * e)7709 BaseGDL* routine_info( EnvT* e)
7710 {
7711 SizeT nParam=e->NParam();
7712 if (nParam > 1) e->Throw("Incorrect number of arguments.");
7713
7714 static int functionsIx = e->KeywordIx( "FUNCTIONS" );
7715 bool functionsKW = e->KeywordSet( functionsIx );
7716 static int systemIx = e->KeywordIx( "SYSTEM" );
7717 bool systemKW = e->KeywordSet( systemIx );
7718 static int disabledIx = e->KeywordIx( "DISABLED" );
7719 bool disabledKW = e->KeywordSet( disabledIx );
7720 static int parametersIx = e->KeywordIx( "PARAMETERS" );
7721 bool parametersKW = e->KeywordSet( parametersIx );
7722 static int sourceIx = e->KeywordIx( "SOURCE" );
7723 bool sourceKW = e->KeywordSet(sourceIx );
7724
7725 if ( sourceKW ) {
7726
7727 // sanity checks
7728 if ( systemKW ) e->Throw( "Conflicting keywords." );
7729
7730 DString raw_name, name;
7731 string FullFileName;
7732 bool found = FALSE;
7733 DStructGDL* stru;
7734 DStructDesc* stru_desc;
7735
7736
7737 if ( nParam == 1 ) {
7738 // getting the routine name from the first parameter (must be a singleton)
7739 e->AssureScalarPar<DStringGDL>(0, raw_name);
7740 name = StrUpCase( raw_name );
7741 if ( functionsKW ) {
7742 for ( FunListT::iterator i = funList.begin( ); i != funList.end( ); ++i ) {
7743 if ( (*i)->ObjectName( ) == name ) {
7744 found = true;
7745 FullFileName = (*i)->GetFilename( );
7746 break;
7747 }
7748 }
7749 if ( !found ) e->Throw( "% Attempt to call undefined/not compiled function: '" + raw_name + "'" );
7750 } else {
7751 for ( ProListT::iterator i = proList.begin( ); i != proList.end( ); ++i ) {
7752 if ( (*i)->ObjectName( ) == name ) {
7753 found = true;
7754 FullFileName = (*i)->GetFilename( );
7755 break;
7756 }
7757 }
7758 if ( !found ) e->Throw( "% Attempt to call undefined/not compiled procedure: '" + raw_name + "'" );
7759 }
7760
7761 // creating the output anonymous structure
7762 stru_desc = new DStructDesc( "$truct" );
7763 SpDString aString;
7764 stru_desc->AddTag( "NAME", &aString );
7765 stru_desc->AddTag( "PATH", &aString );
7766 stru = new DStructGDL( stru_desc, dimension( ) );
7767
7768 // filling the structure with information about the routine
7769 stru->InitTag( "NAME", DStringGDL( name ) );
7770 stru->InitTag( "PATH", DStringGDL( FullFileName ) );
7771 return stru;
7772
7773 } else {
7774 // creating the output anonymous structure
7775 stru_desc = new DStructDesc( "$truct" );
7776 SpDString aString;
7777 stru_desc->AddTag( "NAME", &aString );
7778 stru_desc->AddTag( "PATH", &aString );
7779
7780 //always starts with $MAIN$
7781 SizeT N=(functionsKW)?funList.size()+1:proList.size()+1;
7782 stru = new DStructGDL( stru_desc, dimension(N) );
7783 (*static_cast<DStringGDL*>(stru->GetTag((SizeT)0, 0)))[0]="$MAIN$";
7784
7785 if ( functionsKW ) {
7786 SizeT ii=1;
7787 for ( FunListT::iterator i = funList.begin( ); i != funList.end( ); ++i ) {
7788 (*static_cast<DStringGDL*>(stru->GetTag((SizeT)0, ii)))[0]=(*i)->ObjectName( );
7789 (*static_cast<DStringGDL*>(stru->GetTag((SizeT)1, ii)))[0]=(*i)->GetFilename( );
7790 ii++;
7791 }
7792 } else {
7793 SizeT ii=1;
7794 for ( ProListT::iterator i = proList.begin( ); i != proList.end( ); ++i ) {
7795 (*static_cast<DStringGDL*>(stru->GetTag((SizeT)0, ii)))[0]=(*i)->ObjectName( );
7796 (*static_cast<DStringGDL*>(stru->GetTag((SizeT)1, ii)))[0]=(*i)->GetFilename( );
7797 ii++;
7798 }
7799 }
7800 return stru;
7801 }
7802 }
7803
7804 if (parametersKW)
7805 {
7806 // sanity checks
7807 if (systemKW || disabledKW) e->Throw("Conflicting keywords.");
7808
7809 // getting the routine name from the first parameter
7810 DString name;
7811 e->AssureScalarPar<DStringGDL>(0, name);
7812 name = StrUpCase(name);
7813
7814 DSubUD* routine = functionsKW
7815 ? static_cast<DSubUD*>(funList[GDLInterpreter::GetFunIx(name)])
7816 : static_cast<DSubUD*>(proList[GDLInterpreter::GetProIx(name)]);
7817 SizeT np = routine->NPar(), nk = routine->NKey();
7818
7819 // creating the output anonymous structure
7820 DStructDesc* stru_desc = new DStructDesc("$truct");
7821 SpDLong aLong;
7822 stru_desc->AddTag("NUM_ARGS", &aLong);
7823 stru_desc->AddTag("NUM_KW_ARGS", &aLong);
7824 if (np > 0)
7825 {
7826 SpDString aStringArr(dimension((int)np));
7827 stru_desc->AddTag("ARGS", &aStringArr);
7828 }
7829 if (nk > 0)
7830 {
7831 SpDString aStringArr(dimension((int)nk));
7832 stru_desc->AddTag("KW_ARGS", &aStringArr);
7833 }
7834 DStructGDL* stru = new DStructGDL(stru_desc, dimension());
7835
7836 // filling the structure with information about the routine
7837 stru->InitTag("NUM_ARGS", DLongGDL(np));
7838 stru->InitTag("NUM_KW_ARGS", DLongGDL(nk));
7839 if (np > 0)
7840 {
7841 DStringGDL *pnames = new DStringGDL(dimension(np));
7842 for (SizeT p = 0; p < np; ++p) (*pnames)[p] = routine->GetVarName(nk + p);
7843 stru->InitTag("ARGS", *pnames);
7844 GDLDelete(pnames);
7845 }
7846 if (nk > 0)
7847 {
7848 DStringGDL *knames = new DStringGDL(dimension(nk));
7849 for (SizeT k = 0; k < nk; ++k) (*knames)[k] = routine->GetKWName(k);
7850 stru->InitTag("KW_ARGS", *knames);
7851 GDLDelete(knames);
7852 }
7853
7854 // returning
7855 return stru;
7856 }
7857
7858 // GDL does not have disabled routines
7859 if( disabledKW) return new DStringGDL("");
7860
7861 // if( functionsKW || systemKW || nParam == 0)
7862 // {
7863 vector<DString> subList;
7864
7865 if( functionsKW)
7866 {
7867 if( systemKW)
7868 {
7869 SizeT n = libFunList.size();
7870 if( n == 0) return new DStringGDL("");
7871
7872 DStringGDL* res = new DStringGDL( dimension( n), BaseGDL::NOZERO);
7873 for( SizeT i = 0; i<n; ++i)
7874 (*res)[i] = libFunList[ i]->ObjectName();
7875
7876 return res;
7877 }
7878 else
7879 {
7880 SizeT n = funList.size();
7881 if( n == 0) {
7882 Message("No FUNCTIONS compiled yet !");
7883 return new DStringGDL("");
7884 }
7885 for( SizeT i = 0; i<n; ++i)
7886 subList.push_back( funList[ i]->ObjectName());
7887 }
7888 }
7889 else
7890 {
7891 if( systemKW)
7892 {
7893 SizeT n = libProList.size();
7894 if( n == 0) return new DStringGDL("");
7895
7896 DStringGDL* res = new DStringGDL( dimension( n), BaseGDL::NOZERO);
7897 for( SizeT i = 0; i<n; ++i)
7898 (*res)[i] = libProList[ i]->ObjectName();
7899
7900 return res;
7901 }
7902 else
7903 {
7904 SizeT n = proList.size();
7905 if( n == 0) {
7906 Message("No PROCEDURES compiled yet !");
7907 DStringGDL* res = new DStringGDL(1, BaseGDL::NOZERO);
7908 (*res)[0]="$MAIN$";
7909 return res;
7910 }
7911 subList.push_back("$MAIN$");
7912 for( SizeT i = 0; i<n; ++i)
7913 subList.push_back( proList[ i]->ObjectName());
7914 }
7915 }
7916
7917 sort( subList.begin(), subList.end());
7918 SizeT nS = subList.size();
7919
7920 DStringGDL* res = new DStringGDL( dimension( nS), BaseGDL::NOZERO);
7921 for( SizeT s=0; s<nS; ++s)
7922 (*res)[ s] = subList[ s];
7923
7924 return res;
7925 // }
7926 }
7927
temporary_fun(EnvT * e)7928 BaseGDL* temporary_fun( EnvT* e)
7929 {
7930 SizeT nParam=e->NParam(1);
7931
7932 BaseGDL** p0 = &e->GetParDefined( 0);
7933
7934 BaseGDL* ret = *p0;
7935
7936 *p0 = NULL; // make parameter undefined
7937 return ret;
7938 }
7939
memory_fun(EnvT * e)7940 BaseGDL* memory_fun( EnvT* e)
7941 {
7942 SizeT nParam=e->NParam( 0);
7943
7944 BaseGDL* ret;
7945 static int kw_l64_Ix = e->KeywordIx("L64");
7946 bool kw_l64 = e->KeywordSet(kw_l64_Ix);
7947 // TODO: IDL-doc mentions about automatically switching to L64 if needed
7948
7949 static int structureIx=e->KeywordIx("STRUCTURE");
7950 if (e->KeywordSet(structureIx))
7951 {
7952 // returning structure
7953 if (kw_l64)
7954 {
7955 ret = new DStructGDL("IDL_MEMORY64");
7956 DStructGDL* retStru = static_cast<DStructGDL*>(ret);
7957 (retStru->GetTag(retStru->Desc()->TagIndex("CURRENT")))->InitFrom( DLong64GDL(MemStats::GetCurrent()));
7958 (retStru->GetTag(retStru->Desc()->TagIndex("NUM_ALLOC")))->InitFrom( DLong64GDL(MemStats::GetNumAlloc()));
7959 (retStru->GetTag(retStru->Desc()->TagIndex("NUM_FREE")))->InitFrom( DLong64GDL(MemStats::GetNumFree()));
7960 (retStru->GetTag(retStru->Desc()->TagIndex("HIGHWATER")))->InitFrom( DLong64GDL(MemStats::GetHighWater()));
7961 }
7962 else
7963 {
7964 ret = new DStructGDL("IDL_MEMORY");
7965 DStructGDL* retStru = static_cast<DStructGDL*>(ret);
7966 (retStru->GetTag(retStru->Desc()->TagIndex("CURRENT")))->InitFrom( DLongGDL(MemStats::GetCurrent()));
7967 (retStru->GetTag(retStru->Desc()->TagIndex("NUM_ALLOC")))->InitFrom( DLongGDL(MemStats::GetNumAlloc()));
7968 (retStru->GetTag(retStru->Desc()->TagIndex("NUM_FREE")))->InitFrom( DLongGDL(MemStats::GetNumFree()));
7969 (retStru->GetTag(retStru->Desc()->TagIndex("HIGHWATER")))->InitFrom( DLongGDL(MemStats::GetHighWater()));
7970 }
7971 }
7972 else
7973 {
7974 static int Ix_kw_current = e->KeywordIx("CURRENT");
7975 static int Ix_kw_num_alloc = e->KeywordIx("NUM_ALLOC");
7976 static int Ix_kw_num_free = e->KeywordIx("NUM_FREE");
7977 static int Ix_kw_highwater = e->KeywordIx("HIGHWATER");
7978
7979 bool kw_current = e->KeywordSet( Ix_kw_current );
7980 bool kw_num_alloc = e->KeywordSet( Ix_kw_num_alloc);
7981 bool kw_num_free = e->KeywordSet( Ix_kw_num_free );
7982 bool kw_highwater = e->KeywordSet( Ix_kw_highwater);
7983
7984 // Following the IDL documentation: mutually exclusive keywords
7985 // IDL behaves different, incl. segfaults with selected kw combinations
7986 if (kw_current + kw_num_alloc + kw_num_free + kw_highwater > 1)
7987 e->Throw("CURRENT, NUM_ALLOC, NUM_FREE & HIGHWATER keywords"
7988 " are mutually exclusive");
7989
7990 if (kw_current)
7991 {
7992 if (kw_l64) ret = new DLong64GDL(MemStats::GetCurrent());
7993 else ret = new DLongGDL(MemStats::GetCurrent());
7994 }
7995 else if (kw_num_alloc)
7996 {
7997 if (kw_l64) ret = new DLong64GDL(MemStats::GetNumAlloc());
7998 else ret = new DLongGDL(MemStats::GetNumAlloc());
7999 }
8000 else if (kw_num_free)
8001 {
8002 if (kw_l64) ret = new DLong64GDL(MemStats::GetNumFree());
8003 else ret = new DLongGDL(MemStats::GetNumFree());
8004 }
8005 else if (kw_highwater)
8006 {
8007 if (kw_l64) ret = new DLong64GDL(MemStats::GetHighWater());
8008 else ret = new DLongGDL(MemStats::GetHighWater());
8009 }
8010 else
8011 {
8012 // returning 4-element array
8013 if (kw_l64)
8014 {
8015 ret = new DLong64GDL(dimension(4));
8016 (*static_cast<DLong64GDL*>(ret))[0] = MemStats::GetCurrent();
8017 (*static_cast<DLong64GDL*>(ret))[1] = MemStats::GetNumAlloc();
8018 (*static_cast<DLong64GDL*>(ret))[2] = MemStats::GetNumFree();
8019 (*static_cast<DLong64GDL*>(ret))[3] = MemStats::GetHighWater();
8020 }
8021 else
8022 {
8023 ret = new DLongGDL(dimension(4));
8024 (*static_cast<DLongGDL*>(ret))[0] = MemStats::GetCurrent();
8025 (*static_cast<DLongGDL*>(ret))[1] = MemStats::GetNumAlloc();
8026 (*static_cast<DLongGDL*>(ret))[2] = MemStats::GetNumFree();
8027 (*static_cast<DLongGDL*>(ret))[3] = MemStats::GetHighWater();
8028 }
8029 }
8030 }
8031
8032 return ret;
8033 }
8034
StrCmp(const string & s1,const string & s2,DLong n)8035 inline DByte StrCmp( const string& s1, const string& s2, DLong n)
8036 {
8037 if( n <= 0) return 1;
8038 if( s1.substr(0,n) == s2.substr(0,n)) return 1;
8039 return 0;
8040 }
StrCmp(const string & s1,const string & s2)8041 inline DByte StrCmp( const string& s1, const string& s2)
8042 {
8043 if( s1 == s2) return 1;
8044 return 0;
8045 }
StrCmpFold(const string & s1,const string & s2,DLong n)8046 inline DByte StrCmpFold( const string& s1, const string& s2, DLong n)
8047 {
8048 if( n <= 0) return 1;
8049 if( StrUpCase( s1.substr(0,n)) == StrUpCase(s2.substr(0,n))) return 1;
8050 return 0;
8051 }
StrCmpFold(const string & s1,const string & s2)8052 inline DByte StrCmpFold( const string& s1, const string& s2)
8053 {
8054 if( StrUpCase( s1) == StrUpCase(s2)) return 1;
8055 return 0;
8056 }
8057
strcmp_fun(EnvT * e)8058 BaseGDL* strcmp_fun( EnvT* e)
8059 {
8060 SizeT nParam=e->NParam(2);
8061
8062 DStringGDL* s0 = static_cast<DStringGDL*>( e->GetParAs< DStringGDL>( 0));
8063 DStringGDL* s1 = static_cast<DStringGDL*>( e->GetParAs< DStringGDL>( 1));
8064
8065 DLongGDL* l2 = NULL;
8066 if( nParam > 2)
8067 {
8068 l2 = static_cast<DLongGDL*>( e->GetParAs< DLongGDL>( 2));
8069 }
8070
8071 static int foldIx = e->KeywordIx( "FOLD_CASE");
8072 bool fold = e->KeywordSet( foldIx );
8073
8074 if( s0->Scalar() && s1->Scalar())
8075 {
8076 if( l2 == NULL)
8077 {
8078 if( fold)
8079 return new DByteGDL( StrCmpFold( (*s0)[0], (*s1)[0]));
8080 else
8081 return new DByteGDL( StrCmp( (*s0)[0], (*s1)[0]));
8082 }
8083 else
8084 {
8085 DByteGDL* res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);
8086 SizeT nEl = l2->N_Elements();
8087 if( fold)
8088 for( SizeT i=0; i<nEl; ++i)
8089 (*res)[i] = StrCmpFold( (*s0)[0], (*s1)[0], (*l2)[i]);
8090 else
8091 for( SizeT i=0; i<nEl; ++i)
8092 (*res)[i] = StrCmp( (*s0)[0], (*s1)[0], (*l2)[i]);
8093 return res;
8094 }
8095 }
8096 else // at least one array
8097 {
8098 if( l2 == NULL)
8099 {
8100 if( s0->Scalar())
8101 {
8102 DByteGDL* res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);
8103 SizeT nEl = s1->N_Elements();
8104 if( fold)
8105 for( SizeT i=0; i<nEl; ++i)
8106 (*res)[i] = StrCmpFold( (*s0)[0], (*s1)[i]);
8107 else
8108 for( SizeT i=0; i<nEl; ++i)
8109 (*res)[i] = StrCmp( (*s0)[0], (*s1)[i]);
8110 return res;
8111 }
8112 else if( s1->Scalar())
8113 {
8114 DByteGDL* res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);
8115 SizeT nEl = s0->N_Elements();
8116 if( fold)
8117 for( SizeT i=0; i<nEl; ++i)
8118 (*res)[i] = StrCmpFold( (*s0)[i], (*s1)[0]);
8119 else
8120 for( SizeT i=0; i<nEl; ++i)
8121 (*res)[i] = StrCmp( (*s0)[i], (*s1)[0]);
8122 return res;
8123 }
8124 else // both arrays
8125 {
8126 DByteGDL* res;
8127 SizeT nEl;
8128 if( s0->N_Elements() <= s1->N_Elements())
8129 {
8130 res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);
8131 nEl = s0->N_Elements();
8132 }
8133 else
8134 {
8135 res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);
8136 nEl = s1->N_Elements();
8137 }
8138 if( fold)
8139 for( SizeT i=0; i<nEl; ++i)
8140 (*res)[i] = StrCmpFold( (*s0)[i], (*s1)[i]);
8141 else
8142 for( SizeT i=0; i<nEl; ++i)
8143 (*res)[i] = StrCmp( (*s0)[i], (*s1)[i]);
8144 return res;
8145 }
8146 }
8147 else // l2 != NULL
8148 {
8149 DByteGDL* res;
8150 SizeT nEl;
8151 bool l2Scalar = l2->Scalar();
8152 if( s0->Scalar())
8153 {
8154 if( l2Scalar || s1->N_Elements() <= l2->N_Elements())
8155 {
8156 res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);
8157 nEl = s1->N_Elements();
8158 }
8159 else
8160 {
8161 res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);
8162 nEl = l2->N_Elements();
8163 }
8164 if( fold)
8165 for( SizeT i=0; i<nEl; ++i)
8166 (*res)[i] = StrCmpFold( (*s0)[0], (*s1)[i], (*l2)[l2Scalar?0:i]);
8167 else
8168 for( SizeT i=0; i<nEl; ++i)
8169 (*res)[i] = StrCmp( (*s0)[0], (*s1)[i], (*l2)[l2Scalar?0:i]);
8170 return res;
8171 }
8172 else if( s1->Scalar())
8173 {
8174 if( l2Scalar || s0->N_Elements() <= l2->N_Elements())
8175 {
8176 res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);
8177 nEl = s0->N_Elements();
8178 }
8179 else
8180 {
8181 res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);
8182 nEl = l2->N_Elements();
8183 }
8184 if( fold)
8185 for( SizeT i=0; i<nEl; ++i)
8186 (*res)[i] = StrCmpFold( (*s0)[i], (*s1)[0], (*l2)[l2Scalar?0:i]);
8187 else
8188 for( SizeT i=0; i<nEl; ++i)
8189 (*res)[i] = StrCmp( (*s0)[i], (*s1)[0], (*l2)[l2Scalar?0:i]);
8190 return res;
8191 }
8192 else // s1 and s2 are arrays
8193 {
8194 if( l2Scalar)
8195 if( s0->N_Elements() <= s1->N_Elements())
8196 {
8197 res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);
8198 nEl = s0->N_Elements();
8199 }
8200 else
8201 {
8202 res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);
8203 nEl = s1->N_Elements();
8204 }
8205 else
8206 {
8207 if( s0->N_Elements() <= s1->N_Elements())
8208 if( s0->N_Elements() <= l2->N_Elements())
8209 {
8210 res = new DByteGDL( s0->Dim(), BaseGDL::NOZERO);
8211 nEl = s0->N_Elements();
8212 }
8213 else
8214 {
8215 res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);
8216 nEl = l2->N_Elements();
8217 }
8218 else
8219 if( s1->N_Elements() <= l2->N_Elements())
8220 {
8221 res = new DByteGDL( s1->Dim(), BaseGDL::NOZERO);
8222 nEl = s1->N_Elements();
8223 }
8224 else
8225 {
8226 res = new DByteGDL( l2->Dim(), BaseGDL::NOZERO);
8227 nEl = l2->N_Elements();
8228 }
8229 }
8230 if( fold)
8231 for( SizeT i=0; i<nEl; ++i)
8232 (*res)[i] = StrCmpFold( (*s0)[i], (*s1)[i], (*l2)[l2Scalar?0:i]);
8233 else
8234 for( SizeT i=0; i<nEl; ++i)
8235 (*res)[i] = StrCmp( (*s0)[i], (*s1)[i], (*l2)[l2Scalar?0:i]);
8236 return res;
8237 }
8238 }
8239 }
8240 assert( false);
8241 }
8242
TagName(EnvT * e,const string & name)8243 string TagName( EnvT* e, const string& name)
8244 {
8245 string n = StrUpCase( name);
8246 SizeT len = n.size();
8247 if( n[0] != '_' && n[0] != '!' && (n[0] < 'A' || n[0] > 'Z'))
8248 e->Throw( "Illegal tag name: "+name+".");
8249 for( SizeT i=1; i<len; ++i)
8250 {
8251 if( n[i] == ' ')
8252 n[i] = '_';
8253 else
8254 if( n[i] != '_' && n[i] != '$' && //n[0] != '!' &&
8255 (n[i] < 'A' || n[i] > 'Z') &&
8256 (n[i] < '0' || n[i] > '9'))
8257 e->Throw( "Illegal tag name: "+name+".");
8258 }
8259 return n;
8260 }
8261
create_struct(EnvT * e)8262 BaseGDL* create_struct( EnvT* e)
8263 {
8264 static int nameIx = e->KeywordIx( "NAME" );
8265 DString name = "$truct";
8266 if( e->KeywordPresent( nameIx)) {
8267 // Check if name exists, if not then treat as unnamed
8268 if (e->GetKW( nameIx) != NULL)
8269 e->AssureStringScalarKW( nameIx, name);
8270 }
8271
8272 if( name != "$truct") // named struct
8273 {
8274 name = StrUpCase( name);
8275
8276 SizeT nParam=e->NParam();
8277
8278 if( nParam == 0)
8279 {
8280 DStructDesc* desc =
8281 e->Interpreter()->GetStruct( name, e->CallingNode());
8282
8283 dimension dim( 1);
8284 return new DStructGDL( desc, dim);
8285 }
8286
8287 DStructDesc* nStructDesc;
8288 Guard<DStructDesc> nStructDescGuard;
8289
8290 DStructDesc* oStructDesc=
8291 FindInStructList( structList, name);
8292
8293 if( oStructDesc == NULL || oStructDesc->NTags() > 0)
8294 {
8295 // not defined at all yet (-> define now)
8296 // or completely defined (-> define now and check equality)
8297 nStructDesc= new DStructDesc( name);
8298
8299 // guard it
8300 nStructDescGuard.Reset( nStructDesc);
8301 }
8302 else
8303 {
8304 // NTags() == 0
8305 // not completely defined (only name in list)
8306 nStructDesc= oStructDesc;
8307 }
8308
8309 // the instance variable
8310 // dimension dim( 1);
8311 // DStructGDL* instance = new DStructGDL( nStructDesc, dim);
8312 DStructGDL* instance = new DStructGDL( nStructDesc);
8313 Guard<DStructGDL> instance_guard(instance);
8314
8315 for( SizeT p=0; p<nParam; ++p)
8316 {
8317 BaseGDL* par = e->GetParDefined( p);
8318 if( par->Type() == GDL_STRUCT)
8319 {
8320 DStructGDL* parStruct = static_cast<DStructGDL*>( par);
8321 // add struct
8322 if( !parStruct->Scalar())
8323 e->Throw("Expression must be a scalar in this context: "+
8324 e->GetParString( p));
8325
8326 DStructDesc* desc = parStruct->Desc();
8327 for( SizeT t=0; t< desc->NTags(); ++t)
8328 {
8329 instance->NewTag( desc->TagName( t),
8330 parStruct->GetTag( t)->Dup());
8331 }
8332 }
8333 else
8334 {
8335 // add tag value pair
8336 DStringGDL* tagNames = e->GetParAs<DStringGDL>( p);
8337 SizeT nTags = tagNames->N_Elements();
8338
8339 SizeT tagStart = p+1;
8340 SizeT tagEnd = p+nTags;
8341 if( tagEnd >= nParam)
8342 e->Throw( "Incorrect number of arguments.");
8343
8344 do{
8345 ++p;
8346 BaseGDL* value = e->GetParDefined( p);
8347
8348 // add
8349 instance->NewTag( TagName( e, (*tagNames)[ p-tagStart]),
8350 value->Dup());
8351 }
8352 while( p<tagEnd);
8353 }
8354 }
8355
8356 if( oStructDesc != NULL)
8357 {
8358 if( oStructDesc != nStructDesc)
8359 {
8360 oStructDesc->AssureIdentical(nStructDesc);
8361 instance->DStructGDL::SetDesc(oStructDesc);
8362 //delete nStructDesc; // auto_ptr
8363 }
8364 }
8365 else
8366 {
8367 // release from guard (if not NULL)
8368 nStructDescGuard.release();
8369 // insert into struct list
8370 structList.push_back(nStructDesc);
8371 }
8372
8373 instance_guard.release();
8374 return instance;
8375 }
8376 else
8377 { // unnamed struc
8378
8379 // Handle case of single structure parameter
8380 SizeT nParam;
8381 nParam = e->NParam(1);
8382 BaseGDL* par = e->GetParDefined( 0);
8383 // DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);
8384 if (nParam != 1 || par->Type() != GDL_STRUCT)// == NULL)
8385 nParam=e->NParam(2);
8386
8387 DStructDesc* nStructDesc = new DStructDesc( "$truct");
8388 // instance takes care of nStructDesc since it is unnamed
8389 // dimension dim( 1);
8390 // DStructGDL* instance = new DStructGDL( nStructDesc, dim);
8391 DStructGDL* instance = new DStructGDL( nStructDesc);
8392 Guard<DStructGDL> instance_guard(instance);
8393
8394 for( SizeT p=0; p<nParam;)
8395 {
8396 BaseGDL* par = e->GetParDefined( p);
8397 // DStructGDL* parStruct = dynamic_cast<DStructGDL*>( par);
8398 // if( parStruct != NULL)
8399 if( par->Type() == GDL_STRUCT)
8400 {
8401 // add struct
8402 DStructGDL* parStruct = static_cast<DStructGDL*>( par);
8403 if( !parStruct->Scalar())
8404 e->Throw("Expression must be a scalar in this context: "+
8405 e->GetParString( p));
8406
8407 DStructDesc* desc = parStruct->Desc();
8408 for( SizeT t=0; t< desc->NTags(); ++t)
8409 {
8410 instance->NewTag( desc->TagName( t),
8411 parStruct->GetTag( t)->Dup());
8412 }
8413 ++p;
8414 }
8415 else
8416 {
8417 // add tag value pair
8418 DStringGDL* tagNames = e->GetParAs<DStringGDL>( p);
8419 SizeT nTags = tagNames->N_Elements();
8420
8421 SizeT tagStart = p+1;
8422 SizeT tagEnd = p+nTags;
8423 if( tagEnd >= nParam)
8424 e->Throw( "Incorrect number of arguments.");
8425
8426 for(++p; p<=tagEnd; ++p)
8427 {
8428 BaseGDL* value = e->GetParDefined( p);
8429
8430 // add
8431 instance->NewTag( TagName( e, (*tagNames)[ p-tagStart]),
8432 value->Dup());
8433 }
8434 }
8435 }
8436
8437 instance_guard.release();
8438 return instance;
8439 }
8440 }
8441
rotate(EnvT * e)8442 BaseGDL* rotate(EnvT* e) {
8443 e->NParam(2);
8444 BaseGDL* p0 = e->GetParDefined(0);
8445
8446 if (p0->Rank() == 0)
8447 e->Throw("Expression must be an array in this context: " + e->GetParString(0));
8448
8449 if (p0->Rank() != 1 && p0->Rank() != 2)
8450 e->Throw("Only 1 or 2 dimensions allowed: " + e->GetParString(0));
8451
8452 if (p0->Type() == GDL_STRUCT)
8453 e->Throw("STRUCT expression not allowed in this context: " +
8454 e->GetParString(0));
8455
8456 DLong dir;
8457 e->AssureLongScalarPar(1, dir);
8458
8459 return p0->Rotate(dir);
8460 }
8461
8462 // SA: based on the code of rotate() (above)
8463
reverse(EnvT * e)8464 BaseGDL* reverse(EnvT* e) {
8465 e->NParam(1);
8466 BaseGDL* p0 = e->GetParDefined(0);
8467 if (p0->Rank() == 0) return p0->Dup();
8468
8469 DLong dim = 1;
8470 if (e->GetPar(1) != NULL)
8471 e->AssureLongScalarPar(1, dim);
8472 if (p0->Rank() != 0 && (dim > p0->Rank() || dim < 1))
8473 e->Throw("Subscript_index must be positive and less than or equal to number of dimensions.");
8474
8475 BaseGDL* ret;
8476 // IDL doc states that OVERWRITE is ignored for one- or two-dim. arrays
8477 // but it seems to behave differently
8478 // if (p0->Rank() > 2 && e->KeywordSet("OVERWRITE") && e->GlobalPar(0))
8479 static int overwriteIx = e->KeywordIx("OVERWRITE");
8480 if (e->KeywordSet(overwriteIx)) {
8481 p0->Reverse(dim - 1);
8482 bool stolen = e->StealLocalPar(0);
8483 // if( !stolen)
8484 // e->GetPar(0) = NULL;
8485 if (!stolen)
8486 e->SetPtrToReturnValue(&e->GetPar(0));
8487 return p0;
8488 } else
8489 ret = p0->DupReverse(dim - 1);
8490 return ret;
8491 }
8492
8493 // PARSE_URL based on the IDL parse_url function behaviour and documentation
8494
parse_url(EnvT * env)8495 BaseGDL* parse_url( EnvT* env)
8496 {
8497 // sanity check for number of parameters
8498 SizeT nParam = env->NParam();
8499
8500 // 1-nd argument : the url string
8501 DString url;
8502 env->AssureScalarPar<DStringGDL>(0, url);
8503
8504 // creating the output anonymous structure
8505 DStructDesc* urlstru_desc = new DStructDesc("$truct");
8506 SpDString aString;
8507 urlstru_desc->AddTag("SCHEME", &aString);
8508 urlstru_desc->AddTag("USERNAME", &aString);
8509 urlstru_desc->AddTag("PASSWORD", &aString);
8510 urlstru_desc->AddTag("HOST", &aString);
8511 urlstru_desc->AddTag("PORT", &aString);
8512 urlstru_desc->AddTag("PATH", &aString);
8513 urlstru_desc->AddTag("QUERY", &aString);
8514 DStructGDL* urlstru = new DStructGDL(urlstru_desc, dimension());
8515 Guard<DStructGDL> urlstru_guard(urlstru);
8516
8517 char const *str = url.c_str();
8518 size_t length = url.length();
8519 char const*pStart, *pMid, *pEnd;
8520
8521 // initialise PORT at 80
8522 urlstru->InitTag("PORT", DStringGDL("80"));
8523
8524 //searching for the scheme and exciting if not found
8525 pStart = str;
8526 if (!(pEnd = std::strstr(str, "://"))){
8527 urlstru_guard.release();
8528 return (urlstru);
8529 }
8530 urlstru->InitTag("SCHEME", DStringGDL(pStart < pEnd ? string(pStart, pEnd - pStart) : ""));
8531
8532 // setting pStart after "://"
8533 pEnd += 3;
8534 pStart = pEnd;
8535
8536 //searching for the username and password (':' & '@')
8537 if (std::strchr(pStart, '@')){
8538 pEnd = std::strchr(pStart, '@');
8539 if (!(pMid = std::strchr(pStart, ':')))
8540 pMid = pEnd;
8541 if (pMid && pMid < pEnd)
8542 urlstru->InitTag("PASSWORD", DStringGDL(pMid + 1 < pEnd ? string(pMid + 1, pEnd - (pMid + 1)) : ""));
8543 urlstru->InitTag("USERNAME", DStringGDL(pStart < pMid ? string(pStart, pMid - pStart) : ""));
8544 pStart = pEnd + 1;
8545 }
8546
8547 // setting pEnd at the first '/' found or at the end if not found
8548 if (std::strchr(pStart, '/')){
8549 pEnd = std::strchr(pStart, '/');
8550 } else {
8551 pEnd = pStart + std::strlen(pStart);
8552 }
8553
8554 // setting pMid at the first ':' found or at the end if not found
8555 // if found : InitTag "PORT" from pMid + 1 (after ':') to pEnd ('/' or END)
8556 if (std::strchr(pStart, ':')){
8557 pMid = std::strchr(pStart, ':');
8558 urlstru->InitTag("PORT", DStringGDL(pMid + 1 < pEnd ? string(pMid + 1, pEnd - (pMid + 1)) : ""));
8559 } else {
8560 pMid = pEnd;
8561 }
8562 // InitTag "PORT" from pStart(after "://" or '@') to pMid (':' or '/' or END)
8563 urlstru->InitTag("HOST", DStringGDL(pStart < pMid ? string(pStart, pMid - pStart) : ""));
8564 pStart = pEnd + 1;
8565 // Searching for a query ('?')
8566 // if found : InitTag "QUERY" from pEnd + 1 (after '?') to the end
8567 if ((pEnd = strchr(pMid, '?'))){
8568 urlstru->InitTag("QUERY", DStringGDL(std::strlen(pEnd + 1) > 0 ? string(pEnd + 1, std::strlen(pEnd + 1)) : ""));
8569 } else {
8570 pEnd = pMid + std::strlen(pMid);
8571 }
8572 // InitTag "PATH" from pStart (after '/') to the end
8573 urlstru->InitTag("PATH", DStringGDL(pStart < pEnd ? string(pStart, pEnd - pStart) : ""));
8574 urlstru_guard.release();
8575 return urlstru;
8576 }
8577
locale_get(EnvT * e)8578 BaseGDL* locale_get(EnvT* e)
8579 {
8580 #ifdef HAVE_LOCALE_H
8581
8582 // make GDL inherit the calling process locale
8583 setlocale(LC_ALL, "");
8584 // note doen the inherited locale
8585 DStringGDL *locale = new DStringGDL(setlocale(LC_CTYPE, NULL));
8586 // return to the C locale
8587 setlocale(LC_ALL, "C");
8588
8589 return locale;
8590 #else
8591 e->Throw("OS does not provide locale information");
8592 #endif
8593 }
8594
8595 // SA: relies on the contents of the lib::command_line_args vector
8596 // defined and filled with data (pointers) in gdl.cpp
command_line_args_fun(EnvT * e)8597 BaseGDL* command_line_args_fun(EnvT* e)
8598 {
8599 static int countIx = e->KeywordIx("COUNT");
8600 static int resetIx = e->KeywordIx("RESET");
8601 static int setIx = e->KeywordIx("SET");
8602 // resetting the command_line_args
8603 if( e->KeywordSet(resetIx) ) command_line_args.clear();
8604
8605 BaseGDL* setKW = e->GetKW(setIx);
8606 if( setKW != NULL)
8607 {
8608 if(setKW->Type() != GDL_STRING)
8609 e->Throw(" SET string values only allowed ");
8610 DString setp;
8611 for(SizeT i = 0; i < setKW->N_Elements(); i++)
8612 {
8613 setp = (*static_cast<DStringGDL*>(setKW))[i] ;
8614 command_line_args.push_back( setp);
8615 }
8616 // printf(" SET: %s \n", (*static_cast<DStringGDL*>(setKW))[i] )
8617 // command_line_args.push_back( ( (*static_cast<DStringGDL*>(setKW))[i] );
8618
8619 }
8620 // setting the COUNT keyword value
8621 if (e->KeywordPresent(countIx))
8622 {
8623 e->AssureGlobalKW(countIx);
8624 e->SetKW(countIx, new DLongGDL(command_line_args.size()));
8625 }
8626
8627 // returning empty string or an array of arguments
8628 if (command_line_args.empty()) return new DStringGDL("");
8629 else
8630 {
8631 BaseGDL* ret = new DStringGDL(dimension(command_line_args.size()));
8632 for (size_t i = 0; i < command_line_args.size(); i++)
8633 (*static_cast<DStringGDL*>(ret))[i] = command_line_args[i];
8634 return ret;
8635 }
8636 }
8637
8638 // SA: relies in the uname() from libc (must be there if POSIX)
get_login_info(EnvT * e)8639 BaseGDL* get_login_info( EnvT* e)
8640 {
8641 // getting the info
8642 #ifdef _WIN32
8643 #define MAX_WCHAR_BUF 256
8644
8645 char login[MAX_WCHAR_BUF];
8646 char info[MAX_WCHAR_BUF];
8647
8648 DWORD N_WCHAR = MAX_WCHAR_BUF;
8649
8650 WCHAR w_buf[MAX_WCHAR_BUF];
8651 GetUserNameW(w_buf, &N_WCHAR);
8652 WideCharToMultiByte(CP_ACP, 0, w_buf, N_WCHAR, login, N_WCHAR, NULL, NULL);
8653 GetComputerNameW(w_buf, &N_WCHAR);
8654 WideCharToMultiByte(CP_ACP, 0, w_buf, N_WCHAR, info, N_WCHAR, NULL, NULL);
8655 #else
8656 char* login = getlogin();
8657 if (login == NULL) e->Throw("Failed to get user name from the OS");
8658 struct utsname info;
8659 if (0 != uname(&info)) e->Throw("Failed to get machine name from the OS");
8660 #endif
8661 // creating the output anonymous structure
8662 DStructDesc* stru_desc = new DStructDesc("$truct");
8663 SpDString aString;
8664 stru_desc->AddTag("MACHINE_NAME", &aString);
8665 stru_desc->AddTag("USER_NAME", &aString);
8666 DStructGDL* stru = new DStructGDL(stru_desc, dimension());
8667
8668 // returning the info
8669 stru->InitTag("USER_NAME", DStringGDL(login));
8670 #ifdef _WIN32
8671 stru->InitTag("MACHINE_NAME", DStringGDL(info));
8672 #else
8673 stru->InitTag("MACHINE_NAME", DStringGDL(info.nodename));
8674 #endif
8675 return stru;
8676 }
8677
8678 // SA: base64 logic in base64.hpp, based on code by Bob Withers (consult base64.hpp)
idl_base64(EnvT * e)8679 BaseGDL* idl_base64(EnvT* e)
8680 {
8681 BaseGDL* p0 = e->GetPar(0);
8682 if (p0 != NULL)
8683 {
8684 if (p0->Rank() == 0 && p0->Type() == GDL_STRING)
8685 {
8686 // decoding
8687 string* str = &((*static_cast<DStringGDL*>(p0))[0]);
8688 if (str->length() == 0) return new DByteGDL(0);
8689 if (str->length() % 4 != 0)
8690 e->Throw("Input string length must be a multiple of 4");
8691 unsigned int retlen = base64::decodeSize(*str);
8692 if (retlen == 0 || retlen > str->length()) e->Throw("No data in the input string");
8693 DByteGDL* ret = new DByteGDL(dimension(retlen));
8694 if (!base64::decode(*str, (char*)&((*ret)[0]), ret->N_Elements()))
8695 {
8696 delete ret;
8697 e->Throw("Base64 decoder failed");
8698 return NULL;
8699 }
8700 return ret;
8701 }
8702 if (p0->Rank() >= 1 && p0->Type() == GDL_BYTE)
8703 {
8704 // encoding
8705 return new DStringGDL(
8706 base64::encode((char*)&(*static_cast<DByteGDL*>(p0))[0], p0->N_Elements())
8707 );
8708 }
8709 }
8710 e->Throw("Expecting string or byte array as a first parameter");
8711 return NULL; //pacify dumb compilers
8712 }
8713
get_drive_list(EnvT * e)8714 BaseGDL* get_drive_list(EnvT* e)
8715 {
8716 if (e->KeywordPresent(0)) e->SetKW(0, new DLongGDL(0));
8717 return new DStringGDL("");
8718 }
8719
scope_level(EnvT * e)8720 BaseGDL* scope_level( EnvT* e)
8721 {
8722 SizeT nParam=e->NParam();
8723 if ( nParam > 0 ) e->Throw("Incorrect number of arguments.");
8724 EnvStackT& callStack = e->Interpreter()->CallStack();
8725 return new DLongGDL(callStack.size());
8726 }
8727
8728 // based on void SimpleDumpStack(EnvT* e) used in "basic_pro.cpp"
8729
scope_traceback(EnvT * e)8730 BaseGDL* scope_traceback( EnvT* e)
8731 {
8732 static int structureIx = e->KeywordIx("STRUCTURE");
8733 bool structureKW = e->KeywordSet(structureIx);
8734
8735 static int systemIx = e->KeywordIx("SYSTEM");
8736 bool systemKW = e->KeywordSet(systemIx);
8737 if (systemKW) {
8738 Warning("keyword SYSTEM is not ready here, please contribute !");
8739 }
8740
8741 int debug=0;
8742
8743 EnvStackT& callStack = e->Interpreter()->CallStack();
8744 long actIx = callStack.size();
8745
8746 if (debug) cout << "actIx : " << actIx << endl;
8747
8748 string tmp, filename;
8749 int lineNumber;
8750
8751 if (!structureKW) {
8752
8753 DStringGDL* res;
8754 res = new DStringGDL(dimension(actIx) , BaseGDL::NOZERO);
8755
8756 for( SizeT i=0; i<actIx; ++i)
8757 {
8758 EnvStackT::pointer_type upEnv = callStack[i];
8759 tmp= upEnv->GetProName();
8760 filename=upEnv->GetFilename();
8761 if( filename != "")
8762 {
8763 lineNumber = upEnv->GetLineNumber();
8764 if( lineNumber != 0)
8765 {
8766 tmp=tmp+" <"+filename+"("+i2s(lineNumber)+")>";
8767 }
8768 }
8769 if (debug) cout << tmp << endl;
8770 (*res)[i]=tmp;
8771 }
8772
8773 return res;
8774 }
8775
8776 if (structureKW) {
8777 DStructGDL* res = new DStructGDL(
8778 FindInStructList(structList, "IDL_TRACEBACK"),
8779 dimension(actIx));
8780
8781 int tRoutine, tFilename, tLine, tLevel, tFunction;
8782 int tMethod=0, tRestored=0, tSystem=0;
8783
8784 for( SizeT i=0; i<actIx; ++i) {
8785
8786 EnvStackT::pointer_type upEnv = callStack[i];
8787 tmp= upEnv->GetProName();
8788 filename=upEnv->GetFilename();
8789 if (filename.length() == 0) filename=" ";
8790 lineNumber = upEnv->GetLineNumber();
8791
8792 tRoutine = res->Desc()->TagIndex("ROUTINE");
8793 tFilename= res->Desc()->TagIndex("FILENAME");
8794 tLine= res->Desc()->TagIndex("LINE");
8795 tLevel= res->Desc()->TagIndex("LEVEL");
8796 tFunction= res->Desc()->TagIndex("IS_FUNCTION");
8797 tMethod= res->Desc()->TagIndex("METHOD");
8798 tRestored= res->Desc()->TagIndex("RESTORED");
8799 tSystem= res->Desc()->TagIndex("SYSTEM");
8800
8801 *(res->GetTag(tRoutine, i)) = DStringGDL(tmp);
8802 *(res->GetTag(tFilename, i)) = DStringGDL(filename);
8803 *(res->GetTag(tLine, i)) = DLongGDL(lineNumber);
8804 *(res->GetTag(tLevel, i)) = DLongGDL(i);
8805
8806 // AC 2015/03/03 : HELP WELCOME
8807 // I don't know how to know if we use Pro or Func
8808 // we do have a long way in "dinterpreter.cpp" with
8809 // if( firstChar == "#")
8810 bool isFunc = false;
8811 for (FunListT::iterator ifunc = funList.begin(); ifunc != funList.end(); ++ifunc) {
8812 if (StrUpCase(tmp).find((*ifunc)->ObjectName()) != std::string::npos) {
8813 isFunc = true;
8814 break;
8815 }
8816 }
8817 *(res->GetTag(tFunction, i)) = (isFunc)?DByteGDL(1):DByteGDL(0);
8818 //all others 0 for the time being
8819 *(res->GetTag(tMethod, i)) = DByteGDL(0);
8820 *(res->GetTag(tRestored, i)) = DByteGDL(0);
8821 *(res->GetTag(tSystem, i)) = DByteGDL(0);
8822 }
8823 return res;
8824 }
8825 return NULL; //pacify, etc.
8826 }
8827
8828 // note: changes here MUST be reflected in scope_varfetch_reference() as well
8829 // because DLibFun of this function is used for scope_varfetch_reference() the keyword
8830 // indices must match
8831
scope_varfetch_value(EnvT * e)8832 BaseGDL* scope_varfetch_value(EnvT* e) {
8833 SizeT nParam = e->NParam();
8834
8835 EnvStackT& callStack = e->Interpreter()->CallStack();
8836 // DLong curlevnum = callStack.size()-1;
8837 // 'e' is not on the stack
8838 DLong curlevnum = callStack.size();
8839
8840 // static int variablesIx = e->KeywordIx( "VARIABLES" );
8841 static int levelIx = e->KeywordIx("LEVEL");
8842 static int enterIx = e->KeywordIx("ENTER");
8843 bool acceptNew = e->KeywordSet(enterIx);
8844
8845 DLongGDL* level = e->IfDefGetKWAs<DLongGDL>(levelIx);
8846
8847 DLong desiredlevnum = 0;
8848
8849 if (level != NULL)
8850 desiredlevnum = (*level)[0];
8851
8852 if (desiredlevnum <= 0) desiredlevnum += curlevnum;
8853 if (desiredlevnum < 1) desiredlevnum = 1;
8854 else if (desiredlevnum > curlevnum) desiredlevnum = curlevnum;
8855
8856 DSubUD* pro = static_cast<DSubUD*> (callStack[desiredlevnum - 1]->GetPro());
8857
8858 SizeT nVar = pro->Size(); // # var in GDL for desired level
8859 int nKey = pro->NKey();
8860
8861 DString varName;
8862
8863 e->AssureScalarPar<DStringGDL>(0, varName);
8864 varName = StrUpCase(varName);
8865
8866 int xI = pro->FindVar(varName);
8867 if (xI != -1)
8868 {
8869 // BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI);
8870 BaseGDL*& par = callStack[desiredlevnum - 1]->GetKW(xI);
8871
8872 if (par == NULL)
8873 e->Throw("Variable is undefined: " + varName);
8874
8875 return par->Dup();
8876 } else if (acceptNew)
8877 {
8878 SizeT u = pro->AddVar(varName);
8879 SizeT s = callStack[desiredlevnum - 1]->AddEnv();
8880 BaseGDL*& par = ((EnvT*) (callStack[desiredlevnum - 1]))->GetPar(s - nKey);
8881 return par->Dup();
8882 }
8883 e->Throw("Variable not found: " + varName);
8884 return new DLongGDL(0); // compiler shut-up
8885 }
8886
8887 // this routine is special, only called as an l-function (from FCALL_LIB::LEval())
8888 // it MUST use an EnvT set up for scope_varfetch_value
8889
scope_varfetch_reference(EnvT * e)8890 BaseGDL** scope_varfetch_reference(EnvT* e) {
8891 SizeT nParam = e->NParam();
8892
8893 EnvStackT& callStack = e->Interpreter()->CallStack();
8894 // DLong curlevnum = callStack.size()-1;
8895 // 'e' is not on the stack
8896 DLong curlevnum = callStack.size();
8897
8898 // static int variablesIx = e->KeywordIx( "VARIABLES" );
8899 static int levelIx = e->KeywordIx("LEVEL");
8900 static int enterIx = e->KeywordIx("ENTER");
8901 bool acceptNew = e->KeywordSet(enterIx);
8902
8903 DLongGDL* level = e->IfDefGetKWAs<DLongGDL>(levelIx);
8904
8905 DLong desiredlevnum = 0;
8906
8907 if (level != NULL)
8908 desiredlevnum = (*level)[0];
8909
8910 if (desiredlevnum <= 0) desiredlevnum += curlevnum;
8911 if (desiredlevnum < 1) desiredlevnum = 1;
8912 else if (desiredlevnum > curlevnum) desiredlevnum = curlevnum;
8913
8914 DSubUD* pro = static_cast<DSubUD*> (callStack[desiredlevnum - 1]->GetPro());
8915
8916 SizeT nVar = pro->Size(); // # var in GDL for desired level
8917 int nKey = pro->NKey();
8918
8919 DString varName;
8920
8921 e->AssureScalarPar<DStringGDL>(0, varName);
8922 varName = StrUpCase(varName);
8923 int xI = pro->FindVar(varName);
8924 if (xI != -1)
8925 {
8926 // BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI);
8927 BaseGDL*& par = callStack[desiredlevnum - 1]->GetKW(xI);
8928
8929 // if( par == NULL)
8930 // e->Throw( "Variable is undefined: " + varName);
8931
8932 return ∥
8933 } else if (acceptNew)
8934 {
8935 SizeT u = pro->AddVar(varName);
8936 SizeT s = callStack[desiredlevnum - 1]->AddEnv();
8937 BaseGDL*& par = ((EnvT*) (callStack[desiredlevnum - 1]))->GetPar(s - nKey);
8938 return ∥
8939 }
8940 e->Throw("LVariable not found: " + varName);
8941 return NULL; // compiler shut-up
8942 }
8943
scope_varname_fun(EnvT * e)8944 BaseGDL* scope_varname_fun(EnvT* e)
8945 {
8946
8947 SizeT nParam = e->NParam( );
8948
8949 EnvStackT& callStack = e->Interpreter( )->CallStack( );
8950
8951 DLong currentLvl = callStack.size( );
8952 DLong level = currentLvl; // default to current level
8953
8954 DStringGDL* retVal = nullptr;
8955 SizeT count( 0 );
8956
8957 static int commonIx = e->KeywordIx( "COMMON" );
8958 static int countIx = e->KeywordIx( "COUNT" );
8959 static int levelIx = e->KeywordIx( "LEVEL" );
8960
8961 if ( e->KeywordSet( commonIx ) )
8962 {
8963
8964 if ( e->KeywordSet( levelIx ) ) e->Throw( "Conflicting keywords." );
8965
8966 DString commonName = "";
8967 e->AssureStringScalarKW( commonIx, commonName );
8968 DSubUD* pro = static_cast<DSubUD*> ( e->Caller( )->GetPro( ) );
8969 DCommon* common = pro->Common( StrUpCase( commonName ) );
8970 if ( common == NULL ) e->Throw( "Common block does not exist: " + commonName );
8971 bool passed_list = true;
8972 SizeT nComm = common->NVar( );
8973 if ( nParam < 1 )
8974 {
8975 nParam = nComm;
8976 passed_list = false;
8977 }
8978 count=nParam;
8979 retVal = new DStringGDL( dimension( count ), BaseGDL::NOZERO );
8980 for ( SizeT i( 0 ); i < count; ++i )
8981 {
8982 DLong ipar = i;
8983 if ( passed_list ) e->AssureLongScalarPar( i, ipar );
8984 if ( ( ipar >= 0 ) && ( ipar < nComm ) )
8985 {
8986 ( *retVal )[i] = common->VarName( ipar );
8987 }
8988 else ( *retVal )[i] = "";
8989 }
8990 }
8991 else
8992 {
8993
8994 DLongGDL* kwLvl = e->IfDefGetKWAs<DLongGDL>( levelIx );
8995 if ( kwLvl )
8996 {
8997 DLong tmp = ( *kwLvl )[0];
8998 if ( tmp > 0 ) level = tmp;
8999 else level += tmp;
9000 level = std::max( std::min( level, currentLvl ), 1 );
9001 }
9002
9003
9004
9005 if ( nParam == 0 )
9006 { // Just list and return all defined parameters at the requested level.
9007 EnvT* requestedScope = (EnvT*) callStack[level - 1];
9008 DSubUD* scope_pro = static_cast<DSubUD*> ( requestedScope->GetPro( ) );
9009 SizeT scope_nVar = scope_pro->Size( );
9010 SizeT scope_nComm = scope_pro->CommonsSize( );
9011 count = scope_nVar + scope_nComm;
9012 if ( !count )
9013 {
9014 retVal = new DStringGDL( "" );
9015 }
9016 else
9017 { // N.B. Order doesn't matter since the result is lexically sorted.
9018 vector<string> names( count );
9019 for ( SizeT i( 0 ); i < scope_nVar; ++i )
9020 {
9021 names[ i ] = scope_pro->GetVarName( i );
9022 if ( names[ i ].empty( ) ) names[ i ] = "*";
9023 }
9024 if ( scope_nComm )
9025 {
9026 DStringGDL* list = static_cast<DStringGDL*> ( scope_pro->GetCommonVarNameList( ) );
9027 for ( SizeT i( 0 ); i < list->N_Elements( ); ++i )
9028 {
9029 names[ scope_nVar + i ] = ( *list )[i];
9030 }
9031 }
9032 std::sort( names.begin( ), names.end( ) );
9033 retVal = new DStringGDL( dimension( count ), BaseGDL::NOZERO );
9034 for ( SizeT i( 0 ); i < count; ++i )
9035 {
9036 ( *retVal )[i] = names[i];
9037 }
9038 }
9039 }
9040 else
9041 {
9042 EnvT* requestedScope = (EnvT*) callStack[level - 1];
9043 DSubUD* scope_pro = static_cast<DSubUD*> ( requestedScope->GetPro( ) );
9044 SizeT scope_nVar = scope_pro->Size( );
9045 SizeT scope_nComm = scope_pro->CommonsSize( );
9046 count = nParam;
9047 retVal = new DStringGDL( dimension( nParam ), BaseGDL::NOZERO );
9048 //retrieve each variable at current level, fetch name at desired level
9049 for ( SizeT i( 0 ); i < nParam; ++i )
9050 {
9051 ( *retVal )[i] = ""; // not found
9052 BaseGDL*& par = e->GetPar( i );
9053 std::string tmp_name;
9054 bool undefineOnExit = false;
9055 //DANGEROUS trick to get parameter name, not <undefined> : avoid to have par=0x0 = NULL
9056 if (par==NULL) {
9057 e->SetPar(i, NullGDL::GetSingleInstance()); //make it something not meaningful
9058 par = e->GetPar (i);
9059 undefineOnExit=true;
9060 }
9061 if ( scope_pro->GetCommonVarName( par, tmp_name ) )
9062 { // Variable found in common-block, so use that name first.
9063 ( *retVal )[i] = tmp_name;
9064
9065 if ( undefineOnExit ) {
9066 par=NULL; //PROBABLY WILL CREATE PROBLEM SOMEWHERE ELSE
9067 };
9068 continue;
9069 }
9070 // not defined in common, can only be local.
9071 if ( level == currentLvl )
9072 { // For current level we need to resolve using e, but return empty string if not a named variable (ex: expression)
9073 tmp_name = e->GetParString( i );
9074 if ( tmp_name.find( '>' ) == std::string::npos ) ( *retVal )[i] = tmp_name;
9075 if ( undefineOnExit ) {
9076 par=NULL; //PROBABLY WILL CREATE PROBLEM SOMEWHERE ELSE
9077 };
9078 } else {
9079 tmp_name = requestedScope->GetString (par);
9080 if ( tmp_name.find( '>' ) == std::string::npos ) ( *retVal )[i] = tmp_name;
9081 }
9082 }
9083 }
9084
9085 }
9086
9087 // set the COUNT keyword
9088 if ( e->KeywordPresent( countIx ) )
9089 {
9090 e->AssureGlobalKW( countIx );
9091 e->SetKW( countIx, new DLongGDL( count ) );
9092 }
9093
9094 return retVal;
9095
9096 }
9097
9098 } // namespace
9099
9100