1 /*******************************************************/
2 /* "C" Language Integrated Production System */
3 /* */
4 /* CLIPS Version 6.30 02/04/15 */
5 /* */
6 /* EVALUATION MODULE */
7 /*******************************************************/
8
9 /*************************************************************/
10 /* Purpose: Provides routines for evaluating expressions. */
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 /* 6.24: Renamed BOOLEAN macro type to intBool. */
23 /* */
24 /* Added EvaluateAndStoreInDataObject function. */
25 /* */
26 /* 6.30: Added support for passing context information */
27 /* to user defined functions. */
28 /* */
29 /* Added support for external address hash table */
30 /* and subtyping. */
31 /* */
32 /* Changed integer type/precision. */
33 /* */
34 /* Support for long long integers. */
35 /* */
36 /* Changed garbage collection algorithm. */
37 /* */
38 /* Support for DATA_OBJECT_ARRAY primitive. */
39 /* */
40 /* Added const qualifiers to remove C++ */
41 /* deprecation warnings. */
42 /* */
43 /* Converted API macros to function calls. */
44 /* */
45 /*************************************************************/
46
47 #define _EVALUATN_SOURCE_
48
49 #include <stdio.h>
50 #define _STDIO_INCLUDED_
51 #include <stdlib.h>
52 #include <string.h>
53 #include <ctype.h>
54
55 #include "setup.h"
56
57 #include "argacces.h"
58 #include "commline.h"
59 #include "constant.h"
60 #include "envrnmnt.h"
61 #include "memalloc.h"
62 #include "router.h"
63 #include "extnfunc.h"
64 #include "prcdrfun.h"
65 #include "multifld.h"
66 #include "factmngr.h"
67 #include "prntutil.h"
68 #include "exprnpsr.h"
69 #include "utility.h"
70 #include "proflfun.h"
71 #include "sysdep.h"
72
73 #if DEFFUNCTION_CONSTRUCT
74 #include "dffnxfun.h"
75 #endif
76
77 #if DEFGENERIC_CONSTRUCT
78 #include "genrccom.h"
79 #endif
80
81 #if OBJECT_SYSTEM
82 #include "object.h"
83 #include "inscom.h"
84 #endif
85
86 #include "evaluatn.h"
87
88 /***************************************/
89 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
90 /***************************************/
91
92 static void DeallocateEvaluationData(void *);
93 static void PrintCAddress(void *,const char *,void *);
94 static void NewCAddress(void *,DATA_OBJECT *);
95 /*
96 static intBool DiscardCAddress(void *,void *);
97 */
98
99 /**************************************************/
100 /* InitializeEvaluationData: Allocates environment */
101 /* data for expression evaluation. */
102 /**************************************************/
InitializeEvaluationData(void * theEnv)103 globle void InitializeEvaluationData(
104 void *theEnv)
105 {
106 struct externalAddressType cPointer = { "C", PrintCAddress, PrintCAddress, NULL, NewCAddress, NULL };
107
108 AllocateEnvironmentData(theEnv,EVALUATION_DATA,sizeof(struct evaluationData),DeallocateEvaluationData);
109
110 InstallExternalAddressType(theEnv,&cPointer);
111 }
112
113 /*****************************************************/
114 /* DeallocateEvaluationData: Deallocates environment */
115 /* data for evaluation data. */
116 /*****************************************************/
DeallocateEvaluationData(void * theEnv)117 static void DeallocateEvaluationData(
118 void *theEnv)
119 {
120 int i;
121
122 for (i = 0; i < EvaluationData(theEnv)->numberOfAddressTypes; i++)
123 { rtn_struct(theEnv,externalAddressType,EvaluationData(theEnv)->ExternalAddressTypes[i]); }
124 }
125
126 /**************************************************************/
127 /* EvaluateExpression: Evaluates an expression. Returns FALSE */
128 /* if no errors occurred during evaluation, otherwise TRUE. */
129 /**************************************************************/
EvaluateExpression(void * theEnv,struct expr * problem,DATA_OBJECT_PTR returnValue)130 globle int EvaluateExpression(
131 void *theEnv,
132 struct expr *problem,
133 DATA_OBJECT_PTR returnValue)
134 {
135 struct expr *oldArgument;
136 void *oldContext;
137 struct FunctionDefinition *fptr;
138 #if PROFILING_FUNCTIONS
139 struct profileFrameInfo profileFrame;
140 #endif
141
142 if (problem == NULL)
143 {
144 returnValue->type = SYMBOL;
145 returnValue->value = EnvFalseSymbol(theEnv);
146 return(EvaluationData(theEnv)->EvaluationError);
147 }
148
149 switch (problem->type)
150 {
151 case STRING:
152 case SYMBOL:
153 case FLOAT:
154 case INTEGER:
155 #if OBJECT_SYSTEM
156 case INSTANCE_NAME:
157 case INSTANCE_ADDRESS:
158 #endif
159 case EXTERNAL_ADDRESS:
160 returnValue->type = problem->type;
161 returnValue->value = problem->value;
162 break;
163
164 case DATA_OBJECT_ARRAY: /* TBD Remove with AddPrimitive */
165 returnValue->type = problem->type;
166 returnValue->value = problem->value;
167 break;
168
169 case FCALL:
170 {
171 fptr = (struct FunctionDefinition *) problem->value;
172 oldContext = SetEnvironmentFunctionContext(theEnv,fptr->context);
173
174 #if PROFILING_FUNCTIONS
175 StartProfile(theEnv,&profileFrame,
176 &fptr->usrData,
177 ProfileFunctionData(theEnv)->ProfileUserFunctions);
178 #endif
179
180 oldArgument = EvaluationData(theEnv)->CurrentExpression;
181 EvaluationData(theEnv)->CurrentExpression = problem;
182
183 switch(fptr->returnValueType)
184 {
185 case 'v' :
186 if (fptr->environmentAware)
187 { (* (void (*)(void *)) fptr->functionPointer)(theEnv); }
188 else
189 { (* (void (*)(void)) fptr->functionPointer)(); }
190 returnValue->type = RVOID;
191 returnValue->value = EnvFalseSymbol(theEnv);
192 break;
193 case 'b' :
194 returnValue->type = SYMBOL;
195 if (fptr->environmentAware)
196 {
197 if ((* (int (*)(void *)) fptr->functionPointer)(theEnv))
198 returnValue->value = EnvTrueSymbol(theEnv);
199 else
200 returnValue->value = EnvFalseSymbol(theEnv);
201 }
202 else
203 {
204 if ((* (int (*)(void)) fptr->functionPointer)())
205 returnValue->value = EnvTrueSymbol(theEnv);
206 else
207 returnValue->value = EnvFalseSymbol(theEnv);
208 }
209 break;
210 case 'a' :
211 returnValue->type = EXTERNAL_ADDRESS;
212 if (fptr->environmentAware)
213 {
214 returnValue->value =
215 (* (void *(*)(void *)) fptr->functionPointer)(theEnv);
216 }
217 else
218 {
219 returnValue->value =
220 (* (void *(*)(void)) fptr->functionPointer)();
221 }
222 break;
223 case 'g' :
224 returnValue->type = INTEGER;
225 if (fptr->environmentAware)
226 {
227 returnValue->value = (void *)
228 EnvAddLong(theEnv,(* (long long (*)(void *)) fptr->functionPointer)(theEnv));
229 }
230 else
231 {
232 returnValue->value = (void *)
233 EnvAddLong(theEnv,(* (long long (*)(void)) fptr->functionPointer)());
234 }
235 break;
236 case 'i' :
237 returnValue->type = INTEGER;
238 if (fptr->environmentAware)
239 {
240 returnValue->value = (void *)
241 EnvAddLong(theEnv,(long long) (* (int (*)(void *)) fptr->functionPointer)(theEnv));
242 }
243 else
244 {
245 returnValue->value = (void *)
246 EnvAddLong(theEnv,(long long) (* (int (*)(void)) fptr->functionPointer)());
247 }
248 break;
249 case 'l' :
250 returnValue->type = INTEGER;
251 if (fptr->environmentAware)
252 {
253 returnValue->value = (void *)
254 EnvAddLong(theEnv,(long long) (* (long int (*)(void *)) fptr->functionPointer)(theEnv));
255 }
256 else
257 {
258 returnValue->value = (void *)
259 EnvAddLong(theEnv,(long long) (* (long int (*)(void)) fptr->functionPointer)());
260 }
261 break;
262 case 'f' :
263 returnValue->type = FLOAT;
264 if (fptr->environmentAware)
265 {
266 returnValue->value = (void *)
267 EnvAddDouble(theEnv,(double) (* (float (*)(void *)) fptr->functionPointer)(theEnv));
268 }
269 else
270 {
271 returnValue->value = (void *)
272 EnvAddDouble(theEnv,(double) (* (float (*)(void)) fptr->functionPointer)());
273 }
274 break;
275 case 'd' :
276 returnValue->type = FLOAT;
277 if (fptr->environmentAware)
278 {
279 returnValue->value = (void *)
280 EnvAddDouble(theEnv,(* (double (*)(void *)) fptr->functionPointer)(theEnv));
281 }
282 else
283 {
284 returnValue->value = (void *)
285 EnvAddDouble(theEnv,(* (double (*)(void)) fptr->functionPointer)());
286 }
287 break;
288 case 's' :
289 returnValue->type = STRING;
290 if (fptr->environmentAware)
291 {
292 returnValue->value = (void *)
293 (* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
294 }
295 else
296 {
297 returnValue->value = (void *)
298 (* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
299 }
300 break;
301 case 'w' :
302 returnValue->type = SYMBOL;
303 if (fptr->environmentAware)
304 {
305 returnValue->value = (void *)
306 (* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
307 }
308 else
309 {
310 returnValue->value = (void *)
311 (* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
312 }
313 break;
314 #if OBJECT_SYSTEM
315 case 'x' :
316 returnValue->type = INSTANCE_ADDRESS;
317 if (fptr->environmentAware)
318 {
319 returnValue->value =
320 (* (void *(*)(void *)) fptr->functionPointer)(theEnv);
321 }
322 else
323 {
324 returnValue->value =
325 (* (void *(*)(void)) fptr->functionPointer)();
326 }
327 if (returnValue->value == NULL)
328 { returnValue->value = (void *) &InstanceData(theEnv)->DummyInstance; }
329
330 break;
331 case 'o' :
332 returnValue->type = INSTANCE_NAME;
333 if (fptr->environmentAware)
334 {
335 returnValue->value = (void *)
336 (* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
337 }
338 else
339 {
340 returnValue->value = (void *)
341 (* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
342 }
343 break;
344 #endif
345
346 #if DEFTEMPLATE_CONSTRUCT
347 case 'y' :
348 returnValue->type = FACT_ADDRESS;
349 if (fptr->environmentAware)
350 {
351 returnValue->value =
352 (* (void *(*)(void *)) fptr->functionPointer)(theEnv);
353 }
354 else
355 {
356 returnValue->value =
357 (* (void *(*)(void)) fptr->functionPointer)();
358 }
359 if (returnValue->value == NULL)
360 { returnValue->value = (void *) &FactData(theEnv)->DummyFact; }
361
362 break;
363 #endif
364
365 case 'c' :
366 {
367 char cbuff[2];
368 if (fptr->environmentAware)
369 {
370 cbuff[0] = (* (char (*)(void *)) fptr->functionPointer)(theEnv);
371 }
372 else
373 {
374 cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
375 }
376 cbuff[1] = EOS;
377 returnValue->type = SYMBOL;
378 returnValue->value = (void *) EnvAddSymbol(theEnv,cbuff);
379 break;
380 }
381
382 case 'j' :
383 case 'k' :
384 case 'm' :
385 case 'n' :
386 case 'u' :
387 if (fptr->environmentAware)
388 {
389 (* (void (*)(void *,DATA_OBJECT_PTR)) fptr->functionPointer)(theEnv,returnValue);
390 }
391 else
392 {
393 (* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
394 }
395 break;
396
397 default :
398 SystemError(theEnv,"EVALUATN",2);
399 EnvExitRouter(theEnv,EXIT_FAILURE);
400 break;
401 }
402
403 #if PROFILING_FUNCTIONS
404 EndProfile(theEnv,&profileFrame);
405 #endif
406
407 SetEnvironmentFunctionContext(theEnv,oldContext);
408 EvaluationData(theEnv)->CurrentExpression = oldArgument;
409 break;
410 }
411
412 case MULTIFIELD:
413 returnValue->type = MULTIFIELD;
414 returnValue->value = ((DATA_OBJECT_PTR) (problem->value))->value;
415 returnValue->begin = ((DATA_OBJECT_PTR) (problem->value))->begin;
416 returnValue->end = ((DATA_OBJECT_PTR) (problem->value))->end;
417 break;
418
419 case MF_VARIABLE:
420 case SF_VARIABLE:
421 if (GetBoundVariable(theEnv,returnValue,(SYMBOL_HN *) problem->value) == FALSE)
422 {
423 PrintErrorID(theEnv,"EVALUATN",1,FALSE);
424 EnvPrintRouter(theEnv,WERROR,"Variable ");
425 EnvPrintRouter(theEnv,WERROR,ValueToString(problem->value));
426 EnvPrintRouter(theEnv,WERROR," is unbound\n");
427 returnValue->type = SYMBOL;
428 returnValue->value = EnvFalseSymbol(theEnv);
429 SetEvaluationError(theEnv,TRUE);
430 }
431 break;
432
433 default:
434 if (EvaluationData(theEnv)->PrimitivesArray[problem->type] == NULL)
435 {
436 SystemError(theEnv,"EVALUATN",3);
437 EnvExitRouter(theEnv,EXIT_FAILURE);
438 }
439
440 if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->copyToEvaluate)
441 {
442 returnValue->type = problem->type;
443 returnValue->value = problem->value;
444 break;
445 }
446
447 if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction == NULL)
448 {
449 SystemError(theEnv,"EVALUATN",4);
450 EnvExitRouter(theEnv,EXIT_FAILURE);
451 }
452
453 oldArgument = EvaluationData(theEnv)->CurrentExpression;
454 EvaluationData(theEnv)->CurrentExpression = problem;
455
456 #if PROFILING_FUNCTIONS
457 StartProfile(theEnv,&profileFrame,
458 &EvaluationData(theEnv)->PrimitivesArray[problem->type]->usrData,
459 ProfileFunctionData(theEnv)->ProfileUserFunctions);
460 #endif
461
462 (*EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction)(theEnv,problem->value,returnValue);
463
464 #if PROFILING_FUNCTIONS
465 EndProfile(theEnv,&profileFrame);
466 #endif
467
468 EvaluationData(theEnv)->CurrentExpression = oldArgument;
469 break;
470 }
471
472 return(EvaluationData(theEnv)->EvaluationError);
473 }
474
475 /******************************************/
476 /* InstallPrimitive: Installs a primitive */
477 /* data type in the primitives array. */
478 /******************************************/
InstallPrimitive(void * theEnv,struct entityRecord * thePrimitive,int whichPosition)479 globle void InstallPrimitive(
480 void *theEnv,
481 struct entityRecord *thePrimitive,
482 int whichPosition)
483 {
484 if (EvaluationData(theEnv)->PrimitivesArray[whichPosition] != NULL)
485 {
486 SystemError(theEnv,"EVALUATN",5);
487 EnvExitRouter(theEnv,EXIT_FAILURE);
488 }
489
490 EvaluationData(theEnv)->PrimitivesArray[whichPosition] = thePrimitive;
491 }
492
493 /******************************************************/
494 /* InstallExternalAddressType: Installs an external */
495 /* address type in the external address type array. */
496 /******************************************************/
InstallExternalAddressType(void * theEnv,struct externalAddressType * theAddressType)497 globle int InstallExternalAddressType(
498 void *theEnv,
499 struct externalAddressType *theAddressType)
500 {
501 struct externalAddressType *copyEAT;
502
503 int rv = EvaluationData(theEnv)->numberOfAddressTypes;
504
505 if (EvaluationData(theEnv)->numberOfAddressTypes == MAXIMUM_EXTERNAL_ADDRESS_TYPES)
506 {
507 SystemError(theEnv,"EVALUATN",6);
508 EnvExitRouter(theEnv,EXIT_FAILURE);
509 }
510
511 copyEAT = (struct externalAddressType *) genalloc(theEnv,sizeof(struct externalAddressType));
512 memcpy(copyEAT,theAddressType,sizeof(struct externalAddressType));
513 EvaluationData(theEnv)->ExternalAddressTypes[EvaluationData(theEnv)->numberOfAddressTypes++] = copyEAT;
514
515 return rv;
516 }
517
518 /******************************************************/
519 /* SetEvaluationError: Sets the EvaluationError flag. */
520 /******************************************************/
SetEvaluationError(void * theEnv,int value)521 globle void SetEvaluationError(
522 void *theEnv,
523 int value)
524 {
525 EvaluationData(theEnv)->EvaluationError = value;
526 if (value == TRUE)
527 { EvaluationData(theEnv)->HaltExecution = TRUE; }
528 }
529
530 /*********************************************************/
531 /* GetEvaluationError: Returns the EvaluationError flag. */
532 /*********************************************************/
GetEvaluationError(void * theEnv)533 globle int GetEvaluationError(
534 void *theEnv)
535 {
536 return(EvaluationData(theEnv)->EvaluationError);
537 }
538
539 /**************************************************/
540 /* SetHaltExecution: Sets the HaltExecution flag. */
541 /**************************************************/
SetHaltExecution(void * theEnv,int value)542 globle void SetHaltExecution(
543 void *theEnv,
544 int value)
545 {
546 EvaluationData(theEnv)->HaltExecution = value;
547 }
548
549 /*****************************************************/
550 /* GetHaltExecution: Returns the HaltExecution flag. */
551 /*****************************************************/
GetHaltExecution(void * theEnv)552 globle int GetHaltExecution(
553 void *theEnv)
554 {
555 return(EvaluationData(theEnv)->HaltExecution);
556 }
557
558 /******************************************************/
559 /* ReturnValues: Returns a linked list of DATA_OBJECT */
560 /* structures to the pool of free memory. */
561 /******************************************************/
ReturnValues(void * theEnv,DATA_OBJECT_PTR garbagePtr,intBool decrementSupplementalInfo)562 globle void ReturnValues(
563 void *theEnv,
564 DATA_OBJECT_PTR garbagePtr,
565 intBool decrementSupplementalInfo)
566 {
567 DATA_OBJECT_PTR nextPtr;
568
569 while (garbagePtr != NULL)
570 {
571 nextPtr = garbagePtr->next;
572 ValueDeinstall(theEnv,garbagePtr);
573 if ((garbagePtr->supplementalInfo != NULL) && decrementSupplementalInfo)
574 { DecrementSymbolCount(theEnv,(struct symbolHashNode *) garbagePtr->supplementalInfo); }
575 rtn_struct(theEnv,dataObject,garbagePtr);
576 garbagePtr = nextPtr;
577 }
578 }
579
580 /***************************************************/
581 /* PrintDataObject: Prints a DATA_OBJECT structure */
582 /* to the specified logical name. */
583 /***************************************************/
PrintDataObject(void * theEnv,const char * fileid,DATA_OBJECT_PTR argPtr)584 globle void PrintDataObject(
585 void *theEnv,
586 const char *fileid,
587 DATA_OBJECT_PTR argPtr)
588 {
589 switch(argPtr->type)
590 {
591 case RVOID:
592 case SYMBOL:
593 case STRING:
594 case INTEGER:
595 case FLOAT:
596 case EXTERNAL_ADDRESS:
597 case DATA_OBJECT_ARRAY: // TBD Remove with AddPrimitive
598 case FACT_ADDRESS:
599 #if OBJECT_SYSTEM
600 case INSTANCE_NAME:
601 case INSTANCE_ADDRESS:
602 #endif
603 PrintAtom(theEnv,fileid,argPtr->type,argPtr->value);
604 break;
605
606 case MULTIFIELD:
607 PrintMultifield(theEnv,fileid,(struct multifield *) argPtr->value,
608 argPtr->begin,argPtr->end,TRUE);
609 break;
610
611 default:
612 if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type] != NULL)
613 {
614 if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->longPrintFunction)
615 {
616 (*EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->longPrintFunction)(theEnv,fileid,argPtr->value);
617 break;
618 }
619 else if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->shortPrintFunction)
620 {
621 (*EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->shortPrintFunction)(theEnv,fileid,argPtr->value);
622 break;
623 }
624 }
625
626 EnvPrintRouter(theEnv,fileid,"<UnknownPrintType");
627 PrintLongInteger(theEnv,fileid,(long int) argPtr->type);
628 EnvPrintRouter(theEnv,fileid,">");
629 SetHaltExecution(theEnv,TRUE);
630 SetEvaluationError(theEnv,TRUE);
631 break;
632 }
633 }
634
635 /****************************************************/
636 /* EnvSetMultifieldErrorValue: Creates a multifield */
637 /* value of length zero for error returns. */
638 /****************************************************/
EnvSetMultifieldErrorValue(void * theEnv,DATA_OBJECT_PTR returnValue)639 globle void EnvSetMultifieldErrorValue(
640 void *theEnv,
641 DATA_OBJECT_PTR returnValue)
642 {
643 returnValue->type = MULTIFIELD;
644 returnValue->value = EnvCreateMultifield(theEnv,0L);
645 returnValue->begin = 1;
646 returnValue->end = 0;
647 }
648
649 /**************************************************/
650 /* ValueInstall: Increments the appropriate count */
651 /* (in use) values for a DATA_OBJECT structure. */
652 /**************************************************/
ValueInstall(void * theEnv,DATA_OBJECT * vPtr)653 globle void ValueInstall(
654 void *theEnv,
655 DATA_OBJECT *vPtr)
656 {
657 if (vPtr->type == MULTIFIELD) MultifieldInstall(theEnv,(struct multifield *) vPtr->value);
658 else AtomInstall(theEnv,vPtr->type,vPtr->value);
659 }
660
661 /****************************************************/
662 /* ValueDeinstall: Decrements the appropriate count */
663 /* (in use) values for a DATA_OBJECT structure. */
664 /****************************************************/
ValueDeinstall(void * theEnv,DATA_OBJECT * vPtr)665 globle void ValueDeinstall(
666 void *theEnv,
667 DATA_OBJECT *vPtr)
668 {
669 if (vPtr->type == MULTIFIELD) MultifieldDeinstall(theEnv,(struct multifield *) vPtr->value);
670 else AtomDeinstall(theEnv,vPtr->type,vPtr->value);
671 }
672
673 /*****************************************/
674 /* AtomInstall: Increments the reference */
675 /* count of an atomic data type. */
676 /*****************************************/
AtomInstall(void * theEnv,int type,void * vPtr)677 globle void AtomInstall(
678 void *theEnv,
679 int type,
680 void *vPtr)
681 {
682 switch (type)
683 {
684 case SYMBOL:
685 case STRING:
686 #if DEFGLOBAL_CONSTRUCT
687 case GBL_VARIABLE:
688 #endif
689 #if OBJECT_SYSTEM
690 case INSTANCE_NAME:
691 #endif
692 IncrementSymbolCount(vPtr);
693 break;
694
695 case FLOAT:
696 IncrementFloatCount(vPtr);
697 break;
698
699 case INTEGER:
700 IncrementIntegerCount(vPtr);
701 break;
702
703 case EXTERNAL_ADDRESS:
704 IncrementExternalAddressCount(vPtr);
705 break;
706
707 case MULTIFIELD:
708 MultifieldInstall(theEnv,(struct multifield *) vPtr);
709 break;
710
711 case RVOID:
712 break;
713
714 default:
715 if (EvaluationData(theEnv)->PrimitivesArray[type] == NULL) break;
716 if (EvaluationData(theEnv)->PrimitivesArray[type]->bitMap) IncrementBitMapCount(vPtr);
717 else if (EvaluationData(theEnv)->PrimitivesArray[type]->incrementBusyCount)
718 { (*EvaluationData(theEnv)->PrimitivesArray[type]->incrementBusyCount)(theEnv,vPtr); }
719 break;
720 }
721 }
722
723 /*******************************************/
724 /* AtomDeinstall: Decrements the reference */
725 /* count of an atomic data type. */
726 /*******************************************/
AtomDeinstall(void * theEnv,int type,void * vPtr)727 globle void AtomDeinstall(
728 void *theEnv,
729 int type,
730 void *vPtr)
731 {
732 switch (type)
733 {
734 case SYMBOL:
735 case STRING:
736 #if DEFGLOBAL_CONSTRUCT
737 case GBL_VARIABLE:
738 #endif
739 #if OBJECT_SYSTEM
740 case INSTANCE_NAME:
741 #endif
742 DecrementSymbolCount(theEnv,(SYMBOL_HN *) vPtr);
743 break;
744
745 case FLOAT:
746 DecrementFloatCount(theEnv,(FLOAT_HN *) vPtr);
747 break;
748
749 case INTEGER:
750 DecrementIntegerCount(theEnv,(INTEGER_HN *) vPtr);
751 break;
752
753 case EXTERNAL_ADDRESS:
754 DecrementExternalAddressCount(theEnv,(EXTERNAL_ADDRESS_HN *) vPtr);
755 break;
756
757 case MULTIFIELD:
758 MultifieldDeinstall(theEnv,(struct multifield *) vPtr);
759 break;
760
761 case RVOID:
762 break;
763
764 default:
765 if (EvaluationData(theEnv)->PrimitivesArray[type] == NULL) break;
766 if (EvaluationData(theEnv)->PrimitivesArray[type]->bitMap) DecrementBitMapCount(theEnv,(BITMAP_HN *) vPtr);
767 else if (EvaluationData(theEnv)->PrimitivesArray[type]->decrementBusyCount)
768 { (*EvaluationData(theEnv)->PrimitivesArray[type]->decrementBusyCount)(theEnv,vPtr); }
769 }
770 }
771
772 #if DEFFUNCTION_CONSTRUCT || DEFGENERIC_CONSTRUCT
773
774 /********************************************/
775 /* EnvFunctionCall: Allows Deffunctions and */
776 /* Generic Functions to be called from C. */
777 /* Allows only constants as arguments. */
778 /********************************************/
EnvFunctionCall(void * theEnv,const char * name,const char * args,DATA_OBJECT * result)779 globle int EnvFunctionCall(
780 void *theEnv,
781 const char *name,
782 const char *args,
783 DATA_OBJECT *result)
784 {
785 FUNCTION_REFERENCE theReference;
786
787 /*=======================================*/
788 /* Call the function if it can be found. */
789 /*=======================================*/
790
791 if (GetFunctionReference(theEnv,name,&theReference))
792 { return(FunctionCall2(theEnv,&theReference,args,result)); }
793
794 /*=========================================================*/
795 /* Otherwise signal an error if a deffunction, defgeneric, */
796 /* or user defined function doesn't exist that matches */
797 /* the specified function name. */
798 /*=========================================================*/
799
800 PrintErrorID(theEnv,"EVALUATN",2,FALSE);
801 EnvPrintRouter(theEnv,WERROR,"No function, generic function or deffunction of name ");
802 EnvPrintRouter(theEnv,WERROR,name);
803 EnvPrintRouter(theEnv,WERROR," exists for external call.\n");
804 return(TRUE);
805 }
806
807 /********************************************/
808 /* FunctionCall2: Allows Deffunctions and */
809 /* Generic Functions to be called from C. */
810 /* Allows only constants as arguments. */
811 /********************************************/
FunctionCall2(void * theEnv,FUNCTION_REFERENCE * theReference,const char * args,DATA_OBJECT * result)812 globle int FunctionCall2(
813 void *theEnv,
814 FUNCTION_REFERENCE *theReference,
815 const char *args,
816 DATA_OBJECT *result)
817 {
818 EXPRESSION *argexps;
819 int error = FALSE;
820
821 /*=============================================*/
822 /* Force periodic cleanup if the function call */
823 /* was executed from an embedded application. */
824 /*=============================================*/
825
826 if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
827 (EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
828 {
829 CleanCurrentGarbageFrame(theEnv,NULL);
830 CallPeriodicTasks(theEnv);
831 }
832
833 /*========================*/
834 /* Reset the error state. */
835 /*========================*/
836
837 if (UtilityData(theEnv)->CurrentGarbageFrame->topLevel) SetHaltExecution(theEnv,FALSE);
838 EvaluationData(theEnv)->EvaluationError = FALSE;
839
840 /*======================================*/
841 /* Initialize the default return value. */
842 /*======================================*/
843
844 result->type = SYMBOL;
845 result->value = EnvFalseSymbol(theEnv);
846
847 /*============================*/
848 /* Parse the argument string. */
849 /*============================*/
850
851 argexps = ParseConstantArguments(theEnv,args,&error);
852 if (error == TRUE) return(TRUE);
853
854 /*====================*/
855 /* Call the function. */
856 /*====================*/
857
858 theReference->argList = argexps;
859 error = EvaluateExpression(theEnv,theReference,result);
860
861 /*========================*/
862 /* Return the expression. */
863 /*========================*/
864
865 ReturnExpression(theEnv,argexps);
866 theReference->argList = NULL;
867
868 /*==========================*/
869 /* Return the error status. */
870 /*==========================*/
871
872 return(error);
873 }
874
875 #endif
876
877 /***************************************************/
878 /* CopyDataObject: Copies the values from a source */
879 /* DATA_OBJECT to a destination DATA_OBJECT. */
880 /***************************************************/
CopyDataObject(void * theEnv,DATA_OBJECT * dst,DATA_OBJECT * src,int garbageMultifield)881 globle void CopyDataObject(
882 void *theEnv,
883 DATA_OBJECT *dst,
884 DATA_OBJECT *src,
885 int garbageMultifield)
886 {
887 if (src->type != MULTIFIELD)
888 {
889 dst->type = src->type;
890 dst->value = src->value;
891 }
892 else
893 {
894 DuplicateMultifield(theEnv,dst,src);
895 if (garbageMultifield)
896 { AddToMultifieldList(theEnv,(struct multifield *) dst->value); }
897 }
898 }
899
900 /***********************************************/
901 /* TransferDataObjectValues: Copies the values */
902 /* directly from a source DATA_OBJECT to a */
903 /* destination DATA_OBJECT. */
904 /***********************************************/
TransferDataObjectValues(DATA_OBJECT * dst,DATA_OBJECT * src)905 globle void TransferDataObjectValues(
906 DATA_OBJECT *dst,
907 DATA_OBJECT *src)
908 {
909 dst->type = src->type;
910 dst->value = src->value;
911 dst->begin = src->begin;
912 dst->end = src->end;
913 dst->supplementalInfo = src->supplementalInfo;
914 dst->next = src->next;
915 }
916
917 /************************************************************************/
918 /* ConvertValueToExpression: Converts the value stored in a data object */
919 /* into an expression. For multifield values, a chain of expressions */
920 /* is generated and the chain is linked by the nextArg field. For a */
921 /* single field value, a single expression is created. */
922 /************************************************************************/
ConvertValueToExpression(void * theEnv,DATA_OBJECT * theValue)923 globle struct expr *ConvertValueToExpression(
924 void *theEnv,
925 DATA_OBJECT *theValue)
926 {
927 long i;
928 struct expr *head = NULL, *last = NULL, *newItem;
929
930 if (GetpType(theValue) != MULTIFIELD)
931 { return(GenConstant(theEnv,GetpType(theValue),GetpValue(theValue))); }
932
933 for (i = GetpDOBegin(theValue); i <= GetpDOEnd(theValue); i++)
934 {
935 newItem = GenConstant(theEnv,GetMFType(GetpValue(theValue),i),
936 GetMFValue(GetpValue(theValue),i));
937 if (last == NULL) head = newItem;
938 else last->nextArg = newItem;
939 last = newItem;
940 }
941
942 if (head == NULL)
943 return(GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$")));
944
945 return(head);
946 }
947
948 /****************************************/
949 /* GetAtomicHashValue: Returns the hash */
950 /* value for an atomic data type. */
951 /****************************************/
GetAtomicHashValue(unsigned short type,void * value,int position)952 unsigned long GetAtomicHashValue(
953 unsigned short type,
954 void *value,
955 int position)
956 {
957 unsigned long tvalue;
958 union
959 {
960 double fv;
961 void *vv;
962 unsigned long liv;
963 } fis;
964
965 switch (type)
966 {
967 case FLOAT:
968 fis.liv = 0;
969 fis.fv = ValueToDouble(value);
970 tvalue = fis.liv;
971 break;
972
973 case INTEGER:
974 tvalue = (unsigned long) ValueToLong(value);
975 break;
976
977 case EXTERNAL_ADDRESS:
978 fis.liv = 0;
979 fis.vv = ValueToExternalAddress(value);
980 tvalue = (unsigned long) fis.liv;
981 break;
982
983 case FACT_ADDRESS:
984 #if OBJECT_SYSTEM
985 case INSTANCE_ADDRESS:
986 #endif
987 fis.liv = 0;
988 fis.vv = value;
989 tvalue = (unsigned long) fis.liv;
990 break;
991
992 case STRING:
993 #if OBJECT_SYSTEM
994 case INSTANCE_NAME:
995 #endif
996 case SYMBOL:
997 tvalue = ((SYMBOL_HN *) value)->bucket;
998 break;
999
1000 default:
1001 tvalue = type;
1002 }
1003
1004 if (position < 0) return(tvalue);
1005
1006 return((unsigned long) (tvalue * (((unsigned long) position) + 29)));
1007 }
1008
1009 /***********************************************************/
1010 /* FunctionReferenceExpression: Returns an expression with */
1011 /* an appropriate expression reference to the specified */
1012 /* name if it is the name of a deffunction, defgeneric, */
1013 /* or user/system defined function. */
1014 /***********************************************************/
FunctionReferenceExpression(void * theEnv,const char * name)1015 globle struct expr *FunctionReferenceExpression(
1016 void *theEnv,
1017 const char *name)
1018 {
1019 #if DEFGENERIC_CONSTRUCT
1020 void *gfunc;
1021 #endif
1022 #if DEFFUNCTION_CONSTRUCT
1023 void *dptr;
1024 #endif
1025 struct FunctionDefinition *fptr;
1026
1027 /*=====================================================*/
1028 /* Check to see if the function call is a deffunction. */
1029 /*=====================================================*/
1030
1031 #if DEFFUNCTION_CONSTRUCT
1032 if ((dptr = (void *) LookupDeffunctionInScope(theEnv,name)) != NULL)
1033 { return(GenConstant(theEnv,PCALL,dptr)); }
1034 #endif
1035
1036 /*====================================================*/
1037 /* Check to see if the function call is a defgeneric. */
1038 /*====================================================*/
1039
1040 #if DEFGENERIC_CONSTRUCT
1041 if ((gfunc = (void *) LookupDefgenericInScope(theEnv,name)) != NULL)
1042 { return(GenConstant(theEnv,GCALL,gfunc)); }
1043 #endif
1044
1045 /*======================================*/
1046 /* Check to see if the function call is */
1047 /* a system or user defined function. */
1048 /*======================================*/
1049
1050 if ((fptr = FindFunction(theEnv,name)) != NULL)
1051 { return(GenConstant(theEnv,FCALL,fptr)); }
1052
1053 /*===================================================*/
1054 /* The specified function name is not a deffunction, */
1055 /* defgeneric, or user/system defined function. */
1056 /*===================================================*/
1057
1058 return(NULL);
1059 }
1060
1061 /******************************************************************/
1062 /* GetFunctionReference: Fills an expression with an appropriate */
1063 /* expression reference to the specified name if it is the */
1064 /* name of a deffunction, defgeneric, or user/system defined */
1065 /* function. */
1066 /******************************************************************/
GetFunctionReference(void * theEnv,const char * name,FUNCTION_REFERENCE * theReference)1067 globle intBool GetFunctionReference(
1068 void *theEnv,
1069 const char *name,
1070 FUNCTION_REFERENCE *theReference)
1071 {
1072 #if DEFGENERIC_CONSTRUCT
1073 void *gfunc;
1074 #endif
1075 #if DEFFUNCTION_CONSTRUCT
1076 void *dptr;
1077 #endif
1078 struct FunctionDefinition *fptr;
1079
1080 theReference->nextArg = NULL;
1081 theReference->argList = NULL;
1082 theReference->type = RVOID;
1083 theReference->value = NULL;
1084
1085 /*=====================================================*/
1086 /* Check to see if the function call is a deffunction. */
1087 /*=====================================================*/
1088
1089 #if DEFFUNCTION_CONSTRUCT
1090 if ((dptr = (void *) LookupDeffunctionInScope(theEnv,name)) != NULL)
1091 {
1092 theReference->type = PCALL;
1093 theReference->value = dptr;
1094 return(TRUE);
1095 }
1096 #endif
1097
1098 /*====================================================*/
1099 /* Check to see if the function call is a defgeneric. */
1100 /*====================================================*/
1101
1102 #if DEFGENERIC_CONSTRUCT
1103 if ((gfunc = (void *) LookupDefgenericInScope(theEnv,name)) != NULL)
1104 {
1105 theReference->type = GCALL;
1106 theReference->value = gfunc;
1107 return(TRUE);
1108 }
1109 #endif
1110
1111 /*======================================*/
1112 /* Check to see if the function call is */
1113 /* a system or user defined function. */
1114 /*======================================*/
1115
1116 if ((fptr = FindFunction(theEnv,name)) != NULL)
1117 {
1118 theReference->type = FCALL;
1119 theReference->value = fptr;
1120 return(TRUE);
1121 }
1122
1123 /*===================================================*/
1124 /* The specified function name is not a deffunction, */
1125 /* defgeneric, or user/system defined function. */
1126 /*===================================================*/
1127
1128 return(FALSE);
1129 }
1130
1131 /*******************************************************/
1132 /* DOsEqual: Determines if two DATA_OBJECTS are equal. */
1133 /*******************************************************/
DOsEqual(DATA_OBJECT_PTR dobj1,DATA_OBJECT_PTR dobj2)1134 globle intBool DOsEqual(
1135 DATA_OBJECT_PTR dobj1,
1136 DATA_OBJECT_PTR dobj2)
1137 {
1138 if (GetpType(dobj1) != GetpType(dobj2))
1139 { return(FALSE); }
1140
1141 if (GetpType(dobj1) == MULTIFIELD)
1142 {
1143 if (MultifieldDOsEqual(dobj1,dobj2) == FALSE)
1144 { return(FALSE); }
1145 }
1146 else if (GetpValue(dobj1) != GetpValue(dobj2))
1147 { return(FALSE); }
1148
1149 return(TRUE);
1150 }
1151
1152 /***********************************************************
1153 NAME : EvaluateAndStoreInDataObject
1154 DESCRIPTION : Evaluates slot-value expressions
1155 and stores the result in a
1156 Kernel data object
1157 INPUTS : 1) Flag indicating if multifields are OK
1158 2) The value-expression
1159 3) The data object structure
1160 4) Flag indicating if a multifield value
1161 should be placed on the garbage list.
1162 RETURNS : FALSE on errors, TRUE otherwise
1163 SIDE EFFECTS : Segment allocated for storing
1164 multifield values
1165 NOTES : None
1166 ***********************************************************/
EvaluateAndStoreInDataObject(void * theEnv,int mfp,EXPRESSION * theExp,DATA_OBJECT * val,int garbageSegment)1167 globle int EvaluateAndStoreInDataObject(
1168 void *theEnv,
1169 int mfp,
1170 EXPRESSION *theExp,
1171 DATA_OBJECT *val,
1172 int garbageSegment)
1173 {
1174 val->type = MULTIFIELD;
1175 val->begin = 0;
1176 val->end = -1;
1177
1178 if (theExp == NULL)
1179 {
1180 if (garbageSegment) val->value = EnvCreateMultifield(theEnv,0L);
1181 else val->value = CreateMultifield2(theEnv,0L);
1182
1183 return(TRUE);
1184 }
1185
1186 if ((mfp == 0) && (theExp->nextArg == NULL))
1187 EvaluateExpression(theEnv,theExp,val);
1188 else
1189 StoreInMultifield(theEnv,val,theExp,garbageSegment);
1190
1191 return(EvaluationData(theEnv)->EvaluationError ? FALSE : TRUE);
1192 }
1193
1194 /*******************************************************/
1195 /* PrintCAddress: */
1196 /*******************************************************/
PrintCAddress(void * theEnv,const char * logicalName,void * theValue)1197 static void PrintCAddress(
1198 void *theEnv,
1199 const char *logicalName,
1200 void *theValue)
1201 {
1202 char buffer[20];
1203
1204 EnvPrintRouter(theEnv,logicalName,"<Pointer-C-");
1205
1206 gensprintf(buffer,"%p",ValueToExternalAddress(theValue));
1207 EnvPrintRouter(theEnv,logicalName,buffer);
1208 EnvPrintRouter(theEnv,logicalName,">");
1209 }
1210
1211 /****************/
1212 /* NewCAddress: */
1213 /****************/
NewCAddress(void * theEnv,DATA_OBJECT * rv)1214 static void NewCAddress(
1215 void *theEnv,
1216 DATA_OBJECT *rv)
1217 {
1218 int numberOfArguments;
1219
1220 numberOfArguments = EnvRtnArgCount(theEnv);
1221
1222 if (numberOfArguments != 1)
1223 {
1224 PrintErrorID(theEnv,"NEW",1,FALSE);
1225 EnvPrintRouter(theEnv,WERROR,"Function new expected no additional arguments for the C external language type.\n");
1226 SetEvaluationError(theEnv,TRUE);
1227 return;
1228 }
1229
1230 SetpType(rv,EXTERNAL_ADDRESS);
1231 SetpValue(rv,EnvAddExternalAddress(theEnv,NULL,0));
1232 }
1233
1234 /*******************************************************/
1235 /* DiscardCAddress: TBD Remove */
1236 /*******************************************************/
1237 /*
1238 static intBool DiscardCAddress(
1239 void *theEnv,
1240 void *theValue)
1241 {
1242 EnvPrintRouter(theEnv,WDISPLAY,"Discarding C Address\n");
1243
1244 return TRUE;
1245 }
1246 */
1247
1248 /*##################################*/
1249 /* Additional Environment Functions */
1250 /*##################################*/
1251
1252 #if ALLOW_ENVIRONMENT_GLOBALS
1253
SetMultifieldErrorValue(DATA_OBJECT_PTR returnValue)1254 globle void SetMultifieldErrorValue(
1255 DATA_OBJECT_PTR returnValue)
1256 {
1257 EnvSetMultifieldErrorValue(GetCurrentEnvironment(),returnValue);
1258 }
1259
FunctionCall(const char * name,const char * args,DATA_OBJECT * result)1260 globle int FunctionCall(
1261 const char *name,
1262 const char *args,
1263 DATA_OBJECT *result)
1264 {
1265 return EnvFunctionCall(GetCurrentEnvironment(),name,args,result);
1266 }
1267
1268 #endif /* ALLOW_ENVIRONMENT_GLOBALS */
1269
1270