!
! Preprocessor 17/4/79 PMM fixed 13/6 RWT
!
! re-ported to VAX 15/07/80 (LDS)
!
%BEGIN

%systemstring (255) %fnspec itos(%integer v,p)
%systemstring (8) %fnspec date
!%include "inc:util.imp"
%EXTERNALINTEGERFNSPEC DEF STREAMS(%STRING(127) STREAMS, DEFAULTS)
%INTEGER RETURN CODE
%OWNSTRING(15) DEFAULTS=".PRE/%I1.SRC"

!***********************************************
!*   General Purpose PreProcessor              *
!***********************************************

! Logical values
%CONSTINTEGER FALSE = 0
%CONSTINTEGER TRUE = -1

! The lexical analyser recognises reserved words
! and these may not be used as tags
%CONSTINTEGER RESWORD=128
%CONSTINTEGER NUMTYPE=129
%CONSTINTEGER TAGTYPE=130
%CONSTINTEGER BOOLTYPE=131
%CONSTINTEGER STRINGTYPE=132
%CONSTINTEGER BUILTINFN=133
   %CONSTINTEGER LENFN=1
   %CONSTINTEGER UNDEF=2
%CONSTINTEGER MACTYPE=134
%CONSTINTEGER ESCAT=135
%CONSTINTEGER IF=-1
%CONSTINTEGER NOT=-2
%CONSTINTEGER OR=-3
%CONSTINTEGER AND=-4
%CONSTINTEGER THEN=-5
%CONSTINTEGER ELSE=-6
%CONSTINTEGER ELIF=-7
%CONSTINTEGER DEFINE=-8
%CONSTINTEGER REDEF=-9
%CONSTINTEGER FINISH=-10
%CONSTINTEGER CYCLE=-11
%CONSTINTEGER REPEAT=-12
%CONSTINTEGER END=-14
%CONSTINTEGER BEGIN=-15
%CONSTINTEGER INCLUDE=-16
%CONSTINTEGER WHILE=-17
%CONSTINTEGER ERR=-18
%CONSTINTEGER MACRO=-19
%CONSTINTEGER FOR=-20
%CONSTINTEGER TO=-21
%CONSTINTEGER STEP=-22
%CONSTINTEGER UNLESS=-23
%CONSTINTEGER UNTIL=-24
%CONSTINTEGER ELUNLESS=-25
%CONSTINTEGER MEND=-26
%CONSTINTEGER EVAL=-27

%CONSTINTEGER STOPPER=-100


! The stored text is all saved in the text buffer
! BUFFER and is inserted and retrieved by STORE
! and RCH.
%CONSTINTEGER BUFFERSIZE=8000
%BYTEINTEGERARRAY BUFFER(257:BUFFERSIZE)
%OWNINTEGER BP=256



! Any temporary text such as string constatns and
! macro arguments are stored in another text buffer
! TEMP, accessed  by TSTORE and PERMANENT.
%CONSTINTEGER TEMPSIZE=3000
%BYTEINTEGERARRAY TEMP(-TEMPSIZE:-2)
%OWNINTEGER TBP=-TEMPSIZE-1


! The current lexical level and macro evaluation number
%OWNINTEGER LEVEL=0
%OWNINTEGER MACNO=0
%INTEGERNAME HMACNO


! Flag to inhibit expansion of meta-tags when reading
! the text of the tags themselves
%OWNINTEGER EXPAND=0



