C:/Users/Dennis/src/lang/Life_start/Life/life-1.02/source/token.c

Go to the documentation of this file.

/* Copyright 1991 Digital Equipment Corporation.
** All Rights Reserved.
*****************************************************************/
/*      $Id: token.c,v 1.4 1995/07/27 19:22:17 duchier Exp $     */

#ifndef lint
static char vcid[] = "$Id: token.c,v 1.4 1995/07/27 19:22:17 duchier Exp $";
#endif /* lint */
#ifndef OS2_PORT
#include <pwd.h>

#else
#include <stdlib.h>
#endif
#include "extern.h"
#include "trees.h"
#include "types.h"
#include "token.h"
#include "memory.h"
#include "error.h"
#include "parser.h" /* For heap_copy_psi_term */
#include "modules.h"


long var_occurred;
ptr_node symbol_table;
ptr_psi_term error_psi_term;
long psi_term_line_number;
long trace_input=FALSE;

FILE *output_stream;
char *prompt;

long stdin_terminal;

/* For parsing from a string */
long stringparse;
char *stringinput;

/****************************************************************************/

/* Abstract Data Type for the Input File State */

/* FILE *last_eof_read; */

/* Global input file state information */
/* Note: all characters should be stored in longs.  This ensures
   that noncharacters (i.e., EOF) can also be stored. */
FILE *input_stream;
string input_file_name;
long line_count;
long start_of_line;
long saved_char; /*  RM: Jul  7 1993  changed to 'int' */
long old_saved_char;
ptr_psi_term saved_psi_term;
ptr_psi_term old_saved_psi_term;
long eof_flag;

/* Psi-term containing global input file state */
ptr_psi_term input_state;

/* Psi-term containing stdin file state */
ptr_psi_term stdin_state;

/***********************************************/
/* Utilities */
/* All psi-terms created here are on the HEAP. */
/* Many utilities exist in two versions that allocate on the heap */
/* or the stack. */
/* All these routines are NON-backtrackable. */



void TOKEN_ERROR(p)    /*  RM: Feb  1 1993  */

     ptr_psi_term p;
{
  if(p->type==error_psi_term->type) {
    Syntaxerrorline("Module violation (%E).\n");
  }
}



/* Clear EOF if necessary for stdin */
void stdin_cleareof()
{
  if (eof_flag && stdin_terminal) {
    clearerr(stdin);
    start_of_line=TRUE;
    saved_psi_term=NULL;
    old_saved_psi_term=NULL;
    saved_char=0;
    old_saved_char=0;
    eof_flag=FALSE;
  }
}


/* Add an attribute whose value is an integer to a psi-term */
/* that does not yet contains this attribute. */
void heap_add_int_attr(t, attrname, value)
ptr_psi_term t;
char *attrname;
long value;
{
  ptr_psi_term t1;

  t1=heap_psi_term(4);
  t1->type=integer;
  t1->value=heap_alloc(sizeof(REAL));
  *(REAL *)t1->value = (REAL) value;

  heap_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), t1);
}

void stack_add_int_attr(t, attrname, value)
ptr_psi_term t;
char *attrname;
long value;
{
  ptr_psi_term t1;

  t1=stack_psi_term(4);
  t1->type=integer;
  t1->value=heap_alloc(sizeof(REAL)); /* 12.5 */
  *(REAL *)t1->value = (REAL) value;

  stack_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), t1);
}


/* Modify an attribute whose value is an integer to a psi-term */
/* that already contains this attribute with another integer value. */
void heap_mod_int_attr(t, attrname, value)
ptr_psi_term t;
char *attrname;
long value;
{
  ptr_node n;
  ptr_psi_term t1;

  n=find(featcmp,attrname,t->attr_list);
  t1=(ptr_psi_term)n->data;
  *(REAL *)t1->value = (REAL) value;
}

/*
void stack_mod_int_attr(t, attrname, value)
ptr_psi_term t;
char *attrname;
long value;
{
  ptr_node n;
  ptr_psi_term t1;

  n=find(featcmp,attrname,t->attr_list);
  t1=(ptr_psi_term)n->data;
  *(REAL *)t1->value = (REAL) value;
}
*/


/* Add an attribute whose value is a string to a psi-term */
/* that does not yet contains this attribute. */
void heap_add_str_attr(t, attrname, str)
ptr_psi_term t;
char *attrname;
char *str;
{
  ptr_psi_term t1;

  t1=heap_psi_term(4);
  t1->type=quoted_string;
  t1->value=(GENERIC)heap_copy_string(str);

  heap_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), t1);
}

