{Portable Prolog Parsed Input Output Control}

{Comment Flags: VAX APM EMAS I77}
{All systems but EMAS required I77}

{-IO-}

{Major input and output procedures (Prolog read/write etc)}

{                                                Lawrence}
{                                                Updated: 10 February 82}
{                                                Richard}
{                                                Again:   February 84}


!VAX! %include "Prolog_Interpreter:GDec.Inc"
!EMAS!%include "ECSC56.GDec#Inc"
{APM} %include "IPlog:GDec.Inc"

!EMAS!%external %routine %spec Prompt (%string (31) P)

%external %INTEGER %spec HASHA,
                         LSP,
                         LC,
                         ATOM0,
                         GLB0,
                         SKEL0,
                         ATOMNIL,
                         LISTFUNC,
                         COMMAFUNC,
                         NVARS,
                         VARCHAIN,
                         V1,
                         ASSERTFUNC,
                         X,
                         LSZ,
                         CRIT,
                         LIST10,
                         LCL0,
                         ATOMFP,
                         QUOTEIA,
                         ASSERTATOM,
                         VARFP,
                         Options,
                         Atom Limit,
                         Output

%external %routine %spec No Space (%string (31) In)
%external %routine %spec Check V1 (%integer P)

{APM} %external %string (255) %spec PL Prompt
!VAX! %external %string (127) %spec PL PROMPT
!EMAS!%external %string (31) %spec PL Prompt

%constant %integer Uppercase Letter  = 1,
                   Underline         = 2,
                   Lowercase Letter  = 3,
                   Digit             = 4,
                   Single Quote      = 5,
                   Double Quote      = 6,
                   Symbol Character  = 7,
                   Solo Character    = 8,
                   Punctuation       = 9,
                   Control Character = 10,
                   Quoted Character  = 11

%constant %integer %array CH TYP (0:127) =  %C
   10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,
   10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,
   10, 8, 6, 7, 3, 8, 7, 5, 9, 9, 7, 7 ,9, 7, 7, 7,
   4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 7, 8, 7, 7, 7, 7,
   7, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
   1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 9, 7, 9, 7, 2,
   11, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
   3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 9, 9, 9, 7,10

%EXTERNAL %ROUTINE %SPEC SIGNAL PROLOG EVENT(%INTEGER N)
%EXTERNAL %INTEGER %function %SPEC GETSP(%INTEGER L)

%const %integer CVMAX = 10

{-F ENTRY-}

{Enters Atom as a Functor with ARITY arguments}

%external %integer %function F ENTRY (%integer ATOM, ARITY)
   %INTEGER FE, NE, I

   FE = ATOM
   %WHILE BYTE INTEGER (FE + ARITY OF FE) # ARITY %CYCLE
      %IF INTEGER (FE + NXT OF FE) = 0 %START
         CRIT = 1                                     {Must not be interrupted}
         NE = GET SP (SZ OF FE + ARITY*4)             {Claim Heap Spaces}
         INTEGER (NE)                    = ATOM
         INTEGER (NE + INF OF FE)        = 0
         BYTE INTEGER (NE + ARITY OF FE) = ARITY
         INTEGER (NE + DEFS OF FE)       = 0
         INTEGER (NE + DB OF FE)         = 0
         INTEGER (NE + NXT OF FE)        = 0          {This_Next == Nil}
         INTEGER (FE + NXT OF FE)        = NE         {Last_Next == This}
         %for I = 0, 1, ARITY - 1 %cycle
            INTEGER (NE + GT OF FE + I*4 + 4) = GLB0 + I*4
         %REPEAT
         INTEGER (NE + GT OF FE)         = NE
         SIGNAL PROLOG EVENT(1) %IF CRIT=2
         CRIT = 0                                   {Re-enable interrupts}
         %RESULT = NE
      %FINISH
      FE = INTEGER (FE + NXT OF FE)                 {Next functor entry}
   %REPEAT
   %RESULT = FE
%END {F Entry}

{-APPLY-}

{Applys N arguments starting at ARGS to the atom AT}

%external %integer %function Apply (%INTEGER AT, N, ARGS)
   %INTEGER SK, R

   SK = FENTRY (AT, N) + GT OF FE            {Address of Skeleton}
   R = V1
   %WHILE N>0 %CYCLE
      Check V1 (4)
      INTEGER (V1) = INTEGER (ARGS)
      ARGS = ARGS + 4
      V1 = V1 + 4
      N = N - 1
   %REPEAT
   Check V1 (8)
   INTEGER (V1) = SK
   INTEGER (V1 + 4) = R
   R = V1
   V1 = V1 + 8
   %RESULT = R
%END {Apply}

