globle void CheckSyntaxFunction(
  void *theEnv,
  DATA_OBJECT *returnValue)
  {
   DATA_OBJECT theArg;

   /*===============================*/
   /* Set up a default return value */
   /* (TRUE for problems found).    */
   /*===============================*/

   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvTrueSymbol(theEnv));

   /*=====================================================*/
   /* Function check-syntax expects exactly one argument. */
   /*=====================================================*/

   if (EnvArgCountCheck(theEnv,"check-syntax",EXACTLY,1) == -1) return;

   /*========================================*/
   /* The argument should be of type STRING. */
   /*========================================*/

   if (EnvArgTypeCheck(theEnv,"check-syntax",1,STRING,&theArg) == FALSE)
     { return; }

   /*===================*/
   /* Check the syntax. */
   /*===================*/

   CheckSyntax(theEnv,DOToString(theArg),returnValue);
  }
Beispiel #2
0
globle int FactPNCompVars1(
  void *theEnv,
  void *theValue,
  DATA_OBJECT *theResult)
  {
   int rv;
   struct field *fieldPtr1, *fieldPtr2;
   struct factCompVarsPN1Call *hack;

   /*========================================*/
   /* Extract the arguments to the function. */
   /*========================================*/

   hack = (struct factCompVarsPN1Call *) ValueToBitMap(theValue);
   fieldPtr1 = &FactData(theEnv)->CurrentPatternFact->theProposition.theFields[hack->field1];
   fieldPtr2 = &FactData(theEnv)->CurrentPatternFact->theProposition.theFields[hack->field2];

   /*=====================*/
   /* Compare the values. */
   /*=====================*/

   if (fieldPtr1->type != fieldPtr2->type) rv = (int) hack->fail;
   else if (fieldPtr1->value != fieldPtr2->value) rv = (int) hack->fail;
   else rv = (int) hack->pass;

   theResult->type = SYMBOL;
   if (rv) theResult->value = EnvTrueSymbol(theEnv);
   else theResult->value = EnvFalseSymbol(theEnv);

   return(rv);
  }
Beispiel #3
0
static intBool JNSimpleCompareFunction3(
    void *theEnv,
    void *theValue,
    DATA_OBJECT *theResult)
{
    INSTANCE_TYPE *ins1,*ins2;
    struct multifieldMarker *theMarks;
    struct ObjectCmpJoinSingleSlotVars3 *hack;
    int rv;
    FIELD f1,f2;

    hack = (struct ObjectCmpJoinSingleSlotVars3 *) ValueToBitMap(theValue);
    GetPatternObjectAndMarks(theEnv,((int) hack->firstPattern),hack->firstPatternLHS,hack->firstPatternRHS,&ins1,&theMarks);
    GetInsMultiSlotField(&f1,ins1,(unsigned) hack->firstSlot,
                         (unsigned) hack->firstFromBeginning,
                         (unsigned) hack->firstOffset);
    GetPatternObjectAndMarks(theEnv,((int) hack->secondPattern),hack->secondPatternLHS,hack->secondPatternRHS,&ins2,&theMarks);
    GetInsMultiSlotField(&f2,ins2,(unsigned) hack->secondSlot,
                         (unsigned) hack->secondFromBeginning,
                         (unsigned) hack->secondOffset);
    if (f1.type != f2.type)
        rv = hack->fail;
    else if (f1.value != f2.value)
        rv = hack->fail;
    else
        rv = hack->pass;
    theResult->type = SYMBOL;
    theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
    return(rv);
}
Beispiel #4
0
globle intBool FactSlotLength(
  void *theEnv,
  void *theValue,
  DATA_OBJECT_PTR returnValue)
  {
   struct factCheckLengthPNCall *hack;
   struct multifield *segmentPtr;
   long extraOffset = 0;
   struct multifieldMarker *tempMark;

   returnValue->type = SYMBOL;
   returnValue->value = EnvFalseSymbol(theEnv);

   hack = (struct factCheckLengthPNCall *) ValueToBitMap(theValue);

   for (tempMark = FactData(theEnv)->CurrentPatternMarks;
        tempMark != NULL;
        tempMark = tempMark->next)
     {
      if (tempMark->where.whichSlotNumber != hack->whichSlot) continue;
      extraOffset += ((tempMark->endPosition - tempMark->startPosition) + 1);
     }

   segmentPtr = (struct multifield *) FactData(theEnv)->CurrentPatternFact->theProposition.theFields[hack->whichSlot].value;

   if (segmentPtr->multifieldLength < (hack->minLength + extraOffset))
     { return(FALSE); }

   if (hack->exactly && (segmentPtr->multifieldLength > (hack->minLength + extraOffset)))
     { return(FALSE); }

   returnValue->value = EnvTrueSymbol(theEnv);
   return(TRUE);
  }