! To get out of cycles we have WFLAG which is set non-32767
! when a `whi statemanet fails
%OWNINTEGER WFLAG=32767


! To prevent too many error messages we have
! a flag indicating that we have output one
%INTEGER ERRMESS


! The escape  character is normally '@' though
! it can be changed.  This is the only character
! which is afforded any special significance by
! the preporocessor
%OWNINTEGER ESCAPE = '@'

! The current input state and evaluation state are
! stored on a stack STACK accessed by TOS, PUSH and
! POP.  The items on the stack are indicators of where
! to get the next input character from as follows.  Zero:
! the next input character is to come from the real source
! file.  1-255: the stacked value is the next input
! character.  >255: the stacked item is a pointer into
! the text buffer whence the next character is to be found.
%CONSTINTEGER STACKSIZE=50
%INTEGERARRAY STACK(1:STACKSIZE)
%INTEGERARRAY LSTACK(0:STACKSIZE)
%OWNINTEGER SP=0
%OWNINTEGER LSP=0
%INTEGERNAME LINENO
%OWNINTEGER INCLUDEFLAG=1
%OWNINTEGER TOS=0


! Directves to RCH
%CONSTINTEGER EOF=254
%CONSTINTEGER EOS=255
%CONSTINTEGER ENDINC=253


! The current output state is held in OFLAG.
! If OFLAG is zero then the output is going
! to the real output destination file.  If
! output is non-zero then it is being discarded.
%OWNINTEGER OFLAG=0



! The number of errors so far;  when we get lost we
! get really lost so give up fast.
%OWNINTEGER NERRS=0
%CONSTINTEGER MAXERRS=10



! The current input character is held in CH while
! reading tokens
%INTEGER CH



! When we are parsing stuff we know about, the current
! input token is held in TOKEN with any associated
! subvalues held in SUB and WORK.
%INTEGER TOKEN, SUB, WORK





%ROUTINESPEC IGNOREWORD
%ROUTINESPEC PROCESS
%ROUTINESPEC PWORD(%INTEGER W)
%INTEGERFNSPEC TYPEOF(%INTEGER W,%INTEGERNAME V)
%PREDICATESPEC LETTER(%INTEGERNAME T)
%PREDICATESPEC DIGIT(%INTEGERNAME T)
%ROUTINESPEC CLEAR(%INTEGER L)
%ROUTINESPEC GENNUM(%INTEGER N)
%ROUTINESPEC RWORD(%INTEGERNAME N, %INTEGER NN)
%ROUTINESPEC RTOKEN
%ROUTINESPEC RCH
%ROUTINESPEC ERROR(%STRING(30) S, %INTEGER T)


%ROUTINE MONITOR(%INTEGER CH)
! Debugging routine - outputs interleaved
! source and destination files to output
! stream 2
   %OWNBYTEINTEGERARRAY B(1:60)
   %OWNINTEGER BP=0
   %INTEGER I,F
   %IF BP>=60 %OR CH=0 %START
      %IF BP>0 %START
         SELECTOUTPUT(2)
         F = 0
         %FOR I = 1,1,BP %CYCLE
            PRINTSYMBOL(B(I)&127)
            F = 1 %IF B(I)>=128
         %REPEAT
         %IF F#0 %START
            PRINTSYMBOL(13)
            %FOR I = 1,1,BP %CYCLE
               %IF B(I)>=128 %THEN PRINTSYMBOL('_') %C
               %ELSE SPACE
            %REPEAT
         %FINISH
         NEWLINE
         SELECTOUTPUT(1)
      %FINISH
      BP = 0
      %RETURN %IF CH=0
   %FINISH
   I = CH&127; F = CH&128
   CH = '^'+F %IF I=NL
   BP = BP+1; B(BP) = CH
%END




%ROUTINE PUSHLINE(%INTEGER L)
! Push a line number onto the line no stack
   LSP = LSP+1;! %IF LSP<STACKSIZE
   LSTACK(LSP) = L
   LINENO == LSTACK(LSP)
%END



%ROUTINE POPLINE
! Pop a line number off the lineno stack
   LSP = LSP-1
   LINENO == LSTACK(LSP)
%END



%ROUTINE PUSH(%INTEGER Q)
! Push Q onto the input state stack
   SP = SP+1
   %IF SP>STACKSIZE %START
      ERROR("Nesting too deep",-1)
      %STOP
   %FINISH
   STACK(SP) = TOS
   TOS = Q
   LINENO = LINENO-1 %IF Q=NL
%END



%ROUTINE BACKSPACE
! Push the current pending CH onto the stack
   PUSH(CH)
%END



%ROUTINE POP
! Pop the last value off the input state stack
   TOS = STACK(SP)
   SP = SP-1
%END



%INTEGERFN SOURCE
! Return zero if the current source is the
! real input stream, else non-zero
! pointer to the source buffer
   %INTEGER I
   STACK(SP+1) = TOS
   %FOR I = SP+1,-1,1 %CYCLE
      %IF STACK(I)>255 %OR STACK(I)<=0 %THEN %RESULT = STACK(I)
   %REPEAT
   %RESULT = 0
%END



%BYTEINTEGERFN TEXTCH(%INTEGER N)
! Return the value of stored character N.
! The indices of TEMP and BUFFER do not overlap so
! we can tell in which buffer it is held
   %IF N<0 %THEN %RESULT = TEMP(N)
   %RESULT = BUFFER(N)
%END



%INTEGERFN GETCH
! Read a character from the current input source
! as defined by the top item on the input
! state stack, and leave it in CH. End-of-file
! is indicated by zero.
   %INTEGER CH
   %on %event 3,9 %start
      ch=eos;  pop
   %finish
AGAIN:
   %IF TOS=0 %START
      ! Real input source stream
      READSYMBOL(CH)
      CH = CH&127
      MONITOR(CH+128)
   %finishELSEIF 0<=TOS<256 %START
      ! Literal character to be popped
      CH = TOS; POP
   %finishELSEIF TOS=STOPPER %START
      ERROR("Unexpected end of input",-1)
      %STOP
   %finish %ELSE %start
      ! Buffer pointer, increment
      TOS = TOS+1
      CH = TEXTCH(TOS-1)
   %FINISH
   %IF CH=EOS %START
     ! End of this input
      POP; ->AGAIN
   %FINISH
   %IF CH=ENDINC %START
      ! End of this input stream
      INCLUDEFLAG = INCLUDEFLAG-1
      POPLINE
      SELECTINPUT(INCLUDEFLAG)
      -> AGAIN
   %FINISH
   LINENO = LINENO+1 %IF CH=NL
   %RESULT = CH
%END



%ROUTINE RCH
   %INTEGER W,V,T
AGAIN:
   CH = GETCH
   %RETURN %UNLESS EXPAND=0 %AND CH=ESCAPE
   CH = GETCH %UNTIL CH#' '
   -> AGAIN %IF CH=NL
   CH = ESCAT %AND %RETURN %IF CH='@'
   %RETURN %UNLESS 'A'<=CH<='Z' %OR 'a'<=CH<='z'
   BACKSPACE
   EXPAND = 1
   RWORD(W,1)
   EXPAND = 0
   T = TYPEOF(W,V)
   %IF T=NUMTYPE %START
      IGNOREWORD; GENNUM(V); -> AGAIN
   %finishELSEIF T=STRINGTYPE %START
      IGNOREWORD; PUSH(V); -> AGAIN
   %finishELSEIF T=BOOLTYPE %START
      IGNOREWORD
      %IF V=FALSE %THEN PUSH('0') %ELSE PUSH('1')
      -> AGAIN
   %finish %ELSE %start
      CH = ESCAPE
   %FINISH
%END



%ROUTINE IGNOREWORD
! Ignore the current tag in the input
! without expansion
   %INTEGER DUMMY
   EXPAND = 1
   RCH
   DUMMY = DUMMY %WHILE LETTER(DUMMY) %OR DIGIT(DUMMY)
   RCH %IF CH='.'
   BACKSPACE
   EXPAND = 0
%END



%INTEGERFN COMPARE(%INTEGER P1,P2)
! Compare two strings.  The value returned
! is -1 for 1<2, 0 for equal and +1 for 1>2.
   %INTEGER C
   %CYCLE
      C = TEXTCH(P1)
      %EXIT %IF C#TEXTCH(P2)
      %RESULT = 0 %IF C=0
      P1 = P1+1; P2 = P2+1
   %REPEAT
   %RESULT = -1 %IF C<TEXTCH(P2) %OR C=EOS
   %RESULT = 1
%END



%ROUTINE STORE(%INTEGER CH)
! Store CH at the current position in
! the text buffer.
   BP = BP+1
   %IF BP>=BUFFERSIZE %START
      ERROR("Too much stored text",-1)
      %STOP
   %FINISH
   BUFFER(BP) = CH; BUFFER(BP+1) = EOS
%END



%ROUTINE TSTORE(%INTEGER CH)
! Store CH at the current position in the
! temporary text buffer.
   TBP = TBP+1
   %IF TBP>=-2 %START
      ERROR("Too much temptext",-1)
      %STOP
   %FINISH
   TEMP(TBP) = CH; TEMP(TBP+1) = EOS
%END



%INTEGERFN PERMANENT(%INTEGER P)
! Make string at P permanent by copying
! it into the text buffer if necessary
   %INTEGER Q,CH
   Q = BP+1
   %RESULT = P %IF P>0; !already permanent
   %CYCLE
      CH = TEMP(P)
      P = P+1
      STORE(CH)
   %REPEAT %UNTIL CH=EOS
   %RESULT = Q
%END





%ROUTINE PCH(%INTEGER CH)
!Print the character CH if necessary
   %IF OFLAG=0 %START
      CH = ESCAPE %IF CH=ESCAT
      PRINTSYMBOL(CH)
      MONITOR(CH)
   %FINISH
   ! else discard CH
%END



! The hashtable is organised as an array (of a power of two)
! frames for holding symbols.  The frame contains the symbol
! name, its value and type, and the level at which it
! was created.  The symbols mask each other in the usual block
! structured way if duplicates are declared at different
! levels.
%CONSTINTEGER HTABSIZE=511
%RECORDFORMAT HTABF(%INTEGER NAME,VALUE, %BYTEINTEGER TYPE,LEVEL)
%RECORD(HTABF)%ARRAY HTAB(0:HTABSIZE)
%OWNRECORD(HTABF) BADTAG


%INTEGERFN HASH(%INTEGER WHAT)
! Calculate the hash value for WHAT
   %RESULT = ((WHAT*16_E945)>>3)&HTABSIZE
%END



%RECORD(HTABF)%MAP LOOKUP(%INTEGER WHAT,EFLAG)
! Lookup the packed tag WHAT in the symbol
! table and return a pointer to its frame.
! If EFLAG is zero then it is an error for
! the symbol to be absent.
   %INTEGER PR,P,L
   %RECORD(HTABF)%NAME R; R == BADTAG
   PR = HASH(WHAT); P = PR; ! Initial probe into table
   L = -1
   %CYCLE
      %IF HTAB(P)_NAME=WHAT %START
         ! Found an occurrence of the symbol WHAT
         %IF HTAB(P)_LEVEL>L %START
            !  at a higher level than before
            L = HTAB(P)_LEVEL; R == HTAB(P)
         %FINISH
      %FINISH
      %EXIT %IF HTAB(P)_NAME=0 %OR P=PR-1
      P = (P+1)&HTABSIZE
   %REPEAT
   ! R now points to the innermost occurrence
   ! of WHAT unless there were none at all
   %IF R==BADTAG %AND EFLAG=0 %START
      ERROR("Undefined: ", WHAT)
   %FINISH
   %RESULT == R
%END



%ROUTINE ENTER(%INTEGER WHAT,LEVEL,TYPE,VALUE)
! Enter a new symbol WHAT into the symbol table at
! level LEVEL, with type TYPE and value VALUE.
   %INTEGER PR,P
   %RECORD(HTABF)%NAME H
   H == LOOKUP(WHAT,1); !No error if absent
   %UNLESS H==BADTAG %START; ! Check for duplication
      ERROR("Duplicate: ",WHAT) %IF H_LEVEL>=LEVEL
   %FINISH
   PR = HASH(WHAT)
   P = PR
   %CYCLE
      H == HTAB(P)
      %IF H_NAME=0 %OR H_NAME=-1 %START; ! Empty slot
         H_NAME = WHAT; H_LEVEL = LEVEL
         H_TYPE = TYPE; H_VALUE = VALUE
         %RETURN
      %FINISH
      P = (P+1)&HTABSIZE
   %REPEAT %UNTIL P=PR
   ERROR("Symbol table full",-1)
   %STOP
%END



%ROUTINE CLEAR(%INTEGER LEVEL)
! Remove all symbols declared at levels
! below LEVEL from the table.
   %INTEGER I
   %RECORD(HTABF)%NAME H
   %FOR I = 0,1,HTABSIZE %CYCLE
      H == HTAB(I)
      %IF H_LEVEL>=LEVEL %START
         H_NAME = -1; ! Free slot
      %FINISH
   %REPEAT
%END



%ROUTINE RESERVE
! Clear out the symbol table and enter the
! reserved words
   %RECORD(HTABF)%NAME H
   %INTEGER PACKED
   %ROUTINE R(%STRING(8) S, %INTEGER ITY,IVAL)
      ! Enter S as a reserved word
      %INTEGER I,T
      PUSH(NL)
      %FOR I = 3,-1,1 %CYCLE
         %IF I<=LENGTH(S) %THEN PUSH(CHARNO(S,I))
      %REPEAT
      RCH
      RWORD(T,0)
      PACKED = T
      ENTER(T,0,ITY,IVAL)
   %END
   %INTEGER I
   LINENO == LSTACK(0);   LINENO=0
   %FOR I = 0,1,HTABSIZE %CYCLE
      HTAB(I)_NAME = 0
   %REPEAT
   R("IF",RESWORD,IF)
   R("NOT",RESWORD,NOT)
   R("OR",RESWORD,OR)
   R("AND",RESWORD,AND)
   R("THE",RESWORD,THEN)
   R("ELS",RESWORD,ELSE)
   R("ELI",RESWORD,ELIF)
   R("DEF",RESWORD,DEFINE)
   R("RED",RESWORD,REDEF)
   R("FIN",RESWORD,FINISH)
   R("INC",RESWORD,INCLUDE)
   R("FOR",RESWORD,FOR)
   R("TO",RESWORD,TO)
   R("STE",RESWORD,STEP)
   R("UNL",RESWORD,UNLESS)
   R("UNT",RESWORD,UNTIL)
   R("ELU",RESWORD,ELUNLESS)
   R("TRU",BOOLTYPE,TRUE)
   R("FAL",BOOLTYPE,FALSE)
   R("NL",STRINGTYPE,257)
   R("CYC",RESWORD,CYCLE)
   R("REP",RESWORD,REPEAT)
   R("WHI",RESWORD,WHILE)
   R("BEG",RESWORD,BEGIN)
   R("END",RESWORD,END)
   R("ERR",RESWORD,ERR)
   R("LEN",BUILTINFN,LENFN)
   R("UND",BUILTINFN,UNDEF)
   R("MAC",RESWORD,MACRO)
   R("MEN",RESWORD,MEND)
   R("EVA",RESWORD,EVAL)
   R("MNO",NUMTYPE,MACNO);! must be last
   H == LOOKUP(PACKED,0)
   HMACNO == H_VALUE
   TOS = STOPPER; SP = 0
   PUSH(EOF); PUSH(0); !initialise stack
   LEVEL = 1
   STORE(NL); STORE(EOS)
   PUSHLINE(1)
%END



%PREDICATE LETTER(%INTEGERNAME C)
! Test CH for being a letter.  If so, map to
! 0-25 in C, read the next character and true.
   CH = CH-'a'+'A' %IF 'a'<=CH<='z'
   %IF 'A'<=CH<='Z' %START
      C = CH-'A'; RCH; %TRUE
   %FINISH
   %FALSE
%END



%PREDICATE DIGIT(%INTEGERNAME C)
! Test CH for being a digit.  If so, map to
! 0-9 in C, read the next character and true.
   %IF '0'<=CH<='9' %START
      C = CH-'0'; RCH; %TRUE
   %FINISH
   %FALSE
%END



%ROUTINE RWORD(%INTEGERNAME WORD, %INTEGER N)
! Read in a tag into WORD and pack
! up the first three characters.
! If N is non-zero then the characters
! are not read but only examined
! and it is assumed that CH does
! not contain the first char (nor is it
! left with the last)
   %INTEGER C,T,C1,C2,C3
   T = 0; C1 = 0; C2 = 0; C3 = 0
   RCH %IF N#0
   -> RW1 %UNLESS LETTER(C)
   C1 = 'A'+C
   T =  C*1073+1111
   -> RW2 %UNLESS LETTER(C)
   C2 = 'A'+C
   T =T+C*37 +111
   -> RW3 %UNLESS LETTER(C)
   C3 = 'A'+C
   T = T+C+11
   -> OUT
RW1:
   -> OUT %UNLESS DIGIT(C)
   C1 = '0'+C
   T = C*111+1
RW2:
   -> OUT %UNLESS DIGIT(C)
   C2 = '0'+C
   T = T+C*11+1
RW3:
   -> OUT %UNLESS DIGIT(C)
   C3 = '0'+C
   T = T+C+1
OUT:
   %IF N#0 %START
      ! Push the three characters back onto the stack
      BACKSPACE
      PUSH(C3) %IF C3#0
      PUSH(C2) %IF C2#0
      PUSH(C1) %IF C1#0
   %FINISH
   WORD = T
%END



%ROUTINE PWORD(%INTEGER T)
! Print out the packed tag T as (up to)
! three characters
   %IF T=0 %THEN PRINTSYMBOL('?') %AND %RETURN
   T = T-1111
   -> PW1 %IF T<0
   PRINTSYMBOL('A'+T//1073); T = REM(T,1073)
   -> PW2 %IF T<111
   PRINTSYMBOL('A'-3+T//37); T = REM(T,37)
   -> PW3 %IF T<11
   PRINTSYMBOL(T+'A'-11)
   %RETURN
PW1:
   T = T+1110
   -> PW2 %IF T<0
   PRINTSYMBOL('0'+T//111); T = REM(T,111)
PW2:
   -> PW3 %IF T=0
   T = T-1
   PRINTSYMBOL('0'+T//11); T = REM(T,11)
PW3:
   PRINTSYMBOL('0'-1+T) %IF T#0
%END



%ROUTINE ERROR(%STRING(30) WHY, %INTEGER WORD)
! Send an error message to the report
! stream consisting of the string WHY.
! If TAG is positive, then append it
! to the end of the message 
! using PWORD.
   %INTEGER S,K
   %RETURN %IF ERRMESS#0; ERRMESS = 1
   MONITOR(0)
   %FOR S = 0,2,2 %CYCLE
      SELECTOUTPUT(S)
      %FOR K = 1,1,LSP %CYCLE
         PRINTSYMBOL('/') %IF K#1
         WRITE(LSTACK(K),0)
      %REPEAT
      SPACE
      PRINTSTRING("ERROR: "); PRINTSTRING(WHY)
      PRINTSYMBOL(WORD&127) %IF WORD<-1
      PWORD(WORD) %IF WORD#-1; NEWLINE
   %REPEAT
   SELECTOUTPUT(1)
   NERRS = NERRS+1
   %IF NERRS>MAXERRS %START
      SELECTOUTPUT(0)
      PRINTSTRING("I give up"); NEWLINE
      %STOP
   %FINISH
%END



%ROUTINE RTAG(%INTEGERNAME TAG)
! Read in a tag into TAG, dealing with
! extra (above three) alphanumerics
   %INTEGER DUMMY
   RWORD(TAG,0)
   DUMMY = DUMMY %WHILE LETTER(DUMMY) %OR DIGIT(DUMMY)
%END




%ROUTINE GENNUM(%INTEGER N)
! Push the characters of N (as a text string)
! back onto the input to be read.
   N = -N %IF N<0; N = REM(N,1000)
   PUSH(REM(N,10)+'0')
   %IF N>=10 %START
      GENNUM(N//10)
   %FINISH
%END



%ROUTINE RNUM(%INTEGERNAME N)
! Read a decimal number into N
   %INTEGER C
   N = 0
   N = N*10+C %WHILE DIGIT(C)
%END



%ROUTINE NEWVAL(%INTEGER TAG,TYPE,VAL)
! Assign a new value to an existing
! tag
   %RECORD(HTABF)%NAME H
   H == LOOKUP(TAG,0)
   %UNLESS H==BADTAG %START
      %IF H_TYPE=TYPE %THEN H_VALUE = VAL %C
      %ELSE ERROR("Type redefinition",-1)
   %FINISH
%END



%INTEGERFN TYPEOF(%INTEGER TAG, %INTEGERNAME V)
! Returns the type of tag TAG.  If it is not
! in the symbol table then we return type TAG.
! The value is also returned in V.
   %RECORD(HTABF)%NAME H
   H == LOOKUP(TAG,1)
   V = 0
   %RESULT = TAGTYPE %IF H==BADTAG
   %RESULT = H_VALUE %IF H_TYPE=RESWORD
   V = H_VALUE
   %RESULT = H_TYPE
%END



%ROUTINE SKIPTONL
! Skip to next newline in input (used
! for attempting error recovery)
   RCH; !Get a character
   RCH %WHILE CH#NL %AND CH#EOF
   BACKSPACE
%END



%ROUTINE IGNOREDOT
! Ignore the period following a substitution if
! necessary
   RCH
   BACKSPACE %UNLESS CH='.'
%END



%INTEGERFN NTOKEN
! Look at the next token but do not read it.
! The token must be either >128 or a tag following
! an escape character
   %INTEGER T,DUMMY
   RCH; !read the @
   RWORD(T,1)
   %RESULT = 0 %IF T=0
   T = TYPEOF(T,DUMMY)
   %RESULT = T
%END



%ROUTINE REVERT
! Revert to normal processing using
! RCH and not parsing into tokens.  We ignore the
! first non-space character following the parsed section
   RCH
   RCH %WHILE CH=' '
   BACKSPACE %UNLESS CH=';' %OR CH=NL
%END



%ROUTINE RTOKEN
! Read a token from the input into TOKEN.  This
! routine should only be used in parts of the
! input that the preprocessor should know about
! or it may gobble up the user's text
   %INTEGER TAG
   RCH; !get the first character
   RCH %WHILE CH=' ';! Ignore spaces
   SUB = 0; WORK = 0
   %IF 'A'<=CH<='Z' %OR 'a'<=CH<='z' %START
      ! It's a tag
      RTAG(TAG)
      BACKSPACE
      WORK = TAG
      TOKEN = TYPEOF(TAG,SUB)
   %finishELSEIF CH=ESCAPE %START
      ! It's a reserved word
      RCH; ! read escape
      RTAG(TAG)
      %IF TAG=0 %START
         ! nothing there
         TOKEN = CH
      %finish %ELSE %start
         BACKSPACE
         WORK = TAG
         TOKEN = TYPEOF(TAG,SUB)
      %FINISH
   %finishELSEIF '0'<=CH<='9' %START
      TOKEN = NUMTYPE
      RNUM(SUB)
      BACKSPACE
   %finishELSEIF CH='"' %START
      TOKEN = STRINGTYPE; SUB = TBP+1
      RCH
      %CYCLE
         %IF CH='"' %START
            RCH; %EXIT %IF CH#'"'
         %FINISH
         TSTORE(CH); RCH
      %REPEAT
      TSTORE(EOS)
      BACKSPACE
   %finishELSEIF CH='<' %OR CH='>' %START
      ! Deal with < <= << > >= >>
      TOKEN = CH
      RCH
      %IF CH='=' %THEN TOKEN = TOKEN+1000 %C
      %ELSEIF CH=TOKEN %THEN TOKEN = TOKEN+2000
      BACKSPACE %IF TOKEN<1000
   %finish %ELSE %start
      TOKEN = CH
   %FINISH
%END



! Expression are passed as two element records, the
! first element containing the type (string, predicate
! or numeric)
%RECORDFORMAT EXPF(%INTEGER TYPE,VALUE)

%ROUTINESPEC COERCE(%RECORD(EXPF)%NAME E,%INTEGER T)
%ROUTINESPEC EVALUATE(%RECORD(EXPF)%NAME S)


%INTEGERFN LENGTH(%INTEGER S)
! Return the length of the string at S
   %INTEGER L
   %FOR L = 0,1,10000 %CYCLE
      %EXIT %IF TEXTCH(S+L)=EOS
   %REPEAT
   %RESULT = L
%END



%INTEGERFN CONCAT(%INTEGER S1,S2)
! Concatenate two strings
   %INTEGER C,B; B = TBP+1
   %CYCLE
      C = TEXTCH(S1)
      %EXIT %IF C=EOS
      TSTORE(C)
      S1 = S1+1
   %REPEAT
   %CYCLE
      C = TEXTCH(S2)
      TSTORE(C)
      S2 = S2+1
   %REPEAT %UNTIL C=EOS
   %RESULT = B
%END




%INTEGERFN SUBSTRING(%INTEGER S,L,R)
! Return the substring from the L'th to the R'th
! character of string S
   %INTEGER C,B,P
   B = TBP+1
   L = 1 %IF L<=0
   -> NULL %IF L>R
   P = 1
   %CYCLE
      C = TEXTCH(S+P-1)
      -> NULL %IF C=EOS
      %EXIT %IF P>=L
      P = P+1
   %REPEAT
   %CYCLE
      C = TEXTCH(S+P-1)
      -> NULL %IF C=EOS
      TSTORE(C)
      %EXIT %IF P>=R
      P = P+1
   %REPEAT
NULL:
   TSTORE(EOS)
   %RESULT = B
%END



%INTEGERFN STRINGEXP
! Get a string expression
   %RECORD(EXPF) E
   EVALUATE(E)
   COERCE(E,STRINGTYPE)
   %IF E_TYPE#STRINGTYPE %START
      ERROR("Not a string",-1)
      TSTORE(EOS)
      %RESULT = TBP
   %FINISH
   %RESULT = E_VALUE
%END



%INTEGERFN NUMEXP
! Get a numerical expression
   %RECORD(EXPF) E
   EVALUATE(E)
   COERCE(E,NUMTYPE)
   %IF E_TYPE#NUMTYPE %START
      ERROR("Not numeric",-1)
      %RESULT = 0
   %FINISH
   %RESULT = E_VALUE
%END



%ROUTINE COERCE(%RECORD(EXPF)%NAME E, %INTEGER TYPE)
! Coerce expression E to be of type TYPE if
! possible.  We currently only implement the
! coercion NUMTYPE -> STRINGTYPE
! and STRINGTYPE -> NUMTYPE
   %ROUTINE NTOS(%INTEGER N)
      N = -N %IF N<0; N = REM(N,1000)
      %IF N>=10 %THEN NTOS(N//10)
      TSTORE(REM(N,10)+'0')
   %END
   %INTEGER B,C,N
   %IF E_TYPE=NUMTYPE %AND TYPE=STRINGTYPE %START
      E_TYPE = STRINGTYPE; B = TBP+1
      NTOS(E_VALUE); TSTORE(EOS)
      E_VALUE = B
   %finishELSEIF E_TYPE=STRINGTYPE %AND TYPE=NUMTYPE %START
      B = E_VALUE; N = 0
      %CYCLE
         C = TEXTCH(B); %EXIT %UNLESS '0'<=C<='9'
         N = N*10+C-'0'
         B = B+1
      %REPEAT
      %IF C=EOS %START
         E_TYPE = NUMTYPE; E_VALUE = N
      %FINISH
   %FINISH
%END



%ROUTINE EXPRESSION(%INTEGER PRECEDENCE, %RECORD(EXPF)%NAME RESULT)
! Read in and evaluate an arithmetic or logical
! expression.  The precedence rules are:
! 10 - Constants or bracketed expressions
! 9  - Monadic oparators, -, + and \
! 8  - Diadic operators *, / and \
! 7  - Diadic operators + and -
! 6  - Diadic comparators <, <=, >, >=, = and #
! 5  - Shifts << and >>
! 4  - Boolean and &
! 3  - Boolean or !
! 2  - Predicate and @AND
! 1  - Predicate or @OR
! Operators all associate to the right with equal
! precedence operators
   %INTEGER OPN,OP,R,T1,T2
   %RECORD(EXPF) TERM1,TERM2
   ! the allowable diadic operators
   %CONSTINTEGER NOPS=18
   %CONSTINTEGERARRAY DOPS(1:NOPS) =
      OR, AND, '!', '&', '<'+2000, '>'+2000,
      '<', '>', '<'+1000, '>'+1000, '=', '#',
      '+', '-', '*', '/', '\', '.'
   ! the operator precedences
   %CONSTINTEGERARRAY DOPP(1:NOPS) =
      1, 2, 3, 4, 5(2), 6(6), 7(2), 8(3), 7
   ! the result type from each operator
   %CONSTINTEGERARRAY RES(1:NOPS) = BOOLTYPE(2),
      NUMTYPE(4), BOOLTYPE(6), NUMTYPE(5), STRINGTYPE
   ! the allowable arument types for each operator
   %CONSTINTEGERARRAY ARGS(1:NOPS) = BOOLTYPE(2),
      NUMTYPE(4), 0(6), NUMTYPE(5), STRINGTYPE
   RESULT_TYPE = NUMTYPE; RESULT_VALUE = 0
   %IF PRECEDENCE<=8 %START
      ! Diadic operator
      EXPRESSION(PRECEDENCE+1,TERM1)
      OPN = 0
      %CYCLE
         OPN = OPN+1
         %IF OPN>NOPS %START
            ! No operator follows
            RESULT_TYPE = TERM1_TYPE
            RESULT_VALUE = TERM1_VALUE
            %RETURN
         %FINISH
         %EXIT %IF TOKEN=DOPS(OPN) %AND PRECEDENCE<=DOPP(OPN)
      %REPEAT
      OP = TOKEN
      RTOKEN
      EXPRESSION(PRECEDENCE,TERM2)
      %IF ARGS(OPN)#0 %START
         COERCE(TERM1,ARGS(OPN))
         COERCE(TERM2,ARGS(OPN))
      %IF TERM1_TYPE#TERM2_TYPE %THEN -> ERR
      %finish %ELSE %start
         COERCE(TERM1,TERM2_TYPE)
      %FINISH
      %IF ARGS(OPN)#0 %START
         -> ERR %IF ARGS(OPN)#TERM1_TYPE
      %FINISH
      RESULT_TYPE = RES(OPN)
      T1 = TERM1_VALUE; T2 = TERM2_VALUE
      %IF OP='+' %THEN R = T1+T2
      %IF OP='-' %THEN R = T1-T2
      %IF OP='/' %THEN R = T1//T2
      %IF OP='*' %THEN R = T1*T2
      %IF OP='\' %THEN R = REM(T1,T2)
      %IF OP='<'+2000 %THEN R = T1<<T2
      %IF OP='>'+2000 %THEN R = T1>>T2
      %IF OP='!' %OR OP=OR %THEN R = T1!T2
      %IF OP='&' %OR OP=AND %THEN R = T1&T2
      %IF OP='.' %THEN R = CONCAT(T1,T2)
      %UNLESS 7<=OPN<=12 %START
         ! Not a comparator
         RESULT_VALUE = R; %RETURN
      %FINISH
      %IF TERM1_TYPE = STRINGTYPE %START
         ! Set up correct relation between t1 and t2
         T1 = COMPARE(T1,T2); T2 = 0
      %FINISH
      RESULT_VALUE = FALSE
      %IF T1=T2 %START
         RESULT_VALUE = TRUE %IF OP>1000 %OR OP='='
         %RETURN
      %FINISH
      %IF OP='=' %OR OP='#' %START
         RESULT_VALUE = TRUE %IF OP='#'; %RETURN
      %FINISH
      OP = OP-1000 %IF OP>1000
      %IF T1>T2 %START
         RESULT_VALUE = TRUE %IF OP='>'; %RETURN
      %FINISH
      RESULT_VALUE = TRUE %IF OP='<'; %RETURN
   %FINISH
   %IF PRECEDENCE<=9 %START
      ! Monadic operator
      %IF TOKEN='-' %OR TOKEN='+' %OR TOKEN='\' %OR TOKEN=NOT %START
         OP = TOKEN; RTOKEN
         EXPRESSION(10,TERM1)
         %IF OP=NOT %START
            -> ERR %IF TERM1_TYPE#BOOLTYPE
            RESULT_TYPE = BOOLTYPE
         %finish %ELSE %start
            COERCE(TERM1,NUMTYPE)
            -> ERR %IF TERM1_TYPE#NUMTYPE
         %FINISH
         T1 = TERM1_VALUE
         RESULT_VALUE = T1
         %IF OP='-' %THEN RESULT_VALUE = -T1
         %IF OP='\' %OR OP=NOT %THEN RESULT_VALUE = \T1
         %RETURN
      %FINISH
   %FINISH
   ! Primary or bracketed expression
   %IF TOKEN='(' %START
      RTOKEN
      EXPRESSION(1,RESULT)
      %IF TOKEN#')' %THEN -> ERR
      RTOKEN; %RETURN
   %finishELSEIF TOKEN=NUMTYPE %START
      RESULT_VALUE = SUB; RTOKEN
      %RETURN
   %finishELSEIF TOKEN=STRINGTYPE %START
      RESULT_TYPE = STRINGTYPE
      RESULT_VALUE = SUB
      RTOKEN
      %IF TOKEN='(' %START
         ! substring
         RTOKEN
         T1 = NUMEXP
         -> ERR %IF TOKEN#','
         RTOKEN
         T2 = NUMEXP
         -> ERR %IF TOKEN#')'
         RTOKEN
         RESULT_VALUE = SUBSTRING(RESULT_VALUE,T1,T2)
      %FINISH
      %RETURN
   %finishELSEIF TOKEN=BOOLTYPE %START
      RESULT_TYPE = BOOLTYPE
      RESULT_VALUE = SUB
      RTOKEN; %RETURN
   %finishELSEIF TOKEN=BUILTINFN %START
      %IF SUB=LENFN %START
         RTOKEN
         -> ERR %IF TOKEN#'('
         T1 = STRINGEXP
         RESULT_VALUE = LENGTH(T1)
         %RETURN
      %finishELSEIF TOKEN=UNDEF %START
         RTOKEN
         -> ERR %IF TOKEN#'('; RTOKEN
         -> ERR %IF WORK=0; T1 = WORK; RTOKEN
         -> ERR %IF TOKEN#')'; RTOKEN
         T2 = TYPEOF(T1,T1)
         RESULT_TYPE = BOOLTYPE
         RESULT_VALUE = FALSE
         ! true if undefined or reserved word
         RESULT_VALUE = TRUE %IF T2=TAGTYPE %OR T2<0 %OR T2=BUILTINFN
         %RETURN
      %FINISH
   %FINISH
ERR:
   ERROR("Malformed expression",-1)
   SKIPTONL
   %RETURN
%END



%ROUTINE EVALUATE(%RECORD(EXPF)%NAME P)
! Read and evaluate an expression of arbitrary
! type
   EXPRESSION(1,P)
%END



%INTEGERFN CONDITION
! Read and evaluate a condition
   %RECORD(EXPF) C
   EVALUATE(C)
   %IF C_TYPE#BOOLTYPE %START
      ERROR("Bad condition",-1)
      SKIPTONL; %RESULT = FALSE
   %FINISH
   %RESULT= TRUE %UNLESS C_VALUE=FALSE
   %RESULT = FALSE
%END



%ROUTINE SYNTAX
! Syntax error; read up to newline
   ERROR("Syntax",-1)
   SKIPTONL
%END



%ROUTINE SCOPY(%INTEGER FLAG,TFLAG)
! Store text not-containing meta-constructs
! The text is not stored if flag is non-zero.
   RCH
   %WHILE CH#ESCAPE %AND CH<128 %CYCLE
      %IF FLAG=0 %START
         %IF TFLAG=0 %THEN TSTORE(CH) %ELSE STORE(CH)
      %FINISH
      RCH
   %REPEAT
   BACKSPACE
%END



%ROUTINE COPY
! Copy text not containing meta-constructs
   RCH
   %WHILE CH#ESCAPE %AND CH<128 %CYCLE
      PCH(CH); RCH
   %REPEAT
   BACKSPACE
   ERRMESS = 0
%END



%ROUTINE DOEVAL
   ! Replace an expression with its evaluated form
   %RECORD(EXPF) E
   RTOKEN
   %RETURN %IF TOKEN#'('
   RTOKEN
   EVALUATE(E)
   %IF E_TYPE=NUMTYPE %START
      GENNUM(E_VALUE)
   %finishELSEIF E_TYPE=STRINGTYPE %START
      PUSH(E_VALUE)
   %finishELSEIF E_TYPE=BOOLTYPE %START
      %IF E_VALUE=FALSE %THEN PUSH('0') %ELSE PUSH('1')
   %FINISH
   SYNTAX %IF TOKEN#')'
%END



%INTEGERFN STORECYCLE(%INTEGERNAME L)
! Store a cycle body in the text buffer, delaing
! correctly with nested cycles.
   %INTEGER B,DEPTH,T,S
   B = TBP+1; DEPTH = 1; S = SOURCE
   EXPAND = 1; !no expansion as we read it in
   REVERT; !ignore ch after @cyc
   L = LINENO
   %CYCLE
      SCOPY(S,0)
      T = NTOKEN; !token found - could be cyc or rep
      %IF T=CYCLE %START
         DEPTH = DEPTH+1
      %finishELSEIF T=REPEAT %START
         DEPTH = DEPTH-1
      %FINISH
      TSTORE(ESCAPE) %IF S=0
   %REPEAT %UNTIL DEPTH=0
   PUSH(ESCAPE); RTOKEN; REVERT; !ignore last @REP
   EXPAND = 0
   %IF S=0 %START
      TSTORE('R'); TSTORE('E'); TSTORE('P'); TSTORE(NL)
      TSTORE(EOS)
      %RESULT = B
   %FINISH
   %RESULT = S
%END


%ROUTINE DOCYCLE
! Process a cycle-repeat.  If the source
! is not from core already then we must first
! load the cycle body into a core buffer
   %INTEGER OLDTBP,CHEAD,OLDWFLAG,DUMMY
   %INTEGER T,CONTROL,INITIAL,INCREMENT,FINAL
   %INTEGER EXISTED,OLDLINE
   %RECORD(HTABF)%NAME H
   OLDTBP = TBP
   OLDWFLAG = WFLAG
   CONTROL = -1
   INITIAL = 1; INCREMENT = 1; FINAL = 1000
   EXISTED = 0
   %IF TOKEN=FOR %START
      RTOKEN
      -> SERR %IF WORK=0
      CONTROL = WORK; RTOKEN
      %IF TOKEN='=' %START
         RTOKEN
         INITIAL = NUMEXP
         -> SERR %IF TOKEN#TO
      %FINISH
   %FINISH
   %IF TOKEN=TO %START
      RTOKEN
      FINAL = NUMEXP
      %IF TOKEN=STEP %START
         RTOKEN
         INCREMENT = NUMEXP
      %FINISH
      -> SERR %IF TOKEN#CYCLE
   %FINISH
   %IF CONTROL#-1 %START
      ! declare control variable
      H == LOOKUP(CONTROL,1)
      %IF H==BADTAG %START
         ! not in table - create it
         EXISTED = 1
         ENTER(CONTROL,LEVEL,NUMTYPE,INITIAL)
         H == LOOKUP(CONTROL,0)
      %finish %ELSE %start
         ! use the old value
         %IF H_TYPE#NUMTYPE %START
            ERROR("Non numeric control variable",INITIAL)
         %finish %ELSE %start
            H_VALUE = INITIAL
         %FINISH
      %FINISH
   %FINISH

   CHEAD = STORECYCLE(OLDLINE); !scan cycle and store if necessary
   %IF OFLAG=0 %START
      ! actually outputting
      %CYCLE
         %IF INCREMENT<0 %START
            %EXIT %IF INITIAL<FINAL
         %finish %ELSE %start
            %EXIT %IF INITIAL>FINAL
         %FINISH
         pushline(oldline)
         PUSH(CHEAD); PROCESS
         T = TOKEN
         REVERT; POP
         %IF T#REPEAT %START
            ERROR("Nesting",-1)
            PROCESS; %RETURN
         %FINISH
         POPLINE
         INITIAL = INITIAL+INCREMENT
         H_VALUE = INITIAL %IF CONTROL#-1
      %REPEAT %UNTIL WFLAG#32767
   %FINISH
   %IF EXISTED=1 %START
      ! we created control v so remove it
      H_NAME = -1
   %FINISH
   OFLAG = WFLAG %IF WFLAG#32767
   WFLAG = OLDWFLAG
   %RETURN
SERR:
   SYNTAX
   TBP = OLDTBP
%END



%ROUTINE STOREMACRO
! Store the text of a Macro, including any internal
! macro definitions
   %INTEGER B,DEPTH,S,T,NAME
   B = BP+1; DEPTH = 1; S = SOURCE
   RTOKEN
   -> ERR %IF WORK=0
   STORE(LINENO>>8); STORE(LINENO&255)
   NAME = WORK
   RTOKEN
   %IF TOKEN='(' %START
      %CYCLE
         RTOKEN
         -> ERR %IF WORK=0
         STORE(WORK>>8); STORE(WORK&255)
         RTOKEN
      %REPEAT %UNTIL TOKEN#','
      -> ERR %IF TOKEN#')'
      RTOKEN
   %FINISH
   STORE(EOS)
   EXPAND = 1
   %CYCLE
      SCOPY(S,1)
      T = NTOKEN
      %IF T=MACRO %THEN DEPTH = DEPTH+1 %C
      %ELSEIF T=MEND %THEN DEPTH = DEPTH-1
      STORE(ESCAPE) %IF S=0
   %REPEAT %UNTIL DEPTH=0
   PUSH(ESCAPE); RTOKEN; REVERT
   EXPAND = 0
   %IF S=0 %START
      STORE('M'); STORE('E'); STORE('N'); STORE(NL)
      STORE(EOS)
   %FINISH
   S = B %IF S=0
   ENTER(NAME,LEVEL,MACTYPE,S)
   %RETURN
ERR:
   ERROR("Error in macro definition",NAME)
%END



%ROUTINE READTOCOMMA
! Store text up to the next , or ) not contained
! within quotes.  Strip off the outermost quotes
! if they occur
   %IF CH='"' %START
      %CYCLE
         RCH
         %IF CH='"' %START
            RCH; %EXIT %IF CH#'"'
         %FINISH
         STORE(CH)
      %REPEAT
      %IF CH#',' %AND CH#')' %START
         ERROR("Comma or bracket expected",-1)
      %FINISH
   %FINISH
   %WHILE CH#',' %AND CH#')' %CYCLE
      STORE(CH); RCH
   %REPEAT
   STORE(EOS)
   ! leave , or ) in CH
%END



%ROUTINE EXPANDMACRO
! Expand a macro body
   %INTEGER M,OLDBP,N,C,T
   %INTEGER OLDHMACNO,MNAME
   OLDHMACNO = HMACNO; MNAME = WORK; OLDBP = BP; M = SUB-1
   %INTEGERFN FETCH
      M = M+1; %RESULT = BUFFER(M)
   %END
   PUSHLINE(FETCH<<8+FETCH)
   MACNO = MACNO+1
   HMACNO = MACNO
   LEVEL = LEVEL+1
   EXPAND = 1
   RCH
   %IF CH#'(' %THEN BACKSPACE %AND PUSH(')')
   CH=','
   %CYCLE
      RCH %IF CH=','
      N = FETCH
      %EXIT %IF N=EOS; !end of arglist
      N = N<<8+FETCH
      ENTER(N,LEVEL,STRINGTYPE,0)
      T = BP+1
      READTOCOMMA
      NEWVAL(N,STRINGTYPE,T)
   %REPEAT
   ERROR("Too many arguments: ",MNAME) %IF CH#')'
   IGNOREDOT
   EXPAND = 0
   %IF OFLAG=0 %START
      ! actually outputting
      PUSH(M+1)
      PROCESS
      %IF TOKEN#MEND %START
         ERROR("End of macro expected: ",MNAME)
         SKIPTONL; PROCESS; %RETURN
      %FINISH
      POP
   %FINISH
   POPLINE
   BP = OLDBP
   HMACNO = OLDHMACNO
   CLEAR(LEVEL)
   LEVEL = LEVEL-1
%END



%ROUTINE DOERROR
! Output an error message for the user
   %INTEGER E,OLDTBP,K,CH
   %BYTEINTEGERARRAY B(0:81)
   OLDTBP = TBP
   RTOKEN
   E = STRINGEXP
   %FOR K = 1,1,82 %CYCLE
      CH = TEXTCH(E+K-1)
      %EXIT %IF CH=EOS
      B(K) = CH
      %EXIT %IF K=81
   %REPEAT
   B(0) = K-1
   ERROR(STRING(ADDR(B(0))),-1)
   TBP = OLDTBP
%END



%ROUTINE DOBLOCK
! Process a begin-end block
   %INTEGER OLDBP; OLDBP = BP
   LEVEL = LEVEL+1
   REVERT
   PROCESS
   %IF TOKEN#END %START
      ERROR("@END expected",-1)
      REVERT; PROCESS; %RETURN
   %FINISH
   REVERT
   CLEAR(LEVEL)
   LEVEL = LEVEL-1
   BP = OLDBP
%END


%ROUTINE DOIF
! Process an @IF statement
! Syntax: @IF condition THEN ... {@ELIF condition
!         THEN ... } @ELSE ... @FINISH
   %INTEGER OLDOFLAG, ELSEFLAG, UNL
   OLDOFLAG = OFLAG; ELSEFLAG = 0
   %IF TOKEN=IF %THEN TOKEN=ELIF %ELSE TOKEN=ELUNLESS
   OFLAG = 1
   %CYCLE
      %EXIT %IF TOKEN=ELSE %OR TOKEN=FINISH
      UNL = TRUE; UNL = FALSE %IF TOKEN=ELUNLESS
      -> NERR %IF TOKEN#ELIF %AND TOKEN#ELUNLESS
      RTOKEN
      %IF UNL=CONDITION %AND ELSEFLAG=0 %START
         ELSEFLAG = 1
         OFLAG = OLDOFLAG
      %FINISH
      %IF TOKEN#THEN %START
         ERROR("@THEN expected",-1)
      %FINISH
      REVERT
      PROCESS
      OFLAG = 1
   %REPEAT
   %IF TOKEN=ELSE %START
      %IF ELSEFLAG=0 %THEN OFLAG = OLDOFLAG
      REVERT
      PROCESS
   %FINISH
   -> NERR %IF TOKEN#FINISH
   REVERT
   OFLAG = OLDOFLAG
   %RETURN
NERR:
   ERROR("Nesting: ",WORK)
   OFLAG = OLDOFLAG
   PROCESS
%END



%ROUTINE DOINCLUDE
! Include a named file
! Syntax: @INC string-expression
   %INTEGER OLDTBP,FILE
%string(31) vaxfile
   OLDTBP = TBP
   RTOKEN; !read @INC
   FILE = STRINGEXP
   REVERT %IF WORK#0
   %IF INCLUDEFLAG>2 %START
      ERROR("@INCLUDEs nested too deep",-1)
      %RETURN
   %FINISH
   INCLUDEFLAG = INCLUDEFLAG+1
vaxfile=""
%cycle
   tbp=tbp-1
   %exit %if tbp=oldtbp
   vaxfile=tostring(temp(tbp)).vaxfile
%repeat
   OPENINPUT(INCLUDEFLAG,vaxFILE)
   PUSH(ENDINC)
   PUSHLINE(1)
   SELECTINPUT(INCLUDEFLAG)
   PUSH(0)
   TBP = OLDTBP; !throw away the filename
%END



%ROUTINE DODEFINE
! Process a @DEF or @RED instruction
! Syntax: @DEF tag = expression {, tag = expression}
   %INTEGER WHICH,NAME,OLDTBP
   %RECORD(EXPF) V
   OLDTBP = TBP
   WHICH = TOKEN
   %CYCLE
      RTOKEN; !read @DEF or ","
      %IF WORK=0 %THEN -> ERR; !not a tag
      NAME = WORK; RTOKEN
      %IF TOKEN#'=' %THEN -> ERR
      RTOKEN
      EVALUATE(V); !expression of any type
      %IF V_TYPE=STRINGTYPE %START
         ! string may be in temporary area
         V_VALUE = PERMANENT(V_VALUE)
      %FINISH
      !ignore if skipping
      %IF OFLAG=0 %START
         %IF WHICH=DEFINE %START
            ENTER(NAME,LEVEL,V_TYPE,V_VALUE)
         %finish %ELSE %start
            NEWVAL(NAME,V_TYPE,V_VALUE)
         %FINISH
      %FINISH
      TBP = OLDTBP; !clear out any string constants
      %IF TOKEN#',' %THEN %RETURN
   %REPEAT
ERR:
   SYNTAX
%END



%ROUTINE PROCESS
! Process the input, dealing with any
! meta-constructs encountered
   %INTEGER W

   %CYCLE
      COPY; RTOKEN; !find something interesting


ALREADY: ;!got something interesting by mistake
      %IF TOKEN=DEFINE %OR TOKEN=REDEF %START
         ! @DEF or @RED - perform the assignment
         DODEFINE
         -> ALREADY %IF WORK#0


      %finishELSEIF TOKEN=ELSE %OR TOKEN=ELIF %OR TOKEN=FINISH %OR %C
      TOKEN=REPEAT %OR TOKEN=END %OR TOKEN=MEND %START
         %RETURN; !Not for us on this level


      %finishELSEIF TOKEN=IF %OR TOKEN=UNLESS %START
        ! @IF statement - process it
        DOIF


      %finishELSEIF TOKEN=INCLUDE %START
         ! @INC filename - push onto input stack
         DOINCLUDE
         -> ALREADY %IF WORK#0


      %finishELSEIF TOKEN=CYCLE %OR TOKEN=FOR %OR TOKEN=TO %START
         ! @CYC-@REP loop - expand it
         DOCYCLE


      %finishELSEIF TOKEN=MACRO %START
         ! Macro definition
         STOREMACRO


      %finishELSEIF TOKEN=MACTYPE %START
         ! Macro evaluation
         EXPANDMACRO



      %finishELSEIF TOKEN=WHILE %OR TOKEN=UNTIL %START
         ! @WHI statement -evaluate and maybe go on
         W = TRUE; W = FALSE %IF TOKEN=UNTIL
         RTOKEN
         %UNLESS W=CONDITION %START
            WFLAG = OFLAG %IF WFLAG=32767
            OFLAG = 1; !inhibit output
         %FINISH
         -> ALREADY %IF WORK#0


      %finishELSEIF TOKEN=EOF %START
         ! End-of-input
         MONITOR(0)
         %RETURN


      %finishELSEIF TOKEN=BEGIN %START
         ! @BEGIN...@END block
         DOBLOCK



      %finishELSEIF TOKEN=EVAL %START
         DOEVAL



      %finishELSEIF TOKEN=ERR %START
         DOERROR
         -> ALREADY %IF WORK#0

      %finish %ELSE %start
         W = TOKEN!16_8000; W = WORK %IF WORK#0
         ERROR("Context: ",W)
         SKIPTONL
      %FINISH


   %REPEAT
%END

RETURN CODE=DEF STREAMS(CLIPARAM,DEFAULTS)
->DONE %UNLESS RETURN CODE=1

RESERVE
SELECTINPUT(1); SELECTOUTPUT(1)
PROCESS

DONE:
%ENDOFPROGRAM