void stack_add_str_attr(t, attrname, str)
ptr_psi_term t;
char *attrname;
char *str;
{
  ptr_psi_term t1;

  t1=stack_psi_term(4);
  t1->type=quoted_string;
  t1->value=(GENERIC)stack_copy_string(str);

  stack_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), t1);
}


/* Modify an attribute whose value is a string to a psi-term */
/* that already contains this attribute with another integer value. */
void heap_mod_str_attr(t, attrname, str)
ptr_psi_term t;
char *attrname;
char *str;
{
  ptr_node n;
  ptr_psi_term t1;

  n=find(featcmp,attrname,t->attr_list);
  t1=(ptr_psi_term)n->data;
  t1->value=(GENERIC)heap_copy_string(str);
}

/*
ATTENTION - This should be made backtrackable if used
void stack_mod_str_attr(t, attrname, str)
ptr_psi_term t;
char *attrname;
char *str;
{
  ptr_node n;
  ptr_psi_term t1;

  n=find(featcmp,attrname,t->attr_list);
  t1=(ptr_psi_term)n->data;
  t1->value=(GENERIC)stack_copy_string(str);
}
*/


/* Attach a psi-term to another as an attribute. */
void heap_add_psi_attr(t, attrname, g)
ptr_psi_term t;
char *attrname;
ptr_psi_term g;
{
  heap_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), g);
}

void stack_add_psi_attr(t, attrname, g)
ptr_psi_term t;
char *attrname;
ptr_psi_term g;
{
  stack_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), g);
}

void bk_stack_add_psi_attr(t, attrname, g)
ptr_psi_term t;
char *attrname;
ptr_psi_term g;
{
  bk_stack_insert(featcmp,heap_copy_string(attrname),&(t->attr_list), g);
}


/* Get the GENERIC value of a psi-term's attribute */
GENERIC get_attr(t, attrname)
ptr_psi_term t;
char *attrname;
{
  ptr_node n=find(featcmp,attrname,t->attr_list);
  return (GENERIC) n->data;
}

/* Get the psi-term's STREAM attribute */
FILE *get_stream(t)
ptr_psi_term t;
{
  return (FILE *) ((ptr_psi_term)get_attr(t,STREAM))->value;
}

/***********************************************/
/* Main routines for saving & restoring state */


/* Save global state into an existing file state psi-term t */
void save_state(t)
ptr_psi_term t;
{
  ptr_node n;
  ptr_psi_term t1;

  n=find(featcmp,STREAM,t->attr_list);
  t1=(ptr_psi_term)n->data;
  t1->value=(GENERIC)input_stream;

  /*  RM: Jan 27 1993
  heap_mod_str_attr(t,CURRENT_MODULE,current_module->module_name);
  */
  
  heap_mod_str_attr(t,INPUT_FILE_NAME,input_file_name);
  heap_mod_int_attr(t,LINE_COUNT,line_count);
  heap_mod_int_attr(t,SAVED_CHAR,saved_char);
  heap_mod_int_attr(t,OLD_SAVED_CHAR,old_saved_char);

  t1=saved_psi_term?saved_psi_term:null_psi_term;
  heap_add_psi_attr(t,SAVED_PSI_TERM,t1);

  t1=old_saved_psi_term?old_saved_psi_term:null_psi_term;
  heap_add_psi_attr(t,OLD_SAVED_PSI_TERM,t1);

  t1=heap_psi_term(4);
  t1->type=(eof_flag?true:false);
  heap_add_psi_attr(t,EOF_FLAG,t1);

  t1=heap_psi_term(4);
  t1->type=(start_of_line?true:false);
  heap_add_psi_attr(t,START_OF_LINE,t1);
}