Beispiel #5
0
static CLIPS_BOOLEAN JNSimpleCompareFunction2(
  void *theEnv,
  void *theValue,
  DATA_OBJECT *theResult)
  {
   INSTANCE_TYPE *ins1,*ins2;
   struct multifieldMarker *theMarks;
   struct ObjectCmpJoinSingleSlotVars2 *hack;
   int rv;
   FIELD f1;
   INSTANCE_SLOT *is2;

   hack = (struct ObjectCmpJoinSingleSlotVars2 *) ValueToBitMap(theValue);
   GetPatternObjectAndMarks(theEnv,((int) hack->firstPattern) - 1,&ins1,&theMarks);
   GetInsMultiSlotField(&f1,ins1,(unsigned) hack->firstSlot,
                        (unsigned) hack->fromBeginning,(unsigned) hack->offset);
   GetPatternObjectAndMarks(theEnv,((int) hack->secondPattern) - 1,&ins2,&theMarks);
   is2 = GetInsSlot(ins2,hack->secondSlot);
   if (f1.type != is2->type)
     rv = hack->fail;
   else if (f1.value != is2->value)
     rv = hack->fail;
   else
     rv = hack->pass;
   theResult->type = SYMBOL;
   theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
   return(rv);
  }
Beispiel #6
0
static intBool JNSimpleCompareFunction1(
    void *theEnv,
    void *theValue,
    DATA_OBJECT *theResult)
{
    INSTANCE_TYPE *ins1,*ins2;
    struct multifieldMarker *theMarks;
    struct ObjectCmpJoinSingleSlotVars1 *hack;
    int rv;
    INSTANCE_SLOT *is1,*is2;

    hack = (struct ObjectCmpJoinSingleSlotVars1 *) ValueToBitMap(theValue);
    GetPatternObjectAndMarks(theEnv,((int) hack->firstPattern),hack->firstPatternLHS,hack->firstPatternRHS,&ins1,&theMarks);
    is1 = GetInsSlot(ins1,hack->firstSlot);
    GetPatternObjectAndMarks(theEnv,((int) hack->secondPattern),hack->secondPatternLHS,hack->secondPatternRHS,&ins2,&theMarks);
    is2 = GetInsSlot(ins2,hack->secondSlot);
    if (is1->type != is2->type)
        rv = hack->fail;
    else if (is1->value != is2->value)
        rv = hack->fail;
    else
        rv = hack->pass;
    theResult->type = SYMBOL;
    theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
    return(rv);
}
globle void CheckSyntaxFunction(
  void *theEnv,
  DATA_OBJECT *returnValue)
  {
   PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
   EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvTrueSymbol(theEnv));
  }
Beispiel #8
0
globle int CheckSyntax(
  void *theEnv,
  const char *theString,
  DATA_OBJECT_PTR returnValue)
  {

   PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
   EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvTrueSymbol(theEnv));
   return(TRUE);
  }
Beispiel #9
0
/*****************************************************
  NAME         : ObjectCmpConstantFunction
  DESCRIPTION  : Used to compare object slot values
                 against a constant
  INPUTS       : 1) The constant test bitmap
                 2) Data object buffer to hold result
  RETURNS      : TRUE if test successful,
                 FALSE otherwise
  SIDE EFFECTS : Buffer set to symbol TRUE if test
                 successful, FALSE otherwise
  NOTES        : Called directly by
                   EvaluatePatternExpression()
 *****************************************************/
