statement.c

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

        if(string) {
          tags[1] = (long)string->string;
          tags[3] = string->len;
          CALL(Send(scr, tags));
        }
    }
    break;

  case FNC_SSCANF:
    {
      inttags[1] =
	  Sscanf(scr,
		 (uchar *)arg->argv[0],
		 (uchar *)arg->argv[1],
		 arg->argc,
		 arg->argv,
		 arg->format);
      CALL(Send(scr, inttags));
    }
    break;
  case FNC_EXISTS:
    inttags[1] =  Exists(scr,
			 (uchar *)arg->argv[0],
			 arg->argc>1?(long)arg->argv[1]:0);
    CALL( Send(scr, inttags) );
    break;

#if defined(AMIGA)
  case FNC_OPENLIB:
    CALL(OpenLib(scr,
                 (uchar *)arg->argv[0], /* name */
                 (long)arg->argv[1],   /* version */
                 (long *)&inttags[1],  /* funclib result */
                 0));                  /* normal 'soft' open */
    CALL(Send(scr, inttags));
    break;

  case FNC_CLOSELIB:
    CALL(CloseLib(scr,
                  (uchar *)arg->argv[0],  /* name */
                  0,                     /* 'soft' close */
                  (long *)&inttags[1])); /* funclib result */
    CALL(Send(scr, inttags));
    break;

  case FNC_DEBUG:
    if(arg->argc) {
      if(!(int)arg->argv[0]) {
        scr->flags&=~FPLDATA_DEBUG_MODE; /* switch off debug mode */
#ifdef DEBUGMAIL
        DebugMail(scr, MAIL_EXIT, 500, NULL);
#endif
      }
      else {
        scr->flags|=FPLDATA_DEBUG_MODE;  /* switch on debug mode */
#ifdef DEBUGMAIL
        DebugMail(scr, MAIL_START, 500, NULL);
#endif
      }
    }
    else {
       inttags[1]=scr->flags&FPLDATA_DEBUG_MODE?1:0; /* return status */
       CALL(Send(scr, inttags));
    }
    break;
#endif
  }
  return(FPL_OK);
}

#if defined(AMIGA)
ReturnCode REGARGS
OpenLib(struct Data *scr,
        uchar *lib,        /* funclib name */
        long version,     /* funclib version */
        long *retvalue,   /* funclib return code */
        uchar flags)
{
   struct MyLibrary *library;
   struct Library *DOSBase;
   BPTR seglist;
   uchar *command;
   uchar *cmd;
   struct FuncList *namelist=scr->funclibs;
   uchar *name;
   ReturnCode ret;
   struct fplStr *string;

   struct ExecBase *SysBase = *(struct ExecBase **)4;

   library = (struct MyLibrary *)getreg(REG_A6);
   DOSBase = library->ml_DosBase;

   GETMEM(command, FPLLIB_MAXSPACE);

   while(namelist) {
     if(!strcmp(namelist->name, lib)) {
       namelist->opens++;
       return FPL_OK; /* this funclib is already opened */
     }
     namelist = namelist->next;
   }

   cmd = command;
   strcpy(command, FPLLIB_SOURCE);
   strcpy(command+strlen(FPLLIB_SOURCE), lib);
   seglist = LoadSeg(command); /* load the command! */
   if(seglist) {
     strcpy(command, FPLLIB_OPENCMD);
     command += strlen(FPLLIB_OPENCMD);

     CALL(Ltostr(scr, &string, 10, (long)scr));
     strcpy(command, string->string);
     command[string->len]= ' '; /* pad with a single space */
     command+=string->len+1;
     FREE(string);

     CALL(Ltostr(scr, &string, 10, version));
     strcpy(command, string->string);
     command[string->len]= '\n';   /* add newline */
     command[string->len+1]= '\0'; /* zero terminate */
     FREE(string);

     if(SysBase->SoftVer<36) {
       /* V33 solution! */
       uchar *segment = BADDR(seglist);
       int (*func)();
#pragma msg 147 ignore
       func = segment + 4; /* generates warning */
#pragma msg 147 warning

       putreg(REG_A0, (long)cmd);
       putreg(REG_D0, strlen(cmd));
#pragma msg 154 ignore
       *retvalue = (func)(); /* generates warning */
#pragma msg 154 warning
     } else /* version 36 or up! */
       *retvalue = RunCommand(seglist, 4000, cmd, strlen(cmd));

     UnLoadSeg( seglist );
   } else {
     /* we failed loading the command! */
     *retvalue = FUNCLIB_LOAD;
   }

   FREE(cmd);

   if(!*retvalue) {
      GETMEMA(namelist, sizeof(struct FuncList));
      STRDUPA(name, lib);
      namelist->name = name;
      namelist->opens = 1;
      namelist->flags = flags;
      namelist->next = scr->funclibs;
      scr->funclibs = namelist;
   }
   return FPL_OK;
}