/* Restore global state from an existing file state psi-term t */
void restore_state(t)
ptr_psi_term t;
{
  long i;
  char *str;

  
  input_stream = (FILE *) ((ptr_psi_term)get_attr(t,STREAM))->value;
  str = (char*) ((ptr_psi_term)get_attr(t,INPUT_FILE_NAME))->value;
  strcpy(input_file_name,str);
  /* for (i=0;i++;i<=strlen(str)) input_file_name[i]=str[i]; */
  line_count = *(REAL *) ((ptr_psi_term)get_attr(t,LINE_COUNT))->value;
  saved_char = *(REAL *) ((ptr_psi_term)get_attr(t,SAVED_CHAR))->value;
  old_saved_char= *(REAL *)((ptr_psi_term)get_attr(t,OLD_SAVED_CHAR))->value;

  saved_psi_term=(ptr_psi_term)get_attr(t,SAVED_PSI_TERM);
  if (saved_psi_term==null_psi_term) saved_psi_term=NULL;

  old_saved_psi_term=(ptr_psi_term)get_attr(t,OLD_SAVED_PSI_TERM);
  if (old_saved_psi_term==null_psi_term) old_saved_psi_term=NULL;

  eof_flag = ((ptr_psi_term)get_attr(t,EOF_FLAG))->type==true;
  start_of_line = ((ptr_psi_term)get_attr(t,START_OF_LINE))->type==true;

  
  /*  RM: Jan 27 1993
      set_current_module(
      find_module(((ptr_psi_term)get_attr(input_state,
      CURRENT_MODULE))->value));
      */
}


/* Create a new file state psi-term that reflects the current global state */
void new_state(t)
ptr_psi_term *t;
{
  ptr_psi_term t1;

  *t=heap_psi_term(4);
  (*t)->type=inputfilesym;

  t1=heap_psi_term(4);
  t1->type=stream;
  t1->value=(GENERIC)input_stream;
  heap_add_psi_attr(*t,STREAM,t1);

  /*  RM: Jan 27 1993  */
  heap_add_str_attr(*t,CURRENT_MODULE,current_module->module_name);
  
  /*
    printf("Creating new state for file '%s', module '%s'\n",
    input_file_name,
    current_module->module_name);
    */
  
  heap_add_str_attr(*t,INPUT_FILE_NAME,input_file_name);
  heap_add_int_attr(*t,LINE_COUNT,line_count);
  heap_add_int_attr(*t,SAVED_CHAR,saved_char);
  heap_add_int_attr(*t,OLD_SAVED_CHAR,old_saved_char);

  t1=saved_psi_term?saved_psi_term:null_psi_term;
  heap_add_psi_attr(*t,SAVED_PSI_TERM,t1);

  t1=old_saved_psi_term?old_saved_psi_term:null_psi_term;
  heap_add_psi_attr(*t,OLD_SAVED_PSI_TERM,t1);

  t1=heap_psi_term(4);
  t1->type=(eof_flag?true:false);
  heap_add_psi_attr(*t,EOF_FLAG,t1);

  t1=heap_psi_term(4);
  t1->type=(start_of_line?true:false);
  heap_add_psi_attr(*t,START_OF_LINE,t1);
}



/****************************************************************************/


/* Parser/tokenizer state handling */

void save_parse_state(pb)
ptr_parse_block pb;
{
   if (pb) {
     pb->lc   = line_count;
     pb->sol  = start_of_line;
     pb->sc   = saved_char;
     pb->osc  = old_saved_char;
     pb->spt  = saved_psi_term;
     pb->ospt = old_saved_psi_term;
     pb->ef   = eof_flag;
   }
}


void restore_parse_state(pb)
ptr_parse_block pb;
{
   if (pb) {
     line_count         = pb->lc;
     start_of_line      = pb->sol;
     saved_char         = pb->sc;
     old_saved_char     = pb->osc;
     saved_psi_term     = pb->spt;
     old_saved_psi_term = pb->ospt;
     eof_flag           = pb->ef;
   }
}


/* Initialize the parser/tokenizer state variables. */
void init_parse_state()
{
  line_count=0;
  start_of_line=TRUE;
  saved_char=0;
  old_saved_char=0;
  saved_psi_term=NULL;
  old_saved_psi_term=NULL;
  eof_flag=FALSE;
  stringparse=FALSE;
}


/****************************************************************************/


static long inchange, outchange;
static FILE *out;
ptr_psi_term old_state=NULL; /*  RM: Feb 17 1993  */



/******** BEGIN_TERMINAL_IO()
   These two routines must bracket any I/O directed to the terminal.
   This is to avoid mix-ups between terminal and file I/O since the
   program's input and output streams may be different from stdin stdout.
   See the routine what_next_aim(), which uses them to isolate the
   user interface I/O from the program's own I/O.
*/
void begin_terminal_io()
{
  inchange = (input_stream!=stdin);
  outchange = (output_stream!=stdout);

  if (outchange) {
    out=output_stream;
    output_stream=stdout;
  }

  if (inchange) {
    old_state=input_state;
    open_input_file("stdin");
  }
}



/******** END_TERMINAL_IO()
  End of terminal I/O bracketing.
*/
void end_terminal_io()
{
  if (inchange) {
    input_state=old_state;
    restore_state(old_state);
    old_state=NULL; /*  RM: Feb 17 1993  */
  }
  if (outchange)
    output_stream=out;
}