globle intBool ObjectCmpConstantFunction(
    void *theEnv,
    void *theValue,
    DATA_OBJECT *theResult)
{
    struct ObjectCmpPNConstant *hack;
    DATA_OBJECT theVar;
    EXPRESSION *constantExp;
    int rv;
    SEGMENT *theSegment;

    hack = (struct ObjectCmpPNConstant *) ValueToBitMap(theValue);
    if (hack->general)
    {
        EvaluateExpression(theEnv,GetFirstArgument(),&theVar);
        constantExp = GetFirstArgument()->nextArg;
    }
    else
    {
        constantExp = GetFirstArgument();
        if (ObjectReteData(theEnv)->CurrentPatternObjectSlot->type == MULTIFIELD)
        {
            theSegment = (struct multifield *) ObjectReteData(theEnv)->CurrentPatternObjectSlot->value;
            if (hack->fromBeginning)
            {
                theVar.type = theSegment->theFields[hack->offset].type;
                theVar.value = theSegment->theFields[hack->offset].value;
            }
            else
            {
                theVar.type = theSegment->theFields[theSegment->multifieldLength -
                                                    (hack->offset + 1)].type;
                theVar.value = theSegment->theFields[theSegment->multifieldLength -
                                                     (hack->offset + 1)].value;
            }
        }
        else
        {
            theVar.type = (unsigned short) ObjectReteData(theEnv)->CurrentPatternObjectSlot->type;
            theVar.value = ObjectReteData(theEnv)->CurrentPatternObjectSlot->value;
        }
    }
    if (theVar.type != constantExp->type)
        rv = hack->fail;
    else if (theVar.value != constantExp->value)
        rv = hack->fail;
    else
        rv = hack->pass;
    theResult->type = SYMBOL;
    theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
    return(rv);
}
globle int CheckSyntax(
  void *theEnv,
  char *theString,
  DATA_OBJECT_PTR returnValue)
  {
#if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theString)
#pragma unused(returnValue)
#endif

   PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
   EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvTrueSymbol(theEnv));
   return(TRUE);
  }
Beispiel #11
0
/********************************************************************************
  NAME         : ParseSlotOverrides
  DESCRIPTION  : Forms expressions for slot-overrides
  INPUTS       : 1) The logical name of the input
                 2) Caller's buffer for error flkag
  RETURNS      : Address override expressions, NULL
                   if none or error.
  SIDE EFFECTS : Slot-expression built
                 Caller's error flag set
  NOTES        : <slot-override> ::= (<slot-name> <value>*)*

                 goes to

                 <slot-name> --> <dummy-node> --> <slot-name> --> <dummy-node>...
                                       |
                                       V
                               <value-expression> --> <value-expression> --> ...

                 Assumes first token has already been scanned
 ********************************************************************************/
globle EXPRESSION *ParseSlotOverrides(
  void *theEnv,
  const char *readSource,
  int *error)
  {
   EXPRESSION *top = NULL,*bot = NULL,*theExp;
   EXPRESSION *theExpNext;

   while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
     {
      *error = FALSE;
      theExp = ArgumentParse(theEnv,readSource,error);
      if (*error == TRUE)
        {
         ReturnExpression(theEnv,top);
         return(NULL);
        }
      else if (theExp == NULL)
        {
         SyntaxErrorMessage(theEnv,"slot-override");
         *error = TRUE;
         ReturnExpression(theEnv,top);
         SetEvaluationError(theEnv,TRUE);
         return(NULL);
        }
      theExpNext = GenConstant(theEnv,SYMBOL,EnvTrueSymbol(theEnv));
      if (CollectArguments(theEnv,theExpNext,readSource) == NULL)
        {
         *error = TRUE;
         ReturnExpression(theEnv,top);
         ReturnExpression(theEnv,theExp);
         return(NULL);
        }
      theExp->nextArg = theExpNext;
      if (top == NULL)
        top = theExp;
      else
        bot->nextArg = theExp;
      bot = theExp->nextArg;
      PPCRAndIndent(theEnv);
      GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
     }
   PPBackup(theEnv);
   PPBackup(theEnv);
   SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
   return(top);
  }
