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