home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-read.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  36KB  |  1,507 lines
  1. /*  pl-read.c,v 1.6 1993/02/23 13:16:44 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: read/1, 2
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-ctype.h"
  12. #include <math.h>
  13.  
  14. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  15. This module defines the Prolog parser.  Reading a term takes two passes:
  16.  
  17.     * Reading the term into memory, deleting multiple blanks, comments
  18.       etc.
  19.     * Parsing this string into a Prolog term.
  20.  
  21. The separation has two reasons: we can call the  first  part  separately
  22. and  insert  the  read  strings in the history and we can produce better
  23. error messages as the parsed part of the source is available.
  24.  
  25. The raw reading pass is quite tricky as PCE requires  us  to  allow  for
  26. callbacks  from  C  during  this  process  and the callback might invoke
  27. another read.  Notable raw reading needs to be studied studied once more
  28. as it  takes  about  30%  of  the  entire  compilation  time  and  looks
  29. promissing  for  optimisations.   It  also  could  be  made  a  bit more
  30. readable.
  31.  
  32. This module is considerably faster when compiled  with  GCC,  using  the
  33. -finline-functions option.
  34. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  35.  
  36. forwards void    startRead P((void));
  37. forwards void    stopRead P((void));
  38. forwards void    errorWarning P((char *));
  39. forwards void    singletonWarning P((Atom *, int));
  40. forwards void    clearBuffer P((void));
  41. forwards void    addToBuffer P((char));
  42. forwards void    delBuffer P((void));
  43. forwards void    extendBeep P((void));
  44. forwards void    extendDeleteEscape P((void));
  45. forwards void    extendDeleteEof P((void));
  46. forwards void    extendReprint P((bool));
  47. forwards Char    getchr P((void));
  48. forwards char *    raw_read2 P((void));
  49. forwards char *    raw_read P((void));
  50.  
  51. typedef struct token * Token;
  52. typedef struct variable * Variable;
  53.  
  54. struct token
  55. { int type;            /* type of token */
  56.   union
  57.   { word prolog;        /* a Prolog value */
  58.     char character;        /* a punctuation character (T_PUNCTUATION) */
  59.     Variable variable;        /* a variable record (T_VARIABLE) */
  60.   } value;            /* value of token */
  61. };
  62.  
  63. struct variable
  64. { Word        address;    /* address of variable */
  65.   char *    name;        /* name of variable */
  66.   int        times;        /* number of occurences */
  67.   Variable     next;        /* next of chain */
  68. };
  69.  
  70. #define T_FUNCTOR    0    /* name of a functor (atom, followed by '(') */
  71. #define T_NAME        1    /* ordinary name */
  72. #define T_VARIABLE    2    /* variable name */
  73. #define T_VOID        3    /* void variable */
  74. #define T_REAL        4    /* realing point number */
  75. #define T_INTEGER    5    /* integer */
  76. #define T_STRING    6    /* "string" */
  77. #define T_PUNCTUATION    7    /* punctuation character */
  78. #define T_FULLSTOP    8    /* Prolog end of clause */
  79.  
  80. extern int Input;        /* current input stream (from pl-file.c) */
  81. static char *here;        /* current character */
  82. static char *base;        /* base of clause */
  83. static char *token_start;    /* start of most recent read token */
  84. static struct token token;    /* current token */
  85. static bool unget = FALSE;    /* unget_token() */
  86.  
  87. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  88. The reading function (raw_read()) can  be  called  recursively  via  the
  89. notifier  when  running  under  notifier  based packages (like O_PCE).  To
  90. avoid corruption of the database we push the read buffer rb on  a  stack
  91. and pop in back when finished.  See raw_read() and raw_read2().
  92. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  93.  
  94. #define RBSIZE    512        /* initial size of read buffer */
  95. #define MAX_READ_NESTING 5    /* nesting of read (O_PCE only) */
  96.  
  97. static
  98. struct read_buffer
  99. { int    size;            /* current size of read buffer */
  100.   int    left;            /* left space in read buffer */
  101.   char *base;            /* base of read buffer */
  102.   char *here;            /* current position in read buffer */
  103.   int   stream;            /* stream we are reading from */
  104.   FILE *fd;            /* file descriptor we are reading from */
  105.   bool    doExtend;        /* extension mode on? */
  106. } rb;
  107.  
  108. #if O_PCE
  109. static struct read_buffer rb_stack[MAX_READ_NESTING];
  110. int read_nesting = 0;        /* current nesting level */
  111. #endif /* O_PCE */
  112.  
  113. void
  114. resetRead()
  115. { 
  116. #if O_PCE
  117.   read_nesting = 0;
  118. #endif
  119. }
  120.  
  121. static
  122. void
  123. startRead()
  124. {
  125. #if O_PCE
  126.   if (read_nesting >= MAX_READ_NESTING)
  127.   { warning("Read stack too deeply nested");
  128.     pl_abort();
  129.   }
  130.   rb_stack[read_nesting++] = rb;
  131.   rb = rb_stack[read_nesting];
  132. #endif /* O_PCE */
  133.   rb.doExtend = (Input == 0 && status.notty == FALSE);
  134.   rb.stream = Input;
  135.   rb.fd = checkInput(rb.stream);
  136.   source_file_name = currentStreamName();
  137. }
  138.  
  139. static void
  140. stopRead()
  141. {
  142. #if O_PCE
  143.   rb_stack[read_nesting] = rb;
  144.   rb = rb_stack[--read_nesting];
  145.   if (read_nesting < 0)
  146.     fatalError("Read stack underflow???");
  147.   if (read_nesting > 0)
  148.   { rb.fd = checkInput(rb.stream);
  149.   /*source_file_name = currentStreamName();*/
  150.   }
  151. #endif /* O_PCE */
  152. }
  153.  
  154.         /********************************
  155.         *         ERROR HANDLING        *
  156.         *********************************/
  157.  
  158. #define syntaxError(what) { errorWarning(what); fail; }
  159.  
  160. static void
  161. errorWarning(what)
  162. char *what;
  163. { char c = *token_start;
  164.   
  165.   if ( !ReadingSource )            /* not reading from a file */
  166.   { fprintf(stderr, "\n[WARNING: Syntax error: %s \n", what);
  167.     *token_start = EOS;
  168.     fprintf(stderr, "%s\n** here **\n", base);  
  169.     if (c != EOS)
  170.     { *token_start = c;
  171.       fprintf(stderr, "%s]\n", token_start);
  172.     }
  173.   } else
  174.   { char *s;
  175.     word goal = globalFunctor(FUNCTOR_exception3);
  176.     word arg;
  177.  
  178.     for(s = base; s < token_start; s++ )
  179.       if ( *s == '\n' )
  180.           source_line_no++;
  181.  
  182.     unifyAtomic(argTermP(goal, 0), ATOM_syntax_error);
  183.     unifyFunctor(argTermP(goal, 1), FUNCTOR_syntax_error3);
  184.     arg = argTerm(goal, 1);
  185.     unifyAtomic(argTermP(arg, 0), source_file_name);
  186.     unifyAtomic(argTermP(arg, 1), consNum(source_line_no));
  187.     unifyAtomic(argTermP(arg, 2), lookupAtom(what));
  188.  
  189.     if ( callGoal(MODULE_user, goal, FALSE) == FALSE )
  190.       warning("Syntax error: %s", what);
  191.   }
  192. }
  193.  
  194.  
  195. static void
  196. singletonWarning(vars, nvars)
  197. Atom *vars;
  198. int nvars;
  199. { word goal = globalFunctor(FUNCTOR_exception3);
  200.   word arg;
  201.   Word a;
  202.   int n;
  203.  
  204.   unifyAtomic(argTermP(goal, 0), ATOM_singleton);
  205.   unifyFunctor(argTermP(goal, 1), FUNCTOR_singleton3);
  206.   arg = argTerm(goal, 1);
  207.   unifyAtomic(argTermP(arg, 0), source_file_name);
  208.   unifyAtomic(argTermP(arg, 1), consNum(source_line_no));
  209.   a = argTermP(arg, 2);
  210.   for(n=0; n<nvars; n++)
  211.   { unifyFunctor(a, FUNCTOR_dot2);
  212.     unifyAtomic(argTermP(*a, 0), vars[n]);
  213.     a = argTermP(*a, 1);
  214.   }
  215.   unifyAtomic(a, ATOM_nil);
  216.  
  217.   if ( callGoal(MODULE_user, goal, FALSE) == FALSE )
  218.   { char buf[LINESIZ];
  219.  
  220.     buf[0] = EOS;
  221.     for(n=0; n<nvars; n++)
  222.     { if ( n > 0 )
  223.     strcat(buf, ", ");
  224.       strcat(buf, stringAtom(vars[n]));
  225.     }
  226.  
  227.     warning("Singleton variables: %s", buf);
  228.   }
  229. }
  230.  
  231.  
  232.         /********************************
  233.         *           RAW READING         *
  234.         *********************************/
  235.  
  236.  
  237. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  238. Scan the input, give prompts when necessary and return a char *  holding
  239. a  stripped  version of the next term.  Contigeous white space is mapped
  240. on a single space, block and % ... \n comment  is  deleted.   Memory  is
  241. claimed automatically en enlarged if necessary.
  242.  
  243. Earlier versions used to local stack for building the term.   This  does
  244. not  work  with  O_PCE  as  we might be called back via the notifier while
  245. reading.
  246.  
  247. (char *) NULL is returned on a syntax error.
  248. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  249.  
  250. static void
  251. clearBuffer()
  252. { if (rb.size == 0)
  253.   { if ((rb.base = Malloc(RBSIZE)) == (char *) NULL)
  254.       fatalError("%s", OsError());
  255.     rb.size = RBSIZE;
  256.   }
  257.   SECURE( if ( rb.base == 0 ) fatalError("read/1: nesting=%d, size=%d",
  258.                         read_nesting, rb.size) );
  259.   rb.left = rb.size;
  260.   base = rb.here = rb.base;
  261.   DEBUG(8, printf("Cleared read buffer.rb at %ld, base at %ld\n", &rb, rb.base));
  262. }      
  263.  
  264. #if PROTO
  265. static void
  266. addToBuffer(
  267. register char c)
  268. #else
  269. static void
  270. addToBuffer(c)
  271. register char c;
  272. #endif
  273. { if (rb.left-- == 0)
  274.   { if ((rb.base = Realloc(rb.base, rb.size * 2)) == (char *)NULL)
  275.       fatalError("%s", OsError());
  276.     DEBUG(8, printf("Reallocated read buffer at %ld\n", rb.base));
  277.     base = rb.base;
  278.     rb.here = rb.base + rb.size;
  279.     rb.left = rb.size - 1;
  280.     rb.size *= 2;
  281.   }
  282.   *rb.here++ = c;
  283. }
  284.  
  285. static void
  286. delBuffer()
  287. { if ( rb.here > rb.base )
  288.   { rb.here--;
  289.     rb.left++;
  290.   }
  291. }
  292.  
  293. #if O_EXTEND_ATOMS
  294.  
  295. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  296. Primitive functions to print and delete characters for  atom-completion.
  297. Should be abstracted from a bit and incorporated in the operating system
  298. interface.   As  this  model of atom-completion is unlikely to work on a
  299. non-Unix machine anyway this will do for the moment.
  300. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  301.  
  302. static void
  303. extendBeep()
  304. { if ( status.beep == TRUE )
  305.   { putchar(07);        /* ^G: the bel */
  306.     fflush(stdout);
  307.   }
  308. }
  309.  
  310. #if O_LINE_EDIT                /* otherwise, define in md.h */
  311. #define DEL_ESC    "\b\b  \b\b"
  312. #define DEL_EOF "\b\b  \b\b"
  313. #endif /* O_LINE_EDIT */
  314.  
  315. static void
  316. extendDeleteEscape()
  317. { printf(DEL_ESC);
  318.   fflush(stdout);
  319. }
  320.  
  321. static void
  322. extendDeleteEof()
  323. { printf(DEL_EOF);
  324.   fflush(stdout);
  325. }
  326.  
  327. static void
  328. extendReprint(reprint)
  329. bool reprint;
  330. { ttybuf buf;
  331.   char *s, *start = rb.here - 1;
  332.  
  333.   for(; *start != '\n' && start >= rb.base; start-- ) ;
  334.   start++;
  335.   PushTty(&buf, reprint ? TTY_APPEND : TTY_RETYPE);
  336.   for( s=start; s < rb.here; s++ )
  337.     PretendTyped(*s);
  338.   PopTty(&buf);
  339.   while(rb.here > start)
  340.     delBuffer();
  341.   fflush(stdout);
  342. }
  343.  
  344. #endif /* O_EXTEND_ATOMS */
  345.  
  346. static Char
  347. getchr()
  348. { register Char c;
  349.  
  350.   if (rb.fd == (FILE *)NULL)
  351.   { c =  Get0();
  352.     base = rb.base;
  353.   } else if ((c = (Char) Getc(rb.fd)) == '\n')
  354.     newLineInput();
  355.  
  356.   return c;
  357. }
  358.  
  359. #define ensure_space(c) { if ( something_read && \
  360.                    (c == '\n'|| !isBlank(rb.here[-1])) ) \
  361.                addToBuffer(c); \
  362.                 }
  363. #define set_start_line { if ( !something_read ) \
  364.              { source_file_name = currentStreamName(); \
  365.                source_line_no = currentInputLine(); \
  366.                something_read++; \
  367.              } \
  368.                }
  369.  
  370. #define rawSyntaxError(what) { addToBuffer(EOS); \
  371.                    base = rb.base, token_start = rb.here-1; \
  372.                    syntaxError(what); \
  373.                  }
  374.  
  375. static char *
  376. raw_read2()
  377. { register Char c;
  378.   bool something_read = FALSE;
  379.   int newlines;
  380.  
  381.   clearBuffer();                /* clear input buffer */
  382.   prompt(FALSE);                /* give prompt */
  383.   source_line_no = -1;
  384.  
  385.   for(;;)
  386.   { c = getchr();
  387.     DEBUG(3, if ( Input == 0 ) printf("getchr() -> %d (%c)\n", c, c));
  388.     DEBUG(3, if ( Input == 0 ) printf("here = %d, base = %d", rb.here, rb.base));
  389.     if ( c == ttytab.tab.c_cc[ VEOF ] ) c = EOF ;
  390.     switch(c)
  391.     { case EOF:
  392.         if (seeingString())        /* do not require '. ' when */
  393.         { addToBuffer(' ');        /* reading from a string */
  394.           addToBuffer('.');
  395.           addToBuffer(' ');
  396.           addToBuffer(EOS);
  397.           return rb.base;
  398.         }
  399.         if (something_read)
  400.         {
  401. #if O_EXTEND_ATOMS
  402.           if ( rb.doExtend == TRUE )
  403.           { char *a;
  404.  
  405.             addToBuffer(EOS);        /* allocates if need be */
  406.             delBuffer();
  407.             a = rb.here - 1;
  408.             for( ;a >= rb.base && isAlpha(*a); a--) ;
  409.             a++;
  410.             extendDeleteEof();
  411.             if ( a >= rb.here || !isLower(*a) )
  412.             { extendReprint(FALSE);
  413.               extendBeep();
  414.               break;
  415.             }
  416.             Put('\n');
  417.             extendAlternatives(a);
  418.             extendReprint(TRUE);
  419.             break;
  420.           }          
  421. #endif /* O_EXTEND_ATOMS */
  422.           rawSyntaxError("Unexpected end of file");
  423.         }
  424.       e_o_f:
  425.         strcpy(rb.base, "end_of_file. ");
  426.         return rb.base;
  427.       case '*':    if ( rb.here-rb.base >= 1 && rb.here[-1] == '/' )
  428.         { register char last;
  429.           int level = 1;
  430.  
  431.           rb.here--, rb.left++;    /* delete read '/' */
  432.  
  433.           if ((last = getchr()) == EOF)
  434.             rawSyntaxError("End of file in ``/* ... */'' comment");
  435.           for(;;)
  436.           { switch(c = getchr())
  437.             { case EOF:
  438.             rawSyntaxError("End of file in ``/* ... */'' comment");
  439.               case '*':
  440.             if ( last == '/' )
  441.               level++;
  442.             break;
  443.               case '/':
  444.             if ( last == '*' && --level == 0 )
  445.             { c = ' ';
  446.               goto case_default; /* hack */
  447.             }
  448.             break;
  449.               case '\n':
  450.             if ( something_read )
  451.               addToBuffer(c);
  452.             }
  453.             last = c;
  454.           }
  455.         }
  456.  
  457.         set_start_line;
  458.         addToBuffer(c);
  459.         break;
  460.       case '%': while((c=getchr()) != EOF && c != '\n') ;
  461.         if (c == EOF)
  462.         { if (something_read)
  463.             rawSyntaxError("Unexpected end of file")
  464.           else
  465.             goto e_o_f;          
  466.         }
  467.  
  468.         goto case_default;        /* Hack */
  469.      case '\'': if ( rb.here > rb.base && isDigit(rb.here[-1]) )
  470.         { addToBuffer(c);            /* <n>' */
  471.           if ( rb.here[-2] == '0' )        /* 0'<c> */
  472.           { if ( (c=getchr()) != EOF )
  473.             { addToBuffer(c);
  474.               break;
  475.             }
  476.             rawSyntaxError("Unexpected end of file");
  477.           }
  478.           break;
  479.         }
  480.  
  481.         set_start_line;
  482.         newlines = 0;
  483.         addToBuffer(c);
  484.         while((c=getchr()) != EOF && c != '\'')
  485.         { if (c == '\n' &&
  486.                newlines++ > MAXNEWLINES &&
  487.                (debugstatus.styleCheck & LONGATOM_CHECK))
  488.             rawSyntaxError("Atom too long");
  489.           addToBuffer(c);
  490.         }
  491.         if (c == EOF)
  492.           rawSyntaxError("End of file in quoted atom");
  493.         addToBuffer(c);
  494.         break;
  495.       case '"':    set_start_line;
  496.         newlines = 0;
  497.         addToBuffer(c);
  498.         while((c=getchr()) != EOF && c != '"')
  499.         { if (c == '\n' &&
  500.                newlines++ > MAXNEWLINES &&
  501.                (debugstatus.styleCheck & LONGATOM_CHECK))
  502.             rawSyntaxError("String too long");
  503.           addToBuffer(c);
  504.         }
  505.         if (c == EOF)
  506.           rawSyntaxError("End of file in string");
  507.         addToBuffer(c);
  508.         break;
  509. #if O_EXTEND_ATOMS
  510.       case ESC: if ( rb.doExtend == TRUE )
  511.         { char *a;
  512.           char *extend;
  513.           bool unique;
  514.  
  515.           addToBuffer(EOS);        /* allocates if need be */
  516.           delBuffer();
  517.           a = rb.here - 1;
  518.           for( ;a >= rb.base && isAlpha(*a); a--) ;
  519.           a++;
  520.           if ( a >= rb.here || !isLower(*a) )
  521.           { extendDeleteEscape();
  522.             extendReprint(FALSE);
  523.             extendBeep();
  524.             break;
  525.           }
  526.           if ( (extend = extendAtom(a, &unique)) != (char *)NULL )
  527.           { ttybuf buf;
  528.  
  529.             extendDeleteEscape();
  530.             extendReprint(FALSE);
  531.             PushTty(&buf, TTY_APPEND);
  532.             while(*extend)
  533.               PretendTyped(*extend++);
  534.             PopTty(&buf);
  535.             if ( unique == FALSE )
  536.               extendBeep();
  537.           } else
  538.           { extendDeleteEscape();
  539.             extendReprint(FALSE);
  540.             extendBeep();
  541.           }
  542.           break;          
  543.         }
  544.         /*FALLTHROUGH*/
  545. #endif /* O_EXTEND_ATOMS */
  546.       case_default:                /* Hack, needs fixing */
  547.       default:    if ( isBlank(c) )
  548.         { long rd;
  549.  
  550.           rd = rb.here - rb.base;
  551.           if (rd == 1 && rb.here[-1] == '.')
  552.             rawSyntaxError("Unexpected end of clause");
  553.           if (rd >= 2)
  554.           { if ( rb.here[-1] == '.' &&
  555.              !isSymbol(rb.here[-2]) &&
  556.              !(rb.here[-2] == '\'' && rd >= 3 && rb.here[-3] == '0'))
  557.             { ensure_space(c);
  558.               addToBuffer(EOS);
  559.               return rb.base;
  560.             }
  561.           }
  562.           ensure_space(c);
  563.           if ( c == '\n' )
  564.             prompt(TRUE);
  565.         } else
  566.         { addToBuffer(c);
  567.           if ( c != '/' )    /* watch comment start */
  568.             set_start_line;
  569.         }
  570.         break;
  571.     }
  572.   }
  573. }  
  574.  
  575. static char *
  576. raw_read()
  577. { char *s;
  578.  
  579.   startRead();
  580. #if O_EXTEND_ATOMS
  581.   if ( Input == 0 && status.notty == FALSE )
  582.   { ttybuf buf;
  583.  
  584.     PushTty(&buf, TTY_EXTEND_ATOMS);
  585.     s = raw_read2();
  586.     PopTty(&buf);
  587.   } else
  588. #endif
  589.     s = raw_read2();
  590.   stopRead();
  591.  
  592.   return s;
  593. }
  594.  
  595.  
  596.         /*********************************
  597.         *        VARIABLE DATABASE       *
  598.         **********************************/
  599.  
  600. #define VARHASHSIZE 16
  601. #define MAX_SINGLETONS 250
  602.  
  603. static char *     allocBase;        /* local allocation base */
  604. #if !O_DYNAMIC_STACKS
  605. static char *    allocTop;        /* top of allocation */
  606. #endif
  607. static Variable* varTable;        /* hashTable for variables */
  608.  
  609. forwards void    check_singletons P((void));
  610. forwards bool    bind_variables P((Word));
  611. forwards char *    alloc_var P((size_t));
  612. forwards char *    save_var_name P((char *));
  613. forwards Variable lookupVariable P((char *));
  614. forwards void    initVarTable P((void));
  615.  
  616. static void
  617. check_singletons()
  618. { register Variable var;
  619.   int n;
  620.   Atom singletons[MAX_SINGLETONS];
  621.   int i=0;
  622.  
  623.   for(n=0; n<VARHASHSIZE; n++)
  624.   { for(var = varTable[n]; var; var=var->next)
  625.     { if (var->times == 1 && var->name[0] != '_' && i < MAX_SINGLETONS)
  626.     singletons[i++] = lookupAtom(var->name);
  627.     }
  628.   }
  629.   
  630.   if ( i > 0 )
  631.     singletonWarning(singletons, i);
  632. }
  633.  
  634. /*  construct a list of Var = <name> terms wich indicate the bindings
  635.     of the variables. Anonymous variables are skipped. The result is
  636.     unified with the argument.
  637.  
  638.  ** Sat Apr 16 23:09:04 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  639.  
  640. static bool
  641. bind_variables(bindings)
  642. Word bindings;
  643. { Variable var;
  644.   int n;
  645.   word binding;
  646.   Word arg;
  647.  
  648.   for(n=0; n<VARHASHSIZE; n++)
  649.   { for(var = varTable[n]; var; var=var->next)
  650.     { if (var->name[0] != '_')
  651.       { binding = globalFunctor(FUNCTOR_equals2);
  652.     arg     = argTermP(binding, 0);
  653.     *arg++  = (word) lookupAtom(var->name);
  654.     *arg    = makeRef(var->address);
  655.     APPENDLIST(bindings, &binding);
  656.       }
  657.     }
  658.   }
  659.   CLOSELIST(bindings);
  660.  
  661.   succeed;
  662. }
  663.  
  664. static char *
  665. alloc_var(n)
  666. register size_t n;
  667. { register char *space;
  668.  
  669.   n = ROUND(n, sizeof(word));
  670.  
  671.   STACKVERIFY(if (allocBase + n > allocTop) outOf((Stack)&stacks.local) );
  672.  
  673.   space = allocBase;
  674.   allocBase += n;
  675.  
  676.   return space;
  677. }
  678.  
  679. static char *
  680. save_var_name(s)
  681. char *s;
  682. { char *copy = alloc_var(strlen(s) + 1);
  683.  
  684.   strcpy(copy, s);
  685.  
  686.   return copy;
  687. }
  688.  
  689. static Variable
  690. lookupVariable(s)
  691. char *s;
  692. { int v = stringHashValue(s, VARHASHSIZE);
  693.   Variable var;
  694.  
  695.   for(var=varTable[v]; var; var=var->next)
  696.   { if (streq(s, var->name) )
  697.     { var->times++;
  698.       return var;
  699.     }
  700.   }
  701.   var = (Variable) alloc_var((size_t) sizeof(struct variable));
  702.   DEBUG(9, printf("Allocated var at %ld\n", var));
  703.   var->next = varTable[v];
  704.   varTable[v] = var;
  705.   var->name = save_var_name(s);
  706.   var->times = 1;
  707.   var->address = (Word) NULL;
  708.  
  709.   return var;
  710. }
  711.  
  712. static void
  713. initVarTable()
  714. { int n;
  715.  
  716.   allocBase = (char *)(lTop+1) + (MAXARITY+MAXVARIABLES) * sizeof(word);
  717. #if !O_DYNAMIC_STACKS
  718.   allocTop  = (char *)lMax;
  719. #endif
  720.  
  721.   varTable = (Variable *)alloc_var((size_t) sizeof(Variable)*VARHASHSIZE);
  722.   for(n=0; n<VARHASHSIZE; n++)
  723.     varTable[n] = (Variable) NULL;
  724. }
  725.  
  726.         /********************************
  727.         *           TOKENISER           *
  728.         *********************************/
  729.  
  730. #define skipSpaces    { while(isBlank(*here) ) here++; c = *here++; }
  731. #define unget_token()    { unget = TRUE; }
  732.  
  733. forwards Token    get_token P((bool));
  734. forwards word    build_term P((Atom, int, Word));
  735. forwards bool    complex_term P((char *, Word));
  736. forwards bool    simple_term P((bool, Word, bool *));
  737. forwards bool    read_term P((Word, Word, bool));
  738.  
  739. typedef union
  740. { long    i;
  741.   real  r;
  742. } number;
  743.  
  744. #define V_ERROR 0
  745. #define V_REAL  1
  746. #define V_INT   2
  747.  
  748. forwards int scan_number P((char **, int, number *));
  749.  
  750. static int
  751. scan_number(s, b, n)
  752. char **s;
  753. int b;
  754. number *n;
  755. { int d;
  756.  
  757.   n->i = 0;
  758.   while((d = digitValue(b, **s)) >= 0)
  759.   { (*s)++;
  760.     n->i = n->i * b + d;
  761.     if ( n->i > PLMAXINT )
  762.     { n->r = (real) n->i;
  763.       while((d = digitValue(b, **s)) >= 0)
  764.       { (*s)++;
  765.         if ( n->r > MAXREAL / (real) b - (real) d )
  766.       return V_ERROR;
  767.         n->r = n->r * (real)b + (real)d;
  768.       }
  769.       return V_REAL;
  770.     }
  771.   }  
  772.  
  773.   return V_INT;
  774. }
  775.  
  776.  
  777. static Token
  778. get_token(must_be_op)
  779. bool must_be_op;
  780. { char c;
  781.   char *start;
  782.   char end;
  783.   int negative = 1;
  784.  
  785.   if (unget)
  786.   { unget = FALSE;
  787.     return &token;
  788.   }
  789.  
  790.   skipSpaces;
  791.   token_start = here - 1;
  792.   switch(char_type[(unsigned)c & 0xff])
  793.   { case LC:    { start = here-1;
  794.           while(isAlpha(*here) )
  795.             here++;
  796.           c = *here;
  797.           *here = EOS;
  798.           token.value.prolog = (word)lookupAtom(start);
  799.           *here = c;
  800.           token.type = (c == '(' ? T_FUNCTOR : T_NAME);
  801.           DEBUG(9, printf("%s: %s\n", c == '(' ? "FUNC" : "NAME", stringAtom(token.value.prolog)));
  802.  
  803.           return &token;
  804.         }
  805.     case UC:    { start = here-1;
  806.           while(isAlpha(*here) )
  807.             here++;
  808.           c = *here;
  809.           *here = EOS;
  810.           if (start[0] == '_' && here == start + 1)
  811.           { setVar(token.value.prolog);
  812.             DEBUG(9, printf("VOID\n"));
  813.             token.type = T_VOID;
  814.           } else
  815.           { token.value.variable = lookupVariable(start);
  816.             DEBUG(9, printf("VAR: %s\n", token.value.variable->name));
  817.             token.type = T_VARIABLE;
  818.           }
  819.           *here = c;
  820.  
  821.           return &token;
  822.         }
  823.     case_digit:
  824.     case DI:    { number value;
  825.           int tp;
  826.  
  827.           if (c == '0' && *here == '\'')        /* 0'<char> */
  828.           { if (isAlpha(here[2]))
  829.             { here += 2;
  830.               syntaxError("Illegal number");
  831.             }
  832.             token.value.prolog = consNum((long)here[1] * negative);
  833.             token.type = T_INTEGER;
  834.             here += 2;
  835.  
  836.             DEBUG(9, printf("INT: %ld\n", valNum(token.value.prolog)));
  837.             return &token;
  838.           }
  839.  
  840.           here--;        /* start of token */
  841.           if ( (tp = scan_number(&here, 10, &value)) == V_ERROR )
  842.             syntaxError("Number too large");
  843.  
  844.                     /* base'value number */
  845.           if ( *here == '\'' )
  846.           { here++;
  847.  
  848.             if ( tp == V_REAL || value.i > 36 )
  849.               syntaxError("Base of <base>'<value> too large");
  850.             if ( (tp = scan_number(&here, (int)value.i, &value))
  851.                                 == V_ERROR )
  852.               syntaxError("Number too large"); 
  853.  
  854.             if (isAlpha(*here) )
  855.               syntaxError("Illegal number");
  856.  
  857.             if ( tp == V_INT )
  858.             { token.value.prolog = consNum(value.i * negative);
  859.               token.type = T_INTEGER;
  860.             } else
  861.             { token.value.prolog = globalReal(value.r * negative);
  862.               token.type = T_REAL;
  863.             }
  864.  
  865.             return &token;
  866.           }
  867.                     /* Real numbers */
  868.           if ( *here == '.' && isDigit(here[1]) )
  869.           { real n;
  870.  
  871.             if ( tp == V_INT )
  872.             { value.r = (real) value.i;
  873.               tp = V_REAL;
  874.             }
  875.             n = 10.0, here++;
  876.             while(isDigit(c = *here) )
  877.             { here++;
  878.               value.r += (real)(c-'0') / n;
  879.               n *= 10.0;
  880.             }
  881.           }
  882.  
  883.           if ( *here == 'e' || c == 'E' )
  884.           { number exponent;
  885.             bool neg_exponent;
  886.  
  887.             here++;
  888.             DEBUG(9, printf("Exponent\n"));
  889.             switch(*here)
  890.             { case '-':        here++;
  891.                     neg_exponent = TRUE;
  892.                     break;
  893.               case '+':        here++;
  894.               default:        neg_exponent = FALSE;
  895.                     break;
  896.             }
  897.  
  898.             if ( scan_number(&here, 10, &exponent) != V_INT )
  899.               syntaxError("Exponent too large");
  900.  
  901.             if ( tp == V_INT )
  902.             { value.r = (real) value.i;
  903.               tp = V_REAL;
  904.             }
  905.  
  906.             value.r *= pow((double)10.0,
  907.                    neg_exponent ? -(double)exponent.i
  908.                                 : (double)exponent.i);
  909.           }
  910.  
  911.           if ( isAlpha(c = *here) )
  912.             syntaxError("Illegal number");
  913.  
  914.           if ( tp == V_REAL )
  915.           { token.value.prolog = globalReal(value.r * negative);
  916.             token.type = T_REAL;
  917.           } else
  918.           { token.value.prolog = consNum(value.i * negative);
  919.             token.type = T_INTEGER;
  920.           }
  921.  
  922.           return &token;
  923.         }          
  924.     case SO:    { char tmp[2];
  925.  
  926.           tmp[0] = c, tmp[1] = EOS;
  927.           token.value.prolog = (word) lookupAtom(tmp);
  928.           token.type = T_NAME;
  929.           DEBUG(9, printf("NAME: %s\n", stringAtom(token.value.prolog)));
  930.  
  931.           return &token;
  932.         }
  933.     case SY:    { if (c == '.' && isBlank(here[0]))
  934.           { token.type = T_FULLSTOP;
  935.             return &token;
  936.           }
  937.           start = here - 1;
  938.           while( isSymbol(*here) )
  939.             here++;
  940.           end = *here, *here = EOS;
  941.           token.value.prolog = (word) lookupAtom(start);
  942.           *here = end;
  943.           if ( !must_be_op && isDigit(end) ) /* +- <number> case */
  944.           { if ( token.value.prolog == (word) ATOM_minus )
  945.             { negative = -1;
  946.               c = *here++;
  947.               goto case_digit;
  948.             } else if ( token.value.prolog == (word) ATOM_plus )
  949.             { c = *here++;
  950.               goto case_digit;
  951.             }
  952.           }
  953.           token.type = (end == '(' ? T_FUNCTOR : T_NAME);
  954.           DEBUG(9, printf("%s: %s\n", end == '(' ? "FUNC" : "NAME", stringAtom(token.value.prolog)));
  955.  
  956.           return &token;
  957.         }
  958.     case PU:    { switch(c)
  959.           { case '{':
  960.             case '[': while(isBlank(*here) )
  961.                 here++;
  962.                   if (here[0] == matchingBracket(c))
  963.                   { here++;
  964.                 token.value.prolog =
  965.                     (word)(c == '[' ? ATOM_nil : ATOM_curl);
  966.                 token.type = T_NAME;
  967.                 DEBUG(9, printf("NAME: %s\n", stringAtom(token.value.prolog)));
  968.                 return &token;
  969.                   }
  970.           }
  971.           token.value.character = c;
  972.           token.type = T_PUNCTUATION;
  973.           DEBUG(9, printf("PUNCT: %c\n", token.value.character));
  974.  
  975.           return &token;
  976.         }
  977.     case SQ:    { char *s;
  978.  
  979.           start = here;
  980.           for(s=start;;)
  981.           { if (*here == '\'')
  982.             { if (here[1] != '\'')
  983.               { end = *s, *s = EOS;
  984.             token.value.prolog = (word) lookupAtom(start);
  985.             *s = end;
  986.             token.type = (here[1] == '(' ? T_FUNCTOR : T_NAME);
  987.             here++;
  988.             DEBUG(9, printf("%s: %s\n", here[1] == '(' ? "FUNC" : "NAME", stringAtom(token.value.prolog)));
  989.             return &token;
  990.               }
  991.               here++;
  992.             }
  993.             *s++ = *here++;
  994.           }
  995.         }
  996.     case DQ:    { char *s;
  997.  
  998.           start = here;
  999.           for(s=start;;)
  1000.           { if (*here == '"')
  1001.             { if (here[1] != '"')
  1002.               { end = *s, *s = EOS;
  1003. #if O_STRING
  1004.             if ( debugstatus.styleCheck & O_STRING_STYLE )
  1005.               token.value.prolog = globalString(start);
  1006.             else
  1007.               token.value.prolog = (word) stringToList(start);
  1008. #else
  1009.             token.value.prolog = (word) stringToList(start);
  1010. #endif /* O_STRING */
  1011.             DEBUG(9, printf("STR: %s\n", start));
  1012.             *s = end;
  1013.             token.type = T_STRING;
  1014.             here++;
  1015.             return &token;
  1016.               }
  1017.               here++;
  1018.             }
  1019.             *s++ = *here++;
  1020.           }
  1021.         }
  1022.     default:    { sysError("read/1: tokeniser internal error");
  1023.               return &token;    /* make lint happy */
  1024.         }
  1025.   }
  1026. }
  1027.  
  1028. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1029. Build a term on the global stack, given the atom  of  the  functor,  the
  1030. arity  and  a  vector of arguments.  The argument vector either contains
  1031. nonvar terms or a reference to a variable block.
  1032. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1033.  
  1034. static word
  1035. build_term(atom, arity, argv)
  1036. Atom atom;
  1037. int arity;
  1038. Word argv;
  1039. { FunctorDef functor = lookupFunctorDef(atom, arity);
  1040.   word term;
  1041.   Word argp;
  1042.  
  1043.   DEBUG(9, printf("Building term %s/%d ... ", stringAtom(atom), arity));
  1044.   term = globalFunctor(functor);
  1045.   argp = argTermP(term, 0);
  1046.   while(arity-- > 0)
  1047.   { if (isRef(*argv) )
  1048.     { Variable var;
  1049. #if O_NO_LEFT_CAST
  1050.       Word w;
  1051.       deRef2(argv, w);
  1052.       var = (Variable) w;
  1053. #else
  1054.       deRef2(argv, (Word)var);
  1055. #endif
  1056.       if (var->address == (Word) NULL)
  1057.     var->address = argp++;
  1058.       else
  1059.     *argp++ = makeRef(var->address);
  1060.       argv++;
  1061.     } else
  1062.       *argp++ = *argv++;
  1063.   }
  1064.   DEBUG(9, printf("result: "); pl_write(&term); printf("\n") );
  1065.  
  1066.   return term;
  1067. }
  1068.  
  1069.  
  1070.         /********************************
  1071.         *             PARSER            *
  1072.         *********************************/
  1073.  
  1074. #define priorityClash { syntaxError("Operator priority clash"); }
  1075.  
  1076. #define MAX_TERM_NESTING 200
  1077.  
  1078. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1079. This part of the parser actually constructs  the  term.   It  calls  the
  1080. tokeniser  to  find  the next token and assumes the tokeniser implements
  1081. one-token pushback efficiently.  It consists  of  two  mutual  recursive
  1082. functions:  complex_term()  which is involved with operator handling and
  1083. simple_term() which reads everything, except for operators.
  1084. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1085.  
  1086. typedef struct
  1087. { Atom    op;
  1088.   int    kind;
  1089.   int    left_pri;
  1090.   int    right_pri;
  1091.   int    op_pri;
  1092. } op_entry;
  1093.  
  1094. static bool
  1095. isOp(atom, kind, e)
  1096. Atom atom;
  1097. int kind;
  1098. op_entry *e;
  1099. { Operator op = isCurrentOperator(atom, kind);
  1100.   int pri;
  1101.  
  1102.   if ( op == NULL )
  1103.     fail;
  1104.   e->op     = atom;
  1105.   e->kind   = kind;
  1106.   e->op_pri = pri = op->priority;
  1107.  
  1108.   switch(op->type)
  1109.   { case OP_FX:        e->left_pri = 0;     e->right_pri = pri-1; break;
  1110.     case OP_FY:        e->left_pri = 0;     e->right_pri = pri;   break;
  1111.     case OP_XF:        e->left_pri = pri-1; e->right_pri = 0;     break;
  1112.     case OP_YF:        e->left_pri = pri;   e->right_pri = 0;     break;
  1113.     case OP_XFX:    e->left_pri = pri-1; e->right_pri = pri-1; break;
  1114.     case OP_XFY:    e->left_pri = pri-1; e->right_pri = pri;   break;
  1115.     case OP_YFX:    e->left_pri = pri;   e->right_pri = pri-1; break;
  1116.     case OP_YFY:    e->left_pri = pri;   e->right_pri = pri;   break;
  1117.   }
  1118.  
  1119.   succeed;
  1120. }
  1121.  
  1122. #define PushOp() \
  1123.     side[side_n++] = in_op; \
  1124.     if ( side_n >= MAX_TERM_NESTING ) \
  1125.       syntaxError("Operator stack overflow"); \
  1126.     side_p = (side_n == 1 ? side : side_p+1);
  1127.     
  1128. #define Modify(pri) \
  1129.     if ( side_p != NULL && pri > side_p->right_pri ) \
  1130.     { if ( side_p->kind == OP_PREFIX && rmo == 0 ) \
  1131.       { DEBUG(1, printf("Prefix %s to atom\n", stringAtom(side_p->op))); \
  1132.         rmo++; \
  1133.         out[out_n++] = (word) side_p->op; \
  1134.         side_n--; \
  1135.         side_p = (side_n == 0 ? NULL : side_p-1); \
  1136.       } else if ( side_p->kind == OP_INFIX && out_n > 0 && rmo == 0 && \
  1137.               isOp(side_p->op, OP_POSTFIX, side_p) ) \
  1138.       { DEBUG(1, printf("Infix %s to postfix\n", stringAtom(side_p->op)));\
  1139.         rmo++; \
  1140.         out[out_n-1] = build_term(side_p->op, 1, &out[out_n-1]); \
  1141.         side_n--; \
  1142.         side_p = (side_n == 0 ? NULL : side_p-1); \
  1143.       } \
  1144.     }
  1145.  
  1146. #define Reduce(cond) \
  1147.     while( out_n > 0 && side_p != NULL && (cond) ) \
  1148.     { int arity = (side_p->kind == OP_INFIX ? 2 : 1); \
  1149.                               \
  1150.       DEBUG(1, printf("Reducing %s/%d\n", stringAtom(side_p->op), arity));\
  1151.       out[out_n-arity] = build_term(side_p->op, \
  1152.                     arity, \
  1153.                     &out[out_n - arity]); \
  1154.       out_n -= (arity-1); \
  1155.       side_n--; \
  1156.       side_p = (side_n == 0 ? NULL : side_p-1); \
  1157.     }
  1158.  
  1159.  
  1160.  
  1161.  
  1162. static bool
  1163. complex_term(stop, term)
  1164. char *stop;
  1165. Word term;
  1166. { word out[MAX_TERM_NESTING];
  1167.   op_entry in_op, side[MAX_TERM_NESTING];
  1168.   int out_n = 0, side_n = 0;
  1169.   int rmo = 0;                /* Rands more than operators */
  1170.   op_entry *side_p = NULL;
  1171.  
  1172.   for(;;)
  1173.   { bool isname;
  1174.     Token token;
  1175.     word in;
  1176.  
  1177.     if ( out_n != 0 || side_n != 0 )    /* Check for end of term */
  1178.     { if ( (token = get_token(rmo == 1)) == (Token) NULL )
  1179.     fail;
  1180.       unget_token();            /* only look-ahead! */
  1181.  
  1182.       switch(token->type)
  1183.       { case T_FULLSTOP:
  1184.       if ( stop == NULL )
  1185.         goto exit;
  1186.       break;
  1187.     case T_PUNCTUATION:
  1188.     { if ( stop != NULL && index(stop, token->value.character) )
  1189.         goto exit;
  1190.     }
  1191.       }
  1192.     }
  1193.  
  1194.                     /* Read `simple' term */
  1195.     TRY( simple_term(rmo == 1, &in, &isname) );
  1196.  
  1197.     if ( isname )            /* Check for operators */
  1198.     { if ( rmo == 1 && isOp((Atom) in, OP_INFIX, &in_op) )
  1199.       {    DEBUG(1, printf("Infix op: %s\n", stringAtom((Atom) in)));
  1200.  
  1201.     Modify(in_op.left_pri);
  1202.     Reduce(in_op.left_pri > side_p->right_pri);
  1203.     PushOp();
  1204.     rmo--;
  1205.  
  1206.     continue;
  1207.       }
  1208.       if ( rmo == 1 && isOp((Atom) in, OP_POSTFIX, &in_op) )
  1209.       { DEBUG(1, printf("Postfix op: %s\n", stringAtom((Atom) in)));
  1210.  
  1211.     Modify(in_op.left_pri);
  1212.     Reduce(in_op.left_pri > side_p->right_pri);
  1213.     PushOp();    
  1214.     
  1215.     continue;
  1216.       }
  1217.       if ( rmo == 0 && isOp((Atom) in, OP_PREFIX, &in_op) )
  1218.       { DEBUG(1, printf("Prefix op: %s\n", stringAtom((Atom) in)));
  1219.     
  1220.     Reduce(in_op.left_pri > side_p->right_pri);
  1221.     PushOp();
  1222.  
  1223.     continue;
  1224.       }
  1225.     }
  1226.  
  1227.     if ( rmo != 0 )
  1228.       syntaxError("Operator expected");
  1229.     rmo++;
  1230.     out[out_n++] = in;
  1231.     if    ( out_n >= MAX_TERM_NESTING )
  1232.       syntaxError("Operant stack overflow");
  1233.   }
  1234.  
  1235. exit:
  1236.   Modify(1000000);
  1237.   Reduce(TRUE);
  1238.  
  1239.   if ( out_n == 1 && side_n == 0 )    /* simple term */
  1240.   { *term = out[0];
  1241.     succeed;
  1242.   }
  1243.  
  1244.   if ( out_n == 0 && side_n == 1 )    /* single operator */
  1245.   { *term = (word) side[0].op;
  1246.     succeed;
  1247.   }
  1248.  
  1249.   syntaxError("Unbalanced operators");
  1250. }
  1251.  
  1252.  
  1253. static bool
  1254. simple_term(must_be_op, term, name)
  1255. bool must_be_op;
  1256. Word term;
  1257. bool *name;
  1258. { Token token;
  1259.  
  1260.   DEBUG(9, printf("simple_term(): Stack at %ld\n", &term));
  1261.  
  1262.   *name = FALSE;
  1263.  
  1264.   if ( (token = get_token(must_be_op)) == NULL )
  1265.     fail;
  1266.  
  1267.   switch(token->type)
  1268.   { case T_FULLSTOP:
  1269.       syntaxError("Unexpected end of clause");
  1270.     case T_VOID:
  1271.       { *term = token->value.prolog;
  1272.     succeed;
  1273.       }
  1274.     case T_VARIABLE:
  1275.       { *term = makeRef(token->value.variable);
  1276.     succeed;
  1277.       }
  1278.     case T_NAME:
  1279.       *name = TRUE;
  1280.     case T_REAL:
  1281.     case T_INTEGER:
  1282.     case T_STRING:
  1283.       {    *term = token->value.prolog;
  1284.     succeed;
  1285.       }
  1286.     case T_FUNCTOR:
  1287.       { if ( must_be_op )
  1288.     { *name = TRUE;
  1289.       *term = token->value.prolog;
  1290.     } else
  1291.     { word argv[MAXARITY+1];
  1292.       int argc;
  1293.       Word argp;
  1294.       word functor;
  1295.  
  1296.       functor = token->value.prolog;
  1297.       argc = 0, argp = argv;
  1298.       get_token(must_be_op);    /* skip '(' */
  1299.  
  1300.       do
  1301.       { TRY( complex_term(",)", argp++) );
  1302.         if (++argc > MAXARITY)
  1303.           syntaxError("Arity too high");
  1304.         token = get_token(must_be_op); /* `,' or `)' */
  1305.       } while(token->value.character == ',');
  1306.  
  1307.       *term = build_term((Atom)functor, argc, argv);
  1308.     }
  1309.     succeed;
  1310.       }
  1311.     case T_PUNCTUATION:
  1312.       { switch(token->value.character)
  1313.     { case '(':
  1314.         { word arg;
  1315.  
  1316.           TRY( complex_term(")", &arg) );
  1317.           token = get_token(must_be_op);    /* skip ')' */
  1318.           *term = arg;
  1319.  
  1320.           succeed;
  1321.         }
  1322.       case '{':
  1323.         { word arg;
  1324.  
  1325.           TRY( complex_term("}", &arg) );
  1326.           token = get_token(must_be_op);
  1327.           *term = build_term(ATOM_curl, 1, &arg);
  1328.  
  1329.           succeed;
  1330.         }
  1331.       case '[':
  1332.         { Word tail = term;
  1333.           word arg[2];
  1334.           Atom dot = ATOM_dot;
  1335.  
  1336.           for(;;)
  1337.           { TRY( complex_term(",|]", &arg[0]) );
  1338.  
  1339.         arg[1] = (word) NULL;
  1340.         *tail = build_term(dot, 2, arg);
  1341.         tail = argTermP(*tail, 1);
  1342.         token = get_token(must_be_op);
  1343.  
  1344.         switch(token->value.character)
  1345.         { case ']':
  1346.             { *tail = (word) ATOM_nil;
  1347.               succeed;
  1348.             }
  1349.           case '|':
  1350.             { TRY( complex_term("]", &arg[0]) );
  1351.  
  1352.               if (isRef(arg[0]))
  1353.               { Variable var;
  1354. #if O_NO_LEFT_CAST
  1355.             Word w;
  1356.             deRef2(&arg[0], w);
  1357.             var = (Variable) w;
  1358. #else
  1359.             deRef2(&arg[0], (Word)var);
  1360. #endif
  1361.             if (var->address == (Word) NULL)
  1362.               var->address = tail;
  1363.             else
  1364.               *tail = makeRef(var->address);
  1365.               } else
  1366.             *tail = arg[0];
  1367.  
  1368.               token = get_token(must_be_op);
  1369.               succeed;
  1370.             }
  1371.           case ',':
  1372.               continue;
  1373.         }
  1374.           }
  1375.         }
  1376.       case '|':
  1377.       case ',':
  1378.       case ')':
  1379.       case '}':
  1380.       case ']':
  1381.       default:
  1382.         { char tmp[2];
  1383.  
  1384.           *name = TRUE; 
  1385.           tmp[0] = token->value.character;
  1386.           tmp[1] = EOS;
  1387.           *term = (word) lookupAtom(tmp);
  1388.  
  1389.           succeed;
  1390.         }
  1391.     }
  1392.       } /* case T_PUNCTUATION */
  1393.     default:;
  1394.       sysError("read/1: Illegal token type (%d)", token->type);
  1395.       /*NOTREACHED*/
  1396.       fail;
  1397.   }
  1398. }
  1399.  
  1400. static bool
  1401. read_term(term, variables, check)
  1402. Word term, variables;
  1403. bool check;
  1404. { Token token;
  1405.   word result;
  1406.  
  1407.   if ((base = raw_read()) == (char *) NULL)
  1408.     fail;
  1409.  
  1410.   initVarTable();
  1411.   here = base;
  1412.   unget = FALSE;
  1413.  
  1414.   TRY( complex_term(NULL, &result) );
  1415.  
  1416.   if ((token = get_token(FALSE)) == (Token) NULL)
  1417.     fail;
  1418.   if (token->type != T_FULLSTOP)
  1419.     syntaxError("End of clause expected");
  1420.  
  1421.   if ( isRef(result) )    /* term is a single variable! */
  1422.   { Variable var;
  1423. #if O_NO_LEFT_CAST
  1424.     Word w;
  1425.     deRef2(&result, w);
  1426.     var = (Variable) w;
  1427. #else
  1428.     deRef2(&result, (Word)var);
  1429. #endif
  1430.     if ( var->times != 1 || var->address != (Word)NULL )
  1431.       sysError("Error while reading a single variable??");
  1432.     var->address = allocGlobal(sizeof(word));
  1433.     setVar(*var->address);
  1434.     result = makeRef(var->address);
  1435.   }
  1436.  
  1437.   TRY(pl_unify(term, &result) );
  1438.   if (variables != (Word) NULL)
  1439.     TRY(bind_variables(variables) );
  1440.   if (check)
  1441.     check_singletons();
  1442.  
  1443.   succeed;
  1444. }
  1445.  
  1446.         /********************************
  1447.         *       PROLOG CONNECTION       *
  1448.         *********************************/
  1449.  
  1450. word
  1451. pl_raw_read(term)
  1452. Word term;
  1453. { char *s;
  1454.   register char *top;
  1455.  
  1456.   s = raw_read();
  1457.  
  1458.   if ( s == (char *) NULL )
  1459.     fail;
  1460.   
  1461.   for(top = s+strlen(s)-1; isBlank(*top); top--);
  1462.   if (*top == '.')
  1463.     *top = EOS;
  1464.   for(; isBlank(*s); s++);
  1465.  
  1466.   return unifyAtomic(term, lookupAtom(s) );
  1467. }
  1468.  
  1469. word
  1470. pl_read_variables(term, variables)
  1471. Word term, variables;
  1472. { return read_term(term, variables, FALSE);
  1473. }
  1474.  
  1475. word
  1476. pl_read_variables3(stream, term, variables)
  1477. Word stream, term, variables;
  1478. { streamInput(stream, pl_read_variables(term, variables));
  1479. }
  1480.  
  1481. word
  1482. pl_read(term)
  1483. Word term;
  1484. { return read_term(term, (Word)NULL, FALSE);
  1485. }
  1486.  
  1487. word
  1488. pl_read2(stream, term)
  1489. Word stream, term;
  1490. { streamInput(stream, pl_read(term));
  1491. }
  1492.  
  1493. word
  1494. pl_read_clause(term)
  1495. Word term;
  1496. { return read_term(term, (Word) NULL,
  1497.            debugstatus.styleCheck & SINGLETON_CHECK ? TRUE : FALSE);
  1498. }
  1499.  
  1500. word
  1501. pl_read_clause2(stream, term)
  1502. Word stream, term;
  1503. { streamInput(stream, pl_read_clause(term));
  1504. }
  1505.  
  1506.  
  1507.