1    /*******************************************************/
2    /*      "C" Language Integrated Production System      */
3    /*                                                     */
4    /*             CLIPS Version 6.30  08/16/14            */
5    /*                                                     */
6    /*          PROCEDURAL FUNCTIONS PARSER MODULE         */
7    /*******************************************************/
8 
9 /*************************************************************/
10 /* Purpose:                                                  */
11 /*                                                           */
12 /* Principal Programmer(s):                                  */
13 /*      Gary D. Riley                                        */
14 /*      Brian L. Dantes                                      */
15 /*                                                           */
16 /* Contributing Programmer(s):                               */
17 /*                                                           */
18 /* Revision History:                                         */
19 /*                                                           */
20 /*      6.23: Changed name of variable exp to theExp         */
21 /*            because of Unix compiler warnings of shadowed  */
22 /*            definitions.                                   */
23 /*                                                           */
24 /*      6.24: Renamed BOOLEAN macro type to intBool.         */
25 /*                                                           */
26 /*      6.30: Local variables set with the bind function     */
27 /*            persist until a reset/clear command is issued. */
28 /*                                                           */
29 /*            Support for long long integers.                */
30 /*                                                           */
31 /*            Added const qualifiers to remove C++           */
32 /*            deprecation warnings.                          */
33 /*                                                           */
34 /*            Fixed linkage issue when BLOAD_ONLY compiler   */
35 /*            flag is set to 1.                              */
36 /*                                                           */
37 /*************************************************************/
38 
39 #define _PRCDRPSR_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 "cstrnutl.h"
51 #include "envrnmnt.h"
52 #include "exprnpsr.h"
53 #include "memalloc.h"
54 #include "modulutl.h"
55 #include "multifld.h"
56 #include "router.h"
57 #include "scanner.h"
58 #include "utility.h"
59 
60 #include "prcdrpsr.h"
61 
62 #if DEFGLOBAL_CONSTRUCT
63 #include "globldef.h"
64 #include "globlpsr.h"
65 #endif
66 
67 #if ! RUN_TIME
68 #define PRCDRPSR_DATA 12
69 
70 struct procedureParserData
71   {
72    struct BindInfo *ListOfParsedBindNames;
73   };
74 
75 #define ProcedureParserData(theEnv) ((struct procedureParserData *) GetEnvironmentData(theEnv,PRCDRPSR_DATA))
76 #endif
77 
78 /***************************************/
79 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
80 /***************************************/
81 
82 #if (! RUN_TIME)
83    static void                    DeallocateProceduralFunctionData(void *);
84 #if (! BLOAD_ONLY)
85    static struct expr            *WhileParse(void *,struct expr *,const char *);
86    static struct expr            *LoopForCountParse(void *,struct expr *,const char *);
87    static void                    ReplaceLoopCountVars(void *,SYMBOL_HN *,EXPRESSION *,int);
88    static struct expr            *IfParse(void *,struct expr *,const char *);
89    static struct expr            *PrognParse(void *,struct expr *,const char *);
90    static struct expr            *BindParse(void *,struct expr *,const char *);
91    static int                     AddBindName(void *,struct symbolHashNode *,CONSTRAINT_RECORD *);
92    static struct expr            *ReturnParse(void *,struct expr *,const char *);
93    static struct expr            *BreakParse(void *,struct expr *,const char *);
94    static struct expr            *SwitchParse(void *,struct expr *,const char *);
95 #endif
96 #endif
97 
98 #if ! RUN_TIME
99 /*******************************************/
100 /* ProceduralFunctionParsers        */
101 /*******************************************/
ProceduralFunctionParsers(void * theEnv)102 globle void ProceduralFunctionParsers(
103   void *theEnv)
104   {
105    AllocateEnvironmentData(theEnv,PRCDRPSR_DATA,sizeof(struct procedureParserData),DeallocateProceduralFunctionData);
106 
107 #if (! BLOAD_ONLY)
108    AddFunctionParser(theEnv,"bind",BindParse);
109    AddFunctionParser(theEnv,"progn",PrognParse);
110    AddFunctionParser(theEnv,"if",IfParse);
111    AddFunctionParser(theEnv,"while",WhileParse);
112    AddFunctionParser(theEnv,"loop-for-count",LoopForCountParse);
113    AddFunctionParser(theEnv,"return",ReturnParse);
114    AddFunctionParser(theEnv,"break",BreakParse);
115    AddFunctionParser(theEnv,"switch",SwitchParse);
116 #endif
117   }
118 
119 /*************************************************************/
120 /* DeallocateProceduralFunctionData: Deallocates environment */
121 /*    data for procedural functions.                         */
122 /*************************************************************/
DeallocateProceduralFunctionData(void * theEnv)123 static void DeallocateProceduralFunctionData(
124   void *theEnv)
125   {
126    struct BindInfo *temp_bind;
127 
128    while (ProcedureParserData(theEnv)->ListOfParsedBindNames != NULL)
129      {
130       temp_bind = ProcedureParserData(theEnv)->ListOfParsedBindNames->next;
131       rtn_struct(theEnv,BindInfo,ProcedureParserData(theEnv)->ListOfParsedBindNames);
132       ProcedureParserData(theEnv)->ListOfParsedBindNames = temp_bind;
133      }
134   }
135 
136 /********************************************************/
137 /* GetParsedBindNames:                                      */
138 /********************************************************/
GetParsedBindNames(void * theEnv)139 globle struct BindInfo *GetParsedBindNames(
140   void *theEnv)
141   {
142    return(ProcedureParserData(theEnv)->ListOfParsedBindNames);
143   }
144 
145 /********************************************************/
146 /* SetParsedBindNames:                                      */
147 /********************************************************/
SetParsedBindNames(void * theEnv,struct BindInfo * newValue)148 globle void SetParsedBindNames(
149   void *theEnv,
150   struct BindInfo *newValue)
151   {
152    ProcedureParserData(theEnv)->ListOfParsedBindNames = newValue;
153   }
154 
155 /********************************************************/
156 /* ClearParsedBindNames:                                     */
157 /********************************************************/
ClearParsedBindNames(void * theEnv)158 globle void ClearParsedBindNames(
159   void *theEnv)
160   {
161    struct BindInfo *temp_bind;
162 
163    while (ProcedureParserData(theEnv)->ListOfParsedBindNames != NULL)
164      {
165       temp_bind = ProcedureParserData(theEnv)->ListOfParsedBindNames->next;
166       RemoveConstraint(theEnv,ProcedureParserData(theEnv)->ListOfParsedBindNames->constraints);
167       rtn_struct(theEnv,BindInfo,ProcedureParserData(theEnv)->ListOfParsedBindNames);
168       ProcedureParserData(theEnv)->ListOfParsedBindNames = temp_bind;
169      }
170   }
171 
172 /********************************************************/
173 /* ParsedBindNamesEmpty:                                     */
174 /********************************************************/
ParsedBindNamesEmpty(void * theEnv)175 globle intBool ParsedBindNamesEmpty(
176   void *theEnv)
177   {
178    if (ProcedureParserData(theEnv)->ListOfParsedBindNames != NULL) return(FALSE);
179 
180    return(TRUE);
181   }
182 
183 #if (! BLOAD_ONLY)
184 
185 /*********************************************************/
186 /* WhileParse: purpose is to parse the while statement.  */
187 /*   The parse of the statement is the return value.     */
188 /*   Syntax: (while <expression> do <action>+)           */
189 /*********************************************************/
WhileParse(void * theEnv,struct expr * parse,const char * infile)190 static struct expr *WhileParse(
191   void *theEnv,
192   struct expr *parse,
193   const char *infile)
194   {
195    struct token theToken;
196    int read_first_paren;
197 
198    /*===============================*/
199    /* Process the while expression. */
200    /*===============================*/
201 
202    SavePPBuffer(theEnv," ");
203 
204    parse->argList = ParseAtomOrExpression(theEnv,infile,NULL);
205    if (parse->argList == NULL)
206      {
207       ReturnExpression(theEnv,parse);
208       return(NULL);
209      }
210 
211    /*====================================*/
212    /* Process the do keyword if present. */
213    /*====================================*/
214 
215    GetToken(theEnv,infile,&theToken);
216    if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
217      {
218       read_first_paren = TRUE;
219       PPBackup(theEnv);
220       SavePPBuffer(theEnv," ");
221       SavePPBuffer(theEnv,theToken.printForm);
222       IncrementIndentDepth(theEnv,3);
223       PPCRAndIndent(theEnv);
224      }
225    else if (theToken.type == LPAREN)
226      {
227       read_first_paren = FALSE;
228       PPBackup(theEnv);
229       IncrementIndentDepth(theEnv,3);
230       PPCRAndIndent(theEnv);
231       SavePPBuffer(theEnv,theToken.printForm);
232      }
233    else
234      {
235       SyntaxErrorMessage(theEnv,"while function");
236       ReturnExpression(theEnv,parse);
237       return(NULL);
238      }
239 
240    /*============================*/
241    /* Process the while actions. */
242    /*============================*/
243    if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
244      ExpressionData(theEnv)->ReturnContext = TRUE;
245    ExpressionData(theEnv)->BreakContext = TRUE;
246    parse->argList->nextArg = GroupActions(theEnv,infile,&theToken,read_first_paren,NULL,FALSE);
247 
248    if (parse->argList->nextArg == NULL)
249      {
250       ReturnExpression(theEnv,parse);
251       return(NULL);
252      }
253    PPBackup(theEnv);
254    PPBackup(theEnv);
255    SavePPBuffer(theEnv,theToken.printForm);
256 
257    /*=======================================================*/
258    /* Check for the closing right parenthesis of the while. */
259    /*=======================================================*/
260 
261    if (theToken.type != RPAREN)
262      {
263       SyntaxErrorMessage(theEnv,"while function");
264       ReturnExpression(theEnv,parse);
265       return(NULL);
266      }
267 
268    DecrementIndentDepth(theEnv,3);
269 
270    return(parse);
271   }
272 
273 /******************************************************************************************/
274 /* LoopForCountParse: purpose is to parse the loop-for-count statement.                   */
275 /*   The parse of the statement is the return value.                                      */
276 /*   Syntax: (loop-for-count <range> [do] <action>+)                                      */
277 /*           <range> ::= (<sf-var> [<start-integer-expression>] <end-integer-expression>) */
278 /******************************************************************************************/
LoopForCountParse(void * theEnv,struct expr * parse,const char * infile)279 static struct expr *LoopForCountParse(
280   void *theEnv,
281   struct expr *parse,
282   const char *infile)
283   {
284    struct token theToken;
285    SYMBOL_HN *loopVar = NULL;
286    EXPRESSION *tmpexp;
287    int read_first_paren;
288    struct BindInfo *oldBindList,*newBindList,*prev;
289 
290    /*======================================*/
291    /* Process the loop counter expression. */
292    /*======================================*/
293 
294    SavePPBuffer(theEnv," ");
295    GetToken(theEnv,infile,&theToken);
296 
297    /* ==========================================
298       Simple form: loop-for-count <end> [do] ...
299       ========================================== */
300    if (theToken.type != LPAREN)
301      {
302       parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1LL));
303       parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
304       if (parse->argList->nextArg == NULL)
305         {
306          ReturnExpression(theEnv,parse);
307          return(NULL);
308         }
309      }
310    else
311      {
312       GetToken(theEnv,infile,&theToken);
313       if (theToken.type != SF_VARIABLE)
314         {
315          if (theToken.type != SYMBOL)
316            goto LoopForCountParseError;
317          parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1LL));
318          parse->argList->nextArg = Function2Parse(theEnv,infile,ValueToString(theToken.value));
319          if (parse->argList->nextArg == NULL)
320            {
321             ReturnExpression(theEnv,parse);
322             return(NULL);
323            }
324         }
325 
326       /* =============================================================
327          Complex form: loop-for-count (<var> [<start>] <end>) [do] ...
328          ============================================================= */
329       else
330         {
331          loopVar = (SYMBOL_HN *) theToken.value;
332          SavePPBuffer(theEnv," ");
333          parse->argList = ParseAtomOrExpression(theEnv,infile,NULL);
334          if (parse->argList == NULL)
335            {
336             ReturnExpression(theEnv,parse);
337             return(NULL);
338            }
339          if (CheckArgumentAgainstRestriction(theEnv,parse->argList,(int) 'i'))
340            goto LoopForCountParseError;
341          SavePPBuffer(theEnv," ");
342          GetToken(theEnv,infile,&theToken);
343          if (theToken.type == RPAREN)
344            {
345             PPBackup(theEnv);
346             PPBackup(theEnv);
347             SavePPBuffer(theEnv,theToken.printForm);
348             tmpexp = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1LL));
349             tmpexp->nextArg = parse->argList;
350             parse->argList = tmpexp;
351            }
352          else
353           {
354             parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
355             if (parse->argList->nextArg == NULL)
356               {
357                ReturnExpression(theEnv,parse);
358                return(NULL);
359               }
360             GetToken(theEnv,infile,&theToken);
361             if (theToken.type != RPAREN)
362               goto LoopForCountParseError;
363            }
364          SavePPBuffer(theEnv," ");
365         }
366      }
367 
368    if (CheckArgumentAgainstRestriction(theEnv,parse->argList->nextArg,(int) 'i'))
369      goto LoopForCountParseError;
370 
371    /*====================================*/
372    /* Process the do keyword if present. */
373    /*====================================*/
374 
375    GetToken(theEnv,infile,&theToken);
376    if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
377      {
378       read_first_paren = TRUE;
379       PPBackup(theEnv);
380       SavePPBuffer(theEnv," ");
381       SavePPBuffer(theEnv,theToken.printForm);
382       IncrementIndentDepth(theEnv,3);
383       PPCRAndIndent(theEnv);
384      }
385    else if (theToken.type == LPAREN)
386      {
387       read_first_paren = FALSE;
388       PPBackup(theEnv);
389       IncrementIndentDepth(theEnv,3);
390       PPCRAndIndent(theEnv);
391       SavePPBuffer(theEnv,theToken.printForm);
392      }
393    else
394      goto LoopForCountParseError;
395 
396    /*=====================================*/
397    /* Process the loop-for-count actions. */
398    /*=====================================*/
399    if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
400      ExpressionData(theEnv)->ReturnContext = TRUE;
401    ExpressionData(theEnv)->BreakContext = TRUE;
402    oldBindList = GetParsedBindNames(theEnv);
403    SetParsedBindNames(theEnv,NULL);
404    parse->argList->nextArg->nextArg =
405       GroupActions(theEnv,infile,&theToken,read_first_paren,NULL,FALSE);
406 
407    if (parse->argList->nextArg->nextArg == NULL)
408      {
409       SetParsedBindNames(theEnv,oldBindList);
410       ReturnExpression(theEnv,parse);
411       return(NULL);
412      }
413    newBindList = GetParsedBindNames(theEnv);
414    prev = NULL;
415    while (newBindList != NULL)
416      {
417       if ((loopVar == NULL) ? FALSE :
418           (strcmp(ValueToString(newBindList->name),ValueToString(loopVar)) == 0))
419         {
420          ClearParsedBindNames(theEnv);
421          SetParsedBindNames(theEnv,oldBindList);
422          PrintErrorID(theEnv,"PRCDRPSR",1,TRUE);
423          EnvPrintRouter(theEnv,WERROR,"Cannot rebind loop variable in function loop-for-count.\n");
424          ReturnExpression(theEnv,parse);
425          return(NULL);
426         }
427       prev = newBindList;
428       newBindList = newBindList->next;
429      }
430    if (prev == NULL)
431      SetParsedBindNames(theEnv,oldBindList);
432    else
433      prev->next = oldBindList;
434    if (loopVar != NULL)
435      ReplaceLoopCountVars(theEnv,loopVar,parse->argList->nextArg->nextArg,0);
436    PPBackup(theEnv);
437    PPBackup(theEnv);
438    SavePPBuffer(theEnv,theToken.printForm);
439 
440    /*================================================================*/
441    /* Check for the closing right parenthesis of the loop-for-count. */
442    /*================================================================*/
443 
444    if (theToken.type != RPAREN)
445      {
446       SyntaxErrorMessage(theEnv,"loop-for-count function");
447       ReturnExpression(theEnv,parse);
448       return(NULL);
449      }
450 
451    DecrementIndentDepth(theEnv,3);
452 
453    return(parse);
454 
455 LoopForCountParseError:
456    SyntaxErrorMessage(theEnv,"loop-for-count function");
457    ReturnExpression(theEnv,parse);
458    return(NULL);
459   }
460 
461 /***************************************************/
462 /* ReplaceLoopCountVars                            */
463 /***************************************************/
ReplaceLoopCountVars(void * theEnv,SYMBOL_HN * loopVar,EXPRESSION * theExp,int depth)464 static void ReplaceLoopCountVars(
465   void *theEnv,
466   SYMBOL_HN *loopVar,
467   EXPRESSION *theExp,
468   int depth)
469   {
470    while (theExp != NULL)
471      {
472       if ((theExp->type != SF_VARIABLE) ? FALSE :
473           (strcmp(ValueToString(theExp->value),ValueToString(loopVar)) == 0))
474         {
475          theExp->type = FCALL;
476          theExp->value = (void *) FindFunction(theEnv,"(get-loop-count)");
477          theExp->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long long) depth));
478         }
479       else if (theExp->argList != NULL)
480         {
481          if ((theExp->type != FCALL) ? FALSE :
482              (theExp->value == (void *) FindFunction(theEnv,"loop-for-count")))
483            ReplaceLoopCountVars(theEnv,loopVar,theExp->argList,depth+1);
484          else
485            ReplaceLoopCountVars(theEnv,loopVar,theExp->argList,depth);
486         }
487       theExp = theExp->nextArg;
488      }
489   }
490 
491 /*********************************************************/
492 /* IfParse: purpose is to parse the if statement.  The  */
493 /*   parse of the statement is the return value.         */
494 /*   Syntax: (if <expression> then <action>+             */
495 /*               [ else <action>+ ] )                    */
496 /*********************************************************/
IfParse(void * theEnv,struct expr * top,const char * infile)497 static struct expr *IfParse(
498   void *theEnv,
499   struct expr *top,
500   const char *infile)
501   {
502    struct token theToken;
503 
504    /*============================*/
505    /* Process the if expression. */
506    /*============================*/
507 
508    SavePPBuffer(theEnv," ");
509 
510    top->argList = ParseAtomOrExpression(theEnv,infile,NULL);
511 
512    if (top->argList == NULL)
513      {
514       ReturnExpression(theEnv,top);
515       return(NULL);
516      }
517 
518    /*========================================*/
519    /* Keyword 'then' must follow expression. */
520    /*========================================*/
521 
522    IncrementIndentDepth(theEnv,3);
523    PPCRAndIndent(theEnv);
524 
525    GetToken(theEnv,infile,&theToken);
526    if ((theToken.type != SYMBOL) || (strcmp(ValueToString(theToken.value),"then") != 0))
527      {
528       SyntaxErrorMessage(theEnv,"if function");
529       ReturnExpression(theEnv,top);
530       return(NULL);
531      }
532 
533    /*==============================*/
534    /* Process the if then actions. */
535    /*==============================*/
536 
537    PPCRAndIndent(theEnv);
538    if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
539      ExpressionData(theEnv)->ReturnContext = TRUE;
540    if (ExpressionData(theEnv)->svContexts->brk == TRUE)
541      ExpressionData(theEnv)->BreakContext = TRUE;
542    top->argList->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,"else",FALSE);
543 
544    if (top->argList->nextArg == NULL)
545      {
546       ReturnExpression(theEnv,top);
547       return(NULL);
548      }
549 
550    top->argList->nextArg = RemoveUnneededProgn(theEnv,top->argList->nextArg);
551 
552    /*===========================================*/
553    /* A ')' signals an if then without an else. */
554    /*===========================================*/
555 
556    if (theToken.type == RPAREN)
557      {
558       DecrementIndentDepth(theEnv,3);
559       PPBackup(theEnv);
560       PPBackup(theEnv);
561       SavePPBuffer(theEnv,theToken.printForm);
562       return(top);
563      }
564 
565    /*=============================================*/
566    /* Keyword 'else' must follow if then actions. */
567    /*=============================================*/
568 
569    if ((theToken.type != SYMBOL) || (strcmp(ValueToString(theToken.value),"else") != 0))
570      {
571       SyntaxErrorMessage(theEnv,"if function");
572       ReturnExpression(theEnv,top);
573       return(NULL);
574      }
575 
576    /*==============================*/
577    /* Process the if else actions. */
578    /*==============================*/
579 
580    PPCRAndIndent(theEnv);
581    top->argList->nextArg->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,NULL,FALSE);
582 
583    if (top->argList->nextArg->nextArg == NULL)
584      {
585       ReturnExpression(theEnv,top);
586       return(NULL);
587      }
588 
589    top->argList->nextArg->nextArg = RemoveUnneededProgn(theEnv,top->argList->nextArg->nextArg);
590 
591    /*======================================================*/
592    /* Check for the closing right parenthesis of the if. */
593    /*======================================================*/
594 
595    if (theToken.type != RPAREN)
596      {
597       SyntaxErrorMessage(theEnv,"if function");
598       ReturnExpression(theEnv,top);
599       return(NULL);
600      }
601 
602    /*===========================================*/
603    /* A ')' signals an if then without an else. */
604    /*===========================================*/
605 
606    PPBackup(theEnv);
607    PPBackup(theEnv);
608    SavePPBuffer(theEnv,")");
609    DecrementIndentDepth(theEnv,3);
610    return(top);
611   }
612 
613 /********************************************************/
614 /* PrognParse: purpose is to parse the progn statement. */
615 /*   The parse of the statement is the return value.    */
616 /*   Syntax:  (progn <expression>*)                     */
617 /********************************************************/
PrognParse(void * theEnv,struct expr * top,const char * infile)618 static struct expr *PrognParse(
619   void *theEnv,
620   struct expr *top,
621   const char *infile)
622   {
623    struct token tkn;
624    struct expr *tmp;
625 
626    ReturnExpression(theEnv,top);
627    ExpressionData(theEnv)->BreakContext = ExpressionData(theEnv)->svContexts->brk;
628    ExpressionData(theEnv)->ReturnContext = ExpressionData(theEnv)->svContexts->rtn;
629    IncrementIndentDepth(theEnv,3);
630    PPCRAndIndent(theEnv);
631    tmp = GroupActions(theEnv,infile,&tkn,TRUE,NULL,FALSE);
632    DecrementIndentDepth(theEnv,3);
633    PPBackup(theEnv);
634    PPBackup(theEnv);
635    SavePPBuffer(theEnv,tkn.printForm);
636    return(tmp);
637   }
638 
639 /***********************************************************/
640 /* BindParse: purpose is to parse the bind statement. The */
641 /*   parse of the statement is the return value.           */
642 /*   Syntax:  (bind ?var <expression>)                     */
643 /***********************************************************/
BindParse(void * theEnv,struct expr * top,const char * infile)644 static struct expr *BindParse(
645   void *theEnv,
646   struct expr *top,
647   const char *infile)
648   {
649    struct token theToken;
650    SYMBOL_HN *variableName;
651    struct expr *texp;
652    CONSTRAINT_RECORD *theConstraint = NULL;
653 #if DEFGLOBAL_CONSTRUCT
654    struct defglobal *theGlobal;
655    int count;
656 #endif
657 
658    SavePPBuffer(theEnv," ");
659 
660    /*=============================================*/
661    /* Next token must be the name of the variable */
662    /* to be bound.                                */
663    /*=============================================*/
664 
665    GetToken(theEnv,infile,&theToken);
666    if ((theToken.type != SF_VARIABLE) && (theToken.type != GBL_VARIABLE))
667      {
668       if ((theToken.type != MF_VARIABLE) || ExpressionData(theEnv)->SequenceOpMode)
669         {
670          SyntaxErrorMessage(theEnv,"bind function");
671          ReturnExpression(theEnv,top);
672          return(NULL);
673         }
674      }
675 
676    /*==============================*/
677    /* Process the bind expression. */
678    /*==============================*/
679 
680    top->argList = GenConstant(theEnv,SYMBOL,theToken.value);
681    variableName = (SYMBOL_HN *) theToken.value;
682 
683 #if DEFGLOBAL_CONSTRUCT
684    if ((theToken.type == GBL_VARIABLE) ?
685        ((theGlobal = (struct defglobal *)
686                      FindImportedConstruct(theEnv,"defglobal",NULL,ValueToString(variableName),
687                                            &count,TRUE,FALSE)) != NULL) :
688        FALSE)
689      {
690       top->argList->type = DEFGLOBAL_PTR;
691       top->argList->value = (void *) theGlobal;
692      }
693    else if (theToken.type == GBL_VARIABLE)
694      {
695       GlobalReferenceErrorMessage(theEnv,ValueToString(variableName));
696       ReturnExpression(theEnv,top);
697       return(NULL);
698      }
699 #endif
700 
701    texp = get_struct(theEnv,expr);
702    texp->argList = texp->nextArg = NULL;
703    if (CollectArguments(theEnv,texp,infile) == NULL)
704      {
705       ReturnExpression(theEnv,top);
706       return(NULL);
707      }
708 
709    top->argList->nextArg = texp->argList;
710    rtn_struct(theEnv,expr,texp);
711 
712 #if DEFGLOBAL_CONSTRUCT
713    if (top->argList->type == DEFGLOBAL_PTR) return(top);
714 #endif
715 
716    if (top->argList->nextArg != NULL)
717      { theConstraint = ExpressionToConstraintRecord(theEnv,top->argList->nextArg); }
718 
719    AddBindName(theEnv,variableName,theConstraint);
720 
721    return(top);
722   }
723 
724 /********************************************/
725 /* ReturnParse: Parses the return function. */
726 /********************************************/
ReturnParse(void * theEnv,struct expr * top,const char * infile)727 static struct expr *ReturnParse(
728   void *theEnv,
729   struct expr *top,
730   const char *infile)
731   {
732    int error_flag = FALSE;
733    struct token theToken;
734 
735    if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
736      ExpressionData(theEnv)->ReturnContext = TRUE;
737    if (ExpressionData(theEnv)->ReturnContext == FALSE)
738      {
739       PrintErrorID(theEnv,"PRCDRPSR",2,TRUE);
740       EnvPrintRouter(theEnv,WERROR,"The return function is not valid in this context.\n");
741       ReturnExpression(theEnv,top);
742       return(NULL);
743      }
744    ExpressionData(theEnv)->ReturnContext = FALSE;
745 
746    SavePPBuffer(theEnv," ");
747 
748    top->argList = ArgumentParse(theEnv,infile,&error_flag);
749    if (error_flag)
750      {
751       ReturnExpression(theEnv,top);
752       return(NULL);
753      }
754    else if (top->argList == NULL)
755      {
756       PPBackup(theEnv);
757       PPBackup(theEnv);
758       SavePPBuffer(theEnv,")");
759      }
760    else
761      {
762       SavePPBuffer(theEnv," ");
763       GetToken(theEnv,infile,&theToken);
764       if (theToken.type != RPAREN)
765         {
766          SyntaxErrorMessage(theEnv,"return function");
767          ReturnExpression(theEnv,top);
768          return(NULL);
769         }
770       PPBackup(theEnv);
771       PPBackup(theEnv);
772       SavePPBuffer(theEnv,")");
773      }
774    return(top);
775   }
776 
777 /**********************************************/
778 /* BreakParse:                                */
779 /**********************************************/
BreakParse(void * theEnv,struct expr * top,const char * infile)780 static struct expr *BreakParse(
781   void *theEnv,
782   struct expr *top,
783   const char *infile)
784   {
785    struct token theToken;
786 
787    if (ExpressionData(theEnv)->svContexts->brk == FALSE)
788      {
789       PrintErrorID(theEnv,"PRCDRPSR",2,TRUE);
790       EnvPrintRouter(theEnv,WERROR,"The break function not valid in this context.\n");
791       ReturnExpression(theEnv,top);
792       return(NULL);
793      }
794 
795    SavePPBuffer(theEnv," ");
796    GetToken(theEnv,infile,&theToken);
797    if (theToken.type != RPAREN)
798      {
799       SyntaxErrorMessage(theEnv,"break function");
800       ReturnExpression(theEnv,top);
801       return(NULL);
802      }
803    PPBackup(theEnv);
804    PPBackup(theEnv);
805    SavePPBuffer(theEnv,")");
806    return(top);
807   }
808 
809 /**********************************************/
810 /* SwitchParse:                               */
811 /**********************************************/
SwitchParse(void * theEnv,struct expr * top,const char * infile)812 static struct expr *SwitchParse(
813   void *theEnv,
814   struct expr *top,
815   const char *infile)
816   {
817    struct token theToken;
818    EXPRESSION *theExp,*chk;
819    int default_count = 0;
820 
821    /*============================*/
822    /* Process the switch value   */
823    /*============================*/
824    IncrementIndentDepth(theEnv,3);
825    SavePPBuffer(theEnv," ");
826    top->argList = theExp = ParseAtomOrExpression(theEnv,infile,NULL);
827    if (theExp == NULL)
828      goto SwitchParseError;
829 
830    /*========================*/
831    /* Parse case statements. */
832    /*========================*/
833    GetToken(theEnv,infile,&theToken);
834    while (theToken.type != RPAREN)
835      {
836       PPBackup(theEnv);
837       PPCRAndIndent(theEnv);
838       SavePPBuffer(theEnv,theToken.printForm);
839       if (theToken.type != LPAREN)
840         goto SwitchParseErrorAndMessage;
841       GetToken(theEnv,infile,&theToken);
842       SavePPBuffer(theEnv," ");
843       if ((theToken.type == SYMBOL) &&
844           (strcmp(ValueToString(theToken.value),"case") == 0))
845         {
846          if (default_count != 0)
847            goto SwitchParseErrorAndMessage;
848          theExp->nextArg = ParseAtomOrExpression(theEnv,infile,NULL);
849          SavePPBuffer(theEnv," ");
850          if (theExp->nextArg == NULL)
851            goto SwitchParseError;
852          for (chk = top->argList->nextArg ; chk != theExp->nextArg ; chk = chk->nextArg)
853            {
854             if ((chk->type == theExp->nextArg->type) &&
855                 (chk->value == theExp->nextArg->value) &&
856                 IdenticalExpression(chk->argList,theExp->nextArg->argList))
857               {
858                PrintErrorID(theEnv,"PRCDRPSR",3,TRUE);
859                EnvPrintRouter(theEnv,WERROR,"Duplicate case found in switch function.\n");
860                goto SwitchParseError;
861               }
862            }
863          GetToken(theEnv,infile,&theToken);
864          if ((theToken.type != SYMBOL) ? TRUE :
865              (strcmp(ValueToString(theToken.value),"then") != 0))
866            goto SwitchParseErrorAndMessage;
867         }
868       else if ((theToken.type == SYMBOL) &&
869                (strcmp(ValueToString(theToken.value),"default") == 0))
870         {
871          if (default_count)
872            goto SwitchParseErrorAndMessage;
873          theExp->nextArg = GenConstant(theEnv,RVOID,NULL);
874          default_count = 1;
875         }
876       else
877         goto SwitchParseErrorAndMessage;
878       theExp = theExp->nextArg;
879       if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
880         ExpressionData(theEnv)->ReturnContext = TRUE;
881       if (ExpressionData(theEnv)->svContexts->brk == TRUE)
882         ExpressionData(theEnv)->BreakContext = TRUE;
883       IncrementIndentDepth(theEnv,3);
884       PPCRAndIndent(theEnv);
885       theExp->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,NULL,FALSE);
886       DecrementIndentDepth(theEnv,3);
887       ExpressionData(theEnv)->ReturnContext = FALSE;
888       ExpressionData(theEnv)->BreakContext = FALSE;
889       if (theExp->nextArg == NULL)
890         goto SwitchParseError;
891       theExp = theExp->nextArg;
892       PPBackup(theEnv);
893       PPBackup(theEnv);
894       SavePPBuffer(theEnv,theToken.printForm);
895       GetToken(theEnv,infile,&theToken);
896      }
897    DecrementIndentDepth(theEnv,3);
898    return(top);
899 
900 SwitchParseErrorAndMessage:
901    SyntaxErrorMessage(theEnv,"switch function");
902 SwitchParseError:
903    ReturnExpression(theEnv,top);
904    DecrementIndentDepth(theEnv,3);
905    return(NULL);
906   }
907 
908 /********************************************************/
909 /* SearchParsedBindNames:                               */
910 /********************************************************/
SearchParsedBindNames(void * theEnv,SYMBOL_HN * name_sought)911 globle int SearchParsedBindNames(
912   void *theEnv,
913   SYMBOL_HN *name_sought)
914   {
915    struct BindInfo *var_ptr;
916    int theIndex = 1;
917 
918    var_ptr = ProcedureParserData(theEnv)->ListOfParsedBindNames;
919    while (var_ptr != NULL)
920      {
921       if (var_ptr->name == name_sought)
922         { return(theIndex); }
923       var_ptr = var_ptr->next;
924       theIndex++;
925      }
926 
927    return(0);
928   }
929 
930 /********************************************************/
931 /* FindBindConstraints:                               */
932 /********************************************************/
FindBindConstraints(void * theEnv,SYMBOL_HN * nameSought)933 globle struct constraintRecord *FindBindConstraints(
934   void *theEnv,
935   SYMBOL_HN *nameSought)
936   {
937    struct BindInfo *theVariable;
938 
939    theVariable = ProcedureParserData(theEnv)->ListOfParsedBindNames;
940    while (theVariable != NULL)
941      {
942       if (theVariable->name == nameSought)
943         { return(theVariable->constraints); }
944       theVariable = theVariable->next;
945      }
946 
947    return(NULL);
948   }
949 
950 /********************************************************/
951 /* CountParsedBindNames: Counts the number of variables */
952 /*   names that have been bound using the bind function */
953 /*   in the current context (e.g. the RHS of a rule).   */
954 /********************************************************/
CountParsedBindNames(void * theEnv)955 globle int CountParsedBindNames(
956   void *theEnv)
957   {
958    struct BindInfo *theVariable;
959    int theIndex = 0;
960 
961    theVariable = ProcedureParserData(theEnv)->ListOfParsedBindNames;
962    while (theVariable != NULL)
963      {
964       theVariable = theVariable->next;
965       theIndex++;
966      }
967 
968    return(theIndex);
969   }
970 
971 /****************************************************************/
972 /* AddBindName: Adds a variable name used as the first argument */
973 /*   of the bind function to the list of variable names parsed  */
974 /*   within the current semantic context (e.g. RHS of a rule).  */
975 /****************************************************************/
AddBindName(void * theEnv,SYMBOL_HN * variableName,CONSTRAINT_RECORD * theConstraint)976 static int AddBindName(
977   void *theEnv,
978   SYMBOL_HN *variableName,
979   CONSTRAINT_RECORD *theConstraint)
980   {
981    CONSTRAINT_RECORD *tmpConstraint;
982    struct BindInfo *currentBind, *lastBind;
983    int theIndex = 1;
984 
985    /*=========================================================*/
986    /* Look for the variable name in the list of bind variable */
987    /* names already parsed. If it is found, then return the   */
988    /* index to the variable and union the new constraint      */
989    /* information with the old constraint information.        */
990    /*=========================================================*/
991 
992    lastBind = NULL;
993    currentBind = ProcedureParserData(theEnv)->ListOfParsedBindNames;
994    while (currentBind != NULL)
995      {
996       if (currentBind->name == variableName)
997         {
998          if (theConstraint != NULL)
999            {
1000             tmpConstraint = currentBind->constraints;
1001             currentBind->constraints = UnionConstraints(theEnv,theConstraint,currentBind->constraints);
1002             RemoveConstraint(theEnv,tmpConstraint);
1003             RemoveConstraint(theEnv,theConstraint);
1004            }
1005 
1006          return(theIndex);
1007         }
1008       lastBind = currentBind;
1009       currentBind = currentBind->next;
1010       theIndex++;
1011      }
1012 
1013    /*===============================================================*/
1014    /* If the variable name wasn't found, then add it to the list of */
1015    /* variable names and store the constraint information with it.  */
1016    /*===============================================================*/
1017 
1018    currentBind = get_struct(theEnv,BindInfo);
1019    currentBind->name = variableName;
1020    currentBind->constraints = theConstraint;
1021    currentBind->next = NULL;
1022 
1023    if (lastBind == NULL) ProcedureParserData(theEnv)->ListOfParsedBindNames = currentBind;
1024    else lastBind->next = currentBind;
1025 
1026    return(theIndex);
1027   }
1028 
1029 /********************************************************/
1030 /* RemoveParsedBindName:                                     */
1031 /********************************************************/
RemoveParsedBindName(void * theEnv,struct symbolHashNode * bname)1032 globle void RemoveParsedBindName(
1033   void *theEnv,
1034   struct symbolHashNode *bname)
1035   {
1036    struct BindInfo *prv,*tmp;
1037 
1038    prv = NULL;
1039    tmp = ProcedureParserData(theEnv)->ListOfParsedBindNames;
1040    while ((tmp != NULL) ? (tmp->name != bname) : FALSE)
1041      {
1042       prv = tmp;
1043       tmp = tmp->next;
1044      }
1045    if (tmp != NULL)
1046      {
1047       if (prv == NULL)
1048         ProcedureParserData(theEnv)->ListOfParsedBindNames = tmp->next;
1049       else
1050         prv->next = tmp->next;
1051 
1052       RemoveConstraint(theEnv,tmp->constraints);
1053       rtn_struct(theEnv,BindInfo,tmp);
1054      }
1055   }
1056 
1057 #endif
1058 
1059 #endif
1060 
1061