1    /*******************************************************/
2    /*      "C" Language Integrated Production System      */
3    /*                                                     */
4    /*             CLIPS Version 6.30  08/16/14            */
5    /*                                                     */
6    /*             PROCEDURAL FUNCTIONS MODULE             */
7    /*******************************************************/
8 
9 /*************************************************************/
10 /* Purpose: Contains the code for several procedural         */
11 /*   functions including if, while, loop-for-count, bind,    */
12 /*   progn, return, break, and switch                        */
13 /*                                                           */
14 /* Principal Programmer(s):                                  */
15 /*      Gary D. Riley                                        */
16 /*      Brian L. Dantes                                      */
17 /*                                                           */
18 /* Contributing Programmer(s):                               */
19 /*                                                           */
20 /* Revision History:                                         */
21 /*                                                           */
22 /*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
23 /*                                                           */
24 /*            Changed name of variable exp to theExp         */
25 /*            because of Unix compiler warnings of shadowed  */
26 /*            definitions.                                   */
27 /*                                                           */
28 /*      6.24: Renamed BOOLEAN macro type to intBool.         */
29 /*                                                           */
30 /*      6.30: Local variables set with the bind function     */
31 /*            persist until a reset/clear command is issued. */
32 /*                                                           */
33 /*            Changed garbage collection algorithm.          */
34 /*                                                           */
35 /*            Support for long long integers.                */
36 /*                                                           */
37 /*************************************************************/
38 
39 #define _PRCDRFUN_SOURCE_
40 
41 #include <stdio.h>
42 #define _STDIO_INCLUDED_
43 
44 #include "setup.h"
45 
46 #include "argacces.h"
47 #include "constrnt.h"
48 #include "cstrnchk.h"
49 #include "cstrnops.h"
50 #include "envrnmnt.h"
51 #include "exprnpsr.h"
52 #include "memalloc.h"
53 #include "multifld.h"
54 #include "prcdrpsr.h"
55 #include "router.h"
56 #include "scanner.h"
57 #include "utility.h"
58 
59 #include "prcdrfun.h"
60 
61 #if DEFGLOBAL_CONSTRUCT
62 #include "globldef.h"
63 #endif
64 
65 /***************************************/
66 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
67 /***************************************/
68 
69    static void                    DeallocateProceduralFunctionData(void *);
70 
71 /**********************************************/
72 /* ProceduralFunctionDefinitions: Initializes */
73 /*   the procedural functions.                */
74 /**********************************************/
ProceduralFunctionDefinitions(void * theEnv)75 globle void ProceduralFunctionDefinitions(
76   void *theEnv)
77   {
78    AllocateEnvironmentData(theEnv,PRCDRFUN_DATA,sizeof(struct procedureFunctionData),DeallocateProceduralFunctionData);
79 
80 #if ! RUN_TIME
81    EnvDefineFunction2(theEnv,"if", 'u', PTIEF IfFunction, "IfFunction", NULL);
82    EnvDefineFunction2(theEnv,"while", 'u', PTIEF WhileFunction, "WhileFunction", NULL);
83    EnvDefineFunction2(theEnv,"loop-for-count",'u', PTIEF LoopForCountFunction, "LoopForCountFunction", NULL);
84    EnvDefineFunction2(theEnv,"(get-loop-count)",'g', PTIEF GetLoopCount, "GetLoopCount", NULL);
85    EnvDefineFunction2(theEnv,"bind", 'u', PTIEF BindFunction, "BindFunction", NULL);
86    EnvDefineFunction2(theEnv,"progn", 'u', PTIEF PrognFunction, "PrognFunction", NULL);
87    EnvDefineFunction2(theEnv,"return", 'u', PTIEF ReturnFunction, "ReturnFunction",NULL);
88    EnvDefineFunction2(theEnv,"break", 'v', PTIEF BreakFunction, "BreakFunction",NULL);
89    EnvDefineFunction2(theEnv,"switch", 'u', PTIEF SwitchFunction, "SwitchFunction",NULL);
90 
91    ProceduralFunctionParsers(theEnv);
92 
93    FuncSeqOvlFlags(theEnv,"progn",FALSE,FALSE);
94    FuncSeqOvlFlags(theEnv,"if",FALSE,FALSE);
95    FuncSeqOvlFlags(theEnv,"while",FALSE,FALSE);
96    FuncSeqOvlFlags(theEnv,"loop-for-count",FALSE,FALSE);
97    FuncSeqOvlFlags(theEnv,"return",FALSE,FALSE);
98    FuncSeqOvlFlags(theEnv,"switch",FALSE,FALSE);
99 #endif
100 
101    EnvAddResetFunction(theEnv,"bind",FlushBindList,0);
102    EnvAddClearFunction(theEnv,"bind",FlushBindList,0);
103   }
104 
105 /*************************************************************/
106 /* DeallocateProceduralFunctionData: Deallocates environment */
107 /*    data for procedural functions.                         */
108 /*************************************************************/
DeallocateProceduralFunctionData(void * theEnv)109 static void DeallocateProceduralFunctionData(
110   void *theEnv)
111   {
112    DATA_OBJECT_PTR nextPtr, garbagePtr;
113 
114    garbagePtr = ProcedureFunctionData(theEnv)->BindList;
115 
116    while (garbagePtr != NULL)
117      {
118       nextPtr = garbagePtr->next;
119       rtn_struct(theEnv,dataObject,garbagePtr);
120       garbagePtr = nextPtr;
121      }
122   }
123 
124 /***************************************/
125 /* WhileFunction: H/L access routine   */
126 /*   for the while function.           */
127 /***************************************/
WhileFunction(void * theEnv,DATA_OBJECT_PTR returnValue)128 globle void WhileFunction(
129   void *theEnv,
130   DATA_OBJECT_PTR returnValue)
131   {
132    DATA_OBJECT theResult;
133    struct garbageFrame newGarbageFrame;
134    struct garbageFrame *oldGarbageFrame;
135 
136    /*====================================================*/
137    /* Evaluate the body of the while loop as long as the */
138    /* while condition evaluates to a non-FALSE value.    */
139    /*====================================================*/
140 
141    oldGarbageFrame = UtilityData(theEnv)->CurrentGarbageFrame;
142    memset(&newGarbageFrame,0,sizeof(struct garbageFrame));
143    newGarbageFrame.priorFrame = oldGarbageFrame;
144    UtilityData(theEnv)->CurrentGarbageFrame = &newGarbageFrame;
145 
146    EnvRtnUnknown(theEnv,1,&theResult);
147    while (((theResult.value != EnvFalseSymbol(theEnv)) ||
148            (theResult.type != SYMBOL)) &&
149            (EvaluationData(theEnv)->HaltExecution != TRUE))
150      {
151       if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
152         break;
153 
154       EnvRtnUnknown(theEnv,2,&theResult);
155 
156       if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
157         break;
158 
159       CleanCurrentGarbageFrame(theEnv,NULL);
160       CallPeriodicTasks(theEnv);
161 
162       EnvRtnUnknown(theEnv,1,&theResult);
163      }
164 
165    /*=====================================================*/
166    /* Reset the break flag. The return flag is not reset  */
167    /* because the while loop is probably contained within */
168    /* a deffunction or RHS of a rule which needs to be    */
169    /* returned from as well.                              */
170    /*=====================================================*/
171 
172    ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
173 
174    /*====================================================*/
175    /* If the return command was issued, then return that */
176    /* value, otherwise return the symbol FALSE.          */
177    /*====================================================*/
178 
179    if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
180      {
181       returnValue->type = theResult.type;
182       returnValue->value = theResult.value;
183       returnValue->begin = theResult.begin;
184       returnValue->end = theResult.end;
185      }
186    else
187      {
188       returnValue->type = SYMBOL;
189       returnValue->value = EnvFalseSymbol(theEnv);
190      }
191 
192    RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,returnValue);
193    CallPeriodicTasks(theEnv);
194   }
195 
196 /********************************************/
197 /* LoopForCountFunction: H/L access routine */
198 /*   for the loop-for-count function.       */
199 /********************************************/
LoopForCountFunction(void * theEnv,DATA_OBJECT_PTR loopResult)200 globle void LoopForCountFunction(
201   void *theEnv,
202   DATA_OBJECT_PTR loopResult)
203   {
204    DATA_OBJECT arg_ptr;
205    long long iterationEnd;
206    LOOP_COUNTER_STACK *tmpCounter;
207    struct garbageFrame newGarbageFrame;
208    struct garbageFrame *oldGarbageFrame;
209 
210    tmpCounter = get_struct(theEnv,loopCounterStack);
211    tmpCounter->loopCounter = 0L;
212    tmpCounter->nxt = ProcedureFunctionData(theEnv)->LoopCounterStack;
213    ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter;
214    if (EnvArgTypeCheck(theEnv,"loop-for-count",1,INTEGER,&arg_ptr) == FALSE)
215      {
216       loopResult->type = SYMBOL;
217       loopResult->value = EnvFalseSymbol(theEnv);
218       ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter->nxt;
219       rtn_struct(theEnv,loopCounterStack,tmpCounter);
220       return;
221      }
222    tmpCounter->loopCounter = DOToLong(arg_ptr);
223    if (EnvArgTypeCheck(theEnv,"loop-for-count",2,INTEGER,&arg_ptr) == FALSE)
224      {
225       loopResult->type = SYMBOL;
226       loopResult->value = EnvFalseSymbol(theEnv);
227       ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter->nxt;
228       rtn_struct(theEnv,loopCounterStack,tmpCounter);
229       return;
230      }
231 
232    oldGarbageFrame = UtilityData(theEnv)->CurrentGarbageFrame;
233    memset(&newGarbageFrame,0,sizeof(struct garbageFrame));
234    newGarbageFrame.priorFrame = oldGarbageFrame;
235    UtilityData(theEnv)->CurrentGarbageFrame = &newGarbageFrame;
236 
237    iterationEnd = DOToLong(arg_ptr);
238    while ((tmpCounter->loopCounter <= iterationEnd) &&
239           (EvaluationData(theEnv)->HaltExecution != TRUE))
240      {
241       if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
242         break;
243 
244       EnvRtnUnknown(theEnv,3,&arg_ptr);
245 
246       if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
247         break;
248 
249       CleanCurrentGarbageFrame(theEnv,NULL);
250       CallPeriodicTasks(theEnv);
251 
252       tmpCounter->loopCounter++;
253      }
254 
255    ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
256    if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
257      {
258       loopResult->type = arg_ptr.type;
259       loopResult->value = arg_ptr.value;
260       loopResult->begin = arg_ptr.begin;
261       loopResult->end = arg_ptr.end;
262      }
263    else
264      {
265       loopResult->type = SYMBOL;
266       loopResult->value = EnvFalseSymbol(theEnv);
267      }
268    ProcedureFunctionData(theEnv)->LoopCounterStack = tmpCounter->nxt;
269    rtn_struct(theEnv,loopCounterStack,tmpCounter);
270 
271    RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,loopResult);
272    CallPeriodicTasks(theEnv);
273   }
274 
275 /*****************/
276 /* GetLoopCount: */
277 /*****************/
GetLoopCount(void * theEnv)278 globle long long GetLoopCount(
279   void *theEnv)
280   {
281    int depth;
282    LOOP_COUNTER_STACK *tmpCounter;
283 
284    depth = ValueToInteger(GetFirstArgument()->value);
285    tmpCounter = ProcedureFunctionData(theEnv)->LoopCounterStack;
286    while (depth > 0)
287      {
288       tmpCounter = tmpCounter->nxt;
289       depth--;
290      }
291    return(tmpCounter->loopCounter);
292   }
293 
294 /************************************/
295 /* IfFunction: H/L access routine   */
296 /*   for the if function.           */
297 /************************************/
IfFunction(void * theEnv,DATA_OBJECT_PTR returnValue)298 globle void IfFunction(
299   void *theEnv,
300   DATA_OBJECT_PTR returnValue)
301   {
302    int numArgs;
303    struct expr *theExpr;
304 
305    /*============================================*/
306    /* Check for the correct number of arguments. */
307    /*============================================*/
308 
309    if ((EvaluationData(theEnv)->CurrentExpression->argList == NULL) ||
310        (EvaluationData(theEnv)->CurrentExpression->argList->nextArg == NULL))
311      {
312       EnvArgRangeCheck(theEnv,"if",2,3);
313       returnValue->type = SYMBOL;
314       returnValue->value = EnvFalseSymbol(theEnv);
315       return;
316      }
317 
318    if (EvaluationData(theEnv)->CurrentExpression->argList->nextArg->nextArg == NULL)
319      { numArgs = 2; }
320    else if (EvaluationData(theEnv)->CurrentExpression->argList->nextArg->nextArg->nextArg == NULL)
321      { numArgs = 3; }
322    else
323      {
324       EnvArgRangeCheck(theEnv,"if",2,3);
325       returnValue->type = SYMBOL;
326       returnValue->value = EnvFalseSymbol(theEnv);
327       return;
328      }
329 
330    /*=========================*/
331    /* Evaluate the condition. */
332    /*=========================*/
333 
334    EvaluateExpression(theEnv,EvaluationData(theEnv)->CurrentExpression->argList,returnValue);
335 
336    if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
337      {
338       returnValue->type = SYMBOL;
339       returnValue->value = EnvFalseSymbol(theEnv);
340       return;
341      }
342 
343    /*=========================================*/
344    /* If the condition evaluated to FALSE and */
345    /* an "else" portion exists, evaluate it   */
346    /* and return the value.                   */
347    /*=========================================*/
348 
349    if ((returnValue->value == EnvFalseSymbol(theEnv)) &&
350        (returnValue->type == SYMBOL) &&
351        (numArgs == 3))
352      {
353       theExpr = EvaluationData(theEnv)->CurrentExpression->argList->nextArg->nextArg;
354       switch (theExpr->type)
355         {
356          case INTEGER:
357          case FLOAT:
358          case SYMBOL:
359          case STRING:
360 #if OBJECT_SYSTEM
361          case INSTANCE_NAME:
362          case INSTANCE_ADDRESS:
363 #endif
364          case EXTERNAL_ADDRESS:
365            returnValue->type = theExpr->type;
366            returnValue->value = theExpr->value;
367            break;
368 
369          default:
370            EvaluateExpression(theEnv,theExpr,returnValue);
371            break;
372         }
373       return;
374      }
375 
376    /*===================================================*/
377    /* Otherwise if the symbol evaluated to a non-FALSE  */
378    /* value, evaluate the "then" portion and return it. */
379    /*===================================================*/
380 
381    else if ((returnValue->value != EnvFalseSymbol(theEnv)) ||
382             (returnValue->type != SYMBOL))
383      {
384       theExpr = EvaluationData(theEnv)->CurrentExpression->argList->nextArg;
385       switch (theExpr->type)
386         {
387          case INTEGER:
388          case FLOAT:
389          case SYMBOL:
390          case STRING:
391 #if OBJECT_SYSTEM
392          case INSTANCE_NAME:
393          case INSTANCE_ADDRESS:
394 #endif
395          case EXTERNAL_ADDRESS:
396            returnValue->type = theExpr->type;
397            returnValue->value = theExpr->value;
398            break;
399 
400          default:
401            EvaluateExpression(theEnv,theExpr,returnValue);
402            break;
403         }
404       return;
405      }
406 
407    /*=========================================*/
408    /* Return FALSE if the condition evaluated */
409    /* to FALSE and there is no "else" portion */
410    /* of the if statement.                    */
411    /*=========================================*/
412 
413    returnValue->type = SYMBOL;
414    returnValue->value = EnvFalseSymbol(theEnv);
415    return;
416   }
417 
418 /**************************************/
419 /* BindFunction: H/L access routine   */
420 /*   for the bind function.           */
421 /**************************************/
BindFunction(void * theEnv,DATA_OBJECT_PTR returnValue)422 globle void BindFunction(
423   void *theEnv,
424   DATA_OBJECT_PTR returnValue)
425   {
426    DATA_OBJECT *theBind, *lastBind;
427    int found = FALSE,
428        unbindVar = FALSE;
429    SYMBOL_HN *variableName = NULL;
430 #if DEFGLOBAL_CONSTRUCT
431    struct defglobal *theGlobal = NULL;
432 #endif
433 
434    /*===============================================*/
435    /* Determine the name of the variable to be set. */
436    /*===============================================*/
437 
438 #if DEFGLOBAL_CONSTRUCT
439    if (GetFirstArgument()->type == DEFGLOBAL_PTR)
440      { theGlobal = (struct defglobal *) GetFirstArgument()->value; }
441    else
442 #endif
443      {
444       EvaluateExpression(theEnv,GetFirstArgument(),returnValue);
445       variableName = (SYMBOL_HN *) DOPToPointer(returnValue);
446      }
447 
448    /*===========================================*/
449    /* Determine the new value for the variable. */
450    /*===========================================*/
451 
452    if (GetFirstArgument()->nextArg == NULL)
453      { unbindVar = TRUE; }
454    else if (GetFirstArgument()->nextArg->nextArg == NULL)
455      { EvaluateExpression(theEnv,GetFirstArgument()->nextArg,returnValue); }
456    else
457      { StoreInMultifield(theEnv,returnValue,GetFirstArgument()->nextArg,TRUE); }
458 
459    /*==================================*/
460    /* Bind a defglobal if appropriate. */
461    /*==================================*/
462 
463 #if DEFGLOBAL_CONSTRUCT
464    if (theGlobal != NULL)
465      {
466       QSetDefglobalValue(theEnv,theGlobal,returnValue,unbindVar);
467       return;
468      }
469 #endif
470 
471    /*===============================================*/
472    /* Search for the variable in the list of binds. */
473    /*===============================================*/
474 
475    theBind = ProcedureFunctionData(theEnv)->BindList;
476    lastBind = NULL;
477 
478    while ((theBind != NULL) && (found == FALSE))
479      {
480       if (theBind->supplementalInfo == (void *) variableName)
481         { found = TRUE; }
482       else
483         {
484          lastBind = theBind;
485          theBind = theBind->next;
486         }
487      }
488 
489    /*========================================================*/
490    /* If variable was not in the list of binds, then add it. */
491    /* Make sure that this operation preserves the bind list  */
492    /* as a stack.                                            */
493    /*========================================================*/
494 
495    if (found == FALSE)
496      {
497       if (unbindVar == FALSE)
498         {
499          theBind = get_struct(theEnv,dataObject);
500          theBind->supplementalInfo = (void *) variableName;
501          IncrementSymbolCount(variableName);
502          theBind->next = NULL;
503          if (lastBind == NULL)
504            { ProcedureFunctionData(theEnv)->BindList = theBind; }
505          else
506            { lastBind->next = theBind; }
507         }
508       else
509         {
510          returnValue->type = SYMBOL;
511          returnValue->value = EnvFalseSymbol(theEnv);
512          return;
513         }
514      }
515    else
516      { ValueDeinstall(theEnv,theBind); }
517 
518    /*================================*/
519    /* Set the value of the variable. */
520    /*================================*/
521 
522    if (unbindVar == FALSE)
523      {
524       theBind->type = returnValue->type;
525       theBind->value = returnValue->value;
526       theBind->begin = returnValue->begin;
527       theBind->end = returnValue->end;
528       ValueInstall(theEnv,returnValue);
529      }
530    else
531      {
532       if (lastBind == NULL) ProcedureFunctionData(theEnv)->BindList = theBind->next;
533       else lastBind->next = theBind->next;
534       DecrementSymbolCount(theEnv,(struct symbolHashNode *) theBind->supplementalInfo);
535       rtn_struct(theEnv,dataObject,theBind);
536       returnValue->type = SYMBOL;
537       returnValue->value = EnvFalseSymbol(theEnv);
538      }
539   }
540 
541 /*******************************************/
542 /* GetBoundVariable: Searches the BindList */
543 /*   for a specified variable.             */
544 /*******************************************/
GetBoundVariable(void * theEnv,DATA_OBJECT_PTR vPtr,SYMBOL_HN * varName)545 globle intBool GetBoundVariable(
546   void *theEnv,
547   DATA_OBJECT_PTR vPtr,
548   SYMBOL_HN *varName)
549   {
550    DATA_OBJECT_PTR bindPtr;
551 
552    for (bindPtr = ProcedureFunctionData(theEnv)->BindList; bindPtr != NULL; bindPtr = bindPtr->next)
553      {
554       if (bindPtr->supplementalInfo == (void *) varName)
555         {
556          vPtr->type = bindPtr->type;
557          vPtr->value = bindPtr->value;
558          vPtr->begin = bindPtr->begin;
559          vPtr->end = bindPtr->end;
560          return(TRUE);
561         }
562      }
563 
564    return(FALSE);
565   }
566 
567 /*************************************************/
568 /* FlushBindList: Removes all variables from the */
569 /*   list of currently bound local variables.    */
570 /*************************************************/
FlushBindList(void * theEnv)571 globle void FlushBindList(
572   void *theEnv)
573   {
574    ReturnValues(theEnv,ProcedureFunctionData(theEnv)->BindList,TRUE);
575    ProcedureFunctionData(theEnv)->BindList = NULL;
576   }
577 
578 /***************************************/
579 /* PrognFunction: H/L access routine   */
580 /*   for the progn function.           */
581 /***************************************/
PrognFunction(void * theEnv,DATA_OBJECT_PTR returnValue)582 globle void PrognFunction(
583   void *theEnv,
584   DATA_OBJECT_PTR returnValue)
585   {
586    struct expr *argPtr;
587 
588    argPtr = EvaluationData(theEnv)->CurrentExpression->argList;
589 
590    if (argPtr == NULL)
591      {
592       returnValue->type = SYMBOL;
593       returnValue->value = EnvFalseSymbol(theEnv);
594       return;
595      }
596 
597    while ((argPtr != NULL) && (GetHaltExecution(theEnv) != TRUE))
598      {
599       EvaluateExpression(theEnv,argPtr,returnValue);
600 
601       if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
602         break;
603       argPtr = argPtr->nextArg;
604      }
605 
606    if (GetHaltExecution(theEnv) == TRUE)
607      {
608       returnValue->type = SYMBOL;
609       returnValue->value = EnvFalseSymbol(theEnv);
610       return;
611      }
612 
613    return;
614   }
615 
616 /*****************************************************************/
617 /* ReturnFunction: H/L access routine for the return function.   */
618 /*****************************************************************/
ReturnFunction(void * theEnv,DATA_OBJECT_PTR result)619 globle void ReturnFunction(
620   void *theEnv,
621   DATA_OBJECT_PTR result)
622   {
623    if (EnvRtnArgCount(theEnv) == 0)
624      {
625       result->type = RVOID;
626       result->value = EnvFalseSymbol(theEnv);
627      }
628    else
629      EnvRtnUnknown(theEnv,1,result);
630    ProcedureFunctionData(theEnv)->ReturnFlag = TRUE;
631   }
632 
633 /***************************************************************/
634 /* BreakFunction: H/L access routine for the break function.   */
635 /***************************************************************/
BreakFunction(void * theEnv)636 globle void BreakFunction(
637   void *theEnv)
638   {
639    ProcedureFunctionData(theEnv)->BreakFlag = TRUE;
640   }
641 
642 /*****************************************************************/
643 /* SwitchFunction: H/L access routine for the switch function.   */
644 /*****************************************************************/
SwitchFunction(void * theEnv,DATA_OBJECT_PTR result)645 globle void SwitchFunction(
646   void *theEnv,
647   DATA_OBJECT_PTR result)
648   {
649    DATA_OBJECT switch_val,case_val;
650    EXPRESSION *theExp;
651 
652    result->type = SYMBOL;
653    result->value = EnvFalseSymbol(theEnv);
654 
655    /* ==========================
656       Get the value to switch on
657       ========================== */
658    EvaluateExpression(theEnv,GetFirstArgument(),&switch_val);
659    if (EvaluationData(theEnv)->EvaluationError)
660      return;
661    for (theExp = GetFirstArgument()->nextArg ; theExp != NULL ; theExp = theExp->nextArg->nextArg)
662      {
663       /* =================================================
664          RVOID is the default case (if any) for the switch
665          ================================================= */
666       if (theExp->type == RVOID)
667         {
668          EvaluateExpression(theEnv,theExp->nextArg,result);
669          return;
670         }
671 
672       /* ====================================================
673          If the case matches, evaluate the actions and return
674          ==================================================== */
675       EvaluateExpression(theEnv,theExp,&case_val);
676       if (EvaluationData(theEnv)->EvaluationError)
677         return;
678       if (switch_val.type == case_val.type)
679         {
680          if ((case_val.type == MULTIFIELD) ? MultifieldDOsEqual(&switch_val,&case_val) :
681              (switch_val.value == case_val.value))
682            {
683             EvaluateExpression(theEnv,theExp->nextArg,result);
684             return;
685            }
686         }
687      }
688   }
689 
690 
691 
692 
693 
694