1 /*******************************************************/
2 /* "C" Language Integrated Production System */
3 /* */
4 /* CLIPS Version 6.39 01/29/15 */
5 /* */
6 /* MISCELLANEOUS FUNCTIONS MODULE */
7 /*******************************************************/
8
9 /*************************************************************/
10 /* Purpose: */
11 /* */
12 /* Principal Programmer(s): */
13 /* Gary D. Riley */
14 /* */
15 /* Contributing Programmer(s): */
16 /* Brian L. Dantes */
17 /* */
18 /* Revision History: */
19 /* */
20 /* 6.23: Correction for FalseSymbol/TrueSymbol. DR0859 */
21 /* */
22 /* Corrected compilation errors for files */
23 /* generated by constructs-to-c. DR0861 */
24 /* */
25 /* Changed name of variable exp to theExp */
26 /* because of Unix compiler warnings of shadowed */
27 /* definitions. */
28 /* */
29 /* 6.24: Removed CONFLICT_RESOLUTION_STRATEGIES, */
30 /* DYNAMIC_SALIENCE, INCREMENTAL_RESET, */
31 /* LOGICAL_DEPENDENCIES, IMPERATIVE_METHODS */
32 /* INSTANCE_PATTERN_MATCHING, */
33 /* IMPERATIVE_MESSAGE_HANDLERS, and */
34 /* AUXILIARY_MESSAGE_HANDLERS compilation flags. */
35 /* */
36 /* Renamed BOOLEAN macro type to intBool. */
37 /* */
38 /* 6.30: Support for long long integers. */
39 /* */
40 /* Used gensprintf instead of sprintf. */
41 /* */
42 /* Removed conditional code for unsupported */
43 /* compilers/operating systems. */
44 /* */
45 /* Renamed EX_MATH compiler flag to */
46 /* EXTENDED_MATH_FUNCTIONS. */
47 /* */
48 /* Combined BASIC_IO and EXT_IO compilation */
49 /* flags into the IO_FUNCTIONS compilation flag. */
50 /* */
51 /* Removed code associated with HELP_FUNCTIONS */
52 /* and EMACS_EDITOR compiler flags. */
53 /* */
54 /* Added operating-system function. */
55 /* */
56 /* Added new function (for future use). */
57 /* */
58 /* Added const qualifiers to remove C++ */
59 /* deprecation warnings. */
60 /* */
61 /* Removed deallocating message parameter from */
62 /* EnvReleaseMem. */
63 /* */
64 /* Removed support for BLOCK_MEMORY. */
65 /* */
66 /*************************************************************/
67
68 #define _MISCFUN_SOURCE_
69
70 #include <stdio.h>
71 #define _STDIO_INCLUDED_
72 #include <string.h>
73
74 #include "setup.h"
75
76 #include "argacces.h"
77 #include "envrnmnt.h"
78 #include "exprnpsr.h"
79 #include "memalloc.h"
80 #include "multifld.h"
81 #include "router.h"
82 #include "sysdep.h"
83 #include "utility.h"
84
85 #if DEFFUNCTION_CONSTRUCT
86 #include "dffnxfun.h"
87 #endif
88
89 #include "miscfun.h"
90
91 #define MISCFUN_DATA 9
92
93 struct miscFunctionData
94 {
95 long long GensymNumber;
96 };
97
98 #define MiscFunctionData(theEnv) ((struct miscFunctionData *) GetEnvironmentData(theEnv,MISCFUN_DATA))
99
100 /***************************************/
101 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
102 /***************************************/
103
104 static void ExpandFuncMultifield(void *,DATA_OBJECT *,EXPRESSION *,
105 EXPRESSION **,void *);
106 static int FindLanguageType(void *,const char *);
107
108 /*****************************************************************/
109 /* MiscFunctionDefinitions: Initializes miscellaneous functions. */
110 /*****************************************************************/
MiscFunctionDefinitions(void * theEnv)111 globle void MiscFunctionDefinitions(
112 void *theEnv)
113 {
114 AllocateEnvironmentData(theEnv,MISCFUN_DATA,sizeof(struct miscFunctionData),NULL);
115 MiscFunctionData(theEnv)->GensymNumber = 1;
116
117 #if ! RUN_TIME
118 EnvDefineFunction2(theEnv,"gensym", 'w', PTIEF GensymFunction, "GensymFunction", "00");
119 EnvDefineFunction2(theEnv,"gensym*", 'w', PTIEF GensymStarFunction, "GensymStarFunction", "00");
120 EnvDefineFunction2(theEnv,"setgen", 'g', PTIEF SetgenFunction, "SetgenFunction", "11i");
121 EnvDefineFunction2(theEnv,"system", 'v', PTIEF gensystem, "gensystem", "1*k");
122 EnvDefineFunction2(theEnv,"length", 'g', PTIEF LengthFunction, "LengthFunction", "11q");
123 EnvDefineFunction2(theEnv,"length$", 'g', PTIEF LengthFunction, "LengthFunction", "11q");
124 EnvDefineFunction2(theEnv,"time", 'd', PTIEF TimeFunction, "TimeFunction", "00");
125 EnvDefineFunction2(theEnv,"random", 'g', PTIEF RandomFunction, "RandomFunction", "02i");
126 EnvDefineFunction2(theEnv,"seed", 'v', PTIEF SeedFunction, "SeedFunction", "11i");
127 EnvDefineFunction2(theEnv,"conserve-mem", 'v', PTIEF ConserveMemCommand, "ConserveMemCommand", "11w");
128 EnvDefineFunction2(theEnv,"release-mem", 'g', PTIEF ReleaseMemCommand, "ReleaseMemCommand", "00");
129 #if DEBUGGING_FUNCTIONS
130 EnvDefineFunction2(theEnv,"mem-used", 'g', PTIEF MemUsedCommand, "MemUsedCommand", "00");
131 EnvDefineFunction2(theEnv,"mem-requests", 'g', PTIEF MemRequestsCommand, "MemRequestsCommand", "00");
132 #endif
133 EnvDefineFunction2(theEnv,"options", 'v', PTIEF OptionsCommand, "OptionsCommand", "00");
134 EnvDefineFunction2(theEnv,"operating-system", 'w', PTIEF OperatingSystemFunction,"OperatingSystemFunction", "00");
135 EnvDefineFunction2(theEnv,"(expansion-call)", 'u', PTIEF ExpandFuncCall, "ExpandFuncCall",NULL);
136 EnvDefineFunction2(theEnv,"expand$",'u', PTIEF DummyExpandFuncMultifield,
137 "DummyExpandFuncMultifield","11m");
138 FuncSeqOvlFlags(theEnv,"expand$",FALSE,FALSE);
139 EnvDefineFunction2(theEnv,"(set-evaluation-error)",
140 'w', PTIEF CauseEvaluationError,"CauseEvaluationError",NULL);
141 EnvDefineFunction2(theEnv,"set-sequence-operator-recognition",
142 'b', PTIEF SetSORCommand,"SetSORCommand","11w");
143 EnvDefineFunction2(theEnv,"get-sequence-operator-recognition",'b',
144 PTIEF EnvGetSequenceOperatorRecognition,"EnvGetSequenceOperatorRecognition","00");
145 EnvDefineFunction2(theEnv,"get-function-restrictions",'s',
146 PTIEF GetFunctionRestrictions,"GetFunctionRestrictions","11w");
147 EnvDefineFunction2(theEnv,"create$", 'm', PTIEF CreateFunction, "CreateFunction", NULL);
148 EnvDefineFunction2(theEnv,"mv-append", 'm', PTIEF CreateFunction, "CreateFunction", NULL);
149 EnvDefineFunction2(theEnv,"apropos", 'v', PTIEF AproposCommand, "AproposCommand", "11w");
150 EnvDefineFunction2(theEnv,"get-function-list", 'm', PTIEF GetFunctionListFunction, "GetFunctionListFunction", "00");
151 EnvDefineFunction2(theEnv,"funcall",'u', PTIEF FuncallFunction,"FuncallFunction","1**k");
152 EnvDefineFunction2(theEnv,"new",'u', PTIEF NewFunction,"NewFunction","1*uw");
153 EnvDefineFunction2(theEnv,"call",'u', PTIEF CallFunction,"CallFunction","1*u");
154 EnvDefineFunction2(theEnv,"timer",'d', PTIEF TimerFunction,"TimerFunction","**");
155 #endif
156 }
157
158 /******************************************************************/
159 /* CreateFunction: H/L access routine for the create$ function. */
160 /******************************************************************/
CreateFunction(void * theEnv,DATA_OBJECT_PTR returnValue)161 globle void CreateFunction(
162 void *theEnv,
163 DATA_OBJECT_PTR returnValue)
164 {
165 StoreInMultifield(theEnv,returnValue,GetFirstArgument(),TRUE);
166 }
167
168 /*****************************************************************/
169 /* SetgenFunction: H/L access routine for the setgen function. */
170 /*****************************************************************/
SetgenFunction(void * theEnv)171 globle long long SetgenFunction(
172 void *theEnv)
173 {
174 long long theLong;
175 DATA_OBJECT theValue;
176
177 /*==========================================================*/
178 /* Check to see that a single integer argument is provided. */
179 /*==========================================================*/
180
181 if (EnvArgCountCheck(theEnv,"setgen",EXACTLY,1) == -1) return(MiscFunctionData(theEnv)->GensymNumber);
182 if (EnvArgTypeCheck(theEnv,"setgen",1,INTEGER,&theValue) == FALSE) return(MiscFunctionData(theEnv)->GensymNumber);
183
184 /*========================================*/
185 /* The integer must be greater than zero. */
186 /*========================================*/
187
188 theLong = ValueToLong(theValue.value);
189
190 if (theLong < 1LL)
191 {
192 ExpectedTypeError1(theEnv,"setgen",1,"number (greater than or equal to 1)");
193 return(MiscFunctionData(theEnv)->GensymNumber);
194 }
195
196 /*====================================*/
197 /* Set the gensym index to the number */
198 /* provided and return this value. */
199 /*====================================*/
200
201 MiscFunctionData(theEnv)->GensymNumber = theLong;
202 return(theLong);
203 }
204
205 /****************************************/
206 /* GensymFunction: H/L access routine */
207 /* for the gensym function. */
208 /****************************************/
GensymFunction(void * theEnv)209 globle void *GensymFunction(
210 void *theEnv)
211 {
212 char genstring[128];
213
214 /*===========================================*/
215 /* The gensym function accepts no arguments. */
216 /*===========================================*/
217
218 EnvArgCountCheck(theEnv,"gensym",EXACTLY,0);
219
220 /*================================================*/
221 /* Create a symbol using the current gensym index */
222 /* as the postfix. */
223 /*================================================*/
224
225 gensprintf(genstring,"gen%lld",MiscFunctionData(theEnv)->GensymNumber);
226 MiscFunctionData(theEnv)->GensymNumber++;
227
228 /*====================*/
229 /* Return the symbol. */
230 /*====================*/
231
232 return(EnvAddSymbol(theEnv,genstring));
233 }
234
235 /************************************************/
236 /* GensymStarFunction: H/L access routine for */
237 /* the gensym* function. */
238 /************************************************/
GensymStarFunction(void * theEnv)239 globle void *GensymStarFunction(
240 void *theEnv)
241 {
242 /*============================================*/
243 /* The gensym* function accepts no arguments. */
244 /*============================================*/
245
246 EnvArgCountCheck(theEnv,"gensym*",EXACTLY,0);
247
248 /*====================*/
249 /* Return the symbol. */
250 /*====================*/
251
252 return(GensymStar(theEnv));
253 }
254
255 /************************************/
256 /* GensymStar: C access routine for */
257 /* the gensym* function. */
258 /************************************/
GensymStar(void * theEnv)259 globle void *GensymStar(
260 void *theEnv)
261 {
262 char genstring[128];
263
264 /*=======================================================*/
265 /* Create a symbol using the current gensym index as the */
266 /* postfix. If the symbol is already present in the */
267 /* symbol table, then continue generating symbols until */
268 /* a unique symbol is found. */
269 /*=======================================================*/
270
271 do
272 {
273 gensprintf(genstring,"gen%lld",MiscFunctionData(theEnv)->GensymNumber);
274 MiscFunctionData(theEnv)->GensymNumber++;
275 }
276 while (FindSymbolHN(theEnv,genstring) != NULL);
277
278 /*====================*/
279 /* Return the symbol. */
280 /*====================*/
281
282 return(EnvAddSymbol(theEnv,genstring));
283 }
284
285 /********************************************/
286 /* RandomFunction: H/L access routine for */
287 /* the random function. */
288 /********************************************/
RandomFunction(void * theEnv)289 globle long long RandomFunction(
290 void *theEnv)
291 {
292 int argCount;
293 long long rv;
294 DATA_OBJECT theValue;
295 long long begin, end;
296
297 /*====================================*/
298 /* The random function accepts either */
299 /* zero or two arguments. */
300 /*====================================*/
301
302 argCount = EnvRtnArgCount(theEnv);
303
304 if ((argCount != 0) && (argCount != 2))
305 {
306 PrintErrorID(theEnv,"MISCFUN",2,FALSE);
307 EnvPrintRouter(theEnv,WERROR,"Function random expected either 0 or 2 arguments\n");
308 }
309
310 /*========================================*/
311 /* Return the randomly generated integer. */
312 /*========================================*/
313
314 rv = genrand();
315
316 if (argCount == 2)
317 {
318 if (EnvArgTypeCheck(theEnv,"random",1,INTEGER,&theValue) == FALSE) return(rv);
319 begin = DOToLong(theValue);
320 if (EnvArgTypeCheck(theEnv,"random",2,INTEGER,&theValue) == FALSE) return(rv);
321 end = DOToLong(theValue);
322 if (end < begin)
323 {
324 PrintErrorID(theEnv,"MISCFUN",3,FALSE);
325 EnvPrintRouter(theEnv,WERROR,"Function random expected argument #1 to be less than argument #2\n");
326 return(rv);
327 }
328
329 rv = begin + (rv % ((end - begin) + 1));
330 }
331
332
333 return(rv);
334 }
335
336 /******************************************/
337 /* SeedFunction: H/L access routine for */
338 /* the seed function. */
339 /******************************************/
SeedFunction(void * theEnv)340 globle void SeedFunction(
341 void *theEnv)
342 {
343 DATA_OBJECT theValue;
344
345 /*==========================================================*/
346 /* Check to see that a single integer argument is provided. */
347 /*==========================================================*/
348
349 if (EnvArgCountCheck(theEnv,"seed",EXACTLY,1) == -1) return;
350 if (EnvArgTypeCheck(theEnv,"seed",1,INTEGER,&theValue) == FALSE) return;
351
352 /*=============================================================*/
353 /* Seed the random number generator with the provided integer. */
354 /*=============================================================*/
355
356 genseed((int) DOToLong(theValue));
357 }
358
359 /********************************************/
360 /* LengthFunction: H/L access routine for */
361 /* the length$ function. */
362 /********************************************/
LengthFunction(void * theEnv)363 globle long long LengthFunction(
364 void *theEnv)
365 {
366 DATA_OBJECT item;
367
368 /*====================================================*/
369 /* The length$ function expects exactly one argument. */
370 /*====================================================*/
371
372 if (EnvArgCountCheck(theEnv,"length$",EXACTLY,1) == -1) return(-1L);
373 EnvRtnUnknown(theEnv,1,&item);
374
375 /*====================================================*/
376 /* If the argument is a string or symbol, then return */
377 /* the number of characters in the argument. */
378 /*====================================================*/
379
380 if ((GetType(item) == STRING) || (GetType(item) == SYMBOL))
381 { return( (long) strlen(DOToString(item))); }
382
383 /*====================================================*/
384 /* If the argument is a multifield value, then return */
385 /* the number of fields in the argument. */
386 /*====================================================*/
387
388 if (GetType(item) == MULTIFIELD)
389 { return ( (long) GetDOLength(item)); }
390
391 /*=============================================*/
392 /* If the argument wasn't a string, symbol, or */
393 /* multifield value, then generate an error. */
394 /*=============================================*/
395
396 SetEvaluationError(theEnv,TRUE);
397 ExpectedTypeError2(theEnv,"length$",1);
398 return(-1L);
399 }
400
401 /*******************************************/
402 /* ReleaseMemCommand: H/L access routine */
403 /* for the release-mem function. */
404 /*******************************************/
ReleaseMemCommand(void * theEnv)405 globle long long ReleaseMemCommand(
406 void *theEnv)
407 {
408 /*================================================*/
409 /* The release-mem function accepts no arguments. */
410 /*================================================*/
411
412 if (EnvArgCountCheck(theEnv,"release-mem",EXACTLY,0) == -1) return(0LL);
413
414 /*========================================*/
415 /* Release memory to the operating system */
416 /* and return the amount of memory freed. */
417 /*========================================*/
418
419 return(EnvReleaseMem(theEnv,-1L));
420 }
421
422 /******************************************/
423 /* ConserveMemCommand: H/L access routine */
424 /* for the conserve-mem command. */
425 /******************************************/
ConserveMemCommand(void * theEnv)426 globle void ConserveMemCommand(
427 void *theEnv)
428 {
429 const char *argument;
430 DATA_OBJECT theValue;
431
432 /*===================================*/
433 /* The conserve-mem function expects */
434 /* a single symbol argument. */
435 /*===================================*/
436
437 if (EnvArgCountCheck(theEnv,"conserve-mem",EXACTLY,1) == -1) return;
438 if (EnvArgTypeCheck(theEnv,"conserve-mem",1,SYMBOL,&theValue) == FALSE) return;
439
440 argument = DOToString(theValue);
441
442 /*====================================================*/
443 /* If the argument is the symbol "on", then store the */
444 /* pretty print representation of a construct when it */
445 /* is defined. */
446 /*====================================================*/
447
448 if (strcmp(argument,"on") == 0)
449 { EnvSetConserveMemory(theEnv,TRUE); }
450
451 /*======================================================*/
452 /* Otherwise, if the argument is the symbol "off", then */
453 /* don't store the pretty print representation of a */
454 /* construct when it is defined. */
455 /*======================================================*/
456
457 else if (strcmp(argument,"off") == 0)
458 { EnvSetConserveMemory(theEnv,FALSE); }
459
460 /*=====================================================*/
461 /* Otherwise, generate an error since the only allowed */
462 /* arguments are "on" or "off." */
463 /*=====================================================*/
464
465 else
466 {
467 ExpectedTypeError1(theEnv,"conserve-mem",1,"symbol with value on or off");
468 return;
469 }
470
471 return;
472 }
473
474 #if DEBUGGING_FUNCTIONS
475
476 /****************************************/
477 /* MemUsedCommand: H/L access routine */
478 /* for the mem-used command. */
479 /****************************************/
MemUsedCommand(void * theEnv)480 globle long long MemUsedCommand(
481 void *theEnv)
482 {
483 /*=============================================*/
484 /* The mem-used function accepts no arguments. */
485 /*=============================================*/
486
487 if (EnvArgCountCheck(theEnv,"mem-used",EXACTLY,0) == -1) return(0);
488
489 /*============================================*/
490 /* Return the amount of memory currently held */
491 /* (both for current use and for later use). */
492 /*============================================*/
493
494 return(EnvMemUsed(theEnv));
495 }
496
497 /********************************************/
498 /* MemRequestsCommand: H/L access routine */
499 /* for the mem-requests command. */
500 /********************************************/
MemRequestsCommand(void * theEnv)501 globle long long MemRequestsCommand(
502 void *theEnv)
503 {
504 /*=================================================*/
505 /* The mem-requests function accepts no arguments. */
506 /*=================================================*/
507
508 if (EnvArgCountCheck(theEnv,"mem-requests",EXACTLY,0) == -1) return(0);
509
510 /*==================================*/
511 /* Return the number of outstanding */
512 /* memory requests. */
513 /*==================================*/
514
515 return(EnvMemRequests(theEnv));
516 }
517
518 #endif
519
520 /****************************************/
521 /* AproposCommand: H/L access routine */
522 /* for the apropos command. */
523 /****************************************/
AproposCommand(void * theEnv)524 globle void AproposCommand(
525 void *theEnv)
526 {
527 const char *argument;
528 DATA_OBJECT argPtr;
529 struct symbolHashNode *hashPtr = NULL;
530 size_t theLength;
531
532 /*=======================================================*/
533 /* The apropos command expects a single symbol argument. */
534 /*=======================================================*/
535
536 if (EnvArgCountCheck(theEnv,"apropos",EXACTLY,1) == -1) return;
537 if (EnvArgTypeCheck(theEnv,"apropos",1,SYMBOL,&argPtr) == FALSE) return;
538
539 /*=======================================*/
540 /* Determine the length of the argument. */
541 /*=======================================*/
542
543 argument = DOToString(argPtr);
544 theLength = strlen(argument);
545
546 /*====================================================================*/
547 /* Print each entry in the symbol table that contains the argument as */
548 /* a substring. When using a non-ANSI compiler, only those strings */
549 /* that contain the substring starting at the beginning of the string */
550 /* are printed. */
551 /*====================================================================*/
552
553 while ((hashPtr = GetNextSymbolMatch(theEnv,argument,theLength,hashPtr,TRUE,NULL)) != NULL)
554 {
555 EnvPrintRouter(theEnv,WDISPLAY,ValueToString(hashPtr));
556 EnvPrintRouter(theEnv,WDISPLAY,"\n");
557 }
558 }
559
560 /****************************************/
561 /* OptionsCommand: H/L access routine */
562 /* for the options command. */
563 /****************************************/
OptionsCommand(void * theEnv)564 globle void OptionsCommand(
565 void *theEnv)
566 {
567 /*===========================================*/
568 /* The options command accepts no arguments. */
569 /*===========================================*/
570
571 if (EnvArgCountCheck(theEnv,"options",EXACTLY,0) == -1) return;
572
573 /*=================================*/
574 /* Print the state of the compiler */
575 /* flags for this executable. */
576 /*=================================*/
577
578 EnvPrintRouter(theEnv,WDISPLAY,"Machine type: ");
579
580 #if GENERIC
581 EnvPrintRouter(theEnv,WDISPLAY,"Generic ");
582 #endif
583 #if VAX_VMS
584 EnvPrintRouter(theEnv,WDISPLAY,"VAX VMS ");
585 #endif
586 #if UNIX_V
587 EnvPrintRouter(theEnv,WDISPLAY,"UNIX System V or 4.2BSD ");
588 #endif
589 #if DARWIN
590 EnvPrintRouter(theEnv,WDISPLAY,"Darwin ");
591 #endif
592 #if LINUX
593 EnvPrintRouter(theEnv,WDISPLAY,"Linux ");
594 #endif
595 #if UNIX_7
596 EnvPrintRouter(theEnv,WDISPLAY,"UNIX System III Version 7 or Sun Unix ");
597 #endif
598 #if MAC_XCD
599 EnvPrintRouter(theEnv,WDISPLAY,"Apple Macintosh with Xcode");
600 #endif
601 #if WIN_MVC
602 EnvPrintRouter(theEnv,WDISPLAY,"Microsoft Windows with Microsoft Visual C++");
603 #endif
604 #if WIN_GCC
605 EnvPrintRouter(theEnv,WDISPLAY,"Microsoft Windows with DJGPP");
606 #endif
607 EnvPrintRouter(theEnv,WDISPLAY,"\n");
608
609 EnvPrintRouter(theEnv,WDISPLAY,"Defrule construct is ");
610 #if DEFRULE_CONSTRUCT
611 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
612 #else
613 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
614 #endif
615
616 EnvPrintRouter(theEnv,WDISPLAY,"Defmodule construct is ");
617 #if DEFMODULE_CONSTRUCT
618 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
619 #else
620 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
621 #endif
622
623 EnvPrintRouter(theEnv,WDISPLAY,"Deftemplate construct is ");
624 #if DEFTEMPLATE_CONSTRUCT
625 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
626 #else
627 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
628 #endif
629
630 EnvPrintRouter(theEnv,WDISPLAY," Fact-set queries are ");
631 #if FACT_SET_QUERIES
632 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
633 #else
634 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
635 #endif
636
637 #if DEFTEMPLATE_CONSTRUCT
638
639 EnvPrintRouter(theEnv,WDISPLAY," Deffacts construct is ");
640 #if DEFFACTS_CONSTRUCT
641 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
642 #else
643 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
644 #endif
645
646 #endif
647
648 EnvPrintRouter(theEnv,WDISPLAY,"Defglobal construct is ");
649 #if DEFGLOBAL_CONSTRUCT
650 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
651 #else
652 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
653 #endif
654
655 EnvPrintRouter(theEnv,WDISPLAY,"Deffunction construct is ");
656 #if DEFFUNCTION_CONSTRUCT
657 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
658 #else
659 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
660 #endif
661
662 EnvPrintRouter(theEnv,WDISPLAY,"Defgeneric/Defmethod constructs are ");
663 #if DEFGENERIC_CONSTRUCT
664 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
665 #else
666 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
667 #endif
668
669 EnvPrintRouter(theEnv,WDISPLAY,"Object System is ");
670 #if OBJECT_SYSTEM
671 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
672 #else
673 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
674 #endif
675
676 #if OBJECT_SYSTEM
677
678 EnvPrintRouter(theEnv,WDISPLAY," Definstances construct is ");
679 #if DEFINSTANCES_CONSTRUCT
680 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
681 #else
682 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
683 #endif
684
685 EnvPrintRouter(theEnv,WDISPLAY," Instance-set queries are ");
686 #if INSTANCE_SET_QUERIES
687 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
688 #else
689 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
690 #endif
691
692 EnvPrintRouter(theEnv,WDISPLAY," Binary loading of instances is ");
693 #if BLOAD_INSTANCES
694 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
695 #else
696 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
697 #endif
698
699 EnvPrintRouter(theEnv,WDISPLAY," Binary saving of instances is ");
700 #if BSAVE_INSTANCES
701 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
702 #else
703 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
704 #endif
705
706 #endif
707
708 EnvPrintRouter(theEnv,WDISPLAY,"Extended math function package is ");
709 #if EXTENDED_MATH_FUNCTIONS
710 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
711 #else
712 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
713 #endif
714
715 EnvPrintRouter(theEnv,WDISPLAY,"Text processing function package is ");
716 #if TEXTPRO_FUNCTIONS
717 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
718 #else
719 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
720 #endif
721
722 EnvPrintRouter(theEnv,WDISPLAY,"Bload capability is ");
723 #if BLOAD_ONLY
724 EnvPrintRouter(theEnv,WDISPLAY,"BLOAD ONLY");
725 #endif
726 #if BLOAD
727 EnvPrintRouter(theEnv,WDISPLAY,"BLOAD");
728 #endif
729 #if BLOAD_AND_BSAVE
730 EnvPrintRouter(theEnv,WDISPLAY,"BLOAD AND BSAVE");
731 #endif
732 #if (! BLOAD_ONLY) && (! BLOAD) && (! BLOAD_AND_BSAVE)
733 EnvPrintRouter(theEnv,WDISPLAY,"OFF ");
734 #endif
735 EnvPrintRouter(theEnv,WDISPLAY,"\n");
736
737 EnvPrintRouter(theEnv,WDISPLAY,"Construct compiler is ");
738 #if CONSTRUCT_COMPILER
739 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
740 #else
741 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
742 #endif
743
744 EnvPrintRouter(theEnv,WDISPLAY,"I/O function package is ");
745 #if IO_FUNCTIONS
746 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
747 #else
748 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
749 #endif
750
751 EnvPrintRouter(theEnv,WDISPLAY,"String function package is ");
752 #if STRING_FUNCTIONS
753 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
754 #else
755 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
756 #endif
757
758 EnvPrintRouter(theEnv,WDISPLAY,"Multifield function package is ");
759 #if MULTIFIELD_FUNCTIONS
760 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
761 #else
762 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
763 #endif
764
765 EnvPrintRouter(theEnv,WDISPLAY,"Debugging function package is ");
766 #if DEBUGGING_FUNCTIONS
767 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
768 #else
769 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
770 #endif
771
772 EnvPrintRouter(theEnv,WDISPLAY,"Window Interface flag is ");
773 #if WINDOW_INTERFACE
774 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
775 #else
776 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
777 #endif
778
779 EnvPrintRouter(theEnv,WDISPLAY,"Developer flag is ");
780 #if DEVELOPER
781 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
782 #else
783 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
784 #endif
785
786 EnvPrintRouter(theEnv,WDISPLAY,"Run time module is ");
787 #if RUN_TIME
788 EnvPrintRouter(theEnv,WDISPLAY,"ON\n");
789 #else
790 EnvPrintRouter(theEnv,WDISPLAY,"OFF\n");
791 #endif
792 }
793
794 /***********************************************/
795 /* OperatingSystemFunction: H/L access routine */
796 /* for the operating system function. */
797 /***********************************************/
OperatingSystemFunction(void * theEnv)798 globle void *OperatingSystemFunction(
799 void *theEnv)
800 {
801 EnvArgCountCheck(theEnv,"operating-system",EXACTLY,0);
802
803 #if GENERIC
804 return(EnvAddSymbol(theEnv,"UNKNOWN"));
805 #endif
806
807 #if VAX_VMS
808 return(EnvAddSymbol(theEnv,"VMS"));
809 #endif
810
811 #if UNIX_V
812 return(EnvAddSymbol(theEnv,"UNIX-V"));
813 #endif
814
815 #if UNIX_7
816 return(EnvAddSymbol(theEnv,"UNIX-7"));
817 #endif
818
819 #if LINUX
820 return(EnvAddSymbol(theEnv,"LINUX"));
821 #endif
822
823 #if DARWIN
824 return(EnvAddSymbol(theEnv,"DARWIN"));
825 #endif
826
827 #if MAC_XCD
828 return(EnvAddSymbol(theEnv,"MAC-OS-X"));
829 #endif
830
831 #if IBM && (! WINDOW_INTERFACE)
832 return(EnvAddSymbol(theEnv,"DOS"));
833 #endif
834
835 #if IBM && WINDOW_INTERFACE
836 return(EnvAddSymbol(theEnv,"WINDOWS"));
837 #endif
838
839 return(EnvAddSymbol(theEnv,"UNKNOWN"));
840 }
841
842 /********************************************************************
843 NAME : ExpandFuncCall
844 DESCRIPTION : This function is a wrap-around for a normal
845 function call. It preexamines the argument
846 expression list and expands any references to the
847 sequence operator. It builds a copy of the
848 function call expression with these new arguments
849 inserted and evaluates the function call.
850 INPUTS : A data object buffer
851 RETURNS : Nothing useful
852 SIDE EFFECTS : Expressions alloctaed/deallocated
853 Function called and arguments evaluated
854 EvaluationError set on errors
855 NOTES : None
856 *******************************************************************/
ExpandFuncCall(void * theEnv,DATA_OBJECT * result)857 globle void ExpandFuncCall(
858 void *theEnv,
859 DATA_OBJECT *result)
860 {
861 EXPRESSION *newargexp,*fcallexp;
862 struct FunctionDefinition *func;
863
864 /* ======================================================================
865 Copy the original function call's argument expression list.
866 Look for expand$ function callsexpressions and replace those
867 with the equivalent expressions of the expansions of evaluations
868 of the arguments.
869 ====================================================================== */
870 newargexp = CopyExpression(theEnv,GetFirstArgument()->argList);
871 ExpandFuncMultifield(theEnv,result,newargexp,&newargexp,
872 (void *) FindFunction(theEnv,"expand$"));
873
874 /* ===================================================================
875 Build the new function call expression with the expanded arguments.
876 Check the number of arguments, if necessary, and call the thing.
877 =================================================================== */
878 fcallexp = get_struct(theEnv,expr);
879 fcallexp->type = GetFirstArgument()->type;
880 fcallexp->value = GetFirstArgument()->value;
881 fcallexp->nextArg = NULL;
882 fcallexp->argList = newargexp;
883 if (fcallexp->type == FCALL)
884 {
885 func = (struct FunctionDefinition *) fcallexp->value;
886 if (CheckFunctionArgCount(theEnv,ValueToString(func->callFunctionName),
887 func->restrictions,CountArguments(newargexp)) == FALSE)
888 {
889 result->type = SYMBOL;
890 result->value = EnvFalseSymbol(theEnv);
891 ReturnExpression(theEnv,fcallexp);
892 return;
893 }
894 }
895 #if DEFFUNCTION_CONSTRUCT
896 else if (fcallexp->type == PCALL)
897 {
898 if (CheckDeffunctionCall(theEnv,fcallexp->value,
899 CountArguments(fcallexp->argList)) == FALSE)
900 {
901 result->type = SYMBOL;
902 result->value = EnvFalseSymbol(theEnv);
903 ReturnExpression(theEnv,fcallexp);
904 SetEvaluationError(theEnv,TRUE);
905 return;
906 }
907 }
908 #endif
909
910 EvaluateExpression(theEnv,fcallexp,result);
911 ReturnExpression(theEnv,fcallexp);
912 }
913
914 /***********************************************************************
915 NAME : DummyExpandFuncMultifield
916 DESCRIPTION : The expansion of multifield arguments is valid only
917 when done for a function call. All these expansions
918 are handled by the H/L wrap-around function
919 (expansion-call) - see ExpandFuncCall. If the H/L
920 function, epand-multifield is ever called directly,
921 it is an error.
922 INPUTS : Data object buffer
923 RETURNS : Nothing useful
924 SIDE EFFECTS : EvaluationError set
925 NOTES : None
926 **********************************************************************/
DummyExpandFuncMultifield(void * theEnv,DATA_OBJECT * result)927 globle void DummyExpandFuncMultifield(
928 void *theEnv,
929 DATA_OBJECT *result)
930 {
931 result->type = SYMBOL;
932 result->value = EnvFalseSymbol(theEnv);
933 SetEvaluationError(theEnv,TRUE);
934 PrintErrorID(theEnv,"MISCFUN",1,FALSE);
935 EnvPrintRouter(theEnv,WERROR,"expand$ must be used in the argument list of a function call.\n");
936 }
937
938 /***********************************************************************
939 NAME : ExpandFuncMultifield
940 DESCRIPTION : Recursively examines an expression and replaces
941 PROC_EXPAND_MULTIFIELD expressions with the expanded
942 evaluation expression of its argument
943 INPUTS : 1) A data object result buffer
944 2) The expression to modify
945 3) The address of the expression, in case it is
946 deleted entirely
947 4) The address of the H/L function expand$
948 RETURNS : Nothing useful
949 SIDE EFFECTS : Expressions allocated/deallocated as necessary
950 Evaluations performed
951 On errors, argument expression set to call a function
952 which causes an evaluation error when evaluated
953 a second time by actual caller.
954 NOTES : THIS ROUTINE MODIFIES EXPRESSIONS AT RUNTIME!! MAKE
955 SURE THAT THE EXPRESSION PASSED IS SAFE TO CHANGE!!
956 **********************************************************************/
ExpandFuncMultifield(void * theEnv,DATA_OBJECT * result,EXPRESSION * theExp,EXPRESSION ** sto,void * expmult)957 static void ExpandFuncMultifield(
958 void *theEnv,
959 DATA_OBJECT *result,
960 EXPRESSION *theExp,
961 EXPRESSION **sto,
962 void *expmult)
963 {
964 EXPRESSION *newexp,*top,*bot;
965 register long i; /* 6.04 Bug Fix */
966
967 while (theExp != NULL)
968 {
969 if (theExp->value == expmult)
970 {
971 EvaluateExpression(theEnv,theExp->argList,result);
972 ReturnExpression(theEnv,theExp->argList);
973 if ((EvaluationData(theEnv)->EvaluationError) || (result->type != MULTIFIELD))
974 {
975 theExp->argList = NULL;
976 if ((EvaluationData(theEnv)->EvaluationError == FALSE) && (result->type != MULTIFIELD))
977 ExpectedTypeError2(theEnv,"expand$",1);
978 theExp->value = (void *) FindFunction(theEnv,"(set-evaluation-error)");
979 EvaluationData(theEnv)->EvaluationError = FALSE;
980 EvaluationData(theEnv)->HaltExecution = FALSE;
981 return;
982 }
983 top = bot = NULL;
984 for (i = GetpDOBegin(result) ; i <= GetpDOEnd(result) ; i++)
985 {
986 newexp = get_struct(theEnv,expr);
987 newexp->type = GetMFType(result->value,i);
988 newexp->value = GetMFValue(result->value,i);
989 newexp->argList = NULL;
990 newexp->nextArg = NULL;
991 if (top == NULL)
992 top = newexp;
993 else
994 bot->nextArg = newexp;
995 bot = newexp;
996 }
997 if (top == NULL)
998 {
999 *sto = theExp->nextArg;
1000 rtn_struct(theEnv,expr,theExp);
1001 theExp = *sto;
1002 }
1003 else
1004 {
1005 bot->nextArg = theExp->nextArg;
1006 *sto = top;
1007 rtn_struct(theEnv,expr,theExp);
1008 sto = &bot->nextArg;
1009 theExp = bot->nextArg;
1010 }
1011 }
1012 else
1013 {
1014 if (theExp->argList != NULL)
1015 ExpandFuncMultifield(theEnv,result,theExp->argList,&theExp->argList,expmult);
1016 sto = &theExp->nextArg;
1017 theExp = theExp->nextArg;
1018 }
1019 }
1020 }
1021
1022 /****************************************************************
1023 NAME : CauseEvaluationError
1024 DESCRIPTION : Dummy function use to cause evaluation errors on
1025 a function call to generate error messages
1026 INPUTS : None
1027 RETURNS : A pointer to the FalseSymbol
1028 SIDE EFFECTS : EvaluationError set
1029 NOTES : None
1030 ****************************************************************/
CauseEvaluationError(void * theEnv)1031 globle void *CauseEvaluationError(
1032 void *theEnv)
1033 {
1034 SetEvaluationError(theEnv,TRUE);
1035 return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
1036 }
1037
1038 /****************************************************************
1039 NAME : SetSORCommand
1040 DESCRIPTION : Toggles SequenceOpMode - if TRUE, multifield
1041 references are replaced with sequence
1042 expansion operators
1043 INPUTS : None
1044 RETURNS : The old value of SequenceOpMode
1045 SIDE EFFECTS : SequenceOpMode toggled
1046 NOTES : None
1047 ****************************************************************/
SetSORCommand(void * theEnv)1048 globle intBool SetSORCommand(
1049 void *theEnv)
1050 {
1051 #if (! RUN_TIME) && (! BLOAD_ONLY)
1052 DATA_OBJECT arg;
1053
1054 if (EnvArgTypeCheck(theEnv,"set-sequence-operator-recognition",1,SYMBOL,&arg) == FALSE)
1055 return(ExpressionData(theEnv)->SequenceOpMode);
1056 return(EnvSetSequenceOperatorRecognition(theEnv,(arg.value == EnvFalseSymbol(theEnv)) ?
1057 FALSE : TRUE));
1058 #else
1059 return(ExpressionData(theEnv)->SequenceOpMode);
1060 #endif
1061 }
1062
1063 /********************************************************************
1064 NAME : GetFunctionRestrictions
1065 DESCRIPTION : Gets DefineFunction2() restriction list for function
1066 INPUTS : None
1067 RETURNS : A string containing the function restriction codes
1068 SIDE EFFECTS : EvaluationError set on errors
1069 NOTES : None
1070 ********************************************************************/
GetFunctionRestrictions(void * theEnv)1071 globle void *GetFunctionRestrictions(
1072 void *theEnv)
1073 {
1074 DATA_OBJECT temp;
1075 struct FunctionDefinition *fptr;
1076
1077 if (EnvArgTypeCheck(theEnv,"get-function-restrictions",1,SYMBOL,&temp) == FALSE)
1078 return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
1079 fptr = FindFunction(theEnv,DOToString(temp));
1080 if (fptr == NULL)
1081 {
1082 CantFindItemErrorMessage(theEnv,"function",DOToString(temp));
1083 SetEvaluationError(theEnv,TRUE);
1084 return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
1085 }
1086 if (fptr->restrictions == NULL)
1087 return((SYMBOL_HN *) EnvAddSymbol(theEnv,"0**"));
1088 return((SYMBOL_HN *) EnvAddSymbol(theEnv,fptr->restrictions));
1089 }
1090
1091 /*************************************************/
1092 /* GetFunctionListFunction: H/L access routine */
1093 /* for the get-function-list function. */
1094 /*************************************************/
GetFunctionListFunction(void * theEnv,DATA_OBJECT * returnValue)1095 globle void GetFunctionListFunction(
1096 void *theEnv,
1097 DATA_OBJECT *returnValue)
1098 {
1099 struct FunctionDefinition *theFunction;
1100 struct multifield *theList;
1101 unsigned long functionCount = 0;
1102
1103 if (EnvArgCountCheck(theEnv,"get-function-list",EXACTLY,0) == -1)
1104 {
1105 EnvSetMultifieldErrorValue(theEnv,returnValue);
1106 return;
1107 }
1108
1109 for (theFunction = GetFunctionList(theEnv);
1110 theFunction != NULL;
1111 theFunction = theFunction->next)
1112 { functionCount++; }
1113
1114 SetpType(returnValue,MULTIFIELD);
1115 SetpDOBegin(returnValue,1);
1116 SetpDOEnd(returnValue,functionCount);
1117 theList = (struct multifield *) EnvCreateMultifield(theEnv,functionCount);
1118 SetpValue(returnValue,(void *) theList);
1119
1120 for (theFunction = GetFunctionList(theEnv), functionCount = 1;
1121 theFunction != NULL;
1122 theFunction = theFunction->next, functionCount++)
1123 {
1124 SetMFType(theList,functionCount,SYMBOL);
1125 SetMFValue(theList,functionCount,theFunction->callFunctionName);
1126 }
1127 }
1128
1129 /***************************************/
1130 /* FuncallFunction: H/L access routine */
1131 /* for the funcall function. */
1132 /***************************************/
FuncallFunction(void * theEnv,DATA_OBJECT * returnValue)1133 globle void FuncallFunction(
1134 void *theEnv,
1135 DATA_OBJECT *returnValue)
1136 {
1137 int argCount, i, j;
1138 DATA_OBJECT theValue;
1139 FUNCTION_REFERENCE theReference;
1140 const char *name;
1141 struct multifield *theMultifield;
1142 struct expr *lastAdd = NULL, *nextAdd, *multiAdd;
1143 struct FunctionDefinition *theFunction;
1144
1145 /*==================================*/
1146 /* Set up the default return value. */
1147 /*==================================*/
1148
1149 SetpType(returnValue,SYMBOL);
1150 SetpValue(returnValue,EnvFalseSymbol(theEnv));
1151
1152 /*=================================================*/
1153 /* The funcall function has at least one argument: */
1154 /* the name of the function being called. */
1155 /*=================================================*/
1156
1157 if ((argCount = EnvArgCountCheck(theEnv,"funcall",AT_LEAST,1)) == -1) return;
1158
1159 /*============================================*/
1160 /* Get the name of the function to be called. */
1161 /*============================================*/
1162
1163 if (EnvArgTypeCheck(theEnv,"funcall",1,SYMBOL_OR_STRING,&theValue) == FALSE)
1164 { return; }
1165
1166 /*====================*/
1167 /* Find the function. */
1168 /*====================*/
1169
1170 name = DOToString(theValue);
1171 if (! GetFunctionReference(theEnv,name,&theReference))
1172 {
1173 ExpectedTypeError1(theEnv,"funcall",1,"function, deffunction, or generic function name");
1174 return;
1175 }
1176
1177 /*====================================*/
1178 /* Functions with specialized parsers */
1179 /* cannot be used with funcall. */
1180 /*====================================*/
1181
1182 if (theReference.type == FCALL)
1183 {
1184 theFunction = FindFunction(theEnv,name);
1185 if (theFunction->parser != NULL)
1186 {
1187 ExpectedTypeError1(theEnv,"funcall",1,"function without specialized parser");
1188 return;
1189 }
1190 }
1191
1192 /*======================================*/
1193 /* Add the arguments to the expression. */
1194 /*======================================*/
1195
1196 ExpressionInstall(theEnv,&theReference);
1197
1198 for (i = 2; i <= argCount; i++)
1199 {
1200 EnvRtnUnknown(theEnv,i,&theValue);
1201 if (GetEvaluationError(theEnv))
1202 {
1203 ExpressionDeinstall(theEnv,&theReference);
1204 return;
1205 }
1206
1207 switch(GetType(theValue))
1208 {
1209 case MULTIFIELD:
1210 nextAdd = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));
1211
1212 if (lastAdd == NULL)
1213 { theReference.argList = nextAdd; }
1214 else
1215 { lastAdd->nextArg = nextAdd; }
1216 lastAdd = nextAdd;
1217
1218 multiAdd = NULL;
1219 theMultifield = (struct multifield *) GetValue(theValue);
1220 for (j = GetDOBegin(theValue); j <= GetDOEnd(theValue); j++)
1221 {
1222 nextAdd = GenConstant(theEnv,GetMFType(theMultifield,j),GetMFValue(theMultifield,j));
1223 if (multiAdd == NULL)
1224 { lastAdd->argList = nextAdd; }
1225 else
1226 { multiAdd->nextArg = nextAdd; }
1227 multiAdd = nextAdd;
1228 }
1229
1230 ExpressionInstall(theEnv,lastAdd);
1231 break;
1232
1233 default:
1234 nextAdd = GenConstant(theEnv,GetType(theValue),GetValue(theValue));
1235 if (lastAdd == NULL)
1236 { theReference.argList = nextAdd; }
1237 else
1238 { lastAdd->nextArg = nextAdd; }
1239 lastAdd = nextAdd;
1240 ExpressionInstall(theEnv,lastAdd);
1241 break;
1242 }
1243 }
1244
1245 /*===========================================================*/
1246 /* Verify a deffunction has the correct number of arguments. */
1247 /*===========================================================*/
1248
1249 #if DEFFUNCTION_CONSTRUCT
1250 if (theReference.type == PCALL)
1251 {
1252 if (CheckDeffunctionCall(theEnv,theReference.value,CountArguments(theReference.argList)) == FALSE)
1253 {
1254 PrintErrorID(theEnv,"MISCFUN",4,FALSE);
1255 EnvPrintRouter(theEnv,WERROR,"Function funcall called with the wrong number of arguments for deffunction ");
1256 EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,theReference.value));
1257 EnvPrintRouter(theEnv,WERROR,"\n");
1258 ExpressionDeinstall(theEnv,&theReference);
1259 ReturnExpression(theEnv,theReference.argList);
1260 return;
1261 }
1262 }
1263 #endif
1264
1265 /*======================*/
1266 /* Call the expression. */
1267 /*======================*/
1268
1269 EvaluateExpression(theEnv,&theReference,returnValue);
1270
1271 /*========================================*/
1272 /* Return the expression data structures. */
1273 /*========================================*/
1274
1275 ExpressionDeinstall(theEnv,&theReference);
1276 ReturnExpression(theEnv,theReference.argList);
1277 }
1278
1279 /***********************************/
1280 /* NewFunction: H/L access routine */
1281 /* for the new function. */
1282 /***********************************/
NewFunction(void * theEnv,DATA_OBJECT * returnValue)1283 globle void NewFunction(
1284 void *theEnv,
1285 DATA_OBJECT *returnValue)
1286 {
1287 int theType;
1288 DATA_OBJECT theValue;
1289 const char *name;
1290
1291 /*==================================*/
1292 /* Set up the default return value. */
1293 /*==================================*/
1294
1295 SetpType(returnValue,SYMBOL);
1296 SetpValue(returnValue,EnvFalseSymbol(theEnv));
1297
1298 /*================================================================*/
1299 /* The new function has at least two arguments: the language type */
1300 /* of the class (e.g. java, .net, c++) and the name of the class. */
1301 /*================================================================*/
1302
1303 if (EnvArgCountCheck(theEnv,"new",AT_LEAST,1) == -1) return;
1304
1305 /*====================================*/
1306 /* Get the name of the language type. */
1307 /*====================================*/
1308
1309 if (EnvArgTypeCheck(theEnv,"new",1,SYMBOL,&theValue) == FALSE)
1310 { return; }
1311
1312 /*=========================*/
1313 /* Find the language type. */
1314 /*=========================*/
1315
1316 name = DOToString(theValue);
1317
1318 theType = FindLanguageType(theEnv,name);
1319
1320 if (theType == -1)
1321 {
1322 ExpectedTypeError1(theEnv,"new",1,"external language");
1323 return;
1324 }
1325
1326 /*====================================================*/
1327 /* Invoke the new function for the specific language. */
1328 /*====================================================*/
1329
1330 if ((EvaluationData(theEnv)->ExternalAddressTypes[theType] != NULL) &&
1331 (EvaluationData(theEnv)->ExternalAddressTypes[theType]->newFunction != NULL))
1332 { (*EvaluationData(theEnv)->ExternalAddressTypes[theType]->newFunction)(theEnv,returnValue); }
1333 }
1334
1335 /************************************/
1336 /* CallFunction: H/L access routine */
1337 /* for the new function. */
1338 /************************************/
CallFunction(void * theEnv,DATA_OBJECT * returnValue)1339 globle void CallFunction(
1340 void *theEnv,
1341 DATA_OBJECT *returnValue)
1342 {
1343 int theType;
1344 DATA_OBJECT theValue;
1345 const char *name;
1346 int argumentCount;
1347 struct externalAddressHashNode *theEA;
1348
1349 /*==================================*/
1350 /* Set up the default return value. */
1351 /*==================================*/
1352
1353 SetpType(returnValue,SYMBOL);
1354 SetpValue(returnValue,EnvFalseSymbol(theEnv));
1355
1356 /*=====================================================*/
1357 /* The call function has at least one argument: either */
1358 /* an external address or the language type of the */
1359 /* method being called (e.g. java, .net, c++). */
1360 /*=====================================================*/
1361
1362 if ((argumentCount = EnvArgCountCheck(theEnv,"call",AT_LEAST,1)) == -1) return;
1363
1364 /*=========================*/
1365 /* Get the first argument. */
1366 /*=========================*/
1367
1368 EnvRtnUnknown(theEnv,1,&theValue);
1369
1370 /*============================================*/
1371 /* If the first argument is a symbol, then it */
1372 /* should be an external language type. */
1373 /*============================================*/
1374
1375 if (GetType(theValue) == SYMBOL)
1376 {
1377 name = DOToString(theValue);
1378
1379 theType = FindLanguageType(theEnv,name);
1380
1381 if (theType == -1)
1382 {
1383 ExpectedTypeError1(theEnv,"call",1,"external language symbol or external address");
1384 return;
1385 }
1386
1387 /*====================================================================*/
1388 /* Invoke the call function for the specific language. Typically this */
1389 /* will invoke a static method of a class (specified with the third */
1390 /* and second arguments to the call function. */
1391 /*====================================================================*/
1392
1393 if ((EvaluationData(theEnv)->ExternalAddressTypes[theType] != NULL) &&
1394 (EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction != NULL))
1395 { (*EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction)(theEnv,&theValue,returnValue); }
1396
1397 return;
1398 }
1399
1400 /*===============================================*/
1401 /* If the first argument is an external address, */
1402 /* then we can determine the external language */
1403 /* type be examining the pointer. */
1404 /*===============================================*/
1405
1406 if (GetType(theValue) == EXTERNAL_ADDRESS)
1407 {
1408 theEA = (struct externalAddressHashNode *) GetValue(theValue);
1409
1410 theType = theEA->type;
1411
1412 if ((EvaluationData(theEnv)->ExternalAddressTypes[theType] != NULL) &&
1413 (EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction != NULL))
1414 { (*EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction)(theEnv,&theValue,returnValue); }
1415
1416 return;
1417 }
1418
1419 ExpectedTypeError1(theEnv,"call",1,"external language symbol or external address");
1420 }
1421
1422 /************************************/
1423 /* FindLanguageType: */
1424 /************************************/
FindLanguageType(void * theEnv,const char * languageName)1425 static int FindLanguageType(
1426 void *theEnv,
1427 const char *languageName)
1428 {
1429 int theType;
1430
1431 for (theType = 0; theType < EvaluationData(theEnv)->numberOfAddressTypes; theType++)
1432 {
1433 if (strcmp(EvaluationData(theEnv)->ExternalAddressTypes[theType]->name,languageName) == 0)
1434 { return(theType); }
1435 }
1436
1437 return -1;
1438 }
1439
1440 /************************************/
1441 /* TimeFunction: H/L access routine */
1442 /* for the time function. */
1443 /************************************/
TimeFunction(void * theEnv)1444 globle double TimeFunction(
1445 void *theEnv)
1446 {
1447 /*=========================================*/
1448 /* The time function accepts no arguments. */
1449 /*=========================================*/
1450
1451 EnvArgCountCheck(theEnv,"time",EXACTLY,0);
1452
1453 /*==================*/
1454 /* Return the time. */
1455 /*==================*/
1456
1457 return(gentime());
1458 }
1459
1460 /***************************************/
1461 /* TimerFunction: H/L access routine */
1462 /* for the timer function. */
1463 /***************************************/
TimerFunction(void * theEnv)1464 globle double TimerFunction(
1465 void *theEnv)
1466 {
1467 int numa, i;
1468 double startTime;
1469 DATA_OBJECT returnValue;
1470
1471 startTime = gentime();
1472
1473 numa = EnvRtnArgCount(theEnv);
1474
1475 i = 1;
1476 while ((i <= numa) && (GetHaltExecution(theEnv) != TRUE))
1477 {
1478 EnvRtnUnknown(theEnv,i,&returnValue);
1479 i++;
1480 }
1481
1482 return(gentime() - startTime);
1483 }
1484