{###################################################}
{#       Portable IMP77 compiler First Pass        #}
{#           Copyright: 1 January 1981             #}
{#    Interactive Datasystems (Edinburgh) Ltd.     #}
{#             32 Upper Gilmore Place              #}
{#               Edinburgh EH3 9NJ                 #}
{#              All Rights Reserved                #}
{###################################################}

%BEGIN
   %EXTERNALINTEGERSPEC IMPFLAG
   %ROUTINE define(%STRING (255) s)
      %EXTERNALROUTINESPEC emas3(%STRINGNAME command,params, %INTEGERNAME flag)
      %INTEGER flag
      emas3("DEFINE",s,flag)
   %END;                                 ! Of %ROUTINE define.
   %CONSTSTRING (4) version= "8.7"

                                         !configuration parameters

   %CONSTINTEGER minus 1= 16_ffff
   %CONSTINTEGER max int= ((minus 1)>>1)//10
   %CONSTINTEGER max dig= (minus 1)>>1-maxint*10
   %CONSTINTEGER byte size= 8            {bits per byte}
   %CONSTINTEGER max tag= 800          {max no. of tags}
   %CONSTINTEGER max dict= 6000         {max extent of dictionary}
   %CONSTINTEGER name bits= 11
   %CONSTINTEGER max names= 1<<namebits-1
   %OWNINTEGER spare names= max names
   %CONSTINTEGER max grammar= 1720
   %CONSTINTEGER lit max= 50           {max no. of constants/stat.}
   %CONSTINTEGER rec size= 520          {size of analysis record}
   %CONSTINTEGER dim limit= 6            {maximum array dimension}

   {Internal monitoring}

   %OWNINTEGER Tag Lower= 0,
                Dict Upper = Max Dict

   {symbols}

   %CONSTINTEGER ff= 12              {form feed}
   %CONSTINTEGER marker= '^'             {marker for faults}
   %CONSTINTEGER squote= '"'             {string quote}
   %CONSTINTEGER cquote= ''''            {character quote}

                                         !streams

   %CONSTINTEGER report= 0,  source = 1, prims = 2
   %CONSTINTEGER Isource= 5, object = 3, listing = 4

                                         !types

   %CONSTINTEGER integer= 1
   %CONSTINTEGER real= 2
   %CONSTINTEGER stringv= 3
   %CONSTINTEGER record= 4

                                         !forms

   %CONSTINTEGER iform= integer<<4+1

   %CONSTINTEGER var= 91
   %CONSTINTEGER const= 93
   %CONSTINTEGER swit= 105
   %CONSTINTEGER comment= 22
   %CONSTINTEGER termin= 20
   %CONSTINTEGER lab= 3
   %CONSTINTEGER jump= 54

   %CONSTINTEGER recfm= 4
   %CONSTINTEGER proc= 7                     {class for proc}

                                         !phrase entries

   %CONSTINTEGER escn= 251,
                 escdec   = 252,
                 escproc  = 253,
                 escarray = 254,
                 escrec   = 255

   %RECORDFORMAT arfm(%INTEGER class,sub,link,ptype,papp,pformat,x,pos)

   %RECORDFORMAT tagfm(%INTEGER app,format,flags,index,text,link)

                                         !flags

!      *===.===.===.===.===.====.====.====.===.======.======*
!      ! u ! c ! c ! p ! s ! a  ! o  ! pr ! s ! type ! form !
!      ! 1 ! 1 ! 1 ! 1 ! 1 ! 1  ! 1  ! 1  ! 1 !  3   !  4   !
!      *===^===^===^===^===^====^====^====^===^======^======*
!        u   c   c   p   s   a    o    p    s    t      f
!        s   l   o   a   u   n    w    r    p    y      o
!        e   o   n   r   b   a    n    o    e    p      r
!        d   s   s   a   n   m         t    c    e      m
!            e   t   m   a   e
!            d       s   m
!                        e
!
!

   %CONSTINTEGER used bit= b'1000000000000000',
                 closed     = b'0100000000000000',
                 const bit  = b'0010000000000000',
                 parameters = b'0001000000000000',
                 subname    = b'0000100000000000',
                 aname      = b'0000010000000000',
                 own bit    = b'0000001000000000',
                 prot       = b'0000000100000000',
                 spec       = b'0000000010000000'

   %CONSTINTEGER trans bit= x'4000'
   %CONSTINTEGER error= x'8000'

   %CONSTINTEGER manifest= 120, figurative = 130
   %CONSTINTEGER actions= 180, phrasal    = 200

   %CONSTBYTEINTEGERARRAY amap(0:15)= %C
 89, 91, 92, 104, 94, const, swit, 100, 101, 102, 103, 106, 107, 108, 109, 89
!?   v   n   l    fm  const  swit  rp   fp   mp   pp   a    an   na   nan  ?

   %CONSTBYTEINTEGERARRAY atoms(0:15)= 89, 1, 1, 10,  9,  1, 10,  7,
                                         7, 7, 7,  4,  1,  4,  1, 89

   %RECORD (arfm) %ARRAY ar(1:rec size)

   %OWNINTEGER class= 0             {class of atom wanted}
   %OWNINTEGER x= 0             {usually last tag}
   %OWNINTEGER atom1= 0             {atom class (major)}
   %OWNINTEGER atom2= 0             {atom class (minor)}
   %OWNINTEGER subatom= 0             {extra info about atom}
   %OWNINTEGER type= 0,
               app          = 0,
               format       = 0             {atom info}
   %INTEGER hash value
   %OWNINTEGER faulty= 0             {fault indicator}
   %OWNINTEGER fault rate= 0             {fault rate count}
   %OWNINTEGER lines= 0             {current line number}
   %OWNINTEGER Section Lines= 0
   %OWNINTEGER text line= 0             {starting line for string const}
   %OWNINTEGER margin= 0             {statement start margin}
   %OWNINTEGER error margin= 0,
               error sym    = 0,
               column       = 0
   %OWNINTEGER stats= 0             {statements compiled}
   %OWNINTEGER Section Stats= 0
   %OWNINTEGER mon pos= 0             {flag for diagnose}
   %OWNINTEGER sym= nl            {current input symbol}
   %OWNINTEGER symtype= 0             {type of current symbol}
   %OWNINTEGER quote= 0             {>0 strings, <0 chars}
   %OWNINTEGER end mark= 0             {%end flag}
   %OWNINTEGER cont= ' ',
               csym         = ' '           {listing continuation marker}
   %OWNINTEGER decl= 0             {current declarator flags}
   %OWNINTEGER dim= 0             {arrayname dimension}
   %OWNINTEGER spec given= 0

   %OWNINTEGER escape class= 0             {when and where to escape}
   %OWNINTEGER protection= 0,
               atom flags   = 0
   %OWNINTEGER otype= 0             {current 'own' type}
   %OWNINTEGER last1= 0             {previous atom class}
   %OWNINTEGER gen type= 0
   %OWNINTEGER ptype= 0             {current phrase type}
   %OWNINTEGER papp= 0             {current phrase parameters}
   %OWNINTEGER pformat= 0             {current phrase format}
   %OWNINTEGER force= 0             {force next ptype}
   %OWNINTEGER g= 0,
               gg           = 0,
               map gg       = 0             {grammar entries}
   %OWNINTEGER fdef= 0             {current format definition}
   %OWNINTEGER this= -1            {current recordformat tag}
   %OWNINTEGER nmin= 0             {analysis record atom pointer}
   %OWNINTEGER nmax= 0             {analysis record phrase pointer}
   %OWNINTEGER rbase= 0             {record format definition base}
   %OWNINTEGER stbase= 0             {constant work area base}
   %OWNINTEGER gmin= max grammar   {upper bound on grammar}
   %OWNINTEGER dmax= 1
   %OWNINTEGER tmin= max tag       {upper bound on tags}
   %OWNINTEGER label= 4
   %OWNINTEGER ss= 0             {source statement entry}
   %STRING (63) include file
   %OWNINTEGER include list= 0,
               include level= 0
   %OWNINTEGER include= 0             {=0 unused, #0 being used}
   %OWNINTEGER perm= 1             {1 = compiling perm, 0 = program}
   %OWNINTEGER progmode= 0             {-1 = file, 1 = begin/eop}
   %OWNINTEGER sstype= 0             {-1:exec stat}
                                         ! 0: declaration
                                         ! 1: block in
                                         ! 2: block out
   %OWNINTEGER spec mode= 0             {>=0: definition}
                                         ! -1: proc spec
                                         ! -2: recordformat
   %OWNINTEGER ocount= -1            {own constants wanted}
   %OWNINTEGER limit= 0             {lookup limit}
   %OWNINTEGER copy= 0             {duplicate name flag}
   %OWNINTEGER order= 0             {out of sequence flag}
   %OWNINTEGER for warn= 0             {non-local flag}
   %OWNINTEGER Lazy Ercc= 0
   %OWNINTEGER dubious= 0             {flag for dubious statements}
   %OWNINTEGER dp= 1
   %OWNINTEGER pos1= 0,
               pos2         = 0             {error position}
   %OWNINTEGER pos= 0             {input line index}
   %OWNINTEGER dimension= 0             {current array dimension}
   %OWNINTEGER local= 0             {search limit for locals}
   %OWNINTEGER fm base= 0             {entry for format decls}
   %OWNINTEGER search base= 0             {entry for record_names}
   %OWNINTEGER format list= 0             {size of current format list}
   %INTEGER recid
   %OWNBYTEINTEGERARRAY char(0:133)= nl(134)  {input line}
   %INTEGERARRAY lit pool(0:lit max)
   %OWNINTEGER lit= 0             {current literal (integer)}
   %OWNINTEGER lp= 0             {literals pointer}
   %OWNINTEGER block x= 0             {block tag}
   %OWNINTEGER list= 1             {<= to enable}
   %OWNINTEGER tty= 0              {non-zero if listing to tty}
   %OWNINTEGER control= 0
   %OWNINTEGER diag= 0             {diagnose flags}
   %INTEGERARRAY hash(0:max names)
   %RECORD (tagfm) %ARRAY tag(0:max tag)
   %INTEGERARRAY dict(1:max dict)
   %BYTEINTEGERARRAY buff(1:512)
   %OWNINTEGER bp= 0

!*** start of generated tables ***
   %INCLUDE "tables"
!***  end  of generated tables ***

   %ROUTINE flush buffer
      %INTEGER j
      %IF faulty=0 %START
         select output(object)
         printch(buff(j)) %FOR J = 1,1,Bp
         select output(listing)
      %FINISH
      bp = 0
   %END
   %ROUTINE print ident(%INTEGER p,mode)
      %INTEGER j,ad
      p = tag(p)_text
      %IF p=0 %START
         bp = bp+1 %AND buff(bp) = '?' %IF Mode#0
         %RETURN
      %FINISH
      ad = addr(dict(p+1))
      %IF mode=0 %THEN printstring(string(ad)) %ELSESTART
         %FOR j = ad+1,1,ad+byteinteger(ad) %CYCLE
            bp = bp+1
            buff(bp) = byteinteger(j)
         %REPEAT
      %FINISH
   %END
   %ROUTINE abandon(%INTEGER n)
      %SWITCH reason(0:9)
      %INTEGER stream
      stream = listing
      %CYCLE
         newline %IF sym#nl
         printsymbol('*'); write(lines,4); space
         ->reason(n)
reason(0):printstring("compiler error!"); ->more
reason(1):printstring("switch vector too large"); ->more
reason(2):printstring("too many names"); ->more
reason(3):printstring("program too complex"); ->more
reason(4):printstring("feature not implemented"); ->more
reason(5):printstring("input ended: ")
         %IF quote#0 %START
            %IF quote<0 %THEN printsymbol(cquote) %ELSE printsymbol(squote)
         %FINISHELSESTART
            printstring("%endof")
            %IF progmode>=0 %THEN printstring("program") %ELSE %C
               printstring("file")
         %FINISH
         printstring(" missing?"); ->more
reason(6):printstring("too many faults!"); ->more
reason(7):printstring("string constant too long"); ->more
reason(8):printstring("dictionary full"); ->more
reason(9):printstring("Included file ".include file." does not exist")
more:    newline
         printstring("***  compilation abandoned ***"); newline
         %EXITIF stream=report %OR tty#0
         stream = report
         select output(report)
      %REPEAT
      IMPFLAG = -Faulty-1
      %SIGNAL 14,15 %IF diag&4096#0
      %STOP
   %END
   %ROUTINE Put Tag(%INTEGER Tag)
      Buff(Bp+1) <- Tag>>8
      Buff(Bp+2) <- Tag
      Bp = Bp+2
   %END
   %ROUTINE op(%INTEGER code,param)
      buff(bp+1) <- code
      buff(bp+2) <- param>>8
      buff(bp+3) <- param
      bp = bp+3
   %END
   %ROUTINE set const(%INTEGER m)
      buff(bp+1) <- 'N'
      buff(bp+5) <- m; m = m>>8
      buff(bp+4) <- m; m = m>>8
      buff(bp+3) <- m; m = m>>8
      buff(bp+2) <- m
      bp = bp+5
   %END



   %ROUTINE compile block(%INTEGER level,block tag,dmin,tmax,id)

      %INTEGERFNSPEC gapp
      %ROUTINESPEC delete names(%INTEGER quiet)
      %ROUTINESPEC analyse
      %ROUTINESPEC compile

      %INTEGER open; open = closed {zero if can return from proc}
      %INTEGER dbase; dbase = dmax {dictionary base}
      %INTEGER tbase; tbase = tmax {tag base}
      %INTEGER tstart; tstart = tmax
      %INTEGER access; access = 1 {non-zero if accessible}
      %INTEGER inhibit; inhibit = 0 {non-zero inhibits declaratons}

      %INTEGERNAME bflags; bflags == tag(block tag)_flags
      %INTEGER block type; blocktype = bflags>>4&7
      %INTEGER block form; blockform = bflags&15
      %INTEGER block fm; blockfm = tag(block tag)_format
      %INTEGER block otype; blockotype = otype
      %INTEGERNAME block app; blockapp == tag(block tag)_app

      %INTEGER l,new app

      %ROUTINE fault(%INTEGER n)

                                         ! -6 : -1  - warnings
                                         !  1 : 22  - errors

         %SWITCH fm(-6:22)
         %INTEGER st

         %ROUTINE print ss
            %INTEGER s,p
            %RETURNIF pos=0
            space
            p = 1
            %CYCLE
               printsymbol(marker) %IF p=pos1
               %EXITIF p=pos
               s = char(p); p = p+1
               %EXITIF s=nl %OR (s='%' %AND p=pos)
               %IF s<' ' %START {beware of tabs}
                  %IF s=ff %THEN s = nl %ELSE s = ' '
               %FINISH
               printsymbol(s)
            %REPEAT
            pos = 0 %IF list<=0
         %END

         pos1 = pos2 %IF pos2>pos1
         newline %IF sym#nl
         st = report
         %IF n=-3 %OR tty#0 %START {unused or listing to console}
            st = listing
            Pos = 0 {inhibit PRINT SS}
         %FINISH
         %CYCLE
            SELECT OUTPUT(st)
            %IF n<0 %THEN printsymbol('?') %AND pos1 = 0 %ELSE printsymbol('*')
            %IF st#report %START
               %IF list<=0 %AND pos1#0 %START
                  spaces(pos1+margin); PRINTSTRING("      ! ")
               %FINISH
            %FINISHELSESTART
               PRINTSTRING(include file) %IF include#0
               write(lines,4); printsymbol(csym); space
            %FINISH
            ->fm(n) %IF-6<=n<=22
            PRINTSTRING("fault"); write(n,2); ->ps

fm(-6):     Printstring("Record type check fails"); Lazy Ercc = 0
            ->nps
fm(-5):     PRINTSTRING("Dubious statement"); dubious = 0; ->psd
fm(-4):     PRINTSTRING("Non-local")
            pos1 = for warn; for warn = 0; ->ps
fm(-3):     print ident(x,0); PRINTSTRING(" unused"); ->nps
fm(-2):     PRINTSTRING("""}"""); ->miss
fm(-1):     PRINTSTRING("access"); ->psd

fm(0):      PRINTSTRING("form"); ->ps
fm(1):      PRINTSTRING("atom"); ->ps
fm(2):      PRINTSTRING("not declared"); ->ps
fm(3):      PRINTSTRING("too complex"); ->ps
fm(4):      PRINTSTRING("duplicate "); Print Ident(Copy,0); ->ps
fm(5):      PRINTSTRING("type"); ->ps
fm(6):      PRINTSTRING("match"); ->psd
fm(7):      PRINTSTRING("context"); ->psd
fm(21):     PRINTSTRING("context "); print ident(this,0); ->ps
fm(8):      PRINTSTRING("%cycle"); ->miss
fm(9):      PRINTSTRING("%start"); ->miss
fm(10):     PRINTSTRING("size"); WRITE(lit,1) %IF pos1=0; ->ps
fm(11):     PRINTSTRING("bounds")
            WRITE(ocount,1) %UNLESS ocount<0; ->ps
fm(12):     PRINTSTRING("index"); ->ps
fm(13):     PRINTSTRING("order"); ->psd
fm(14):     PRINTSTRING("not a location"); ->ps
fm(15):     PRINTSTRING("%begin"); ->miss
fm(16):     PRINTSTRING("%end"); ->miss
fm(17):     PRINTSTRING("%repeat"); ->miss
fm(18):     PRINTSTRING("%finish"); ->miss
fm(19):     PRINTSTRING("result"); ->miss
fm(22):     PRINTSTRING("format"); ->ps
fm(20):     printsymbol('"'); print ident(x,0); printsymbol('"')
miss:       PRINTSTRING(" missing"); ->nps
psd:        pos1 = 0
ps:         print ss
nps:        NEWLINE
            %EXITIF st=listing
            st = listing
         %REPEAT
         %IF n>=0 %START
            %SIGNAL 14,15 %IF diag&4096#0
            %IF n#13 %START {order is fairly safe}
               ocount = -1
               gg = 0
               copy = 0; quote = 0
               search base = 0; escape class = 0
               gg = 0
            %FINISH
            faulty = faulty+1

                                         !check that there haven't been too many faults

            fault rate = fault rate+3; abandon(6) %IF fault rate>30
            fault rate = 3 %IF fault rate<=0
         %FINISH
         tbase = tstart
         %IF list<=0 %AND sym#nl %START
            error margin = column
            error sym = sym; sym = nl
         %FINISH
      %END

      dmin = dmin-1; dict(dmin) = -1 {end marker for starts & cycles}
      Dict Upper = Dmin %IF Dmin<Dict Upper
      abandon(2) %IF dmax=dmin

      %IF list>0 %AND level>0 %START
         write(lines,5); spaces(level*3-1)
         %IF block tag=0 %START
            printstring("Begin")
         %FINISHELSESTART
            printstring("Procedure "); print ident(block tag,0)
         %FINISH
         newline
      %FINISH

                                         !deal with procedure definition (parameters)

      %IF block tag#0 %START {proc}
         analyse; compile %IF ss#0

         %IF block otype#0 %START {external-ish}
            %IF bflags&spec=0 %START {definition}
               %IF progmode<=0 %AND level=1 %THEN progmode = -1 %ELSE fault(7)
            %FINISH
         %FINISH

         new app = gapp {generate app grammar}
         %IF spec given#0 %START {definition after spec}
            fault(6) %IF new app#block app {different from spec}
         %FINISH
         block app = new app {use the latest}

         %IF level<0 %START {not procedure definition}
            delete names(0)
            %RETURN
         %FINISH
      %FINISHELSESTART
         open = 0 {can return from a block?}
      %FINISH

      %CYCLE
         analyse
         %CONTINUEIF ss=0
         compile
         fault(-5) %IF dubious#0
         fault(-6) %IF Lazy Ercc#0
         flush buffer %IF bp>=128
         %IF sstype>0 %START {block in or out}
            %EXITIF sstype=2 {out}
            compile block(spec mode,block x,dmin,tmax,id)
            %EXITIF ss<0 {endofprogram}
         %FINISH
      %REPEAT
      %IF list>0 %AND level>0 %START
         write(lines,5); spaces(level*3-1)
         printstring("End")
         newline
      %FINISH
      delete names(0)
      %RETURN

      %INTEGERFN gapp {generate app grammar (backwards)}
         %CONSTINTEGER comma= 140               {psep}
         %ROUTINESPEC set cell(%INTEGER g,tt)
         %ROUTINESPEC class(%RECORD (tagfm) %NAME v)
         %RECORD (tagfm) %NAME v
         %INTEGER p,link,tp,c,ap,t

         %RESULT = 0 %IF tmax=local {no app needed}

         p = gmax1; link = 0; t = tmax

         %CYCLE
            v == tag(t); t = t-1
            class(v) {deduce class from tag}
            %IF c<0 %START {insert %PARAM}
               c = -c
               set cell(196,tp)
               tp = -1
            %FINISH
            set cell(c,tp)
            %EXITIF t=local {end of parameters}
            set cell(comma,-1) {add the separating comma}
         %REPEAT
         abandon(3) %IF gmax>gmin

         %RESULT = link

         %ROUTINE set cell(%INTEGER g,tt)

                                         !add the cell to the grammar, combining common tails

            %WHILE p#gmax %CYCLE
               p = p+1
               %IF glink(p)=link %AND gram(p)=g %START
                  %IF tt<0 %OR (gram(p+1)=tt %AND glink(p+1)=ap) %START
                     link = p {already there}
                     %RETURN
                  %FINISH
               %FINISH
            %REPEAT

                                         !add a new cell

            gmax = gmax+1
            gram(gmax) = g
            glink(gmax) = link
            link = gmax

            %IF tt>=0 %START { set type cell}
               gmax = gmax+1
               gram(gmax) = tt
               glink(gmax) = ap
            %FINISH

            p = gmax
         %END

         %ROUTINE class(%RECORD (tagfm) %NAME v)
            %CONSTINTEGER err= 89,
                       rtp    = 100,
                       fnp    = 101,
                       mapp   = 102,
                       predp  = 103
            %CONSTINTEGERARRAY class map(0:15)= %C
         err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214,
         err, 229, err
            %INTEGER tags,type,form
            ap = 0
            tags = v_flags
            type = tags>>4&7; form = tags&15
            tp = v_format<<3!type
            c = class map(form)
            c = 208 %AND tp = 0 %IF type=0 %AND form=2 {%NAME}
            ap = v_app %IF tags&parameters#0
         %END
      %END

      %ROUTINE delete names(%INTEGER quiet)
         %INTEGER flags
         %RECORD (tagfm) %NAME tx
         Tag Lower = Tmax %IF Tmax>Tag Lower
         %WHILE tmax>tbase %CYCLE
            x = tmax; tmax = tmax-1
            tx == tag(x)
            flags = tx_flags

            %IF flags&used bit=0 %START {identifier unused}
               Fault(-3) %IF Quiet=0 %AND %C
                  {warn unused unless ...} Level>=0 %AND %C
                  {global} List<=0 {no listing}
            %FINISHELSESTART {identifier used}
               Fault(20) %IF flags&spec#0 %AND flags&own bit=0
               {spec and use with no definition}
            %FINISH

            dict(tx_text) = tx_link
         %REPEAT
      %END

      %ROUTINE analyse

         %CONSTINTEGER order bits= x'3000', order bit = x'1000'
         %CONSTINTEGER escape= x'1000'
         %INTEGER strp,mark,flags,prot err,k,s,c
         %OWNINTEGER key= 0
         %RECORD (arfm) %NAME arp
         %INTEGER node
         %INTEGERNAME z
         %SWITCH act(actions:phrasal),paction(0:15)

         %ROUTINE trace analysis
                                         !diagnostic trace routine (diagnose&1 # 0)
            %INTEGER a
            %ROUTINE show(%INTEGER a)
               %IF 0<a<130 %START
                  space
                  printstring(text(a))
               %FINISHELSE write(a,3)
            %END
            %OWNINTEGER la1=0, la2=0, lsa=0, lt=0
            newline %IF mon pos#pos %AND sym#nl
            mon pos = pos
            write(g,3)
            space
            printstring(text(class))
            printsymbol('"') %IF gg&trans bit#0
            a = gg>>8&15
            %IF a#0 %START
               printsymbol('{')
               write(a,0)
               printsymbol('}')
            %FINISH
            %IF atom1#la1 %OR atom2#la2 %OR lsa#subatom %OR lt#type %START
               printstring(" [")
               la1 = atom1; show(la1)
               la2 = atom2; show(la2)
               lsa = subatom; write(lsa,3)
               lt = type; write(lt,5)
               printsymbol(']')
            %FINISH
            newline
         %END

         %ROUTINE get sym
            readsymbol(sym)
            pos = pos+1 %IF pos#133
            char(pos) = sym
            printsymbol(sym) %IF list<=0
            column = column+1
         %END
         %ROUTINE read sym
            %OWNINTEGER Last= 0
            %CONSTBYTEINTEGERARRAY mapped(0:127)= %C
   0,  0,  0,  0,   0,  0,  0,  0,    0,  0, nl,  0,  3 ,  0,  0,  0,
   0,  0,  0,  0,   0,  0,  0,  0,    0,  0,  0,  0,   0,  0,  0,  0,
  0 ,'!','"','#', '$', 1 ,'&', 39,  '(',')','*','+', ',','-','.','/',
 '0','1','2','3', '4','5','6','7',  '8','9',':',';', '<','=','>','?',
 '@','A','B','C', 'D','E','F','G',  'H','I','J','K', 'L','M','N','O',
 'P','Q','R','S', 'T','U','V','W',  'X','Y','Z','[', '\',']','^','_',
 '`','A','B','C', 'D','E','F','G',  'H','I','J','K', 'L','M','N','O',
 'P','Q','R','S', 'T','U','V','W',  'X','Y','Z', 2 , '|','}','~',  0

!!   0 = space
!!   1 = %
!!   2 = {}
!!   3 = ff
!!   other values represent themselves

            %IF sym=nl %START
s1:            lines = lines+1
               printsymbol(end mark) %IF end mark#0
s11:           pos = 0; pos1 = 0; pos2 = 0; margin = 0; column = 0
               Last = 0
               end mark = 0
               %IF list<=0 %START
                  %IF include#0 %START
                     printstring(" &"); write(lines,-4)
                  %FINISHELSE write(lines,5)
                  csym = cont; printsymbol(csym)
                  space
                  %IF error margin#0 %START
                     lines = lines-1
                     spaces(error margin)
                     error margin = 0
                     %IF error sym#0 %START
                        printsymbol(error sym)
                        pos = 1; char(1) = error sym
                        sym = error sym; error sym = 0
                        ->s5
                     %FINISH
                  %FINISH
               %FINISH
s2:            symtype = 1
            %FINISH
s3:         readsymbol(sym)
            pos = pos+1 %IF pos#133
            char(pos) = sym
            printsymbol(sym) %IF list<=0
            column = column+1
s5:         %IF sym#nl %START
               Last = Sym
               %RETURNIF quote#0 {dont alter strings}
               sym = mapped(sym&127)
               %IF sym<=3 %START {special symbol}
                  ->s2 %IF sym=0 {space (or dubious control)}
                  symtype = 2 %AND ->s3 %IF sym=1 {%}
                  cont = '+' %AND ->s11 %IF sym=3 {ff}
                                         !must be {}
                  %CYCLE
                     get sym
                     ->s3 %IF sym='}'
                     ->s4 %IF sym=nl
                  %REPEAT
               %FINISH
               key = kdict(sym)
               %IF key&3=0 %AND symtype=2 %START {keyword}
                  %IF sym='C' %AND nextsymbol=nl %START {%C...}
                     getsym; cont = '+'; ->s1
                  %FINISH
               %FINISHELSESTART
                  symtype = key&3-2
               %FINISH
               %RETURN
            %FINISH
s4:         symtype = quote
            ->S1 %IF last=0 %AND Quote=0
            Cont = '+'
         %END

         %INTEGERFN format selected
            format list = tag(format)_app {number of names}
            %IF format list<0 %START {forward ref}
               atom1 = error+22
               %RESULT = 0
            %FINISH
            %IF sym='_' %START
               escape class = esc rec
               search base = tag(format)_format
            %FINISH
            %RESULT = 1
         %END

         %ROUTINE code atom(%INTEGER target)
            %INTEGER dbase,da
            %INTEGER base,n,mul,pend quote
            %INTEGER j,k,l,pt

            %ROUTINE lookup(%INTEGER d)
               %CONSTINTEGER magic= 6700421
               %INTEGER new name,vid,k1,k2,form
               %RECORD (tagfm) %NAME t
               %LONGINTEGER k0
               %INTEGER new

                                         !first locate the text of the name

               new = addr(dict(dmax+1))

               {K2 = hash value*magic}

               k0 = magic
               k1 = (k0*hash value)&X'7FFFFFFF'
               k2 = k1>>(32-2*name bits)!1

               k1 = k2>>name bits {giving name bits}
               %CYCLE
                  newname = hash(k1)
                  %EXITIF newname=0 {not in}
                  ->in %IF string(addr(dict(newname+1)))=string(new)
                  k1 = (k1+k2)&max names
               %REPEAT

                                         ! not found

               spare names = spare names-1
               abandon(2) %IF spare names<=0
               hash(k1) = dmax {put it in}
               dict(dmax) = -1
               newname = dmax; dmax = dp; ->not in

in:            search base = rbase %IF this>=0 %AND d#0 {record elem defn}
               %IF search base#0 %START {record subname}
                  new = -1
                  x = search base
                  %CYCLE
                     ->not in %IF x<format list
                     %EXITIF tag(x)_text=new name
                     x = x-1
                  %REPEAT
               %FINISHELSESTART {hash in for normal names}
                  x = dict(newname)
                  ->not in %IF x<=limit {wrong level}
               %FINISH

               subatom = x {name found, extract info}
               t == tag(x)
               atom flags = t_flags
               format = t_format; app = t_app
               protection = atom flags&prot
               type = atom flags>>4&7; atom1 = amap(atom flags&15)

               %IF diag&8#0 %START
                  printstring("lookup:")
                  write(atom1,3)
                  write(type,1)
                  write(app,3)
                  write(format,5)
                  write(atom flags,3)
                  newline
               %FINISH

               %IF d=0 %START {old name wanted}
                  t_flags <- t_flags!used bit
                  search base = 0

                  %IF atom flags&subname#0 %AND format#0 %START {a record}
                     %RETURNIF format selected=0
                  %FINISH

                  %IF atom flags&parameters#0 %START {proc or array}

                     %IF app=0 %START {no parameters needed}
                        atom2 = atom1
                        atom1 = atom1-4
                        %IF 97<=atom1<=98 %START
                           map gg = atom1; atom1 = var
                        %FINISH
                     %FINISHELSEIF sym='(' %START
                        search base = 0 {ignore format for now}
                        %IF atom1>=106 %START {arrays}
                           app = phrase(app+200)
                           escape class = esc array
                           atom1 = (atom1-106)>>1+91 {a,an->v  na,nan->n}
                        %FINISHELSESTART {procedures}
                           escape class = esc proc
                           atom1 = atom1-4
                        %FINISH
                        phrase(200) = app
                     %FINISH
                     pos2 = pos; %RETURN
                  %FINISH

                                         !deal with constintegers etc

                  %IF atom flags&const bit#0 %AND atom1=var %START
                     map gg = const; atom2 = const
                     subatom = -subatom %IF type=integer
                  %FINISH
                  Escape Class = EscN %IF Atom1=92 {N} %AND Sym='['
                  %RETURN

               %FINISH
                                         !new name wanted
               ->not in %IF tbase#tstart {don't fault proc parm-parm}
               %IF d=lab+spec+used bit %START
                  t_flags = t_flags!used bit
                  %RETURN
               %FINISH
               %IF atom flags&spec#0 %START {a spec has been given}
                  %IF d=lab %START {define label}
                     t_flags <- t_Flags-Spec
                     %RETURN
                  %FINISH
                  %IF {7 <= decl&15 <= 10 %AND} decl&spec=0 %START

                                         !{procedure} definition after spec

                     %IF (decl!!atom flags)&b'1111111'=0 %START {correct type?}
                        t_flags = t_flags-spec
                        spec given = 1 %IF 7<=Decl&15<=10 {procedure}
                        %RETURN
                     %FINISH

                  %FINISH
                  %IF decl&15=recfm %START {recordformat}
                     t_flags = record<<4+recfm
                     t_format = fdef
                     %RETURN
                  %FINISH
               %FINISH
               %RETURNIF last1=jump %AND atom1=swit
               copy = x %IF copy=0

notin:         app = 0; vid = 0
               atom1 = error+2

               %RETURNIF d=0 {old name wanted}
               type = d>>4&7; form = d&15; atom1 = amap(form)

               %IF this<0 %START {normal scope}
                  new = newname
                  tmax = tmax+1; x = tmax
               %FINISHELSESTART {recordformat scope}
                  new = -1
                  recid = recid-1; vid = recid
                  tmin = tmin-1; x = tmin
                  format list = tmin
               %FINISH

               %IF 11<=form<=14 %START {arrays}
                  dim = 1 %IF dim=0 {set dim for owns}
                  app = dim
               %FINISH

               d = d!used bit %IF %C
                  (otype>2 %AND d&spec=0) %OR perm#0 %OR Level=Include Level

                                         !external definitions need not be used in the file in which
                                         !they are defined, so inhibit a useless unused warning.

               t == tag(x)
               %IF form=lab %START
                  id = id+1; vid = id
               %FINISH
               t_index = vid
               t_text = new name
               t_flags <- d
               t_app = app
               t_format = fdef; format = fdef
               subatom = x

               %IF new>=0 %START {insert into hash table}
                  t_link = dict(new); dict(new) = x
                  %IF gmin=max grammar %START {proc param params}
                     tmin = tmin-1; subatom = tmin
                     tag(tmin) = t
                  %FINISH
               %FINISH
               abandon(2) %IF tmax>=tmin
            %END



top:        pos1 = pos
            subatom = 0; pend quote = 0; atom flags = 0 {***new***}

                                         !app and format must be left for assigning to papp & pformat

            ->name %IF symtype=-2 {letter}
            ->number %IF symtype<0 {digit}
            %IF symtype=0 %START
               atom1 = termin; atom2 = 0
               %RETURN
            %FINISH
            %IF symtype#2 %START {catch keywords here}
               ->text %IF quote#0 {completion of text}
               ->strings %IF sym=squote {start of string}
               ->symbols %IF sym=cquote {start of symbol}
               ->number %IF sym='.' %AND '0'<=nextsymbol<='9'
            %FINISH

                                         !locate atom in fixed dict
            k = key>>2; read sym
            %CYCLE
               j = kdict(k)
               %EXITIF j&x'4000'#0
               %IF j&127#sym %OR symtype<0 %START
                  ->err %UNLESS j<0
                  k = k+1
               %FINISHELSESTART
                  l = j>>7&127; read sym
                  %IF j>0 %START
                     %IF l#0 %START
                        ->err %IF l#sym %OR symtype<0
                        read sym
                     %FINISH
                     l = 1
                  %FINISH
                  k = k+l
               %FINISH
            %REPEAT
            atom1 = j&127
            %IF atom1=0 %START {comma}
               atom1 = 19; subatom = 19; atom2 = 0
               %IF sym=nl %START
                  %RETURNIF ocount>=0

                                         !special action needs to be taken with <comma nl> as
                                         !const array lists can be enormous

                  read sym
               %FINISH
               %RETURN
            %FINISH
            atom2 = j>>7&127
            subatom = kdict(k+1)&x'3fff'
                                         !!!!!cont = ' '
            %RETURN

                                         !report an error. adjust the error marker (pos1) to point
                                         !to the faulty character in an atom, but care needs to be taken
                                         !to prevent misleading reports in cases like ...?????

err:        atom1 = error+1; atom2 = 0
            pos1 = pos %IF pos-pos1>2
            %RETURN

                                         !take care with strings and symbol constants.
                                         !make sure the constant is valid here before sucking it in
                                         !(and potentially loosing many lines)

symbols:    atom1 = var; atom2 = const; type = integer
            map gg = const; protection = prot
            subatom = lp; abandon(3) %IF lp>=lit max
            quote = \pend quote
            %RETURN

                                         !an integer constant is acceptable so get it in and
                                         !get the next atom

chars:      n = 0
            %CYCLE
               read sym
               Cont = Cquote
               %IF sym=cquote %START
                  %EXITIF nextsymbol#cquote
                  read sym
               %FINISH
               %IF n&(\((-1)>>byte size))#0 %START { overflow}
                  pos1 = pos; atom1 = error+10; %RETURN
               %FINISH
               ->err %IF quote=0
               n = n<<byte size+sym
               quote = quote+1
            %REPEAT
            quote = 0; cont = ' '
            readsym %IF sym#nl
            lit pool(lp) = n; lp = lp+1
            ->top

                                         !sniff the grammar before getting the string

strings:    atom1 = var; atom2 = const; type = stringv
            subatom = (strp-stbase)!x'4000'
            map gg = const; protection = prot
            quote = subatom
            text line = lines {in case of errors}
            %RETURN

                                         !a string constant is ok here, so pull it in and get
                                         !the next atom

text:       ->chars %IF quote<0 {character consts}
            l = strp; n = strp
            j = addr(glink(gmin-1)) {absolute limit}
            k = l+256 {string length limit}
            k = j %IF j<k {choose lower}

            %CYCLE
               quote = 1
               %CYCLE
                  read sym
                  Cont = Squote
                  %IF sym=squote %START {terminator?}
                     %EXITIF nextsymbol#squote {yes ->}
                     read sym { skip quote}
                  %FINISH
                  l = l+1; byteinteger(l) = sym
                  lines = text line %AND abandon(7) %IF l>=k {too many chars}
               %REPEAT
               byteinteger(n) = l-n {plug in length}

               strp = l+1 {ready for next string}
               quote = 0; cont = ' '; read sym
               code atom(target)
               %RETURNUNLESS atom1=48 %AND sym=squote {fold "???"."+++"}
            %REPEAT

            %ROUTINE get(%INTEGER limit)
               %INTEGER s,shift
               shift = 0
               %IF base#10 %START
                  %IF base=16 %START
                     shift = 4
                  %FINISHELSEIF base=8 %START
                     shift = 3
                  %FINISHELSEIF base=2 %START
                     shift = 1
                  %FINISH
               %FINISH
               n = 0
               %CYCLE
                  %IF symtype=-1 %START {digit}
                     s = sym-'0'
                  %FINISHELSEIF symtype<0 %START {letter}
                     s = sym-'A'+10
                  %FINISHELSESTART
                     %RETURN
                  %FINISH
                  %RETURNIF s>=limit
                  pt = pt+1; byteinteger(pt) = sym
                  %IF base=10 %START {check overflow}
                     %IF n>=max int %AND (s>max dig %OR n>max int) %START

                                         !too big for an integer,
                                         !so call it a real

                        base = 0; type = real; n = 0
                     %FINISH
                  %FINISH
                  %IF shift=0 %START
                     n = n*base+s
                  %FINISHELSESTART
                     n = n<<shift+s
                  %FINISH
                  read sym
               %REPEAT
            %END

number:     base = 10
bxk:        atom1 = var; atom2 = const; type = integer; subatom = lp
            map gg = const; protection = prot
            abandon(3) %IF lp>=lit max
            pt = strp; mul = 0
            %CYCLE
               get(base)
               %EXITUNLESS sym='_' %AND base#0 %AND %C
                  pend quote=0 {change of base}
               pt = pt+1; byteinteger(pt) = '_'
               read sym
               base = n
            %REPEAT

            %IF pend quote#0 %START
               ->err %IF sym#cquote
               readsym
            %FINISH
            %IF sym='.' %START {a real constant}
               pt = pt+1; byteinteger(pt) = '.'
               read sym
               type = real; n = base; base = 0; get(n)
            %FINISH

            %IF sym='@' %START {an exponent}
               pt = pt+1; byteinteger(pt) = '@'; k = pt
               readsym
               type = integer; base = 10
               %IF sym='-' %START
                  read sym; get(10); n = -n
               %FINISHELSESTART
                  get(10)
               %FINISH
               pt = k+1; byteinteger(pt) = lp; litpool(lp) = n
               lp = lp+1
               atom1 = error+10 %IF base=0
               type = real {exponents force the type}
            %FINISH

            %IF type=real %START
               byteinteger(strp) = pt-strp
               subatom = (strp-stbase)!x'2000'; strp = pt+1
            %FINISHELSESTART
               litpool(lp) = n
               lp = lp+1
            %FINISH
            %RETURN

name:       atom1 = 0 %ANDRETURNIF 27<=target<=41
            hash value = 0

                                         !*****************************
                                         !*machine dependent for speed*
                                         !*****************************

            dp = dmax+1
            da = addr(dict(dp)); dbase = da
            %CYCLE
               hash value = hash value+(hash value+sym) {is this good enough?}
               da = da+1; byteinteger(da) = sym
               read sym
               %EXITIF symtype>=0
            %REPEAT
            %IF sym=cquote %START
               pend quote = 100
               ->symbols %IF hash value='M'
               read sym
               %IF hash value='X' %THEN base = 16 %AND ->bxk
               %IF hash value='K' %OR hash value='O' %THEN base = 8 %AND ->bxk
               %IF hash value='B' %THEN base = 2 %AND ->bxk
               ->err
            %FINISH
            n = da-dbase
            byteinteger(dbase) = n
            dp = dp+(n+4)>>2
            abandon(8) %IF dp>=dmin

            atom2 = 90 {ident}
            %IF last1=0 %AND sym=':' %START {label}
               limit = local; lookup(lab); %RETURN
            %FINISH
            %IF last1=jump %START {->label}
               limit = local; lookup(lab+spec+used bit); %RETURN
            %FINISH
            %IF decl#0 %AND target=90 %START {identifier}
               search base = fm base
               limit = local; lookup(decl)
               search base = 0
            %FINISHELSESTART
               limit = 0; lookup(0)
            %FINISH
         %END

         %INTEGERFN parsed machine code
                                         !   *opcode_??????????
            atom1 = error %ANDRESULT = 0 %UNLESS %C
               symtype=-2 {starts with letter}
            flush buffer %IF bp>=128
            bp = bp+1; buff(bp) = 'w'
            %CYCLE
               bp = bp+1; buff(bp) = sym
               read sym
               %EXITIF symtype>=0 {pull in letters and digits}
            %REPEAT
            bp = bp+1; buff(bp) = '_'
            %IF symtype#0 %START {not terminator}
               atom1 = error %ANDRESULT = 0 %UNLESS sym='_'
               read sym
               %WHILE symtype#0 %CYCLE
                  %IF symtype<0 %START {complex}
                     code atom(0); %RESULT = 0 %IF atom1&error#0
                     %IF atom2=const %AND type=integer %START
                        %IF subatom<0 %THEN %C
                           Set Const(tag(-subatom)_format) %ELSE %C
                           Set Const(litpool(subatom))
                     %FINISHELSEIF 91<=atom1<=109 %START
                        %IF atom1=104 {label} %AND %C
                           Tag(Subatom)_Flags&Closed=0 %START
                           This = Subatom; Atom1 = Error+21
                           %RESULT = 0
                        %FINISH
                        op(' ',tag(subatom)_index)
                     %FINISHELSESTART
                        atom1 = error; %RESULT = 0
                     %FINISH
                  %FINISHELSESTART
                     bp = bp+1; buff(bp) = sym; read sym
                  %FINISH
               %REPEAT
            %FINISH
            bp = bp+1; buff(bp) = ';'
            %RESULT = 1
         %END
         %ROUTINE Set FTP
            Arp == Ar(Nmax)
            X = Arp_X
            Pos1 = Arp_Pos
            Pos2 = 0
            App = 0
            Format = Tag(X)_Format
            Flags = Tag(X)_Flags
            Type = Flags>>4&7
            Protection = Flags&Prot
            Protection = 0 %IF Flags&Aname#0
         %END

         %ON 9 %START {input ended}
            Abandon(5) %UNLESS Sstype=-2 {start of statement}
            Atom1 = 76; Atom2 = 0; Subatom = 0 {%endoffile}
            Sym = NL; Symtype = 0
            ->EOF
         %FINISH

         cont = ' ' %IF gg=0
         last1 = 0; mapgg = 0
         s = 0; ss = 0; sstype = -2; fdef = 0
         fm base = 0
         app = 0

                                         !deal with alignment following an error in one statement
                                         !of several on a line

         margin = column {start of statement}

         pos = 0
         stbase = addr(glink(gmax+1)); strp = stbase; lp = 0
         tbase = tstart {??????????????}
         local = tbase

         %IF gg=0 %OR ocount>=0 %START {data or not continuation(z)}
again:      %WHILE sym type=0 %CYCLE {skip redundant terminators}
               c = cont
               cont = ' '; cont = '+' %IF ocount>=0
               read sym
               cont = c
            %REPEAT
            ->skip %IF sym='!' {comment}
            this = -1
            code atom(0)
            %IF atom1=comment %START
skip:          quote = 1
               c = cont
               read sym %AND cont = c %WHILE sym#nl {skip to end of line}
               quote = 0; symtype = 0
               ->again
            %FINISH
         %FINISH
         decl = 0; mark = 0
         gentype = 0; force = 0
         dim = 0; prot err = 0
         node = 0; nmax = 0; nmin = rec size+1
         order = 1; gmin = max grammar+1
         sstype = 0 %AND ->more %IF gg#0 {continuation}
         ptype = 0; spec given = 0

         stats = stats+1; op('O',lines) %IF perm=0 %AND include=0

         ->fail1 %IF atom1&error#0 {first atom faulty}

         %IF escape class#0 %START {enter the hard way after}
            g = imp phrase; sstype = -1; ->a3
         %FINISH

EOF:
         g = initial(atom1) {pick up entry point}
         %IF g=0 %START {invalid first atom}
            g = initial(0); sstype = 0; ->a3 {declarator?}
         %FINISH
         %IF g<0 %START {phrase imp}
            g = g&255
            nmax = 1
            ar(1)_class = 0; ar(1)_link = 0; ar(1)_sub = imp phrase
         %FINISH

         gg = gram(g); class = gg&255; sstype = gg>>12&3-1
         ->a1

act(194):ptype = type; papp = app; pformat = format; ->more
act(196):k = g+1; ->a610
act(188):k = ar(nmax)_sub+1
a610:    papp = glink(k)
         k = gram(k)
         ->more %IF k=0 {%NAME}
         ptype = k&7; pformat = k>>3
act(183):k = type; gentype = k %IF gentype=0 %OR k=real {%TYPE}
         %IF pformat<0 %START {general type}
            app = papp; format = pformat
            k = real %IF ptype=real %AND type=integer
            k = force %AND force = 0 %IF force#0
         %FINISH
         ->fail2 %UNLESS papp=app %AND (ptype=k %OR ptype=0)
         ->more %IF pformat=format %OR pformat=0 %OR format=0
         %IF Ptype=Record %AND Control&1#0 %START
            Lazy Ercc = 1
            ->More
         %FINISH
         ->fail2
act(197):arp == ar(nmin)
         k = arp_sub
         ->fail3 %UNLESS block form=k&15
         arp_sub = k>>4

         type = block type
         ptype = block type; pformat = block fm; papp = app
         pformat = -1 %IF ptype#record
         ->more
act(195):->Fail2 %IF Type#0 %AND Type#Integer %AND Type#Real
         arp == ar(nmin)
         k = arp_sub
         arp_sub = k>>2
         k = k&3
                                         !1 = check integer
                                         !2 = check real
                                         !3 = check real + int
         ->more %IF k=0 {0 = no action}
         %IF k=1 %START
            force = integer
            ->more %IF type=integer %OR type=0
            ->fail2
         %FINISH
         ->fail2 %UNLESS ptype=real %OR ptype=0 {or added?}
         force = integer %IF k=3
         ->more
act(198):                                !%OTHER
         k = gg>>8&15
         %IF k=0 %START {restore atom}
            atom1 = last1
            ->more
         %FINISH
         %IF k=1 %START {test string}
            ->fail2 %UNLESS type=stringv
            ->more
         %FINISH
         %IF k=2 %START {fault record comparisons}
            ->fail2 %IF type=record
            ->more
         %FINISH
         %IF k=3 %START {check OWN variable coming}
            code atom(0)
            ->A7 %IF atom flags&own bit=0
            ->more
         %FINISH
         %IF k=6 %START
            Set FTP
            Atom1 = 91 {V}
            ->More
         %FINISH
         for warn = pos1 %IF x<=local {%FORTEST}
         ->more
paction(1):%IF type=record %THEN g = phrase(242) %ELSE pformat = -1
         ->a3
paction(2):ptype = real; pformat = -1; ->a3
paction(3):ptype = stringv; pformat = -1; ->a3
paction(4):ptype = integer; pformat = -1; ->a3
paction(5):->a3 %IF ptype=integer
         g = phrase(212) %AND pformat = -1 %IF ptype=real
         g = phrase(213) %IF ptype=stringv
         ->a3
paction(6):ptype = gram(ar(nmax)_sub+1)&7; pformat = -1; ->a3
paction(7):ptype = real %IF ptype=integer; pformat = -1; ->a3

a1:      last1 = class; atom1 = 0; s = subatom

a2:      %IF gg&trans bit=0 %START {insert into analysis record}
            z == node
            %CYCLE {insert cell in order}
               k = z
               %EXITIF gg&order bits=0 %OR k=0
               gg = gg-order bit; z == ar(k)_link
            %REPEAT
            gg = map gg %IF map gg#0 %AND gg&255=var
            nmin = nmin-1; ->fail0 %IF nmin=nmax
            z = nmin
            arp == ar(nmin)
            arp_sub = s; arp_class = (gg&255)!mark
            arp_link = k
         %FINISH
         mark = 0; map gg = 0

more:    g = glink(g) {chain down the grammar}

paction(0):
a3:      gg = gram(g); class = gg&255
         trace analysis %IF diag&1#0
         ->a5 %IF class=0 {end of phrase}

         %IF class<actions %START {not a phrase or an action}
            class = atomic(class) %IF class>=figurative
            ->a2 %IF class>=manifest
            code atom(class) %IF atom1=0
            %IF escape class#0 %START {escape to new grammar}
               class = escape class; escape class = 0
               g = g+escape

                                         !note that following an escape the next item is
                                         !forced to be transparent!

esc:           gg = 0
               arp == ar(nmax+1)
               arp_papp = papp; arp_x = x; ->a4
            %FINISH

            ->a1 %IF class=atom1 %OR class=atom2

a7:         ->fail1 %IF gg>=0 {no alternative}
            g = g+1
            ->a3
         %FINISH

         %IF class>=phrasal %START {a phrase}
a4:         nmax = nmax+1; ->fail0 %IF nmax=nmin
            arp == ar(nmax)
            arp_ptype = ptype
            arp_pos = pos1
            arp_pformat = pformat
            arp_link = gentype
            arp_class = node
            arp_sub = g
            node = 0
            g = phrase(class)
            ptype = force %AND force = 0 %IF force#0
            gentype = 0
            ->paction(gg>>8&15)
         %FINISH

         ->act(class) {only actions left}

a5:                                      !reverse links

         s = 0
         %WHILE node#0 %CYCLE
            z == ar(node)_link
            k = z; z = s; s = node; node = k
         %REPEAT
         ss = s

a6:      %IF nmax#0 %START
            k = gentype {type of phrase}
            arp == ar(nmax); nmax = nmax-1
            node = arp_class
            gentype = arp_link
            ptype = arp_ptype
            pformat = arp_pformat
            g = arp_sub
            %IF g&escape#0 %START
               g = g-escape
               papp = arp_papp
               mark = 255
               subatom = s
               ->a3
            %FINISH
            gentype = k %IF gentype=0 %OR k=real
            type = gen type

            k = gg {exit-point code}
            %CYCLE
               gg = gram(g)
               ->a2 %IF k=0
               ->fail1 %IF gg>=0 {no alternative phrase}
               k = k-order bit
               g = g+1 {sideways step}
            %REPEAT

         %FINISH

         Fault(4) %IF copy#0
         fault(13) %IF order=0
         fault(-4) %IF for warn#0
         pos1 = 0
         fault rate = fault rate-1
         %RETURN

act(193):gg = 0 %AND ->a5 %UNLESS sym='=' %OR sym='<' {cdummy}
act(181):atom1 = amap(decl&15) {dummy}
         ->more

act(182):class = escdec; g = glink(g)!escape
         decl = 0; otype = 0; ->esc {decl}

act(199):                                !compile

         s = 0
         %WHILE node#0 %CYCLE
            z == ar(node)_link
            k = z; z = s; s = node; node = k
         %REPEAT
         ss = s

         code atom(28) %IF quote#0 {expend}
         compile; ->more %IF atom1&error=0
         ->fail1

act(184):->fail4 %UNLESS type=integer
         %IF subatom<0 %THEN lit = tag(-subatom)_format %ELSE %C
            lit = lit pool(subatom)
         ->fail4 %IF lit#0
         ->more
act(185):                                !apply parameters
         s = 0
         %WHILE node#0 %CYCLE
            z == ar(node)_link
            k = z; z = s; s = node; node = k
         %REPEAT
         ss = s

         atom1 = ar(s)_class; atom2 = 0
         atom1 = var %IF atom1=97 %OR atom1=98
         Set FTP

         %IF flags&subname#0 %AND format#0 %START
            ->fail1 %IF format selected=0
         %FINISH

         Escape Class = EscN %IF Atom1=92 {N} %AND Sym='['

         ->a6

act(187):protection = prot; ->more {%SETPROT}
act(186):->More %IF protection&prot=0
         prot err = nmin
         ->A7
act(191):k = protection {%GUARD}
         code atom(0)
         protection = k %IF atom flags&aname=0
         ->more

act(192):->fail1 %IF parsed machine code=0
         ->more

act(189):k = gapp {%GAPP}
         delete names(1)
         tmax = tbase; tbase = gram(gmin) {restore tmax}
         local = tbase
         gmin = gmin+1

         x = ar(ar(nmax)_class)_sub
         tag(x)_app = k {update app}
         ->more

act(180):Atom1 = 45 {Sign}
         Atom2 = 0
         Subatom = 36 {Minus}
         ->More

act(190):gmin = gmin-1 {%LOCAL}
         abandon(2) %IF gmin<=gmax
         gram(gmin) = tbase; tbase = tmax
         local = tbase
         ->more

! errors

fail4:   k = error+10; ->failed {*size}
fail3:   k = error+7; ->failed {*context}
fail2:   k = error+5; pos2 = 0; ->failed {*type}
fail0:   k = error+3; ->failed {*too complex}
fail1:   k = atom1; pos2 = 0

failed:
         %IF diag&32#0 %START
            printstring("Atom1 ="); write(atom1,3)
            printstring("  Atom2 ="); write(atom2,3)
            printstring("  subatom ="); write(subatom,3); newline
            printstring("Type ="); write(type,1)
            printstring("   Ptype ="); write(ptype,1); newline
            printstring("App ="); write(app,1)
            printstring("   Papp ="); write(papp,1); newline
            printstring("Format ="); write(format,1)
            printstring("   Pformat ="); write(pformat,1); newline
            %SIGNAL 13,15
         %FINISH

         quote = 0 %AND readsym %WHILE sym#nl %AND sym#';'
         %IF k&error#0 %START
            fault(k&255)
         %FINISHELSESTART
            %IF prot err=nmin %THEN fault(14) %ELSE fault(0)
         %FINISH
         gg = 0; ss = 0; symtype = 0
      %END {of analyse}

      %ROUTINE compile

         %CONSTINTEGER then= 4, else = 8, loop = 16
         %INTEGERNAME Dcon

         %SWITCH c(0:actions),litop(1:12)

         %CONSTBYTEINTEGERARRAY operator(1:14)= %C
                         '[',  ']',  'X',  '/', '&',  '!',  '%',  '+',
                         '-',  '*',  'Q',  'x', '.',  'v'

         %CONSTBYTEINTEGERARRAY cc(0:7)= '#','=',')','<','(','>', 'k','t'

         %CONSTBYTEINTEGERARRAY anyform(0:15)= 1,0,1,1(4),1,0,1,1,0,1,1,1,1

         %CONSTINTEGERARRAY decmap(0:15)= %C
         1,             2,
         x'100B',       x'100D',       x'140C',      x'140E',
         3,             4,
         x'1007',       x'1008',       x'1009',      x'100A',
         6,             0,             0,            0
         %OWNBYTEINTEGERARRAY cnest(0:15)
         %RECORD (Tagfm) %NAME T
         %INTEGER lmode,clab,dupid
         %INTEGER resln
         %OWNINTEGER last def= 0
         %OWNINTEGER lb,ub
         %INTEGER cp,ord
         %INTEGER next,link,j,k,n,done,St Len
         %INTEGER class
         %INTEGER lit2,defs,decs,cident
         %INTEGERNAME PP
         %INTEGER pending; %OWNINTEGERARRAY pstack(1:40)
         %OWNSTRING (8) name= ""
         %OWNINTEGER count= 0

         %ROUTINE def lab(%INTEGER l)
            op(':',l)
            access = 1
         %END

         %ROUTINE get next
            %RECORD (arfm) %NAME p
gn:         %IF next=0 %START {end of phrase}
               class = 0 %ANDRETURNIF link=0 {end of statement}
               p == ar(link)
               next = p_link
               link = p_sub
            %FINISH
            %CYCLE
               p == ar(next)
               x = p_sub
               class = p_class
               %EXITIF class<actions {an atom}
               %IF x=0 %START {null phrase}
                  next = p_link; ->gn
               %FINISH
               %IF p_link#0 %START {follow a phrase}
                  p_sub = link; link = next
               %FINISH
               next = x
            %REPEAT
            next = p_link
            %IF diag&2#0 %START
               spaces(8-length(name)) %UNLESS name=""
               name = text(class)
               write(x,2)
               space
               printstring(name)
               space
               count = count-1
               %IF count<=0 %START
                  count = 5
                  name = ""
                  newline
               %FINISH
            %FINISH
         %END

         %ROUTINE set subs(%INTEGER n)

                                         !update the app field in n array descriptors

            %INTEGER p
            p = tmax
            %WHILE n>0 %CYCLE
               %SIGNAL 14,15 %IF p<tbase
               tag(p)_app = dimension
               p = p-1; n = n-1
            %REPEAT
         %END

         %ROUTINE set bp

                                         !define a constant bound pair from the last stacked constants

            pending = pending-2
            lb = pstack(pending+1); ub = pstack(pending+2)
            %IF ub-lb+1<0 %START
               pos1 = 0; next = link; fault(11)
               ub = lb
            %FINISH
            set const(lb); set const(ub)
            bp = bp+1 %AND buff(bp) = 'b' %UNLESS class=146
         %END

         %ROUTINE compile end(%INTEGER type)

                                         ! type = 0:eof, 1:eop, 2:end

            %IF access#0 %START
               open = 0
               fault(19) %IF block form>proc {can reach end}
            %FINISH

            %WHILE dict(dmin)>=0 %CYCLE {finishes & repeats}
               fault(17+dict(dmin)&1)
               dmin = dmin+1
            %REPEAT
            {delete names(0)}
            bp = bp+1; buff(bp) = ';'
            bp = bp+1 %AND buff(bp) = ';' %IF type=1 {endofprogram}

            bflags = bflags!open {show if it returns}

            %IF type#2 %START {eop, eof}
               fault(16) %IF level#type {end missing}
            %FINISHELSEIF level=0 %START
               fault(15) {spurious end}
            %FINISH

            end mark = 10 {******Mouses specific******}
         %END

         %ROUTINE def(%INTEGER p)

                                         !dump a descriptor

            %INTEGER t,f,type
            %RECORD (tagfm) %NAME v
            flush buffer %IF bp#0
            defs = defs+1
            v == tag(p)
            t = 0
            %UNLESS v_index<0 %START {no index for subnames}
               id = id+1 %AND v_index = id %IF v_index=0
               last def = v_index
               t = last def
            %FINISH
            op('$',t)
            print ident(p,1) {output the name}
            t = v_flags
            type = t
            type = type&(\(7<<4)) %IF type&(7<<4)>=6<<4 {routine & pred}
            op(',',type&b'1111111') {type & form}
            f = v_format
            f = tag(f)_index %IF t&x'70'=record<<4
            f = v_index %IF f<0
            Put Tag(f) {format}
            f = otype+t>>4&b'1111000'
            f = f!8 %IF class=125 {add spec from %DUP}
            dim = v_app {dimension}
            dim = 0 %UNLESS 0<dim<=dim limit
            Put Tag(f+dim<<8) {otype & spec & prot}
            defs = 0 %IF t&parameters=0
            f = t&15
            %IF v_flags&spec#0 %START
!!!!*why???            v_flags = v_flags&(\spec) %UNLESS 3 <= f <= 10
               ocount = -1 {external specs have no constants}
            %FINISH
            dimension = 0
            %IF otype=2 %AND (f=2 %OR f=12 %OR f=14) %START
               v_flags = v_flags-1 {convert to simple}
            %FINISH
         %END

         %ROUTINE def s lab(%INTEGER n)

                                         !define a switch label, x defines the switch tag

            %INTEGER p,l,b,w,bit
            p = tag(x)_format {pointer to table}
            l = dict(p) {lower bound}
            %IF l<=n<=dict(p+1) %START
               b = n-l
               w = b>>4+p
               bit = 1<<(b&15)
               %IF dict(w+2)&bit#0 %START {already set}
                  fault(4) %IF pending#0
                  %RETURN
               %FINISH
               dict(w+2) <- dict(w+2)!bit %IF pending#0
               set const(n)
               op('_',tag(x)_index)
            %FINISHELSESTART
               fault(12)
            %FINISH
            access = 1
         %END

         %ROUTINE call
            %RECORD (tagfm) %NAME T
            t == tag(x)
            op('@',t_index)
            access = 0 %IF t_flags&closed#0 {never comes back}
            bp = bp+1 %AND buff(bp) = 'E' %IF t_app=0 {no parameters}
         %END

         %ROUTINE pop def
            set const(pstack(pending)); pending = pending-1
         %END

         %ROUTINE pop lit
            %IF pending=0 %THEN lit = 0 %ELSESTART
               lit = pstack(pending); pending = pending-1
            %FINISH
         %END


         %IF sstype<0 %START {executable statement}
            %IF level=0 %START {outermost level}
               fault(13) {*order}
            %FINISHELSESTART
               %IF access=0 %START
                  access = 1; fault(-1) {only a warning}
               %FINISH
            %FINISH
         %FINISH

         %IF diag&2#0 %START
            newline %IF sym#nl
            printstring("ss =")
            write(ss,1)
            newline
            count = 5
            name = ""
         %FINISH

         next = ss
         pending = 0; lmode = 0
         link = 0; decs = 0
         defs = 0; resln = 0; done = 0; St Len = 0
         ord = level
         ord = 1 %IF this>=0 {recordformat declarations}
c(0):
top:     %IF next#link %START
            get next; ->c(class)
         %FINISH

                                         !all done, tidy up declarations and jumps

         newline %IF diag&2#0 %AND count#5

         %IF lmode&(loop!then!else)#0 %START {pending labels and jumps}
            op('B',label-1) %IF lmode&loop#0 {repeat}
            def lab(label) %IF lmode&then#0 {entry from then}
            def lab(label-1) %IF lmode&else#0 {entry from else}
         %FINISH

         %RETURNIF decs=0
         atom1 = error %ANDRETURNIF atom1#0 {%INTEGERROUTINE}
         order = ord
         decl = decl&(\15)+decmap(decl&15) {construct declarator flags}
         atom1 = atoms(decl&15) {generate class}
         %IF otype#0 %START {own, const etc.}
            atom1 = atom1+1 %IF atom1#proc
            %IF otype=2 %START {const}
               n = decl&15
               %IF n&1#0 %START
                  decl = decl!prot
                  decl = decl!const bit %IF decl&b'1111111'=iform
               %FINISH
            %FINISHELSESTART
               decl = decl!own bit
            %FINISH
         %FINISH
         sstype = 1 %IF sstype=0 %AND atom1=proc
         atom1 = atom1+1 %IF decl&spec#0 {onto spec variant}
         ocount = 0 %AND cont = '+' %IF atom1=5 {own array}
         %IF anyform(decl&15)=0 %START {check meaningful}
            %IF decl>>4&7=record %START
               this = fdef %IF tag(fdef)_flags&spec#0
               atom1 = error+21 %IF fdef=this {*context for format}
            %FINISH
            %IF Fdef=0 %START {*Size ?}
               Atom1 = Error+10 %UNLESS %C
                  Otype=2 %AND Decl&2_1111111=StringV<<4+1
               {Permit %Conststring(*) Fred}
            %FINISH
         %FINISH
         %RETURN

atop:    access = 0; ->top

! declarators

c(88):                                   !rtype
c(28):   decl = x&(\7) {stype}
         fdef = x&7 {precision}
         decs = 1; ->top
c(34):                                   !own
c(35):   otype = x; ord = 1; ->top {external}
c(17):   pop lit; otype = lit<<8+6; ord = 1; ->top {prim}
c(152):  decl = decl+x<<1; ->top {xname}
c(31):                                   !proc
c(32):   spec mode = level+1 {fn/map}
         decl = decl!prot %IF x=9 {function}
c(29):   ord = 1 {array}
         dim = 0
c(30):   decl = decl+x {name}
         decs = 1
         ->top
c(27):   lit = 0 { arrayd}
         %IF pending#0 %START
            pop lit
            %UNLESS 0<lit<=dim limit %START
               atom1 = error+11; %RETURN
            %FINISH
         %FINISH
         dim = lit
         decl = decl+x; decs = 1
         ->top
c(37):   x = x!subname {record}
c(36):   lit = 0 {string}
         %IF pending#0 %START
            pop lit
            %UNLESS 0<lit<=255 %START {max length wrong}
               atom1 = error+10; %RETURN
            %FINISH
         %FINISH
         fdef = lit {format or length}
c(33):   decl = x {switch}
         decs = 1
         ->top
c(39):   decl = decl!spec {spec}
         ocount = -1 {no initialisation}
         spec mode = -1
         ->top
c(38):   decl = 64+4 {recordformat (spec)}
         order = 1
         atom1 = x
         decl = decl!spec %IF atom1=12 {formatspec}
         fdef = tmax+1 {format tag}
         %RETURN
c(175):  id = id+1; tag(x)_index = id; %RETURN {FSID}
c(41):   decs = 1; decl = x!spec!closed; ->top {label}
c(133):  recid = 0; rbase = tmin-1 {fname}
         this = x
         fm base = fdef; format list = tmin
         def(this); ->top
c(148):  fdef = 0 %AND ->top %IF next=0 {reclb}
         get next {skip name}
         fdef = x
         ->top
c(127):  bp = bp+1; buff(bp) = '}'; ->top {%POUT}
c(126):  bp = bp+1; buff(bp) = '{'; ->top {%PIN}

c(174):  set bp {rangerb}
c(171):                                  !fmlb
c(172):                                  !fmrb
c(173):  bp = bp+1; buff(bp) = '~'
         bp = bp+1; buff(bp) = class-171+'A'; ->top {fmor}
c(168):  rbase = -rbase {orrb}
         sstype = 0; spec mode = 0

c(147):  search base = 0 {recrb}
         tag(this)_app = tmin
         tag(this)_format = rbase
         ->top

c(45):   bp = bp+1 %AND buff(bp) = 'U' %IF x=36; ->top {sign}
c(46):   bp = bp+1; buff(bp) = '\'; ->top {uop}
c(47):                                   !mod
c(48):                                   !dot
c(42):                                   !op1
c(43):                                   !op2
c(44):   bp = bp+1; buff(bp) = operator(x); ->top {op3}

!conditions & jumps

         %ROUTINE push(%INTEGER x)
            %IF cnest(cp)&2#x %START
               cnest(cp) = cnest(cp)!1; x = x+4
            %FINISH
            clab = clab+1 %IF cnest(cp)&1#0
            cnest(cp+1) = x; cp = cp+1
         %END

         %ROUTINE pop label(%INTEGER mode)
            lmode = dict(dmin)
            %IF lmode<0 %OR lmode&1#mode %START
               fault(mode+8)
            %FINISHELSESTART
               dmin = dmin+1; label = label-3
            %FINISH
         %END

c(56):                                   !and
c(57):   push(x); ->top {or}
c(58):   cnest(cp) = cnest(cp)!!2; ->top {not}

c(138):  x = 128+32+16+4 {csep: treat like %WHILE}
c(59):                                   !while
c(60):   %IF class=138 %THEN op('f',label-1) %ELSE def lab(label-1) {until}
c(166):                                  !runtil
c(62):   lmode = (lmode&(else!loop))!(x>>3) {cword}
         clab = label; cp = 1; cnest(1) = x&7
         ->top
c(72):   pop label(0) {repeat}
         def lab(label+1) %IF lmode&32#0; ->atop
c(69):   pop label(1); ->top {finish}
c(163):                                  !xelse
c(70):   pop label(1) {finish else ...}
         fault(7) %IF lmode&3=3 {dangling else}
c(68):   lmode = (lmode&else)!3 {...else...}
         %IF access#0 %START
            op('F',label-1); lmode = else!3
         %FINISH
         def lab(label)
         ->top %IF next#0

c(120):                                  !%MSTART
c(67):                                   !start
c(71):                                   !cycle
stcy:    def lab(label-1) %AND lmode = loop %IF lmode=0 {cycle}
         dmin = dmin-1; abandon(3) %IF dmin<=dmax
         Dict Upper = Dmin %IF Dmin<Dict Upper
         dict(dmin) = lmode
         label = label+3
         %RETURN

c(64):   fault(13) %IF dict(dmin)>=0 %OR inhibit#0 {on event}
         inhibit = 1
         n = 0
         n = x'FFFF' %IF pending=0 {* = all events}
         %WHILE pending>0 %CYCLE
            pop lit; fault(10) %IF lit&(\15)#0 {too big}
            j = 1<<lit
            dubious = 1 %IF n&j#0
            n = n!j {construct bit mask}
         %REPEAT
         op('o',n); Put Tag(label)
         lmode = then!1; ->stcy


c(104):  op('J',tag(x)_index) {l}
         inhibit = 1; ->atop
c(149):  stats = stats-1 {lab}
         access = 1; inhibit = 1
         op('L',tag(x)_index); ->top

c(63):   j = dmin; l = label {exit, continue}
         %CYCLE
            l = l-3
            fault(7) %AND ->top %IF dict(j)<0
            %EXITIF dict(j)&1=0
            j = j+1
         %REPEAT
         l = l+1 %IF x=32 {continue}
         op('F',l)
         dict(j) = dict(j)!x {show given}
         ->atop

c(50):   bp = bp+1; buff(bp) = 'C'; ->cop {acomp}

c(176):  x = 2 {<}
c(49):   bp = bp+1
         %IF next#0 %START {comparator}
            buff(bp) = '"'; push(0) {double sided}
         %FINISHELSESTART
            buff(bp) = '?'
         %FINISH

cop:     x = x!!1 %IF cnest(cp)&2#0 {invert the condition}
         j = cp; l = clab
         %WHILE cnest(j)&4=0 %CYCLE
            j = j-1; l = l-cnest(j)&1
         %REPEAT
         op(cc(x),l)
         def lab(clab+1) %IF cnest(cp)&1#0
         cp = cp-1
         clab = clab-cnest(cp)&1
         ->top

c(78):                                   !fresult
c(79):                                   !mresult
c(80):   open = 0 {return, true, false}
         access = 0
c(15):   {[index]}
c(81):   bp = bp+1; buff(bp) = x; ->top {monitor}

c(82):   {stop}
c(65):   pop lit; op('e',lit) {signal}
         Fault(10) %UNLESS 0<=Lit<=15
         ->Atop
c(123):  Set Const(0); ->Top {%stackz}

c(51):   bp = bp+1; buff(bp) = 'S'; ->top {eq}
c(53):   bp = bp+1; buff(bp) = 'j'; ->top {jam transfer}
c(52):   bp = bp+1; buff(bp) = 'Z'; ->top {eqeq}

C(73):   Fault(7) %IF Level#0 {Section}
         Tbase = 0; Tstart = 0
         Delete Names(0)
         Id = 0
         List = List+1
         Section Lines = Lines; Section Stats = Stats
         Gmin = Max Grammar; Tmin = Max Tag
         Perm = 1
         Close Stream(Prims)
         Select input(Prims)
         Bp = Bp+1; Buff(Bp) = 'c'
         %IF Next#0 %START
            Get Next; ->Pstr
         %FINISH
         Bp = Bp+1; Buff(Bp) = 0 {null string}
         %RETURN
c(74):   %IF level=0 %START {begin}
            %IF progmode<=0 %THEN progmode = 1 %ELSE fault(7)
            {Permit BEGIN after external defs}
         %FINISH
         spec mode = level+1
         block x = 0
         bp = bp+1; buff(bp) = 'H'; %RETURN
c(77):   perm = 0 {endofperm}
         Lines = Section Lines; Stats = Section Stats
         select input(source)
         list = list-1
         tbase = tmax; tstart = tmax
         %RETURN
c(76):   %IF include#0 %AND x=0 %START {end of ...}
            lines = include; sstype = 0 {include}
            list = include list
            include level = 0
            include = 0;
            select input(source);        !  %RETURN
            close stream(Isource)
            %RETURN
         %FINISH
         ss = -1 {prog/file}
c(75):   compile end(x); %RETURN {%END}

c(85):   %IF x=0 %THEN Dcon == control %ELSE Dcon == Diag {control}
         Dcon = lit&x'3FFF' %IF lit>>14&3=1
         op('z'-x,lit)
         ->top
c(83):   list = list+x-2; ->top {%LIST/%ENDOFLIST}
c(86):   %IF include#0 %START {include "file"}
            fault(7); %RETURN
         %FINISH
         get next {sconst}
         include file = string(x-x'4000'+stbase)
         %BEGIN
            %ON 9 %START; Abandon(9); %FINISH
            Define("ST5,".Include File)
         %END
         include = lines; lines = 0
         include list = list; include level = level
         select input(Isource)
         ->top

c(154):  dimension = dimension+1 {dbsep}
         fault(11) %IF dimension=dim limit+1
         ->top
c(145):  set bp; ->top {crb}
c(146):  set bp {rcrb}
c(142):                                  !bplrb
         dimension = 1 %IF dimension=0
         op('d',dimension); Put Tag(defs)
         %IF class#146 %START
            set subs(defs)
            fault(13) %IF dict(dmin)>=0 %OR inhibit#0 %OR level=0
         %FINISH
         dimension = 0; defs = 0
         ->top
c(128):  id = dupid; ->top {EDUP}
c(130):  block x = x
c(125):  dupid = id {%DUP}
         %RETURNIF Level<0 {spec about}
c(90):   def(x); ->top {ident}
c(131):  T == Tag(X) {cident}
         %IF T_flags&(b'1111111'+const bit)=iform+const bit %START
            T_format = lit
         %FINISHELSESTART
            set const(lit) %IF pending#0
            %IF T_Flags&2_1111111=StringV<<4+1 %START {Simple string}
               T_Format = St Len %IF T_Format=0
               Fault(10) %IF St Len>T_Format
            %FINISH
            def(x)
            op('A',1)
         %FINISH
         cident = x
         ->top
c(124):  dubious = 1 %IF tag(cident)_flags&prot#0 {%DUBIOUS}
         ->top
c(97):                                   !f
c(98):                                   !m
c(99):                                   !p
c(96):   call; ->top {r}

c(165):                                  !nlab
c(100):                                  !rp
c(101):                                  !fp
c(102):                                  !mp
c(103):                                  !pp
c(91):                                   !v
c(92):                                   !n
c(106):                                  !a
c(107):                                  !an
c(108):                                  !na
c(109):                                  !nan
         k = tag(x)_index
         %IF k<0 %THEN op('n',-k) %ELSE op('@',k)
         ->top
c(121):  set const(0); ->top {special for zero}
c(167):  bp = bp+1; buff(bp) = 'G'; ->pstr {aconst (alias)}
c(const):                                !const
         %IF x<0 %START {constinteger}
            set const(tag(-x)_format); ->top
         %FINISH
         %IF x&x'4000'#0 %START {strings}
            bp = bp+1; buff(bp) = ''''
pstr:       x = x-x'4000'+stbase
            St Len = byteinteger(x)
            bp = bp+1; buff(bp) = St Len
            k = St Len+x
            %CYCLE
               ->top %IF x=k
               x = x+1; bp = bp+1; buff(bp) = byteinteger(x)
            %REPEAT
         %FINISH
         %IF x&x'2000'#0 %START {real}
            x = x-x'2000'+stbase
            k = byteinteger(x)
            op('D',k)
            k = k+x
            %CYCLE
               ->top %IF x=k
               x = x+1; j = byteinteger(x)
               %IF j='@' %START
                  op('@',litpool(byteinteger(x+1))); ->top
               %FINISH
               bp = bp+1; buff(bp) = j
            %REPEAT
         %FINISH
         set const(lit pool(x))
         ->top

c(137):  bp = bp+1; buff(bp) = 'i'; ->top {asep}
c(141):  bp = bp+1; buff(bp) = 'a'; ->top {arb}

!own arrays

c(132):  ocount = ub-lb+1
         def(x) {oident}
         dimension = 1; set subs(1)
         %IF next=0 %START {no initialisation}
            op('A',ocount) %IF ocount>0
            ocount = -1
         %FINISHELSESTART {initialisation given}
            get next
         %FINISH
         ->top
c(162):  lit = ocount; ->ins {indef}
c(143):  pop lit {orb}
ins:     fault(10) %AND lit = 0 %IF lit<0
         get next
         ->inst
c(139):                                  !osep (x=19)
c(153):  lit = 1
inst:    pop def %IF pending#0 {ownt (x=0)}
         op('A',lit)
         ocount = ocount-lit
         %IF ocount>=0 %START
            ->top %IF x#0 {more coming}
            ocount = -1 %ANDRETURNIF ocount=0 {all done}
         %FINISH
         fault(11); %RETURN

c(swit): op('W',tag(x)_index); inhibit = 1; ->atop
c(134):  def(x) {swid}
         n = ub-lb+1
         n = (n+15)>>4 {slots needed (includes zero)}
         j = dmax; dmax = dmax+n+2
         abandon(1) %IF dmax>=dmin
         tag(x)_format = j
         dict(j) = lb; dict(j+1) = ub
         %CYCLE
            n = n-1
            ->top %IF n<0
            j = j+1; dict(j+1) = 0
         %REPEAT
c(151):  stats = stats-1 {slab}
         fault(7) %ANDRETURNIF x<tbase
         %IF pending#0 %START {explicit label}
            def s lab(pstack(1))
         %FINISHELSESTART
            fault(4) %ANDRETURNIF tag(x)_app#0
            tag(x)_app = 1
            n = tag(x)_format
            %FOR j = dict(n),1,dict(n+1) %CYCLE
               def s lab(j)
               flush buffer %IF bp>=128
            %REPEAT
         %FINISH
         inhibit = 1
         %RETURN

c(140):  bp = bp+1; buff(bp) = 'p'; ->top {psep}
c(144):  buff(bp+1) = 'p'; buff(bp+2) = 'E'; bp = bp+2; ->top {prb}

!constant expressions

c(155):                                  !pconst
         %IF x<0 %THEN lit = tag(-x)_format %ELSE lit = lit pool(x)
         pending = pending+1
Set Lit: Pstack(Pending) = Lit; ->top
c(156):  Lit = pstack(pending); Lit = -Lit %IF Lit<0; ->SetLit {cmod}
c(157):  Lit = pstack(pending); Lit = -Lit; ->SetLit {csign}
c(158):  Lit = pstack(pending); Lit = \Lit; ->SetLit {cuop}
c(159):  {cop1}
c(160):  {cop2}
c(161):  pending = pending-1 {cop3}
         lit = Pstack(Pending)
         lit2 = pstack(pending+1)
         ->litop(x>>2)
litop(10):Lit = Lit*lit2; ->SetLit
litop(12):
litop(3):n = 1 {lit = lit\\lit2}
         fault(10) %IF lit2<0
         Lit2 = Lit2-1 %AND N = N*Lit %WHILE lit2>0
         Lit = n; ->SetLit
litop(1):Lit = Lit<<lit2; ->SetLit
litop(2):Lit = Lit>>lit2; ->SetLit
litop(5):Lit = Lit&lit2; ->SetLit
litop(11):
litop(4):%IF lit2=0 %THEN fault(10) %ELSE Lit = Lit//lit2
         ->SetLit
litop(8):Lit = Lit+lit2; ->SetLit
litop(9):Lit = Lit-lit2; ->SetLit
litop(6):Lit = Lit!lit2; ->SetLit
litop(7):Lit = Lit!!lit2; ->SetLit

c(170):  Fault(4) {%if IMPCOM_Option # ""}
!!!       IMPCOM_Option = String(x-x'4000'+Stbase)      {Option string}
         ->Top

!string resolution

c(135):  resln = 2; ->top {dotl}
c(136):  resln = resln+1; ->top {dotr}
c(55):   op('r',resln); resln = 0; ->top {resop}
c(164):  op('r',resln+4); resln = 0 {cresop}
c(122):  x = 6; ->cop {%PRED}
c(87):   set const(pstack(1)) {mass}
         bp = bp+1; buff(bp) = 'P'; ->top
      %END

   %END {of compile block}

   {list = 15 %IF Impcom_Flags&x'1000' # 0}
   tty = 0

   selectinput(2); selectoutput(listing)
   tag(max tag) = 0 {%BEGIN defn}
   tag(0) = 0; tag(0)_flags = 7 {%BEGIN tag!}
   Hash(x) = 0 %FOR x = 0,1,max names
   printstring("     Lattice Logic IMP77 Compiler - Version ")
   printstring(version)
   newlines(2)
   op('l',0)
   compile block(0,0,max dict,0,0)
   bp = bp+1; buff(bp) = nl {for bouncing off}
   flush buffer
   %IF Diag&4096#0 %START
      Select Output(0)
      Printstring("Tags: "); Write(Tag Lower,0); Write(Tmin,1)
      Newline
      Printstring("Dict: "); Write(Dmax,0); Write(Dict Upper,1)
      Newline
      Printstring("Gram: "); Write(Gmax,0); Write(Gmin,1); Newline
   %FINISH
   IMPFLAG = Stats
   IMPFLAG = ~Faulty %IF Faulty#0
   *lm_4,15,16(10)
   *bcr_15,15
%ENDOFPROGRAM