Beispiel #12
0
static intBool SlotLengthTestFunction(
    void *theEnv,
    void *theValue,
    DATA_OBJECT *theResult)
{
    struct ObjectMatchLength *hack;

    theResult->type = SYMBOL;
    theResult->value = EnvFalseSymbol(theEnv);
    hack = (struct ObjectMatchLength *) ValueToBitMap(theValue);
    if (ObjectReteData(theEnv)->CurrentObjectSlotLength < hack->minLength)
        return(FALSE);
    if (hack->exactly && (ObjectReteData(theEnv)->CurrentObjectSlotLength > hack->minLength))
        return(FALSE);
    theResult->value = EnvTrueSymbol(theEnv);
    return(TRUE);
}
Beispiel #13
0
static intBool PNSimpleCompareFunction1(
    void *theEnv,
    void *theValue,
    DATA_OBJECT *theResult)
{
    struct ObjectCmpPNSingleSlotVars1 *hack;
    INSTANCE_SLOT *is1,*is2;
    int rv;

    hack = (struct ObjectCmpPNSingleSlotVars1 *) ValueToBitMap(theValue);
    is1 = GetInsSlot(ObjectReteData(theEnv)->CurrentPatternObject,hack->firstSlot);
    is2 = GetInsSlot(ObjectReteData(theEnv)->CurrentPatternObject,hack->secondSlot);
    if (is1->type != is2->type)
        rv = hack->fail;
    else if (is1->value != is2->value)
        rv = hack->fail;
    else
        rv = hack->pass;
    theResult->type = SYMBOL;
    theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
    return(rv);
}
Beispiel #14
0
static intBool PNSimpleCompareFunction3(
    void *theEnv,
    void *theValue,
    DATA_OBJECT *theResult)
{
    struct ObjectCmpPNSingleSlotVars3 *hack;
    int rv;
    FIELD f1,f2;

    hack = (struct ObjectCmpPNSingleSlotVars3 *) ValueToBitMap(theValue);
    GetInsMultiSlotField(&f1,ObjectReteData(theEnv)->CurrentPatternObject,(unsigned) hack->firstSlot,
                         (unsigned) hack->firstFromBeginning,(unsigned) hack->firstOffset);
    GetInsMultiSlotField(&f2,ObjectReteData(theEnv)->CurrentPatternObject,(unsigned) hack->secondSlot,
                         (unsigned) hack->secondFromBeginning,(unsigned) hack->secondOffset);
    if (f1.type != f2.type)
        rv = hack->fail;
    else if (f1.value != f2.value)
        rv = hack->fail;
    else
        rv = hack->pass;
    theResult->type = SYMBOL;
    theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
    return(rv);
}
Beispiel #15
0
static CLIPS_BOOLEAN PNSimpleCompareFunction2(
  void *theEnv,
  void *theValue,
  DATA_OBJECT *theResult)
  {
   struct ObjectCmpPNSingleSlotVars2 *hack;
   int rv;
   FIELD f1;
   INSTANCE_SLOT *is2;

   hack = (struct ObjectCmpPNSingleSlotVars2 *) ValueToBitMap(theValue);
   GetInsMultiSlotField(&f1,ObjectReteData(theEnv)->CurrentPatternObject,(unsigned) hack->firstSlot,
                             (unsigned) hack->fromBeginning,(unsigned) hack->offset);
   is2 = GetInsSlot(ObjectReteData(theEnv)->CurrentPatternObject,hack->secondSlot);
   if (f1.type != is2->type)
     rv = hack->fail;
   else if (f1.value != is2->value)
     rv = hack->fail;
   else
     rv = hack->pass;
   theResult->type = SYMBOL;
   theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
   return(rv);
  }