/******** EXPAND_FILE_NAME(str)
  Return the expansion of file name STR.
  For the time being all this does is replace '~' by the HOME directory
  if no user is given, or tries to find the user.
*/
#ifndef OS2_PORT
char *expand_file_name(s)
char *s;
{
  char *r;
  char *home, *getenv();
  struct passwd *pw;
  char *user="eight character name";
  char userbuf[STRLEN];
  /* char *user=userbuf; 
   */
  char *t1,*t2;

  r=s;
  if (s[0]=='~') {
    t1=s+1;
    t2=user;
    while (*t1!=0 && *t1!='/') {
      *t2= *t1;
      *t2++;
      *t1++;
    }
    *t2=0;
    if ((int)strlen(user)>0) {
      pw = getpwnam(user);
      if (pw) {
        user=pw->pw_dir;
        r=(char *)malloc(strlen(user)+strlen(t1)+1);
        sprintf(r,"%s%s",user,t1);
      }
      else
        /* if (warning()) printf("couldn't find user '%s'.\n",user) */;
    }
    else {
      home=getenv("HOME");
      if (home) {
        r=(char *)malloc(strlen(home)+strlen(s)+1);
        sprintf(r,"%s%s",home,s+1);
      }
      else
        /* if (warning()) printf("no HOME directory.\n") */;
    }
  }

  /* printf("*** Using file name: '%s'\n",r); */
  
  return r;
}
#else
char *expand_file_name(s)
char *s;
{
  char *r;
  char *home;
  char *pw;
  char userbuf[STRLEN];
  char *user;
  char *t1,*t2;
   r = s;
  if (s[0]=='~') {
    t1=s+1;
    if (user=getenv("LIFEHOME") ) {
        r=(char *)malloc(strlen(user)+strlen(t1)+2);
        sprintf(r,"%s\\%s",user,t1);
        }
      else
        {
        user = OS2_HOME;
        r=(char *)malloc(strlen(user)+strlen(t1)+1);
        sprintf(r,"%s%s",user,t1);
        }
    }
  return r; 
}
#endif
#if 0

char *expand_file_name(s)
char *s;
{
  char *r;
  char *home, *getenv();
  /* char *user="eight character name"; 18.5 */
  char userbuf[STRLEN];
  char *user=userbuf;
  char *t1,*t2;
  r=s;
  if (s[0]=='~') {
    t1=s+1;
    t2=user;
    while (*t1!=0 && *t1!='/') {
      *t2= *t1;
      *t2++;
      *t1++;
    }
    *t2=0;
    if ((int)strlen(user)>0) {
      if (TRUE) {
        user=OS2_HOME;
        r=(char *)malloc(strlen(user)+strlen(t1)+1);
        sprintf(r,"%s%s",user,t1);
      }
      else
        /* if (warning()) printf("couldn't find user '%s'.\n",user) */;
    }
    else {
      home=getenv("HOME");
      if (home) {
        r=(char *)malloc(strlen(home)+strlen(s)+1);
        sprintf(r,"%s%s",home,s+1);
      }
      else
        /* if (warning()) printf("no HOME directory.\n") */;
    }
  }

  /* printf("*** Using file name: '%s'\n",r); */
  
  return r;
}
#endif
  
