statement.c

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

    } else {
      /*
       * We must ask user for information!
       */
      
      GETMEM(arg, sizeof(struct fplArgument));
      arg->ID=FPL_FILE_REQUEST;
      arg->key=(void *)scr;
      arg->argv=(void **)&prog->name;
      arg->argc=1;
      ret=InterfaceCall(scr, arg, scr->function);
      FREE(arg);
      if(ret)
        return ret;
      
      GetMessage(scr, FPLMSG_PROGRAM, &msg);
      if(!msg) {
	GetMessage(scr, FPLMSG_RETURN, &msg);
	if(!msg || ((msg->flags&FPLMSG_FLG_BITS) != FPLMSG_FLG_STRING))
	  /*
	   * No kind of proper answer could be found!
	   * Dead end failure!
	   */	  
	  return FPLERR_INTERNAL_ERROR;
	
	string=(struct fplStr *)msg->message[0];
	ret = ReadFile(scr, string->string, prog);
	FREE(msg->message[0]); /* we don't need this anymore! */
	if(ret)
	  return ret;
      } else {
	/*
	 * User supplied us with a memory pointer to the program again!
	 */
	prog->program= (uchar *)msg->message[0];
	prog->flags|=PR_USERSUPPLIED;
      }
      DeleteMessage(scr, msg);
    }
  } /* else
       we already have it loaded! */
  prog->running++;
  return(FPL_OK);
}


/**********************************************************************
 *
 * LeaveProgram();
 *
 * If we leave one program, call this. If any flush is to be done, this
 * will perform that!
 *
 ******/

ReturnCode REGARGS
LeaveProgram(struct Data *scr,
             struct Program *prog)
{
  struct fplArgument *arg;
  ReturnCode ret;
  struct fplMsg *msg;
  prog->running--;
  if(prog->program && !prog->running && prog->flags&PR_FLUSH_NOT_IN_USE) {
    /*
     * The program is there and no one is using it!
     * flush it if we want to!
     */

    if(prog->flags&PR_USERSUPPLIED) {
      /*
       * This program is supplied by the external program. We cannot
       * free the memory, only tell our father that freeing is OK...
       */
      GETMEM(arg, sizeof(struct fplArgument));
      arg->ID=FPL_FLUSH_FILE;
      arg->key=(void *)scr;
      arg->argv=(void **)&prog->name;
      arg->argc=1;
      CALL(InterfaceCall(scr, arg, scr->function));
      FREE(arg);
      GetMessage(scr, FPLMSG_CONFIRM, &msg);
      /*
       * We require a {FPLSEND_CONFIRM, TRUE} message from the user before we
       * flush the user supplied function! Simply ignore implementing any
       * answer to this message if we never want to flush user supplied
       * functions.
       */
      if(msg && msg->message[0])
	/* If we got a "OK" message! */
	prog->program=NULL;
      if(msg)
	DeleteMessage(scr, msg);
    } else {
      /*
       * The memory occupied by this program is our business.
       * Swap the memory first to be sure we know the kind of it!
       */
      SwapMem(scr, prog->program, MALLOC_DYNAMIC);
      FREE(prog->program);
      prog->program=NULL; /* to visualize the clearing of this program! */
    }
  }
  return(FPL_OK);
}

static long INLINE
Exists(struct Data *scr,
       uchar *name,
       long check)
{
  ReturnCode ret;
  struct Identifier *ident;
  GetIdentifier(scr, name, &ident);
  if(check && ident) {
    switch(tolower(check)) {
    case EXISTS_FUNCTION:
      ret = ident->flags&FPL_FUNCTION;
      break;
    case EXISTS_INTEGER:
      ret = ident->flags&FPL_INT_VARIABLE;
      break;
    case EXISTS_STRING:
      ret = ident->flags&FPL_STRING_VARIABLE;
      break;
    case EXISTS_VARIABLE:
      ret = ident->flags&FPL_VARIABLE;
      break;
    }
  }
  else
    ret = ident?TRUE:FALSE;
  return ret;
}

#if 0
/*
 * These are some fixes to make this work on compiled programs too.
 * It currently does not.
 */