{-MAKE LIST-}

%external %integer %function Make List (%INTEGER N,ELMS)
   %INTEGER P,F,I

   P = ELMS + 4*(N - 1)
   %WHILE N>10 %CYCLE
      F=V1
      %for I=1,1,10 %cycle
         Check V1 (4)
         INTEGER (V1) = INTEGER (P)
         P=P-4
         V1=V1+4
      %REPEAT
      P=P+4
      INTEGER(P)=V1
      Check V1 (8)
      INTEGER(V1)=LIST10
      INTEGER(V1+4)=F
      N=N-9
      V1=V1+8
   %REPEAT
   F=V1
   Check V1 (N*4 + 8)
   %for I=1,1,N %cycle
      INTEGER(V1)=INTEGER(P)
      P=P-4
      V1 = V1+4
   %REPEAT
   INTEGER(V1) = LIST10 + (10 - N)*12
   INTEGER(V1+4)=F
   F=V1
   V1=V1+8
   %RESULT=F
%END {Make List}

{-DE REF-}

{Dereference a %name %name ... until it become a real object}

%external %integer %function De Ref (%INTEGER VP)
   VP=INTEGER(VP) %WHILE INTEGER(VP)>=GLB0
   %RESULT=VP
%END {De Ref}

{-V VALUE-}

%external %integer %function V VALUE (%integer VP, %INTEGERNAME TF)
   VP = DEREF(VP)
   %RESULT = VP %IF INTEGER (VP) = 0
   TF = INTEGER (VP + 4) %IF INTEGER(VP)>=SKEL0
   %RESULT = INTEGER (VP)
%END {V Value}

{-ARG-}

%external %integer %function ARG (%INTEGER ARGP,TF)
   %INTEGER A, AA

   A = INTEGER (ARGP)
   %IF A >= GLB0 %START
         %if A >= LCL0 %start
            AA = X + (A - LCL0)
         %else
            AA = TF + (A - GLB0)
      %finish
      ARGP = DEREF (AA)
      A = INTEGER (ARGP)
      %RESULT = ARGP %IF A = 0 %OR %c
                         A >= SKEL0
   %FINISH
   %RESULT = A
%END {Arg}

{-ARG V-}

%external %integer %function Arg V (%INTEGER ARGP,TF,%INTEGERNAME AF)
   %INTEGER A

   A = ARG (ARGP, TF)

   %IF A>=GLB0 %START
      %RESULT=A %IF INTEGER(A)=0
      AF=INTEGER(A+4)
      %RESULT=INTEGER(A)
   %FINISH
   AF=TF
   %RESULT=A
%end {Arg V}

{IS OP}

%integer %function Is Op (%INTEGER ATOM,
                                   OPTYPE,
                          %INTEGER %NAME P,
                                         LP,
                                         RP)
   %INTEGER OE

!EMAS!   OE =  INTEGER (ATOM + INF OF AE)&16_0000FFFF
!VAX!    OE = (Integer (Atom + Inf OF AE)&16_FFFF0000)>>16
{APM}    OE =  INTEGER (ATOM + INF OF AE)&16_0000FFFF

   %RESULT = 0 %IF OE = 0
   OE = INTEGER (ATOM0 + OE + OPTYPE)
   %RESULT = 0 %IF OE < 0
   P = OE&MSK PRTY
   %IF OE&DLPR FLG = 0 %THEN LP=P %c
                       %ELSE LP=P-1
   %IF OE&DRPR FLG=0 %THEN RP=P %c
                     %ELSE RP=P-1
   %RESULT=1
%END

{-OP-}

{Processes Op declarations}

%external %integer %function Op (%integer PR,OPTYPE,SPEC)
   %integer C,I,SPF,AT,OE,TYPE
   
   %constant %string (3) %array OPTYPES(1:7)= %c
      "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"
   %constant %integer %array OPTYP(1:7)=4,4,4,8,8,0,0

{I77}  %string (*) %name OPS
!EMAS! %string %name Ops

   %RESULT = 0 %IF PR >= 0

   PR = PR&(\INT0)

   %RESULT = 0 %UNLESS PR <= 1200

   %RESULT = 0 %UNLESS 0 <= OP TYPE < SKEL0

   OPS == STRING (OP TYPE + ST OF AE)
   C=-1
   %for I = 1, 1, 7 %cycle
      C = I %AND %EXIT %IF OPS = OP TYPES(I)
   %repeat
   %RESULT = 0 %IF C = -1

   TYPE = OP TYP (C)
   C = 1<<C
   PR = PR!DLPRFLG %IF C&16_16#0
   PR = PR!DRPRFLG %IF C&16_4A#0
   SPEC = VVALUE (SPEC, SPF)
   