Beispiel #16
0
globle int EvaluateExpression(
  void *theEnv,
  struct expr *problem,
  DATA_OBJECT_PTR returnValue)
  {
   struct expr *oldArgument;
   void *oldContext;
   struct FunctionDefinition *fptr;
#if PROFILING_FUNCTIONS
   struct profileFrameInfo profileFrame;
#endif

   if (problem == NULL)
     {
      returnValue->type = SYMBOL;
      returnValue->value = EnvFalseSymbol(theEnv);
      return(EvaluationData(theEnv)->EvaluationError);
     }

   switch (problem->type)
     {
      case STRING:
      case SYMBOL:
      case FLOAT:
      case INTEGER:
#if OBJECT_SYSTEM
      case INSTANCE_NAME:
      case INSTANCE_ADDRESS:
#endif
      case EXTERNAL_ADDRESS:
        returnValue->type = problem->type;
        returnValue->value = problem->value;
        break;

      case DATA_OBJECT_ARRAY: /* TBD Remove with AddPrimitive */
        returnValue->type = problem->type;
        returnValue->value = problem->value;
        break;

      case FCALL:
        {
         fptr = (struct FunctionDefinition *) problem->value;
         oldContext = SetEnvironmentFunctionContext(theEnv,fptr->context);

#if PROFILING_FUNCTIONS   
         StartProfile(theEnv,&profileFrame,
                      &fptr->usrData,
                      ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif

         oldArgument = EvaluationData(theEnv)->CurrentExpression;
         EvaluationData(theEnv)->CurrentExpression = problem;

         switch(fptr->returnValueType)
           {
            case 'v' :
              if (fptr->environmentAware)
                { (* (void (*)(void *)) fptr->functionPointer)(theEnv); }
              else
                { (* (void (*)(void)) fptr->functionPointer)(); }
              returnValue->type = RVOID;
              returnValue->value = EnvFalseSymbol(theEnv);
              break;
            case 'b' :
              returnValue->type = SYMBOL;
              if (fptr->environmentAware)
                {
                 if ((* (int (*)(void *)) fptr->functionPointer)(theEnv))
                   returnValue->value = EnvTrueSymbol(theEnv);
                 else
                   returnValue->value = EnvFalseSymbol(theEnv);
                }
              else
                {
                 if ((* (int (*)(void)) fptr->functionPointer)())
                   returnValue->value = EnvTrueSymbol(theEnv);
                 else
                   returnValue->value = EnvFalseSymbol(theEnv);
                }
              break;
            case 'a' :
              returnValue->type = EXTERNAL_ADDRESS;
              if (fptr->environmentAware)
                {
                 returnValue->value =
                                (* (void *(*)(void *)) fptr->functionPointer)(theEnv);
                }
              else
                {
                 returnValue->value =
                                (* (void *(*)(void)) fptr->functionPointer)();
                }
              break;
            case 'g' :
              returnValue->type = INTEGER;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                   EnvAddLong(theEnv,(* (long long (*)(void *)) fptr->functionPointer)(theEnv));
                }
              else
                {
                 returnValue->value = (void *)
                   EnvAddLong(theEnv,(* (long long (*)(void)) fptr->functionPointer)());
                }
              break;
            case 'i' :
              returnValue->type = INTEGER;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                   EnvAddLong(theEnv,(long long) (* (int (*)(void *)) fptr->functionPointer)(theEnv));
                }
              else
                {
                 returnValue->value = (void *)
                   EnvAddLong(theEnv,(long long) (* (int (*)(void)) fptr->functionPointer)());
                }
              break;
            case 'l' :
              returnValue->type = INTEGER;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                    EnvAddLong(theEnv,(long long) (* (long int (*)(void *)) fptr->functionPointer)(theEnv));
                }
              else
                {
                 returnValue->value = (void *)
                    EnvAddLong(theEnv,(long long) (* (long int (*)(void)) fptr->functionPointer)());
                }
              break;
            case 'f' :
              returnValue->type = FLOAT;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                    EnvAddDouble(theEnv,(double) (* (float (*)(void *)) fptr->functionPointer)(theEnv));
                }
              else
                {
                 returnValue->value = (void *)
                    EnvAddDouble(theEnv,(double) (* (float (*)(void)) fptr->functionPointer)());
                }
              break;
            case 'd' :
              returnValue->type = FLOAT;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                    EnvAddDouble(theEnv,(* (double (*)(void *)) fptr->functionPointer)(theEnv));
                }
              else
                {
                 returnValue->value = (void *)
                    EnvAddDouble(theEnv,(* (double (*)(void)) fptr->functionPointer)());
                }
              break;
            case 's' :
              returnValue->type = STRING;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                   (* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
                }
              else
                {
                 returnValue->value = (void *)
                   (* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
                }
              break;
            case 'w' :
              returnValue->type = SYMBOL;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                   (* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
                }
              else
                {
                 returnValue->value = (void *)
                   (* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
                }
              break;
#if OBJECT_SYSTEM
            case 'x' :
              returnValue->type = INSTANCE_ADDRESS;
              if (fptr->environmentAware)
                {
                 returnValue->value =
                                (* (void *(*)(void *)) fptr->functionPointer)(theEnv);
                }
              else
                {
                 returnValue->value =
                                (* (void *(*)(void)) fptr->functionPointer)();
                }
              break;
            case 'o' :
              returnValue->type = INSTANCE_NAME;
              if (fptr->environmentAware)
                {
                 returnValue->value = (void *)
                   (* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
                }
              else
                {
                 returnValue->value = (void *)
                   (* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
                }
              break;
#endif
            case 'c' :
              {
               char cbuff[2];
               if (fptr->environmentAware)
                 {
                  cbuff[0] = (* (char (*)(void *)) fptr->functionPointer)(theEnv);
                 }
               else
                 {
                  cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
                 }
               cbuff[1] = EOS;
               returnValue->type = SYMBOL;
               returnValue->value = (void *) EnvAddSymbol(theEnv,cbuff);
               break;
              }

            case 'j' :
            case 'k' :
            case 'm' :
            case 'n' :
            case 'u' :
               if (fptr->environmentAware)
                 {
                  (* (void (*)(void *,DATA_OBJECT_PTR)) fptr->functionPointer)(theEnv,returnValue);
                 }
               else
                 {
                  (* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
                 }
              break;

            default :
               SystemError(theEnv,"EVALUATN",2);
               EnvExitRouter(theEnv,EXIT_FAILURE);
               break;
            }

#if PROFILING_FUNCTIONS 
        EndProfile(theEnv,&profileFrame);
#endif

        SetEnvironmentFunctionContext(theEnv,oldContext);
        EvaluationData(theEnv)->CurrentExpression = oldArgument;
        break;
        }

     case MULTIFIELD:
        returnValue->type = MULTIFIELD;
        returnValue->value = ((DATA_OBJECT_PTR) (problem->value))->value;
        returnValue->begin = ((DATA_OBJECT_PTR) (problem->value))->begin;
        returnValue->end = ((DATA_OBJECT_PTR) (problem->value))->end;
        break;

     case MF_VARIABLE:
     case SF_VARIABLE:
        if (GetBoundVariable(theEnv,returnValue,(SYMBOL_HN *) problem->value) == FALSE)
          {
           PrintErrorID(theEnv,"EVALUATN",1,FALSE);
           EnvPrintRouter(theEnv,WERROR,"Variable ");
           EnvPrintRouter(theEnv,WERROR,ValueToString(problem->value));
           EnvPrintRouter(theEnv,WERROR," is unbound\n");
           returnValue->type = SYMBOL;
           returnValue->value = EnvFalseSymbol(theEnv);
           SetEvaluationError(theEnv,TRUE);
          }
        break;

      default:
        if (EvaluationData(theEnv)->PrimitivesArray[problem->type] == NULL)
          {
           SystemError(theEnv,"EVALUATN",3);
           EnvExitRouter(theEnv,EXIT_FAILURE);
          }

        if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->copyToEvaluate)
          {
           returnValue->type = problem->type;
           returnValue->value = problem->value;
           break;
          }

        if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction == NULL)
          {
           SystemError(theEnv,"EVALUATN",4);
           EnvExitRouter(theEnv,EXIT_FAILURE);
          }

        oldArgument = EvaluationData(theEnv)->CurrentExpression;
        EvaluationData(theEnv)->CurrentExpression = problem;

#if PROFILING_FUNCTIONS 
        StartProfile(theEnv,&profileFrame,
                     &EvaluationData(theEnv)->PrimitivesArray[problem->type]->usrData,
                     ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif

        (*EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction)(theEnv,problem->value,returnValue);

#if PROFILING_FUNCTIONS
        EndProfile(theEnv,&profileFrame);
#endif

        EvaluationData(theEnv)->CurrentExpression = oldArgument;
        break;
     }

   return(EvaluationData(theEnv)->EvaluationError);
  }
