{###################################################}
{#       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 "dimpsrc.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%C
                                         ! 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%C
                                         (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,%C
                                         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%C
                                         # 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%C
                                         used in the file in which
                                         !they are defined, so inhibit a%C
                                         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%C
                                         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%C
                                         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%C
                                         marker (pos1) to point
                                         !to the faulty character in an atom,%C
                                         but care needs to be taken
                                         !to prevent misleading reports in%C
                                         cases like ...?????

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

                                         !take care with strings and symbol%C
                                         constants.
                                         !make sure the constant is valid here%C
                                         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%C
                                         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%C
                                         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%C
                                         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%C
                                         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%C
                                         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%C
                                         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%C
                                         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%C
                                         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%C
                                         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