AGAIN: 
   %RESULT = 0 %UNLESS ATOM0 <= SPEC < GLB0
   %IF SPEC >= SKEL0 %START
      %RESULT = 0 %UNLESS INTEGER (SPEC) = LIST FUNC
      AT = ARG (SPEC + 4, SPF)
      %RESULT = 0 %UNLESS ATOM0 <= AT < SKEL0
      SPEC = ARGV (SPEC + 8, SPF, SPF)
   %ELSE
      AT=SPEC
      SPEC=ATOMNIL
   %FINISH

!EMAS! OE =  INTEGER (AT + INF OF AE)&16_0000FFFF
!VAX!  OE = (Integer (At + Inf Of AE)&16_FFFF0000)>>16
{APM}  OE =  INTEGER (AT + INF OF AE)&16_0000FFFF

   %IF OE = 0 %START
      OE = ATOM FP
      ATOM FP = ATOM FP + SZ OF OE
      INTEGER (OE + I) = -1 %for I = 0, 4, 8
      OE = OE - ATOM0
!EMAS!INTEGER (AT + INF OF AE) = INTEGER (AT + INF OF AE)!OE
!VAX! Integer (At + Inf Of AE) = Integer (At + Inf Of AE)!(OE<<16)
{APM} INTEGER (AT + INF OF AE) = INTEGER (AT + INF OF AE)!OE
   %FINISH
   INTEGER (ATOM0 + OE + TYPE) = PR
   ->AGAIN %UNLESS SPEC = ATOM NIL
   %RESULT=1
%END {Op}

{LEGAL ATOM}

!EMAS!%integer %function Legal Atom (%string %name S)
{I77} %integer %function Legal Atom (%string (*) %name S)

   %INTEGER L,I,C
   
   L=LENGTH(S)
   C=CHTYP(CHARNO(S,1))
   %IF C=3 %START
      %for I=1,1,L %cycle
         %RESULT=0 %UNLESS CHTYP(CHARNO(S,I))<=4 
      %REPEAT
      %RESULT=1
   %FINISH
   %RESULT=1 %IF C=8
   %RESULT=0 %UNLESS C=7
   %RESULT=0 %IF S="/*" %OR S="."
   %for I=1,1,L %cycle
      %RESULT=0 %UNLESS CHTYP(CHARNO(S,I))=7
   %REPEAT
   %RESULT=1
%END

{PROCESS ATOM}