ReturnCode REGARGS
CloseLib(struct Data *scr,
         uchar *lib,        /* funclib name or NULL for all */
         long flags,       /* options */
         long *retvalue)   /* funclib return code */
{
   struct MyLibrary *library;
   struct Library *DOSBase;
   struct FuncList *namelist=scr->funclibs;
   struct FuncList *prevlist=NULL;
   struct FuncList *next;
   uchar *command;
   uchar *cmd;
   ReturnCode ret;
   struct fplStr *string;
   BPTR seglist;

   struct ExecBase *SysBase = *(struct ExecBase **)4;

   library = (struct MyLibrary *)getreg(REG_A6);
   DOSBase = library->ml_DosBase;

   GETMEM(command, FPLLIB_MAXSPACE);
   cmd = command;

   while(namelist) {
     if(namelist->flags&FPLLIB_KEEP && namelist->opens==1) {
       /* This funclib is prevented from being 'soft' closed! */
       namelist->opens++;
     }
     if((!lib || !strcmp(namelist->name, lib)) &&
        (!--namelist->opens || flags&FPLLIB_FORCE) ) {
       /* the funclib _is_ opened! */

       strcpy(command, FPLLIB_SOURCE);
       strcpy(command+strlen(FPLLIB_SOURCE), lib);
       seglist = LoadSeg(command); /* load the command! */
       if(seglist) {
         strcpy(command, FPLLIB_CLOSECMD);
         command += strlen(FPLLIB_CLOSECMD);
    
         CALL(Ltostr(scr, &string, 10, (long)scr));
         strcpy(command, string->string);
         command[string->len]= '\n';   /* add newline */
         command[string->len+1]= '\0'; /* zero terminate */
         FREE(string);
    
         if(SysBase->SoftVer<36) {
           /* V33 solution! */
           uchar *segment = BADDR(seglist);
           int (*func)();
#pragma msg 147 ignore
           func = segment + 4; /* generates warning */
#pragma msg 147 warning
    
           putreg(REG_A0, (long)cmd);
           putreg(REG_D0, strlen(cmd));
#pragma msg 154 ignore
           *retvalue = (func)(); /* generates warning */
#pragma msg 154 warning
         } else /* version 36 or up! */
           *retvalue = RunCommand(seglist, 4000, cmd, strlen(cmd));
    
         UnLoadSeg( seglist );
       } else {
         /* we failed loading the command! */
         *retvalue = FUNCLIB_LOAD;
       }
    
    
       if(!*retvalue) {
         next = namelist->next;
         if(prevlist) /* was there a previous funclib in the list? */
           prevlist->next=next; /* point it to the next in the list */
         else
           scr->funclibs = next; /* point the origin to the next */
         FREEA(namelist->name); /* free name space */
         FREEA(namelist);       /* free struct */
         namelist = next;
         continue;
       }
     }
     prevlist = namelist;
     namelist = namelist->next;
   }

   FREE(cmd);

   return FPL_OK;
}

#endif

/**********************************************************************
 *
 * fplLtostr()
 *
 * Frontend to the FPL Ltostr() function to be used by anyone! The returned
 * string *must* be freed using the fplFreeString() function!
 *
 ****/

PREFIX uchar *
fplLtostr(AREG(0) struct Data *scr,
          DREG(0) long base,
          DREG(1) long num)
{
  ReturnCode ret;
  struct fplStr *string;
  uchar *retstring=NULL;
#ifdef DEBUGMAIL
  DebugMail(scr, MAIL_FUNCTION, 500, (void *)"fplLtostr");
#endif
  ret = Ltostr(scr, &string, base, num);
  if(FPL_OK == ret) {
    SwapMem(scr, string, MALLOC_STATIC); /* turn allocation to static type */
    retstring = string->string; /* return string pointer */
  }
  return retstring;
}


static ReturnCode REGARGS
Ltostr(struct Data *scr,
       struct fplStr **string,
       long base,
       long num)
{
  /*
   * Convert the integer to string with `any base'-convertions.
   */
  extern const uchar upper_digits[];
  ReturnCode ret;
  static const uchar *digits = upper_digits;
  long is_neg=num<0;
  long len=0;
  uchar buffer[34+sizeof(struct fplStr)];
  uchar *bufpoint;  /* the accurate position in the buffer */

  if(base>(long)strlen(digits)) {
    CALL(Warn(scr, FPLERR_OUT_OF_REACH));
    num=strlen(digits); /* reset to maximum */
  }
  num=ABS(num);
	
  buffer[33+sizeof(struct fplStr)]=CHAR_ASCII_ZERO; /* zero byte termination */
  bufpoint=&buffer[33+sizeof(struct fplStr)]; /* start digit output position */
	
  if(num) {
    while(num>0) {
      *--bufpoint= digits[num % base];
      num /= base;
      len++;
    }
    if(is_neg) {
      *--bufpoint='-';
      len++;
    }
  } else {
    *--bufpoint=CHAR_ZERO;
    len++;
  }

  GETMEM(*string, len+sizeof(struct fplStr));
  strcpy((*string)->string, bufpoint);
  (*string)->len=len;
  (*string)->alloc=len;
  return(FPL_OK);
}