ReturnCode static INLINE Interpret(struct Data *scr,
                                   struct fplArgument *arg,
                                   struct Expr *val)
{
  unsigned long inttags[]={FPLSEND_INT, 0, FPLSEND_DONE};
  ReturnCode ret;
  struct Program *prog;
  struct Program *oldprog=scr->prog;
  long prg;
  long virprg;
  char *text;
  char *virfile;
  
  GETMEM(prog, sizeof(struct Program));
  memcpy(prog, scr->prog, sizeof(struct Program));

  prog->lines=1;
  prog->flags &= ~(PR_COMPILED|PR_SELECTED_FPC);
  STRDUP(prog->name, "<interpret>");
  
  prog->next = scr->programs;
  scr->prog = scr->programs = prog;

  prg=scr->prg;
  text=scr->text;    
  virprg=scr->virprg;
  virfile=scr->virfile;
  
  scr->virprg=1;
  scr->virfile=NULL;
  scr->prg=1;
  scr->text=(uchar *)arg->argv[0];

  scr->interpret=NULL; /* nothing recursive here, no no! */

  CALL(LeaveProgram(scr, oldprog));
  CALL(GetProgram(scr, prog));
  
  GETMEM(val, sizeof(struct Expr));
  ret = Script(scr, val, SCR_NORMAL, NULL);
  if( ret ) {
    if(scr->prog != prog) {
      LeaveProgram(scr, scr->prog); /* leave the failed program! */
      GetProgram(scr, prog); /* fetch the previous program again! */
    }
    return ret;
  }
  inttags[1]=val->val.val;
  FREE(val);

  CALL(LeaveProgram(scr, scr->prog));
  scr->prog=oldprog;
  CALL(GetProgram(scr, scr->prog));
  prog->program = NULL; /* we don't actually have a program ;) */
  DelProgram(scr, prog); /* remove it again please */

  scr->prg=prg;
  scr->text=text;

  scr->virprg=virprg;
  scr->virfile=virfile;
  CALL(Send(arg->key, inttags));
}
#endif

/**********************************************************************
 *
 * int functions(struct fplArgument *);
 *
 * This function handles the internal functions. *EXACTLY* the same way
 * external processes handles their functions!!! :-)
 *
 *****/

