1 /*************************************************************************** 2 basic_fun_jmg.cpp - basic GDL library function 3 ------------------- 4 begin : 2004 5 copyright : (C) 2004 by Joel Gales 6 email : jomoga@users.sourceforge.net 7 ***************************************************************************/ 8 9 /*************************************************************************** 10 * * 11 * This program is free software; you can redistribute it and/or modify * 12 * it under the terms of the GNU General Public License as published by * 13 * the Free Software Foundation; either version 2 of the License, or * 14 * (at your option) any later version. * 15 * * 16 ***************************************************************************/ 17 18 #include "includefirst.hpp" 19 20 #include <string> 21 #include <fstream> 22 #include <memory> 23 #include <sys/stat.h> 24 25 #include "datatypes.hpp" 26 #include "envt.hpp" 27 #include "basic_fun.hpp" 28 #include "io.hpp" 29 #include "dinterpreter.hpp" 30 #include "objects.hpp" 31 #include "basic_fun_jmg.hpp" 32 #include "nullgdl.hpp" 33 34 35 //#define GDL_DEBUG 36 #undef GDL_DEBUG 37 38 namespace lib { 39 40 using namespace std; 41 using namespace antlr; 42 SizeT HASH_count( DStructGDL* oStructGDL); 43 SizeT LIST_count( DStructGDL* oStructGDL); 44 isa_fun(EnvT * e)45 BaseGDL* isa_fun( EnvT* e) 46 { 47 if (e->NParam() == 0) e->Throw("Requires at least one argument !"); 48 49 DString type; 50 BaseGDL *p0; 51 BaseGDL *p1; 52 DStringGDL *p1Str; 53 DString p1S = ""; 54 int nb_kw=0; 55 56 bool secPar = false; 57 SizeT n_elem; 58 SizeT rank; 59 int debug=0; 60 61 string structName; 62 string objectName; 63 64 bool ARRAY_KW_B = false; 65 bool NULL_KW_B = false; 66 bool NUMBER_KW_B = false; 67 bool SCALAR_KW_B = false; 68 69 bool isARRAY = false; 70 bool isFILE = false; 71 bool isNULL = false; 72 bool isSCALAR = false; 73 74 static int array_kw = e->KeywordIx("ARRAY"); 75 static int null_kw = e->KeywordIx("NULL"); 76 static int number_kw = e->KeywordIx("NUMBER"); 77 static int scalar_kw = e->KeywordIx("SCALAR"); 78 79 if (e->KeywordSet(array_kw)) { ARRAY_KW_B = true;} 80 if (e->KeywordSet(null_kw)) { NULL_KW_B = true;} 81 if (e->KeywordSet(number_kw)) { NUMBER_KW_B = true;} 82 if (e->KeywordSet(scalar_kw)) { SCALAR_KW_B = true; } 83 84 // new since 8.4 85 86 bool isBOOLEAN = false; 87 bool isINTEGER = false; 88 bool isFLOAT = false; 89 bool isCOMPLEX = false; 90 bool isSTRING = false; 91 92 bool BOOLEAN_KW_B = false; 93 bool INTEGER_KW_B = false; 94 bool FLOAT_KW_B = false; 95 bool COMPLEX_KW_B = false; 96 bool STRING_KW_B = false; 97 98 static int boolean_kw = e->KeywordIx("BOOLEAN"); 99 static int integer_kw = e->KeywordIx("INTEGER"); 100 static int float_kw = e->KeywordIx("FLOAT"); 101 static int complex_kw = e->KeywordIx("COMPLEX"); 102 static int string_kw = e->KeywordIx("STRING"); 103 104 if (e->KeywordSet(boolean_kw)) { BOOLEAN_KW_B = true;} 105 if (e->KeywordSet(integer_kw)) { INTEGER_KW_B = true;} 106 if (e->KeywordSet(float_kw)) { FLOAT_KW_B = true;} 107 if (e->KeywordSet(complex_kw)) { COMPLEX_KW_B = true; } 108 if (e->KeywordSet(string_kw)) { STRING_KW_B = true; } 109 110 // /FILE keyword not ready 111 bool FILE_KW_B = false; 112 static int file_kw = e->KeywordIx("FILE"); 113 if (e->KeywordSet(file_kw)) { FILE_KW_B = true;} 114 if (FILE_KW_B) { 115 string txt="(file keyword - ISA() not ready ! Please contribute !!"; 116 e->Throw(txt); 117 } 118 119 if (SCALAR_KW_B && ARRAY_KW_B) { 120 e->Throw("Keywords ARRAY and SCALAR are mutually exclusive."); 121 } 122 123 if (NULL_KW_B) { 124 string txt="Keywords NULL and "; 125 if (ARRAY_KW_B) e->Throw(txt+"ARRAY are mutually exclusive."); 126 if (FILE_KW_B) e->Throw(txt+"FILE are mutually exclusive."); 127 if (SCALAR_KW_B) e->Throw(txt+"SCALAR are mutually exclusive."); 128 if (NUMBER_KW_B) e->Throw(txt+"NUMBER are mutually exclusive."); 129 130 if (BOOLEAN_KW_B) e->Throw(txt+"BOOLEAN are mutually exclusive."); 131 if (INTEGER_KW_B) e->Throw(txt+"INTEGER are mutually exclusive."); 132 if (FLOAT_KW_B) e->Throw(txt+"FLOAT are mutually exclusive."); 133 if (COMPLEX_KW_B) e->Throw(txt+"COMPLEX are mutually exclusive."); 134 if (STRING_KW_B) e->Throw(txt+"STRING are mutually exclusive."); 135 } 136 137 if (BOOLEAN_KW_B) { 138 string txt="Keywords BOOLEAN and "; 139 if (INTEGER_KW_B) e->Throw(txt+"INTEGER are mutually exclusive."); 140 if (FLOAT_KW_B) e->Throw(txt+"FLOAT are mutually exclusive."); 141 if (COMPLEX_KW_B) e->Throw(txt+"COMPLEX are mutually exclusive."); 142 if (STRING_KW_B) e->Throw(txt+"STRING are mutually exclusive."); 143 } 144 if (INTEGER_KW_B) { 145 string txt="Keywords INTEGER and "; 146 if (FLOAT_KW_B) e->Throw(txt+"FLOAT are mutually exclusive."); 147 if (COMPLEX_KW_B) e->Throw(txt+"COMPLEX are mutually exclusive."); 148 if (STRING_KW_B) e->Throw(txt+"STRING are mutually exclusive."); 149 } 150 if (FLOAT_KW_B) { 151 string txt="Keywords FLOAT and "; 152 if (COMPLEX_KW_B) e->Throw(txt+"COMPLEX are mutually exclusive."); 153 if (STRING_KW_B) e->Throw(txt+"STRING are mutually exclusive."); 154 } 155 if (COMPLEX_KW_B) { 156 string txt="Keywords COMPLEX and "; 157 if (STRING_KW_B) e->Throw(txt+"STRING are mutually exclusive."); 158 } 159 160 //first par. 161 p0 = e->GetPar(0); 162 163 bool isNUMBER = true; 164 bool res = true; 165 // (1: boolean, 2: all integer like, 3 : float, 4 : complex, 5: string) 166 int sub_type=0; 167 168 if (p0 == NULL) { 169 type="UNDEFINED"; 170 res = false; 171 isNUMBER=false; 172 } else { 173 n_elem = p0->N_Elements(); 174 rank = p0->Rank(); 175 if (debug) cout << "type : "<< p0->Type() << ", Rank : "<< rank << endl; 176 177 switch (p0->Type()) 178 { 179 case GDL_UNDEF: type="UNDEFINED"; isNUMBER=false; res=false; break; 180 case GDL_BYTE: type="BYTE"; sub_type=1; break; 181 case GDL_INT: type="INT"; sub_type=2; break; 182 case GDL_LONG: type="LONG"; sub_type=2; break; 183 case GDL_FLOAT: type="FLOAT"; sub_type=3; break; 184 case GDL_DOUBLE: type="DOUBLE"; sub_type=3; break; 185 case GDL_COMPLEX: type="COMPLEX"; sub_type=4; break; 186 case GDL_STRING: type="STRING"; sub_type=5; isNUMBER=false; break; 187 case GDL_STRUCT: type="STRUCT"; isNUMBER=false; break; 188 case GDL_COMPLEXDBL: type="DCOMPLEX"; sub_type=4; break; 189 case GDL_PTR: type="POINTER"; isNUMBER=false; break; 190 case GDL_OBJ: type="OBJREF"; isNUMBER=false; break; 191 case GDL_UINT: type="UINT"; sub_type=2; break; 192 case GDL_ULONG: type="ULONG"; sub_type=2; break; 193 case GDL_LONG64: type="LONG64"; sub_type=2; break; 194 case GDL_ULONG64: type="ULONG64"; sub_type=2; break; 195 196 default: e->Throw("This should never happen, please report"); 197 } 198 } 199 200 if(type == "POINTER"){ 201 DPtrGDL* ptr = static_cast<DPtrGDL*>(p0); 202 DPtr ptrID = (*ptr)[0]; 203 if(ptrID == 0) res=false; else res=true; 204 } 205 206 if(type == "STRUCT"){ 207 //cout << "struct" << endl; 208 rank=1; // alway array following ISA() doc. 209 DStructGDL* str = static_cast<DStructGDL*>(p0); 210 if(str->Desc()->IsUnnamed()) structName="ANONYMOUS"; else structName = str->Desc()->Name(); 211 } 212 213 if(type == "OBJREF"){ 214 rank=1; // alway array following ISA() doc. 215 //cout << "OBJREF" << endl; 216 DObjGDL* obj = static_cast<DObjGDL*>(p0); 217 DObj objID = (*obj)[0]; 218 if(objID == 0) res = false; else res = true; 219 220 DStructGDL* oStructGDL= GDLInterpreter::GetObjHeapNoThrow(objID); 221 if( oStructGDL != NULL) { 222 BaseGDL* objRef = DInterpreter::GetObjHeap(objID); 223 DStructGDL* str = static_cast<DStructGDL*>(objRef); 224 if(str->Desc()->IsUnnamed()) 225 { 226 objectName="Anonymous"; 227 } 228 else { 229 objectName = str->Desc()->Name(); 230 } 231 // cout << objectName << endl; 232 } 233 } 234 235 //second par. 236 p1 = e->GetPar(1); 237 if (p1 != NULL){ 238 239 if (p1->Type() != GDL_STRING) 240 e->Throw("String expression required in this context:"+e->GetParString(1)); 241 242 if (p1->N_Elements() > 1) 243 e->Throw("Expression must be a scalar or 1 element array in this context"+e->GetParString(1)); 244 245 p1Str = static_cast<DStringGDL*>(p1->Convert2(GDL_STRING,BaseGDL::COPY)); 246 transform((*p1Str)[0].begin(), (*p1Str)[0].end(),(*p1Str)[0].begin(), ::toupper); 247 248 if (type == (*p1Str)[0]) res = true; else res = false; 249 250 if(type == "INT"){ if((*p1Str)[0] == "IDL_INT" || (*p1Str)[0] =="IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE" || (*p1Str)[0] == "IDL_INTEGER") res = true;} 251 if(type == "BYTE"){ if((*p1Str)[0] == "IDL_BYTE" || (*p1Str)[0] == "IDL_INTEGER" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 252 if(type == "LONG"){ if ((*p1Str)[0] == "IDL_LONG" || (*p1Str)[0] == "IDL_INTEGER" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 253 if(type == "FLOAT"){ if((*p1Str)[0] == "IDL_FLOAT" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 254 if(type == "DOUBLE"){ if((*p1Str)[0] == "IDL_DOUBLE" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 255 if(type == "STRING"){ if((*p1Str)[0] == "IDL_STRING" || (*p1Str)[0] == "IDL_VARIBALE") res = true;} 256 if(type == "DCOMPLEX"){ if((*p1Str)[0] == "IDL_DCOMPLEX" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 257 if(type == "POINTER"){if((*p1Str)[0] == "IDL_POINTER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 258 if(type == "UINT"){if((*p1Str)[0] == "IDL_UINT" || (*p1Str)[0] == "IDL_INTEGER" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 259 if(type == "ULONG"){if((*p1Str)[0] == "IDL_ULONG" || (*p1Str)[0] == "IDL_INTEGER" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 260 if(type == "LONG64"){if((*p1Str)[0] == "IDL_LONG64" || (*p1Str)[0] == "IDL_INTEGER" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 261 if(type == "ULONG64"){if((*p1Str)[0] == "IDL_ULONG64" || (*p1Str)[0] == "IDL_INTEGER" || (*p1Str)[0] == "IDL_NUMBER" || (*p1Str)[0] == "IDL_VARIABLE") res = true;} 262 263 if(type == "STRUCT"){ if(structName == (*p1Str)[0]) res = true;} 264 if(type == "OBJREF"){ if(objectName == (*p1Str)[0]) res = true;} 265 266 debug=0; 267 if (debug) cout << type << " " << (*p1Str)[0] << " " << res << endl; 268 } 269 270 if(type != "UNDEFINED"){ 271 272 if (sub_type == 1) isBOOLEAN = true; 273 if (sub_type == 2) isINTEGER = true; 274 if (sub_type == 3) isFLOAT = true; 275 if (sub_type == 4) isCOMPLEX = true; 276 if (sub_type == 5) isSTRING = true; 277 278 if(BOOLEAN_KW_B && res) { res = res && isBOOLEAN ;} 279 if(INTEGER_KW_B && res) { res = res && isINTEGER ;} 280 if(FLOAT_KW_B && res) { res = res && isFLOAT ;} 281 if(COMPLEX_KW_B && res) { res = res && isCOMPLEX ;} 282 if(STRING_KW_B && res) { res = res && isSTRING ;} 283 284 if(NULL_KW_B && res){ 285 res = false; 286 } 287 288 if(SCALAR_KW_B && res){ 289 if (rank == 0) isSCALAR=true; else isSCALAR=false; 290 res = res && isSCALAR; 291 } 292 293 if(NUMBER_KW_B && res){ 294 //cout<<"Number"<<endl; 295 res = res && isNUMBER; 296 } 297 298 if(ARRAY_KW_B && res){ 299 //cout<<"Array"<<endl; 300 if (rank > 0) isARRAY = true; else isARRAY = false; 301 res = res && isARRAY; 302 } 303 304 if(NULL_KW_B && res){ 305 res = false; 306 } 307 } else { 308 // we have two cases : undefined variable OR variable set to !null 309 if (NULL_KW_B){ 310 if (p0 == NULL) res = false; 311 else { 312 res = true; 313 res = res && (!ARRAY_KW_B) && (!SCALAR_KW_B) && (!NUMBER_KW_B); 314 } 315 } else { 316 res = res && (!ARRAY_KW_B) && (!SCALAR_KW_B) && (!NUMBER_KW_B); 317 } 318 } 319 320 if (res) return new DByteGDL(1); 321 return new DByteGDL(0); 322 } 323 typename_fun(EnvT * e)324 BaseGDL* typename_fun( EnvT* e) 325 { 326 DString type=""; 327 BaseGDL* p0 = e->GetPar(0); 328 329 // we manage Undefined here, !null is managed below 330 if (p0 == NULL) return new DStringGDL("UNDEFINED"); 331 332 int redo=0; 333 334 switch (p0->Type()) 335 { 336 // this is different that (p0 == NULL), here input is set to !null 337 case GDL_UNDEF: type="UNDEFINED"; break; 338 case GDL_BYTE: type="BYTE"; break; 339 case GDL_INT: type="INT"; break; 340 case GDL_LONG: type="LONG"; break; 341 case GDL_FLOAT: type="FLOAT"; break; 342 case GDL_DOUBLE: type="DOUBLE"; break; 343 case GDL_COMPLEX: type="COMPLEX"; break; 344 case GDL_STRING: type="STRING"; break; 345 case GDL_STRUCT: redo=1; break; 346 case GDL_COMPLEXDBL: type="DCOMPLEX"; break; 347 case GDL_PTR: type="POINTER"; break; 348 case GDL_OBJ:redo=1; break; 349 case GDL_UINT: type="UINT"; break; 350 case GDL_ULONG: type="ULONG"; break; 351 case GDL_LONG64: type="LONG64"; break; 352 case GDL_ULONG64: type="ULONG64"; break; 353 354 default: e->Throw("This should never happen, please report"); 355 } 356 357 if (redo) { 358 //cout << "here we are " <<p0->Type() << endl; 359 if (p0->Type() == GDL_STRUCT) { 360 DStructGDL* s = static_cast<DStructGDL*> (p0); 361 // AC 2018-Feb-02 : order is : Array (struct), name, anon 362 bool debug=false; 363 if (debug) { 364 cout << "Rank :" << p0->Rank() << endl; 365 cout << "Dim :" << p0->Dim() << endl; 366 cout << "Size :" << p0->Size() << endl; 367 cout << "StrictScalar :" << p0->StrictScalar() << endl; 368 } 369 if (p0->Dim(0) > 1) { 370 type = "STRUCT"; 371 } else { 372 if (s->Desc()->IsUnnamed()) { 373 type = "ANONYMOUS"; 374 } else { 375 type = s->Desc()->Name(); 376 } 377 } 378 } 379 380 // here we manage : {Objects, LIST, HASH} 381 if (p0->Type() == GDL_OBJ) { 382 383 // see case in "basic_pro.cpp", in help_item() 384 if (!p0->StrictScalar()) { 385 type = "OBJREF"; 386 } else { 387 388 DObj s = (*static_cast<DObjGDL*> (p0))[0]; // is StrictScalar() 389 if (s != 0) // no overloads for null object 390 { 391 DStructGDL* oStructGDL = GDLInterpreter::GetObjHeapNoThrow(s); 392 if (oStructGDL->Desc()->IsUnnamed()) 393 e->Throw("We don't know how to be here (unnamed Obj/List/Hash), please provide example !"); 394 395 type = oStructGDL->Desc()->Name(); 396 } else { 397 type = "UNDEFINED"; 398 } 399 } 400 } 401 } 402 return new DStringGDL(type); 403 404 } 405 size_fun(EnvT * e)406 BaseGDL* size_fun( EnvT* e) 407 { 408 static int L64Ix = e->KeywordIx( "L64"); 409 static int dimIx = e->KeywordIx( "DIMENSIONS"); 410 static int FILE_LUNIx = e->KeywordIx( "FILE_LUN"); 411 static int FILE_OFFSETIx = e->KeywordIx( "FILE_OFFSET"); 412 static int N_DIMENSIONSIx = e->KeywordIx( "N_DIMENSIONS"); 413 static int N_ELEMENTSIx = e->KeywordIx( "N_ELEMENTS"); 414 static int STRUCTUREIx = e->KeywordIx( "STRUCTURE"); 415 static int SNAMEIx = e->KeywordIx( "SNAME"); 416 static int TNAMEIx = e->KeywordIx( "TNAME"); 417 static int TYPEIx = e->KeywordIx( "TYPE"); 418 419 e->NParam( 1); // might be GDL_UNDEF, but must be given 420 421 // BaseGDL* p0 = e->GetParDefined( 0); //, "SIZE"); 422 BaseGDL* p0 = e->GetPar( 0); //, "SIZE"); 423 424 // managing exclusive keywords (all but L64) 425 int nb_keywords_set=0; 426 if (e->KeywordSet(dimIx)) nb_keywords_set++; 427 if (e->KeywordSet(FILE_LUNIx)) nb_keywords_set++; 428 if (e->KeywordSet(FILE_OFFSETIx)) nb_keywords_set++; 429 if (e->KeywordSet(N_DIMENSIONSIx)) nb_keywords_set++; 430 if (e->KeywordSet(N_ELEMENTSIx)) nb_keywords_set++; 431 if (e->KeywordSet(STRUCTUREIx)) nb_keywords_set++; 432 if (e->KeywordSet(SNAMEIx)) nb_keywords_set++; 433 if (e->KeywordSet(TNAMEIx)) nb_keywords_set++; 434 if (e->KeywordSet(TYPEIx)) nb_keywords_set++; 435 436 if (nb_keywords_set > 1) e->Throw("Conflicting keywords."); 437 438 SizeT nEl = 0; 439 SizeT Rank = 0; 440 SizeT LogicalRank = 0; 441 SizeT vType = GDL_UNDEF; 442 443 if (p0 != NULL) { 444 nEl = p0->N_Elements(); 445 Rank = p0->Rank(); 446 LogicalRank = p0->Rank(); 447 vType = p0->Type(); 448 } 449 450 bool forceL64=false; 451 if (nEl > 2147483647UL) forceL64=true; 452 453 bool isObjectContainer = false; 454 if( vType == GDL_OBJ) 455 { 456 DObjGDL* p0Obj = static_cast<DObjGDL*>(p0); 457 if( p0Obj->StrictScalar()) 458 { 459 DStructGDL* oStructGDL= GDLInterpreter::GetObjHeapNoThrow( (*p0Obj)[0]); 460 if( oStructGDL != NULL) // if object not valid -> default behaviour 461 { 462 DStructDesc* desc = oStructGDL->Desc(); 463 464 if( desc->IsParent("LIST")) 465 { 466 isObjectContainer = true; nEl = LIST_count(oStructGDL); 467 } 468 if( desc->IsParent("HASH")) 469 { 470 isObjectContainer = true; nEl = HASH_count(oStructGDL); 471 } 472 } 473 } 474 } 475 476 if( isObjectContainer) 477 { 478 LogicalRank = 1; 479 } 480 481 // DIMENSIONS 482 if( e->KeywordSet( dimIx)) { 483 if( LogicalRank == 0) { 484 if( e->KeywordSet(L64Ix) || forceL64) 485 return new DLong64GDL( 0); 486 else 487 return new DLongGDL( 0); 488 } 489 dimension dim( LogicalRank); 490 491 if( e->KeywordSet(L64Ix) || forceL64) { // L64 492 DLong64GDL* res = new DLong64GDL( dim, BaseGDL::NOZERO); 493 (*res)[0] = 0; 494 for( SizeT i=0; i<Rank; ++i) (*res)[ i] = p0->Dim(i); 495 if( isObjectContainer) 496 (*res)[ 0] = nEl; 497 return res; 498 } else { 499 DLongGDL* res = new DLongGDL( dim, BaseGDL::NOZERO); 500 (*res)[0] = 0; 501 for( SizeT i=0; i<Rank; ++i) (*res)[ i] = p0->Dim(i); 502 if( isObjectContainer) 503 (*res)[ 0] = nEl; 504 return res; 505 } 506 } 507 508 // FILE_LUN 509 string txt="Sorry, keyword "; 510 if( e->KeywordSet(FILE_LUNIx)) { 511 e->Throw(txt+"/FILE_LUN not supported yet, please contribute."); 512 } 513 if( e->KeywordSet(FILE_OFFSETIx)) { 514 e->Throw(txt+"/FILE_OFFSET not supported yet, please contribute."); 515 } 516 517 // N_DIMENSIONS 518 if( e->KeywordSet(N_DIMENSIONSIx)) { 519 return new DLongGDL( LogicalRank); 520 } 521 522 //N_ELEMENTS 523 if( e->KeywordSet(N_ELEMENTSIx)) { 524 if( e->KeywordSet(L64Ix) || forceL64) 525 return new DLong64GDL(nEl); 526 else 527 return new DLongGDL( nEl); 528 } 529 530 // STRUCTURE 531 if( e->KeywordSet(STRUCTUREIx)) { 532 533 DStructGDL* res; 534 535 if (e->KeywordSet(L64Ix) || forceL64 ) { 536 res = new DStructGDL( "IDL_SIZE64"); 537 } else { 538 res = new DStructGDL( "IDL_SIZE"); 539 } 540 541 if ( p0 == NULL) { 542 res->InitTag("TYPE_NAME", DStringGDL("UNDEFINED")); 543 return res; 544 } 545 546 DString tname; 547 DString sname; 548 if (vType == GDL_STRUCT) { 549 tname = "STRUCT"; 550 DStructGDL* s = static_cast<DStructGDL*>( p0); 551 if (s->Desc()->IsUnnamed()) 552 sname = ""; 553 else 554 sname = s->Desc()->Name(); 555 } else { 556 tname = p0->TypeStr(); 557 sname = ""; 558 } 559 560 res->InitTag("TYPE_NAME", DStringGDL(tname)); 561 res->InitTag("STRUCTURE_NAME", DStringGDL(sname)); 562 res->InitTag("TYPE", DIntGDL(vType)); 563 res->InitTag("FILE_LUN", DIntGDL(0)); 564 if (e->KeywordSet(L64Ix) || forceL64) { 565 res->InitTag("FILE_OFFSET", DLong64GDL(0)); 566 res->InitTag("N_ELEMENTS", DLong64GDL(nEl)); 567 } else { 568 res->InitTag("FILE_OFFSET", DLongGDL(0)); 569 res->InitTag("N_ELEMENTS", DLongGDL(nEl)); 570 } 571 res->InitTag("N_DIMENSIONS", DLongGDL(Rank)); 572 573 // Initialize dimension values to 0 574 if (e->KeywordSet(L64Ix) || forceL64 ) { 575 DLong64GDL *dims_res = new DLong64GDL(dimension(MAXRANK), BaseGDL::ZERO); 576 for( SizeT i=Rank; i<MAXRANK; ++i) (*dims_res)[ i] = 0; 577 for( SizeT i=0; i<Rank; ++i) (*dims_res)[ i] = p0->Dim(i); 578 res->InitTag("DIMENSIONS", *dims_res); 579 } else { 580 DLongGDL *dims_res = new DLongGDL(dimension(MAXRANK), BaseGDL::ZERO); 581 for( SizeT i=Rank; i<MAXRANK; ++i) (*dims_res)[ i] = 0; 582 for( SizeT i=0; i<Rank; ++i) (*dims_res)[ i] = p0->Dim(i); 583 res->InitTag("DIMENSIONS", *dims_res); 584 } 585 586 return res; 587 //e->Throw( "STRUCTURE not supported yet."); 588 } 589 590 // SNAME 591 if( e->KeywordSet(SNAMEIx)) { 592 DString sname=""; 593 if (vType == GDL_STRUCT) { 594 DStructGDL* s = static_cast<DStructGDL*>( p0); 595 if (!s->Desc()->IsUnnamed()) sname = s->Desc()->Name(); 596 } 597 return new DStringGDL(sname); 598 } 599 600 // TNAME 601 if( e->KeywordSet(TNAMEIx)) { 602 if( p0 == NULL) 603 return new DStringGDL( "UNDEFINED"); 604 return new DStringGDL( p0->TypeStr()); 605 } 606 607 // TYPE 608 if( e->KeywordSet(TYPEIx)) { 609 return new DLongGDL( vType ); 610 } 611 612 // the general case without keyword ... 613 614 dimension dim( 3 + LogicalRank); 615 616 if( e->KeywordSet(L64Ix) || forceL64 ) { 617 DLong64GDL* res = new DLong64GDL( dim, BaseGDL::NOZERO); 618 (*res)[ 0] = LogicalRank; 619 for( SizeT i=0; i<Rank; ++i) (*res)[ i+1] = p0->Dim(i); 620 if( isObjectContainer) 621 (*res)[ 0+1] = nEl; 622 (*res) [ LogicalRank+1] = vType; 623 (*res) [ LogicalRank+2] = nEl; 624 625 return res; 626 } else { 627 DLongGDL* res = new DLongGDL( dim, BaseGDL::NOZERO); 628 (*res)[ 0] = LogicalRank; 629 for( SizeT i=0; i<Rank; ++i) (*res)[ i+1] = p0->Dim(i); 630 if( isObjectContainer) 631 (*res)[ 0+1] = nEl; 632 (*res) [ LogicalRank+1] = vType; 633 (*res) [ LogicalRank+2] = nEl; 634 635 return res; 636 } 637 638 return new DIntGDL( 0); // default for not supported 639 } 640 fstat_fun(EnvT * e)641 BaseGDL* fstat_fun( EnvT* e) 642 { 643 e->NParam( 1);//, "FSTAT"); 644 645 DLong lun; 646 e->AssureLongScalarPar( 0, lun); 647 648 if( lun < -2 || lun > maxLun) 649 throw GDLException( e->CallingNode(), 650 " File unit is not within allowed range: "+i2s(lun)+"."); 651 652 SizeT size; 653 bool big = false; 654 655 if (lun > 0) 656 { 657 if (fileUnits[ lun - 1].IsOpen() && !fileUnits[ lun - 1].Compress() ) //due to bug in gzTell, we DO NOT WANT to get the size here. 658 { 659 size = fileUnits[ lun - 1].Size(); 660 big = (DLong(size) != size); 661 } 662 } 663 664 DStructGDL* fileStatus; 665 if (big) fileStatus = new DStructGDL( "FSTAT64"); 666 else fileStatus = new DStructGDL( "FSTAT"); 667 668 fileStatus->InitTag("UNIT", DLongGDL( lun)); 669 670 if( lun <= 0) 671 { 672 std::string names[3]={"<stdin>","<stdout>","<stderr>"}; 673 int rval[3]={1,0,0}; 674 struct stat buffer; 675 int status = fstat(-lun, &buffer); 676 fileStatus->InitTag("NAME", DStringGDL( names[-lun])); 677 fileStatus->InitTag("OPEN", DByteGDL( 1 )); 678 DByte isatty=((buffer.st_mode & S_IFMT) == S_IFCHR); 679 fileStatus->InitTag("ISATTY", DByteGDL( isatty )); 680 fileStatus->InitTag("ISAGUI", DByteGDL( 0)); 681 fileStatus->InitTag("INTERACTIVE", DByteGDL( isatty )); 682 // fileStatus->InitTag("XDR", DByteGDL( 0 )); 683 // fileStatus->InitTag("COMPRESS",DByteGDL( 0 )); 684 fileStatus->InitTag("READ", DByteGDL( rval[-lun] )); 685 fileStatus->InitTag("WRITE", DByteGDL( rval[-lun]==0 )); 686 fileStatus->InitTag("ATIME", DLong64GDL( buffer.st_atime)); 687 fileStatus->InitTag("CTIME", DLong64GDL( buffer.st_ctime)); 688 fileStatus->InitTag("MTIME", DLong64GDL( buffer.st_mtime)); 689 // fileStatus->InitTag("TRANSFER_COUNT", DLongGDL( 0 )); 690 // fileStatus->InitTag("CUR_PTR", DLongGDL( 0 )); 691 // fileStatus->InitTag("SIZE", DLongGDL( 0 )); 692 // fileStatus->InitTag("REC_LEN", DLongGDL( 0 )); 693 } 694 else 695 { // normal file 696 GDLStream& actUnit = fileUnits[ lun-1]; 697 698 if( !actUnit.IsOpen()) 699 return fileStatus; // OPEN tag is init to zero (SpDByte::GetInstance()) 700 701 struct stat buffer; 702 int status = stat(actUnit.Name().c_str(), &buffer); 703 704 fileStatus->InitTag("NAME", DStringGDL( actUnit.Name())); 705 fileStatus->InitTag("OPEN", DByteGDL( 1)); 706 if (big) fileStatus->InitTag("SIZE", DLong64GDL( buffer.st_size));//size)); 707 else fileStatus->InitTag("SIZE", DLongGDL( buffer.st_size));//size)); 708 DByte isatty=((buffer.st_mode & S_IFMT) == S_IFCHR); 709 fileStatus->InitTag("ISATTY", DByteGDL( isatty )); 710 fileStatus->InitTag("ISAGUI", DByteGDL( 0)); 711 fileStatus->InitTag("INTERACTIVE", DByteGDL( isatty )); 712 fileStatus->InitTag("XDR", DByteGDL( (actUnit.Xdr()==NULL)?0:1)); 713 fileStatus->InitTag("COMPRESS",DByteGDL( actUnit.Compress())); 714 fileStatus->InitTag("READ", DByteGDL( actUnit.IsReadable()?1:0)); 715 fileStatus->InitTag("WRITE", DByteGDL( actUnit.IsWriteable()?1:0)); 716 fileStatus->InitTag("ATIME", DLong64GDL( buffer.st_atime)); 717 fileStatus->InitTag("CTIME", DLong64GDL( buffer.st_ctime)); 718 fileStatus->InitTag("MTIME", DLong64GDL( buffer.st_mtime)); 719 // fileStatus->InitTag("TRANSFER_COUNT", DLongGDL( 0 )); 720 if (big) fileStatus->InitTag("CUR_PTR", DLong64GDL( actUnit.Tell())); 721 else fileStatus->InitTag("CUR_PTR", DLongGDL( actUnit.Tell())); 722 if (big) fileStatus->InitTag("SIZE", DLong64GDL( buffer.st_size )); 723 else fileStatus->InitTag("SIZE", DLongGDL( buffer.st_size )); 724 // fileStatus->InitTag("REC_LEN", DLongGDL( 0 )); 725 } 726 727 return fileStatus; 728 } 729 730 template<typename T> make_array_template(EnvT * e,DLongGDL * dimKey,BaseGDL * value,DDouble off,DDouble inc)731 BaseGDL* make_array_template(EnvT* e, DLongGDL* dimKey, BaseGDL* value, DDouble off, DDouble inc) 732 { 733 try { 734 dimension dim; 735 736 if(!dimKey) arr(e, dim); 737 else dim = dimension(&(*dimKey)[0], dimKey->N_Elements()); 738 739 if(value) { 740 return static_cast<T*>(value)->New(dim, BaseGDL::INIT)->Convert2(T::Traits::t); 741 } 742 if(e->KeywordSet("NOZERO")) return new T(dim, BaseGDL::NOZERO); 743 744 if(e->KeywordSet("INDEX")) return new T(dim, BaseGDL::INDGEN, off, inc); 745 746 return new T(dim); 747 } catch(GDLException& ex) { 748 e->Throw(ex.getMessage()); 749 } 750 751 assert(false); 752 return NULL; 753 } 754 make_array_template(EnvT * e,DLongGDL * dimKey,DStructGDL * value,DDouble off,DDouble inc)755 DStructGDL* make_array_template(EnvT* e, DLongGDL* dimKey, DStructGDL* value, DDouble off, DDouble inc) 756 { 757 try { 758 dimension dim; 759 760 if(!dimKey) arr(e, dim); 761 else dim = dimension(&(*dimKey)[0], dimKey->N_Elements()); 762 return value->New(dim,BaseGDL::INIT); 763 } catch(GDLException& ex) { 764 e->Throw(ex.getMessage()); 765 } 766 767 assert(false); 768 return NULL; 769 } 770 make_array(EnvT * e)771 BaseGDL* make_array(EnvT* e) { 772 DDouble off = 0, inc = 1; 773 DType type = GDL_UNDEF; 774 775 e->AssureDoubleScalarKWIfPresent("START", off); 776 e->AssureDoubleScalarKWIfPresent("INCREMENT", inc); 777 778 DLongGDL* dimKey = NULL; 779 Guard<DLongGDL> dimKey_guard; 780 781 static int sizeix = e->KeywordIx("SIZE"); 782 static int dimensionix = e->KeywordIx("DIMENSION"); 783 784 BaseGDL* size = e->GetKW(sizeix); 785 BaseGDL* b_dimension = e->GetKW(dimensionix); 786 787 if(b_dimension) { 788 DLongGDL* l_dimension = e->GetKWAs<DLongGDL>(dimensionix); 789 790 for(int i = 0; i < l_dimension->N_Elements(); ++i) 791 if((*l_dimension)[i] < 1) 792 e->Throw("Array dimensions must be greater than 0."); 793 794 if(e->NParam() == 0 && size == NULL) { 795 dimension dim(l_dimension->N_Elements(), 1); 796 dimKey = new DLongGDL(dim, BaseGDL::NOZERO); 797 dimKey_guard.Reset(dimKey); 798 799 for(int i = 0; i < l_dimension->N_Elements(); ++i) 800 (*dimKey)[i] = (*l_dimension)[i]; 801 } 802 } else if(size) { 803 DLongGDL* l_size = e->GetKWAs<DLongGDL>(sizeix); 804 805 if(l_size->N_Elements() < 4 || l_size->N_Elements() > 11) 806 e->Throw("Keyword array parameter SIZE must have from 4 to 11 elements."); 807 808 DLong expectedDim = l_size->N_Elements()-3; 809 type = static_cast<DType>((*l_size)[expectedDim + 1]); 810 811 if(e->NParam() == 0) { 812 dimension dim(expectedDim, 1); 813 dimKey = new DLongGDL(dim, BaseGDL::NOZERO); 814 dimKey_guard.Reset(dimKey); 815 816 for(int i = 1; i <= expectedDim; ++i) { 817 if((*l_size)[i] < 1) 818 e->Throw("Array dimensions must be greater than 0."); 819 820 (*dimKey)[i - 1] = (*l_size)[i]; 821 } 822 } 823 } 824 825 static int indexIx = e->KeywordIx("INDEX"); 826 static int valueIx = e->KeywordIx("VALUE"); 827 BaseGDL* value = e->GetKW(valueIx); 828 bool wasAValue=false; 829 if(value && !value->Scalar()) e->Throw("Expression must be a scalar in this context: " + e->GetString(valueIx)); 830 831 static int typeIx = e->KeywordIx("TYPE"); 832 if(e->KeywordPresent(typeIx)) { 833 DLong temp; 834 e->AssureLongScalarKW(typeIx, temp); 835 type = static_cast<DType>(temp); 836 } 837 else if(e->KeywordSet("BOOLEAN")) { 838 if(e->KeywordSet(indexIx)) 839 e->Throw("Keyword INDEX is not allowed with BOOLEAN."); 840 841 // TODO: Add support for BOOLEAN type introduced in IDL 8.4 842 e->Throw("MAKE_ARRAY of BOOLEAN types not yet implemented."); 843 } 844 else if(e->KeywordSet("BYTE")) type = GDL_BYTE; 845 else if(e->KeywordSet("COMPLEX")) type = GDL_COMPLEX; 846 else if(e->KeywordSet("DCOMPLEX")) type = GDL_COMPLEXDBL; 847 else if(e->KeywordSet("DOUBLE")) type = GDL_DOUBLE; 848 else if(e->KeywordSet("FLOAT")) type = GDL_FLOAT; 849 else if(e->KeywordSet("INTEGER")) type = GDL_INT; 850 else if(e->KeywordSet("L64")) type = GDL_LONG64; 851 else if(e->KeywordSet("LONG")) type = GDL_LONG; 852 else if(e->KeywordSet("OBJ")) type = GDL_OBJ; 853 else if(e->KeywordSet("PTR")) type = GDL_PTR; 854 else if(e->KeywordSet("STRING")) type = GDL_STRING; 855 else if(e->KeywordSet("UINT")) type = GDL_UINT; 856 else if(e->KeywordSet("UL64")) type = GDL_ULONG64; 857 else if(e->KeywordSet("ULONG")) type = GDL_ULONG; 858 else if(value) { 859 wasAValue=true; 860 type = value->Type(); 861 } 862 863 switch(type) { 864 case GDL_BYTE: return make_array_template<DByteGDL>(e, dimKey, value, off, inc); 865 case GDL_COMPLEX: return make_array_template<DComplexGDL>(e, dimKey, value, off, inc); 866 case GDL_COMPLEXDBL: return make_array_template<DComplexDblGDL>(e, dimKey, value, off, inc); 867 case GDL_DOUBLE: return make_array_template<DDoubleGDL>(e, dimKey, value, off, inc); 868 case GDL_FLOAT: return make_array_template<DFloatGDL>(e, dimKey, value, off, inc); 869 case GDL_INT: return make_array_template<DIntGDL>(e, dimKey, value, off, inc); 870 case GDL_LONG64: return make_array_template<DLong64GDL>(e, dimKey, value, off, inc); 871 case GDL_LONG: return make_array_template<DLongGDL>(e, dimKey, value, off, inc); 872 case GDL_UINT: return make_array_template<DUIntGDL>(e, dimKey, value, off, inc); 873 case GDL_ULONG64: return make_array_template<DULong64GDL>(e, dimKey, value, off, inc); 874 case GDL_ULONG: return make_array_template<DULongGDL>(e, dimKey, value, off, inc); 875 case GDL_OBJ: 876 if(e->KeywordSet(indexIx)) e->Throw("Index initialization of object reference array is invalid."); 877 return make_array_template<DObjGDL>(e, dimKey, value, off, inc); 878 case GDL_PTR: 879 if(e->KeywordSet(indexIx)) e->Throw("Index initialization of pointer array is invalid."); 880 return make_array_template<DPtrGDL>(e, dimKey, value, off, inc); 881 case GDL_STRING: 882 if(!e->KeywordSet(indexIx)) return make_array_template<DStringGDL>(e, dimKey, value, off, inc); 883 else return make_array_template<DULongGDL>(e, dimKey, value, off, inc)->Convert2(GDL_STRING); 884 case GDL_STRUCT: 885 if (wasAValue) return make_array_template(e, dimKey, static_cast<DStructGDL*>(value), off, inc); 886 else e->Throw("Invalid type specified for result."); 887 default:; // Default to FLOAT to emulate IDL 888 } 889 890 return make_array_template<DFloatGDL>(e, dimKey, value, off, inc); 891 } 892 reform(EnvT * e)893 BaseGDL* reform( EnvT* e) 894 { 895 SizeT nParam=e->NParam(1); 896 897 BaseGDL** p0P = &e->GetParDefined( 0); 898 BaseGDL* p0 = *p0P; 899 900 SizeT nEl = p0->N_Elements(); 901 // SizeT Rank = p0->Rank(); 902 // if( Rank == 0) 903 // e->Throw( "Parameter must be an array in this context: " 904 // + e->GetParString( 0)); 905 906 // SizeT Type = p0->Type(); 907 908 dimension dim; 909 910 if (nParam == 1) { 911 // SizeT j=1; 912 for( SizeT i=0; i<p0->Rank(); ++i) { 913 // if (p0->Dim(i) == 0) break; 914 if (p0->Dim(i) > 1) 915 { 916 dim << p0->Dim( i); 917 // j *= p0->Dim(i); 918 // cout << j << p0->Dim(i) << endl; 919 // dim.Set(j,p0->Dim(i)); 920 //j++; 921 } 922 } 923 if( dim.Rank() == 0) 924 dim << 1; 925 // dim.Set(0, j); 926 } 927 else 928 arr( e, dim, 1); 929 930 if (dim.NDimElements() != nEl) 931 e->Throw( "New subscripts must not change the number of elements in " 932 + e->GetParString( 0)); 933 934 // make a copy if p0 is not global 935 // if( !e->GlobalPar( 0)) 936 // p0 = p0->Dup(); 937 // better: steal p0 938 if( !e->GlobalPar( 0)) 939 { 940 bool success = e->StealLocalPar( 0); //*p0P = NULL; 941 //*p0P = NULL; // prevent local parameter form deletion 942 assert( success); 943 p0->SetDim(dim); 944 return p0; 945 } 946 947 static int overwriteIx = e->KeywordIx("OVERWRITE"); 948 if (e->KeywordSet( overwriteIx)) 949 { 950 p0->SetDim(dim); 951 e->SetPtrToReturnValue( p0P); 952 return p0; 953 } 954 955 // global paramter - make a copy 956 BaseGDL* res = p0->Dup(); 957 res->SetDim(dim); 958 return res; 959 } 960 961 962 // note: changes here MUST be reflected in routine_names_reference() as well 963 // because DLibFun of this function is used for routine_names_reference() the keyword 964 // indices must match 965 routine_names_value(EnvT * e)966 BaseGDL* routine_names_value(EnvT* e) { 967 SizeT nParam = e->NParam(); 968 969 EnvStackT& callStack = e->Interpreter()->CallStack(); 970 // DLong curlevnum = callStack.size()-1; 971 // 'e' is not on the stack 972 DLong curlevnum = callStack.size(); 973 static int sfunctionsIx=e->KeywordIx("S_FUNCTIONS"); 974 static int sproceduresIx=e->KeywordIx("S_PROCEDURES"); 975 static int levelIx=e->KeywordIx("LEVEL"); 976 if (e->KeywordSet(sfunctionsIx)) { 977 vector<DString> subList; 978 979 SizeT nFun = libFunList.size(); 980 for (SizeT i = 0; i < nFun; ++i) { 981 DString s = libFunList[ i]->ToString(); 982 s = s.substr(4); // Remove "res=" 983 984 size_t left_paren = s.find_first_of("("); 985 subList.push_back(s.substr(0, left_paren)); 986 } 987 988 sort(subList.begin(), subList.end()); 989 990 DStringGDL* res = new DStringGDL(dimension(nFun), BaseGDL::NOZERO); 991 for (SizeT i = 0; i < nFun; ++i) { 992 (*res)[i] = subList[ i]; 993 } 994 return res; 995 } 996 997 if (e->KeywordSet(sproceduresIx)) { 998 vector<DString> subList; 999 1000 SizeT nPro = libProList.size(); 1001 for (SizeT i = 0; i < nPro; ++i) { 1002 DString s = libProList[ i]->ToString(); 1003 1004 size_t comma_brac = s.find_first_of(",["); 1005 subList.push_back(s.substr(0, comma_brac)); 1006 } 1007 1008 sort(subList.begin(), subList.end()); 1009 1010 DStringGDL* res = new DStringGDL(dimension(nPro), BaseGDL::NOZERO); 1011 for (SizeT i = 0; i < nPro; ++i) { 1012 (*res)[i] = subList[ i]; 1013 } 1014 return res; 1015 } 1016 1017 if (e->KeywordSet(levelIx)) { 1018 return new DLongGDL(curlevnum); 1019 } 1020 1021 static int variablesIx = e->KeywordIx("VARIABLES"); 1022 static int fetchIx = e->KeywordIx("FETCH"); 1023 static int arg_namesIx = e->KeywordIx("ARG_NAME"); 1024 static int storeIx = e->KeywordIx("STORE"); 1025 bool var = false, fetch = false, arg = false, store = false; 1026 1027 DLongGDL* level; 1028 level = e->IfDefGetKWAs<DLongGDL>(variablesIx); 1029 if (level != NULL) { 1030 var = true; 1031 } 1032 else { 1033 level = e->IfDefGetKWAs<DLongGDL>(fetchIx); 1034 if (level != NULL) { 1035 fetch = true; 1036 } else { 1037 level = e->IfDefGetKWAs<DLongGDL>(arg_namesIx); 1038 if (level != NULL) { 1039 arg = true; 1040 } else { 1041 level = e->IfDefGetKWAs<DLongGDL>(storeIx); 1042 if (level != NULL) { 1043 store = true; 1044 } 1045 } 1046 } 1047 } 1048 1049 DString varName; 1050 1051 if (level != NULL) { 1052 DLong desiredlevnum = (*level)[0]; 1053 if (desiredlevnum <= 0) 1054 desiredlevnum += curlevnum; 1055 if (desiredlevnum < 1) 1056 return new DStringGDL(""); 1057 if (desiredlevnum > curlevnum) 1058 desiredlevnum = curlevnum; 1059 1060 DSubUD* pro = static_cast<DSubUD*> (callStack[desiredlevnum - 1]->GetPro()); 1061 SizeT nVar = pro->Size(); // # var in GDL for desired level 1062 SizeT nComm = pro->CommonsSize(); // # has commons? 1063 //cerr<<"nComm= "<<nComm<<" in " <<pro->NumberOfCommons()<<" commons"<<endl; 1064 SizeT nTotVar = nVar + nComm; //All the variables availables at that lev. 1065 int nKey = pro->NKey(); 1066 //cout << "nKey:" << nKey << endl; 1067 //cout << "nVar:" << nVar << endl; 1068 //cout << pro->Name() << endl; 1069 1070 if (var) { 1071 if (nTotVar == 0) return new DStringGDL(""); 1072 DStringGDL* res = new DStringGDL(dimension(nTotVar), BaseGDL::NOZERO); 1073 set<string> sortedList; // "Sorted List" 1074 if (nVar > 0) { 1075 for (SizeT i = 0; i < nVar; ++i) { 1076 string vname = pro->GetVarName(i); 1077 sortedList.insert(vname); 1078 } 1079 } 1080 if (nComm > 0) { 1081 DStringGDL* list=static_cast<DStringGDL*>(pro->GetCommonVarNameList()); 1082 for (SizeT i = 0; i < list->N_Elements(); ++i) { 1083 sortedList.insert((*list)[i]); 1084 } 1085 } 1086 SizeT ivar=0; 1087 set<string>::iterator it = sortedList.begin(); 1088 while (it != sortedList.end()) (*res)[ivar++] = *it++; 1089 return res; 1090 } 1091 else if (fetch) { // FETCH 1092 1093 e->AssureScalarPar<DStringGDL>(0, varName); 1094 varName = StrUpCase(varName); 1095 int xI = pro->Find(varName); 1096 //cout << xI << " " << varName << " " << pro->Size() << endl; 1097 if (xI != -1) { 1098 // BaseGDL* par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI-nKey); 1099 1100 // Keywords are already counted (in FindVar) 1101 // BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI-nKey); 1102 if (((EnvT*)(callStack[desiredlevnum - 1]))->NParam() < 1) return NULL; //meaning this fetch level is not initialized. Avoids throwing an #assert in debug mode 1103 BaseGDL*& par = ((EnvT*) (callStack[desiredlevnum - 1]))->GetKW(xI); 1104 1105 // not IDL behaviour if (par == NULL) e->Throw("Variable is undefined: " + varName); 1106 if (par == NULL) return NULL; 1107 // char* addr = static_cast<char*>(par->DataAddr()); 1108 1109 // no retnew function BUT: ret value is not from current environment 1110 // which is ok with the new ref return value handling introdcuced with 0.9.4 1111 // note that the _reference version does not need par to be defined and is hence still necessary 1112 e->SetPtrToReturnValue(&par); // <- HERE IS THE DIFFERENCE 1113 return par; // <- HERE IS THE DIFFERENCE 1114 // return par->Dup(); // <- HERE IS THE DIFFERENCE // no retnew function BUT: ret value is not from current environment 1115 } else { 1116 BaseGDL** par = pro->GetCommonVarPtr(varName); 1117 // not IDL behaviour if (par == NULL) e->Throw("Variable is undefined: " + varName); 1118 if (par == NULL) return NULL; 1119 return *par; // <- HERE IS THE DIFFERENCE 1120 } 1121 if (e->Interpreter()->InterruptEnable()) 1122 Message("Variable not found: " + varName); 1123 1124 return NULL; 1125 1126 } else if (arg) { // ARG_NAME 1127 1128 if (nParam == 0) return new DStringGDL(""); 1129 1130 DStringGDL* res = new DStringGDL(dimension(nParam), BaseGDL::NOZERO); 1131 1132 // cout << "nVar:" << nVar << endl; 1133 EnvBaseT* desiredCallStack; 1134 if (desiredlevnum >= callStack.size()) 1135 desiredCallStack = e; 1136 else 1137 desiredCallStack = callStack[ desiredlevnum]; 1138 1139 SizeT nCall = desiredCallStack->NParam(); 1140 1141 // cout << "nCall:" << nCall << "curlevnum:" << curlevnum << endl; 1142 // search for all given parameters of this call 1143 for (SizeT i = 0; i < nParam; ++i) { 1144 1145 // search all parameters of target environment 1146 for (SizeT j = 0; j < nCall; ++j) { 1147 1148 if (e->GetParString(i) == desiredCallStack->GetParString(j)) { 1149 // cout << "Calling param: " << j+1 << endl; 1150 BaseGDL*& p = e->GetPar(i); 1151 if (p == NULL) { 1152 (*res)[i] = "UNDEFINED"; 1153 // break; 1154 } 1155 // cout << "p:" << p << endl; 1156 1157 SizeT xI = 0; 1158 for (; xI < nVar; ++xI) { 1159 string vname = pro->GetVarName(xI); 1160 BaseGDL*& par = ((EnvT*) (callStack[desiredlevnum - 1]))->GetPar(xI - nKey); 1161 // cout << "xI:" << xI << " " << vname.c_str() << endl; 1162 // cout << "par:" << par << endl; 1163 if (&par == &p) { 1164 (*res)[i] = vname; 1165 break; 1166 } 1167 } // xI loop 1168 if (xI == nVar) // not found -> search common 1169 { 1170 string vname; 1171 bool success = pro->GetCommonVarName(p, vname); 1172 if (success) 1173 (*res)[i] = vname; 1174 } 1175 break; 1176 } 1177 } // j loop 1178 } // i loop 1179 1180 return res; 1181 } else { // STORE 1182 1183 if (nParam != 2) 1184 throw GDLException(e->CallingNode(), 1185 "ROUTINE_NAMES: Incorrect number of arguments."); 1186 1187 // "res" points to variables to be restored 1188 BaseGDL* res = e->GetParDefined(1); 1189 1190 SizeT s; 1191 e->AssureScalarPar<DStringGDL>(0, varName); 1192 varName=StrUpCase(varName); 1193 int xI = pro->FindVar(varName); 1194 // cout << "varName: " << varName << " xI: " << xI << endl; 1195 if (xI != -1) { 1196 s = xI; 1197 // cout << "FindVar s: " << s << endl; 1198 } else { 1199 BaseGDL** varPtr = pro->GetCommonVarPtr(varName); 1200 // cout << "FindCommonVar s: " << varPtr << endl; 1201 if (varPtr) { 1202 if (pro->ReplaceExistingCommonVar(varName, res->Dup())) return new DIntGDL(1); 1203 else return new DIntGDL(0); 1204 } else { 1205 SizeT u = pro->AddVar(varName); 1206 s = callStack[desiredlevnum - 1]->AddEnv(); 1207 // cout << "AddVar u: " << u << endl; 1208 // cout << "AddEnv s: " << s << endl; 1209 } 1210 } 1211 // BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( s-nKey); 1212 1213 // ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( s-nKey) = res->Dup(); 1214 ((EnvT*) (callStack[desiredlevnum - 1]))->GetKW(s) = res->Dup(); 1215 1216 // cout << "par: " << &par << endl << endl; 1217 // memcpy(&par, &res, sizeof(par)); 1218 1219 return new DIntGDL(1); 1220 } 1221 } else { 1222 // Get Compiled Procedures & Functions 1223 DLong n = proList.size() + funList.size() + 1; 1224 1225 // Add $MAIN$ to list 1226 vector<DString> pfList; 1227 pfList.push_back("$MAIN$"); 1228 1229 // Procedures 1230 for (ProListT::iterator i = proList.begin(); i != proList.end(); ++i) { 1231 pfList.push_back((*i)->ObjectName()); 1232 } 1233 1234 // Functions 1235 for (FunListT::iterator i = funList.begin(); i != funList.end(); ++i) { 1236 pfList.push_back((*i)->ObjectName()); 1237 } 1238 1239 // Sort 1240 sort(pfList.begin(), pfList.end()); 1241 1242 // Fill return variable 1243 dimension dim(&n, (size_t) 1); 1244 DStringGDL* res = new DStringGDL(dim, BaseGDL::NOZERO); 1245 for (SizeT i = 0; i < n; ++i) { 1246 (*res)[i] = pfList[ i]; 1247 } 1248 return res; 1249 } 1250 } 1251 1252 // this version does not need the return value pointing to a defined value and is hence necessary 1253 routine_names_reference(EnvT * e)1254 BaseGDL** routine_names_reference(EnvT* e) { 1255 SizeT nParam = e->NParam(); 1256 1257 EnvStackT& callStack = e->Interpreter()->CallStack(); 1258 DLong curlevnum = callStack.size(); 1259 static int sfunctionsIx=e->KeywordIx("S_FUNCTIONS"); 1260 static int sproceduresIx=e->KeywordIx("S_PROCEDURES"); 1261 static int levelIx=e->KeywordIx("LEVEL"); 1262 if (e->KeywordSet(sfunctionsIx)) { 1263 return NULL; 1264 } 1265 1266 if (e->KeywordSet(sproceduresIx)) { 1267 return NULL; 1268 } 1269 1270 if (e->KeywordSet(levelIx)) { 1271 return NULL; 1272 } 1273 1274 static int variablesIx = e->KeywordIx("VARIABLES"); 1275 static int fetchIx = e->KeywordIx("FETCH"); 1276 static int arg_namesIx = e->KeywordIx("ARG_NAME"); 1277 static int storeIx = e->KeywordIx("STORE"); 1278 bool var = false, fetch = false, arg = false, store = false; 1279 var=e->KeywordPresent(variablesIx); 1280 arg=e->KeywordPresent(arg_namesIx); 1281 store=e->KeywordPresent(storeIx); 1282 fetch=e->KeywordPresent(fetchIx); 1283 if (fetch && nParam < 1) e->Throw("Incorrect number of arguments."); 1284 if ( var + fetch + store + arg > 1 ) e->Throw("Incorrect number of arguments."); 1285 DLongGDL* level; 1286 level = e->IfDefGetKWAs<DLongGDL>(variablesIx); 1287 if (level != NULL) { 1288 var = true; 1289 } else { 1290 level = e->IfDefGetKWAs<DLongGDL>(fetchIx); 1291 if (level != NULL) { 1292 fetch = true; 1293 } else { 1294 level = e->IfDefGetKWAs<DLongGDL>(arg_namesIx); 1295 if (level != NULL) { 1296 arg = true; 1297 } else { 1298 level = e->IfDefGetKWAs<DLongGDL>(storeIx); 1299 if (level != NULL) { 1300 store = true; 1301 } 1302 } 1303 } 1304 } 1305 1306 DString varName; 1307 1308 if (level != NULL) { 1309 DLong desiredlevnum = (*level)[0]; 1310 if (desiredlevnum <= 0) desiredlevnum += curlevnum; 1311 if (desiredlevnum < 1) return NULL; 1312 if (desiredlevnum > curlevnum) desiredlevnum = curlevnum; 1313 1314 DSubUD* pro = static_cast<DSubUD*> (callStack[desiredlevnum - 1]->GetPro()); 1315 1316 SizeT nVar = pro->Size(); // # var in GDL for desired level 1317 SizeT nComm = pro->CommonsSize(); // # has commons? 1318 SizeT nTotVar = nVar + nComm; //All the variables availables at that lev. 1319 1320 int nKey = pro->NKey(); 1321 //cout << "nKey:" << nKey << endl; 1322 //cout << "nVar:" << nVar << endl; 1323 //cout << pro->Name() << endl; 1324 1325 if (fetch) { // FETCH 1326 1327 e->AssureScalarPar<DStringGDL>(0, varName); 1328 varName = StrUpCase(varName); 1329 int xI = pro->FindVar(varName); 1330 // cout << xI << endl; 1331 if (xI != -1) { 1332 // BaseGDL*& par = ((EnvT*)(callStack[desiredlevnum-1]))->GetPar( xI-nKey); 1333 BaseGDL*& par = ((EnvT*) (callStack[desiredlevnum - 1]))->GetKW(xI); 1334 if (par == NULL) return NULL; 1335 return ∥ // <- HERE IS THE DIFFERENCE 1336 } else { 1337 BaseGDL** par = pro->GetCommonVarPtr(varName); 1338 // not IDL behaviour if (par == NULL) e->Throw("Variable is undefined: " + varName); 1339 if (par == NULL) return NULL; 1340 return par; // <- HERE IS THE DIFFERENCE 1341 } 1342 1343 e->Throw("Variable not found: " + varName); 1344 return NULL; 1345 1346 } else if (var) { // ARG_NAME 1347 1348 return NULL; 1349 1350 } else if (arg) { // ARG_NAME 1351 1352 return NULL; 1353 1354 } 1355 else { // STORE 1356 1357 return NULL; 1358 } 1359 } 1360 else { 1361 // Get Compiled Procedures & Functions 1362 return NULL; 1363 } 1364 } 1365 1366 1367 1368 } // namespace 1369 1370