'BEGIN'

# IMPLEMENTATION RESTRICTIONS #

'INT' SPOOLSIZE = 400,
   STLIM = 50,
   ARGLIM = 5,
   RSLIM = 80,
   PSLIM = 20,
   FTLIM = 10 ;

# ABSTRACT MACHINE #

'MODE' 'ITEM' = 'UNION' ('INT', 'REF''STRINGITEM', 'PATTERN'),
   'STRINGITEM' = 'STRUCT' ('STRING' VAL, 'REF''ITEM' REF),
   'PATTERN' = 'REF'[]'COMPONENT',
   'COMPONENT' = 'STRUCT' ('INT' ROUTINE, SUBSEQUENT, ALTERNATE,
                                 EXTRA, 'REF''ITEM' ARG),
'MODE' 'PSENTRY' = 'STRUCT' ('INT' CURSOR, ALTERNATE),
   'RSENTRY' = 'REF''ITEM',
   'FTENTRY' = 'STRUCT' ('REF''ITEM' FNNAME, ENTRY NAME,
                         'REF'[]'REF''ITEM' PARAMS, LOCALS) ;
[1:SPOOLSIZE] 'REF''ITEM' SPOOL, 'INT' NIN,
'BOOL' FAILED := 'FALSE',
[1:PSLIM] 'PSENTRY' PATTERN STACK, 'INT' PSP,
[1:RSLIM] 'RSENTRY' RUN STACK, 'INT' RSP := 0,
[1:FTLIM] 'FTENTRY' FUNCTION TABLE, 'INT' FTP := 0 ;
'INT' MSTR = 1, MLEN = 2, MBRK = 3, MSPN = 4, MANY = 5, MNUL = 6,
   MIV1 = 7, MIV2 = 8, M1 = 9, MAT = 10, MPOS = 11, MTAB = 12,
   MRPOS = 13, MRTAB = 14, MNTY = 15 ;

# INTERNAL FORM OF PROGRAMS #

'MODE' 'STMT' = 'STRUCT' ('REF''IDR' LABEL,
                          'UNION' ('REF''ASMT', 'REF''MATCH',
                             'REF''REPL', 'REF''EXPR') STMT CORE,
                          'REF''GOTOFIELD' GOTO),
   'IDR' = 'STRUCT' ('REF''ITEM' IDR ADDR),
   'NUM' = 'STRUCT' ('REF''ITEM' NUM ADDR),
   'LSTR' = 'STRUCT' ('REF''ITEM' LSTR ADDR),
   'ASMT' = 'STRUCT' ('REF''EXPR' SUBJECT, OBJECT),
   'MATCH' = 'STRUCT' ('REF''EXPR' SUBJECT, PATTERN),
   'REPL' = 'STRUCT' ('REF''EXPR' SUBJECT, PATTERN, OBJECT),
   'EXPR' = 'UNION' ('REF''UNARYEXPR', 'REF''BINARYEXPR', 'IDR', 'NUM',
                     'LSTR', 'REF''CALL'),
   'GOTOFIELD' = 'STRUCT' ('REF''DEST' UPART, SPART, FPART),
   'DEST' = 'UNION' ('REF''EXPR', 'CHAR'),
   'UNARYEXPR' = 'STRUCT' ('REF''EXPR' OPERAND, 'CHAR' OPERATOR),
   'BINARYEXPR' = 'STRUCT' ('REF''EXPR' OPERAND1, OPERAND2,
                            'CHAR' OPERATOR),
   'CALL' = 'STRUCT' ('IDR' FNNAME, 'REF'[]'REF''EXPR' ARGS) ;

'REF'[]'STMT' T ,
'REF''ITEM' PROG ENTRY := 'NIL' ;

'PROC' ERROR = ('STRING' MESS) 'VOID' : (
   PRINT ((NEWLINE, NEWLINE, "---", MESS, "---")) ;
   STOP ) ;

'BEGIN'        # TRANSLATION PHASE #

# DECLARATIONS FOR SCANNER #

[1:80] 'CHAR' CARD, 'INT' CP,   # SOURCE LINE AND POINTER #
'CHAR' CH,                      # SOURCE CHARACTER #
[1:80] 'CHAR' STR, 'INT' SP,    # STRING BUFFER AND POINTER #
'CHAR' TOK,                     # TOKEN CODE #
'REF''ITEM' PSN,                # POSITION OF A CREATED VALUE #
'INT' NV,                       # NUMERIC VALUE OF CONSTANT #
'INT' STN,                      # SOURCE STATEMENT NUMBER #
'BOOL' LISTING,                 # FLAG FOR SOURCE LISTING #
'CHAR' C ;                      # TEMPORARY #

# TOKEN MNEMONICS #

'CHAR' DOLL    = "$",    BDOLL   = "D",
       PLUS    = "+",    BPLUS   = "P",
       MINUS   = "-",    BMINUS  = "M",
       AT      = "@",    BBAR    = "!",
       BSTAR   = "*",    BSLASH  = "/",
       LPAR    = "(",    RPAR    = ")",
       COMMA   = ",",    COLON   = ":",
       EQUAL   = "=",    BLANK   = " ",
       EOS     = ";",    NAME    = "A",
       LSTRING = "L",    NUMBER  = "U",
       ENDT    = "E",    RET     = "R",
       FRET    = "F",    STOK    = "Y",
       FTOK    = "Z" ;

'PROC' GET CARD = 'VOID' : (
   CP := 0 ;
   'WHILE' READ (CARD) ;
      C := CARD[1] ;
      'IF' C /= "." 'AND' C /= "+" 'AND' C /= "-" 'AND' C /= "*" 'THEN'
         STN := STN + 1 'FI' ;
      'IF' LISTING 'THEN' PRINT ((STN, "    ", CARD, NEWLINE)) 'FI' ;
      'IF' C = "-"
      'THEN' 'IF' CARD[2:5] = "LIST"
         'THEN' LISTING := 'TRUE'
         'ELIF' CARD[2:7] = "UNLIST"
         'THEN' LISTING := 'FALSE'
         'FI'
      'FI' ;
      C = "-" 'OR' C = "*"
   'DO' 'SKIP' 'OD' ) ;

'PROC' NEXT CH = 'VOID' :
   'IF' CP = 80
   'THEN' GET CARD ;
      'IF' C = "." 'OR' C = "+"
      'THEN' CH := " " ;  CP := 1
      'ELSE' CH := "#"   # END OF LINE AND STATEMENT #
      'FI'
   'ELSE' CH := CARD [CP +:= 1]
   'FI' ;

