src/clipsrules/core/multifun.c Source File

00001    /*******************************************************/
00002    /*      "C" Language Integrated Production System      */
00003    /*                                                     */
00004    /*             CLIPS Version 6.24  06/05/06            */
00005    /*                                                     */
00006    /*             MULTIFIELD FUNCTIONS MODULE             */
00007    /*******************************************************/
00008 
00009 /*************************************************************/
00010 /* Purpose: Contains the code for several multifield         */
00011 /*   functions including first$, rest$, subseq$, delete$,    */
00012 /*   delete-member$, replace-member$                         */
00013 /*   replace$, insert$, explode$, implode$, nth$, member$,   */
00014 /*   subsetp, progn$, str-implode, str-explode, subset, nth, */
00015 /*   mv-replace, member, mv-subseq, and mv-delete.           */
00016 /*                                                           */
00017 /* Principal Programmer(s):                                  */
00018 /*      Gary D. Riley                                        */
00019 /*      Brian Dantes                                         */
00020 /*      Barry Cameron                                        */
00021 /*                                                           */
00022 /* Contributing Programmer(s):                               */
00023 /*                                                           */
00024 /* Revision History:                                         */
00025 /*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
00026 /*                                                           */
00027 /*            Changed name of variable exp to theExp         */
00028 /*            because of Unix compiler warnings of shadowed  */
00029 /*            definitions.                                   */
00030 /*                                                           */
00031 /*      6.24: Renamed BOOLEAN macro type to intBool.         */
00032 /*                                                           */
00033 /*            Moved ImplodeMultifield to multifld.c.         */
00034 /*                                                           */
00035 /*      6.30: Added foreach function.                        */
00036 /*                                                           */
00037 /*************************************************************/
00038 
00039 #define _MULTIFUN_SOURCE_
00040 
00041 #include "setup.h"
00042 
00043 #if MULTIFIELD_FUNCTIONS || OBJECT_SYSTEM
00044 
00045 #include <stdio.h>
00046 #define _STDIO_INCLUDED_
00047 #include <string.h>
00048 
00049 #include "argacces.h"
00050 #include "envrnmnt.h"
00051 #include "exprnpsr.h"
00052 #include "memalloc.h"
00053 #include "multifld.h"
00054 #include "multifun.h"
00055 #include "prcdrpsr.h"
00056 #include "prcdrfun.h"
00057 #include "router.h"
00058 #if (! BLOAD_ONLY) && (! RUN_TIME)
00059 #include "scanner.h"
00060 #endif
00061 #include "utility.h"
00062 
00063 #if OBJECT_SYSTEM
00064 #include "object.h"
00065 #endif
00066 
00067 /**************/
00068 /* STRUCTURES */
00069 /**************/
00070 
00071 typedef struct fieldVarStack
00072   {
00073    unsigned short type;
00074    void *value;
00075    long index;
00076    struct fieldVarStack *nxt;
00077   } FIELD_VAR_STACK;
00078 
00079 /***************************************/
00080 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
00081 /***************************************/
00082 
00083 #if MULTIFIELD_FUNCTIONS
00084    static intBool                 MVRangeCheck(long,long,long *,int);
00085 #if (! BLOAD_ONLY) && (! RUN_TIME)
00086    static struct expr            *MultifieldPrognParser(void *,struct expr *,char *);
00087    static struct expr            *ForeachParser(void *,struct expr *,char *);
00088    static void                    ReplaceMvPrognFieldVars(void *,SYMBOL_HN *,struct expr *,int);
00089 #endif
00090 #endif
00091    static void                    MVRangeError(void *,long,long,long,char *);
00092    static void                    MultifieldPrognDriver(void *,DATA_OBJECT_PTR,char *);
00093 #endif
00094 
00095 /***************************************/
00096 /* LOCAL INTERNAL VARIABLE DEFINITIONS */
00097 /***************************************/
00098 
00099 #if MULTIFIELD_FUNCTIONS
00100 
00101 #define MULTIFUN_DATA 10
00102 
00103 struct multiFunctionData
00104   { 
00105    FIELD_VAR_STACK *FieldVarStack;
00106   };
00107 
00108 #define MultiFunctionData(theEnv) ((struct multiFunctionData *) GetEnvironmentData(theEnv,MULTIFUN_DATA))
00109 
00110 /**********************************************/
00111 /* MultifieldFunctionDefinitions: Initializes */
00112 /*   the multifield functions.                */
00113 /**********************************************/
00114 globle void MultifieldFunctionDefinitions(
00115   void *theEnv)
00116   {
00117    AllocateEnvironmentData(theEnv,MULTIFUN_DATA,sizeof(struct multiFunctionData),NULL);
00118 
00119 #if ! RUN_TIME
00120    EnvDefineFunction2(theEnv,"first$", 'm', PTIEF FirstFunction, "FirstFunction", "11m");
00121    EnvDefineFunction2(theEnv,"rest$", 'm', PTIEF RestFunction, "RestFunction", "11m");
00122    EnvDefineFunction2(theEnv,"subseq$", 'm', PTIEF SubseqFunction, "SubseqFunction", "33im");
00123    EnvDefineFunction2(theEnv,"delete-member$", 'm', PTIEF DeleteMemberFunction, "DeleteMemberFunction", "2*um");
00124    EnvDefineFunction2(theEnv,"replace-member$", 'm', PTIEF ReplaceMemberFunction, "ReplaceMemberFunction","3*um");
00125    EnvDefineFunction2(theEnv,"delete$", 'm', PTIEF DeleteFunction, "DeleteFunction", "33im");
00126    EnvDefineFunction2(theEnv,"replace$", 'm', PTIEF ReplaceFunction, "ReplaceFunction","4**mii");
00127    EnvDefineFunction2(theEnv,"insert$", 'm', PTIEF InsertFunction, "InsertFunction", "3**mi");
00128    EnvDefineFunction2(theEnv,"explode$", 'm', PTIEF ExplodeFunction, "ExplodeFunction", "11s");
00129    EnvDefineFunction2(theEnv,"implode$", 's', PTIEF ImplodeFunction, "ImplodeFunction", "11m");
00130    EnvDefineFunction2(theEnv,"nth$", 'u', PTIEF NthFunction, "NthFunction", "22*im");
00131    EnvDefineFunction2(theEnv,"member$", 'u', PTIEF MemberFunction, "MemberFunction", "22*um");
00132    EnvDefineFunction2(theEnv,"subsetp", 'b', PTIEF SubsetpFunction, "SubsetpFunction", "22*mm");
00133    EnvDefineFunction2(theEnv,"progn$", 'u', PTIEF MultifieldPrognFunction, "MultifieldPrognFunction", NULL);
00134    EnvDefineFunction2(theEnv,"foreach", 'u', PTIEF ForeachFunction, "ForeachFunction", NULL);
00135    EnvDefineFunction2(theEnv,"str-implode", 's', PTIEF ImplodeFunction, "ImplodeFunction", "11m");
00136    EnvDefineFunction2(theEnv,"str-explode", 'm', PTIEF ExplodeFunction, "ExplodeFunction", "11s");
00137    EnvDefineFunction2(theEnv,"subset", 'b', PTIEF SubsetpFunction, "SubsetpFunction", "22*mm");
00138    EnvDefineFunction2(theEnv,"nth", 'u', PTIEF NthFunction, "NthFunction", "22*im");
00139    EnvDefineFunction2(theEnv,"mv-replace", 'm', PTIEF MVReplaceFunction, "MVReplaceFunction","33*im");
00140    EnvDefineFunction2(theEnv,"member", 'u', PTIEF MemberFunction, "MemberFunction", "22*um");
00141    EnvDefineFunction2(theEnv,"mv-subseq", 'm', PTIEF MVSubseqFunction, "MVSubseqFunction", "33*iim");
00142    EnvDefineFunction2(theEnv,"mv-delete", 'm', PTIEF MVDeleteFunction,"MVDeleteFunction", "22*im");
00143 #if ! BLOAD_ONLY
00144    AddFunctionParser(theEnv,"progn$",MultifieldPrognParser);
00145    AddFunctionParser(theEnv,"foreach",ForeachParser);
00146 #endif
00147    FuncSeqOvlFlags(theEnv,"progn$",FALSE,FALSE);
00148    FuncSeqOvlFlags(theEnv,"foreach",FALSE,FALSE);
00149    EnvDefineFunction2(theEnv,"(get-progn$-field)", 'u', PTIEF GetMvPrognField, "GetMvPrognField", "00");
00150    EnvDefineFunction2(theEnv,"(get-progn$-index)", 'l', PTIEF GetMvPrognIndex, "GetMvPrognIndex", "00");
00151 #endif
00152   }
00153 
00154 /****************************************/
00155 /* DeleteFunction: H/L access routine   */
00156 /*   for the delete$ function.          */
00157 /****************************************/
00158 globle void DeleteFunction(
00159   void *theEnv,
00160   DATA_OBJECT_PTR returnValue)
00161   {
00162    DATA_OBJECT value1, value2, value3;
00163 
00164    /*=======================================*/
00165    /* Check for the correct argument types. */
00166    /*=======================================*/
00167 
00168    if ((EnvArgTypeCheck(theEnv,"delete$",1,MULTIFIELD,&value1) == FALSE) ||
00169        (EnvArgTypeCheck(theEnv,"delete$",2,INTEGER,&value2) == FALSE) ||
00170        (EnvArgTypeCheck(theEnv,"delete$",3,INTEGER,&value3) == FALSE))
00171      {
00172       SetEvaluationError(theEnv,TRUE);
00173       EnvSetMultifieldErrorValue(theEnv,returnValue);
00174       return;
00175      }
00176 
00177    /*=================================================*/
00178    /* Delete the section out of the multifield value. */
00179    /*=================================================*/
00180 
00181    if (DeleteMultiValueField(theEnv,returnValue,&value1,
00182             (long) DOToLong(value2),(long) DOToLong(value3),"delete$") == FALSE)/* TBD */
00183      {
00184       SetEvaluationError(theEnv,TRUE);
00185       EnvSetMultifieldErrorValue(theEnv,returnValue);
00186      }
00187   }
00188 
00189 /******************************************/
00190 /* MVDeleteFunction: H/L access routine   */
00191 /*   for the mv-delete function.          */
00192 /******************************************/
00193 globle void MVDeleteFunction(
00194   void *theEnv,
00195   DATA_OBJECT_PTR returnValue)
00196   {
00197    DATA_OBJECT value1, value2;
00198 
00199    /*=======================================*/
00200    /* Check for the correct argument types. */
00201    /*=======================================*/
00202 
00203    if ((EnvArgTypeCheck(theEnv,"mv-delete",1,INTEGER,&value1) == FALSE) ||
00204        (EnvArgTypeCheck(theEnv,"mv-delete",2,MULTIFIELD,&value2) == FALSE))
00205      {
00206       SetEvaluationError(theEnv,TRUE);
00207       EnvSetMultifieldErrorValue(theEnv,returnValue);
00208       return;
00209      }
00210 
00211    /*=================================================*/
00212    /* Delete the section out of the multifield value. */
00213    /*=================================================*/
00214 
00215    if (DeleteMultiValueField(theEnv,returnValue,&value2,
00216             (long) DOToLong(value1),(long) DOToLong(value1),"mv-delete") == FALSE) /* TBD */
00217      {
00218       SetEvaluationError(theEnv,TRUE);
00219       EnvSetMultifieldErrorValue(theEnv,returnValue);
00220      }
00221   }
00222 
00223 /*****************************************/
00224 /* ReplaceFunction: H/L access routine   */
00225 /*   for the replace$ function.          */
00226 /*****************************************/
00227 globle void ReplaceFunction(
00228   void *theEnv,
00229   DATA_OBJECT_PTR returnValue)
00230   {
00231    DATA_OBJECT value1, value2, value3, value4;
00232    EXPRESSION *fieldarg;
00233 
00234    /*=======================================*/
00235    /* Check for the correct argument types. */
00236    /*=======================================*/
00237 
00238    if ((EnvArgTypeCheck(theEnv,"replace$",1,MULTIFIELD,&value1) == FALSE) ||
00239        (EnvArgTypeCheck(theEnv,"replace$",2,INTEGER,&value2) == FALSE) ||
00240        (EnvArgTypeCheck(theEnv,"replace$",3,INTEGER,&value3) == FALSE))
00241      {
00242       SetEvaluationError(theEnv,TRUE);
00243       EnvSetMultifieldErrorValue(theEnv,returnValue);
00244       return;
00245      }
00246 
00247    /*===============================*/
00248    /* Create the replacement value. */
00249    /*===============================*/
00250 
00251    fieldarg = GetFirstArgument()->nextArg->nextArg->nextArg;
00252    if (fieldarg->nextArg != NULL)
00253      { StoreInMultifield(theEnv,&value4,fieldarg,TRUE); }
00254    else
00255      { EvaluateExpression(theEnv,fieldarg,&value4); }
00256 
00257    /*==============================================*/
00258    /* Replace the section in the multifield value. */
00259    /*==============================================*/
00260 
00261    if (ReplaceMultiValueField(theEnv,returnValue,&value1,(long) DOToLong(value2),
00262                    (long) DOToLong(value3),&value4,"replace$") == FALSE) /* TBD */
00263      {
00264       SetEvaluationError(theEnv,TRUE);
00265       EnvSetMultifieldErrorValue(theEnv,returnValue);
00266      }
00267   }
00268 
00269 /*******************************************/
00270 /* MVReplaceFunction: H/L access routine   */
00271 /*   for the mv-replace function.          */
00272 /*******************************************/
00273 globle void MVReplaceFunction(
00274   void *theEnv,
00275   DATA_OBJECT_PTR returnValue)
00276   {
00277    DATA_OBJECT value1, value2, value3;
00278 
00279    /*=======================================*/
00280    /* Check for the correct argument types. */
00281    /*=======================================*/
00282 
00283    if ((EnvArgTypeCheck(theEnv,"mv-replace",1,INTEGER,&value1) == FALSE) ||
00284        (EnvArgTypeCheck(theEnv,"mv-replace",2,MULTIFIELD,&value2) == FALSE))
00285      {
00286       SetEvaluationError(theEnv,TRUE);
00287       EnvSetMultifieldErrorValue(theEnv,returnValue);
00288       return;
00289      }
00290 
00291    /*===============================*/
00292    /* Create the replacement value. */
00293    /*===============================*/
00294 
00295    EvaluateExpression(theEnv,GetFirstArgument()->nextArg->nextArg,&value3);
00296 
00297    /*==============================================*/
00298    /* Replace the section in the multifield value. */
00299    /*==============================================*/
00300 
00301    if (ReplaceMultiValueField(theEnv,returnValue,&value2,(long) DOToLong(value1),
00302                    (long) DOToLong(value1),&value3,"mv-replace") == FALSE) /* TBD */
00303      {
00304       SetEvaluationError(theEnv,TRUE);
00305       EnvSetMultifieldErrorValue(theEnv,returnValue);
00306      }
00307   }
00308 
00309 /**********************************************/
00310 /* DeleteMemberFunction: H/L access routine   */
00311 /*   for the delete-member$ function.         */
00312 /**********************************************/
00313 globle void DeleteMemberFunction(
00314   void *theEnv,
00315   DATA_OBJECT_PTR returnValue)
00316   {
00317    DATA_OBJECT resultValue,*delVals,tmpVal;
00318    int i,argCnt;
00319    unsigned delSize;
00320    long j,k;
00321 
00322    /*============================================*/
00323    /* Check for the correct number of arguments. */
00324    /*============================================*/
00325 
00326    argCnt = EnvArgCountCheck(theEnv,"delete-member$",AT_LEAST,2);
00327    if (argCnt == -1)
00328      {
00329       SetEvaluationError(theEnv,TRUE);
00330       EnvSetMultifieldErrorValue(theEnv,returnValue);
00331       return;
00332      }
00333 
00334    /*=======================================*/
00335    /* Check for the correct argument types. */
00336    /*=======================================*/
00337    if (EnvArgTypeCheck(theEnv,"delete-member$",1,MULTIFIELD,&resultValue) == FALSE)
00338      {
00339       SetEvaluationError(theEnv,TRUE);
00340       EnvSetMultifieldErrorValue(theEnv,returnValue);
00341       return;
00342      }
00343 
00344    /*=================================================
00345      For every value specified, delete all occurrences
00346      of those values from the multifield
00347      ================================================= */
00348    delSize = (sizeof(DATA_OBJECT) * (argCnt-1));
00349    delVals = (DATA_OBJECT_PTR) gm2(theEnv,delSize);
00350    for (i = 2 ; i <= argCnt ; i++)
00351      {
00352       if (!EnvRtnUnknown(theEnv,i,&delVals[i-2]))
00353         {
00354          rm(theEnv,(void *) delVals,delSize);
00355          SetEvaluationError(theEnv,TRUE);
00356          EnvSetMultifieldErrorValue(theEnv,returnValue);
00357          return;
00358         }
00359      }
00360 
00361    while (FindDOsInSegment(delVals,argCnt-1,&resultValue,&j,&k,NULL,0))
00362      {
00363       if (DeleteMultiValueField(theEnv,&tmpVal,&resultValue,
00364                                 j,k,"delete-member$") == FALSE)
00365         {
00366          rm(theEnv,(void *) delVals,delSize);
00367          SetEvaluationError(theEnv,TRUE);
00368          EnvSetMultifieldErrorValue(theEnv,returnValue);
00369          return;
00370         }
00371       GenCopyMemory(DATA_OBJECT,1,&resultValue,&tmpVal);
00372      }
00373    rm(theEnv,(void *) delVals,delSize);
00374    GenCopyMemory(DATA_OBJECT,1,returnValue,&resultValue);
00375   }
00376 
00377 /***********************************************/
00378 /* ReplaceMemberFunction: H/L access routine   */
00379 /*   for the replace-member$ function.         */
00380 /***********************************************/
00381 globle void ReplaceMemberFunction(
00382   void *theEnv,
00383   DATA_OBJECT_PTR returnValue)
00384   {
00385    DATA_OBJECT resultValue,replVal,*delVals,tmpVal;
00386    int i,argCnt;
00387    unsigned delSize;
00388    long j,k,mink[2],*minkp;
00389    long replLen = 1L;
00390 
00391    /*============================================*/
00392    /* Check for the correct number of arguments. */
00393    /*============================================*/
00394    argCnt = EnvArgCountCheck(theEnv,"replace-member$",AT_LEAST,3);
00395    if (argCnt == -1)
00396      {
00397       SetEvaluationError(theEnv,TRUE);
00398       EnvSetMultifieldErrorValue(theEnv,returnValue);
00399       return;
00400      }
00401 
00402    /*=======================================*/
00403    /* Check for the correct argument types. */
00404    /*=======================================*/
00405    if (EnvArgTypeCheck(theEnv,"replace-member$",1,MULTIFIELD,&resultValue) == FALSE)
00406      {
00407       SetEvaluationError(theEnv,TRUE);
00408       EnvSetMultifieldErrorValue(theEnv,returnValue);
00409       return;
00410      }
00411 
00412    if (!EnvRtnUnknown(theEnv,2,&replVal))
00413      {
00414       SetEvaluationError(theEnv,TRUE);
00415       EnvSetMultifieldErrorValue(theEnv,returnValue);
00416       return;
00417      }
00418    if (GetType(replVal) == MULTIFIELD)
00419      replLen = GetDOLength(replVal);
00420 
00421    /*=====================================================
00422      For the value (or values from multifield ) specified,
00423      replace all occurrences of those values with all
00424      values specified
00425      ===================================================== */
00426    delSize = (sizeof(DATA_OBJECT) * (argCnt-2));
00427    delVals = (DATA_OBJECT_PTR) gm2(theEnv,delSize);
00428    for (i = 3 ; i <= argCnt ; i++)
00429      {
00430       if (!EnvRtnUnknown(theEnv,i,&delVals[i-3]))
00431         {
00432          rm(theEnv,(void *) delVals,delSize);
00433          SetEvaluationError(theEnv,TRUE);
00434          EnvSetMultifieldErrorValue(theEnv,returnValue);
00435          return;
00436         }
00437      }
00438    minkp = NULL;
00439    while (FindDOsInSegment(delVals,argCnt-2,&resultValue,&j,&k,minkp,minkp ? 1 : 0))
00440      {
00441       if (ReplaceMultiValueField(theEnv,&tmpVal,&resultValue,j,k,
00442                                  &replVal,"replace-member$") == FALSE)
00443         {
00444          rm(theEnv,(void *) delVals,delSize);
00445          SetEvaluationError(theEnv,TRUE);
00446          EnvSetMultifieldErrorValue(theEnv,returnValue);
00447          return;
00448         }
00449       GenCopyMemory(DATA_OBJECT,1,&resultValue,&tmpVal);
00450       mink[0] = 1L;
00451       mink[1] = j + replLen - 1L;
00452       minkp = mink;
00453      }
00454    rm(theEnv,(void *) delVals,delSize);
00455    GenCopyMemory(DATA_OBJECT,1,returnValue,&resultValue);
00456   }
00457 
00458 /****************************************/
00459 /* InsertFunction: H/L access routine   */
00460 /*   for the insert$ function.          */
00461 /****************************************/
00462 globle void InsertFunction(
00463   void *theEnv,
00464   DATA_OBJECT_PTR returnValue)
00465   {
00466    DATA_OBJECT value1, value2, value3;
00467    EXPRESSION *fieldarg;
00468 
00469    /*=======================================*/
00470    /* Check for the correct argument types. */
00471    /*=======================================*/
00472 
00473    if ((EnvArgTypeCheck(theEnv,"insert$",1,MULTIFIELD,&value1) == FALSE) ||
00474        (EnvArgTypeCheck(theEnv,"insert$",2,INTEGER,&value2) == FALSE))
00475      {
00476       SetEvaluationError(theEnv,TRUE);
00477       EnvSetMultifieldErrorValue(theEnv,returnValue);
00478       return;
00479      }
00480 
00481    /*=============================*/
00482    /* Create the insertion value. */
00483    /*=============================*/
00484 
00485    fieldarg = GetFirstArgument()->nextArg->nextArg;
00486    if (fieldarg->nextArg != NULL)
00487      StoreInMultifield(theEnv,&value3,fieldarg,TRUE);
00488    else
00489      EvaluateExpression(theEnv,fieldarg,&value3);
00490 
00491    /*===========================================*/
00492    /* Insert the value in the multifield value. */
00493    /*===========================================*/
00494 
00495    if (InsertMultiValueField(theEnv,returnValue,&value1,(long) DOToLong(value2), /* TBD */
00496                              &value3,"insert$") == FALSE)
00497      {
00498       SetEvaluationError(theEnv,TRUE);
00499       EnvSetMultifieldErrorValue(theEnv,returnValue);
00500      }
00501   }
00502 
00503 /*****************************************/
00504 /* ExplodeFunction: H/L access routine   */
00505 /*   for the explode$ function.          */
00506 /*****************************************/
00507 globle void ExplodeFunction(
00508   void *theEnv,
00509   DATA_OBJECT_PTR returnValue)
00510   {
00511    DATA_OBJECT value;
00512    struct multifield *theMultifield;
00513    unsigned long end;
00514 
00515    /*=====================================*/
00516    /* Explode$ expects a single argument. */
00517    /*=====================================*/
00518 
00519    if (EnvArgCountCheck(theEnv,"explode$",EXACTLY,1) == -1)
00520      {
00521       SetHaltExecution(theEnv,TRUE);
00522       SetEvaluationError(theEnv,TRUE);
00523       EnvSetMultifieldErrorValue(theEnv,returnValue);
00524       return;
00525      }
00526 
00527    /*==================================*/
00528    /* The argument should be a string. */
00529    /*==================================*/
00530 
00531    if (EnvArgTypeCheck(theEnv,"explode$",1,STRING,&value) == FALSE)
00532      {
00533       SetHaltExecution(theEnv,TRUE);
00534       SetEvaluationError(theEnv,TRUE);
00535       EnvSetMultifieldErrorValue(theEnv,returnValue);
00536       return;
00537      }
00538 
00539    /*=====================================*/
00540    /* Convert the string to a multifield. */
00541    /*=====================================*/
00542 
00543    theMultifield = StringToMultifield(theEnv,DOToString(value));
00544    if (theMultifield == NULL)
00545      {
00546       theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,0L);
00547       end = 0;
00548      }
00549    else
00550      { end = GetMFLength(theMultifield); }
00551 
00552    /*========================*/
00553    /* Return the multifield. */
00554    /*========================*/
00555 
00556    SetpType(returnValue,MULTIFIELD);
00557    SetpDOBegin(returnValue,1);
00558    SetpDOEnd(returnValue,end);
00559    SetpValue(returnValue,(void *) theMultifield);
00560    return;
00561   }
00562 
00563 /*****************************************/
00564 /* ImplodeFunction: H/L access routine   */
00565 /*   for the implode$ function.          */
00566 /*****************************************/
00567 globle void *ImplodeFunction(
00568   void *theEnv)
00569   {
00570    DATA_OBJECT value;
00571 
00572    /*=====================================*/
00573    /* Implode$ expects a single argument. */
00574    /*=====================================*/
00575 
00576    if (EnvArgCountCheck(theEnv,"implode$",EXACTLY,1) == -1)
00577      { return(EnvAddSymbol(theEnv,"")); }
00578 
00579    /*======================================*/
00580    /* The argument should be a multifield. */
00581    /*======================================*/
00582 
00583    if (EnvArgTypeCheck(theEnv,"implode$",1,MULTIFIELD,&value) == FALSE)
00584      { return(EnvAddSymbol(theEnv,"")); }
00585 
00586    /*====================*/
00587    /* Return the string. */
00588    /*====================*/
00589 
00590    return(ImplodeMultifield(theEnv,&value));
00591   }
00592 
00593 /****************************************/
00594 /* SubseqFunction: H/L access routine   */
00595 /*   for the subseq$ function.          */
00596 /****************************************/
00597 globle void SubseqFunction(
00598   void *theEnv,
00599   DATA_OBJECT_PTR sub_value)
00600   {
00601    DATA_OBJECT value;
00602    struct multifield *theList;
00603    long long offset, start, end, length; /* 6.04 Bug Fix */
00604 
00605    /*===================================*/
00606    /* Get the segment to be subdivided. */
00607    /*===================================*/
00608 
00609    if (EnvArgTypeCheck(theEnv,"subseq$",1,MULTIFIELD,&value) == FALSE)
00610      {
00611       EnvSetMultifieldErrorValue(theEnv,sub_value);
00612       return;
00613      }
00614    theList = (struct multifield *) DOToPointer(value);
00615    offset = GetDOBegin(value);
00616    length = GetDOLength(value);
00617 
00618    /*=============================================*/
00619    /* Get range arguments. If they are not within */
00620    /* appropriate ranges, return a null segment.  */
00621    /*=============================================*/
00622 
00623    if (EnvArgTypeCheck(theEnv,"subseq$",2,INTEGER,&value) == FALSE)
00624      {
00625       EnvSetMultifieldErrorValue(theEnv,sub_value);
00626       return;
00627      }
00628    start = DOToLong(value);
00629 
00630    if (EnvArgTypeCheck(theEnv,"subseq$",3,INTEGER,&value) == FALSE)
00631      {
00632       EnvSetMultifieldErrorValue(theEnv,sub_value);
00633       return;
00634      }
00635    end = DOToLong(value);
00636 
00637    if ((end < 1) || (end < start))
00638      {
00639       EnvSetMultifieldErrorValue(theEnv,sub_value);
00640       return;
00641      }
00642 
00643    /*===================================================*/
00644    /* Adjust lengths  to conform to segment boundaries. */
00645    /*===================================================*/
00646 
00647    if (start > length)
00648      {
00649       EnvSetMultifieldErrorValue(theEnv,sub_value);
00650       return;
00651      }
00652    if (end > length) end = length;
00653    if (start < 1) start = 1;
00654 
00655    /*=========================*/
00656    /* Return the new segment. */
00657    /*=========================*/
00658 
00659    SetpType(sub_value,MULTIFIELD);
00660    SetpValue(sub_value,theList);
00661    SetpDOEnd(sub_value,offset + end - 1);
00662    SetpDOBegin(sub_value,offset + start - 1);
00663   }
00664 
00665 /******************************************/
00666 /* MVSubseqFunction: H/L access routine   */
00667 /*   for the mv-subseq function.          */
00668 /******************************************/
00669 globle void MVSubseqFunction(
00670   void *theEnv,
00671   DATA_OBJECT_PTR sub_value)
00672   {
00673    DATA_OBJECT value;
00674    struct multifield *theList;
00675    long long offset, start, end, length; /* 6.04 Bug Fix */
00676 
00677    /*=============================================*/
00678    /* Get range arguments. If they are not within */
00679    /* appropriate ranges, return a null segment.  */
00680    /*=============================================*/
00681 
00682    if (EnvArgTypeCheck(theEnv,"mv-subseq",1,INTEGER,&value) == FALSE)
00683      {
00684       EnvSetMultifieldErrorValue(theEnv,sub_value);
00685       return;
00686      }
00687    start = DOToLong(value);
00688 
00689    if (EnvArgTypeCheck(theEnv,"mv-subseq",2,INTEGER,&value) == FALSE)
00690      {
00691       EnvSetMultifieldErrorValue(theEnv,sub_value);
00692       return;
00693      }
00694    end = DOToLong(value);
00695 
00696    if ((end < 1) || (end < start))
00697      {
00698       EnvSetMultifieldErrorValue(theEnv,sub_value);
00699       return;
00700      }
00701 
00702    /*===================================*/
00703    /* Get the segment to be subdivided. */
00704    /*===================================*/
00705 
00706    if (EnvArgTypeCheck(theEnv,"mv-subseq",3,MULTIFIELD,&value) == FALSE)
00707      {
00708       EnvSetMultifieldErrorValue(theEnv,sub_value);
00709       return;
00710      }
00711    theList = (struct multifield *) DOToPointer(value);
00712    offset = GetDOBegin(value);
00713 
00714    /*===================================================*/
00715    /* Adjust lengths  to conform to segment boundaries. */
00716    /*===================================================*/
00717 
00718    length = GetDOLength(value);
00719    if (start > length)
00720      {
00721       EnvSetMultifieldErrorValue(theEnv,sub_value);
00722       return;
00723      }
00724    if (end > length) end = length;
00725    if (start < 1) start = 1;
00726 
00727    /*=========================*/
00728    /* Return the new segment. */
00729    /*=========================*/
00730 
00731    SetpType(sub_value,MULTIFIELD);
00732    SetpValue(sub_value,theList);
00733    SetpDOEnd(sub_value,offset + end - 1);
00734    SetpDOBegin(sub_value,offset + start - 1);
00735   }
00736 
00737 /***************************************/
00738 /* FirstFunction: H/L access routine   */
00739 /*   for the first$ function.          */
00740 /***************************************/
00741 globle void FirstFunction(
00742   void *theEnv,
00743   DATA_OBJECT_PTR returnValue)
00744   {
00745    DATA_OBJECT theValue;
00746    struct multifield *theList;
00747 
00748    /*===================================*/
00749    /* Get the segment to be subdivided. */
00750    /*===================================*/
00751 
00752    if (EnvArgTypeCheck(theEnv,"first$",1,MULTIFIELD,&theValue) == FALSE)
00753      {
00754       EnvSetMultifieldErrorValue(theEnv,returnValue);
00755       return;
00756      }
00757 
00758    theList = (struct multifield *) DOToPointer(theValue);
00759 
00760    /*=========================*/
00761    /* Return the new segment. */
00762    /*=========================*/
00763 
00764    SetpType(returnValue,MULTIFIELD);
00765    SetpValue(returnValue,theList);
00766    if (GetDOEnd(theValue) >= GetDOBegin(theValue))
00767      { SetpDOEnd(returnValue,GetDOBegin(theValue)); }
00768    else
00769      { SetpDOEnd(returnValue,GetDOEnd(theValue)); }
00770    SetpDOBegin(returnValue,GetDOBegin(theValue));
00771   }
00772 
00773 /**************************************/
00774 /* RestFunction: H/L access routine   */
00775 /*   for the rest$ function.          */
00776 /**************************************/
00777 globle void RestFunction(
00778   void *theEnv,
00779   DATA_OBJECT_PTR returnValue)
00780   {
00781    DATA_OBJECT theValue;
00782    struct multifield *theList;
00783 
00784    /*===================================*/
00785    /* Get the segment to be subdivided. */
00786    /*===================================*/
00787 
00788    if (EnvArgTypeCheck(theEnv,"rest$",1,MULTIFIELD,&theValue) == FALSE)
00789      {
00790       EnvSetMultifieldErrorValue(theEnv,returnValue);
00791       return;
00792      }
00793 
00794    theList = (struct multifield *) DOToPointer(theValue);
00795 
00796    /*=========================*/
00797    /* Return the new segment. */
00798    /*=========================*/
00799 
00800    SetpType(returnValue,MULTIFIELD);
00801    SetpValue(returnValue,theList);
00802    if (GetDOBegin(theValue) > GetDOEnd(theValue))
00803      { SetpDOBegin(returnValue,GetDOBegin(theValue)); }
00804    else
00805      { SetpDOBegin(returnValue,GetDOBegin(theValue) + 1); }
00806    SetpDOEnd(returnValue,GetDOEnd(theValue));
00807   }
00808 
00809 /*************************************/
00810 /* NthFunction: H/L access routine   */
00811 /*   for the nth$ function.          */
00812 /*************************************/
00813 globle void NthFunction(
00814   void *theEnv,
00815   DATA_OBJECT_PTR nth_value)
00816   {
00817    DATA_OBJECT value1, value2;
00818    struct multifield *elm_ptr;
00819    long long n; /* 6.04 Bug Fix */
00820 
00821    if (EnvArgCountCheck(theEnv,"nth$",EXACTLY,2) == -1)
00822          {
00823           SetpType(nth_value,SYMBOL);
00824           SetpValue(nth_value,(void *) EnvAddSymbol(theEnv,"nil"));
00825           return;
00826          }
00827 
00828    if ((EnvArgTypeCheck(theEnv,"nth$",1,INTEGER,&value1) == FALSE) ||
00829            (EnvArgTypeCheck(theEnv,"nth$",2,MULTIFIELD,&value2) == FALSE))
00830          {
00831           SetpType(nth_value,SYMBOL);
00832           SetpValue(nth_value,(void *) EnvAddSymbol(theEnv,"nil"));
00833           return;
00834          }
00835 
00836    n = DOToLong(value1); /* 6.04 Bug Fix */
00837    if ((n > GetDOLength(value2)) || (n < 1))
00838          {
00839           SetpType(nth_value,SYMBOL);
00840           SetpValue(nth_value,(void *) EnvAddSymbol(theEnv,"nil"));
00841           return;
00842          }
00843 
00844    elm_ptr = (struct multifield *) GetValue(value2);
00845    SetpType(nth_value,GetMFType(elm_ptr,((long) n) + GetDOBegin(value2) - 1));
00846    SetpValue(nth_value,GetMFValue(elm_ptr,((long) n) + GetDOBegin(value2) - 1));
00847   }
00848 
00849 /* ------------------------------------------------------------------
00850  *    SubsetFunction:
00851  *               This function compares two multi-field variables
00852  *               to see if the first is a subset of the second. It
00853  *               does not consider order.
00854  *
00855  *    INPUTS:    Two arguments via argument stack. First is the sublist
00856  *               multi-field variable, the second is the list to be
00857  *               compared to. Both should be of type MULTIFIELD.
00858  *
00859  *    OUTPUTS:   TRUE if the first list is a subset of the
00860  *               second, else FALSE
00861  *
00862  *    NOTES:     This function is called from H/L with the subset
00863  *               command. Repeated values in the sublist must also
00864  *               be repeated in the main list.
00865  * ------------------------------------------------------------------
00866  */
00867 
00868 globle intBool SubsetpFunction(
00869   void *theEnv)
00870   {
00871    DATA_OBJECT item1, item2, tmpItem;
00872    long i,j,k; 
00873 
00874    if (EnvArgCountCheck(theEnv,"subsetp",EXACTLY,2) == -1)
00875      return(FALSE);
00876 
00877    if (EnvArgTypeCheck(theEnv,"subsetp",1,MULTIFIELD,&item1) == FALSE)
00878      return(FALSE);
00879 
00880    if (EnvArgTypeCheck(theEnv,"subsetp",2,MULTIFIELD,&item2) == FALSE)
00881      return(FALSE);
00882 
00883    if (GetDOLength(item1) == 0) return(TRUE);
00884    if (GetDOLength(item2) == 0) return(FALSE);
00885 
00886    for (i = GetDOBegin(item1) ; i <= GetDOEnd(item1) ; i++)
00887      {
00888       SetType(tmpItem,GetMFType((struct multifield *) GetValue(item1),i));
00889       SetValue(tmpItem,GetMFValue((struct multifield *) GetValue(item1),i));
00890 
00891 
00892       if (! FindDOsInSegment(&tmpItem,1,&item2,&j,&k,NULL,0))
00893         { return(FALSE); }
00894      }
00895 
00896    return(TRUE);
00897   }
00898 
00899 /****************************************/
00900 /* MemberFunction: H/L access routine   */
00901 /*   for the member$ function.          */
00902 /****************************************/
00903 globle void MemberFunction(
00904   void *theEnv,
00905   DATA_OBJECT_PTR result)
00906   {
00907    DATA_OBJECT item1, item2;
00908    long j, k;
00909 
00910    result->type = SYMBOL;
00911    result->value = EnvFalseSymbol(theEnv);
00912 
00913    if (EnvArgCountCheck(theEnv,"member$",EXACTLY,2) == -1) return;
00914 
00915    EnvRtnUnknown(theEnv,1,&item1);
00916 
00917    if (EnvArgTypeCheck(theEnv,"member$",2,MULTIFIELD,&item2) == FALSE) return;
00918 
00919    if (FindDOsInSegment(&item1,1,&item2,&j,&k,NULL,0))
00920      {
00921       if (j == k)
00922         {
00923          result->type = INTEGER;
00924          result->value = (void *) EnvAddLong(theEnv,j);
00925         }
00926       else
00927         {
00928          result->type = MULTIFIELD;
00929          result->value = EnvCreateMultifield(theEnv,2);
00930          SetMFType(result->value,1,INTEGER);
00931          SetMFValue(result->value,1,EnvAddLong(theEnv,j));
00932          SetMFType(result->value,2,INTEGER);
00933          SetMFValue(result->value,2,EnvAddLong(theEnv,k));
00934          SetpDOBegin(result,1);
00935          SetpDOEnd(result,2);
00936         }
00937      }
00938   }
00939 
00940 /***************************************/
00941 /* FindDOsInSegment:                  */
00942 /***************************************/
00943 /* 6.05 Bug Fix */
00944 intBool FindDOsInSegment(
00945   DATA_OBJECT_PTR searchDOs,
00946   int scnt,
00947   DATA_OBJECT_PTR value,
00948   long *si,
00949   long *ei,
00950   long *excludes,
00951   int epaircnt)
00952   {
00953    long mul_length,slen,i,k; /* 6.04 Bug Fix */
00954    int j;
00955 
00956    mul_length = GetpDOLength(value);
00957    for (i = 0 ; i < mul_length ; i++)
00958      {
00959       for (j = 0 ; j < scnt ; j++)
00960         {
00961          if (GetType(searchDOs[j]) == MULTIFIELD)
00962            {
00963             slen = GetDOLength(searchDOs[j]);
00964             if (MVRangeCheck(i+1L,i+slen,excludes,epaircnt))
00965               {
00966                for (k = 0L ; (k < slen) && ((k + i) < mul_length) ; k++)
00967                  if ((GetMFType(GetValue(searchDOs[j]),k+GetDOBegin(searchDOs[j])) !=
00968                       GetMFType(GetpValue(value),k+i+GetpDOBegin(value))) ||
00969                      (GetMFValue(GetValue(searchDOs[j]),k+GetDOBegin(searchDOs[j])) !=
00970                       GetMFValue(GetpValue(value),k+i+GetpDOBegin(value))))
00971                    break;
00972                if (k >= slen)
00973                  {
00974                   *si = i + 1L;
00975                   *ei = i + slen;
00976                   return(TRUE);
00977                  }
00978               }
00979            }
00980          else if ((GetValue(searchDOs[j]) == GetMFValue(GetpValue(value),i + GetpDOBegin(value))) &&
00981                   (GetType(searchDOs[j]) == GetMFType(GetpValue(value),i + GetpDOBegin(value))) &&
00982                   MVRangeCheck(i+1L,i+1L,excludes,epaircnt))
00983            {
00984             *si = *ei = i+1L;
00985             return(TRUE);
00986            }
00987         }
00988      }
00989 
00990    return(FALSE);
00991   }
00992 
00993 /******************************************************/
00994 /* MVRangeCheck:  */
00995 /******************************************************/
00996 static intBool MVRangeCheck(
00997   long si,
00998   long ei,
00999   long *elist,
01000   int epaircnt)
01001 {
01002   int i;
01003 
01004   if (!elist || !epaircnt)
01005     return(TRUE);
01006   for (i = 0 ; i < epaircnt ; i++)
01007     if (((si >= elist[i*2]) && (si <= elist[i*2+1])) ||
01008         ((ei >= elist[i*2]) && (ei <= elist[i*2+1])))
01009     return(FALSE);
01010 
01011   return(TRUE);
01012 }
01013 
01014 #if (! BLOAD_ONLY) && (! RUN_TIME)
01015 
01016 /******************************************************/
01017 /* MultifieldPrognParser: Parses the progn$ function. */
01018 /******************************************************/
01019 static struct expr *MultifieldPrognParser(
01020   void *theEnv,
01021   struct expr *top,
01022   char *infile)
01023   {
01024    struct BindInfo *oldBindList,*newBindList,*prev;
01025    struct token tkn;
01026    struct expr *tmp;
01027    SYMBOL_HN *fieldVar = NULL;
01028 
01029    SavePPBuffer(theEnv," ");
01030    GetToken(theEnv,infile,&tkn);
01031 
01032    /* ================================
01033       Simple form: progn$ <mf-exp> ...
01034       ================================ */
01035    if (tkn.type != LPAREN)
01036      {
01037       top->argList = ParseAtomOrExpression(theEnv,infile,&tkn);
01038       if (top->argList == NULL)
01039         {
01040          ReturnExpression(theEnv,top);
01041          return(NULL);
01042         }
01043      }
01044    else
01045      {
01046       GetToken(theEnv,infile,&tkn);
01047       if (tkn.type != SF_VARIABLE)
01048         {
01049          if (tkn.type != SYMBOL)
01050            goto MvPrognParseError;
01051          top->argList = Function2Parse(theEnv,infile,ValueToString(tkn.value));
01052          if (top->argList == NULL)
01053            {
01054             ReturnExpression(theEnv,top);
01055             return(NULL);
01056            }
01057         }
01058 
01059       /* =========================================
01060          Complex form: progn$ (<var> <mf-exp>) ...
01061          ========================================= */
01062       else
01063         {
01064          fieldVar = (SYMBOL_HN *) tkn.value;
01065          SavePPBuffer(theEnv," ");
01066          top->argList = ParseAtomOrExpression(theEnv,infile,NULL);
01067          if (top->argList == NULL)
01068            {
01069             ReturnExpression(theEnv,top);
01070             return(NULL);
01071            }
01072          GetToken(theEnv,infile,&tkn);
01073          if (tkn.type != RPAREN)
01074            goto MvPrognParseError;
01075          PPBackup(theEnv);
01076          /* PPBackup(theEnv); */
01077          SavePPBuffer(theEnv,tkn.printForm);
01078          SavePPBuffer(theEnv," ");
01079         }
01080      }
01081 
01082    if (CheckArgumentAgainstRestriction(theEnv,top->argList,(int) 'm'))
01083      goto MvPrognParseError;
01084    oldBindList = GetParsedBindNames(theEnv);
01085    SetParsedBindNames(theEnv,NULL);
01086    IncrementIndentDepth(theEnv,3);
01087    ExpressionData(theEnv)->BreakContext = TRUE;
01088    ExpressionData(theEnv)->ReturnContext = ExpressionData(theEnv)->svContexts->rtn;
01089    PPCRAndIndent(theEnv);
01090    top->argList->nextArg = GroupActions(theEnv,infile,&tkn,TRUE,NULL,FALSE);
01091    DecrementIndentDepth(theEnv,3);
01092    PPBackup(theEnv);
01093    PPBackup(theEnv);
01094    SavePPBuffer(theEnv,tkn.printForm);
01095    if (top->argList->nextArg == NULL)
01096      {
01097       ClearParsedBindNames(theEnv);
01098       SetParsedBindNames(theEnv,oldBindList);
01099       ReturnExpression(theEnv,top);
01100       return(NULL);
01101      }
01102    tmp = top->argList->nextArg;
01103    top->argList->nextArg = tmp->argList;
01104    tmp->argList = NULL;
01105    ReturnExpression(theEnv,tmp);
01106    newBindList = GetParsedBindNames(theEnv);
01107    prev = NULL;
01108    while (newBindList != NULL)
01109      {
01110       if ((fieldVar == NULL) ? FALSE :
01111           (strcmp(ValueToString(newBindList->name),ValueToString(fieldVar)) == 0))
01112         {
01113          ClearParsedBindNames(theEnv);
01114          SetParsedBindNames(theEnv,oldBindList);
01115          PrintErrorID(theEnv,"MULTIFUN",2,FALSE);
01116          EnvPrintRouter(theEnv,WERROR,"Cannot rebind field variable in function progn$.\n");
01117          ReturnExpression(theEnv,top);
01118          return(NULL);
01119         }
01120       prev = newBindList;
01121       newBindList = newBindList->next;
01122      }
01123    if (prev == NULL)
01124      SetParsedBindNames(theEnv,oldBindList);
01125    else
01126      prev->next = oldBindList;
01127    if (fieldVar != NULL)
01128      ReplaceMvPrognFieldVars(theEnv,fieldVar,top->argList->nextArg,0);
01129    return(top);
01130 
01131 MvPrognParseError:
01132    SyntaxErrorMessage(theEnv,"progn$");
01133    ReturnExpression(theEnv,top);
01134    return(NULL);
01135   }
01136 
01137 /******************************************************/
01138 /* ForeachParser: Parses the foreach function. */
01139 /******************************************************/
01140 static struct expr *ForeachParser(
01141   void *theEnv,
01142   struct expr *top,
01143   char *infile)
01144   {
01145    struct BindInfo *oldBindList,*newBindList,*prev;
01146    struct token tkn;
01147    struct expr *tmp;
01148    SYMBOL_HN *fieldVar;
01149 
01150    SavePPBuffer(theEnv," ");
01151    GetToken(theEnv,infile,&tkn);
01152 
01153    if (tkn.type != SF_VARIABLE)
01154      { goto ForeachParseError; }
01155 
01156    fieldVar = (SYMBOL_HN *) tkn.value;
01157    SavePPBuffer(theEnv," ");
01158    top->argList = ParseAtomOrExpression(theEnv,infile,NULL);
01159    if (top->argList == NULL)
01160      {
01161       ReturnExpression(theEnv,top);
01162       return(NULL);
01163      }
01164 
01165    if (CheckArgumentAgainstRestriction(theEnv,top->argList,(int) 'm'))
01166      goto ForeachParseError;
01167    oldBindList = GetParsedBindNames(theEnv);
01168    SetParsedBindNames(theEnv,NULL);
01169    IncrementIndentDepth(theEnv,3);
01170    ExpressionData(theEnv)->BreakContext = TRUE;
01171    ExpressionData(theEnv)->ReturnContext = ExpressionData(theEnv)->svContexts->rtn;
01172    PPCRAndIndent(theEnv);
01173    top->argList->nextArg = GroupActions(theEnv,infile,&tkn,TRUE,NULL,FALSE);
01174    DecrementIndentDepth(theEnv,3);
01175    PPBackup(theEnv);
01176    PPBackup(theEnv);
01177    SavePPBuffer(theEnv,tkn.printForm);
01178    if (top->argList->nextArg == NULL)
01179      {
01180       ClearParsedBindNames(theEnv);
01181       SetParsedBindNames(theEnv,oldBindList);
01182       ReturnExpression(theEnv,top);
01183       return(NULL);
01184      }
01185    tmp = top->argList->nextArg;
01186    top->argList->nextArg = tmp->argList;
01187    tmp->argList = NULL;
01188    ReturnExpression(theEnv,tmp);
01189    newBindList = GetParsedBindNames(theEnv);
01190    prev = NULL;
01191    while (newBindList != NULL)
01192      {
01193       if ((fieldVar == NULL) ? FALSE :
01194           (strcmp(ValueToString(newBindList->name),ValueToString(fieldVar)) == 0))
01195         {
01196          ClearParsedBindNames(theEnv);
01197          SetParsedBindNames(theEnv,oldBindList);
01198          PrintErrorID(theEnv,"MULTIFUN",2,FALSE);
01199          EnvPrintRouter(theEnv,WERROR,"Cannot rebind field variable in function foreach.\n");
01200          ReturnExpression(theEnv,top);
01201          return(NULL);
01202         }
01203       prev = newBindList;
01204       newBindList = newBindList->next;
01205      }
01206    if (prev == NULL)
01207      SetParsedBindNames(theEnv,oldBindList);
01208    else
01209      prev->next = oldBindList;
01210    if (fieldVar != NULL)
01211      ReplaceMvPrognFieldVars(theEnv,fieldVar,top->argList->nextArg,0);
01212    return(top);
01213 
01214 ForeachParseError:
01215    SyntaxErrorMessage(theEnv,"foreach");
01216    ReturnExpression(theEnv,top);
01217    return(NULL);
01218   }
01219   
01220 /**********************************************/
01221 /* ReplaceMvPrognFieldVars: Replaces variable */
01222 /*   references found in the progn$ function. */
01223 /**********************************************/
01224 static void ReplaceMvPrognFieldVars(
01225   void *theEnv,
01226   SYMBOL_HN *fieldVar,
01227   struct expr *theExp,
01228   int depth)
01229   {
01230    size_t flen;
01231 
01232    flen = strlen(ValueToString(fieldVar));
01233    while (theExp != NULL)
01234      {
01235       if ((theExp->type != SF_VARIABLE) ? FALSE :
01236           (strncmp(ValueToString(theExp->value),ValueToString(fieldVar),
01237                    (STD_SIZE) flen) == 0))
01238         {
01239          if (ValueToString(theExp->value)[flen] == '\0')
01240            {
01241             theExp->type = FCALL;
01242             theExp->value = (void *) FindFunction(theEnv,"(get-progn$-field)");
01243             theExp->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long long) depth));
01244            }
01245          else if (strcmp(ValueToString(theExp->value) + flen,"-index") == 0)
01246            {
01247             theExp->type = FCALL;
01248             theExp->value = (void *) FindFunction(theEnv,"(get-progn$-index)");
01249             theExp->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long long) depth));
01250            }
01251         }
01252       else if (theExp->argList != NULL)
01253         {
01254          if ((theExp->type == FCALL) && ((theExp->value == (void *) FindFunction(theEnv,"progn$")) ||
01255                                         (theExp->value == (void *) FindFunction(theEnv,"foreach")) ))
01256            ReplaceMvPrognFieldVars(theEnv,fieldVar,theExp->argList,depth+1);
01257          else
01258            ReplaceMvPrognFieldVars(theEnv,fieldVar,theExp->argList,depth);
01259         }
01260       theExp = theExp->nextArg;
01261      }
01262   }
01263 
01264 #endif
01265 
01266 /*****************************************/
01267 /* MultifieldPrognFunction: H/L access   */
01268 /*   routine for the progn$ function.    */
01269 /*****************************************/
01270 globle void MultifieldPrognFunction(
01271   void *theEnv,
01272   DATA_OBJECT_PTR result)
01273   {
01274    MultifieldPrognDriver(theEnv,result,"progn$");
01275   }
01276 
01277 /***************************************/
01278 /* ForeachFunction: H/L access routine */
01279 /*   for the foreach function.         */
01280 /***************************************/
01281 globle void ForeachFunction(
01282   void *theEnv,
01283   DATA_OBJECT_PTR result)
01284   {
01285    MultifieldPrognDriver(theEnv,result,"foreach");
01286   }
01287     
01288 /*******************************************/
01289 /* MultifieldPrognDriver: Driver routine   */
01290 /*   for the progn$ and foreach functions. */
01291 /******************************************/
01292 static void MultifieldPrognDriver(
01293   void *theEnv,
01294   DATA_OBJECT_PTR result,
01295   char *functionName)
01296   {
01297    EXPRESSION *theExp;
01298    DATA_OBJECT argval;
01299    long i, end; /* 6.04 Bug Fix */
01300    FIELD_VAR_STACK *tmpField;
01301 
01302    tmpField = get_struct(theEnv,fieldVarStack);
01303    tmpField->type = SYMBOL;
01304    tmpField->value = EnvFalseSymbol(theEnv);
01305    tmpField->nxt = MultiFunctionData(theEnv)->FieldVarStack;
01306    MultiFunctionData(theEnv)->FieldVarStack = tmpField;
01307    result->type = SYMBOL;
01308    result->value = EnvFalseSymbol(theEnv);
01309    if (EnvArgTypeCheck(theEnv,functionName,1,MULTIFIELD,&argval) == FALSE)
01310      {
01311       MultiFunctionData(theEnv)->FieldVarStack = tmpField->nxt;
01312       rtn_struct(theEnv,fieldVarStack,tmpField);
01313       return;
01314      }
01315    ValueInstall(theEnv,&argval);
01316    end = GetDOEnd(argval);
01317    for (i = GetDOBegin(argval) ; i <= end ; i++)
01318      {
01319       tmpField->type = GetMFType(argval.value,i);
01320       tmpField->value = GetMFValue(argval.value,i);
01321       /* tmpField->index = i; */
01322       tmpField->index = (i - GetDOBegin(argval)) + 1; 
01323       for (theExp = GetFirstArgument()->nextArg ; theExp != NULL ; theExp = theExp->nextArg)
01324         {
01325          EvaluationData(theEnv)->CurrentEvaluationDepth++;
01326          EvaluateExpression(theEnv,theExp,result);
01327          EvaluationData(theEnv)->CurrentEvaluationDepth--;
01328          if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
01329            { PropagateReturnValue(theEnv,result); }
01330          PeriodicCleanup(theEnv,FALSE,TRUE);
01331 
01332          if (EvaluationData(theEnv)->HaltExecution || ProcedureFunctionData(theEnv)->BreakFlag || ProcedureFunctionData(theEnv)->ReturnFlag)
01333            {
01334             ValueDeinstall(theEnv,&argval);
01335             ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
01336             if (EvaluationData(theEnv)->HaltExecution)
01337               {
01338                result->type = SYMBOL;
01339                result->value = EnvFalseSymbol(theEnv);
01340               }
01341             MultiFunctionData(theEnv)->FieldVarStack = tmpField->nxt;
01342             rtn_struct(theEnv,fieldVarStack,tmpField);
01343             return;
01344            }
01345         }
01346      }
01347    ValueDeinstall(theEnv,&argval);
01348    ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
01349    MultiFunctionData(theEnv)->FieldVarStack = tmpField->nxt;
01350    rtn_struct(theEnv,fieldVarStack,tmpField);
01351   }
01352 
01353 /***************************************************/
01354 /* GetMvPrognField                                 */
01355 /***************************************************/
01356 globle void GetMvPrognField(
01357   void *theEnv,
01358   DATA_OBJECT_PTR result)
01359   {
01360    int depth;
01361    FIELD_VAR_STACK *tmpField;
01362 
01363    depth = ValueToInteger(GetFirstArgument()->value);
01364    tmpField = MultiFunctionData(theEnv)->FieldVarStack;
01365    while (depth > 0)
01366      {
01367       tmpField = tmpField->nxt;
01368       depth--;
01369      }
01370    result->type = tmpField->type;
01371    result->value = tmpField->value;
01372   }
01373 
01374 /***************************************************/
01375 /* GetMvPrognIndex                                 */
01376 /***************************************************/
01377 globle long GetMvPrognIndex(
01378   void *theEnv)
01379   {
01380    int depth;
01381    FIELD_VAR_STACK *tmpField;
01382 
01383    depth = ValueToInteger(GetFirstArgument()->value);
01384    tmpField = MultiFunctionData(theEnv)->FieldVarStack;
01385    while (depth > 0)
01386      {
01387       tmpField = tmpField->nxt;
01388       depth--;
01389      }
01390    return(tmpField->index);
01391   }
01392 
01393 #endif
01394 
01395 #if OBJECT_SYSTEM || MULTIFIELD_FUNCTIONS
01396 
01397 /**************************************************************************
01398   NAME         : ReplaceMultiValueField
01399   DESCRIPTION  : Performs a replace on the src multi-field value
01400                    storing the results in the dst multi-field value
01401   INPUTS       : 1) The destination value buffer
01402                  2) The source value (can be NULL)
01403                  3) Beginning of index range
01404                  4) End of range
01405                  5) The new field value
01406   RETURNS      : TRUE if successful, FALSE otherwise
01407   SIDE EFFECTS : Allocates and sets a ephemeral segment (even if new
01408                    number of fields is 0)
01409                  Src value segment is not changed
01410   NOTES        : index is NOT guaranteed to be valid
01411                  src is guaranteed to be a multi-field variable or NULL
01412  **************************************************************************/
01413 globle int ReplaceMultiValueField(
01414   void *theEnv,
01415   DATA_OBJECT *dst,
01416   DATA_OBJECT *src,
01417   long rb,
01418   long re,
01419   DATA_OBJECT *field,
01420   char *funcName)
01421   {
01422    long i,j,k;
01423    struct field *deptr;
01424    struct field *septr;
01425    long srclen,dstlen;
01426 
01427    srclen = ((src != NULL) ? (src->end - src->begin + 1) : 0);
01428    if ((re < rb) ||
01429            (rb < 1) || (re < 1) ||
01430            (rb > srclen) || (re > srclen))
01431          {
01432           MVRangeError(theEnv,rb,re,srclen,funcName);
01433           return(FALSE);
01434          }
01435    rb = src->begin + rb - 1;
01436    re = src->begin + re - 1;
01437    if (field->type == MULTIFIELD)
01438          dstlen = srclen + GetpDOLength(field) - (re-rb+1);
01439    else
01440          dstlen = srclen + 1 - (re-rb+1);
01441    dst->type = MULTIFIELD;
01442    dst->begin = 0;
01443    dst->value = EnvCreateMultifield(theEnv,dstlen);
01444    SetpDOEnd(dst,dstlen);
01445    for (i = 0 , j = src->begin ; j < rb ; i++ , j++)
01446          {
01447           deptr = &((struct multifield *) dst->value)->theFields[i];
01448           septr = &((struct multifield *) src->value)->theFields[j];
01449           deptr->type = septr->type;
01450           deptr->value = septr->value;
01451          }
01452    if (field->type != MULTIFIELD)
01453          {
01454           deptr = &((struct multifield *) dst->value)->theFields[i++];
01455           deptr->type = field->type;
01456           deptr->value = field->value;
01457          }
01458    else
01459          {
01460           for (k = field->begin ; k <= field->end ; k++ , i++)
01461                 {
01462                  deptr = &((struct multifield *) dst->value)->theFields[i];
01463                  septr = &((struct multifield *) field->value)->theFields[k];
01464                  deptr->type = septr->type;
01465                  deptr->value = septr->value;
01466                 }
01467          }
01468    while (j < re)
01469          j++;
01470    for (j++ ; i < dstlen ; i++ , j++)
01471          {
01472           deptr = &((struct multifield *) dst->value)->theFields[i];
01473           septr = &((struct multifield *) src->value)->theFields[j];
01474           deptr->type = septr->type;
01475           deptr->value = septr->value;
01476          }
01477    return(TRUE);
01478   }
01479 
01480 /**************************************************************************
01481   NAME         : InsertMultiValueField
01482   DESCRIPTION  : Performs an insert on the src multi-field value
01483                    storing the results in the dst multi-field value
01484   INPUTS       : 1) The destination value buffer
01485                  2) The source value (can be NULL)
01486                  3) The index for the change
01487                  4) The new field value
01488   RETURNS      : TRUE if successful, FALSE otherwise
01489   SIDE EFFECTS : Allocates and sets a ephemeral segment (even if new
01490                    number of fields is 0)
01491                  Src value segment is not changed
01492   NOTES        : index is NOT guaranteed to be valid
01493                  src is guaranteed to be a multi-field variable or NULL
01494  **************************************************************************/
01495 globle int InsertMultiValueField(
01496   void *theEnv,
01497   DATA_OBJECT *dst,
01498   DATA_OBJECT *src,
01499   long theIndex,
01500   DATA_OBJECT *field,
01501   char *funcName)
01502   {
01503    long i,j,k;
01504    register FIELD *deptr, *septr;
01505    long srclen,dstlen;
01506 
01507    srclen = (long) ((src != NULL) ? (src->end - src->begin + 1) : 0);
01508    if (theIndex < 1)
01509      {
01510       MVRangeError(theEnv,theIndex,theIndex,srclen+1,funcName);
01511       return(FALSE);
01512      }
01513    if (theIndex > (srclen + 1))
01514      theIndex = (srclen + 1);
01515    dst->type = MULTIFIELD;
01516    dst->begin = 0;
01517    if (src == NULL)
01518      {
01519       if (field->type == MULTIFIELD)
01520         {
01521          DuplicateMultifield(theEnv,dst,field);
01522          AddToMultifieldList(theEnv,(struct multifield *) dst->value);
01523         }
01524       else
01525         {
01526          dst->value = EnvCreateMultifield(theEnv,0L);
01527          dst->end = 0;
01528          deptr = &((struct multifield *) dst->value)->theFields[0];
01529          deptr->type = field->type;
01530          deptr->value = field->value;
01531         }
01532       return(TRUE);
01533      }
01534    dstlen = (field->type == MULTIFIELD) ? GetpDOLength(field) + srclen : srclen + 1;
01535    dst->value = EnvCreateMultifield(theEnv,dstlen);
01536    SetpDOEnd(dst,dstlen);
01537    theIndex--;
01538    for (i = 0 , j = src->begin ; i < theIndex ; i++ , j++)
01539      {
01540       deptr = &((struct multifield *) dst->value)->theFields[i];
01541       septr = &((struct multifield *) src->value)->theFields[j];
01542       deptr->type = septr->type;
01543       deptr->value = septr->value;
01544      }
01545    if (field->type != MULTIFIELD)
01546      {
01547       deptr = &((struct multifield *) dst->value)->theFields[theIndex];
01548       deptr->type = field->type;
01549       deptr->value = field->value;
01550       i++;
01551      }
01552    else
01553      {
01554       for (k = field->begin ; k <= field->end ; k++ , i++)
01555         {
01556          deptr = &((struct multifield *) dst->value)->theFields[i];
01557          septr = &((struct multifield *) field->value)->theFields[k];
01558          deptr->type = septr->type;
01559          deptr->value = septr->value;
01560         }
01561      }
01562    for ( ; j <= src->end ; i++ , j++)
01563      {
01564       deptr = &((struct multifield *) dst->value)->theFields[i];
01565       septr = &((struct multifield *) src->value)->theFields[j];
01566       deptr->type = septr->type;
01567       deptr->value = septr->value;
01568      }
01569    return(TRUE);
01570   }
01571 
01572 /*******************************************************
01573   NAME         : MVRangeError
01574   DESCRIPTION  : Prints out an error messages for index
01575                    out-of-range errors in multi-field
01576                    access functions
01577   INPUTS       : 1) The bad range start
01578                  2) The bad range end
01579                  3) The max end of the range (min is
01580                      assumed to be 1)
01581   RETURNS      : Nothing useful
01582   SIDE EFFECTS : None
01583   NOTES        : None
01584  ******************************************************/
01585 static void MVRangeError(
01586   void *theEnv,
01587   long brb,
01588   long bre,
01589   long max,
01590   char *funcName)
01591   {
01592    PrintErrorID(theEnv,"MULTIFUN",1,FALSE);
01593    EnvPrintRouter(theEnv,WERROR,"Multifield index ");
01594    if (brb == bre)
01595      PrintLongInteger(theEnv,WERROR,(long long) brb);
01596    else
01597      {
01598       EnvPrintRouter(theEnv,WERROR,"range ");
01599       PrintLongInteger(theEnv,WERROR,(long long) brb);
01600       EnvPrintRouter(theEnv,WERROR,"..");
01601       PrintLongInteger(theEnv,WERROR,(long long) bre);
01602      }
01603    EnvPrintRouter(theEnv,WERROR," out of range 1..");
01604    PrintLongInteger(theEnv,WERROR,(long long) max);
01605    if (funcName != NULL)
01606      {
01607       EnvPrintRouter(theEnv,WERROR," in function ");
01608       EnvPrintRouter(theEnv,WERROR,funcName);
01609      }
01610    EnvPrintRouter(theEnv,WERROR,".\n");
01611   }
01612 
01613 /**************************************************************************
01614   NAME         : DeleteMultiValueField
01615   DESCRIPTION  : Performs a modify on the src multi-field value
01616                    storing the results in the dst multi-field value
01617   INPUTS       : 1) The destination value buffer
01618                  2) The source value (can be NULL)
01619                  3) The beginning index for deletion
01620                  4) The ending index for deletion
01621   RETURNS      : TRUE if successful, FALSE otherwise
01622   SIDE EFFECTS : Allocates and sets a ephemeral segment (even if new
01623                    number of fields is 0)
01624                  Src value segment is not changed
01625   NOTES        : index is NOT guaranteed to be valid
01626                  src is guaranteed to be a multi-field variable or NULL
01627  **************************************************************************/
01628 globle int DeleteMultiValueField(
01629   void *theEnv,
01630   DATA_OBJECT *dst,
01631   DATA_OBJECT *src,
01632   long rb,
01633   long re,
01634   char *funcName)
01635   {
01636    long i,j;
01637    register FIELD_PTR deptr,septr;
01638    long srclen, dstlen;
01639 
01640    srclen = (long) ((src != NULL) ? (src->end - src->begin + 1) : 0);
01641    if ((re < rb) ||
01642        (rb < 1) || (re < 1) ||
01643        (rb > srclen) || (re > srclen))
01644      {
01645       MVRangeError(theEnv,rb,re,srclen,funcName);
01646       return(FALSE);
01647      }
01648    dst->type = MULTIFIELD;
01649    dst->begin = 0;
01650    if (srclen == 0)
01651     {
01652      dst->value = EnvCreateMultifield(theEnv,0L);
01653      dst->end = -1;
01654      return(TRUE);
01655     }
01656    rb = src->begin + rb -1;
01657    re = src->begin + re -1;
01658    dstlen = srclen-(re-rb+1);
01659    SetpDOEnd(dst,dstlen);
01660    dst->value = EnvCreateMultifield(theEnv,dstlen);
01661    for (i = 0 , j = src->begin ; j < rb ; i++ , j++)
01662      {
01663       deptr = &((struct multifield *) dst->value)->theFields[i];
01664       septr = &((struct multifield *) src->value)->theFields[j];
01665       deptr->type = septr->type;
01666       deptr->value = septr->value;
01667      }
01668    while (j < re)
01669      j++;
01670    for (j++ ; i <= dst->end ; j++ , i++)
01671      {
01672       deptr = &((struct multifield *) dst->value)->theFields[i];
01673       septr = &((struct multifield *) src->value)->theFields[j];
01674       deptr->type = septr->type;
01675       deptr->value = septr->value;
01676      }
01677    return(TRUE);
01678   }
01679 
01680 #endif