         Edinburgh IMP77 Compiler - Version 8.4

    1  ! IMP77 compiler  first pass
    2  
    3  !###########################################################
    4  ! This program is a Copyright work.                        #
    5  !                                                          #
    6  ! Over the last 40+ years a long and distinguished list of #
    7  ! institutions, individuals and other entities have made   #
    8  ! contributions to portions of this program and may have a #
    9  ! reasonable claim over rights to certain parts of the     #
   10  ! program.                                                 #
   11  !                                                          #
   12  ! This version is therefore provided for education and     #
   13  ! demonstration purposes only                              #
   14  !###########################################################
   15  
   16  %begin
   17      %conststring(4) version = "8.4"
   18  
   19      !configuration parameters
   20      { minus one represents all bits set for an %integer     }
   21      { %integer could be 16,32,64 bits wide depending on the }
   22      { processor being targeted                              }
   23      { i.e 8086 (16 bits), 80386 (32 bits), i86_64 (64 bits) }
   24      %constinteger minus one    = -1;
   25  ! Wee change needed to cross-compile the compiler when going from 16 bit to 32 bit world
   26  !    %constinteger minus one    = 16_7fff;
   27  
   28      { now to set up various constants }
   29      %constinteger max int      = ((minus one)>>1)//10
   30      %constinteger max dig      = (minus one)>>1-maxint*10
   31      %constinteger byte size    = 8;            !bits per byte
   32      %constinteger max tag      = 800;          !max no. of tags
   33      %constinteger max dict     = 6000;         !max extent of dictionary
   34      %constinteger name bits    = 11;           !size of name table as a power of two
   35      %constinteger max names    = 1<<namebits-1;!table limit (a mask, eg 255)
   36      %owninteger   spare names  = max names
   37      %constinteger lit max      = 50;           !max no. of constants/stat.
   38      %constinteger rec size     = 520;          !size of analysis record
   39      %constinteger dim limit    = 6;            !maximum array dimension
   40  
   41      !symbols
   42      %constinteger ff     = 12;              !form feed
   43      %constinteger marker = '^';             !marker for faults
   44      %constinteger squote = '"';             !string quote
   45      %constinteger cquote = '''';            !character quote
   46  
   47      !streams
   48      %constinteger report = 0,  source = 1
   49      %constinteger object = 1, listing = 2
   50  
   51      !types
   52      %constinteger integer = 1
   53      %constinteger real    = 2
   54      %constinteger stringv = 3
   55      %constinteger record  = 4
   56  
   57      !forms
   58      %constinteger iform = integer<<4+1
   59      %constinteger var = 91
   60      %constinteger const   = 93
   61      %constinteger swit    = 105
   62      %constinteger comment = 22
   63      %constinteger termin  = 20
   64      %constinteger lab     = 3
   65      %constinteger jump    = 54
   66      %constinteger recfm = 4
   67      %constinteger proc  = 7;                     !class for proc
   68  
   69      !phrase entries
   70      %constinteger escdec   = 252
   71      %constinteger escproc  = 253
   72      %constinteger escarray = 254
   73      %constinteger escrec   = 255
   74  
   75      !%recordformat arfm(%shortinteger class,sub,link,ptype,papp,pformat,x,pos);!imp77:
   76      %recordformat arfm(%integer class,sub,link,ptype,papp,pformat,x,pos)
   77  
   78      %recordformat tagfm(%integer app, format, %integer flags, index, text, link)
   79  
   80      !flags
   81      !      *===.===.===.===.===.====.====.====.===.======.======*
   82      !      ! u ! c ! c ! p ! s ! a  ! o  ! pr ! s ! type ! form !
   83      !      ! 1 ! 1 ! 1 ! 1 ! 1 ! 1  ! 1  ! 1  ! 1 !  3   !  4   !
   84      !      *===^===^===^===^===^====^====^====^===^======^======*
   85      !        u   c   c   p   s   a    o    p    s    t      f
   86      !        s   l   o   a   u   n    w    r    p    y      o
   87      !        e   o   n   r   b   a    n    o    e    p      r
   88      !        d   s   s   a   n   m         t    c    e      m
   89      !            e   t   m   a   e     
   90      !            d       s   m
   91      !                        e
   92      !
   93      !                             
   94  
   95      %constinteger used bit   = 2_1000000000000000
   96      %constinteger closed     = 2_0100000000000000
   97      %constinteger const bit  = 2_0010000000000000
   98      %constinteger parameters = 2_0001000000000000
   99      %constinteger subname    = 2_0000100000000000
  100      %constinteger aname      = 2_0000010000000000
  101      %constinteger own bit    = 2_0000001000000000
  102      %constinteger prot       = 2_0000000100000000
  103      %constinteger spec       = 2_0000000010000000
  104  
  105      %constinteger trans bit  = 16_4000
  106      %constinteger error      = 16_8000
  107  
  108      %record(arfm)%array ar(1:rec size)
  109  
  110      %owninteger class        = 0;             !class of atom wanted
  111      %owninteger x            = 0;             !usually last tag
  112      %owninteger atom1        = 0;             !atom class (major)
  113      %owninteger atom2        = 0;             !atom class (minor)
  114      %owninteger subatom      = 0;             !extra info about atom
  115      %owninteger type         = 0
  116      %owninteger app          = 0
  117      %owninteger format       = 0;             !atom info
  118      %integer hash value
  119      %owninteger faulty       = 0;             !fault indicator
  120      %owninteger fault rate   = 0;             !fault rate count
  121      %owninteger lines        = 0;             !current line number
  122      %owninteger text line    = 0;             !starting line for string const
  123      %owninteger margin       = 0;             !statement start margin
  124      %owninteger error margin = 0
  125      %owninteger error sym    = 0
  126      %owninteger column       = 0
  127      %owninteger stats        = 0;             !statements compiled
  128      %owninteger mon pos      = 0;             !flag for diagnose
  129      %owninteger sym          = nl;            !current input symbol
  130      %owninteger symtype      = 0;             !type of current symbol
  131      %owninteger quote        = 0;             !>0 strings, <0 chars
  132      %owninteger end mark     = 0;             !%end flag
  133      %owninteger cont         = ' '
  134      %owninteger csym         = ' ';           !listing continuation marker
  135      %owninteger decl         = 0;             !current declarator flags
  136      %owninteger dim          = 0;             !arrayname dimension
  137      %owninteger spec given   = 0
  138  
  139      %owninteger escape class = 0;             !when and where to escape
  140      %owninteger protection   = 0
  141      %owninteger atom flags   = 0
  142      %owninteger otype        = 0;             !current 'own' type
  143      %owninteger reals ln     = 1;             ! =4 for %REALSLONG
  144      %owninteger last1        = 0;             !previous atom class
  145      %owninteger gen type     = 0
  146      %owninteger ptype        = 0;             !current phrase type
  147      %owninteger papp         = 0;             !current phrase parameters
  148      %owninteger pformat      = 0;             !current phrase format
  149      %owninteger force        = 0;             !force next ptype
  150      %owninteger g            = 0
  151      %owninteger gg           = 0
  152      %owninteger map gg       = 0;             !grammar entries
  153      %owninteger fdef         = 0;             !current format definition
  154      %owninteger this         = -1;            !current recordformat tag
  155      %owninteger nmin         = 0;             !analysis record atom pointer
  156      %owninteger nmax         = 0;             !analysis record phrase pointer
  157      %owninteger rbase        = 0;             !record format definition base
  158      %owninteger dmax         = 1
  159      %owninteger tmin         = max tag;       !upper bound on tags
  160      %owninteger ss           = 0;             !source statement entry
  161      %string(63) include file
  162      %owninteger include list = 0
  163      %owninteger include level= 0
  164      %owninteger include      = 0;             !=0 unused, #0 being used
  165      %owninteger perm         = 1;             !1 = compiling perm, 0 = program
  166      %owninteger progmode     = 0;             !-1 = file, 1 = begin/eop
  167      %owninteger sstype       = 0;             !-1:exec stat
  168                                                ! 0: declaration
  169                                                ! 1: block in
  170                                                ! 2: block out
  171      %owninteger spec mode    = 0;             !>=0: definition
  172                                                ! -1: proc spec
  173                                                ! -2: recordformat
  174      %owninteger ocount       = -1;            !own constants wanted
  175      %owninteger limit        = 0;             !lookup limit
  176      %owninteger copy         = 0;             !duplicate name flag
  177      %owninteger order        = 0;             !out of sequence flag
  178      %owninteger for warn     = 0;             !non-local flag
  179      %owninteger dubious      = 0;             !flag for dubious statements
  180      %owninteger dp           = 1
  181      %owninteger pos1         = 0
  182      %owninteger pos2         = 0;             !error position
  183      %owninteger pos          = 0;             !input line index
  184      %owninteger dimension    = 0;             !current array dimension
  185      %owninteger local        = 0;             !search limit for locals
  186      %owninteger fm base      = 0;             !entry for format decls
  187      %owninteger search base  = 0;             !entry for record_names
  188      %owninteger format list  = 0;             !size of current format list
  189      %integer recid
  190      %ownbyteintegerarray char(0:133) = ;  !input line
  191+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  192+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  193+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  194+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  195+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  196+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  197+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  198+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  199+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  200+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  201+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  202+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  203+     10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
  204+     10, 10, 10, 10
  205      %integerarray lit pool(0:lit max)
  206      %owninteger lit          = 0;             !current literal (integer)
  207      %owninteger lp           = 0;             !literals pointer
  208      %owninteger block x      = 0;             !block tag
  209      %owninteger list         = 1;             !<= to enable
  210      %owninteger control      = 0
  211      %owninteger diag         = 0;             !diagnose flags
  212      %integerarray hash(0:max names)
  213      %record(tagfm)%array tag(0:max tag)
  214      %integerarray dict(1:max dict)
  215      %byteintegerarray buff(1:512)
  216      %owninteger bp           = 0
  217  
  218      { grammar related constants }
  219      %constinteger max grammar  = 1720
  220      %owninteger gmin       = max grammar               ;! upper bound on grammar
  221      %constinteger manifest = 120, figurative = 130
  222      %constinteger actions  = 180, phrasal    = 200
  223  
  224      %constbyteintegerarray amap(0:15) = %c
  225+        89,   91,   92,  104,   94,   93,  105,  100,  101,  102,  103,  106,  107,  108,  109,   89
  226      !   ?     v     n     l    fm const  swit    rp    fp    mp    pp     a    an    na    nan    ?
  227  
  228      %constbyteintegerarray atoms(0:15) = 89, 1, 1, 10,  9,  1, 10,  7,
  229+                                           7, 7, 7,  4,  1,  4,  1, 89
  230  
  231      !*** start of generated tables ***
  232  !    %include "i77.tables.imp"
  233     %endoflist
  572  !%endoffile
  573      !***  end  of generated tables ***
  574  
  575      %routine flush buffer( %integer limit )
  576          %integer j
  577          %if bp >= limit %start
  578          %if faulty = 0 %start
  579              selectoutput(object)
  580              %for j = 1, 1, bp %cycle
  581                  printsymbol(buff(j))
  582              %repeat
  583              selectoutput(listing)
  584          %finish
  585          bp = 0
  586          %finish
  587      %end
  588  
  589      %routine add char( %byteinteger ch )
  590          bp = bp + 1
  591          buff(bp) = ch
  592      %end
  593  
  594      %routine op(%integer code, param)
  595          buff(bp+1) = code
  596          buff(bp+2) = param>>8
  597          buff(bp+3) = param
  598          bp = bp+3
  599      %end
  600  
  601      %routine set const(%integer m)
  602          buff(bp+1) = 'N'
  603          buff(bp+5) = m;  m = m>>8
  604          buff(bp+4) = m;  m = m>>8
  605          buff(bp+3) = m;  m = m>>8
  606          buff(bp+2) = m
  607          bp = bp+5
  608      %end
  609  
  610      %routine octal(%integer n)
  611          %integer m
  612          m = n>>3
  613          octal(m) %if m # 0
  614          add char( n&7+'0' )
  615      %end
  616  
  617      %routine hexadecimal(%integer n)
  618          %integer m
  619          m = n>>4
  620          hexadecimal(m) %if m # 0
  621          %if n&15 > 9 %then add char( n&15+'A' ) %else add char( n&15+'0' )
  622      %end
  623  
  624      %routine print ident(%integer p, mode)
  625  
  626          %routine putit(%integer ch)
  627              %if mode = 0 %then %start
  628                  printsymbol(ch)
  629              %else
  630                  add char( ch )
  631              %finish
  632          %end
  633  
  634          %integer k, l
  635          p = tag(p)_text
  636          %if p = 0 %start
  637              putit('?')
  638              %return
  639          %finish
  640          p = p+1;       ! advance to name string
  641          k = dict(p)
  642          l = k & 255;   ! length
  643          %while l > 0 %cycle
  644              putit(k>>8)
  645              l = l-1
  646              p = p+1
  647              k = dict(p)
  648              %exit %if l = 0
  649              putit(k&255)
  650              l = l-1
  651          %repeat
  652      %end
  653  
  654      %routine abandon(%integer n)
  655          %switch reason(0:9)
  656          %integer stream
  657          stream = listing
  658          %cycle
  659              newline %if sym # nl
  660              printsymbol('*');  write(lines,4);  space
  661              ->reason(n)
  662  reason(0):  printstring("compiler error!");          ->more
  663  reason(1):  printstring("switch vector too large");  ->more
  664  reason(2):  printstring("too many names");           ->more
  665  reason(3):  printstring("program too complex");      ->more
  666  reason(4):  printstring("feature not implemented");  ->more
  667  reason(5):  printstring("input ended: ")
  668              %if quote # 0 %start
  669                  %if quote < 0 %then printsymbol(cquote) %else printsymbol(squote)
  670              %else
  671                  printstring("%endof")
  672                  %if progmode >= 0 %then printstring("program") %else printstring("file")
  673              %finish
  674              printstring(" missing?");                ->more
  675  reason(6):  printstring("too many faults!");         ->more
  676  reason(7):  printstring("string constant too long"); ->more
  677  reason(8):  printstring("dictionary full");          ->more
  678  reason(9):  printstring("Included file ".include file." does not exist")
  679  
  680  more:       newline
  681              printstring("***  compilation abandoned ***");  newline
  682              %exit %if stream = report
  683              close output
  684              stream = report
  685              select output(report)
  686          %repeat
  687          !%signal 15,15 %if diag&4096 # 0
  688          %stop
  689      %end
  690  
  691      %routine compile block(%integer level, block tag, dmin, tmax, id)
  692  
  693          %integerfnspec gapp
  694          %routinespec delete names(%integer quiet)
  695          %routinespec analyse
  696          %routinespec compile
  697  
  698          %integer open;    open       = closed;      !zero if can return from proc
  699          %integer dbase;   dbase      = dmax;        !dictionary base
  700          %integer tbase;   tbase      = tmax;        !tag base
  701          %integer tstart;  tstart     = tmax
  702          %integer label;   label      = 4;           !first internal label
  703          %integer access;  access     = 1;           !non-zero if accessible
  704          %integer inhibit; inhibit    = 0;           !non-zero inhibits declaratons
  705  
  706          %integername bflags;      bflags      == tag(block tag)_flags
  707          %integer block type;      block type   = bflags>>4&7
  708          %integer block form;      block form   = bflags&15
  709          %integer block fm;        block fm     = tag(block tag)_format
  710          %integer block otype;     block otype  = otype
  711          %integername block app;   block app   == tag(block tag)_app
  712  
  713          %integer l, new app
  714  
  715          %routine fault(%integer n)
  716              ! -5 : -1  - warnings
  717              !  1 : 22  - errors
  718  
  719              %switch fm(-5:22)
  720              %integer st
  721  
  722              %routine print ss
  723                  %integer s, p
  724                  %return %if pos = 0
  725                  space
  726                  p = 1
  727                  %cycle
  728                      printsymbol(marker) %if p = pos1
  729                      %exit %if p = pos
  730                      s = char(p);  p = p+1
  731                      %exit %if s = nl %or (s='%' %and p = pos)
  732                      %if s < ' ' %start;         !beware of tabs
  733                          %if s = ff %then s = nl %else s = ' '
  734                      %finish
  735                      printsymbol(s)
  736                  %repeat
  737                  pos = 0 %if list <= 0
  738              %end
  739  
  740              pos1 = pos2 %if pos2 > pos1
  741              newline %if sym # nl
  742              st = report
  743              st = listing %if n = -3;              !don't report unused on the console
  744              %cycle
  745                  select output(st)
  746                  %if n < 0 %then printsymbol('?') %and pos1 = 0 %else printsymbol('*')
  747                  %if st # report %start
  748                      %if list <= 0 %and pos1 # 0 %start
  749                          spaces(pos1+margin);  printstring("      ! ")
  750                      %finish
  751                  %finish %else %start
  752                      printstring(include file) %if include # 0
  753                      write(lines, 4);  printsymbol(csym);  space
  754                  %finish
  755                  ->fm(n) %if -5 <= n %and n <= 22
  756                  printstring("fault");  write(n, 2);              ->ps
  757  
  758  fm(-5):         printstring("Dubious statement");  dubious = 0;        ->psd
  759  fm(-4):         printstring("Non-local")
  760                  pos1 = for warn;  for warn = 0;                        ->ps
  761  fm(-3):         print ident(x, 0);  printstring(" unused");            ->nps
  762  fm(-2):         printstring("""}""");                                  ->miss
  763  fm(-1):         printstring("access");                                 ->psd
  764  fm(0):          printstring("form");                                   ->ps
  765  fm(1):          printstring("atom");                                   ->ps
  766  fm(2):          printstring("not declared");                           ->ps
  767  fm(3):          printstring("too complex");                            ->ps
  768  fm(4):          printstring("duplicate ");  Print Ident(x, 0);         ->ps
  769  fm(5):          printstring("type");                                   ->ps
  770  fm(6):          printstring("match");                                  ->psd
  771  fm(7):          printstring("context");                                ->psd
  772  fm(8):          printstring("%cycle");                                 ->miss
  773  fm(9):          printstring("%start");                                 ->miss
  774  fm(10):         printstring("size");  write(lit, 1) %if pos1 = 0;      ->ps
  775  fm(11):         printstring("bounds")
  776                  write(ocount, 1) %unless ocount < 0;                   ->ps
  777  fm(12):         printstring("index");                                  ->ps
  778  fm(13):         printstring("order");                                  ->psd
  779  fm(14):         printstring("not a location");                         ->ps
  780  fm(15):         printstring("%begin");                                 ->miss
  781  fm(16):         printstring("%end");                                   ->miss
  782  fm(17):         printstring("%repeat");                                ->miss
  783  fm(18):         printstring("%finish");                                ->miss
  784  fm(19):         printstring("result");                                 ->miss
  785  fm(20):         printsymbol('"'); print ident(x, 0); printsymbol('"'); ->miss
  786  fm(21):         printstring("context ");  print ident(this, 0);        ->ps
  787  fm(22):         printstring("format");                                 ->ps
  788  
  789  miss:           printstring(" missing");                               ->nps
  790  psd:            pos1 = 0
  791  ps:             print ss
  792  nps:            newline
  793                  %exit %if st = listing
  794                  st = listing
  795              %repeat
  796              %if n >= 0 %start
  797                  !%signal 15,15 %if diag&4096 # 0
  798                  %if n # 13 %start;           !order is fairly safe
  799                      ocount = -1
  800                      gg = 0
  801                      copy = 0;  quote = 0
  802                      search base = 0;  escape class = 0
  803                      gg = 0
  804                  %finish
  805                  faulty = faulty+1
  806     
  807                  !check that there haven't been too many faults
  808     
  809                  fault rate = fault rate+3;  abandon(6) %if fault rate > 30
  810                  fault rate = 3 %if fault rate <= 0
  811              %finish
  812              tbase = tstart
  813              %if list <= 0 %and sym # nl %start
  814                  error margin = column
  815                  error sym = sym;  sym = nl
  816              %finish
  817          %end
  818  
  819          dmin = dmin-1;  dict(dmin) = -1;            !end marker for starts & cycles
  820          abandon(2) %if dmax = dmin
  821  
  822          %if list > 0 %and level > 0 %start
  823              write(lines, 5);  spaces(level*3-1)
  824              %if block tag = 0 %start
  825                  printstring("Begin")
  826              %finish %else %start
  827                  printstring("Procedure ");  print ident(block tag, 0)
  828              %finish
  829              newline
  830          %finish
  831  
  832          !deal with procedure definition (parameters)
  833          %if block tag # 0 %start;                   !proc
  834              analyse;  compile %if ss # 0
  835  
  836              %if block otype # 0 %start;              !external-ish
  837                  %if bflags&spec = 0 %start;           !definition
  838                      %if progmode <= 0 %and level = 1 %then progmode = -1 %else fault(7)
  839                  %finish
  840              %finish
  841  
  842              new app = gapp;                          !generate app grammar
  843              %if spec given # 0 %start;               !definition after spec
  844                  fault(6) %if new app # block app;     !different from spec
  845              %finish
  846              block app = new app;                     !use the latest
  847  
  848              %if level < 0 %start;                    !not procedure definition
  849                  delete names(0)
  850                  %return
  851              %finish
  852          %finish %else %start
  853              open = 0;                                !can return from a block?
  854          %finish
  855  
  856          %cycle
  857              analyse
  858              %if ss # 0 %start
  859                  compile
  860                  fault(-5) %if dubious # 0
  861                  flush buffer( 128 )                    ;! flush if bp >= 128
  862                  %if sstype > 0 %start;                 !block in or out
  863                      %exit %if sstype = 2;               !out
  864                      compile block(spec mode, block x, dmin, tmax, id)
  865                      %exit %if ss < 0;                   !endofprogram
  866                  %finish
  867              %finish
  868          %repeat
  869          %if list > 0 %and level > 0 %start
  870              write(lines, 5);  spaces(level*3-1)
  871              printstring("End")
  872              newline
  873          %finish
  874          delete names(0)
  875          %return
  876  
  877          ! generate app grammar (backwards)
  878          %integerfn gapp
  879              %constinteger comma = 140;               !psep
  880              %routinespec set cell(%integer g, tt)
  881              %routinespec class(%record(tagfm)%name v)
  882              %record(tagfm)%name v
  883              %integer p, link, tp, c, ap, t
  884  
  885              %result = 0 %if tmax = local;            !no app needed
  886  
  887              p = gmax1;  link = 0;  t = tmax
  888  
  889              %cycle
  890                  v == tag(t);  t = t-1
  891                  class(v);                             ! deduce class from tag
  892                  %if c < 0 %start;                     ! insert %PARAM
  893                      c = -c
  894                      set cell(196, tp)
  895                      tp = -1
  896                  %finish
  897                  set cell(c, tp)
  898                  %exit %if t = local;                  ! end of parameters
  899                  set cell(comma, -1);                  ! add the separating comma
  900              %repeat
  901              abandon(3) %if gmax > gmin
  902  
  903              %result = link
  904  
  905              %routine set cell(%integer g, tt)
  906                  ! add the cell to the grammar, combining common tails
  907                  %while p # gmax %cycle
  908                      p = p+1
  909                      %if glink(p) = link %and gram(p) = g %start
  910                          %if tt < 0 %or (gram(p+1) = tt %and glink(p+1)=ap) %start
  911                              link = p;                    ! already there
  912                              %return
  913                          %finish
  914                      %finish
  915                  %repeat
  916  
  917                  !add a new cell
  918                  gmax = gmax+1
  919                  gram(gmax) = g
  920                  glink(gmax) = link
  921                  link = gmax
  922  
  923                  %if tt >= 0 %start;             ! set type cell
  924                      gmax = gmax+1
  925                      gram(gmax) = tt
  926                      glink(gmax) = ap
  927                  %finish
  928                  p = gmax
  929  
  930              %end
  931  
  932              %routine class(%record(tagfm)%name v)
  933                  %constinteger err    = 89
  934                  %constinteger rtp    = 100
  935                  %constinteger fnp    = 101
  936                  %constinteger mapp   = 102
  937                  %constinteger predp  = 103
  938                  %constintegerarray class map(0:15) = %c
  939+                           err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214,
  940+                 !         err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214,
  941+                           err, 229, err
  942                  !         err, 229, err
  943                  %integer tags, type, form
  944  
  945                  ap = 0
  946                  tags = v_flags
  947                  type = tags>>4&7;  form = tags&15
  948                  tp = v_format<<3!type
  949                  c = class map(form)
  950                  c = 208 %and tp = 0 %if type = 0 %and form = 2;  !%name
  951                  ap = v_app %if tags&parameters # 0
  952              %end
  953          %end
  954  
  955          %routine delete names(%integer quiet)
  956              %integer flags
  957              %record(tagfm)%name tx
  958  
  959              %while tmax > tbase %cycle
  960                  x = tmax;  tmax = tmax-1
  961                  tx == tag(x)
  962                  flags = tx_flags
  963                  fault(20) %if flags&spec # 0 %and flags&own bit = 0
  964                  !{spec with no definition & not external}
  965                  %if flags&used bit = 0 %and level >= 0 %and list <= 0 %start
  966                      fault(-3) %if quiet = 0;          !unused
  967                  %finish
  968                  dict(tx_text) = tx_link
  969              %repeat
  970          %end
  971  
  972          %routine analyse
  973              %constinteger order bits = 16_3000, order bit = 16_1000
  974              %constinteger escape     = 16_1000
  975              %integer strp, mark, flags, prot err, k, s, c
  976              %owninteger key = 0
  977              %integer node
  978              %integername z
  979              %record(arfm)%name arp
  980              %switch act(actions:phrasal), paction(0:15)
  981  
  982              %routine trace analysis
  983                  !diagnostic trace routine (diagnose&1 # 0)
  984                  %integer a
  985  
  986                  %routine show(%integer a)
  987                      %if 0 < a %and a < 130 %start
  988                          space
  989                          printstring(text(a))
  990                      %finish %else write(a, 3)
  991                  %end
  992  
  993                  %owninteger la1=0, la2=0, lsa=0, lt=0
  994                  newline %if mon pos # pos %and sym # nl
  995                  mon pos = pos
  996                  write(g, 3)
  997                  space
  998                  printstring(text(class))
  999                  printsymbol('"') %if gg&trans bit # 0
 1000                  a = gg>>8&15
 1001                  %if a # 0 %start
 1002                      printsymbol('{')
 1003                      write(a, 0)
 1004                      printsymbol('}')
 1005                  %finish
 1006                  %if atom1 # la1 %or atom2 # la2 %or lsa # subatom %or lt # type %start
 1007                      printstring(" [")
 1008                      la1 = atom1
 1009                      show(la1)
 1010                      la2 = atom2
 1011                      show(la2)
 1012                      lsa = subatom
 1013                      write(lsa, 3)
 1014                      lt = type
 1015                      write(lt, 5)
 1016                      printsymbol(']')
 1017                  %finish
 1018                  newline
 1019              %end
 1020  
 1021              %routine get sym
 1022                  readsymbol(sym)
 1023                  abandon(5) %if sym < 0
 1024                  pos = pos+1 %if pos # 133
 1025                  char(pos) = sym
 1026                  printsymbol(sym) %if list <= 0
 1027                  column = column+1
 1028              %end
 1029  
 1030              %routine read sym
 1031                  %owninteger Last = 0
 1032                  %constbyteintegerarray mapped(0:127) = %c
 1033+                   0,  0,  0,  0,   0,  0,  0,  0,    0,  0, 10,  0,   3,  0,  0,  0,
 1034+                   0,  0,  0,  0,   0,  0,  0,  0,    0,  0,  0,  0,   0,  0,  0,  0,
 1035+                   0,'!','"','#', '$',  1,'&', 39,  '(',')','*','+', ',','-','.','/',
 1036+                 '0','1','2','3', '4','5','6','7',  '8','9',':',';', '<','=','>','?',
 1037+                 '@','A','B','C', 'D','E','F','G',  'H','I','J','K', 'L','M','N','O',
 1038+                 'P','Q','R','S', 'T','U','V','W',  'X','Y','Z','[', '\',']','^','_',
 1039+                 '`','A','B','C', 'D','E','F','G',  'H','I','J','K', 'L','M','N','O',
 1040+                 'P','Q','R','S', 'T','U','V','W',  'X','Y','Z', 2 , '|','}','~',  0
 1041  
 1042                  !!   0 = space
 1043                  !!   1 = %
 1044                  !!   2 = {
 1045                  !!   3 = ff
 1046                  !!   other values represent themselves
 1047  
 1048                  %if sym = nl %start
 1049  s1:                 lines = lines+1
 1050                      printsymbol(end mark) %if end mark # 0
 1051  s11:                pos = 0;  pos1 = 0;  pos2 = 0;  margin = 0;  column = 0
 1052                      Last = 0
 1053                      end mark = 0
 1054                      %if list <= 0 %start
 1055                          %if include # 0 %start
 1056                              printstring(" &");  write(lines, -4)
 1057                          %finish %else  write(lines, 5)
 1058                          csym = cont;  printsymbol(csym)
 1059                          space
 1060                          %if error margin # 0 %start
 1061                              lines = lines-1
 1062                              spaces(error margin)
 1063                              error margin = 0
 1064                              %if error sym # 0 %start
 1065                                  printsymbol(error sym)
 1066                                  pos = 1;  char(1) = error sym
 1067                                  sym = error sym;  error sym = 0
 1068                                  ->s5
 1069                              %finish
 1070                          %finish
 1071                      %finish
 1072  s2:                 symtype = 1
 1073                  %finish
 1074  s3:             readsymbol(sym)
 1075                  abandon(5) %if sym < 0
 1076                  pos = pos+1 %if pos # 133
 1077                  char(pos) = sym
 1078                  printsymbol(sym) %if list <= 0
 1079                  column = column+1
 1080  s5:             %if sym # nl %start
 1081                      Last = Sym
 1082                      %return %if quote # 0;                     !dont alter strings
 1083                      sym = mapped(sym&127)
 1084                      %if sym <= 3 %start;                       !special symbol
 1085                          ->s2 %if sym = 0;                       !space (or dubious control)
 1086                          symtype = 2 %and ->s3 %if sym = 1;      !%
 1087                          cont = '+' %and ->s11 %if sym = 3;      !ff
 1088                          !must be {
 1089                          %cycle
 1090                              get sym
 1091                              ->s3 %if sym = '}'
 1092                              ->s4 %if sym = nl
 1093                          %repeat
 1094                      %finish
 1095                      key = kdict(sym)
 1096                      %if key&3 = 0 %and symtype = 2 %start;            !keyword
 1097                          %if sym = 'C' %and nextsymbol = nl %start;     !%c...
 1098                              getsym;  cont = '+';  ->s1
 1099                          %finish
 1100                      %else
 1101                          symtype = key&3-2
 1102                      %finish
 1103                      %return
 1104                  %finish
 1105  s4:             symtype = quote
 1106                  ->S1 %if last = 0 %and Quote = 0
 1107                  Cont = '+'
 1108              %end
 1109  
 1110              %integerfn format selected
 1111                  format list = tag(format)_app;      !number of names
 1112                  %if format list < 0 %start;         !forward ref
 1113                      atom1 = error+22
 1114                      %result = 0
 1115                  %finish
 1116                  %if sym = '_' %start
 1117                      escape class = esc rec
 1118                      search base = tag(format)_format
 1119                  %finish
 1120                  %result = 1
 1121              %end
 1122  
 1123              %routine code atom(%integer target)
 1124                  %integer dbase, da
 1125                  %integer base, n, mul, pend quote
 1126                  %integer j,k,l, pt
 1127  
 1128                  %routine lookup(%integer d)
 1129                      %integer new name, vid, k1, k2, form
 1130                      %record(tagfm)%name t
 1131                      %integer new
 1132  
 1133                      ! twee little function because SKIMP86 can't do string compare properly
 1134                      ! returns 1 if the two names are the same, else zero
 1135                      %integerfn dict match(%integer ptr1, ptr2)
 1136                          %integer len;
 1137                          ! start with a cheap check of the length and first character
 1138                          %if dict(ptr1) # dict(ptr2) %then %result = 0
 1139                          len = dict(ptr1) & 255
 1140                          ptr1 = ptr1 + 1
 1141                          ptr2 = ptr2 + 1
 1142                          len = len - 1
 1143                          %while len >= 2 %cycle
 1144                              %if dict(ptr1) # dict(ptr2) %then %result = 0
 1145                              ptr1 = ptr1 + 1
 1146                              ptr2 = ptr2 + 1
 1147                              len = len - 2
 1148                          %repeat
 1149                          ! if the string was odd length, we might need one last byte checked
 1150                          %if len = 1 %start
 1151                              %if dict(ptr1)&255 # dict(ptr2)&255 %then %result = 0
 1152                          %finish
 1153                          %result = 1
 1154                      %end
 1155  
 1156                      !first locate the text of the name
 1157                      new = dmax+1;     ! points to text of string in dictionary
 1158                      k1 = hash value & max names;        ! rather crude hash!
 1159  
 1160                      %cycle
 1161                          newname = hash(k1)
 1162                          %exit %if newname = 0;                !not in
 1163                          ->in %if dict match(newname+1, new) = 1
 1164                          k1 = (k1+1)&max names
 1165                      %repeat
 1166  
 1167                      ! not found
 1168                      spare names = spare names-1
 1169                      abandon(2) %if spare names <= 0
 1170                      hash(k1) = dmax;                               !put it in
 1171                      dict(dmax) = -1
 1172                      newname = dmax;  dmax = dp;  ->not in
 1173  
 1174  in:                 search base = rbase %if this >= 0 %and d # 0;  !record elem defn
 1175                      %if search base # 0 %start;                    !record subname
 1176                          new = -1
 1177                          x = search base
 1178                          %cycle
 1179                              ->not in %if x < format list
 1180                              %exit %if tag(x)_text = new name
 1181                              x = x-1
 1182                          %repeat
 1183                      %finish %else %start;                   !hash in for normal names
 1184                          x = dict(newname)
 1185                          ->not in %if x <= limit;             !wrong level
 1186                      %finish
 1187  
 1188                      subatom = x;                            !name found, extract info
 1189                      t == tag(x)
 1190                      atom flags = t_flags
 1191                      format = t_format;  app = t_app
 1192                      protection = atom flags&prot
 1193                      type = atom flags>>4&7;  atom1 = amap(atom flags&15)
 1194  
 1195                      %if diag&8 # 0 %start
 1196                          printstring("lookup:")
 1197                          write(atom1, 3)
 1198                          write(type, 1)
 1199                          write(app, 3)
 1200                          write(format, 5)
 1201                          write(atom flags, 3)
 1202                          newline
 1203                      %finish
 1204  
 1205                      %if d = 0 %start;                             !old name wanted
 1206                          t_flags = t_flags!used bit
 1207                          search base = 0
 1208  
 1209                          %if atom flags&subname # 0 %and format # 0 %start; !a record
 1210                              %return %if format selected = 0
 1211                          %finish
 1212  
 1213                          %if atom flags&parameters # 0 %start;      !proc or array
 1214                              %if app = 0 %start;                     !no parameters needed
 1215                                  atom2 = atom1
 1216                                  atom1 = atom1-4
 1217                                  %if 97 <= atom1 %and atom1 <= 98 %start
 1218                                      map gg = atom1;  atom1 = var
 1219                                  %finish
 1220                              %finish %else %start
 1221                                  %if sym = '(' %start
 1222                                      search base = 0;                  !ignore format for now
 1223                                      %if atom1 >= 106 %start;          !arrays
 1224                                          app = phrase(app+200)
 1225                                          escape class = esc array
 1226                                          atom1 = (atom1-106)>>1+91;     !a,an->v  na,nan->n
 1227                                      %finish %else %start;             !procedures
 1228                                          escape class = esc proc
 1229                                          atom1 = atom1-4
 1230                                      %finish
 1231                                      phrase(200) = app
 1232                                  %finish
 1233                              %finish
 1234                              pos2 = pos;  %return
 1235                          %finish
 1236  
 1237                          !deal with constintegers etc
 1238                          %if atom flags&const bit # 0 %and atom1 = var %start
 1239                              map gg = const;  atom2 = const
 1240                              subatom = -subatom %if type = integer
 1241                          %finish
 1242                          %return
 1243                      %finish
 1244                                                                  !new name wanted
 1245                      ->not in %if tbase # tstart;                !don't fault proc parm-parm
 1246                      %if d = lab+spec+used bit %start
 1247                          t_flags = t_flags!used bit
 1248                          %return
 1249                      %finish
 1250                      %if atom flags&spec # 0 %start;            !a spec has been given
 1251                          %if d = lab %start;                     !define label
 1252                              t_flags = t_Flags-Spec
 1253                              %return
 1254                          %finish
 1255                          %if 7 <= decl&15 %and decl&15 <= 10 %and decl&spec = 0 %start
 1256                              !procedure definition after spec
 1257                              %if (decl!!atom flags)&2_1111111 = 0 %start;  !correct type?
 1258                                  t_flags = t_flags-spec
 1259                                  spec given = 1
 1260                                  %return
 1261                              %finish
 1262                              !note that an external procedure must be speced as a
 1263                              !non-external procedure.
 1264                          %finish
 1265                          %if decl&15 = recfm %start;              !recordformat
 1266                              t_flags = record<<4+recfm
 1267                              t_format = fdef
 1268                              %return
 1269                          %finish
 1270                      %finish
 1271                      %return %if last1 = jump %and atom1 = swit
 1272                      copy = x %if copy = 0
 1273  notin:              app = 0;  vid = 0
 1274                      atom1 = error+2
 1275  
 1276                      %return %if d = 0;                         !old name wanted
 1277                      type = d>>4&7;  form = d&15;  atom1 = amap(form)
 1278  
 1279                      %if this < 0 %start;                       !normal scope
 1280                          new = newname
 1281                          tmax = tmax+1;  x = tmax
 1282                      %finish %else %start;                      !recordformat scope
 1283                          new = -1
 1284                          recid = recid-1;  vid = recid
 1285                          tmin = tmin-1;  x = tmin
 1286                          format list = tmin
 1287                      %finish
 1288  
 1289                      %if 11 <= form %and form <= 14 %start;               !arrays
 1290                          dim = 1 %if dim = 0;                    !set dim for owns
 1291                          app = dim
 1292                      %finish
 1293  
 1294                      d = d!used bit %if (otype > 2 %and d&spec = 0) %or perm # 0 %or Level = Include Level
 1295  
 1296                      !external definitions need not be used in the file in which
 1297                      !they are defined, so inhibit a useless unused warning.
 1298  
 1299                      t == tag(x)
 1300                      %if form = lab %start
 1301                          id = id+1;  vid = id
 1302                      %finish
 1303                      t_index = vid
 1304                      t_text   = new name
 1305                      t_flags = d
 1306                      t_app    = app
 1307                      t_format = fdef;  format = fdef
 1308                      subatom = x
 1309  
 1310                      %if new >= 0 %start;                             !insert into hash table
 1311                          t_link = dict(new);  dict(new) = x
 1312                          %if gmin = max grammar %start;                !proc param params
 1313                              tmin = tmin-1;  subatom = tmin
 1314                              tag(tmin) = t
 1315                          %finish
 1316                      %finish
 1317                      abandon(3) %if tmax >= tmin
 1318                  %end
?K2 unused
 1319  
 1320  top:            pos1 = pos
 1321                  subatom = 0;  pend quote = 0;  atom flags = 0
 1322  
 1323                  !app and format must be left for assigning to papp & pformat
 1324                  ->name %if symtype = -2;               ! letter
 1325                  ->number %if symtype < 0;              ! digit
 1326                  %if symtype = 0 %start
 1327                      atom1 = termin;  atom2 = 0
 1328                      %return
 1329                  %finish
 1330                  %if symtype # 2 %start;                ! catch keywords here
 1331                      ->text %if quote # 0;              ! completion of text
 1332                      ->strings %if sym = squote;        ! start of string
 1333                      ->symbols %if sym = cquote;        ! start of symbol
 1334                      ->number %if sym = '.' %and '0' <= nextsymbol %and nextsymbol <= '9'
 1335                  %finish
 1336  
 1337                  ! locate atom in fixed dict
 1338                  k = key>>2;  read sym
 1339                  %cycle
 1340                      j = kdict(k)
 1341                      %exit %if j&16_4000 # 0
 1342                      %if j&127 # sym %or symtype < 0 %start
 1343                          ->err %unless j < 0
 1344                          k = k+1
 1345                      %finish %else %start
 1346                          l = j>>7&127;  read sym
 1347                          %if j > 0 %start
 1348                              %if l # 0 %start
 1349                                  ->err %if l # sym %or symtype < 0
 1350                                  read sym
 1351                              %finish
 1352                              l = 1
 1353                          %finish
 1354                          k = k+l
 1355                      %finish
 1356                  %repeat
 1357                  atom1 = j&127
 1358                  %if atom1 = 0 %start;                  ! comma
 1359                      atom1 = 19;  subatom = 19;  atom2 = 0
 1360                      %if sym = nl %start
 1361                          %return %if ocount >= 0
 1362  
 1363                          ! special action needs to be taken with <comma nl> as
 1364                          ! const array lists can be enormous
 1365                          read sym
 1366                      %finish
 1367                      %return
 1368                  %finish
 1369                  atom2 = j>>7&127
 1370                  subatom = kdict(k+1)&16_3fff
 1371                  !!!!!cont = ' '
 1372                  %return
 1373  
 1374                  ! report an error. adjust the error marker (pos1) to point
 1375                  ! to the faulty character in an atom, but care needs to be taken
 1376                  ! to prevent misleading reports in cases like ...?????
 1377  
 1378  err:            atom1 = error+1;  atom2 = 0
 1379                  pos1 = pos %if pos-pos1 > 2
 1380                  %return
 1381  
 1382                  ! take care with strings and symbol constants.
 1383                  ! make sure the constant is valid here before sucking it in
 1384                  ! (and potentially loosing many lines)
 1385  
 1386  symbols:        atom1 = var;  atom2 = const;  type = integer
 1387                  map gg = const;  protection = prot
 1388                  subatom = lp;  abandon(3) %if lp >= lit max
 1389                  quote = \pend quote
 1390                  %return
 1391  
 1392                  ! an integer constant is acceptable so get it in and
 1393                  ! get the next atom
 1394  chars:          n = 0;  cont = cquote
 1395                  %cycle
 1396                      read sym
 1397                      %if sym = cquote %start
 1398                          %exit %if nextsymbol # cquote
 1399                          read sym
 1400                      %finish
 1401                      %if n&(\((-1)>>byte size)) # 0 %start; ! overflow
 1402                          pos1 = pos;  atom1 = error+10;  %return
 1403                      %finish
 1404                      ->err %if quote = 0
 1405                      n = n<<byte size+sym
 1406                      quote = quote+1
 1407                  %repeat
 1408                  quote = 0;  cont = ' '
 1409                  readsym %if sym # nl
 1410                  lit pool(lp) = n;  lp = lp+1
 1411                  ->top
 1412  
 1413                  !sniff the grammar before getting the string
 1414  strings:        atom1 = var;  atom2 = const;  type = stringv
 1415                  subatom = strp!16_4000
 1416                  map gg = const;  protection = prot
 1417                  quote = subatom
 1418                  text line = lines;                     ! in case of errors
 1419                  %return
 1420  
 1421                  ! a string constant is ok here, so pull it in and get
 1422                  ! the next atom
 1423                  ! ABD - temp variable to help pack bytes into words
 1424                  %integer flipflop
 1425  
 1426  text:           ->chars %if quote < 0;                 ! character consts
 1427                  l = strp;                              ! point to beginning
 1428                  k = 0;                                 ! length so far
 1429                  flipflop = 0;                          ! space for the length is up the spout
 1430  
 1431                  %cycle
 1432                      cont = squote;  quote = 1
 1433                      %cycle
 1434                          read sym
 1435                          %if sym = squote %start;       ! terminator?
 1436                              %exit %if nextsymbol # squote; ! yes ->
 1437                              read sym;                  ! skip quote
 1438                          %finish
 1439                          %if flipflop >= 0 %start
 1440                              glink(strp) = sym<<8 + flipflop
 1441                              strp = strp+1
 1442                              flipflop = -1
 1443                          %else
 1444                              flipflop = sym
 1445                          %finish
 1446                          k = k+1
 1447                          lines = text line %and abandon(7) %if k > 255; ! too many chars
 1448                      %repeat
 1449                      %if flipflop >=0 %start;           ! tail-end charlie
 1450                          glink(strp) = flipflop
 1451                          strp = strp+1
 1452                      %finish
 1453                      glink(l) = glink(l)!k;             ! plug in length
 1454  
 1455                      quote = 0;  cont = ' ';  read sym
 1456                      code atom(target)
 1457                      %return %unless atom1 = 48 %and sym = squote; ! fold "???"."+++"
 1458                  %repeat
 1459  
 1460                  %routine get(%integer limit)
 1461                      %integer s, shift
 1462                      shift = 0
 1463                      %if base # 10 %start
 1464                          %if base = 16 %start
 1465                              shift = 4
 1466                          %finish %else %start
 1467                              %if base = 8 %start
 1468                                  shift = 3
 1469                              %finish %else %start
 1470                                  %if base = 2 %start
 1471                                      shift = 1
 1472                                  %finish
 1473                              %finish
 1474                          %finish
 1475                      %finish
 1476                      n = 0
 1477                      %cycle
 1478                          %if symtype = -1 %start;       ! digit
 1479                              s = sym-'0'
 1480                          %finish %else %start
 1481                              %if symtype < 0 %start;    ! letter
 1482                                  s = sym-'A'+10
 1483                              %finish %else %start
 1484                                  %return
 1485                              %finish
 1486                          %finish
 1487                          %return %if s >= limit
 1488                          pt = pt+1;  glink(pt) = sym
 1489                          %if base = 10 %start;          ! check overflow
 1490                              %if n >= max int %and (s > max dig %or n > max int) %start
 1491                                  !too big for an integer,
 1492                                  !so call it a real
 1493                                  base = 0;  type = real;  n = 0
 1494                              %finish
 1495                          %finish
 1496                          %if shift = 0 %start
 1497                              n = n*base+s
 1498                          %finish %else %start
 1499                              n = n<<shift+s
 1500                          %finish
 1501                          read sym
 1502                      %repeat
 1503                  %end
 1504  
 1505  number:         base = 10
 1506  bxk:            atom1 = var;  atom2 = const;  type = integer;  subatom = lp
 1507                  map gg = const;  protection = prot
 1508                  abandon(3) %if lp >= lit max
 1509                  pt = strp;  mul = 0
 1510                  %cycle
 1511                      get(base)
 1512                      %exit %unless sym = '_' %and base # 0 %and pend quote = 0; ! change of base
 1513                      pt = pt+1;  glink(pt) = '_'
 1514                      read sym
 1515                      base = n
 1516                  %repeat
 1517  
 1518                  %if pend quote # 0 %start
 1519                      ->err %if sym # cquote
 1520                      readsym
 1521                  %finish
 1522                  %if sym = '.' %start;                  ! a real constant
 1523                      pt = pt+1;  glink(pt) = '.'
 1524                      read sym
 1525                      type = real;  n = base;  base = 0;  get(n)
 1526                  %finish
 1527  
 1528                  %if sym = '@' %start;                  ! an exponent
 1529                      pt = pt+1;  glink(pt) = '@';  k = pt
 1530                      readsym
 1531                      type = integer;  base = 10
 1532                      %if sym = '-' %start
 1533                          read sym;  get(10);  n = -n
 1534                      %finish %else %start
 1535                          get(10)
 1536                      %finish
 1537                      pt = k+1;  glink(pt) = lp;  litpool(lp) = n;  lp = lp+1
 1538                      atom1 = error+10 %if base = 0
 1539                      type = real;                       ! exponents force the type
 1540                  %finish
 1541  
 1542                  %if type = real %start
 1543                      glink(strp) = pt-strp;             ! store the length (difference)
 1544                      subatom = (strp)!16_2000;  strp = pt+1
 1545                  %finish %else %start
 1546                      litpool(lp) = n
 1547                      lp = lp+1
 1548                  %finish
 1549                  %return
 1550  
 1551  name:           atom1 = 0 %and %return %if 27 <= target %and target <= 41
 1552                  hash value = 0
 1553  
 1554                  ! ABD changed to remove dependency on direct addressing
 1555                  dp = dmax+1
 1556                  dbase = dp
 1557                  n = 0
 1558                  dict(dp) = 0
 1559                  %cycle
 1560                      hash value = hash value+(hash value+sym); ! is this good enough?
 1561                      dict(dp) = dict(dp) ! (sym << 8);
 1562                      n = n+1
 1563                      dp = dp+1
 1564                      read sym
 1565                      %exit %if symtype >= 0
 1566                      dict(dp) = sym;
 1567                      n = n+1
 1568                      read sym
 1569                      %exit %if symtype >= 0
 1570                  %repeat
 1571                  %if sym = cquote %start
 1572                      pend quote = 100
 1573                      ->symbols %if hash value = 'M'
 1574                      read sym
 1575                      %if hash value = 'X' %then base = 16 %and ->bxk
 1576                      %if hash value = 'K' %or hash value = 'O' %then base = 8 %and ->bxk
 1577                      %if hash value = 'B' %then base = 2 %and ->bxk
 1578                      ->err
 1579                  %finish
 1580                  dict(dbase) = dict(dbase)!n
 1581                  %if n&1 = 0 %then dp = dp+1
 1582                  abandon(8) %if dp >= dmin
 1583  
 1584                  atom2 = 90;                            ! ident
 1585                  %if last1 = 0 %and sym = ':' %start;   ! label
 1586                      limit = local;  lookup(lab);  %return
 1587                  %finish
 1588                  %if last1 = jump %start;               ! ->label
 1589                      limit = local;  lookup(lab+spec+used bit);  %return
 1590                  %finish
 1591                  %if decl # 0 %and target = 90 %start;  ! identifier
 1592                      search base = fm base
 1593                      limit = local;  lookup(decl)
 1594                      search base = 0
 1595                  %finish %else %start
 1596                      limit = 0;  lookup(0)
 1597                  %finish
 1598              %end
?DA unused
 1599  
 1600              %integerfn parsed machine code
 1601                  !   *opcode_??????????
 1602                  atom1 = error %and %result=0 %unless symtype = -2; ! starts with letter
 1603                  flush buffer( 128 );                   ! flush if bp >= 128
 1604                  add char( 'w' )
 1605                  %cycle
 1606                      add char( sym ); read sym
 1607                  %repeat %until Sym = '_' %or Symtype = 0; ! pull in letters and digits
 1608                  add char( '_' )
 1609                  %if symtype # 0 %start;                ! not terminator
 1610                      read sym
 1611                      %while symtype # 0 %cycle
 1612                          %if symtype < 0 %start;        ! complex
 1613                              code atom(0);  %result=0 %if atom1&error # 0
 1614                              %if atom2 = const %and type = integer %start
 1615                                  %if subatom < 0 %then set const(tag(-subatom)_format) %else set const(litpool(subatom))
 1616                              %finish %else %if 91 <= atom1 %and atom1 <= 109 %start
 1617                                  %if atom1 = 104 %and Tag(Subatom)_Flags&Closed = 0 %start
 1618                                      This = Subatom;  Atom1 = Error+21
 1619                                      %result = 0
 1620                                  %finish
 1621                                  op(' ', tag(subatom)_index)
 1622                              %finish %else %start
 1623                                  atom1 = error;  %result=0
 1624                              %finish
 1625                          %finish %else %start
 1626                              sym = sym!128 %if symtype = 2      {underline with %}
 1627                              add char( sym ); read sym
 1628                          %finish
 1629                      %repeat
 1630                  %finish
 1631                  add char( ';' )
 1632                  %result=1
 1633              %end
 1634  
 1635              cont = ' ' %if gg = 0
 1636              last1 = 0;  mapgg = 0
 1637              s = 0;  ss = 0;  sstype = -1; fdef = 0
 1638              fm base = 0
 1639              app = 0
 1640  
 1641              ! deal with alignment following an error in one statement
 1642              ! of several on a line
 1643              margin = column;                           ! start of statement
 1644              pos = 0
 1645              strp = gmax+1;  lp = 0
 1646              tbase = tstart;                            ! ??????????????
 1647              local = tbase
 1648  
 1649              %if gg = 0 %or ocount >= 0 %start;         ! data or not continuation(z)
 1650  again:          %while sym type = 0 %cycle;            ! skip redundant terminators
 1651                      c = cont
 1652                      cont = ' ';  cont = '+' %if ocount >= 0
 1653                      read sym
 1654                      cont = c
 1655                  %repeat
 1656                  ->skip %if sym = '!';                  ! comment
 1657                  this = -1
 1658                  code atom(0)
 1659                  %if atom1 = comment %start
 1660  skip:               quote = 1
 1661                      c = cont
 1662                      read sym %and cont = c %while sym # nl; ! skip to end of line
 1663                      quote = 0;  symtype = 0
 1664                      ->again
 1665                  %finish
 1666              %finish
 1667              decl = 0;  mark = 0
 1668              gentype = 0;  force = 0
 1669              dim = 0;  prot err = 0
 1670              node = 0;  nmax = 0;  nmin = rec size+1
 1671              order = 1;  gmin = max grammar+1
 1672              sstype = 0 %and ->more %if gg # 0;         ! continuation
 1673              ptype = 0;  spec given = 0
 1674  
 1675              stats = stats+1;  op('O', lines) %if perm = 0
 1676  
 1677              ->fail1 %if atom1&error # 0;               ! first atom faulty
 1678  
 1679              %if escape class # 0 %start;               ! enter the hard way after
 1680                  g = imp phrase;  sstype = -1;  ->a3
 1681              %finish
 1682  
 1683              g = initial(atom1);                        ! pick up entry point
 1684              %if g = 0 %start;                          ! invalid first atom
 1685                  g = initial(0);  sstype = 0;  ->a3;    ! declarator?
 1686              %finish
 1687              %if g < 0 %start;                          ! phrase imp
 1688                  g = g&255
 1689                  nmax = 1
 1690                  ar(1)_class = 0;  ar(1)_link = 0;  ar(1)_sub = imp phrase
 1691              %finish
 1692  
 1693              gg = gram(g);  class = gg&255;  sstype = gg>>12&3-1
 1694              ->a1
 1695  
 1696  act(194):   ptype = type;  papp = app;  pformat = format;  ->more
 1697  act(196):   k =g+1;  ->a610
 1698  act(188):   k = ar(nmax)_sub+1
 1699  a610:       papp = glink(k)
 1700              k = gram(k)
 1701              ->more %if k = 0;                          ! %name
 1702              ptype = k&7;  pformat = k>>3
 1703  act(183):   k = type;  gentype = k %if gentype = 0 %or k = real
 1704              %if pformat < 0 %start;                    ! general type
 1705                  app = papp;  format = pformat
 1706                  k = real %if ptype = real %and type = integer
 1707                  k = force %and force = 0 %if force # 0
 1708              %finish
 1709              ->fail2 %unless papp = app %and (ptype = k %or ptype = 0)
 1710              ->more %if pformat=format %or pformat = 0 %or format = 0
 1711              ->fail2
 1712  act(197):   arp == ar(nmin)
 1713              k = arp_sub
 1714              ->fail3 %unless block form = k&15
 1715              arp_sub = k>>4
 1716  
 1717              type = block type
 1718              ptype = block type;  pformat = block fm;  papp = app
 1719              pformat = -1 %if ptype # record
 1720              ->more
 1721  act(195):   ->Fail2 %if Type # 0 %and Type # Integer %and Type # Real
 1722              arp == ar(nmin)
 1723              k = arp_sub
 1724              arp_sub = k>>2
 1725              k = k&3
 1726                                                         ! 1 = check integer
 1727                                                         ! 2 = check real
 1728                                                         ! 3 = check real + int
 1729              ->more %if k = 0;                          ! 0 = no action
 1730              %if k = 1 %start
 1731                  force = integer
 1732                  ->more %if type = integer %or type = 0
 1733                  ->fail2
 1734              %finish
 1735              ->fail2 %unless ptype = real %or ptype = 0; ! {or added?}
 1736              force = integer %if k = 3
 1737              ->more
 1738  act(198):   ! %OTHER
 1739              k = gg>>8&15
 1740              %if k = 0 %start;                          ! restore atom
 1741                  atom1 = last1
 1742                  ->more
 1743              %finish
 1744              %if k = 1 %start;                          ! test string
 1745                  ->fail2 %unless type = stringv
 1746                  ->more
 1747              %finish
 1748              %if k = 2 %start;                          ! {fault record comparisons}
 1749                  ->fail2 %if type = record
 1750                  ->more
 1751              %finish
 1752              %if k = 3 %start;                          ! check OWN variable coming
 1753                  code atom(0)
 1754                  ->A7 %if atom flags&own bit = 0
 1755                  ->more
 1756              %finish
 1757              for warn = pos1 %if x <= local;            ! %for TEST
 1758              ->more
 1759  paction(1): %if type = record %then g = phrase(242) %else pformat = -1; ->a3
 1760  paction(2): ptype = real;     pformat = -1;                             ->a3
 1761  paction(3): ptype = stringv;  pformat = -1;                             ->a3
 1762  paction(4): ptype = integer;  pformat = -1;                             ->a3
 1763  paction(5): ->a3 %if ptype = integer
 1764              g = phrase(212) %and pformat=-1 %if ptype = real
 1765              g = phrase(213) %if ptype = stringv
 1766                                                                          ->a3
 1767  paction(6): ptype = gram(ar(nmax)_sub+1)&7;  pformat = -1;              ->a3
 1768  paction(7): ptype=real %if ptype = integer;  pformat = -1;              ->a3
 1769  
 1770  a1:         last1 = class;  atom1 = 0;  s = subatom
 1771  a2:         %if gg&trans bit = 0 %start;               ! insert into analysis record
 1772                  z == node
 1773                  %cycle;                                ! insert cell in order
 1774                      k = z
 1775                      %exit %if gg&order bits = 0 %or k = 0
 1776                      gg = gg-order bit;  z == ar(k)_link
 1777                  %repeat
 1778                  gg = map gg %if map gg # 0 %and gg&255 = var
 1779                  nmin = nmin-1;  ->fail0 %if nmin = nmax
 1780                  z = nmin
 1781                  arp == ar(nmin)
 1782                  arp_sub = s;  arp_class = (gg&255)!mark
 1783                  arp_link = k
 1784              %finish
 1785              mark = 0;  map gg = 0
 1786  more:       g = glink(g);                              ! chain down the grammar
 1787  paction(0):
 1788  a3:         gg = gram(g);  class = gg&255
 1789              trace analysis %if diag&1 # 0
 1790              ->a5 %if class = 0;                        ! end of phrase
 1791  
 1792              %if class < actions %start;                ! not a phrase or an action
 1793                  class = atomic(class) %if class >= figurative
 1794                  ->a2 %if class >= manifest
 1795                  code atom(class) %if atom1 = 0
 1796                  %if escape class # 0 %start;           ! escape to new grammar
 1797                      class = escape class;  escape class = 0
 1798                      g = g+escape
 1799  
 1800                      ! note that following an escape the next item is
 1801                      ! forced to be transparent!
 1802  
 1803  esc:                gg = 0
 1804                      arp == ar(nmax+1)
 1805                      arp_papp = papp;  arp_x = x;  ->a4
 1806                  %finish
 1807  
 1808                  ->a1 %if class = atom1 %or class = atom2
 1809  
 1810  a7:             ->fail1 %if gg >= 0;                   ! no alternative
 1811                  g = g+1
 1812                  ->a3
 1813              %finish
 1814  
 1815              %if class >= phrasal %start;               ! a phrase
 1816  a4:             nmax = nmax+1;  ->fail0 %if nmax = nmin
 1817                  arp == ar(nmax)
 1818                  arp_ptype = ptype
 1819                  arp_pos = pos1
 1820                  arp_pformat = pformat
 1821                  arp_link = gentype
 1822                  arp_class = node
 1823                  arp_sub = g
 1824                  node = 0
 1825                  g = phrase(class)
 1826                  ptype = force %and force = 0 %if force # 0
 1827                  gentype = 0
 1828                  ->paction(gg>>8&15)
 1829              %finish
 1830              ->act(class);                              ! only actions left
 1831  
 1832  a5:         ;! reverse links
 1833              s = 0
 1834              %while node # 0 %cycle
 1835                  z == ar(node)_link
 1836                  k = z;  z = s;  s = node;  node = k
 1837              %repeat
 1838              ss = s
 1839  a6:         %if nmax # 0 %start
 1840                  k = gentype;                           ! type of phrase
 1841                  arp == ar(nmax);  nmax = nmax-1
 1842                  node = arp_class
 1843                  gentype = arp_link
 1844                  ptype = arp_ptype
 1845                  pformat = arp_pformat
 1846                  g = arp_sub
 1847                  %if g&escape # 0 %start
 1848                      g = g-escape
 1849                      papp = arp_papp
 1850                      mark = 255
 1851                      subatom = s
 1852                      ->a3
 1853                  %finish
 1854                  gentype = k %if gentype = 0 %or k = real
 1855                  type = gen type
 1856  
 1857                  k = gg;                                ! exit-point code
 1858                  %cycle
 1859                      gg = gram(g)
 1860                      ->a2 %if k = 0
 1861                      ->fail1 %if gg >= 0;               ! no alternative phrase
 1862                      k = k-order bit
 1863                      g = g+1;                           ! sideways step
 1864                  %repeat
 1865              %finish
 1866  
 1867              Fault(4)  %if copy # 0
 1868              fault(13) %if order = 0
 1869              fault(-4) %if for warn # 0
 1870              pos1 = 0
 1871              fault rate = fault rate-1
 1872              %return
 1873  
 1874  act(193):   gg = 0 %and ->a5 %unless sym = '=' %or sym = '<'; ! cdummy
 1875  act(181):   atom1 = amap(decl&15);                     ! dummy
 1876              ->more
 1877  
 1878  act(182):   class = escdec;  g = glink(g)!escape;      ! an example of ! as an operator
 1879              decl = 0;  otype = 0;  ->esc;              ! decl
 1880  
 1881  act(199):   ;                                          ! compile
 1882              s = 0
 1883              %while node # 0 %cycle
 1884                  z == ar(node)_link
 1885                  k = z;  z = s;  s = node;  node = k
 1886              %repeat
 1887              ss = s
 1888  
 1889              code atom(28) %if quote # 0;               ! expend
 1890              compile;  ->more %if atom1&error = 0
 1891              ->fail1
 1892  
 1893  act(184):   ->fail4 %unless type = integer
 1894              %if subatom < 0 %then lit = tag(-subatom)_format %else lit = lit pool(subatom)
 1895              ->fail4 %if lit # 0
 1896              ->more
 1897  act(185):   ;                                          ! apply parameters
 1898              s = 0
 1899              %while node # 0 %cycle
 1900                  z == ar(node)_link
 1901                  k = z;  z = s;  s = node;  node = k
 1902              %repeat
 1903              ss = s
 1904  
 1905              atom1 = ar(s)_class;  atom2 = 0
 1906              atom1 = var %if atom1 = 97 %or atom1 = 98
 1907              arp == ar(nmax)
 1908              x = arp_x
 1909              pos1 = arp_pos
 1910              pos2 = 0
 1911              app = 0
 1912              format = tag(x)_format
 1913              flags = tag(x)_flags
 1914              type = flags>>4&7
 1915              protection = flags&prot
 1916              protection = 0 %if flags&aname # 0
 1917  
 1918              %if flags&subname # 0 %and format # 0 %start
 1919                  ->fail1 %if format selected = 0
 1920              %finish
 1921  
 1922              ->a6
 1923  
 1924  act(187):   protection = prot;  ->more;                ! %SETPROT
 1925  act(186):   ->More %if protection&prot = 0
 1926              prot err = nmin
 1927              ->A7
 1928  act(191):   k = protection;                            ! %GUARD
 1929              code atom(0)
 1930              protection = k %if atom flags&aname = 0
 1931              ->more
 1932  
 1933  act(192):   ->fail1 %if parsed machine code=0
 1934              ->more
 1935  
 1936  act(189):   k = gapp;                                  ! %GAPP
 1937              delete names(1)
 1938              tmax = tbase;  tbase = gram (gmin);        ! restore tmax
 1939              local= tbase
 1940              gmin = gmin+1
 1941  
 1942              x = ar(ar(nmax)_class)_sub
 1943              tag(x)_app = k;                            ! update app
 1944              ->more
 1945  
 1946  act(190):   gmin = gmin-1;                             ! %LOCAL
 1947              abandon(2) %if gmin <= gmax
 1948              gram (gmin) = tbase;  tbase = tmax
 1949              local = tbase
 1950              ->more
 1951  
 1952              ! errors
 1953  
 1954  fail4:      k = error+10;            ->failed;         ! *size
 1955  fail3:      k = error+7;             ->failed;         ! *context
 1956  fail2:      k = error+5;  pos2 = 0;  ->failed;         ! *type
 1957  fail0:      k = error+3;             ->failed;         ! *too complex
 1958  fail1:      k = atom1;    pos2 = 0
 1959  failed:     %if diag&32 # 0 %start
 1960                  printstring("Atom1 =");      write(atom1, 3)
 1961                  printstring("  Atom2 =");    write(atom2, 3)
 1962                  printstring("  subatom =");  write(subatom, 3); newline
 1963                  printstring("Type =");       write(type, 1)
 1964                  printstring("   Ptype =");   write(ptype, 1);   newline
 1965                  printstring("App =");        write(app, 1)
 1966                  printstring("   Papp =");    write(papp, 1);    newline
 1967                  printstring("Format =");     write(format, 1)
 1968                  printstring("   Pformat ="); write(pformat, 1); newline
 1969                  !%signal 13,15
 1970              %finish
 1971  
 1972              quote = 0 %and readsym %while sym # nl %and sym # ';'
 1973              %if k&error # 0 %start
 1974                  fault(k&255)
 1975              %finish %else %start
 1976                  %if prot err = nmin %then fault(14) %else fault(0)
 1977              %finish
 1978              gg = 0;  ss = 0;  symtype = 0
 1979          %end;                                          ! of analyse
 1980  
 1981          %routine compile
 1982              %constinteger then = 4, else = 8, loop = 16
 1983  
 1984              %switch c(0:actions), litop(1:12)
 1985  
 1986              %constbyteintegerarray operator(1:14) = '[', ']', 'X', '/', '&', '!', '%', '+', '-', '*', 'Q', 'x', '.', 'v'
 1987              %constbyteintegerarray cc(0 : 7) = '#','=',')','<','(','>', 'k','t'
 1988              %constbyteintegerarray anyform(0:15) = 1,0,1,1,1,1,1,1,0,1,1,0,1,1,1,1
 1989  
 1990              %constintegerarray decmap(0:15) = %c
 1991+             1,             2,
 1992+             16_100B,       16_100D,       16_140C,      16_140E,
 1993+             3,             4,
 1994+             16_1007,       16_1008,       16_1009,      16_100A,
 1995+             6,             0,             0,            0
 1996              %ownbyteintegerarray cnest(0:15)
 1997              %integer lmode, clab, dupid
 1998              %integer resln
 1999              %owninteger last def = 0
 2000              %owninteger lb, ub
 2001              %integer cp, ord
 2002              %integer next, link, j, k, n, done
 2003              %integer class
 2004              %integer lit2, defs, decs, cident
 2005              %integer pending;  %ownintegerarray pstack(1:40)
 2006              %ownstring(8) name = ""
 2007              %owninteger count = 0
 2008  
 2009              %routine def lab(%integer l)
 2010                  op(':', l)
 2011                  access = 1
 2012              %end
 2013  
 2014              %routine get next
 2015                  %record(arfm)%name p
 2016  gn:             %if next = 0 %start;                   ! end of phrase
 2017                      class = 0 %and %return %if link = 0; ! end of statement
 2018                      p == ar(link)
 2019                      next = p_link
 2020                      link = p_sub
 2021                  %finish
 2022                  %cycle
 2023                      p == ar(next)
 2024                      x = p_sub
 2025                      class = p_class
 2026                      %exit %if class < actions;         ! an atom
 2027                      %if x = 0 %start;                  ! null phrase
 2028                          next = p_link;  ->gn
 2029                      %finish
 2030                      %if p_link # 0 %start;             ! follow a phrase
 2031                          p_sub = link;  link = next
 2032                      %finish
 2033                      next = x
 2034                  %repeat
 2035                  next = p_link
 2036                  %if diag&2 # 0 %start
 2037                      spaces(8-length(name)) %unless length(name) = 0
 2038                      name = text(class)
 2039                      write(x, 2)
 2040                      space
 2041                      printstring(name)
 2042                      space
 2043                      count = count-1
 2044                      %if count <= 0 %start
 2045                          count = 5
 2046                          name = ""
 2047                          newline
 2048                      %finish
 2049                  %finish
 2050              %end
 2051  
 2052              %routine set subs(%integer n)
 2053                  !update the app field in n array descriptors
 2054                  %integer p
 2055                  p = tmax
 2056                  %while n > 0 %cycle
 2057                      !%signal 15,15 %if p < tbase
 2058                      tag(p)_app = dimension
 2059                      p = p-1;  n = n-1
 2060                  %repeat
 2061              %end
 2062  
 2063              %routine set bp
 2064                  !define a constant bound pair from the last stacked constants
 2065                  pending = pending-2
 2066                  lb = pstack(pending+1);  ub = pstack(pending+2)
 2067                  %if ub-lb+1 < 0 %start
 2068                      pos1 = 0;  next = link;  fault(11)
 2069                      ub = lb
 2070                  %finish
 2071                  set const(lb);  set const(ub)
 2072                  add char( 'b' ) %unless class = 146
 2073              %end
 2074  
 2075              %routine compile end(%integer type)
 2076                  ! type = 0:eof, 1:eop, 2:end
 2077                  %if access # 0 %start
 2078                      open = 0
 2079                      fault(19) %if block form > proc;   ! can reach end
 2080                  %finish
 2081  
 2082                  %while dict(dmin) >= 0 %cycle;         ! finishes & repeats
 2083                      fault(17+dict(dmin)&1)
 2084                      dmin = dmin+1
 2085                  %repeat
 2086                  !{delete names(0)}
 2087                  add char( ';' )
 2088                  add char( ';' ) %if type = 1;          ! endofprogram
 2089  
 2090                  bflags = bflags!open;                  ! show if it returns
 2091  
 2092                  def lab(0) %if block tag # 0 %and level # 1; ! for jump around
 2093                  %if type # 2 %start;                   ! eop, eof
 2094                      fault(16) %if level # type;        ! end missing
 2095                  %finish %else %start
 2096                      %if level = 0 %start
 2097                          fault(15);                     ! spurious end
 2098                      %finish
 2099                  %finish
 2100  
 2101                  end mark = 11;               !******Mouses specific******
 2102              %end
 2103  
 2104              %routine def(%integer p)
 2105                  !dump a descriptor
 2106                  %integer t, f, type
 2107                  %record(tagfm)%name v
 2108                  flush buffer( 1 );                     ! flush if bp > 0
 2109                  defs = defs+1
 2110                  v == tag(p)
 2111                  t = 0
 2112                  %unless v_index < 0 %start;            ! no index for subnames
 2113                      id = id+1 %and v_index = id %if v_index = 0
 2114                      last def = v_index
 2115                      t = last def
 2116                  %finish
 2117                  op('$', t)
 2118                  print ident(p, 1);                     ! output the name
 2119                  t = v_flags
 2120                  type = t
 2121                  type = type&(\(7<<4)) %if type&(7<<4) >= 6<<4;!routine & pred
 2122                  op(',', type&2_1111111);               ! type & form
 2123                  f = v_format
 2124                  f = tag(f)_index %if t&16_70 = record<<4
 2125                  f = v_index %if f < 0
 2126                  op(',', f);                            ! format
 2127                  f = otype+t>>4&2_1111000
 2128                  f = f!8 %if class = 125;               ! add spec from %DUP
 2129                  dim = v_app;                           ! dimension
 2130                  dim = 0 %unless 0 < dim %and dim <= dim limit
 2131                  op(',', f+dim<<8);                     ! otype & spec & prot
 2132                  defs = 0 %if t&parameters = 0
 2133                  f = t&15
 2134                  %if v_flags&spec # 0 %start
 2135                      v_flags = v_flags&(\spec) %unless 3 <= f %and f <= 10
 2136                      ocount = -1;                       ! external specs have no constants
 2137                  %finish
 2138                  dimension = 0
 2139                  %if otype = 2 %and (f=2 %or f=12 %or f=14) %start
 2140                      v_flags = v_flags-1;               ! convert to simple
 2141                  %finish
 2142              %end
 2143  
 2144              %routine def s lab(%integer n)
 2145                  ! define a switch label, x defines the switch tag
 2146                  %integer p, l, b, w, bit
 2147                  p = tag(x)_format;                     ! pointer to table
 2148                  l = dict(p);                           ! lower bound
 2149                  %if l <= n %and n <= dict(p+1) %start
 2150                      b = n-l
 2151                      w = b>>4+p
 2152                      bit = 1<<(b&15)
 2153                      %if dict(w+2)&bit # 0 %start;      ! already set
 2154                          fault(4) %if pending # 0
 2155                          %return
 2156                      %finish
 2157                      dict(w+2) = dict(w+2)!bit %if pending # 0
 2158                      set const(n)
 2159                      op('_', tag(x)_index)   
 2160                  %finish %else %start
 2161                      fault(12)
 2162                  %finish
 2163                  access = 1
 2164              %end
 2165  
 2166              %routine call
 2167                  %record(tagfm)%name T
 2168                  t == tag(x)
 2169                  op('@', t_index)
 2170                  access = 0 %if t_flags&closed # 0;     ! never comes back
 2171                  add char( 'E' ) %if t_app = 0;         ! no parameters
 2172              %end
 2173  
 2174              %routine pop def
 2175                  set const(pstack(pending));  pending = pending-1
 2176              %end
 2177  
 2178              %routine pop lit
 2179                  %if pending = 0 %then lit = 0 %else %start
 2180                      lit = pstack(pending);  pending = pending-1
 2181                  %finish
 2182              %end
 2183  
 2184              !conditions & jumps
 2185              %routine push(%integer x)
 2186                  %if cnest(cp)&2 # x %start
 2187                      cnest(cp) = cnest(cp)!1;  x = x+4
 2188                  %finish
 2189                  clab = clab+1 %if cnest(cp)&1 # 0
 2190                  cnest(cp+1) = x;  cp = cp+1
 2191              %end
 2192  
 2193              %routine pop label(%integer mode)
 2194                  lmode = dict(dmin)
 2195                  %if lmode < 0 %or lmode&1 # mode %start
 2196                      fault(mode+8)
 2197                  %finish %else %start
 2198                      dmin = dmin+1;  label = label-3
 2199                  %finish
 2200              %end
 2201  
 2202              %if sstype < 0 %start;                     ! executable statement
 2203                  %if level = 0 %start;                  ! outermost level
 2204                      fault(13);                         ! *order
 2205                  %finish %else %start
 2206                      %if access = 0 %start
 2207                          access = 1;  fault(-1);        ! only a warning
 2208                      %finish
 2209                  %finish
 2210              %finish
 2211  
 2212              %if diag&2 # 0 %start
 2213                  newline %if sym # nl
 2214                  printstring("ss =")
 2215                  write(ss, 1)
 2216                  newline
 2217                  count = 5
 2218                  name = ""
 2219              %finish
 2220  
 2221              next = ss
 2222              pending = 0;  lmode = 0
 2223              link = 0;  decs = 0
 2224              defs = 0;  resln = 0;  done = 0
 2225              ord = level
 2226              ord = 1 %if this >= 0;                     ! recordformat declarations
 2227  c(0):
 2228  top:        %if next # link %start
 2229                  get next;  ->c(class)
 2230              %finish
 2231  
 2232              !all done, tidy up declarations and jumps
 2233              newline %if diag&2 # 0 %and count # 5
 2234  
 2235              %if lmode&(loop!then!else) # 0 %start;     ! pending labels and jumps
 2236                  op('B', label-1) %if lmode&loop # 0;   ! repeat
 2237                  def lab(label)   %if lmode&then # 0;   ! entry from then
 2238                  def lab(label-1) %if lmode&else # 0;   ! entry from else
 2239              %finish
 2240  
 2241              %return %if decs = 0
 2242              atom1 = error %and %return %if atom1 # 0;  ! %integerroutine
 2243              order = ord
 2244              decl = decl&(\15)+decmap(decl&15);         ! construct declarator flags
 2245              atom1 = atoms(decl&15);                    ! generate class
 2246              %if otype # 0 %start;                      ! own, const etc.
 2247                  atom1 = atom1+1 %if atom1 # proc
 2248                  %if otype = 2 %start;                  ! const
 2249                      n = decl&15
 2250                      %if n&1 # 0 %start
 2251                          decl = decl!prot
 2252                          decl = decl!const bit %if decl&2_1111111 = iform
 2253                      %finish
 2254                  %else
 2255                      decl = decl!own bit
 2256                  %finish
 2257              %finish
 2258              sstype = 1 %if sstype = 0 %and atom1 = proc
 2259              atom1 = atom1+1 %if decl&spec # 0;         ! onto spec variant
 2260              ocount = 0 %and cont = '+' %if atom1 = 5;  ! own array
 2261              %if anyform(decl&15) = 0 %start;           ! check meaningful
 2262                  %if decl>>4&7 = record %start
 2263                      this = fdef %if tag(fdef)_flags&spec # 0
 2264                      atom1 = error+21 %if fdef = this;  ! *context for format
 2265                  %finish
 2266                  atom1 = error+10 %if fdef = 0;         ! *size
 2267              %finish
 2268              %return
 2269  
 2270  atop:       access = 0;  ->top
 2271              ! declarators
 2272  c(88):      ;                                          ! rtype
 2273  c(28):      decl = x&(\7);                             ! stype
 2274              fdef = x&7;                                ! precision
 2275              fdef = reals ln %if x&2_1110001 = real<<4+1; ! convert to long
 2276              decs = 1;  ->top
 2277  c(34):      ;                                          ! own
 2278  c(35):      otype = x;  ord = 1;  ->top;               ! external
 2279  c(152):     decl = decl+x<<1;  ->top;                  ! xname
 2280  c(31):      ;                                          ! proc
 2281  c(32):      spec mode = level+1;                       ! fn/map
 2282              decl = decl!prot %if x = 9;                ! function
 2283  c(29):      ord = 1;                                   ! array
 2284              dim = 0
 2285  c(30):      decl = decl+x;                             ! name
 2286              decs = 1
 2287              ->top
 2288  c(27):      lit = 0;                                   ! arrayd
 2289              %if pending # 0 %start
 2290                  pop lit
 2291                  %unless 0<lit %and lit<=dim limit %start
 2292                      atom1 = error + 11;  %return
 2293                  %finish
 2294              %finish
 2295              dim = lit
 2296              decl = decl + x;  decs = 1
 2297              -> top
 2298  c(37):      x = x!subname;                             ! record
 2299  c(36):      lit = 0;                                   ! string
 2300              %if pending # 0 %start
 2301                  pop lit
 2302                  %unless 0 < lit %and lit <= 255 %start; ! max length wrong
 2303                      atom1 = error+10;  %return
 2304                  %finish
 2305              %finish
 2306              fdef = lit;                                ! format or length
 2307  c(33):      decl = x;                                  ! switch
 2308              decs = 1
 2309              ->top
 2310  c(39):      decl = decl!spec;                          ! spec
 2311              ocount = -1;                               ! no initialisation
 2312              spec mode = -1
 2313              ->top
 2314  c(38):      decl = 64+4;                               ! recordformat (spec)
 2315              order = 1
 2316              atom1 = x
 2317              decl = decl!spec %if atom1 = 12;           ! formatspec
 2318              fdef = tmax+1;                             ! format tag
 2319              %return
 2320  c(175):     id = id+1;  tag(x)_index = id;  %return;   ! FSID
 2321  c(41):      decs = 1;  decl = x!spec!closed;  ->top;   ! label
 2322  c(133):     recid = 0;  rbase = tmin-1;                ! fname
 2323              this = x
 2324              fm base = fdef;  format list = tmin
 2325              def(this);                      ->top
 2326  c(148):     fdef = 0 %and ->top %if next = 0;          ! reclb
 2327              get next;                                  ! skip name
 2328              fdef = x
 2329              ->top
 2330  
 2331  c(127):     add char( '}' );             ->top;        ! %POUT
 2332  c(126):     add char( '{' );             ->top;        ! %PIN
 2333  c(174):     set bp;                                    ! rangerb
 2334  c(171):     ;                                          ! fmlb
 2335  c(172):     ;                                          ! fmrb
 2336  c(173):     add char( '~' )
 2337              add char( class-171+'A' );   ->top;        ! fmor
 2338  c(168):     rbase = -rbase;                            ! orrb
 2339              sstype = 0;  spec mode = 0
 2340  
 2341  c(147):     search base = 0;                           ! recrb
 2342              tag(this)_app = tmin
 2343              tag(this)_format = rbase
 2344              ->top
 2345  
 2346  c(45):      add char( 'U' ) %if x = 36;  ->top;        ! sign
 2347  c(46):      add char( '\' );             ->top;        ! uop
 2348  c(47):;                                                ! mod
 2349  c(48):;                                                ! dot
 2350  c(42):;                                                ! op1
 2351  c(43):;                                                ! op2
 2352  c(44):      add char( operator(x) );     ->top;        ! op3
 2353  c(56):      ;                                          ! and
 2354  c(57):      push(x);  ->top;                           ! or
 2355  c(58):      cnest(cp) = cnest(cp)!!2;  ->top;          ! not
 2356  c(138):     x = 128+32+16+4;                           ! csep: treat like %while
 2357  c(59):      ;                                          ! while
 2358  c(60):      %if class = 138 %then op('f', label-1) %else def lab(label-1); ! until
 2359  c(166):     ;                                          ! runtil
 2360  c(62):      lmode = (lmode&(else!loop)) !(x>>3);       ! cword
 2361              clab = label;  cp = 1;  cnest(1) = x&7
 2362              ->top
 2363  c(72):      pop label(0);                              ! repeat
 2364              def lab(label+1) %if lmode&32 # 0;  ->atop
 2365  c(69):      pop label(1);               ->top;         ! finish
 2366  c(163):     ;                                          ! xelse
 2367  c(70):      pop label(1);                              ! finish else ...
 2368              fault(7) %if lmode&3 = 3;                  ! dangling else
 2369  c(68):      lmode = (lmode&else)!3;                    ! ...else...
 2370              %if access # 0 %start
 2371                  op('F', label-1);  lmode = else!3
 2372              %finish
 2373              def lab(label)
 2374              ->top %if next # 0
 2375  c(120):     ;                                          ! %MSTART
 2376  c(67):      ;                                          ! start
 2377  c(71):      ;                                          ! cycle
 2378  stcy:       def lab(label-1) %and lmode = loop %if lmode = 0; ! cycle
 2379              dmin = dmin-1;  abandon(3) %if dmin <= dmax
 2380              dict(dmin) = lmode
 2381              label = label+3
 2382              %return
 2383  
 2384  c(64):      fault(13) %if dict(dmin) >= 0 %or inhibit # 0; ! on event
 2385              inhibit = 1
 2386              n = 0
 2387              n = 16_FFFF %if pending = 0;               ! * = all events
 2388              %while pending > 0 %cycle
 2389                  pop lit;  fault(10) %if lit&(\15) # 0; ! too big
 2390                  j = 1<<lit
 2391                  dubious = 1 %if n&j # 0
 2392                  n = n!j;                               ! construct bit mask
 2393              %repeat
 2394              op('o', n);  op(',', label)
 2395              lmode = then!1;  ->stcy
 2396  
 2397  c(104):     op('J', tag(x)_index);                     ! l
 2398              inhibit = 1;            ->atop
 2399  c(149):     stats = stats-1;                           ! lab
 2400              access = 1;  inhibit = 1
 2401              op('L', tag(x)_index);  ->top
 2402  
 2403  c(63):      j = dmin;  l = label-3;                    ! exit, continue
 2404              %cycle
 2405                  fault(7) %and ->top %if dict(j) < 0
 2406                  %exit %if dict(j)&1 = 0
 2407                  j = j+1;  l = l-3
 2408              %repeat
 2409              l = l+1 %if x = 32;                        ! continue
 2410              op('F', l)
 2411              dict(j) = dict(j)!x;                       ! show given
 2412              ->atop
 2413  
 2414  c(50):      add char( 'C' );          ->cop;           ! acomp
 2415  c(49):
 2416              %if next # 0 %start;                       ! comparator
 2417                  add char( '"' )
 2418                  push(0);                               ! double sided
 2419              %finish %else %start
 2420                  add char( '?' )
 2421              %finish
 2422  
 2423  cop:        x = x!!1 %if cnest(cp)&2 # 0;              ! invert the condition
 2424              j = cp;  l = clab
 2425              %while cnest(j)&4 = 0 %cycle
 2426                  j = j-1;  l = l-cnest(j)&1
 2427              %repeat
 2428              op(cc(x), l)
 2429              def lab(clab+1) %if cnest(cp)&1 # 0
 2430              cp = cp-1
 2431              clab = clab-cnest(cp)&1
 2432              ->top
 2433  
 2434  c(78):      ;                                          ! fresult
 2435  c(79):      ;                                          ! mresult
 2436  c(80):      open = 0;                                  ! return, true, false
 2437  c(82):      access = 0;                                ! stop
 2438  c(89):      ;                                          ! addop
 2439  c(81):      add char( x );              ->top;         ! monitor
 2440  c(65):      pop lit;  op('e', lit);     ->atop;        ! signal
 2441  c(51):      add char( 'S' );            ->top;         ! eq
 2442  c(53):      add char( 'j' );            ->top;         ! jam transfer
 2443  c(52):      add char( 'Z' );            ->top;         ! eqeq
 2444  c(74):      %if level = 0 %start;                      ! begin
 2445                  %if progmode <= 0 %then progmode = 1 %else fault(7)
 2446                  !{Permit BEGIN after external defs}
 2447              %finish
 2448              spec mode = level+1
 2449              block x = 0
 2450              add char( 'H' )
 2451              %return
 2452  c(77):      perm = 0;  lines = 0;  stats = 0;          ! endofperm
 2453              close input
 2454              select input(source)
 2455              list = list-1
 2456              tbase = tmax;  tstart = tmax
 2457              %return
 2458  c(76):      %if include # 0 %and x = 0 %start;         ! end of ...
 2459                  lines = include;  sstype =  0;         ! include
 2460                  close input
 2461                  list = include list
 2462                  include level = 0
 2463                  include = 0;  select input(source);  %return
 2464              %finish
 2465              ss = -1;                                   ! prog/file
 2466  c(75):      compile end(x);  %return;                  ! %end
 2467  
 2468  c(85):      %if x=0 %then control=lit %else %start;    ! control
 2469                  diag = lit&16_3FFF %if lit>>14&3 = 1
 2470              %finish
 2471              op('z'-x, lit)
 2472              ->top
 2473  c(83):      list = list+x-2;   ->top;                  ! %LIST/%endoflist
 2474  c(84):      reals ln = x;      ->top;                  ! %REALS long/normal
 2475  c(86):      %if include # 0 %start;                    ! include "file"
 2476                  fault(7);  %return
 2477              %finish
 2478              get next;                                  ! sconst
 2479              x = x-16_4000
 2480              j = glink(x)
 2481              k = j&255
 2482              !ABD - another little copy loop because SKIMP can't do the string map
 2483              include file = ""
 2484              %cycle
 2485                  k = k-1; %exit %if k < 0
 2486                  include file = include file.tostring(j>>8)
 2487                  x = x+1
 2488                  j = glink(x)
 2489                  k = k-1; %exit %if k < 0
 2490                  include file = include file.tostring(j&255)
 2491              %repeat
 2492              ! include file = string(x-16_4000+stbase)
 2493              ! remove this event block for SKIMP or pre-event IMP versions
 2494              %begin
 2495                  %on 9 %start;  Abandon(9);  %finish
 2496                  open input(3, include file)
 2497              %end
 2498              include = lines;  lines = 0
 2499              include list = list;  include level = level
 2500              select input(3)
 2501              ->top
 2502  
 2503  c(154):     dimension = dimension+1;                   ! dbsep
 2504              fault(11) %if dimension = dim limit+1
 2505              ->top
 2506  c(145):     set bp;                       ->top;       ! crb
 2507  c(146):     set bp;                                    ! rcrb
 2508  c(142):     ;                                          ! bplrb
 2509              dimension = 1 %if dimension = 0
 2510              op('d', dimension);  op(',', defs)
 2511              %if class # 146 %start
 2512                  set subs(defs)
 2513                  fault(13) %if dict(dmin) >= 0 %or inhibit # 0 %or level=0
 2514              %finish
 2515              dimension = 0;  defs = 0
 2516              ->top
 2517  c(128):     id = dupid;  ->top;                        ! EDUP
 2518  c(130):     block x = x
 2519              op('F', 0) %if decl&spec = 0 %and level # 0; ! jump round proc
 2520  c(125):     dupid = id;                                ! %DUP
 2521              %return %if Level < 0;                     ! {spec about}
 2522  c(90):      def(x);  ->top;                            ! ident
 2523  c(131):     ;                                          ! cident
 2524              %if tag(x)_flags&(2_1111111+const bit) = iform+const bit %start
 2525                  tag(x)_format = lit
 2526              %finish %else %start
 2527                  set const(lit) %if pending # 0
 2528                  def(x)
 2529                  op('A', 1)
 2530              %finish
 2531              cident = x
 2532              ->top
 2533  c(124):     dubious = 1 %if tag(cident)_flags&prot # 0; ! %DUBIOUS
 2534              ->top
 2535  c(97):      ;                                          ! f
 2536  c(98):      ;                                          ! m
 2537  c(99):      ;                                          ! p
 2538  c(96):      call;  ->top;                              ! r
 2539  c(165):     ;                                          ! nlab
 2540  c(100):     ;                                          ! rp
 2541  c(101):     ;                                          ! fp
 2542  c(102):     ;                                          ! mp
 2543  c(103):     ;                                          ! pp
 2544  c(91):      ;                                          ! v
 2545  c(92):      ;                                          ! n
 2546  c(106):     ;                                          ! a
 2547  c(107):     ;                                          ! an
 2548  c(108):     ;                                          ! na
 2549  c(109):     ;                                          ! nan
 2550              k = tag(x)_index
 2551              %if k < 0 %then op('n', -k) %else op('@', k)
 2552              ->top
 2553  c(121):     set const(0);                   ->top;     ! special for zero
 2554  c(167):     add char( 'G' );                ->pstr;    ! aconst (alias)
 2555  c(const):   ;                                          ! const
 2556              %if x < 0 %start;                          ! constinteger
 2557                  set const(tag(-x)_format);  ->top
 2558              %finish
 2559              %if x&16_4000 # 0 %start;                  ! strings
 2560                  add char( '''' )
 2561  pstr:           x = x-16_4000
 2562                  j = glink(x)
 2563                  k = j&255
 2564                  add char( k )
 2565                  %cycle
 2566                      k = k-1; ->top %if k < 0
 2567                      add char( j>>8 );
 2568                      x = x+1
 2569                      j = glink(x)
 2570                      k = k-1; ->top %if k < 0
 2571                      add char( j&255 )
 2572                  %repeat
 2573              %finish
 2574              %if x&16_2000 # 0 %start;                  ! real - ABD also string-like, but NOT packed
 2575                  x = x-16_2000
 2576                  k = glink(x)
 2577                  op('D', k);  add char( ',' )
 2578                  %cycle
 2579                      ->top %if k = 0
 2580                      k = k-1
 2581                      x = x+1;  j = glink(x)
 2582                      %if j = '@' %start
 2583                          op('@', litpool(glink(x+1)));  ->top
 2584                      %finish
 2585                      add char( j )
 2586                  %repeat
 2587              %finish
 2588              set const(lit pool(x))
 2589              ->top
 2590  
 2591  c(137):     add char( 'i' );                ->top;     ! asep
 2592  c(141):     add char( 'a' );                ->top;     ! arb
 2593  
 2594              !own arrays
 2595  c(132):     ocount = ub-lb+1
 2596              def(x);                                    ! oident
 2597              dimension = 1;  set subs(1)
 2598              %if next = 0 %start;                       ! no initialisation
 2599                  op('A', ocount) %if ocount > 0
 2600                  ocount = -1
 2601              %finish %else %start;                      ! initialisation given
 2602                  get next
 2603              %finish
 2604              ->top
 2605  c(162):     lit = ocount;  ->ins;                      ! indef
 2606  c(143):     pop lit;                                   ! orb
 2607  ins:        fault(10) %and lit = 0 %if lit < 0
 2608              get next
 2609              ->inst
 2610  c(139):     ;                                          ! osep (x=19)
 2611  c(153):     lit = 1
 2612  inst:       pop def %if pending # 0;                   ! ownt (x=0)
 2613              op('A', lit)
 2614              ocount = ocount-lit
 2615              %if ocount >= 0 %start
 2616                  ->top %if x # 0;                       ! more coming
 2617                  ocount = -1 %and %return %if ocount = 0; ! all done
 2618              %finish
 2619              fault(11);  %return
 2620  
 2621  c(swit):    op('W', tag(x)_index);  inhibit = 1;  ->atop
 2622  c(134):     def(x);                                    ! swid
 2623              n = ub-lb+1
 2624              n = (n+15)>>4;                             ! slots needed (includes zero)
 2625              j = dmax;  dmax = dmax+n+2
 2626              abandon(1) %if dmax >= dmin
 2627              tag(x)_format = j
 2628              dict(j) = lb;  dict(j+1) = ub
 2629              %cycle
 2630                  n = n-1
 2631                  ->top %if n < 0
 2632                  j = j+1;  dict(j+1) = 0
 2633              %repeat
 2634  c(151):     stats = stats-1;                           ! slab
 2635              fault(7) %and %return %if x < tbase
 2636              %if pending # 0 %start;                    ! explicit label
 2637                  def s lab(pstack(1))
 2638              %finish %else %start
 2639                  fault(4) %and %return %if tag(x)_app # 0
 2640                  tag(x)_app = 1
 2641                  n = tag(x)_format
 2642                  %for j = dict(n), 1, dict(n+1) %cycle
 2643                      def s lab(j)
 2644                      flush buffer( 128 );               ! flush if bp >= 128
 2645                  %repeat
 2646              %finish
 2647              inhibit = 1
 2648              %return
 2649  
 2650  c(140):     add char( 'p' );         ->top;            ! psep
 2651  c(144):     ;                                          ! prb
 2652              add char( 'p' );
 2653              add char( 'E' );         ->top
 2654  
 2655              !constant expressions
 2656  c(155):     ;                                          ! pconst
 2657              %if x < 0 %then lit = tag(-x)_format %else lit = lit pool(x)
 2658              pending = pending+1;     pstack(pending) = lit;  ->top
 2659  c(156):     lit = pstack(pending);  lit = -lit %if lit < 0
 2660              pstack(pending) = lit;  ->top;  !cmod
 2661  c(157):     lit = -pstack(pending);  pstack(pending) = lit;  ->top; ! csign
 2662  c(158):     lit = \pstack(pending);  pstack(pending) = lit;  ->top; ! cuop
 2663  c(159):     ;                                          ! cop1
 2664  c(160):     ;                                          ! cop2
 2665  c(161):     pending = pending-1;                       ! cop3
 2666              lit2 = pstack(pending+1);  lit = pstack(pending)
 2667              ->litop(x>>2)
 2668  
 2669  litop(1):   lit = lit<<lit2;           ->setl
 2670  litop(2):   lit = lit>>lit2;           ->setl
 2671  litop(3):   n = 1;                                     ! lit = lit\\lit2
 2672              fault(10) %if lit2 < 0
 2673              %while lit2 > 0 %cycle
 2674                  lit2 = lit2-1
 2675                  n = n*lit
 2676              %repeat
 2677              lit = n;                   ->setl
 2678  litop(4):   %if lit2 = 0 %then fault(10) %else lit = lit//lit2
 2679                                         ->setl
 2680  litop(5):   lit = lit&lit2;            ->setl
 2681  litop(6):   lit = lit!lit2;            ->setl
 2682  litop(7):   lit = lit!!lit2;           ->setl
 2683  litop(8):   lit = lit+lit2;            ->setl
 2684  litop(9):   lit = lit-lit2;            ->setl
 2685  litop(10):  lit = lit*lit2;            ->setl
 2686  litop(11):  lit = lit+lit2;            ->setl
 2687  litop(12):  n = 1;                                     ! lit = lit\\lit2
 2688              fault(10) %if lit2 < 0
 2689              %while lit2 > 0 %cycle
 2690                  lit2 = lit2-1
 2691                  n = n*lit
 2692              %repeat
 2693              lit = n;                   ->setl
 2694  setl:       pstack(pending) = lit;     ->top
 2695  
 2696  c(170):     ;
 2697              !Fault(4) %if IMPCOM_Option # ""
 2698              !IMPCOM_Option = String(x-x'4000'+Stbase); ! Option string
 2699              ->Top
 2700  
 2701              !string resolution
 2702  c(135):     resln = 2;                    ->top;       ! dotl
 2703  c(136):     resln = resln+1;              ->top;       ! dotr
 2704  c(55):      op('r', resln);    resln = 0; ->top;       ! resop
 2705  c(164):     op('r', resln+4);  resln = 0;              ! cresop
 2706  c(122):     x = 6;                        ->cop;       ! %PRED
 2707  c(87):      set const(pstack(1));                      ! mass
 2708              bp=bp+1 %and buff(bp)='P';    ->top
 2709          %end
 2710  
 2711      %end;                                              ! of compile block
 2712  
 2713      %on 9 %start
 2714          abandon(5)
 2715      %finish
 2716  
 2717      selectinput(2);  selectoutput(listing)
 2718      tag(max tag) = 0;                                  ! %begin defn
 2719      tag(0) = 0;  tag(0)_flags = 7;                     ! %begin tag!
 2720      Hash(x) = 0 %for x = 0, 1, max names
 2721      printstring("         Edinburgh IMP77 Compiler - Version ")
 2722  !    printstring("         Preston IMP2020 Compiler - Version ")
 2723      printstring(version);  newlines(2)
 2724      op('l', 0)
 2725      compile block(0, 0, max dict, 0, 0)
 2726      add char( nl );                                    ! {for bouncing off}
 2727      flush buffer( 0 );                                 ! flush if bp >= 0
 2728  
 2729      x = listing
 2730      newline
 2731      %cycle
 2732          %if faulty = 0 %start
 2733              write(stats, 5)
 2734              printstring(" Statements compiled")
 2735          %else
 2736              printstring(" Program contains ")
 2737              write(faulty, 1)
 2738              printstring(" fault")
 2739              printsymbol('s') %unless faulty = 1
 2740          %finish
 2741          newline
 2742          %exit %if x = report
 2743          x = report
 2744          selectoutput(report)
 2745      %repeat
 2746  
 2747      %if faulty # 0 %then %stop;        ! try to flag to shell that we failed
 2748  
 2749  %endofprogram

 2404 Statements compiled