/******** OPEN_INPUT_FILE(file)
  Open the input file specified by the string FILE.  If the file is "stdin",
  restore the stdin state.  Otherwise, open the file and create a new global
  state for it.
  If the file can't be opened, print an error and open "stdin" instead.
*/   
long open_input_file(file)
char *file;
{
  long ok=TRUE;
  long stdin_flag;
#ifdef OS2_PORT
char *file2;
#endif

  /* Save global input file state */
  if (input_state!=NULL) save_state(input_state);

#ifndef OS2_PORT2
  file=expand_file_name(file);
  
  if (stdin_flag=(!strcmp(file,"stdin"))) {
    input_stream=stdin;
    noisy=TRUE;
  }
  else {
    input_stream=fopen(file,"r");
    noisy=FALSE;
  }
  
  if (input_stream==NULL) {
    Errorline("file '%s' does not exist.\n",file);
    file="stdin";
    input_stream=stdin;
    noisy=TRUE;
    ok=FALSE;
  }

  if (!stdin_flag || stdin_state==NULL) {
    /* Initialize a new global input file state */
    strcpy(input_file_name,file);
    init_parse_state();
    /* Create a new state containing the new global values */
    new_state(&input_state);
    if (stdin_flag) stdin_state=input_state;
  }
  else {
    input_state=stdin_state;
    restore_state(input_state);
  }

  return ok;
#else
  file2=expand_file_name(file);
  
  if (stdin_flag=(!strcmp(file2,"stdin"))) {
    input_stream=stdin;
    noisy=TRUE;
  }
  else {
    input_stream=fopen(file2,"r");
    noisy=FALSE;
  }
  
  if (input_stream==NULL) {
#ifdef DJD_DEBUG
printf("missing file == %s\n",file2);
#endif


    Errorline("file '%s' does not exist.\n",file2);
    file="stdin";
    input_stream=stdin;
    noisy=TRUE;
    ok=FALSE;
  }

  if (!stdin_flag || stdin_state==NULL) {
    /* Initialize a new global input file state */
    strcpy(input_file_name,file2);
    init_parse_state();
    /* Create a new state containing the new global values */
    new_state(&input_state);
    if (stdin_flag) stdin_state=input_state;
  }
  else {
    input_state=stdin_state;
    restore_state(input_state);
  }

  return ok;
#endif
}



/******** OPEN_OUTPUT_FILE(file)
  Same thing as OPEN_INPUT_FILE, only for output. If FILE="stdout" then
  output_stream=stdout.
*/
long open_output_file(file)
string file;
{
  long ok=TRUE;


  file=expand_file_name(file);
  
  if (!strcmp(file,"stdout"))
    output_stream=stdout;
  else
    if (!strcmp(file,"stderr"))
      output_stream=stderr;
    else
      output_stream=fopen(file,"w");
   
  if (output_stream==NULL) {
    Errorline("file '%s' could not be opened for output.\n",file);
    ok=FALSE;
    output_stream=stdout;
  }
  
  return ok;
}



/******** READ_CHAR
  Return the char read from the input stream, if end of file reached
  then return EOF.
  If stringparse==TRUE then read characters from the input string
  instead of from a file.
*/
long read_char()
{
  long c=0;
  
  if (c=saved_char) {
    saved_char=old_saved_char;
    old_saved_char=0;
  }
  else if (stringparse) {
    if (c=(*stringinput))
      stringinput++;
    else
      c=EOF;
  }
  else if (feof(input_stream))
      c=EOF;
  else {
    if (start_of_line) {
      start_of_line=FALSE;
      line_count++;
      if (input_stream==stdin) Infoline("%s",prompt); /* 21.1 */
    }
     
    c=fgetc(input_stream);
    
    if(trace_input)   /*  RM: Jan 13 1993  */
      if(c!=EOF)
        printf("%c",c);
      else
        printf(" <EOF>\n");
#ifdef OS2_PORT
fflush(stdout);
#endif
    if (c==EOLN)
      start_of_line=TRUE;
  }

  /* printf("%c\n",c); RM: Jan  5 1993  Just to trace the parser */
  
  return c;
}



/******** PUT_BACK_CHAR
  Put back one character, if there already are 2 saved characters then report
  an error (= bug).
*/
void put_back_char(c)
long c;
{
  if (old_saved_char)
    Errorline("in tokenizer, put_back_char three times (last=%d).\n",c);
  old_saved_char=saved_char;
  saved_char=c;
}


/******** PUT_BACK_TOKEN
  Put back a psi_term, if there already are two saved then report an
  error (= bug).
*/
void put_back_token(t)
psi_term t;
{  
  if (old_saved_psi_term!=NULL)
    Errorline("in parser, put_back_token three times (last=%P).\n",t);
  old_saved_psi_term=saved_psi_term;
  saved_psi_term=stack_copy_psi_term(t);
}



/******** PSI_TERM_ERROR
  Print the line number at which the current psi_term started.
*/
void psi_term_error()
{
  perr_i("near line %d",psi_term_line_number);
  if (strcmp(input_file_name,"stdin")) {
    perr_s(" in file \042%s\042",input_file_name);
  }
  /* prompt="error>"; 20.8 */
  parse_ok=FALSE;
}



/******** READ_COMMENT
  Read a comment starting with '%' to the end of the line.
*/
void read_comment(tok)
ptr_psi_term tok;
{
  long c;
  
  do {
    c=read_char();
  } while (c!=EOF && c!=EOLN);
  
  tok->type=comment;
}

