numexpr.c

类PASCAL语言的编译器,LINUX环境的,我没试过是否正确.

            pass->format[pass->argc]=CHAR_ASCII_ZERO;
            if(text && *text && !(*text&CASE_BIT)) {
              return FPLERR_MISSING_ARGUMENT;
              /*
               * This is a serious mis-use. The function is called with to few
               * parameters. At least one parameter missing is a required one.
               * I really can't figure out a way to survive such a shock!
               */
            }
          } else
            pass->format=NULL;
          if(*scr->text!=CHAR_CLOSE_PAREN) {
            CALL(Warn(scr, FPLERR_TOO_MANY_PARAMETERS)); /* too many parameters! */
            /* It's ok to continue without the parenthesis! */
          } else
            scr->text++;

          /*
           * Call the function!
           */

          CALL(CallFunction(scr, pass, ident));

#if 0
	  fprintf(stderr, "**Return\n");
#endif
          CALL(GetMessage(scr, FPLMSG_RETURN, &msg));
          if(FPL_OPTEXPRARG == hit) {
            if(msg) {
              if(msg->flags&FPLMSG_FLG_INT) {
                /* There is a return 'int' message! This may well be a
                   function returning int! */
                hit = FPL_INTARG;
              }
              else {
                /* found string, it returned a 'string' !!! */
                hit = FPL_STRARG;
              }
            }
            /* There is no return nor hint! */
          }

          switch(hit) {
            case FPL_STRARG:
#if 0
	      fprintf(stderr, "**String from %s\n", pass->name);
	      fprintf(stderr, "**Flags %d %d\n", msg->flags&FPLMSG_FLG_BITS,
		      FPLMSG_FLG_STRING);
#endif
              if(msg && ((msg->flags&FPLMSG_FLG_BITS) != FPLMSG_FLG_STRING))
                return FPLERR_UNEXPECTED_INT_STATEMENT;
              if(!msg || !msg->message[0])
                /* We got a zero length string or no string at all! */
                expr->val.str=NULL; /* no string! */
              else
                /* the copied string! */
                expr->val.str=(struct fplStr *)msg->message[0];
            
#ifdef DEBUGMAIL
              DebugMail(scr, MAIL_RETURN_STRING, (long)pass->name,
                        expr->val.str);
#endif
              expr->flags=FPL_STRING|FPL_ACTION;
              break;
            case FPL_INTARG:
            default:
#if 0
	      fprintf(stderr, "**Int from %s\n", pass->name);
#endif
              if(msg && ((msg->flags&FPLMSG_FLG_BITS) != FPLMSG_FLG_INT))
                return FPLERR_UNEXPECTED_STRING_STATEMENT;
              /* only if integer! or the function is non-existent */
              expr->val.val=(msg?(long)msg->message[0]:0);
#ifdef DEBUGMAIL
              DebugMail(scr, MAIL_RETURN_INTEGER, (long)pass->name,
                        (void *)expr->val.val);
#endif
              CALL(NewMember(scr, &expr));
              break;
          }
          if(msg)
            DeleteMessage(scr, msg);

          if(!ident) {
            /*
             * The function we invoked was not found regularly!
	     * Free the name we allocated temporarily.
	     */
            FREE(pass->name); /* the name was strdup()'ed! */
	  }

          while(pass->argc--) {
            if(pass->format[pass->argc]==FPL_STRARG && array[pass->argc]) {
              /* free the string if it's been marked to be freed!! */
              FREE((uchar *)pass->argv[pass->argc]-
                   offsetof(struct fplStr, string));
            }
          }
          if(pass->format) {
            FREE(pass->argv);
            FREE(pass->format);
            FREE(array);
          }
          FREE(pass);
        }
      } else {

          pos=0;
          switch(*scr->text) {
	  case CHAR_MULTIPLY:
	    /*
	     * This is the 'contents of' operator!
	     * The contents of the variable that follows this sign should
	     * get the following rvalue.
	     * Of course, we must first check that this really is a
	     * 'pointer' to a variable.
	     * If we declare this, make sure that it doesn't point to
	     * anything at all!
	     */

	    while(*++scr->text==CHAR_MULTIPLY); /* just in case! */

	    CALL(Getword(scr));
	    if(control&CON_DECLARE) {
	      return FPLERR_SYNTAX_ERROR; /* not yet supported */
	    }
	    else {
              CALL(GetIdentifier(scr, scr->buf, &ident));
	      if(!(ident->flags&FPL_REFERENCE))
	        return FPLERR_ILLEGAL_REFERENCE; /* referenced a non-reference! */
	      if(!ident->data.variable.ref)
		return FPLERR_ILLEGAL_REFERENCE; /* illegal reference! */

	      ident = ident->data.variable.ref; /* use the "actual" variable! */

	      /* we have an identifier and the level is OK! */
	      control |= CON_IDENT|CON_LEVELOK;
	      continue; /* now we have the pointer for the *real* variable! */
	    }
	    break;
          case CHAR_ZERO:
            /*
             * Numbers starting with a '0' can be hex/oct/bin.
             */
            if(control&CON_STRING) {
              /* NO integers allowed! */
              return FPLERR_UNEXPECTED_INT_STATEMENT;
            }
            switch(scr->text[1]) {
            case CHAR_X:
            case CHAR_UPPER_X:
              /* hexadecimal number parser */
              for(scr->text+=2; isxdigit(*scr->text); scr->text++)
                expr->val.val=expr->val.val*16+ (isdigit(*scr->text)?
                                         *scr->text-CHAR_ZERO:
                                         UPPER(*scr->text)-CHAR_UPPER_A+10);
              break;
            case CHAR_B:
            case CHAR_UPPER_B:
              /* binary number parser */
              for(scr->text+=2;*scr->text==CHAR_ZERO || *scr->text==CHAR_ONE;)
                expr->val.val=expr->val.val*2+ *scr->text++ - CHAR_ZERO;
              break;
            case CHAR_ZERO:
            case CHAR_ONE:
            case CHAR_TWO:
            case CHAR_THREE:
            case CHAR_FOUR:
            case CHAR_FIVE:
            case CHAR_SIX:
            case CHAR_SEVEN:
              /* octal number parser */
              for(scr->text++; isodigit(*scr->text);)
                expr->val.val=expr->val.val*8+ *scr->text++ - CHAR_ZERO;
              break;
            default:
              /* a single zero is simply 0 */
              scr->text++;
              expr->val.val=0;
              break;
            }
            CALL(NewMember(scr, &expr));
            break;
  	  /* end of case CHAR_ZERO: */

          case CHAR_ONE:
          case CHAR_TWO:
          case CHAR_THREE:
          case CHAR_FOUR:
          case CHAR_FIVE:
          case CHAR_SIX:
          case CHAR_SEVEN:
          case CHAR_EIGHT:
          case CHAR_NINE:
            /*
             * We hit a number between 1 and 9.
             */
            if(control&CON_STRING) {
              /* NO integers allowed! */
              CALL(Warn(scr, FPLERR_UNEXPECTED_INT_STATEMENT));
            }
            do
              expr->val.val= expr->val.val*10 + *scr->text++ - CHAR_ZERO;
            while(isdigit(*scr->text));
            CALL(NewMember(scr, &expr));
  	  break;

  	  case CHAR_QUOTATION_MARK:
            if(control&CON_NUM) {
              /* NO integers allowed! */
              CALL(Warn(scr, FPLERR_UNEXPECTED_STRING_STATEMENT));
            }
            CALL(Convert(val, scr));
            /* This returned a string! */
            expr->val.str=val->val.str;
            expr->flags=FPL_STRING;
	    CALL(StringExpr(expr, scr));
  	  break;

  	  case CHAR_APOSTROPHE:
            /*
             * Apostrophes surround character. Returns ASCII code.
             */
            if(control&CON_STRING) {
              /* NO integers allowed! */
              CALL(Warn(scr, FPLERR_UNEXPECTED_INT_STATEMENT));
            }
            CALL(ReturnChar((scr->text++, scr), &expr->val.val, FALSE));
            if(*scr->text!=CHAR_APOSTROPHE) {
              CALL(Warn(scr, FPLERR_MISSING_APOSTROPHE)); /* >warning< */
              /* just continue as nothing has ever happened! */
            } else
              scr->text++;
            CALL(NewMember(scr, &expr));
  	  break;

  	  case CHAR_OPEN_PAREN:
            CALL(Expression(val, (++scr->text, scr), CON_GROUNDLVL|CON_NUM, NULL));
            if(*scr->text!=CHAR_CLOSE_PAREN) {
              CALL(Warn(scr, FPLERR_MISSING_PARENTHESES)); /* >warning< */
              /* Go on anyway! */
            } else
              scr->text++;
            expr->val.val=val->val.val;
            CALL(NewMember(scr, &expr));
            break;

  	  case CHAR_NOT_OPERATOR:
            CALL(AddUnary(scr, expr, OP_NOT));
            ++scr->text;
            break;

  	  case CHAR_ONCE_COMPLEMENT:
            CALL(AddUnary(scr, expr, OP_COMPL));
            ++scr->text;
  	    break;

  	  case CHAR_PLUS:
            if(scr->text[1]==CHAR_PLUS) {
              expr->flags|=FPL_ACTION;
              scr->text+=2;
              CALL(AddUnary(scr, expr, OP_PREINC));
            } else {
              CALL(AddUnary(scr, expr, OP_PLUS));
              scr->text++;
            }
            break;

  	  case CHAR_MINUS:
            if(scr->text[1]==CHAR_MINUS) {
              expr->flags|=FPL_ACTION;
              scr->text+=2;
              CALL(AddUnary(scr, expr, OP_PREDEC));
            } else {
              CALL(AddUnary(scr, expr, OP_MINUS));
              scr->text++;
            }
            break;

          default:

            if((*scr->text==CHAR_SEMICOLON && control&CON_SEMICOLON) ||
               (*scr->text==CHAR_CLOSE_PAREN && control&CON_PAREN)
               && basexpr==expr && expr->operator==OP_NOTHING) {
              /* for(;;) support.
                 There must not have been a previous operand or operator */
              pos=expr->val.val=TRUE;
            } else {   /* no operand results in error! */
              CALL(Warn(scr, FPLERR_MISSING_OPERAND)); /* WARNING! */
              expr->operator=OP_NOTHING; /* reset */
            }
  	    break;
	  }
		  if(pos)
          break;
      }

    } else {                                         /* waiting for operator */
      uchar *point=scr->text;

      switch(*scr->text) {
      case CHAR_ASSIGN:
        if(scr->text[1]==CHAR_ASSIGN) {
          expr->operator=OP_EQUAL;
          scr->text+=2;
        }
        break;
      case CHAR_AND:
	if(scr->text[1]==CHAR_AND) {
          /*
           * This is a logical AND (&&)
           */
          scr->text+=2;

          /*
           * Get result from everything to the left of this!
           */
          CALL(Calc(scr, val, basexpr));

          /*
           * Clean the expression so far.
           */
          Clean(scr, basexpr);    /* erase the list */

          /*
           * Start a new list with this result
           */
          GETMEM(expr, sizeof(struct Expr));
          memset(expr, 0, sizeof(struct Expr));
          basexpr=expr;
          expr->val.val = val->val.val;

          if(!expr->val.val) {
            /*
             * In this case, its like in the 'a && b' expression and 'a'
             * equals 0. Then we should skip the 'b' expression.
             */
            CALL(ScanForNext(scr, OP_LOGAND));
            expr->flags = FPL_OPERAND;
          }
          continue;

        } else {
          expr->operator=OP_BINAND;
          scr->text++;
        }
        break;
      case CHAR_OR:
        if(scr->text[1]==CHAR_OR) {
          /*
           * This is a logical OR operator (||)
           */
          scr->text+=2;

          /*
           * Get result from everything to the left of this!
           */
          CALL(Calc(scr, val, basexpr));

          /*
           * Clean the expression so far.
           */
          Clean(scr, basexpr);    /* erase the list */

          /*
           * Start a new list with this result
           */
          GETMEM(expr, sizeof(struct Expr));
          memset(expr, 0, sizeof(struct Expr));
          basexpr=expr;
          expr->val.val = val->val.val;

          if(expr->val.val) {
            /*
             * In this case, its like in the 'a || b' expression and 'a'
             * equals 1. Then we should skip the 'b' expression.