ReturnCode REGARGS
functions(struct fplArgument *arg)
{
  struct Expr *val;
  unsigned long inttags[]={FPLSEND_INT, 0, FPLSEND_DONE};
  unsigned long strtags[]={FPLSEND_STRING, 0, FPLSEND_STRLEN, 0, FPLSEND_DONE};
  long base;
  ReturnCode ret;
  struct Data *scr=(struct Data *)arg->key;
  struct fplStr *string;
  long prg;
  long line;
  long virprg;
  uchar *virfile;
  uchar *text;

  long len;		/* length of the string */
  register long col;	/* the column parameter */
  switch(arg->ID) {
    
  case FNC_ABS:
    inttags[1]= ABS((long)arg->argv[0]);
    CALL(Send(arg->key, inttags));
    break;

  case FNC_ITOC:
    prg=(long)arg->argv[0]&255;
    text=(uchar *)&line; /* we just need 2 bytes to play with in peace! */
    text[1]='\0';
    text[0]=(uchar)prg;
    strtags[1]=(long)text;
    strtags[3]=1;
    CALL(Send(scr, strtags));
    break;
    
  case FNC_JOINSTR:
    string=NULL;
    for(prg=0; prg<arg->argc; prg++) {
      CALL(StrAssign((struct fplStr *) ((uchar *)arg->argv[prg]-
					offsetof(struct fplStr, string)),
		     scr, &string, TRUE));
    }
    if(string) {
      strtags[1]=(unsigned long)string->string;
      strtags[3]=string->len;
      CALL(Send(scr, strtags));
      FREE(string);
    }
    break;

  case FNC_ITOA:
  case FNC_LTOSTR:
    base=(arg->argc<2?10:(long)arg->argv[1]);
    CALL(Ltostr(scr, &string, base, (long)arg->argv[0]));
    strtags[1]=(unsigned long)string->string;
    strtags[3]=string->len;
    CALL(Send(scr, strtags));
    FREE(string);
    break;
    
  case FNC_ATOI:
  case FNC_STRTOL:
    base=(arg->argc<2?10:(long)arg->argv[1]);
    inttags[1]= Strtol((uchar *)arg->argv[0], base, &text);
    CALL(Send(scr, inttags));
    break;
    
  case FNC_EVAL:
    prg=scr->prg;
    text=scr->text;
    line=scr->prog->lines;
    virprg=scr->virprg;
    virfile=scr->virfile;

    scr->virprg=1;
    scr->virfile=NULL;
    scr->text=(uchar *)arg->argv[0];
    scr->prg=scr->prog->lines=1;
 
    GETMEM(val, sizeof(struct Expr));
    CALL(Expression(val, scr, CON_GROUNDLVL|CON_END|CON_NUM, NULL));
    inttags[1]=val->val.val;
    FREE(val);

    scr->prg=prg;
    scr->text=text;
    scr->prog->lines=line;
    scr->virprg=virprg;
    scr->virfile=virfile;
    
    CALL(Send(scr, inttags));
    break;
    
  case FNC_INTERPRET:
    prg=scr->prg;
    text=scr->text;
    line=scr->prog->lines;
/*    file=scr->prog->name; */
    virprg=scr->virprg;
    virfile=scr->virfile;
    scr->virprg=1;
    scr->virfile=NULL;
    scr->interpret=NULL; /* nothing recursive here, no no! */
    scr->prg=1;
    scr->text=(uchar *)arg->argv[0];
    scr->prog->lines=1;
/*    scr->prog->name=NULL; */ /* we have no file name! */

    GETMEM(val, sizeof(struct Expr));
    ret=Script(scr, val, SCR_NORMAL, NULL);
    inttags[1]=val->val.val;
    FREE(val);

    if(ret) {
      /*
       * Check if the error occurred somewhere in the real program
       * or if it was within the argument. If within argument, we
       * set back the previous program pointer, otherwise not.
       */
      for(base=0;base<line;base++)
	if(scr->text>(&scr->prog->program)[base] &&
	   scr->text<((&scr->prog->program)[base]+
		      strlen((&scr->prog->program)[base])))
	  break;
      if(base==line) {
	scr->prg=prg;
	scr->text=text;
	scr->prog->lines=line;
/*	scr->prog->name=file; */
      }
      return(ret);
    }
    scr->prg=prg;
    scr->text=text;
    scr->prog->lines=line;
/*    scr->prog->name=file; */
    scr->virprg=virprg;
    scr->virfile=virfile;
    CALL(Send(arg->key, inttags));
    break;
#if 0
  case FNC_INTERPRET:
    CALL( Interpret(scr, arg, val) );
    break;
#endif
  case FNC_RENAME:
    {
      struct Identifier *ident;
      GetIdentifier(scr, (uchar *)arg->argv[0], &ident);
      if(!ident || ident->flags&FPL_KEYWORD) {
        /* not found or found keyword, fail! */
        inttags[1] = FPLERR_IDENTIFIER_NOT_FOUND;
      }
      else {
        if(((char *)arg->argv[1])[0])
          inttags[1] = RenameIdentifier(scr, ident, arg->argv[1]);
        else
          inttags[1] = DelIdentifier(scr, NULL, ident);
      }
      CALL(Send(arg->key, inttags));
    }    
  break;

  case FNC_STRCMP:
  case FNC_STRICMP:
    /*
     * strcmp() with strings that can include a zero byte must use
     * memcmp(), but that also takes a third length argument which
     * must never be larger than the smallest of the two compared
     * strings!
     */
    line = MIN(FPL_STRING_LENGTH(arg, 0), FPL_STRING_LENGTH(arg, 1)); /* len */

    if(FNC_STRCMP == arg->ID)
      base = memcmp(arg->argv[0], arg->argv[1], line);
    else
      base = my_memicmp(arg->argv[0], arg->argv[1], line);

    if(!base && FPL_STRING_LENGTH(arg, 0) != FPL_STRING_LENGTH(arg, 1)) {
      /* similar strings after 'line' characters */

      /*
       * The strings are of different length.
       */

      base = ((uchar *)arg->argv[0])[line] -
	(FPL_STRING_LENGTH(arg, 1)>line?
	 ((uchar *)arg->argv[1])[line] : 0 );
      
      if(!base) {
	/* only possible since FPL strings can hold zeroes! */
	base = 256; /* not possible in regular C */
      }
    }
    inttags[1]=base;
    CALL(Send(scr, inttags));
    break;
    
  case FNC_SUBSTR:
    len=FPL_STRING_LENGTH(arg, 0);
    col=(long)arg->argv[1];
    if(col>len || col<0) {
      ;				/* we can't get any string! */
    } else {
      len-=col;			/* Maximum length we can get */
      strtags[3]=((long)arg->argv[2]>len?len:(long)arg->argv[2]); /* strlen */
      strtags[1]=(long) arg->argv[0]+col; /* return string from here */
      CALL(Send(scr, strtags));
    }
    break;
    
  case FNC_STRLEN:
    inttags[1]=FPL_STRING_LENGTH(arg, 0);
    CALL(Send(scr, inttags));
    break;

  case FNC_STRNCMP:
  case FNC_STRNICMP:
    /*
     * strncmp() with strings that can include a zero byte must use
     * memcmp(), that also takes a third length argument which
     * must never be larger than the smallest of the two compared
     * strings or the number specified!
     */
    if(FNC_STRNCMP == arg->ID) {
      inttags[1]=
	memcmp(arg->argv[0], arg->argv[1],
	       MIN3((long)arg->argv[2],
		    FPL_STRING_LENGTH(arg, 0), FPL_STRING_LENGTH(arg, 1)));
    }
    else {
      inttags[1]=
	my_memicmp(arg->argv[0], arg->argv[1],
		MIN3((long)arg->argv[2],
		     FPL_STRING_LENGTH(arg, 0), FPL_STRING_LENGTH(arg, 1)));
    }
    CALL(Send(scr, inttags));
    break;
    
  case FNC_STRSTR:
  case FNC_STRISTR:
    /*
     * strstr() should compare two memory regions, like a memmem()!
     * Code an own!
     */
    base = FPL_STRLEN(arg->argv[0]);
    line = FPL_STRLEN(arg->argv[1]);
    text = (uchar *)arg->argv[0];

    /*
     * Addition from FPL version 9:
     * starting search column in third parameter!
     */
    if(arg->argc>2) {
      if((int)arg->argv[2] < base) {
	text+=(int)arg->argv[2];
	base-=(int)arg->argv[2];
      }
      else {
	/* tried to start searching outside the string! */

	line = 1; /* to make a not-found return code */
	base = 0;
      }
    }
    
    if(line && base) {
      if(FNC_STRSTR == arg->ID) {
	/* Case sensitive */
	while(base-->=line) {
	  if(!memcmp(text, (uchar *)arg->argv[1], line)) {
	    line=0;
	    break;
	  }
	  text++;
	}
      }
      else {
	/* Case insensitive */
	while(base-->=line) {
	  if(!my_memicmp(text, (uchar *)arg->argv[1], line)) {
	    line=0;
	    break;
	  }
	  text++;
	}
      }
    }
    inttags[1]=line?-1:text-(uchar *)arg->argv[0];

    /* OLD ONE:
    text=(uchar *)strstr((uchar *)arg->argv[0], (uchar *)arg->argv[1]);
    inttags[1]=text?text-(uchar *)arg->argv[0]:-1;
    */
    CALL(Send(scr, inttags));
    break;

  case FNC_SPRINTF:
    {
        static unsigned long tags[]={
            FPLSEND_STRING, 0,
            FPLSEND_STRLEN, 0,
            FPLSEND_DONTCOPY_STRING, TRUE,
            FPLSEND_DONE
        };
        string = NULL;
        CALL(Sprintf(scr, &string, arg->argv[0], arg->argv, arg->format,
		     arg->argc));