void
read_string_error(n)
     int n;
{
  if (stringparse) parse_ok=FALSE;
  else
    switch (n) {
    case 0:
      Syntaxerrorline("end of file reached before end of string (%E).\n");
      break;
    case 1:
      Syntaxerrorline("Hexadecimal digit expected (%E).\n");
      break;
    }
}

int
base2int(n)
     int n;
{
  switch (n) {
  case '0': return 0;
  case '1': return 1;
  case '2': return 2;
  case '3': return 3;
  case '4': return 4;
  case '5': return 5;
  case '6': return 6;
  case '7': return 7;
  case '8': return 8;
  case '9': return 9;
  case 'a':
  case 'A': return 10;
  case 'b':
  case 'B': return 11;
  case 'c':
  case 'C': return 12;
  case 'd':
  case 'D': return 13;
  case 'e':
  case 'E': return 14;
  case 'f':
  case 'F': return 15;
  default:
    fprintf(stderr,"base2int('%c'): illegal argument\n",n);
    exit(-1);
  }
}

#define isoctal(c) (c=='0'||c=='1'||c=='2'||c=='3'||c=='4'||c=='5'||c=='6'||c=='7')

/******** READ_STRING(e)
  Read a string ending with character E, where E=" or '. Transform a double
  occurrence into a single one so that 'ab""cd' is the string 'ab"cd'.
*/
void read_string(tok,e)
ptr_psi_term tok;
long e;
{
  long c;
  string str;
  long len=0;
  long store=TRUE;
  long flag=TRUE;
  
  str[len]=0;
  
  do {
    c=read_char();
    if (c==EOF) {
      store=FALSE;
      flag=FALSE;
      read_string_error(0);
    }
    else if (e=='"' && c=='\\') {
      c=read_char();
      if (c==EOF) {
        store=FALSE;
        flag=FALSE;
        put_back_char('\\');
        read_string_error(0);
      }
      else {
        switch (c) {
        case 'a': c='\a'; break;
        case 'b': c='\b'; break;
        case 'f': c='\f'; break;
        case 'n': c='\n'; break;
        case 'r': c='\r'; break;
        case 't': c='\t'; break;
        case 'v': c='\v'; break;
          /* missing \ooo and \xhh */
        case 'x':
          {
            int n;
            c=read_char();
            if (c==EOF) {
              store=flag=FALSE;
              read_string_error(0);
              break;
            }
            else if (!isxdigit(c)) {
              store=flag=FALSE;
              read_string_error(1);
              break;
            }
            else {
              n = base2int(c);
            }
            c=read_char();
            if (isxdigit(c)) n = 16*n+base2int(c);
            else put_back_char(c);
            c=n;
            break;
          }
        default: 
          if (isoctal(c)) {
            int n,i;
            for(i=n=0;i<3&&isoctal(c);i++,c=read_char())
              n = n*8 + base2int(c);
            if (c!=EOF) put_back_char(c);
            c=n;
            break;
          }
          else break;
        }
      }
    }
    else
      if (c==e) {
        c=read_char();
        if (c!=e) {
          store=FALSE;
          flag=FALSE;
          put_back_char(c);
        }
      }
    if (store)
      if (len==STRLEN) {
        Warningline("string too long, extra ignored (%E).\n");
        store=FALSE;
      }
      else {
        str[len++]=c;
        str[len]=0;
      }
  } while(flag);
  
  if (e=='"')
    tok->value=(GENERIC)heap_copy_string(str);
  else {
    tok->type=update_symbol(NULL,str); /* Maybe no_module would be better */
    tok->value=NULL;
    TOKEN_ERROR(tok);           /*  RM: Feb  1 1993  */
  }
}



/******** SYMBOLIC(character)
  Tests if character is a symbol (see macro).
*/
long symbolic(c)
long c;
{
  return SYMBOL(c);
}



/******** LEGAL_IN_NAME(character)
  Tests if character is legal in a name or a variable (see macros).
*/
long legal_in_name(c)
long c;
{
  return
    UPPER(c) ||
      LOWER(c) ||
        DIGIT(c);

  /* || c=='\'' RM: Dec 16 1992  */ ;
}