%external %string (255) %function Process Atom (%integer At)
!EMAS! %STRING %NAME S
{I77}  %string (*) %name S
   %INTEGER I, CH
   %string (255) Res

   S == STRING (AT + ST OF AE)
   %IF QUOTE IA = 0 %OR %c
       Legal Atom (S) # 0 %START
      %result = S
   %FINISH
   Res = "'"
   %for I = 1, 1, Length (S) %cycle
      CH = Char No (S, I)
      Res = Res . "'" %if CH=''''
      Res = Res . To String (Ch)
   %REPEAT
   %result = Res . "'"
%end {Process Atom}

%external %string (255) %function %spec I To S (%integer I, F)

{B Write}

%external %routine B Write (%integer I, F)
   Print String (I To S (I, F))
%end {B Write}

{P ATOM}

%ROUTINE P ATOM(%INTEGER AT)
   Print String (Process Atom (AT))
%END {P Atom}

{-P WRITE-}

{Write a Prolog term}

%external %routine P Write (%integer T, G, P)
   ! WRITE TERM T IN CONTEXT OF PRIORITY P
   ! WITH GLOBAL FRAME G
   %INTEGER I,
            A,
            F,
            M,
            MR,
            ML, 
            Anon

   %IF T<0 %START
      {Must be a number}
      I=T
      I=I&16_1FFFFFFF %IF T&16_20000000=0
      B Write (I, 0)
      %RETURN
   %FINISH

   %IF T < SKEL0 %START
      {Must be an atom if below the Skeleton area}
      PATOM (T)
      %RETURN
   %FINISH

   %IF INTEGER (T) = 0 %START
      {Anonymous variable}
      Anon = 'A' + (T - GLB0)>>2
      %if 'A' <= Anon <= 'Z' %start
         Print Symbol (Anon)
      %else
         Print Symbol('_')
         B Write ((T - GLB0)>>2, 0)
      %finish
      %RETURN
   %FINISH

   %IF T>=GLB0 %START
      G=INTEGER(T+4)                         {This is the start of the args}
      T=INTEGER(T)                           {Pointer to FE}
   %FINISH

   %IF INTEGER (T)=LISTFUNC %START
      Print Symbol('[')
   L: 
      P Write(ARGV(T+4,G,A),A,999)
      T=ARGV(T+8,G,G)
      Print String(", ") %AND ->L %IF T>=SKEL0 %AND INTEGER(T)=LISTFUNC
      Print Symbol('|') %AND P WRITE(T,G,999) %UNLESS T=ATOMNIL
      Print Symbol(']')
      %RETURN
   %FINISH

   %IF INTEGER (T) = ASSERT FUNC %START
      Print Symbol('{')
      P WRITE(ARGV(T+4,G,G),G,1200)
      Print Symbol('}')
      %RETURN
   %FINISH

   F = INTEGER (T)
   I = BYTE INTEGER (F + ARITY OF FE)     {Arity of the functor}
   A = INTEGER(F)                         {The atom for this functor}

   %IF I=1 %START
      {Unary Operators}
      %IF ISOP(A,PRFXOFOE,M,ML,MR)#0 %START
         Print Symbol('(') %IF M>P
         PATOM(A)
         Print Symbol (' ') %IF 'A' <= BYTE INTEGER (A + ST OF AE + 1) <='z' 
         P WRITE(ARGV(T+4,G,F),F,MR)
         Print Symbol(')') %IF M>P
         %RETURN
      %FINISH
      %IF ISOP(A, PSFX OF OE,M,ML,MR)#0 %START
         Print Symbol('(') %IF M>P
         P WRITE(ARGV(T+4,G,F),F,ML)
         Print Symbol(' ') %IF 'A' <= BYTE INTEGER (A + ST OF AE + 1) <= 'z'
         PATOM(A)
         Print Symbol(')') %IF M>P
         %RETURN
      %FINISH  
   %FINISH

   %IF I=2 %AND %c
       ISOP(A,INFXOFOE,M,ML,MR)#0 %START
      Print Symbol('(') %IF M>P 
      P WRITE(ARGV(T+4,G,F),F,ML)             {Fisrt Arguement}
      Print Symbol(' ') %IF 'A' <= BYTE INTEGER (A + ST OF AE + 1) <= 'z' 
      PATOM(A)
      Print Symbol(' ') %IF 'A' <= BYTE INTEGER (A + ST OF AE + 1) <='z'
      P WRITE(ARGV(T+8,G,F),F,MR)             {Second Arguement}
      Print Symbol(')') %IF M>P
      %RETURN
   %FINISH

   PATOM(A)
   Print Symbol('(')
   %for I=I,-1,1 %cycle
      T=T+4                                  {Move through arguements}
      P WRITE (ARGV (T, G, F), F, 999)
      Print String (", ") %IF I#1
   %REPEAT
   Print Symbol(')')
%END {P Write}

{-LOOK UP-} 

{Intern a string to get a prolog atom}

!EMAS! %external %integer %function Look Up (%string %name ID)
{I77}  %external %integer %function Look Up (%string (*) %name ID)
   %INTEGER PTR,
            H, 
            Size

   H=LENGTH(ID)            {Compute hash}
   %for PTR = 1, 1, H %cycle
      H = H + CHAR NO (ID, PTR)
   %REPEAT

   PTR = HASH A + (H&127)<<2
   %WHILE INTEGER (PTR) # 0 %CYCLE
      PTR = INTEGER(PTR)
      %RESULT = PTR %IF STRING (PTR + ST OF AE) = ID
      PTR = PTR + NXT OF AE
   %REPEAT

   CRIT = 1                                       {Critical Section}
   INTEGER (PTR) = ATOM FP
   PTR = ATOM FP
   Size = (SZ OF AE + LENGTH (ID) + 4)&16_FC  
   No Space ("ATOM") %if Atom FP + Size > Atom Limit
   ATOM FP = ATOM FP + Size
                       {Size of entry for symbol}
   INTEGER (PTR) = PTR
   INTEGER (PTR + INF OF AE)  = 0
   INTEGER (PTR + DEFS OF AE) = 0
   INTEGER (PTR + DB OF AE)   = 0
   INTEGER (PTR + FC OF AE)   = 0
   INTEGER (PTR + NXT OF AE)  = 0
   STRING (PTR + ST OF AE)    = ID
   SIGNAL PROLOG EVENT(1) %IF CRIT=2
   CRIT = 0

   %RESULT = PTR
%END {Look Up}

{-GETC-}

{Get input character, with checking}

%external %routine Get C (%byte %name CH)
   
   %ON 9 %START
      SIGNAL PROLOG EVENT(3)
   %FINISH
   
   Read Symbol (CH)
   CH = CH&16_7F                     { Remove any parity bit}
%END {Get C}

{-READ TERM-}

{Read a Prolog term}
{(This function has lots of internal functions)}

%external %integer %function Read Term
%integer XXX
   %constant %integer NAME     = 1,
                      NUMBER   = 2,
                      VAR      = 3,
                      String T = 4,
                      Punct Ch = 5,
                      FULLSTOP = 6

   %INTEGER E,LPMAX,LP,SLSP
   %BYTE RETOKEN,TOKENTYPE,CH,RECHAR,CHTYPE,ERRFLG

!EMAS! %byte %array %name LINE
!VAX!  %byte %array %name LINE
{APM}  %byte %array %name Line (0:1000)

   %record %format Array Frig fm (%byte %array Line (0:1000))
   %record (Array Frig fm) %name AF

   %STRING(255) NAM
   %INTEGER TOKENINFO
   
   {NEXT CH}

   {Next character from input buffer (in READ)}
   {Allows for single char lookahead}
   
   %integer %function NEXT CH
      RECHAR = 0 %AND %RESULT = CH TYPE %IF RECHAR # 0 
      LP = LP + 1
      CH = LINE (LP)
      CH TYPE = CH TYP (CH)
      LP = LP MAX - 2 %IF LP >= LP MAX 
      %RESULT = CHTYPE
   %END {Next Ch}
   
   {LOOK UP VAR}
   
   ! Look up variable name in variable table (in READ)
   
   !EMAS!%integer %function Look Up Var (%string %name ID);
   {I77} %integer %function Look Up Var (%string (*) %name ID);
      %INTEGER P
   
      %IF ID="_" %START
         Check V1 (8)
         P = V1
         INTEGER (V1)=0
         V1 = V1 + 8
         %RESULT = P
      %FINISH

      P = ADDR (VAR CHAIN)
   
      %WHILE INTEGER (P) # 0 %CYCLE
         P = INTEGER (P)
         %RESULT = INTEGER (P + 4) %IF STRING (P + 8) = ID
      %REPEAT
      NVARS = NVARS + 1
      INTEGER (P) = VAR FP
      P = VARFP
      VARFP = VAR FP + (LENGTH (ID) + 4)&16_FC + 8
      STRING (P + 8) = ID
      INTEGER (P) = 0
      INTEGER (P + 4) = V1
      Check V1 (4)
      P = V1
      INTEGER (V1) = 0
      V1 = V1 + 4
      %RESULT = P
   %END {Look Up Var}
   
   {SYNTAX ERROR}
   
   {Report a syntax error and wind things up (in READ)}
   
   %routine Syntax Error (%integer Code)
      %INTEGER I,
               Start,
               Stop,
               Start Lop = 0
      
      %constant %integer Message Length = 20
      %constant %string (30) %array Messages (1:11) = %c
         {1}  "Too Long",
         {2}  "Expecting ')'",
         {3}  "Syntax Error (3)",
         {4}  "Expecting ')'",
         {5}  "Expecting ']'",
         {6}  "Expecting '}'",
         {7}  "Unexpected",
         {8}  "Expecting Punctuation",
         {9}  "Miss Placed",
         {10} "Expecting final '.'",
         {11} "Missing close quote"

{APM} %constant %integer Lop Size = 1
!VAX! %constant %integer Lop Size = 1
!EMAS!%constant %integer Lop Size = 3

      {DOTS}

      %routine Dots
         Print String ("...")
      %end {Dots}

      RECHAR = 0
      RETOKEN = 0
      LP = LP MAX - 2 %AND %RETURN %IF ERR FLG # 0 
      %if LP > 80 - Message Length %start
         Start Lop = 1
         Start = LP - 35 + Lop Size
         Stop = LP Max
         Stop = Start + 80 - Lop Size %if LP Max > Start + 80 
      %else
         Start = 0
         Stop = LP Max
         Stop = 79 - Lop Size %if LP Max > 79
      %finish
      Select Output (0)
      New Line
      Dots %if Start Lop # 0 
      %for I = Start, 1, Stop %cycle
         Print Symbol (LINE(I))
      %REPEAT
      Dots %and New Line %if Stop < LP Max
      Spaces (Lop Size) %if Start Lop # 0
      Spaces (LP - Start)
      Print String ("| ")
      Print String (Messages (Code))
      New Line
      LP = LP MAX - 2
      ERR FLG = 1
      Select Output (Output)
   %END {Syntax Error}
   
   {TOKEN}
   
   {Tokenises input}
   
   %integer %function Token
      %SWITCH Case Ch(1:11);
      %INTEGER V,L
   
      RETOKEN=0 %AND %RESULT=TOKENTYPE %IF RETOKEN#0
   START: 
   Case Ch(Control Character): 
      -> CASE CH (NEXT CH)
   
   Case Ch (Uppercase Letter):
      V=LC
      ->ID

   Case Ch (Underline):
      V=1
      ->ID

   Case Ch (Lowercase Letter):
      V=0
   ID:         {common to both variables and atoms}
      RECHAR=1
      Nam = ""
      %WHILE NEXT CH <= 4 %CYCLE
         CH=CH+32 %IF LC=0 %AND %c
                      V=0 %AND %c
                      CH>='A' %AND %c
                      CH<='Z'
         NAM = NAM . To String (Ch)
      %REPEAT
      
      RECHAR=1
      %IF V # 0 %START
         TOKENTYPE  = VAR
         TOKEN INFO = LOOK UP VAR (NAM)
         %RESULT    = VAR
      %else
         TOKEN TYPE = NAME
         TOKEN INFO = LOOK UP (NAM)
         %RESULT    = NAME
      %FINISH
      
   Case Ch (Digit):
      TOKENINFO=CH-'0'
      %IF LINE(LP+1)='''' %START
         LP=LP+1
         V=TOKEN INFO
         TOKEN INFO=0
      %ELSE 
         V=10
      %finish
   
      TOKEN INFO = TOKEN INFO * V + CH - '0' %WHILE NEXT CH = Digit
      RECHAR=1
      TOKEN TYPE=NUMBER 
      %RESULT=NUMBER
   
   Case Ch (Quoted Character):   
      V = Next Ch
      Token Info = Ch
      V = Next Ch
      Syntax Error (11) %unless V = Quoted Character
      Token Type = Number
      %result = Number

   Case Ch (Single Quote):
      V = Single Quote 
      ->QUOTED
   
   Case Ch (Double Quote):
      V = Double Quote
   QUOTED: 
      L=0
      Nam = ""