globle int CheckSyntax(
  void *theEnv,
  char *theString,
  DATA_OBJECT_PTR returnValue)
  {
   char *name;
   struct token theToken;
   struct expr *top;
   short rv;

   /*==============================*/
   /* Set the default return value */
   /* (TRUE for problems found).   */
   /*==============================*/

   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvTrueSymbol(theEnv));

   /*===========================================*/
   /* Create a string source router so that the */
   /* string can be used as an input source.    */
   /*===========================================*/

   if (OpenStringSource(theEnv,"check-syntax",theString,0) == 0)
     { return(TRUE); }

   /*=================================*/
   /* Only expressions and constructs */
   /* can have their syntax checked.  */
   /*=================================*/

   GetToken(theEnv,"check-syntax",&theToken);

   if (theToken.type != LPAREN)
     {
      CloseStringSource(theEnv,"check-syntax");
      SetpValue(returnValue,EnvAddSymbol(theEnv,"MISSING-LEFT-PARENTHESIS"));
      return(TRUE);
     }

   /*========================================*/
   /* The next token should be the construct */
   /* type or function name.                 */
   /*========================================*/

   GetToken(theEnv,"check-syntax",&theToken);
   if (theToken.type != SYMBOL)
     {
      CloseStringSource(theEnv,"check-syntax");
      SetpValue(returnValue,EnvAddSymbol(theEnv,"EXPECTED-SYMBOL-AFTER-LEFT-PARENTHESIS"));
      return(TRUE);
     }

   name = ValueToString(theToken.value);

   /*==============================================*/
   /* Set up a router to capture the error output. */
   /*==============================================*/

   EnvAddRouter(theEnv,"error-capture",40,
              FindErrorCapture, PrintErrorCapture,
              NULL, NULL, NULL);

   /*================================*/
   /* Determine if it's a construct. */
   /*================================*/

   if (FindConstruct(theEnv,name))
     {
      ConstructData(theEnv)->CheckSyntaxMode = TRUE;
      rv = (short) ParseConstruct(theEnv,name,"check-syntax");
      GetToken(theEnv,"check-syntax",&theToken);
      ConstructData(theEnv)->CheckSyntaxMode = FALSE;

      if (rv)
        {
         EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
         PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
         EnvPrintRouter(theEnv,WERROR,"\n");
        }

      DestroyPPBuffer(theEnv);

      CloseStringSource(theEnv,"check-syntax");

      if ((rv != FALSE) || (ParseFunctionData(theEnv)->WarningString != NULL))
        {
         SetErrorCaptureValues(theEnv,returnValue);
         DeactivateErrorCapture(theEnv);
         return(TRUE);
        }

      if (theToken.type != STOP)
        {
         SetpValue(returnValue,EnvAddSymbol(theEnv,"EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
         DeactivateErrorCapture(theEnv);
         return(TRUE);
        }

      SetpType(returnValue,SYMBOL);
      SetpValue(returnValue,EnvFalseSymbol(theEnv));
      DeactivateErrorCapture(theEnv);
      return(FALSE);
     }

   /*=======================*/
   /* Parse the expression. */
   /*=======================*/

   top = Function2Parse(theEnv,"check-syntax",name);
   GetToken(theEnv,"check-syntax",&theToken);
   ClearParsedBindNames(theEnv);
   CloseStringSource(theEnv,"check-syntax");

   if (top == NULL)
     {
      SetErrorCaptureValues(theEnv,returnValue);
      DeactivateErrorCapture(theEnv);
      return(TRUE);
     }

   if (theToken.type != STOP)
     {
      SetpValue(returnValue,EnvAddSymbol(theEnv,"EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
      DeactivateErrorCapture(theEnv);
      ReturnExpression(theEnv,top);
      return(TRUE);
     }

   DeactivateErrorCapture(theEnv);

   ReturnExpression(theEnv,top);
   SetpType(returnValue,SYMBOL);
   SetpValue(returnValue,EnvFalseSymbol(theEnv));
   return(FALSE);
  }
Beispiel #18
0
/****************************************************************************
  NAME         : ParseSimpleInstance
  DESCRIPTION  : Parses instances from file for load-instances
                   into an EXPRESSION forms that
                   can later be evaluated with EvaluateExpression(theEnv,)
  INPUTS       : 1) The address of the top node of the expression
                    containing the make-instance function call
                 2) The logical name of the input source
  RETURNS      : The address of the modified expression, or NULL
                    if there is an error
  SIDE EFFECTS : The expression is enhanced to include all
                    aspects of the make-instance call
                    (slot-overrides etc.)
                 The "top" expression is deleted on errors.
  NOTES        : The name, class, values etc. must be constants.

                 This function parses a make-instance call into
                 an expression of the following form :

                  (make-instance <instance> of <class> <slot-override>*)
                  where <slot-override> ::= (<slot-name> <expression>+)

                  goes to -->

                  make-instance
                      |
                      V
                  <instance-name>-><class-name>-><slot-name>-><dummy-node>...
                                                                 |
                                                                 V
                                                          <value-expression>...

 ****************************************************************************/
globle EXPRESSION *ParseSimpleInstance(
  void *theEnv,
  EXPRESSION *top,
  const char *readSource)
  {
   EXPRESSION *theExp,*vals = NULL,*vbot,*tval;
   unsigned short type;

   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
   if ((GetType(DefclassData(theEnv)->ObjectParseToken) != INSTANCE_NAME) &&
       (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL))
     goto MakeInstanceError;

   if ((GetType(DefclassData(theEnv)->ObjectParseToken) == SYMBOL) &&
       (strcmp(CLASS_RLN,DOToString(DefclassData(theEnv)->ObjectParseToken)) == 0))
     {
      top->argList = GenConstant(theEnv,FCALL,
                                 (void *) FindFunction(theEnv,"gensym*"));
     }
   else
     {
      top->argList = GenConstant(theEnv,INSTANCE_NAME,
                                 (void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
      GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
      if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :
          (strcmp(CLASS_RLN,DOToString(DefclassData(theEnv)->ObjectParseToken)) != 0))
        goto MakeInstanceError;
     }

   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
     goto MakeInstanceError;
   top->argList->nextArg =
        GenConstant(theEnv,SYMBOL,(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
   theExp = top->argList->nextArg;
   if (ReplaceClassNameWithReference(theEnv,theExp) == FALSE)
     goto MakeInstanceError;
   GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
   while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
     {
      GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
      if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
        goto SlotOverrideError;
      theExp->nextArg = GenConstant(theEnv,SYMBOL,(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
      theExp->nextArg->nextArg = GenConstant(theEnv,SYMBOL,EnvTrueSymbol(theEnv));
      theExp = theExp->nextArg->nextArg;
      GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
      vbot = NULL;
      while (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
        {
         type = GetType(DefclassData(theEnv)->ObjectParseToken);
         if (type == LPAREN)
           {
            GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
            if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :
                (strcmp(ValueToString(DefclassData(theEnv)->ObjectParseToken.value),"create$") != 0))
              goto SlotOverrideError;
            GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
            if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
              goto SlotOverrideError;
            tval = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));
           }
         else
           {
            if ((type != SYMBOL) && (type != STRING) &&
                (type != FLOAT) && (type != INTEGER) && (type != INSTANCE_NAME))
              goto SlotOverrideError;
            tval = GenConstant(theEnv,type,(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
           }
         if (vals == NULL)
           vals = tval;
         else
           vbot->nextArg = tval;
         vbot = tval;
         GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
        }
      theExp->argList = vals;
      GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
      vals = NULL;
     }
   if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
     goto SlotOverrideError;
   return(top);

MakeInstanceError:
   SyntaxErrorMessage(theEnv,"make-instance");
   SetEvaluationError(theEnv,TRUE);
   ReturnExpression(theEnv,top);
   return(NULL);

SlotOverrideError:
   SyntaxErrorMessage(theEnv,"slot-override");
   SetEvaluationError(theEnv,TRUE);
   ReturnExpression(theEnv,top);
   ReturnExpression(theEnv,vals);
   return(NULL);
  }