/******** READ_NAME(C,F,TYP)
  Read in the name starting with character C followed by character of whose
  type function is F. The result is a psi_term of symbol type TYP.
*/
void read_name(tok,ch,f,typ)
ptr_psi_term tok;
long ch;
long (*f)();
ptr_definition typ;
{
  long c;
  string str;
  long len=1;
  long store=TRUE;
  long flag=TRUE;
  ptr_module module=NULL;
  ptr_node n; /*  RM: Feb  9 1993  */

  tok->coref=NULL;
  tok->resid=NULL;
  tok->attr_list=NULL;

  str[0]=ch;
  
  do {
    c=read_char();
    flag=(*f)(c);
    
    if(c=='#' &&       /*  RM: Feb  3 1993  */
       f==legal_in_name &&
       len>0 &&
       len<STRLEN &&
       !module) {
      str[len]=0;
      module=create_module(str);
      len=0;
      flag=TRUE;

      /*  RM: Sep 21 1993  */
      /* Change the type function if required */
      c=read_char();
      if SYMBOL(c)
        f=symbolic;
      put_back_char(c);
    }
    else
      if (flag) {
        if (store)
          if (len==STRLEN) {
            Warningline("name too long, extra ignored (%E).\n");
            store=FALSE;
          }
          else
            str[len++]=c;
      }
      else
        put_back_char(c);
  } while(flag);

  if(module && len==0) { /*  RM: Feb  3 1993  */
    strcpy(str,module->module_name);
    len=strlen(str);
    put_back_char('#');
    module=NULL;
  }
  
  str[len]=0;
  
  tok->type=typ;
  
  if(typ==constant) {
    /* printf("module=%s\n",module->module_name); */
    tok->type=update_symbol(module,str); /*  RM: Feb  3 1993  */
    tok->value=NULL;

    TOKEN_ERROR(tok); /*  RM: Feb  1 1993  */

    /* PVR 4.2.94 for correct level incrementing */
    if (tok->type->type==global) {
      var_occurred=TRUE;
    }
    if (FALSE /*tok->type->type==global && tok->type->global_value*/) {
      /*  RM: Nov 10 1993  */
      
      /* Remove this for Bruno who didn't like it, and doesn't like
         to use "print_depth" */
      
      /*  RM: Feb  9 1993  */
      /* Add into the variable tree */
      var_occurred=TRUE;
      n=find(strcmp,tok->type->keyword->symbol,var_tree);
      if (n==NULL) {
        /* The change is always trailed. */
        bk2_stack_insert(strcmp,
                         tok->type->keyword->symbol,
                         &var_tree,
                         tok->type->global_value);
      }
    }
    
  }
  else  
    tok->value=(GENERIC)heap_copy_string(str);
}



/******** READ_NUMBER(c)
  Read in the number whose first character is c.
  Accepted syntax: digit+ [ . digit+ ] [ {e|E} {+|-|empty} digit* ]
  Negative numbers are dealt with in the parser.
*/
void read_number(tok,c)
ptr_psi_term tok;
long c;
{
  long c2;
  REAL f,p;
  long sgn,pwr,posflag;

  /* if (sgn=(c=='-')) c=read_char(); */

  /* tok->type=integer;   RM: Mar  8 1993  */

  f=0.0;
  do { f=f*10.0+(c-'0'); c=read_char(); } while (DIGIT(c));

  if (c=='.') {
    c2=read_char();
    if DIGIT(c2) {
      /* tok->type=real;     RM: Mar  8 1993  */
      p=10.0;
      while (DIGIT(c2)) { f=f+(c2-'0')/p; p=p*10.0; c2=read_char(); }
      put_back_char(c2);
    }
    else {
      put_back_char(c2);
      put_back_char(c);
    }
  }
  else
    put_back_char(c);

  c=read_char();
  if (c=='e' || c=='E') {
    c2=read_char();
    if (c2=='+' || c2=='-' || DIGIT(c2)) {
      tok->type=real;
      posflag = (c2=='+' || DIGIT(c2));
      if (!DIGIT(c2)) c2=read_char();
      pwr=0;
      while (DIGIT(c2)) { pwr=pwr*10+(c2-'0'); c2=read_char(); }
      put_back_char(c2);
      p=1.0;
      while (pwr>=100) { pwr-=100; if (posflag) p*=1e100; else p/=1e100; }
      while (pwr>=10 ) { pwr-=10;  if (posflag) p*=1e10;  else p/=1e10;  }
      while (pwr>0   ) { pwr-=1;   if (posflag) p*=1e1;   else p/=1e1;   }
      f*=p;
    }
    else {
      put_back_char(c2);
      put_back_char(c);
    }
  }
  else
    put_back_char(c);

  /* if (sgn) f = -f; */
  tok->value=heap_alloc(sizeof(REAL)); /* 12.5 */
  *(REAL *)tok->value=f;

  /*  RM: Mar  8 1993  */
  if(f==floor(f))
    tok->type=integer;
  else
    tok->type=real;
}