'PROC' LOOKUP = ('STRING' SV) 'REF''ITEM' : (
   'INT' I := 0, 'BOOL' NF := 'TRUE' ;
   'WHILE' 'IF' (I +:= 1) <= NIN
      'THEN' NF := SV /= VAL 'OF' (SPOOL[I] ! ('REF''STRINGITEM' S) : S)
      'ELSE' 'FALSE'
      'FI'
   'DO' 'SKIP' 'OD' ;
   'IF' NF
   'THEN' 'IF' NIN = SPOOLSIZE 'THEN' ERROR ("TOO MANY STRINGS") 'FI' ;
      SPOOL [NIN +:= 1] := 'HEAP''ITEM' := 'HEAP''STRINGITEM' :=
                                                   (SV, 'NIL') 'FI' ;
   SPOOL[I] ) ;

'PROC' SCAN = 'VOID' :
   'IF' CH = " "    # BLANKS AND BINARY OPERATORS #
   'THEN' 'WHILE' NEXT CH ; CH = " " 'DO' 'SKIP' 'OD' ;
      # IGNORE TRAILING BLANKS IN A STATEMENT #
      'IF' CH = ";"
      'THEN' NEXT CH ;  STN := STN + 1 ;  TOK := EOS
      'ELIF' CH = "#"
      'THEN' NEXT CH ;  TOK := EOS
      'ELIF' CH = "!" 'OR' CH = "$" 'OR' CH = "+" 'OR' CH = "-"
                      'OR' CH = "*" 'OR' CH = "/"
      'THEN' 'IF' CARD[CP+1] = " "
         'THEN' C := CH ;
            'WHILE' NEXT CH ; CH = " " 'DO' 'SKIP' 'OD' ;
            TOK := (C = "!" ! BBAR !: C = "$" ! BDOLL !: C = "-" !
               BMINUS !: C = "+" ! BPLUS !: C = "*" ! BSTAR ! BSLASH)
         'ELSE' TOK := BLANK
         'FI'
      'ELSE' TOK := BLANK
      'FI'
   'ELIF' CH = "'" 'OR' CH = """"    # LITERAL STRINGS #
   'THEN' C := CH ;  SP := 0 ;
      'WHILE' NEXT CH ;
         'IF' CH = "#" 'THEN' ERROR ("UNTERMINATED LITERAL") 'FI' ;
         (STR [SP +:= 1] := CH) /= C
      'DO' 'SKIP' 'OD' ;
      NEXT CH ;
      TOK := LSTRING  ;
      'IF' SP = 1
      'THEN' PSN := 'NIL'
      'ELSE' 'STRING' S = STR[1:SP-1] ;
         PSN := LOOKUP (S)
      'FI'
   'ELIF' CH >= "0" 'AND' CH <= "9"    # NUMBERS #
   'THEN' NV := 0 ;
      'WHILE' NV := NV * 10 + 'ABS' CH - 'ABS' "0" ;
         NEXT CH ;
         CH >= "0" 'AND' CH <= "9"
      'DO' 'SKIP' 'OD' ;
      TOK := NUMBER ;
      PSN := 'HEAP''ITEM' := NV
   'ELIF' CH >= "A" 'AND' CH <= "Z"    # NAMES #
   'THEN' SP := 0 ;
      'WHILE' STR [SP +:= 1] := CH ;
         NEXT CH ;
         CH = "." 'OR' CH >= "A" 'AND' CH <= "Z" 'OR'
                       CH >= "0" 'AND' CH <= "9"
      'DO' 'SKIP' 'OD' ;
      'STRING' S = STR[1:SP] ;
      TOK := (S = "S" ! STOK !: S = "F" ! FTOK !: S = "END" ! ENDT
                !: S = "RETURN" ! RET !: S = "FRETURN" ! FRET
                ! PSN := LOOKUP (S) ;  NAME)
   'ELIF' CH = ";"
   'THEN' NEXT CH ;  STN := STN + 1 ;  TOK := EOS
   'ELIF' CH = "#"
   'THEN' NEXT CH ;  TOK := EOS
   'ELSE'   #  ( ) , : = @ $ + -  #
      TOK := CH ;  NEXT  CH
   'FI' ;

'PROC' INIT = 'VOID' : (
   STN := 0 ;  LISTING := 'TRUE' ;
   SPOOL [NIN := 1] := 'HEAP''ITEM' := 'HEAP''STRINGITEM' :=
                   ("ARB", 'HEAP''ITEM' := 'HEAP'[1:3]'COMPONENT' :=
                     ( (MNUL, 2, 0, 'SKIP', 'NIL'),
                       (MNUL, 0, 3, 'SKIP', 'NIL'),
                       (M1, 2, 0, 'SKIP', 'NIL')   ) ) ;
   GET CARD ;
   NEXT CH ;
   SCAN ) ;

'PROC' VERIFY = ('CHAR' TOKEN) 'VOID' :
   'IF' TOK = TOKEN 'THEN' SCAN
   'ELSE' 'STRING' S := "TOKEN "" "" DOES NOT OCCUR WHERE EXPECTED" ;
      S[8] := TOKEN ;
      ERROR (S)
   'FI' ;

'PROC' TRANSLATE = 'VOID' : (
   'HEAP'[1:STLIM]'STMT' SS, 'INT' SSC := 0 ;
   'WHILE' 'IF' SSC = STLIM 'THEN' ERROR ("TOO MANY STATEMENTS") 'FI' ;
      TOK /= ENDT
   'DO' SS[SSC +:= 1] := TRANS STMT
   'OD' ;
   SCAN ;
   'IF' TOK = BLANK
   'THEN' SCAN ;
      'IF' TOK = NAME 'THEN' PROG ENTRY := PSN 'FI'
   'FI' ;
   T := SS[1:SSC] ) ;

'PROC' TRANS STMT = 'STMT' : (
   'REF''IDR' LAB := 'NIL',
   'REF''EXPR' SUBJ, PAT, OBJ := 'NIL',
   'REF' 'GOTOFIELD' GO := 'NIL',
   'BOOL' ASGN ;

   'PROC' MOVE TO OBJ = 'STMT' : (
      'IF' TOK = BLANK
      'THEN' SCAN ;
         'IF' TOK = COLON
         'THEN' GO := TRANS GOFIELD
         'ELSE' OBJ := TRANS EXPR ;
            'IF' TOK = COLON
            'THEN' GO := TRANS GOFIELD
            'ELSE' VERIFY (EOS)
            'FI'
         'FI'
      'ELSE' VERIFY (EOS)
      'FI' ;
      'IF' ASGN
      'THEN' 'STMT' (LAB, 'HEAP''ASMT' := (SUBJ, OBJ), GO)
      'ELSE' 'STMT' (LAB, 'HEAP''REPL' := (SUBJ, PAT, OBJ), GO)
      'FI' ) ;

   'PROC' MOVE TO SUBJ = 'STMT' : (
      SCAN ;
      'IF' TOK = COLON
      'THEN' 'STMT' (LAB, 'REF''EXPR' ('NIL'), TRANS GOFIELD)
      'ELSE' SUBJ := TRANS ELEM ;
         'IF' TOK = BLANK
         'THEN' SCAN ;
            'IF' TOK = COLON
            'THEN' 'STMT' (LAB, 'REF''EXPR' (SUBJ), TRANS GOFIELD)
            'ELIF' TOK = EQUAL
            'THEN' ASGN := 'TRUE' ;  SCAN ;  MOVE TO OBJ
            'ELSE' PAT := TRANS EXPR ;
               'IF' TOK = COLON
               'THEN' 'STMT' (LAB, 'HEAP''MATCH' := (SUBJ, PAT),
                                            TRANS GOFIELD)
               'ELIF' TOK = EQUAL 'THEN' ASGN := 'FALSE' ;  SCAN ;
                     MOVE TO OBJ
               'ELSE' VERIFY (EOS) ;
                  'STMT' (LAB, 'HEAP''MATCH' := (SUBJ, PAT), 'NIL')
               'FI'
            'FI'
         'ELSE' VERIFY (EOS) ;
            'STMT' (LAB, 'REF''EXPR' (SUBJ), 'NIL')
         'FI'
      'FI' ) ;

   # BODY OF TRANS STMT #
   'IF' TOK = NAME
   'THEN' LAB := 'HEAP''IDR' ;  IDR ADDR 'OF' LAB := PSN ;  SCAN ;
      'IF' TOK = BLANK
      'THEN' MOVE TO SUBJ
      'ELSE' VERIFY (EOS) ;
         'STMT' (LAB, 'REF''EXPR' ('NIL'), 'NIL')
      'FI'
   'ELIF' TOK = BLANK
   'THEN' MOVE TO SUBJ
   'ELSE' VERIFY (EOS) ;
      'STMT' (LAB, 'REF''EXPR' ('NIL'), 'NIL')
   'FI' ) ;

'PROC' TRANS GOFIELD = 'REF''GOTOFIELD' : (

   'PROC' WHERE = 'REF''DEST' : (
      'HEAP''DEST' D ;
      VERIFY (LPAR) ;
      'IF' TOK = BLANK 'THEN' SCAN 'FI' ;
      D := (TOK = ENDT ! SCAN ; "E" !: TOK = RET ! SCAN ; "R"
             !: TOK = FRET ! SCAN ; "F" ! TRANS EXPR) ;
      VERIFY (RPAR) ;
      D ) ;

   'REF''DEST' UNCOND := 'NIL', SUCC := 'NIL', FAIL := 'NIL' ;
   SCAN ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ;
   'IF' TOK = STOK
   'THEN' SCAN ;  SUCC := WHERE ;
      'IF' TOK = BLANK 'THEN' SCAN 'FI' ;
      'IF' TOK = FTOK 'THEN' SCAN ; FAIL := WHERE 'FI' ;
      VERIFY (EOS)
   'ELIF' TOK = FTOK
   'THEN' SCAN ;  FAIL := WHERE ;
      'IF' TOK = BLANK 'THEN' SCAN 'FI' ;
      'IF' TOK = STOK 'THEN' SCAN ;  SUCC := WHERE 'FI' ;
      VERIFY (EOS)
   'ELSE' UNCOND := WHERE ;  VERIFY (EOS)
   'FI' ;
   'HEAP''GOTOFIELD' := (UNCOND, SUCC, FAIL) ) ;

'PROC' TRANS EXPR = 'REF''EXPR' : (
   'REF''EXPR' E := TRANS EXPR1 ;
   'WHILE' TOK = BBAR 'DO'
      SCAN ;
      E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS EXPR1, "!")
   'OD' ;
   E ) ;

'PROC' TRANS EXPR1 = 'REF''EXPR' : (
   'REF''EXPR' E := TRANS EXPR2 ;
   'WHILE' TOK = BLANK 'DO' SCAN;
      'IF' TOK /= COLON 'AND' TOK /= RPAR 'AND' TOK /= COMMA 'AND'
           TOK /= EQUAL
      'THEN' E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' :=
                 (E, TRANS EXPR2, "C")
      'FI'
   'OD' ;
   E ) ;

'PROC' TRANS EXPR2 = 'REF''EXPR' : (
   'REF''EXPR' E := TRANS TERM ;  'CHAR' OPR ;
   'WHILE' TOK = BPLUS 'OR' TOK = BMINUS 'DO'
      OPR := (TOK = BPLUS ! "+" ! "-") ;  SCAN ;
      E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS TERM, OPR)
   'OD' ;
   E ) ;

'PROC' TRANS TERM = 'REF''EXPR' : (
   'REF''EXPR' E := TRANS TERM1 ;
   'WHILE' TOK = BSLASH 'DO'
      SCAN ;
      E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS TERM1, "/")
   'OD' ;
   E ) ;

'PROC' TRANS TERM1 = 'REF''EXPR' : (
   'REF''EXPR' E := TRANS TERM2 ;
   'WHILE' TOK = BSTAR 'DO'
      SCAN ;
      E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS TERM2, "*")
   'OD' ;
   E ) ;

'PROC' TRANS TERM2 = 'REF''EXPR' : (
   'REF''EXPR' E := TRANS ELEM ;
   'WHILE' TOK = BDOLL 'DO'
      SCAN ;
      E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS ELEM, "$")
   'OD' ;
   E ) ;

'PROC' TRANS ELEM = 'REF''EXPR' :
   'IF' TOK = DOLL 'OR' TOK = PLUS 'OR' TOK = MINUS 'OR' TOK = AT
   'THEN' 'CHAR' OPR = TOK ;  SCAN ;
      'HEAP''EXPR' := 'HEAP''UNARYEXPR' := (TRANS ELEMENT, OPR)
   'ELSE' TRANS ELEMENT
   'FI' ;

'PROC' TRANS ELEMENT = 'REF''EXPR' :
   'IF' TOK = NAME
   'THEN' 'IDR' N ;  IDR ADDR 'OF' N := PSN ;
      SCAN ;
      'IF' TOK /= LPAR
      'THEN' 'HEAP''EXPR' := N
      'ELSE' 'HEAP'[1:ARGLIM]'REF''EXPR' A, 'INT' AC := 0 ;
         'WHILE' SCAN ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ;
            'IF' AC = ARGLIM 'THEN' ERROR (
               "TOO MANY ARGUMENTS IN FUNCTION CALL") 'FI' ;
            'IF' 'NOT' (AC = 0 'AND' TOK = RPAR) 'THEN' A[AC +:= 1] :=
               (TOK = COMMA 'OR' TOK = RPAR ! 'NIL' ! TRANS EXPR) 'FI' ;
            'IF' TOK /= COMMA 'AND' TOK /= RPAR 'THEN' ERROR (
               "ERROR IN ARGUMENT LIST") 'FI' ;
            TOK = COMMA
         'DO' 'SKIP' 'OD' ;
         SCAN ;
         'HEAP''EXPR' := 'HEAP''CALL' := (N, A[1:AC])
      'FI'
   'ELIF' TOK = LSTRING
   'THEN' 'LSTR' LS ;  LSTR ADDR 'OF' LS := PSN ;  SCAN ;
      'HEAP''EXPR' := LS
   'ELIF' TOK = NUMBER
   'THEN' 'NUM' NU ;  NUM ADDR 'OF' NU := PSN ;  SCAN ;
      'HEAP''EXPR' := NU
   'ELSE' VERIFY (LPAR) ;
      'IF' TOK = BLANK 'THEN' SCAN 'FI' ;
      'REF''EXPR' E = TRANS EXPR ;
      VERIFY (RPAR) ;
      E
   'FI' ;

INIT ;
TRANSLATE

'END'          # TRANSLATION PHASE # ;


'BEGIN'        # INTERPRETATION PHASE #

'OP' 'INTG' = ('REF''ITEM' A) 'INT' : (A ! ('INT' I) : I),
     'STR' = ('REF''ITEM' A) 'REF''STRINGITEM' :
        (A ! ('REF''STRINGITEM' S) : S),
     'PAT' = ('REF''ITEM' A) 'PATTERN' : (A ! ('PATTERN' P) : P) ;
'BOOL' FN SUCCESS ;

'PROC' INTERPRET = ('INT' STMT NO) 'VOID' : (
   'INT' SN := STMT NO ; 'BOOL' CYCLING := 'TRUE' ;

   'PROC' JUMP = ('REF''DEST' DEST) 'VOID' : (
      FAILED := 'FALSE' ;
      'CASE' DEST 'IN'
         ('REF''EXPR' E) :
            SN := FIND LABEL (EVAL SOFTLY (E)),
         ('CHAR' C) :
            'IF' C = "E" 'THEN' SN := 'UPB' T + 1
            'ELIF' C = "R" 'THEN' FN SUCCESS := 'TRUE' ;
                                  CYCLING := 'FALSE'
            'ELSE' # C = "F" # FN SUCCESS := CYCLING := 'FALSE'
            'FI'
      'ESAC' ) ;

   'WHILE' CYCLING 'DO'
      'IF' SN > 'UPB' T 'THEN' STOP 'FI' ;
      FAILED := 'FALSE' ;

      # EXECUTE STATEMENT CORE #
      'CASE' STMT CORE 'OF' T[SN] 'IN'
         ('REF''ASMT' A) : (
            'REF''ITEM' SP = EVAL SOFTLY (SUBJECT 'OF' A) ;
            ASSIGN (SP, EVAL STRONGLY (OBJECT 'OF' A)) ),
         ('REF''MATCH' M) : (
            'REF''ITEM' SVP = EVAL STRONGLY (SUBJECT 'OF' M) ;
            MATCH (CONVERT TO STR (SVP), CONVERT TO PAT (
                               EVAL STRONGLY (PATTERN 'OF' M))) ),
         ('REF''REPL' R) : (
            'REF''ITEM' SP = EVAL SOFTLY (SUBJECT 'OF' R) ;
            'REF''ITEM' PP = CONVERT TO PAT (EVAL STRONGLY (
                                              PATTERN 'OF' R)) ;
            'REF''ITEM' SVP = CONVERT TO STR (REF 'OF' ('STR' SP)) ;
            'INT' C = MATCH (SVP, PP) ;
            'REF''ITEM' B = (SVP 'IS' 'NIL' ! 'NIL' !
                            MAKE STR ((VAL 'OF' ('STR' SVP)) [C+1:])) ;
            'REF''ITEM' OBP = EVAL STRONGLY (OBJECT 'OF' R) ;
            ASSIGN (SP, CONCATENATE (OBP, B)) ),
         ('REF''EXPR' E) :
            EVAL STRONGLY (E)
      'ESAC' ;

      # PROCESS GOTO FIELD #
      'REF''GOTOFIELD' GO = GOTO 'OF' T[SN] ;
      'IF' GO 'IS' 'NIL' 'THEN' SN := SN + 1
      'ELIF' 'REF''DEST' (UPART 'OF' GO) 'ISNT' 'NIL' 'THEN'
          JUMP (UPART 'OF' GO)
      'ELIF' 'NOT' FAILED 'AND' ('REF''DEST' (SPART 'OF' GO)
          'ISNT' 'NIL') 'THEN' JUMP (SPART 'OF' GO)
      'ELIF' FAILED 'AND' ('REF''DEST' (FPART 'OF' GO)
          'ISNT' 'NIL') 'THEN' JUMP (FPART 'OF' GO)
      'ELSE' SN := SN + 1
      'FI'
   'OD' )  # END OF INTERPRET # ;

'PROC' FIND LABEL = ('REF''ITEM' LABEL PTR) 'INT' : (
   'INT' STMT NO := 0 ;
   'IF' FAILED 'THEN' ERROR ("FAILURE IN GOTO FIELD") 'FI' ;
   'FOR' I 'TO' 'UPB' T 'WHILE' STMT NO = 0 'DO'
      'IF' ('REF''IDR' (LABEL 'OF' T[I]) 'IS' 'NIL' ! 'FALSE' !
                   LABEL PTR 'IS' IDR ADDR 'OF' LABEL 'OF' T[I])
      'THEN' STMT NO := I
      'FI'
   'OD' ;
   'IF' STMT NO = 0 'THEN' ERROR ("UNDEFINED LABEL") 'FI' ;
   STMT NO ) ;

'PROC' MATCH = ('REF''ITEM' SUBJECT PTR, PATTERN PTR) 'INT' :
   'IF' FAILED 'THEN' 0 'ELSE'
   'PATTERN' P = 'PAT' PATTERN PTR ;  'STRING' SUBJ = (SUBJECT PTR 'IS'
      'NIL' ! "" ! VAL 'OF' ('STR' SUBJECT PTR)) ;
      'INT' U = 'UPB' SUBJ ;
   'INT' IARG       # INTEGER COMPONENT ARGUMENT # ,
   'STRING' SARG    # STRING COMPONENT ARGUMENT # ,
   'INT' L          # LENGTH OF SARG # ;
   'INT' CN := 1    # COMPONENT NUMBER # ,
         C := 0     # CURSOR # ,
         CODE       # NEW CURSOR OR -1 IF COMPONENT NO-MATCH # ;
   'BOOL' MATCHING := 'TRUE' ;
   PSP := 0         # CLEAR PATTERN STACK # ;

   'WHILE' MATCHING 'DO'
      'IF' ALTERNATE 'OF' P[CN] /= 0 'THEN' # PUSH PATTERN STACK #
         PATTERN STACK [PSP +:= 1] := (C, ALTERNATE 'OF' P[CN]) 'FI' ;
      'IF' 'REF''ITEM' (ARG 'OF' P[CN]) 'ISNT' 'NIL' 'THEN'
         'CASE' ARG 'OF' P[CN] 'IN'
            ('INT' I) : IARG := I,
            ('REF''STRINGITEM' S) : (
               SARG := VAL 'OF' S ;  L := 'UPB' SARG )
         'ESAC' 'FI' ;

      # EXECUTE INDICATED MATCHING ROUTINE #
      'CASE' ROUTINE 'OF' P[CN] 'IN'
         #MSTR #
            'IF' 'REF''ITEM'(ARG 'OF' P[CN]) 'IS' 'NIL' 'THEN' CODE := C
            'ELIF' C + L > U 'THEN' CODE := -1
            'ELSE' CODE := (SARG = SUBJ[C+1:C+L] ! C + L ! -1)
            'FI',
         # MLEN #
            CODE := (IARG <= U - C ! C + IARG ! -1),
         # MBRK #
            'IF' C >= U 'THEN' CODE := -1 'ELSE'
               'INT' N = BREAK SCAN (SUBJ[C+1:], SARG) ;
               CODE := (N < U - C ! C + N ! -1) 'FI',
         # MSPN #
            'IF' C >= U 'THEN' CODE := -1
            'ELIF' ANY (SARG, SUBJ[C+1])
            'THEN' 'INT' J := C + 1 ;
               'FOR' I 'FROM' C + 2 'TO' U 'WHILE' ANY (SARG, SUBJ[I])
                  'DO' J := I 'OD' ;
               CODE := J
            'ELSE' CODE := -1
            'FI',
         # MANY #
            'IF' C >= U 'THEN' CODE := -1 'ELSE'
               CODE := (ANY (SARG, SUBJ[C+1]) ! C + 1 ! -1) 'FI',
         # MNUL #
            CODE := C,
         # MIV1 #
            CODE := EXTRA 'OF' P[CN] := C,
         # MIV2 # (
            'INT' M = EXTRA 'OF' P [CN - EXTRA 'OF' P[CN]] + 1 ;
            ASSIGN (ARG 'OF' P[CN], MAKE STR (SUBJ[M:C])) ;
            CODE := C ) ,
         # M1 #
            CODE := (1 <= U - C ! C + 1 ! -1),
         # MAT # (
            ASSIGN (ARG 'OF' P[CN], MAKE INT (C)) ;
            CODE := C ),
         # MPOS #
            CODE := (C = IARG ! C ! -1),
         # MTAB #
            CODE := (C <= IARG 'AND' IARG <= U ! IARG ! -1),
         # MRPOS #
            CODE := (U - C = IARG ! C ! -1),
         # MRTAB #
            CODE := (U - C >= IARG ! U - IARG ! -1),
         # MNTY #
            'IF' C >= U 'THEN' CODE := -1 'ELSE'
               CODE := (ANY (SARG, SUBJ[C+1]) ! -1 ! C + 1) 'FI'
      'ESAC' ;

      # DECIDE WHAT TO DO NEXT #
      'IF' CODE >= 0
      'THEN' 'IF' SUBSEQUENT 'OF' P[CN] = 0
         'THEN' MATCHING := 'FALSE' #SUCCESSFUL TERMINATION #
         'ELSE' CN := SUBSEQUENT 'OF' P[CN] ;  C := CODE  # CONTINUE #
         'FI'
      'ELIF' PSP = 0
      'THEN' FAILED := 'TRUE' ;  MATCHING := 'FALSE'  # STMT FAILURE #
      'ELSE'  # POP PATTERN STACK TO BACKTRACK #
         CN := ALTERNATE 'OF' PATTERN STACK [PSP] ;
         C := CURSOR 'OF' PATTERN STACK [PSP] ;  PSP := PSP - 1
      'FI'
   'OD' ;
   (FAILED ! 0 ! CODE)
   'FI'  # END OF MATCH PROCEDURE # ;

'PROC' ASSIGN = ('REF''ITEM' SUBJECT PTR, OBJECT PTR) 'VOID' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'REF''STRINGITEM' S = 'STR' SUBJECT PTR ;
   REF 'OF' S := OBJECT PTR ;
   'IF' VAL 'OF' S = "OUTPUT"
   'THEN' PRINT (
      'IF' OBJECT PTR 'IS' 'NIL' 'THEN' NEWLINE
      'ELSE' 'CASE' OBJECT PTR 'IN'
                ('REF''STRINGITEM' R) : (VAL 'OF' R, NEWLINE),
                ('INT' I) : (WHOLE (I, 0), NEWLINE),
                ('PATTERN') : (ERROR ("ATTEMPT TO OUTPUT PATTERN") ;
                   'SKIP')
             'ESAC'
      'FI' )
   'FI'
   'FI' ;

'PROC' EVAL SOFTLY = ('REF''EXPR' EXPRESSION) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'CASE' EXPRESSION # CAN NEVER BE NIL # 'IN'
      ('IDR' ID) :
         IDR ADDR 'OF' ID,
      ('REF''UNARYEXPR' UE) :
         'IF' OPERATOR 'OF' UE = "$"
         'THEN' 'REF''ITEM' R = CONVERT TO STR (EVAL STRONGLY (
                   OPERAND 'OF' UE)) ;
            'IF' R 'IS' 'NIL'
            'THEN' ERROR ("NULL RESULT WHERE VAR REQUIRED") ; 'SKIP'
            'ELSE' R
            'FI'
         'ELSE' ERROR ("INAPPROPRIATE UNARY EXPR WHERE VAR REQUIRED") ;
            'SKIP'
         'FI'
   'OUT' ERROR ("INAPPROPRIATE EXPR WHERE VAR REQUIRED") ; 'SKIP'
   'ESAC'
   'FI' ;

'PROC' EVAL STRONGLY = ('REF''EXPR' EXPRESSION) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP'
   'ELIF' EXPRESSION 'IS' 'NIL' 'THEN' 'NIL' 'ELSE'
   'CASE' EXPRESSION 'IN'
      ('IDR' ID) : (
         'REF''STRINGITEM' S = 'STR' (IDR ADDR 'OF' ID) ;
         'IF' VAL 'OF' S = "INPUT"
         'THEN' 'STRING' LINE;  'FILE' STIN := STANDIN ;
            ON LOGICAL FILE END (STIN,
               ('REF''FILE' F) 'BOOL' : (
                  FAILED := 'TRUE' ;  'GOTO' EOF ;  'SKIP')) ;
            GET (STIN, (NEWLINE, LINE)) ;
            ASSIGN (IDR ADDR 'OF' ID, MAKE STR (LINE)) ;
            EOF : 'SKIP'
         'FI' ;
         REF 'OF' S ),
      ('NUM' NBR) :
         NUM ADDR 'OF' NBR,
      ('LSTR' LS) :
         LSTR ADDR 'OF' LS,
      ('REF''UNARYEXPR' UE) : (
        'REF' 'ITEM' ARG PTR = (OPERATOR 'OF' UE = "@" ! EVAL SOFTLY (
            OPERAND 'OF' UE) ! EVAL STRONGLY (OPERAND 'OF' UE)) ;
         EVAL UNARY (ARG PTR, OPERATOR 'OF' UE) ),
      ('REF''BINARYEXPR' BE) : (
         'REF''ITEM' ARG1 PTR = EVAL STRONGLY (OPERAND1 'OF' BE) ;
         'REF''ITEM' ARG2 PTR = (OPERATOR 'OF' BE = "$" ! EVAL SOFTLY (
            OPERAND2 'OF' BE) ! EVAL STRONGLY (OPERAND2 'OF' BE)) ;
         EVAL BINARY (ARG1 PTR, ARG2 PTR, OPERATOR 'OF' BE) ),
      ('REF''CALL' CL) : (
         'INT' N = 'UPB' ARGS 'OF' CL ;
         [1:N]'REF''ITEM' ARGLIST ;
         'FOR' I 'TO' N 'DO'
            ARGLIST[I] := EVAL STRONGLY ((ARGS 'OF' CL)[I]) 'OD' ;
         EVAL CALL (IDR ADDR 'OF' FNNAME 'OF' CL, ARGLIST) )
   'ESAC'
   'FI' ;

'PROC' EVAL UNARY = ('REF''ITEM' ARG PTR, 'CHAR' OPR) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'IF' OPR = "$" 'THEN'
      'IF' ARG PTR 'IS' 'NIL'
      'THEN' ERROR ("INDIRECTION APPLIED TO NULL STRING") ; 'SKIP'
      'ELSE' REF 'OF' ('STR' CONVERT TO STR (ARG PTR))
      'FI'
   'ELIF' OPR = "+" 'THEN'
      CONVERT TO INT (ARG PTR)
   'ELIF' OPR = "-" 'THEN'
      'INT' K = 'INTG' CONVERT TO INT (ARG PTR) ;
      MAKE INT (-K)
   'ELSE' # OPR = "@" #
      MAKE PAT COMP (MAT, ARG PTR)
   'FI'
   'FI' ;

'PROC' EVAL BINARY = ('REF''ITEM' ARG1 PTR, ARG2 PTR, 'CHAR' OPR)
      'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'IF' OPR = "$"
   'THEN' 'REF''ITEM' C = CONCATENATE (MAKE PAT COMP (MIV1, 'NIL'),
                                       ARG1 PTR) ;
      CONCATENATE (C, MAKE PAT COMP (MIV2, ARG2 PTR))
   'ELIF' OPR = "*" 'OR' OPR = "/" 'OR' OPR = "+" 'OR' OPR = "-"
   'THEN' 'INT' M = 'INTG' CONVERT TO INT (ARG1 PTR),
                N = 'INTG' CONVERT TO INT (ARG2 PTR) ;
      MAKE INT ((OPR = "*" ! M * N !: OPR = "/" ! M 'OVER' N
                  !: OPR = "+" ! M + N ! M - N ))
   'ELIF' OPR = "C"
   'THEN' CONCATENATE (ARG1 PTR, ARG2 PTR)
   'ELSE'  # OPR = "!" #
      'PATTERN' P1 = 'PAT' CONVERT TO PAT (ARG1 PTR),
                P2 = 'PAT' CONVERT TO PAT (ARG2 PTR) ;
      'INT' U1 = 'UPB' P1, U2 = 'UPB' P2 ;
      'PATTERN' P = 'HEAP'[U1 + U2]'COMPONENT',
      'INT' OFFSET = U1 + 1, 'INT' J := 1 ;
      P[1:U1] := P1[1:U1];
      'WHILE' ALTERNATE 'OF' P[J] /= 0 'DO'
         J := ALTERNATE 'OF' P[J]
      'OD' ;
      ALTERNATE 'OF' P[J] := OFFSET ;
      'FOR' I 'FROM' OFFSET 'TO' U1 + U2 'DO'
         P[I] := P2 [I - U1] ;
         'IF' SUBSEQUENT 'OF' P[I] /= 0 'THEN'
            SUBSEQUENT 'OF' P[I] +:= U1 'FI' ;
         'IF' ALTERNATE 'OF' P[I] /= 0 'THEN'
            ALTERNATE 'OF' P[I] +:= U1 'FI'
      'OD' ;
      'HEAP''ITEM' := P
   'FI'
   'FI' ;

'PROC' EVAL CALL = ('REF''ITEM' NAME PTR, 'REF'[]'REF''ITEM' ARGLIST)
      'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'

   # SEARCH FUNCTION TABLE FOR NAME #
   'BOOL' NOT FOUND := 'TRUE', 'INT' J ;
   'FOR' I 'TO' FTP 'WHILE' NOT FOUND 'DO'
      'IF' NAME PTR 'IS' FNNAME 'OF' FUNCTION TABLE [I]
      'THEN' J := I ;  NOT FOUND := 'FALSE'
      'FI'
   'OD' ;

   'IF' NOT FOUND
   'THEN' EXEC PRIM FN (NAME PTR, ARGLIST)
   'ELSE'  #PROGRAMMER-DEFINED FUNCTION #

      'PROC' STACK = ('REF''ITEM' A) 'VOID' : (
         'IF' RSP = RSLIM 'THEN' ERROR ("RUN STACK OVERFLOW") 'FI' ;
         RUN STACK [RSP +:= 1] := A ) ;

      'PROC' UNSTACK = 'REF''ITEM' : (
         'IF' RSP = 0 'THEN' ERROR ("RETURN FROM LEVEL 0") 'FI' ;
         RUN STACK [(RSP -:= 1) + 1] ) ;

      'REF''STRINGITEM' NAME = 'STR' NAME PTR ;

      # ENTRY PROTOCOL #
      STACK (REF 'OF' NAME) ;
      ASSIGN (NAME PTR, 'NIL') ;
      'REF'[]'REF''ITEM' PARAMS = PARAMS 'OF' FUNCTION TABLE [J],
      'INT' N = 'UPB' ARGLIST ;
      'IF' 'UPB' PARAMS /= N 'THEN' ERROR (
         "WRONG NUMBER OF ARGUMENTS IN CALL") 'FI' ;
      'FOR' I 'TO' N 'DO'
         STACK (REF 'OF' ('STR' PARAMS[I])) ;
         ASSIGN (PARAMS[I], ARGLIST[I])
      'OD' ;
      'REF'[]'REF''ITEM' LOCALS = LOCALS 'OF' FUNCTION TABLE [J] ;
      'FOR' I 'TO' 'UPB' LOCALS 'DO'
         STACK (REF 'OF' ('STR' LOCALS[I])) ;
         ASSIGN (LOCALS[I], 'NIL')
      'OD' ;

      INTERPRET (FIND LABEL (ENTRY NAME 'OF' FUNCTION TABLE [J])) ;

      # RETURN PROTOCOL #
      'FOR' I 'FROM' 'UPB' LOCALS 'BY' -1 'TO' 1 'DO'
         ASSIGN (LOCALS[I], UNSTACK)
      'OD' ;
      'FOR' I 'FROM' N 'BY' -1 'TO' 1 'DO'
         ASSIGN (PARAMS[I], UNSTACK)
      'OD' ;
      'REF''ITEM' RESULT = REF 'OF' NAME ;
      ASSIGN (NAME PTR, UNSTACK) ;
      (FN SUCCESS ! RESULT ! FAILED := 'TRUE' ; 'SKIP')
   'FI'
   'FI' ;

'PROC' EXEC PRIM FN = ('REF''ITEM' NAME PTR,
                       'REF'[]'REF''ITEM' ARGLIST) 'REF''ITEM' : (

   'PROC' GEN1 = ('INT' ROUTINE) 'REF''ITEM' : (
      # CREATE PATTERN COMPONENT WITH STRING ARGUMENT #
      'REF''ITEM' ARG = CONVERT TO STR (ARGLIST[1]) ;
      'IF' ARG 'IS' 'NIL' 'THEN' ERROR (
         "NULL ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION" ) 'FI' ;
      MAKE PAT COMP (ROUTINE, ARG) ) ;

   'PROC' GEN2 = ('INT' ROUTINE) 'REF''ITEM' : (
      # CREATE PATTERN COMPONENT WITH INTEGER ARGUMENT #
      'REF''ITEM' ARG = CONVERT TO INT (ARGLIST[1]) ;
      'IF' 'INTG' ARG < 0 'THEN' ERROR (
         "NEGATIVE ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION") 'FI' ;
      MAKE PAT COMP (ROUTINE, ARG) ) ;

   'STRING' FN = VAL 'OF' ('STR' NAME PTR), 'INT' N = 'UPB' ARGLIST ;
   'IF' FN = "LE" 'AND' N = 2 'THEN'
      'IF' 'INTG' CONVERT TO INT (ARGLIST[1]) <= 'INTG' CONVERT TO INT (
         ARGLIST[2]) 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI'
   'ELIF' FN = "EQ" 'AND' N = 2 'THEN'
      'IF' 'INTG' CONVERT TO INT (ARGLIST[1]) = 'INTG' CONVERT TO INT (
         ARGLIST[2]) 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI'
   'ELIF' FN = "NE" 'AND' N = 2 'THEN'
      'IF' 'INTG' CONVERT TO INT (ARGLIST[1]) /= 'INTG' CONVERT TO INT (
         ARGLIST[2]) 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI'
   'ELIF' FN = "IDENT" 'AND' N = 2 'THEN'
      'IF' 'REF''ITEM' (ARGLIST[1]) 'IS' ARGLIST[2] 'THEN' 'NIL'
         'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI'
   'ELIF' FN = "DIFFER" 'AND' N = 2 'THEN'
      'IF' 'REF''ITEM' (ARGLIST[1]) 'ISNT' ARGLIST[2] 'THEN' 'NIL'
         'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI'
   'ELIF' FN = "ANY" 'AND' N = 1 'THEN' GEN1 (MANY)
   'ELIF' FN = "LEN" 'AND' N = 1 'THEN' GEN2 (MLEN)
   'ELIF' FN = "POS" 'AND' N = 1 'THEN' GEN2 (MPOS)
   'ELIF' FN = "TAB" 'AND' N = 1 'THEN' GEN2 (MTAB)
   'ELIF' FN = "SPAN" 'AND' N = 1 'THEN' GEN1 (MSPN)
   'ELIF' FN = "RPOS" 'AND' N = 1 'THEN' GEN2 (MRPOS)
   'ELIF' FN = "RTAB" 'AND' N = 1 'THEN' GEN2 (MRTAB)
   'ELIF' FN = "BREAK" 'AND' N = 1 'THEN' GEN1 (MBRK)
   'ELIF' FN = "NOTANY" 'AND' N = 1 'THEN' GEN1 (MNTY)
   'ELIF' FN = "SIZE" 'AND' N = 1 'THEN'
      MAKE INT ('UPB' VAL 'OF' ('STR' CONVERT TO STR (ARGLIST[1])))

   'ELIF' FN = "DEFINE" 'AND' N = 2 'THEN'
      'IF' 'REF''ITEM' (ARGLIST[1]) 'IS' 'NIL' 'THEN' ERROR (
                 "NULL PROTOTYPE") 'FI' ;
      'STRING' PROTOTYPE = VAL 'OF' ('STR' CONVERT TO STR (ARGLIST[1]));
      'REF''ITEM' ENTRY = CONVERT TO STR (ARGLIST[2]) ;
      'IF' ENTRY 'IS' 'NIL' 'THEN' ERROR ("NULL ENTRY LABEL") 'FI' ;

      'PROC' CHECK AND FIND = ('STRING' STR) 'REF''ITEM' : (
         'IF' 'UPB' STR = 0 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ;
         'STRING' AN = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789." ;
         'IF' 'NOT' ANY (AN[:26], STR[1]) 'THEN'
            ERROR ("ILLEGAL PROTOTYPE") 'FI' ;
         'FOR' I 'FROM' 2 'TO' 'UPB' STR 'DO'
            'IF' 'NOT' ANY (AN, STR[I]) 'THEN'
              ERROR ("ILLEGAL PROTOTYPE") 'FI'
         'OD' ;
         MAKE STR (STR) ) ;

      'PROC' BREAKUP = ('STRING' STR) 'REF'[]'REF''ITEM' : (
         #ANALYZE A LIST OF IDENTIFIERS #
         [1:ARGLIM]'REF''ITEM' R, 'INT' P := 0, A := 1, B ;
         'WHILE' A <= 'UPB' STR 'DO'
            B := BREAK SCAN (STR[A:], ",") ;
            'IF' P >= ARGLIM 'THEN' ERROR (
               "TOO MANY PARAMETERS OR LOCALS IN PROTOTYPE") 'FI' ;
            R [P +:= 1] := CHECK AND FIND (STR[A:A+B-1]) ;
            A := A + B + 1
         'OD' ;
         'HEAP'[1:P]'REF''ITEM' := R[:P] ) ;

      'INT' LP = 'UPB' PROTOTYPE ;
      'INT' A = BREAK SCAN (PROTOTYPE, "(") ;
      'IF' A >= LP 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ;
      'REF''ITEM' NAME PTR = CHECK AND FIND (PROTOTYPE[:A]) ;
      'INT' B = BREAK SCAN (PROTOTYPE[A+2:], ")") ;
      'IF' B >= LP - A - 1 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ;
      'REF'[]'REF''ITEM' PARAMS = BREAKUP (PROTOTYPE[A+2:A+1+B]) ;
      'REF'[]'REF''ITEM' LOCALS = BREAKUP (PROTOTYPE[A+B+3:]) ;

      'BOOL' NOT FOUND := 'TRUE' ;
      'FOR' I 'TO' FTP 'WHILE' NOT FOUND 'DO'
         'IF' NAME PTR 'IS' FNNAME 'OF' FUNCTION TABLE [I]
         'THEN' NOT FOUND := 'FALSE' ;
            FUNCTION TABLE [I] := (NAME PTR, ENTRY, PARAMS, LOCALS)
         'FI'
      'OD' ;
      'IF' NOT FOUND
      'THEN' 'IF' FTP = FTLIM 'THEN' ERROR (
                "FUNCTION TABLE OVERFLOW") 'FI' ;
         FUNCTION TABLE [FTP +:= 1] := (NAME PTR, ENTRY,
                                        PARAMS, LOCALS)
      'FI' ;
      'NIL'  # RESULT OF DEFINE(...) #
   'ELSE' ERROR ("ILLEGAL FUNCTION CALL") ; 'SKIP'
   'FI' ) ;

'PROC' CONCATENATE = ('REF''ITEM' PTR1, PTR2) 'REF''ITEM' : (

   'PROC' CONCAT PATTERNS = ('PATTERN' P1, P2) 'REF''ITEM' : (
      'INT' U1 = 'UPB' P1, U2 = 'UPB' P2 ;
      'PATTERN' P = 'HEAP'[U1 + U2]'COMPONENT' ;
      'INT' OFFSET = U1 + 1 ;
      'FOR' I 'TO' U1 'DO'
         P[I] := P1[I] ;
         'IF' SUBSEQUENT 'OF' P[I] = 0
         'THEN' SUBSEQUENT 'OF' P[I] := OFFSET
         'FI'
      'OD' ;
      'FOR' I 'FROM' OFFSET 'TO' U1 + U2 'DO'
         P[I] := P2 [I - U1] ;
         'IF' SUBSEQUENT 'OF' P[I] /= 0 'THEN'
            SUBSEQUENT 'OF' P[I] +:= U1 'FI' ;
         'IF' ALTERNATE 'OF' P[I] /= 0 'THEN'
            ALTERNATE 'OF' P[I] +:= U1 'FI'
      'OD' ;
      'IF' U2 = 1 'AND' ROUTINE 'OF' P[OFFSET] = MIV2 'THEN'
         EXTRA 'OF' P[OFFSET] := U1 'FI' ;
      'HEAP''ITEM' := P ) ;

   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'IF' PTR1 'IS' 'NIL' 'THEN' PTR2
   'ELIF' PTR2 'IS' 'NIL' 'THEN' PTR1
   'ELSE' 'CASE' PTR1 'IN' ('PATTERN' P1) :
         CONCAT PATTERNS (P1, 'PAT' CONVERT TO PAT (PTR2))
      'OUSE' PTR2 'IN' ('PATTERN' P2) :
         CONCAT PATTERNS ('PAT' CONVERT TO PAT (PTR1), P2)
      'OUT' 'STRING' S1 = VAL 'OF' ('STR' CONVERT TO STR (PTR1)) ;
         MAKE STR (S1 + VAL 'OF' ('STR' CONVERT TO STR (PTR2)))
      'ESAC'
   'FI'
   'FI' ) ;

'PROC' CONVERT TO INT = ('REF''ITEM' PTR) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'IF' PTR 'IS' 'NIL' 'THEN' MAKE INT (0)
   'ELSE' 'CASE' PTR 'IN'
      ('INT') : PTR,
      ('PATTERN') : (ERROR (
         "PATTERN VALUE WHERE INTEGER REQUIRED") ; 'SKIP'),
      ('REF''STRINGITEM' S) : (
         'INT' N := 0, D, Z := 'ABS' "0" ;
         'FOR' I 'TO' 'UPB' VAL 'OF' S 'DO'
            D := 'ABS' (VAL 'OF' S)[I] - Z ;
            'IF' D < 0 'OR' D > 9 'THEN' ERROR (
               "STRING NOT CONVERTIBLE TO INTEGER") 'FI' ;
            N := N * 10 + D
         'OD' ;
         MAKE INT (N) )
      'ESAC'
   'FI'
   'FI' ;

'PROC' CONVERT TO PAT = ('REF''ITEM' PTR) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'IF' PTR 'IS' 'NIL' 'THEN' MAKE PAT COMP (MSTR, 'NIL')
   'ELSE' 'CASE' PTR 'IN' ('PATTERN') : PTR
          'OUT' MAKE PAT COMP (MSTR, CONVERT TO STR (PTR))
          'ESAC'
   'FI'
   'FI' ;

'PROC' CONVERT TO STR = ('REF''ITEM' PTR) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'IF' PTR 'IS' 'NIL' 'THEN' PTR
   'ELSE' 'CASE' PTR 'IN'
         ('REF''STRINGITEM') : PTR,
         ('PATTERN') : (ERROR (
            "PATTERN VALUE WHERE STRING REQUIRED") ; 'SKIP'),
         ('INT' I) : MAKE STR (WHOLE (I, 0))
      'ESAC'
   'FI'
   'FI' ;

'PROC' MAKE INT = ('INT' VAL) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'HEAP''ITEM' := VAL
   'FI' ;

'PROC' MAKE PAT COMP = ('INT' ROUTINE, 'REF''ITEM' ARG) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP' 'ELSE'
   'HEAP''ITEM' := 'HEAP'[1:1]'COMPONENT' :=
      'COMPONENT' (ROUTINE, 0, 0, 'SKIP', ARG)
   'FI' ;

'PROC' MAKE STR = ('STRING' VAL) 'REF''ITEM' :
   'IF' FAILED 'THEN' 'SKIP'
   'ELIF' 'UPB' VAL = 0 'THEN' 'NIL' 'ELSE'
   'INT' I := 0, 'BOOL' NF := 'TRUE' ;
   'WHILE' 'IF' (I +:= 1) <= NIN
      'THEN' NF := VAL /= VAL 'OF' ('STR' SPOOL[I])
      'ELSE' 'FALSE'
      'FI'
   'DO' 'SKIP' 'OD' ;
   'IF' NF
   'THEN' 'IF' NIN = SPOOLSIZE 'THEN' ERROR ("TOO MANY STRINGS") 'FI' ;
      SPOOL [NIN +:= 1] := 'HEAP''ITEM' := 'HEAP''STRINGITEM' :=
                                                   (VAL, 'NIL')
   'FI' ;
   SPOOL[I]
   'FI' ;

'PROC' BREAK SCAN = ('STRING' STR, ARG) 'INT' : (
   # RESULT = 'UPB' STR IF NO BREAK CHAR, LESS OTHERWISE #
   'INT' J := 0 ;
   'FOR' I 'TO' 'UPB' STR 'WHILE' 'NOT' ANY (ARG, STR[I])
      'DO' J := I 'OD' ;
   J ) ;

'PROC' ANY = ('STRING' STR, 'CHAR' CH) 'BOOL' : (
   'BOOL' NF ;
   'FOR' I 'TO' 'UPB' STR 'WHILE' NF := CH /= STR[I] 'DO' 'SKIP' 'OD' ;
   'NOT' NF ) ;

PRINT ((NEWLINE, NEWLINE, NEWLINE)) ;
INTERPRET (('REF''ITEM'(PROG ENTRY) 'IS' 'NIL' ! 1 !
   FIND LABEL (PROG ENTRY)))

'END'          # INTERPRETATION PHASE #

'END'