!EMAS! %WHILE NEXT CH # V %OR %c
!EMAS!        NEXT CH = V %CYCLE

  %WHILE NEXT CH # V %OR %c
         NEXT CH = V %CYCLE

!{-APM Compiler Bug work round-}
!{APM}      %cycle
!{APM}         %if Next Ch # V %start
!{APM}         %else 
!{APM}         Label:
!{APM}            %if Next Ch = V %start
!{APM}            %else
!{APM}               %exit
!{APM}            %finish
!{APM}         %finish
!{-END-}

         L = L + 1
         Nam = Nam . To String (Ch)
         Syntax Error (1) %IF L>=228
      %REPEAT
      RECHAR=1
      
      %IF V=Single Quote %START
         TOKENTYPE=NAME
         TOKENINFO=LOOKUP(NAM)
         %RESULT=NAME
      %FINISH

      TOKENTYPE=String T
      TOKENINFO=ADDR(NAM)
      %RESULT=String T
   
   Case Ch (Symbol Character):
      %IF CH='/' %AND %c
          LINE(LP+1)='*' %START
         CH TYPE = NEXT CH %UNTIL CH = '*' %AND LINE (LP+1)='/'
         LP=LP+1
         ->START
      %FINISH
      L=1
      Nam = To String (Ch)
      %IF CH = '.' %START  {full stop is a special case}
         %IF NEXT CH = Control Character %start 
            TOKENTYPE=FULLSTOP  
            LP=LP-1
            %RESULT=FULLSTOP 
         %finish
         RECHAR=1
      %FINISH
      %WHILE NEXT CH = Symbol Character %CYCLE
         L = L + 1
         Nam = Nam . To String (Ch)
      %REPEAT
      RECHAR=1
      TOKENTYPE=NAME
      TOKENINFO=LOOKUP(NAM);
      %RESULT=NAME
   
   Case Ch (Solo Character):
      NAM = TO STRING(CH)
      TOKEN TYPE = NAME
      TOKEN INFO = LOOK UP (NAM)
      %RESULT=NAME
   
   Case Ch (Punctuation):
      %IF CH = '[' %AND %c
          LINE (LP + 1) = ']' %START
         TOKEN TYPE=NAME
         NAM = "[]"
         LP = LP + 1
         %IF ATOM NIL # 0 %THEN TOKEN INFO=ATOM NIL %c
                          %ELSE TOKEN INFO = LOOK UP (NAM)
         %RESULT = NAME
      %FINISH
      TOKEN TYPE = Punct Ch
      TOKEN INFO = CH
      %RESULT = Punct Ch
   %END {Token}
   
   %integer %function %spec Term (%integer P)
   
   {READ ARGS} 
   
   {Parse arguments of a term (in READ)}
   
   %integer %function Read Args (%integer ATOM)
      %INTEGER SAVE LSP,E,A
      
      SAVE LSP = LSP
      A=0
      CH TYPE = NEXT CH                        {Pass over (}
      %cycle
         INTEGER(LSP) = TERM(999)              {stores the terms away}
         LSP = LSP+4
         A = A + 1
      %repeat %until Token # Punct Ch %or Token Info # ','
      
      Syntax Error (2) %if Token Type # Punct Ch %OR %c
                           Token Info # ')'

      E = APPLY (ATOM, A, SAVE LSP)

      LSP = SAVE LSP
      %RESULT = E
   %END {Read Args}
   
   {STRING TO LIST}
   
   {String to list of chars (in READ)}
   
   %integer %function String To List
      %INTEGER SAVELSP,N,L
      
      SAVELSP=LSP
      N=LENGTH(NAM)
      %for L=1,1,N %cycle
         INTEGER(LSP)=CHARNO(NAM,L)+INT0
         LSP=LSP+4
      %REPEAT
      INTEGER(LSP)=ATOMNIL
      LSP=SAVELSP
      %RESULT=MAKELIST(N+1,SAVELSP)
   %END {String To List}
   
   
   {READLIST} 
   
   {Parse a Prolog list (in READ)}
   
   %integer %function Read List
      %INTEGER SAVELSP,E,N
   
      SAVE LSP = LSP
      N = 1
   AGAIN: 
      INTEGER(LSP) = TERM(999)
      LSP=LSP+4
      N=N+1
      %IF TOKEN = Punct Ch %AND %c
          TOKEN INFO = ',' %START
      Label:
         %IF TOKEN = NAME %AND NAM = ".." %START
            E=TERM(999)
         %ELSE
            RETOKEN=1
            ->AGAIN
         %FINISH
      %ELSE
         %IF TOKEN TYPE = Punct Ch %AND %c
             TOKEN INFO='|' %start
            E = TERM(999)
         %ELSE
            E = ATOM NIL
            RETOKEN = 1
         %FINISH
      %FINISH
      INTEGER (LSP) = E
      LSP = SAVE LSP
      %RESULT = MAKE LIST (N, SAVE LSP)
   %END {Read List}
   
   
   {TERM}
   
   {Parse token stream to get term (in READ)}
   
   %integer %function Term (%INTEGER N)
      %integer m,
               m1,
               ml,
               mr,
                s

   {Order Critical}

!VAX!  %integer  e2,
!VAX!            e

{APM}  %integer  e2,
{APM}            e

!EMAS! %integer E,
!EMAS!          E2

      %SWITCH CASE T (1:6)
   
      %result = 0 %IF ERRFLG#0
      M = 0  
      -> CASET(Token)
   
   CASET (Name):
      %IF Line (LP) = '(' %start
         E = READ ARGS (TOKEN INFO) 
         -> ON
      %finish
      %If Is Op (Token Info,
                 PRFX OF OE,
                 M,
                 ML,
                 MR) # 0 %start
         S = Token Info
         E = S
         %IF (Token = Punct Ch %and %c
              (Token Info # '(' %OR %c
               Token Info # '[')) %or %c
             Token Type = Full Stop %START
            Syntax Error (3) %IF M > N
            Retoken=1 
            -> ON
         %finish
         RETOKEN=1
         E = TERM (MR)
         E = APPLY (S, 1, ADDR (E))
         -> ON
      %FINISH
      E = TOKEN INFO
      -> ON
   
   CASET (Number):
      E = INT0!TOKEN INFO
      ->ON
   
   CASET (Var):
      E = TOKEN INFO
      ->ON
   
   CASET (String T):
      E = STRING TO LIST
      ->ON
   
   CASET (Punct Ch):
      %IF TOKEN INFO = '(' %START
         E = TERM (1200)
         Syntax Error (4) %IF TOKEN # Punct Ch %OR %c
                              TOKEN INFO # ')'
         -> ON
      %FINISH
      %IF TOKENINFO='[' %START
         E=READLIST
         Syntax Error (5) %IF TOKEN # Punct Ch %OR %c
                              TOKEN INFO # ']'
         ->ON
      %FINISH
      %IF TOKENINFO='{' %START
         E=TERM(1200)
         Syntax Error (6) %IF TOKEN # Punct Ch %OR %c
                              TOKEN INFO # '}'
         E = APPLY (ASSERT ATOM, 1, ADDR (E))
         -> ON
      %FINISH
   
   CASET (Full Stop):   {or other punctuation chars}
      Syntax error (7)
      %result = 0
   
   ON: 
      %result = 0 %if Err Flg # 0
      %IF TOKEN = NAME %START
         %IF IS OP (TOKEN INFO,
                    INFX OF OE,
                    M1,
                    ML,
                    MR) # 0 %START
            %IF M1 <= N %AND %c
                ML >= M %START
               S = TOKEN INFO
               E2 = TERM (MR)
               E = APPLY (S, 2, ADDR (E))
               M = M1
               -> ON
            %FINISH
         %FINISH

         %IF IS OP (TOKEN INFO,
                    PSFX OF OE,
                    M1,
                    ML,
                    MR) # 0 %START
            %IF M1 <= N %AND %c
                ML >= M %START
               S = TOKEN INFO
               E = APPLY (S, 1, ADDR (E))
               M = M1
               -> ON
            %FINISH
         %FINISH

         RETOKEN = 1
         %RESULT = E
      %FINISH
   
      %IF TOKEN TYPE = FULL STOP %start
         RETOKEN = 1 
         %RESULT = E
      %finish
   
      %IF TOKEN TYPE # Punct Ch %start
         SYNTAX ERROR (8)
         %RESULT=0
      %finish
   
      %IF TOKEN INFO = '(' %OR %c
          TOKEN INFO = '[' %START
         SYNTAX ERROR (9)
         %RESULT=0
      %FINISH
      
      %IF TOKENINFO=',' %AND %c
          N >= 1000 %AND %c
          M <= 999 %START
         E2=TERM(1000)
         E=APPLY(COMMAFUNC,2,ADDR(E));
         M=1000
         -> On %IF M<N
         %RESULT=E
      %FINISH

      RETOKEN=1
      %RESULT=E
   %END {Term}
   
   {-MAIN CODE OF READ TERM-}
   
   VARCHAIN=0
   ERRFLG=0
   NVARS=0
   AF == Record(LSP)       {Mapping array over input buffer}
   Line == AF_Line
   LPMAX=0
   SLSP=LSP
   
   GETC(CH)           {Force old prompt before (possibly) changing it}
   PROMPT (PL PROMPT)
   ->L1
   
Loop: 
   GETC(CH);
L1: 
   CHTYPE=CHTYP(CH)

   %IF CHTYPE=Control Character %START
      GETC(CH) %UNTIL CHTYP(CH)#Control Character
      LINE(LPMAX)=' '
      LPMAX=LPMAX+1
      ->L1
   %FINISH

   %IF CH='%' %START
      GETC(CH)
      %IF CH='(' %start 
         CH='{' 
         ->L1
      %finish
      %IF CH=')' %start 
         CH='}' 
         ->L1
      %finish
      GETC(CH) %WHILE CH#NL
      ->LOOP
   %FINISH

   LINE(LPMAX)=CH
   LPMAX=LPMAX+1

   {???}
   CHTYPE = Digit %IF CHTYPE = Single Quote %AND %c
                     LPMAX>1 %AND %c
                     CHTYP(LINE(LPMAX-2)) = Digit
   {???}

   %IF CH='*' %AND %c
       LPMAX>1 %AND %c
       LINE(LPMAX-2)='/' %START
      {Found a /* comment - remove the '/'}
      LPMAX=LPMAX-2
      %cycle
         GETC(CH) %UNTIL CH='*'
         GETC(CH)
      %REPEAT %until Ch = '/'
      -> LOOP
   %FINISH

   %IF LSP + LPMAX - LSZ > 100 %START
      PRINT STRING ("** Text Too Long")
      NEW LINE
      SIGNAL PROLOG EVENT(1)
   %FINISH

   %IF CH TYPE = Single Quote %OR %c
       CH TYPE = Double Quote %START
      %CYCLE
         GET C (CH)
         LINE (LPMAX)=CH
         LP MAX = LP MAX + 1
      %REPEAT %UNTIL CH TYP (CH) = CH TYPE 
      -> LOOP
   %FINISH

   %IF CH='.' %AND %c
       LP MAX >= 2 %AND %c
       CH TYP (LINE (LP MAX - 2)) # Symbol Character %START
      GET C (CH)
      %IF CH TYP (CH) = 10 %THEN -> END %c
                           %ELSE -> L1
   %FINISH
   -> LOOP
   
END: 
   LINE(LPMAX)=NL
   LP=-1

   RECHAR=0
   RETOKEN=0

   LSP = LSP + (LPMAX + 4)&16_FFC            {points to free space after line}
                                             {of text - used as work area}

   E = TERM (1200)
   Syntax Error (10) %IF TOKEN # FULLSTOP
   E = 0 %IF ERR FLG # 0

{*%if E # 0 %start
{*   Print String ("Result of Read Term = ");  P Write (E, 0, 1200);   New Line
{*%finish
   LSP=SLSP
   %RESULT = E
%END {Read Term}

%end %of %file