/******** READ_TOKEN
  Read in one token from the input stream, represented as a psi_term.
  Return the psi_term 'end_of_file' if that is the case.
*/

void read_token_main(); /* Forward declaration */

/* Used in the parser */
/* Set prompt to the 'partial input' prompt */
void read_token(tok)
ptr_psi_term tok;
{ read_token_main(tok, TRUE); }

/* Used as a built-in */
/* Prompt is unchanged */
void read_token_b(tok)
ptr_psi_term tok;
{ read_token_main(tok, FALSE); }

void read_token_main(tok, for_parser)
ptr_psi_term tok;
long for_parser;
{
  long c, c2;
  ptr_node n;
  char p[2];

  if (for_parser && (saved_psi_term!=NULL)) {
    *tok= *saved_psi_term;
    saved_psi_term=old_saved_psi_term;
    old_saved_psi_term=NULL;
  }
  else {
    tok->type=nothing;
    
    do {
      c=read_char();
    } while(c!=EOF && (c<=32));
    
    if (for_parser) psi_term_line_number=line_count;
    
    switch(c) {
    case EOF:
      tok->type=eof;
      tok->value=NULL;
      break;
    case '%':
      read_comment(tok);
      break;
    case '"':
      read_string(tok,c);
      tok->type=quoted_string;
      break;
    case 39: /* The quote symbol "'" */
      read_string(tok,c);
      break;
      
    default:
      
      /* Adding this results in problems with terms like (N-1) */
      /* if (c=='-' && (c2=read_char()) && DIGIT(c2)) {
        put_back_char(c2);
        read_number(tok,c);
      }
      else */

      if(c=='.' || c=='?') { /*  RM: Jul  7 1993  */
        c2=read_char();
        put_back_char(c2);
        /*printf("c2=%d\n",c2);*/
        if(c2<=' ' || c2==EOF) {
          if(c=='.')
            tok->type=final_dot;
          else
            tok->type=final_question;
          
          tok->value=NULL;
        }
        else
          read_name(tok,c,symbolic,constant);
      }
      else
        if DIGIT(c)
          read_number(tok,c);
          else
            if UPPER(c) {
              read_name(tok,c,legal_in_name,variable);
            }
            else
              if LOWER(c) {
                read_name(tok,c,legal_in_name,constant);
              }
              else
                if SYMBOL(c) {
                  read_name(tok,c,symbolic,constant);
                }
                else /*  RM: Jul  7 1993  Moved this */
                  if SINGLE(c) {
                    p[0]=c; p[1]=0;
                    tok->type=update_symbol(current_module,p);
                    tok->value=NULL;
                    TOKEN_ERROR(tok); /*  RM: Feb  1 1993  */
                  }
                  else {
                    Errorline("illegal character %d in input (%E).\n",c);
                  }
    }

    if (tok->type==variable) {
      if (tok->value) {
        /* If the variable read in has name "_", then it becomes 'top' */
        /* and is no longer a variable whose name must be remembered.  */
        /* As a result, '@' and '_' are synonyms in the program input. */
        if (!strcmp((char *)tok->value,"_")) {
          p[0]='@'; p[1]=0;
          tok->type=update_symbol(current_module,p);
          tok->value=NULL;
          TOKEN_ERROR(tok); /*  RM: Feb  1 1993  */
        }
        else {
          /* Insert into variable tree, create 'top' value if need be. */
          var_occurred=TRUE;
          n=find(strcmp,tok->value,var_tree);
          if (n==NULL) {
            ptr_psi_term t=stack_psi_term(0);
            /* The change is always trailed. */
            bk2_stack_insert(strcmp,tok->value,&var_tree,t); /* 17.8 */
            tok->coref=t;
          }
          else
            tok->coref=(ptr_psi_term)n->data;
        }
      }
      /* else do nothing */
    }
  }

  if (tok->type==comment)
    read_token(tok);

  if (tok->type!=variable)
    tok->coref=NULL;

  tok->attr_list=NULL;
  tok->status=0;
  tok->flags=FALSE; /* 14.9 */
  tok->resid=NULL;

  if (tok->type==cut) /* 12.7 */
    tok->value=(GENERIC)choice_stack;

  do {
    c=read_char();
    if (c==EOLN) {
      if (for_parser) put_back_char(c);
      c=0;
    }
    else if (c<0 || c>32) {
      put_back_char(c);
      c=0;
    }
  } while(c && c!=EOF);
  
  if (for_parser) prompt="|    ";
}

/****************************************************************************/

---