/**********************************************************************
 *
 * fplStrtol()
 *
 * Frontend to the FPL Strtol() function to be used by anyone!
 *
 ****/

long PREFIX
fplStrtol(AREG(0) uchar *string,
          DREG(0) long base,
          AREG(1) uchar **end)
{
  uchar *dummypoint;
  if(!end)
    end = &dummypoint;
  /*
   * THIS CAN'T CURRENTLY CALL DEBUGMAIL SINCE NO struct Data IS USED!!!
   */
  return Strtol(string, base, end);
}

/**********************************************************************
 *
 * Strtol()
 *
 * String to long integer. Code copied and changed from the GNU libc
 * source code package.
 *
 ****/

long REGARGS
Strtol(uchar *nptr,
       long base,
       uchar **end)
{
  uchar negative;
  unsigned long cutoff;
  unsigned long cutlim;
  long i;
  uchar *s;
  uchar c;
  uchar *save;
  long overflow;

  if (base < 0 || base == 1 || base > 36)
    base = 10;

  s = nptr;

  /* Skip white space.  */
  while(isspace(*s))
      s++;

  if (*s == CHAR_ASCII_ZERO)
    return (0);

  /* Check for a sign.  */
  else if (*s == CHAR_MINUS) {
    negative = 1;
    ++s;
  } else if (*s == CHAR_PLUS) {
    negative = 0;
    ++s;
  } else
    negative = 0;

  if ((base == 16 && s[0] == CHAR_ZERO && UPPER(s[1]) == CHAR_UPPER_X) ||
      (base == 2 && s[0] == CHAR_ZERO && UPPER(s[1]) == CHAR_UPPER_B) )
    s += 2;

  /* If BASE is zero, figure it out ourselves.  */
  if (base == 0)
    if (*s == '0') {
      switch(UPPER(s[1])) {
      case CHAR_UPPER_X:
	s += 2;
	base = 16;
	break;
      case CHAR_UPPER_B:
	s += 2;
	base = 2;
	break;
      default:
	base = 8;
	break;
      }
    } else
      base = 10;

  /* Save the pointer so we can check later if anything happened.  */
  save = s;

  cutoff = ULONG_MAX / (unsigned long int) base;
  cutlim = ULONG_MAX % (unsigned long int) base;

  overflow = 0;
  i = 0;
  for (c = *s; c; c = *++s) {
    if (isdigit(c))
      c -= '0';
    else if (isalpha(c))
      c = UPPER(c) - CHAR_UPPER_A + 10;
    else
      break;
    if (c >= base)
      break;
    /* Check for overflow.  */
    if ((unsigned long)i > cutoff ||
		((unsigned long)i == cutoff && c > cutlim))
      overflow = 1;
    else {
      i *= (unsigned long int) base;
      i += c;
    }
  }

  *end=s; /* this is the end position of the number */

  /* Check if anything actually happened.  */
  if (s == save)
    return (0);

  /* Check for a value that is within the range of
     `unsigned long int', but outside the range of `long int'.  */
  if (i > (negative ?
	   - (long ) LONG_MIN :
	   (long ) LONG_MAX))
    overflow = 1;

  if (overflow)
    return negative ? LONG_MIN : LONG_MAX;

  /* Return the result of the appropriate sign.  */
  return (negative ? - i : i);
}

/*****************************************************************************
 *
 * my_memicmp()
 *
 * This makes a case insensitive memcmp() with the very same parameters.
 *
 *********/

long REGARGS my_memicmp(uchar *s1, uchar *s2, long len)
{
  long pos=0;
  long result;
  while(pos < len) {
    result = tolower(s1[pos]) - tolower(s2[pos]);
    if(result)
      return result;
    pos++;
  }
  return 0;
}


ReturnCode REGARGS
  StringExpr(struct Expr *val,		/* original string -> new */
	     struct Data *scr)		/* standard */
{
  ReturnCode ret;
  struct fplStr *whole;

  CALL(Eat(scr)); /* scan white spaces */

  if(CHAR_PLUS == scr->text[0]) {
    
    GETMEM(whole, sizeof(struct fplStr));
    memset(whole, 0, sizeof(struct fplStr));
    
    /* put string in new string variable */
    CALL(StrAssign(val->val.str, scr, &whole, 1));
    
    do {
      scr->text++; /* skip the '+' */
      
      CALL(Expression(val, scr, CON_STRING, NULL));
      
      /* append string to that new variable */
      CALL(StrAssign(val->val.str, scr, &whole, 1));
      
      if(!(val->flags&FPL_NOFREE) && val->val.str)
	FREE(val->val.str);
    } while(CHAR_PLUS == scr->text[0]);
      
    val->val.str = whole; /* get the string info! */
    val->flags&=~FPL_NOFREE; /* free this, yes! */
  }
  return FPL_OK;
}