         Edinburgh IMP77 Compiler - Version 8.4

    1  %externalroutinespec debug(%string(255)s)
    2  
    3  !   Computer Science IMP77 Compiler   -   Version 8  First pass
    4  !                         23rd March 1981
    5  !
    6  %control 0
    7  
    8  %external %string (15) %fn %spec date
    9  %external %string (15) %fn %spec time
   10  
   11  %externalintegerfn pass1(%integer object tank)
   12     %externalroutinespec put(%integer n)
   13     %externalroutinespec putword(%integer n)
   14     %externalroutinespec putlong(%integer n)
   15     %externalroutinespec putblock(%integer len, %bytename b)
   16     %externalroutinespec select output tank(%integer n)
   17     %systemroutinespec exit %alias "exit" (%integer status)
   18     %externalstring(63)%spec error message
   19     %externalstring(72)%fnspec sysmess(%integer n)
   20     %externalstring(127)%fnspec infilename
   21  
   22     %externalstring(6) version = "V08.02"
   23  
   24     %externalintegerspec command
   25  
   26     %constinteger warnbit = 8_200
   27     %constinteger listbit = 8_400
   28  
   29     !configuration parameters
   30  
   31     %CONSTINTEGER max int      = ((-1)>>1)//10
   32     %CONSTINTEGER max dig      = (-1)>>1-maxint*10
   33     %CONSTINTEGER byte size    = 8;            !bits per byte
   34     %CONSTINTEGER max tag      = 1200;          !max no. of tags
   35     %CONSTINTEGER max dict     = 9000;         !max extent of dictionary
   36     %CONSTINTEGER name bits    = 11
   37     %CONSTINTEGER max names    = 1<<namebits-1
   38     %OWNINTEGER   spare names  = max names
   39     %CONSTINTEGER max grammar  = 1800
   40     %CONSTINTEGER lit max      = 50;           !max no. of constants/stat.
   41     %CONSTINTEGER rec size     = 260;          !size of analysis record
   42     %CONSTINTEGER dim limit    = 6;            !maximum array dimension
   43  
   44     !symbols
   45  
   46     %CONSTINTEGER ff     = 12;              !form feed
   47     %CONSTINTEGER marker = '^';             !marker for faults
   48     %CONSTINTEGER squote = '"';             !string quote
   49     %CONSTINTEGER cquote = '''';            !character quote
   50  
   51     !streams
   52  
   53     %CONSTINTEGER   source = 1, prims = 2
   54     %CONSTINTEGER report = 0, listing = 2
   55  
   56  
   57     !types
   58  
   59     %CONSTINTEGER integer = 1
   60     %CONSTINTEGER real    = 2
   61     %CONSTINTEGER stringv = 3
   62     %CONSTINTEGER record  = 4
   63  
   64     !forms
   65  
   66     %CONSTINTEGER iform = integer<<4+1
   67  
   68     %CONSTINTEGER var = 91
   69     %CONSTINTEGER const   = 93
   70     %CONSTINTEGER swit    = 105
   71     %CONSTINTEGER comment = 22
   72     %CONSTINTEGER termin  = 20
   73     %CONSTINTEGER lab     = 3
   74     %CONSTINTEGER jump    = 54
   75  
   76     %CONSTINTEGER recfm = 4
   77     %CONSTINTEGER proc  = 7;                     !class for proc
   78  
   79     !phrase entries
   80  
   81     %CONSTINTEGER escdec   = 252
   82     %CONSTINTEGER escproc  = 253
   83     %CONSTINTEGER escarray = 254
   84     %CONSTINTEGER escrec   = 255
   85  
   86     %RECORDFORMAT arfm({GT:%SHORT}%INTEGER class,sub,link,ptype,papp,pformat,x,pos);!imp77:
   87  
   88     %RECORDFORMAT tagfm(%INTEGER app, format, %C
   89+                        {GT:%SHORT}%INTEGER flags, index, text, link)
   90  
   91     !flags
   92  
   93  !      *===.===.===.===.===.====.====.====.===.======.======*
   94  !      ! u ! c ! c ! p ! s ! a  ! o  ! pr ! s ! type ! form !
   95  !      ! 1 ! 1 ! 1 ! 1 ! 1 ! 1  ! 1  ! 1  ! 1 !  3   !  4   !
   96  !      *===^===^===^===^===^====^====^====^===^======^======*
   97  !        u   c   c   p   s   a    o    p    s    t      f
   98  !        s   l   o   a   u   n    w    r    p    y      o
   99  !        e   o   n   r   b   a    n    o    e    p      r
  100  !        d   s   s   a   n   m         t    c    e      m
  101  !            e   t   m   a   e
  102  !            d       s   m
  103  !                        e
  104  !
  105  !
  106  
  107     %CONSTINTEGER used bit   = 2_1000000000000000,
  108+                  closed     = 2_0100000000000000,
  109+                  const bit  = 2_0010000000000000,
  110+                  parameters = 2_0001000000000000,
  111+                  subname    = 2_0000100000000000,
  112+                  aname      = 2_0000010000000000,
  113+                  own bit    = 2_0000001000000000,
  114+                  prot       = 2_0000000100000000,
  115+                  spec       = 2_0000000010000000
  116  
  117     %CONSTINTEGER trans bit  = 16_4000
  118     %CONSTINTEGER error      = 16_8000
  119  
  120     %CONSTINTEGER manifest = 120, figurative = 130
  121     %CONSTINTEGER actions  = 180, phrasal    = 200
  122  
  123     %CONSTBYTEINTEGERARRAY amap(0:15) = %C
  124+  89, 91, 92, 104, 94, const, swit, 100, 101, 102, 103, 106, 107, 108, 109, 89
  125  !?   v   n   l    fm  const  swit  rp   fp   mp   pp   a    an   na   nan  ?
  126  
  127     %CONSTBYTEINTEGERARRAY atoms(0:15) = 89, 1, 1, 10,  9,  1, 10,  7,
  128+                                          7, 7, 7,  4,  1,  4,  1, 89
  129  
  130     %RECORD(arfm)%ARRAY ar(1:rec size)
  131  
  132     %OWNINTEGER class = 0;                    !class of atom wanted
  133     %OWNINTEGER x = 0;                        !usually last tag
  134     %OWNINTEGER atom1 = 0;                    !atom class (major)
  135     %OWNINTEGER atom2 = 0;                    !atom class (minor)
  136     %OWNINTEGER subatom = 0;                  !extra info about atom
  137     %OWNINTEGER type = 0, app = 0, format = 0;!atom info
  138     %INTEGER hash value
  139     %OWNINTEGER faulty  = 0;                  !fault indicator
  140     %OWNINTEGER fault rate = 0;               !fault rate count
  141     %OWNINTEGER lines = 0;                    !current line number
  142     %OWNINTEGER text line = 0;                !starting line for string const
  143     %OWNINTEGER margin = 0;                   !statement start margin
  144     %OWNINTEGER error margin = 0, error sym = 0, column = 0
  145     %OWNINTEGER stats = 0;                    !statements compiled
  146     %OWNINTEGER mon pos = 0;                  !flag for diagnose
  147     %OWNINTEGER sym = nl;                     !current input symbol
  148     %OWNINTEGER symtype = 0;                  !type of current symbol
  149     %OWNINTEGER quote = 0;                    !>0 strings, <0 chars
  150     %owninteger end mark = 0;                  !%end flag
  151     %OWNINTEGER cont = ' ', csym = ' ';       !listing continuation marker
  152     %OWNINTEGER decl = 0;                     !current declarator flags
  153     %OWNINTEGER dim  = 0;                     !arrayname dimension
  154     %OWNINTEGER spec given = 0
  155  
  156     %OWNINTEGER escape class = 0;             !when and where to escape
  157     %OWNINTEGER protection=0, atom flags=0
  158     %OWNINTEGER otype = 0;                    !current 'own' type
  159     %OWNINTEGER reals ln = 1;                 ! =4 for %REALSLONG
  160     %OWNINTEGER last1 = 0;                    !previous atom class
  161     %OWNINTEGER gen type = 0
  162     %OWNINTEGER ptype = 0;                    !current phrase type
  163     %OWNINTEGER papp = 0;                     !current phrase parameters
  164     %OWNINTEGER pformat = 0;                  !current phrase format
  165     %OWNINTEGER force = 0;                    !force next ptype
  166     %OWNINTEGER g = 0, gg = 0, map gg = 0;            !grammar entries
  167     %OWNINTEGER fdef  = 0;                    !current format definition
  168     %OWNINTEGER this  = -1;                   !current recordformat tag
  169     %OWNINTEGER nmin = 0;                     !analysis record atom pointer
  170     %OWNINTEGER nmax = 0;                     !analysis record phrase pointer
  171     %OWNINTEGER rbase = 0;                    !record format definition base
  172     %OWNINTEGER stbase = 0;                   !constant work area base
  173     %OWNINTEGER gmin = max grammar;           !upper bound on grammar
  174     %OWNINTEGER dmax = 1
  175     %OWNINTEGER tmin = max tag;               !upper bound on tags
  176     %OWNINTEGER ss      = 0;                  !source statement entry
  177        %STRING(63) include file
  178     %OWNINTEGER include list = 0
  179     %OWNINTEGER include = 0;                  !=0 unused, #0 being used
  180     %OWNINTEGER perm    = 1;                  !1 = compiling perm, 0 = program
  181     %OWNINTEGER progmode= 0;                  !-1 = file, 1 = begin/eop
  182     %OWNINTEGER sstype = 0;                   !-1:exec stat
  183                                               ! 0: declaration
  184                                               ! 1: block in
  185                                               ! 2: block out
  186     %OWNINTEGER spec mode = 0;                !>=0: definition
  187                                               ! -1: proc spec
  188                                               ! -2: recordformat
  189     %OWNINTEGER ocount  = -1;                 !own constants wanted
  190     %OWNINTEGER limit   = 0;                  !lookup limit
  191     %OWNINTEGER copy    = 0;                  !duplicate name flag
  192     %OWNINTEGER order   = 0;                  !out of sequence flag
  193     %OWNINTEGER for warn = 0;                 !non-local flag
  194     %OWNINTEGER dubious = 0;                  !flag for dubious statements
  195     %OWNINTEGER dp      = 1
  196     %OWNINTEGER pos1    = 0, pos2 = 0;        !error position
  197     %OWNINTEGER pos     = 0;                  !input line index
  198     %OWNINTEGER dimension = 0;                !current array dimension
  199     %OWNINTEGER local = 0;                    !search limit for locals
  200     %OWNINTEGER fm base = 0;                  !entry for format decls
  201     %OWNINTEGER search base = 0;              !entry for record_names
  202     %OWNINTEGER format list = 0;              !size of current format list
  203     %INTEGER recid
  204     %ownbyteintegername current char
  205     %OWNBYTEINTEGERARRAY char(0:133)=nl(134);  !input line
  206     %INTEGERARRAY lit pool(0:lit max)
  207     %OWNINTEGER lit = 0;                      !current literal (integer)
  208     %OWNINTEGER lp = 0;                       !literals pointer
  209     %OWNINTEGER block x = 0;                  !block tag
  210     %OWNINTEGER list    = 2;                  !<= to enable
  211     %OWNINTEGER control = 0
  212     %OWNINTEGER diag = 0;                     !diagnose flags
  213     %SHORTINTEGERARRAY hash(0:max names)
  214     %RECORD(tagfm)%ARRAY tag(0:max tag)
  215     {GT:%SHORT}%INTEGERARRAY dict(1:max dict)
  216  
  217  !*** start of generated tables ***
  218  !!   %include "tables.imp"
  219  !!   %endoflist
  220  %conststring(8)%array text(0:255) = %c
  221+ "Z","VDEC","OWNVDEC","EXTVSPEC","ADEC","OWNADEC",
  222+ "EXTASPEC","PROC","PROCSPEC","FORMDEC","SWDEC","LDEC",
  223+ "FORMSPEC","","","","","",
  224+ "OPTION","COMMA","T","COLON","COMMENT","LB",
  225+ "ALIAS","RB","SUB","ARRAYD","STYPE","ARRAY",
  226+ "NAME","PROCD","FNMAP","SWITCH","OWN","EXTERNAL",
  227+ "STRING","RECORD","FORMAT","SPEC","MCODE","LABEL",
  228+ "OP1","OP2","OP3","SIGN","UOP","MOD",
  229+ "DOT","COMP","ACOMP","EQ","EQEQ","JAM",
  230+ "JUMP","RESOP","AND","OR","NOT","WHILE",
  231+ "UNTIL","FOR","CWORD","EXIT","ON","SIGNAL",
  232+ "THEN","START","ELSE","FINISH","FELSE","CYCLE",
  233+ "REPEAT","PROGRAM","BEGIN","END","ENDPROG","ENDPERM",
  234+ "FRESULT","MRESULT","BACK","MONITOR","STOP","LIST",
  235+ "","CONTROL","INCLUDE","MASS","RTYPE","ADDOP",
  236+ "IDENT","V","N","CONST","FM","",
  237+ "R","F","M","P","RP","FP",
  238+ "MP","PP","L","S","A","AN",
  239+ "NA","NAN","","","","",
  240+ "","","","","","",
  241+ "%MSTART","%CLEAR","%PRED","","%DUBIOUS","%DUP",
  242+ "%PIN","%POUT","%EDUP","","PIDENT","CIDENT",
  243+ "OIDENT","FNAME","SWID","DOTL","DOTR","ASEP",
  244+ "CSEP","OSEP","PSEP","ARB","BPLRB","ORB",
  245+ "PRB","CRB","RCRB","RECRB","RECLB","LAB",
  246+ "MLAB","SLAB","XNAME","OWNT","DBSEP","PCONST",
  247+ "CMOD","CSIGN","CUOP","COP1","COP2","COP3",
  248+ "INDEF","XELSE","CRESOP","NLAB","RUNTIL","ACONST",
  249+ "ORRB","FMANY","OSTRING","FMLB","FMRB","FMOR",
  250+ "RANGERB","FSID","","","","",
  251+ "","%DUMMY","%DECL","%TYPE","%ZERO","%APPLY",
  252+ "%PROT","%SETPROT","%PTYPE","%GAPP","%LOCAL","%GUARD",
  253+ "%MCODE","%CDUMMY","%SETTYPE","%OPER","%PARAM","%BLOCK",
  254+ "%OTHER","%COMPILE","APP","BASEAPP","APP2","APP3",
  255+ "APP4","APP5","APP6","ADEFN","NPARM","SWDEF",
  256+ "SWIDS","CIEXP","RCONST","SCONST","ARRAYP","XIMP",
  257+ "IMP","COND","SCOND","EXP1","EXP2","SEXP",
  258+ "IEXP","IEXP1","IEXP2","ISEXP","SEQ","FDEF",
  259+ "EXP","NARRAYP","STRUCT","RESEXP","BPL","CONSTB",
  260+ "FITEM","MOREA","CLIST","FPP","FPP0","FPP1",
  261+ "FPP2","INITVAR","RECEXP","EIMP","IDENTS","RANGE",
  262+ "RCONSTB","VARP","INITDEC","","","",
  263+ "ESCDEC","ESCPROC","ESCARRAY","ESCREC"
  264  %constinteger gmax1=718
  265  %owninteger gmax=718
  266  %constinteger imp phrase =24
  267  
  268  %ownshortintegerarray phrase(200:255) = %C
  269+    0, 563, 564, 566, 568, 570, 572, 561,
  270+  613, 202, 199, 601, 477, 479, 623, 297,
  271+  205, 307, 317, 432, 425, 436, 443, 457,
  272+  452, 460, 466, 481, 401, 626, 628, 602,
  273+  520, 510, 485, 501, 574, 526, 527, 542,
  274+  549, 577, 396, 286, 196, 635, 515, 620,
  275+  166,   0,   0,   0, 639, 692, 700, 708
  276  
  277  %constbyteintegerarray atomic(130:179) = %c
  278+   90,  90,  90,  90,  90,  48,  48,  19,
  279+   19,  19,  19,  25,  25,  25,  25,  25,
  280+   25,  25,  23, 104, 104, 105,  30,  20,
  281+   21,  93,  47,  45,  46,  42,  43,  44,
  282+   40,  68,  55, 104,  60,  93,  25,  40,
  283+   93,  23,  25,  57,  25,  90, 176, 177,
  284+  178, 179
  285  
  286  !  FLAG<1> 0<1> SS<2> 0<3> T<1> LINK<8>
  287  %constshortintegerarray initial(0:119) = %c
  288+       23,       0,       0,       0,       0,       0,       0,       0,
  289+        0,       0,       0,       0,       0,       0,       0,       0,
  290+        0,       0,      22,       0,       0,       0,       0,       0,
  291+        0,       0,       0,       0,       0,       0,       0,       0,
  292+        0,       0,       0,       0,       0,       0,       0,       0,
  293+       20,       0,       0,       0,       0,       0,       0,       0,
  294+        0,       0,       0,       0,       0,       0,  -32552,       0,
  295+        0,       0,       0,      13,       0,      14,       4,  -32558,
  296+       16,  -32551,       0,       0,       5,       6,       3,      12,
  297+       15,       8,       7,       9,      10,      11,  -32559,  -32555,
  298+   -32560,  -32553,  -32554,      18,       0,      17,      21,      19,
  299+        0,       0,       0,  -32563,  -32561,       0,       0,       0,
  300+   -32562,       0,       0,       0,       0,       0,       0,       0,
  301+        1,       2,       0,  -32557,       0,  -32556,       0,       0,
  302+        0,       0,       0,       0,       0,       0,       0,       0
  303  
  304  !  MORE<1> 0<1> ORDER<2> TYPE<4> CLASS<8>
  305  %ownshortintegerarray gram(0:max grammar) = %c
  306+        0,  -28523,  -28521,  -28602,  -32706,  -28509,  -28603,  -24502,
  307+   -24503,  -20405,  -20404,  -28595,  -32697,  -32709,  -16323,  -28600,
  308+   -32704,  -28587,  -28589,  -32681,  -16344,  -28586,  -16366,  -32586,
  309+      216,  -12287,  -16380,   -8185,   -8184,  -12285,  -12286,  -12283,
  310+   -12282,  -12279,  -12276,  -16373,   20490,  -32706,  -32701,     216,
  311+   -16364,  -28610,  -28613,  -28612,   16445,     217,  -16364,      62,
  312+   -32701,   16450,  -16364,    5346,  -16364,     166,  -16344,    4332,
  313+      130,  -16360,  -16361,     126,     217,  -32701,     216,  -16364,
  314+    16450,  -32700,   16404,  -32701,  -32706,     216,   16405,   16407,
  315+   -16222,    8414,     130,     217,  -32697,   16450,    1250,    4307,
  316+     4318,     192,      93,     170,      90,     207,  -16365,   16404,
  317+       90,  -16360,  -16365,   16404,     241,  -16365,   16404,     132,
  318+      132,  -16360,    4329,  -16365,   16404,     133,     175,      90,
  319+   -16365,   16404,     209,  -16365,   16404,    4313,     217,   16451,
  320+     4263,   16384,   16384,     120,     216,  -32700,   16404,  -32706,
  321+    16404,     243,   16409,     454,  -32685,   16404,     454,     248,
  322+   -16365,   16404,    4263,     194,  -16360,    4329,  -32717,   16404,
  323+     4263,   16407,     454,     237,     127,     215,     454,    4263,
  324+    16384,  -16364,    1502,  -32629,  -16361,     153,  -32606,     222,
  325+      143,  -32629,     153,     454,     126,   16409,     454,   16384,
  326+      234,  -16365,  -32595,     147,  -32678,     234,     193,  -32677,
  327+   -32676,  -32661,     109,  -32717,      53,      52,      52,      52,
  328+      194,     194,     194,  -28581,    4188,     194,  -28566,    4203,
  329+      194,  -28564,    4205,    4580,   16429,     183,     183,     186,
  330+      186,  -28583,       0,    9437,      90,  -16365,       0,     134,
  331+   -16365,       0,     210,    4329,     199,  -32677,  -32672,  -32676,
  332+   -32688,  -32690,  -32705,  -32661,  -32659,  -32689,  -32686,  -32687,
  333+   -16330,      65,  -32716,     186,  -28583,  -32717,  -32715,  -32713,
  334+       52,  -32664,    4201,     186,  -32717,  -32715,      55,  -16328,
  335+        0,     197,     197,      52,      52,     197,  -28581,  -28580,
  336+      186,  -28581,    4188,    4318,     194,  -28581,    4188,    9437,
  337+      194,     194,     454,   16407,     216,     194,  -28566,  -28565,
  338+      186,  -28566,    4203,     194,  -28564,  -28563,     186,  -28564,
  339+     4205,     183,     183,     186,     183,  -16365,       0,     183,
  340+     4580,   16429,    5095,    9444,    5348,     186,  -28583,  -16328,
  341+        0,   16409,  -16365,       0,    9437,    5348,     217,  -32701,
  342+    16450,  -32701,     216,  -32700,       0,  -32701,  -32706,     216,
  343+      243,     217,  -16318,       0,  -32552,       0,  -32700,       0,
  344+   -32706,       0,     215,  -32550,     228,  -28616,  -28615,       0,
  345+     4096,     218,     218,  -28616,       0,  -32677,  -32676,  -16361,
  346+   -32710,  -32669,  -32662,  -32661,  -32660,  -32659,     740,  -32039,
  347+      740,  -32719,    4096,     194,  -32719,  -32718,  -32604,  -32726,
  348+   -32725,  -32724,  -32720,    4096,     710,    6116,  -32719,       0,
  349+      710,    6116,  -28581,    4188,     218,     122,      50,   16409,
  350+   -32726,  -32725,  -32724,  -32719,    4096,     710,     454,     195,
  351+      195,     195,     454,  -28581,    4188,     194,  -28566,  -28565,
  352+   -28564,    4205,     195,     195,     195,     710,    4836,    5095,
  353+     4829,  -32726,  -32725,  -32724,  -32719,    4096,    4827,    4828,
  354+      454,  -32720,  -32719,    4096,    4829,    4827,    4828,     194,
  355+   -32719,       0,     710,    4836,  -16291,  -32677,      92,     184,
  356+      121,  -28581,  -28580,  -32722,  -32723,    4317,  -32726,  -32725,
  357+   -32724,       0,     183,  -32726,  -32725,  -32724,  -32720,       0,
  358+     4316,     195,     195,     195,     454,  -28581,    4188,    4315,
  359+      183,    4317,  -32726,  -32725,       0,     195,     195,    4315,
  360+     4317,  -32726,       0,     195,  -32677,  -32676,  -16361,   16431,
  361+      228,     228,      47,  -32610,  -32611,    5345,  -32609,  -32608,
  362+   -32607,       0,    4320,    4319,    5345,  -32609,  -32608,       0,
  363+     4319,    5345,  -32609,       0,  -32613,  -16361,   16431,     222,
  364+      222,     156,  -32677,      92,     183,     186,    1222,   16435,
  365+      228,   16403,    4324,     138,    8420,  -32723,    4189,      93,
  366+      454,     148,  -32674,   16546,   16409,  -32597,     182,  -16383,
  367+    16388,     234,  -16365,  -32595,     172,  -32678,     234,      90,
  368+      244,     246,  -16365,       0,     235,  -32678,     234,  -16365,
  369+      246,  -16365,       0,  -32678,     234,      90,   16407,     222,
  370+    16405,     222,     145,   16407,     222,   16405,     222,     146,
  371+    16407,    1252,     154,    5348,  -16365,     142,     126,     182,
  372+   -16383,   16391,      90,  -16365,     127,  -32678,     238,      90,
  373+      125,     239,  -16365,    8319,    8430,     128,     126,  -16361,
  374+      127,     190,     240,     189,   16409,     182,  -16383,   16391,
  375+       90,  -16365,       0,  -32678,     240,      90,   16623,  -16365,
  376+        0,     244,     232,    1252,    1252,     137,    1252,     137,
  377+     1252,     137,    1252,     137,    1252,     137,     222,  -16365,
  378+        0,     131,     194,  -16360,  -16333,  -16332,     124,     181,
  379+   -16292,  -16277,   16493,  -31802,    5342,  -28581,    4188,    4263,
  380+      181,     186,     454,   16475,     183,  -28583,     199,    5598,
  381+     9438,     222,  -32677,  -32676,   16407,     186,     228,     135,
  382+    16409,  -32632,       0,  -32677,      92,  -32677,  -32676,  -32662,
  383+   -32661,  -32660,  -32659,     165,  -32677,      92,     188,  -32662,
  384+      107,     188,  -32660,     109,  -32732,      37,  -16344,    4318,
  385+      148,  -32674,   16424,     222,   16405,     222,     174,  -28644,
  386+   -32734,  -32680,  -28641,  -32733,  -32730,  -32735,  -32727,  -32738,
  387+     4326,  -32738,  -32739,  -32741,  -32736,     199,  -28644,  -32680,
  388+   -28641,    4326,  -32739,  -32741,     199,  -32738,  -32739,  -32741,
  389+   -32736,  -32729,     199,  -32616,     199,  -32739,  -32741,  -32729,
  390+      199,  -32616,  -32729,     199,  -28644,  -32680,    4326,  -32738,
  391+   -32739,  -32741,     199,     245,    4318,     245,   16409,     152,
  392+     4318,   16409,     152,     245,  -32672,  -32671,  -32670,      99,
  393+    16407,     200,     144,     185,  -32677,      92,   16407,  -32582,
  394+      200,     200,     187,     141,  -32677,      92,   16410,     191,
  395+   -32677,  -32676,  -32662,  -32661,  -32660,     109,     198,
  396+ 0(max grammar-718)
  397  
  398  %ownshortintegerarray glink(0:max grammar) = %c
  399+       -1,      70,      71,      37,      45,      46,      66,      66,
  400+       74,      66,       0,      66,      50,      75,      78,      52,
  401+       54,      79,      66,      80,      81,      82,      83,      25,
  402+       40,      84,      85,      56,      56,      88,      92,      95,
  403+       96,     101,     102,     103,     106,      45,      66,      66,
  404+        0,     109,     109,     110,      51,      48,       0,      60,
  405+       66,      61,       0,      66,       0,     110,     111,     111,
  406+       57,     112,     113,     114,      63,      66,      65,     115,
  407+      116,      67,       0,      66,     121,      66,       0,      72,
  408+      122,     122,      66,      76,      66,      39,      76,      66,
  409+       66,       0,     123,     126,     127,      86,      85,       0,
  410+       89,     130,      88,       0,      93,      92,       0,     131,
  411+       97,     136,      99,      96,       0,     137,      66,     104,
  412+      103,       0,     107,     106,       0,      66,      66,      66,
  413+      138,     139,     140,       0,     117,     119,     115,     141,
  414+      115,      66,      70,     124,      66,       0,      66,     128,
  415+       84,       0,     142,     132,     143,     134,     144,       0,
  416+      155,     156,      58,     157,      66,     118,      90,     158,
  417+      145,     144,     147,     145,     150,       0,     152,     152,
  418+      153,     145,       0,      98,     159,      66,     133,     160,
  419+      161,     164,     160,     140,     161,     161,     167,     171,
  420+      173,     174,     175,     176,     177,     178,     181,     184,
  421+      187,     188,     179,     189,     189,     182,     190,     190,
  422+      185,     190,     190,       0,     187,     191,     192,     193,
  423+        0,     195,       0,       0,     197,     196,       0,     200,
  424+      199,       0,     203,     204,       0,     227,     231,     218,
  425+      233,     234,       0,     235,     236,     237,       0,     231,
  426+      225,     243,     244,     220,     247,     248,     249,     250,
  427+      244,       0,     251,     228,     248,     249,     250,     252,
  428+        0,       0,     187,     253,     259,     238,     268,     268,
  429+      241,     190,     190,     269,     245,     271,     271,     228,
  430+      272,     273,     274,     275,       0,     254,     265,     265,
  431+      257,     266,     266,     260,     265,     265,     263,     266,
  432+      266,     231,     267,     231,       0,     276,       0,     277,
  433+      231,     272,     231,     281,     282,     278,     284,     252,
  434+        0,       0,     285,       0,     231,       0,     287,       0,
  435+      289,       0,     291,     293,       0,       0,     296,       0,
  436+        0,     298,     300,       0,     302,       0,     304,       0,
  437+      306,       0,       0,     309,     312,     313,     314,       0,
  438+        0,     315,     310,     313,       0,     331,     331,     327,
  439+      348,     349,     350,     350,     350,     350,     329,     281,
  440+      351,     357,       0,     332,     340,     346,     358,     359,
  441+      360,     361,     362,       0,     341,     342,     344,       0,
  442+      345,       0,     268,     268,       0,       0,     365,     352,
  443+      370,     371,     372,     373,       0,     374,     375,     376,
  444+      382,     383,     363,     384,     384,     366,     268,     268,
  445+      268,     268,     388,     389,     390,     391,     392,       0,
  446+      377,     359,     360,     361,     340,       0,     378,     379,
  447+      385,     362,     340,       0,     352,     353,     354,     374,
  448+      394,       0,     395,       0,     399,     268,     268,     400,
  449+        0,     410,     410,     405,     416,     406,     417,     418,
  450+      419,       0,     411,     417,     418,     419,     420,       0,
  451+      408,     405,     423,     416,     421,     424,     424,     407,
  452+      414,     426,     429,     430,       0,     425,     431,     427,
  453+      433,     435,       0,     432,     268,     268,     440,     441,
  454+      281,     442,       0,     445,     450,     446,     445,     451,
  455+      450,       0,     448,     447,     453,     452,     456,       0,
  456+      454,     458,     457,       0,     268,     463,     464,     281,
  457+      465,       0,     468,     468,     469,     470,     471,     472,
  458+      473,     474,     475,     476,       0,     478,     268,     480,
  459+        0,     482,     484,     484,     204,     489,     487,     495,
  460+      496,     490,     493,     489,       0,     490,     490,       0,
  461+      497,     498,     500,       0,       0,     503,     505,     509,
  462+      498,     507,       0,     505,     505,     503,     511,     512,
  463+      513,     514,       0,     516,     517,     518,     519,       0,
  464+      521,     522,     523,     524,     521,       0,     527,     528,
  465+      530,     535,     531,     533,       0,     531,       0,     536,
  466+      537,     538,     540,     541,     541,       0,     543,     545,
  467+        0,     546,     547,     548,     532,     550,     552,     557,
  468+      553,     555,       0,     553,       0,     558,     559,     556,
  469+        0,     562,     204,       0,     565,     563,     567,     564,
  470+      569,     566,     571,     568,     573,     570,     575,     574,
  471+        0,     578,     579,     591,     592,     583,     204,     584,
  472+      587,     587,     587,     589,     204,     593,     593,     594,
  473+      595,     596,     580,     599,     597,     600,       0,     204,
  474+      204,     204,     605,     605,     606,     607,     608,     604,
  475+      609,     611,       0,     192,     192,     192,     192,     192,
  476+      192,     192,     192,       0,     622,     622,     191,     625,
  477+      625,       0,     625,     625,     630,     632,     281,     281,
  478+      633,     281,     281,     636,     637,     638,       0,     649,
  479+      676,     683,     665,     654,     204,     204,     204,     204,
  480+      649,     658,     667,     684,     665,       0,     661,     685,
  481+      665,     661,     667,     684,       0,     669,     673,     688,
  482+      665,     204,       0,     204,       0,     673,     688,     204,
  483+        0,     665,     204,       0,     679,     691,     679,     658,
  484+      667,     684,       0,     649,     686,     661,     687,     204,
  485+      689,     690,     665,     679,     696,     696,     696,     696,
  486+      697,     698,     699,       0,     702,     702,     703,     705,
  487+      706,     707,     707,     699,     710,     710,     711,     712,
  488+      718,     718,     718,     718,     718,     718,       0,
  489+ 0(max grammar-718)
  490  
  491  %constshortintegerarray kdict(32:596) = %c
  492+        0,     511,     131,     531,     131,     551,     559,     131,
  493+      567,     575,     583,     603,     623,     631,     663,     671,
  494+      129,     129,     129,     129,     129,     129,     129,     129,
  495+      129,     129,     691,     698,     707,     751,     795,     131,
  496+      131,     824,     900,     960,    1076,    1120,    1280,     128,
  497+      128,    1392,     128,     128,    1460,    1556,    1592,    1660,
  498+     1748,     128,    1828,    2000,    2196,    2228,     128,    2268,
  499+      128,     128,     128,    2287,    2295,    2327,    2335,    2355,
  500+      131,     131,     131,     131,     131,     131,     131,     131,
  501+      131,     131,     131,     131,     131,     131,     131,     131,
  502+      131,     131,     131,     131,     131,     131,     131,     131,
  503+      131,     131,     131,     131,    2363,     131,    2335,  -32351,
  504+    16428,      25,   16428,      29,  -32349,   16433,       1,   16434,
  505+        1,  -16127,       0,   16427,      21,   16407,       0,   16409,
  506+        0,  -32323,  -10840,      40,   16471,       0,  -32341,  -10580,
  507+       32,   16473,     117,   16384,      19,  -31955,  -32322,  -10580,
  508+       36,   -9290,       0,   16473,     113,   16432,      13,  -32337,
  509+    16427,      46,   16427,      17,   16405,       0,   16404,       0,
  510+   -31556,  -31939,  -32322,   -9551,       2,   16433,       1,   16433,
  511+        5,   16426,       5,  -31606,  -32323,   -9807,       0,  -32374,
  512+    -9678,       0,   16436,       0,   16435,       0,  -31939,  -32322,
  513+    16433,       4,   16426,       9,   16433,       3,  -30772,  -31666,
  514+    10578,   11457,  -32344,   16413,       2,   16411,       2,      68,
  515+   -32374,   16440,       0,   16440,       0,    8393,      83,   16408,
  516+        0,  -31291,   10841,      69,  -32311,   16412,      18,   10830,
  517+     9157,   10565,   16412,      18,    9415,      78,   16458,       0,
  518+   -32049,    8665,    8908,   16455,       0,  -30131,      78,  -31277,
  519+       84,  -32055,   10194,      76,   16469,       0,   10958,      69,
  520+    16447,      32,      84,  -32319,   16418,       2,   10830,   16418,
  521+        2,    8909,   10830,   16406,       0,  -31927,   10073,    9921,
  522+     8649,   16419,       5,    9153,   10190,    8915,   16469,       1,
  523+   -27956,  -31282,      88,  -31927,    8916,   10066,    9793,   16419,
  524+        3,      84,   16447,       4,      68,  -32305,   16459,       2,
  525+       70,  -30650,  -31284,      80,  -31931,   10194,   10567,    9921,
  526+    16460,       1,    9938,   16461,       0,   10697,      84,   16467,
  527+        3,    9801,      69,   16460,       0,    8915,   16452,       0,
  528+   -29631,  -30903,  -31282,  -31793,   10069,   10819,   10185,      78,
  529+    16416,       9,      82,   16445,       0,   16416,       9,    9422,
  530+     9299,  -32315,   16453,       0,   10700,      69,   16454,       0,
  531+    10700,      69,   16464,    1210,  -30778,      78,  -31549,    8916,
  532+     8903,      82,  -32344,   16412,      17,   16472,      17,   10956,
  533+     8900,   16470,       0,   16446,      44,  -30143,  -30647,   10063,
  534+       71,  -31671,  -32302,   16412,      20,    8389,      76,   16412,
  535+       36,   10830,    9157,   10565,   16412,      20,   10835,   16467,
  536+        1,    8898,      76,   16425,       6,  -31935,   10063,   10825,
  537+    10575,   16465,     109,      80,   16416,      10,  -32191,   10831,
  538+    16442,       0,    8909,  -32314,   16414,       1,  -31794,   10069,
  539+    10819,   10185,      78,   16416,      10,   16416,      10,  -30770,
  540+   -31408,  -32174,   10071,   16418,       1,  -32374,   16441,       2,
  541+    16441,       2,    9428,   10063,   16402,       0,  -32315,   16448,
  542+        0,    8918,   10830,   16448,       0,  -30523,      82,  -31419,
  543+   -31927,    9167,    8402,      77,   16457,       0,      77,   16419,
  544+        6,    9412,    8387,    8916,   16415,     123,    9938,   16419,
  545+        7,  -31931,   10959,    9428,    8910,   16415,     104,  -28351,
  546+   -30397,  -31024,  -32045,   10964,   10066,   16464,    1319,    9813,
  547+     7892,  -32323,   16462,    1384,   16463,    1241,    8389,      84,
  548+    16456,       0,   10575,      68,  -32314,   16421,      64,   10575,
  549+     8397,      84,  -32301,   16422,       9,    8912,      67,   16422,
  550+       12,      76,   16412,      33,  -27704,  -28983,  -29488,  -31276,
  551+   -31913,   10713,    8916,      77,   16419,       4,   10825,    9283,
  552+    16417,      12,  -31423,  -31921,    9426,    9166,      40,   16420,
  553+       48,      80,   16466,     115,   10834,   16451,       0,    8645,
  554+    16423,       0,   10055,    9793,  -32315,   16449,       0,    8918,
  555+    10830,   16449,       0,   10575,      84,  -32311,   16412,      19,
  556+    10830,    9157,   10565,   16412,      19,  -32056,   10962,      69,
  557+    16464,    1354,   10053,   16450,       0,      78,  -32052,    9428,
  558+       76,   16444,     182,   10693,      83,   16446,      46,    9416,
  559+     8908,   16443,     180,   16407,       0,  -31939,  -32292,  -10454,
  560+       51,   16426,      13,   16433,       1,   16409,       0,  -32290,
  561+   -10454,      51,   16426,      13,   16410,       0,   16431,      14,
  562+   -32323,   16430,      51,   16433,       1
  563  !!   %list
  564  !!%endoffile
  565  !***  end  of generated tables ***
  566  
  567  %routine print ident(%integer p, mode)
  568     %INTEGER j, ad
  569     p = tag(p)_text
  570     %IF p = 0 %START
  571        %IF mode = 0 %THEN printsymbol('?') %C
  572+                    %ELSE put('?')
  573        %RETURN
  574     %FINISH
  575     ad = addr(dict(p+1))
  576     %IF mode = 0 %THEN printstring(string(ad)) %ELSE %START
  577        putblock(byteinteger(ad),byteinteger(ad+1))
  578     %finish
  579  %END
?J unused
  580  %ROUTINE abandon(%INTEGER n)
  581     %SWITCH reason(0:9)
  582     %INTEGER stream
  583     stream = listing
  584     %CYCLE
  585        newline %IF sym # nl
  586        printsymbol('*'); write(lines,4);  space
  587  printsymbol('[')
  588  write(n,0)
  589  printsymbol(']')
  590        ->reason(n)
  591  reason(*):debug("* Switch label not set: reason(".itos(n,0).")"); %stop
  592  reason(0):printstring("compiler error!");          ->more
  593  reason(1):printstring("switch vector too large");  ->more
  594  reason(2):printstring("too many names");           ->more
  595  reason(3):printstring("program too complex");      ->more
  596  reason(4):printstring("feature not implemented");  ->more
  597  {GT: reason(5):printstring(error message.sysmess(event_extra)) %and -> more %if event_subevent # 1
  598  
  599  reason(5):
  600            %if event_subevent # 1 %start
  601              printstring("error message=""".error message.""" event_event=".itos(event_event,0)."  event_subevent=".itos(event_subevent, 0))
  602              {printstring("sysmess(event_extra)=""".sysmess(event_extra)."""")
  603              -> more 
  604            %finish
  605  
  606            %IF quote # 0 %START
  607              %IF quote < 0 %THEN printsymbol(cquote) %C
  608+                           %ELSE printsymbol(squote)
  609            %ELSE
  610               printstring("%endof")
  611               %IF progmode >= 0 %THEN printstring("program") %C
  612+                                %ELSE printstring("file")
  613            %FINISH
  614            printstring(" missing?");              ->more
  615  reason(6):printstring("too many faults!");   ->more
  616  reason(7):printstring("string constant too long"); ->more
  617  reason(8):printstring("dictionary full"); -> more
  618  reason(9): printstring("Included file ".include file." does not exist")
  619  more: newline
  620        printstring("***  compilation abandoned ***");  newline
  621        %EXIT %IF stream = report
  622        close output
  623        stream = report
  624        select output(report)
  625     %REPEAT
  626     %monitor %IF diag&4096 # 0
  627     exit(16_1000002c)    {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
  628  %END
  629  
  630  %routine op(%integer code, param)
  631     put(code);  putword(param)
  632  %end
  633  %routine set const(%integer m)
  634     %integer v
  635     v = m;  v = -m %if v < 0
  636     put('N');  putlong(v)
  637     put('U') %if m < 0
  638  %end
  639  
  640  
  641  %ROUTINE compile block(%INTEGER level, block tag, dmin, tmax, id)
  642  
  643     %INTEGERFNSPEC gapp
  644     %ROUTINESPEC delete names(%INTEGER quiet)
  645     %ROUTINESPEC analyse
  646     %ROUTINESPEC compile
  647  
  648     %INTEGER open; open       = closed;      !zero if can return from proc
  649     %INTEGER dbase; dbase      = dmax;        !dictionary base
  650     %INTEGER tbase; tbase      = tmax;        !tag base
  651     %INTEGER tstart; tstart    = tmax
  652     %INTEGER label; label      = 4;           !first internal label
  653     %INTEGER last array; last array = 0
  654     %INTEGER access; access     = 1;           !non-zero if accessible
  655     %INTEGER inhibit; inhibit    = 0;           !non-zero inhibits declaratons
  656  
  657     {GT:%SHORT}%INTEGERNAME bflags; bflags      == tag(block tag)_flags
  658     %INTEGER block type;          block type   = bflags>>4&7
  659     %INTEGER block form;          block form   = bflags&15
  660     %INTEGER block fm;          block fm     = tag(block tag)_format
  661     %INTEGER block otype;          block otype  = otype
  662     %INTEGERNAME block app;      block app   == tag(block tag)_app
  663  
  664     %INTEGER l, new app
  665  
  666  %ROUTINE fault(%INTEGER n)
  667  
  668      ! -5 : -1  - warnings
  669      !  1 : 22  - errors
  670  
  671      %SWITCH fm(-5:22)
  672      %INTEGER st
  673  
  674      %ROUTINE print ss
  675         %INTEGER s, p
  676         %RETURN %IF pos = 0
  677         space
  678         p = 1
  679         %CYCLE
  680            printsymbol(marker) %IF p = pos1
  681            %EXIT %IF p = pos
  682            s = char(margin+p);  p = p+1
  683            %EXIT %IF s = nl %OR (s='%' %AND p = pos)
  684            %IF s < ' ' %START;         !beware of tabs
  685               %IF s = ff %THEN s = nl %ELSE s = ' '
  686            %FINISH
  687            printsymbol(s)
  688         %REPEAT
  689         pos = 0 %IF list <= 0
  690      %END
  691  
  692      pos1 = pos2 %IF pos2 > pos1
  693     %if n >=0 %or command&warnbit # 0 %start
  694      newline %IF sym # nl
  695      st = report
  696      st = listing %IF n = -3;              !don't report unused on the console
  697      %cycle
  698         SELECT OUTPUT(st)
  699         %if n < 0 %then printsymbol('?') %and pos1 = 0 %else printsymbol('*')
  700         %if st # report %start
  701            %if list <= 0 %and pos1 # 0 %start
  702               spaces(pos1+margin);  PRINTSTRING("      ! ")
  703            %finish
  704         %finish %else %start
  705            PRINTSTRING(include file) %if include # 0
  706            write(lines, 4);  printsymbol(csym);  space
  707         %finish
  708         ->fm(n) %if -5 <= n <= 22
  709         PRINTSTRING("fault");  write(n, 2);              ->ps
  710  fm(*):debug("* Switch label not set: fm(".itos(n,0).")"); %stop
  711  fm(-5):PRINTSTRING("Dubious statement");  dubious = 0;  ->psd
  712  fm(-4):PRINTSTRING("Non-local")
  713         pos1 = for warn;  for warn = 0;      ->ps
  714  fm(-3):print ident(x, 0);  PRINTSTRING(" unused");      ->nps
  715  fm(-2):PRINTSTRING("""}""");                            ->miss
  716  fm(-1):PRINTSTRING("access");                           ->psd
  717  
  718  fm(0): PRINTSTRING("form");                             ->ps
  719  fm(1): PRINTSTRING("atom");                             ->ps
  720  fm(2): PRINTSTRING("not declared");                     ->ps
  721  fm(3): PRINTSTRING("too complex");                      ->ps
  722  fm(4): PRINTSTRING("duplicate");                        ->ps
  723  fm(5): PRINTSTRING("type");                             ->ps
  724  fm(6): PRINTSTRING("match");                            ->psd
  725  fm(7): PRINTSTRING("context");                          ->psd
  726  fm(21):PRINTSTRING("context ");  print ident(this, 0);  ->ps
  727  fm(8): PRINTSTRING("%cycle");                           ->miss
  728  fm(9): PRINTSTRING("%start");                           ->miss
  729  fm(10):PRINTSTRING("size");  WRITE(lit, 1) %if pos1 = 0;->ps
  730  fm(11):PRINTSTRING("bounds")
  731         WRITE(ocount, 1) %unless ocount < 0;             ->ps
  732  fm(12):PRINTSTRING("index");                            ->ps
  733  fm(13):PRINTSTRING("order");                            ->psd
  734  fm(14):PRINTSTRING("not a location");                   ->ps
  735  fm(15):PRINTSTRING("%begin");                           ->miss
  736  fm(16):PRINTSTRING("%end");                             ->miss
  737  fm(17):PRINTSTRING("%repeat");                          ->miss
  738  fm(18):PRINTSTRING("%finish");                          ->miss
  739  fm(19):PRINTSTRING("result");                           ->miss
  740  fm(22):PRINTSTRING("format");                           ->ps
  741  fm(20):printsymbol('"');  print ident(x, 0);  printsymbol('"')
  742  miss:  PRINTSTRING(" missing");                         ->nps
  743  psd:   pos1 = 0
  744  ps:    print ss
  745  nps:   NEWLINE
  746         %exit %if st = listing
  747         st = listing
  748      %repeat
  749     %finish
  750      %if n >= 0 %start
  751         %monitor %if diag&4096 # 0
  752         %if n # 13 %start;           !order is fairly safe
  753            ocount = -1
  754            gg = 0
  755            copy = 0;  quote = 0
  756            search base = 0;  escape class = 0
  757            gg = 0
  758         %finish
  759         faulty = faulty+1
  760  
  761         !check that there haven't been too many faults
  762  
  763         fault rate = fault rate+3;  abandon(6) %IF fault rate > 30
  764         fault rate = 3 %IF fault rate <= 0
  765      %FINISH
  766      tbase = tstart
  767      %IF list <= 0 %AND sym # nl %START
  768         error margin = column
  769         error sym = sym;  sym = nl
  770      %FINISH
  771  %END
  772  
  773     dmin = dmin-1;  dict(dmin) = -1;            !end marker for starts & cycles
  774     abandon(2) %IF dmax = dmin
  775  
  776     %IF list > 0 %AND level > 0 %START
  777        write(lines, 5);  spaces(level*3-1)
  778        %IF block tag = 0 %START
  779           printstring("Begin")
  780        %FINISH %ELSE %START
  781           printstring("Procedure ");  print ident(block tag, 0)
  782        %FINISH
  783        newline
  784     %FINISH
  785  
  786     !deal with procedure definition (parameters)
  787  
  788     %IF block tag # 0 %START;                   !proc
  789        analyse;  compile %IF ss # 0
  790  
  791        %IF block otype # 0 %START;              !external-ish
  792           %IF bflags&spec = 0 %START;           !definition
  793              %IF progmode <= 0 %AND level = 1 %THEN progmode = -1 %C
  794+                                              %ELSE fault(7)
  795  !!!!!    %FINISH %ELSE %START;                                !external spec
  796  !!!!!       bflags = bflags-spec;              !definition elsewhere
  797           %FINISH
  798        %FINISH
  799  
  800        new app = gapp;                          !generate app grammar
  801        %IF spec given # 0 %START;               !definition after spec
  802           fault(6) %IF new app # block app;     !different from spec
  803        %FINISH
  804        block app = new app;                     !use the latest
  805  
  806        %IF level < 0 %START;                    !not procedure definition
  807           delete names(0)
  808           %RETURN
  809        %FINISH
  810     %FINISH %ELSE %START
  811        open = 0;                                !can return from a block?
  812     %FINISH
  813  
  814     %CYCLE
  815        analyse
  816        %CONTINUE %IF ss = 0
  817        compile
  818        fault(-5) %IF dubious # 0
  819        %IF sstype > 0 %START;                   !block in or out
  820           %EXIT %IF sstype = 2;               !out
  821           compile block(spec mode, block x, dmin, tmax, id)
  822           %EXIT %IF ss < 0;                   !endofprogram
  823        %FINISH
  824     %REPEAT
  825     %IF list > 1 %AND level > 0 %START
  826        write(lines, 5);  spaces(level*3-1)
  827        printstring("End")
  828        newline
  829     %FINISH
  830     delete names(0)
  831     %RETURN
  832  
  833     %INTEGERFN gapp;                            !generate app grammar (backwards)
  834        %CONSTINTEGER comma = 140;               !psep
  835        %ROUTINESPEC set cell(%INTEGER g, tt)
  836        %ROUTINESPEC class(%RECORD(tagfm)%NAME v);   !imp77:
  837        %RECORD(tagfm)%NAME v;                       !imp77:
  838        %INTEGER p, link, tp, c, ap, t
  839  
  840        %RESULT = 0 %IF tmax = local;            !no app needed
  841  
  842        p = gmax1;  link = 0;  t = tmax
  843  
  844        %CYCLE
  845           v == tag(t);  t = t-1
  846           class(v);                             !deduce class from tag
  847           %IF c < 0 %START;                     !insert %PARAM
  848              c = -c
  849              set cell(196, tp)
  850              tp = -1
  851           %FINISH
  852           set cell(c, tp)
  853           %EXIT %IF t = local;                  !end of parameters
  854           set cell(comma, -1);                  !add the separating comma
  855        %REPEAT
  856        abandon(3) %IF gmax > gmin
  857  
  858        %RESULT = link
  859  
  860        %ROUTINE set cell(%INTEGER g, tt)
  861  
  862           !add the cell to the grammar, combining common tails
  863  
  864           %WHILE p # gmax %CYCLE
  865              p = p+1
  866              %IF glink(p) = link %AND gram(p) = g %START
  867                 %IF tt < 0 %OR (gram(p+1) = tt %AND glink(p+1)=ap) %START
  868                    link = p;                    !already there
  869                    %RETURN
  870                 %FINISH
  871              %FINISH
  872           %REPEAT
  873  
  874           !add a new cell
  875  
  876           gmax = gmax+1
  877           gram(gmax) = g
  878           glink(gmax) = link
  879           link = gmax
  880  
  881           %IF tt >= 0 %START;             ! set type cell
  882              gmax = gmax+1
  883              gram(gmax) = tt
  884              glink(gmax) = ap
  885           %FINISH
  886  
  887           p = gmax
  888        %END
  889  
  890        %ROUTINE class(%RECORD(tagfm)%NAME v);  !imp77:
  891           %CONSTINTEGER err    = 89
  892           %CONSTINTEGER rtp    = 100
  893           %CONSTINTEGER fnp    = 101
  894           %CONSTINTEGER mapp   = 102
  895           %CONSTINTEGER predp  = 103
  896           %CONSTINTEGERARRAY class map(0:15) = %C
  897+          err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214,
  898+          err, 229, err
  899           %INTEGER tags, type, form
  900           ap = 0
  901           tags = v_flags
  902           type = tags>>4&7;  form = tags&15
  903           tp = v_format<<3!type
  904           c = class map(form)
  905           c = 208 %AND tp = 0 %IF type = 0 %AND form = 2;  !%NAME
  906           ap = v_app %IF tags&parameters # 0
  907        %END
  908     %END
  909  
  910  %ROUTINE delete names(%INTEGER quiet)
  911     %INTEGER flags
  912     %RECORD(tagfm)%NAME tx;      !imp77:
  913     %WHILE tmax > tbase %CYCLE
  914        x = tmax;  tmax = tmax-1
  915        tx == tag(x)
  916        flags = tx_flags
  917        fault(20) %IF flags&spec # 0 %and flags&own bit = 0
  918                 {spec with no definition & not external}
  919        %IF flags&used bit = 0 %AND level > 0 %AND list <= 0 %START
  920           fault(-3) %IF quiet = 0;          !unused
  921        %FINISH
  922        dict(tx_text) = tx_link
  923     %REPEAT
  924  %END
  925  
  926  %ROUTINE analyse
  927  
  928     %CONSTINTEGER order bits = 16_3000, order bit = 16_1000
  929     %CONSTINTEGER escape     = 16_1000
  930     %INTEGER strp, mark, flags, prot err, k, s, c
  931     %OWNINTEGER key = 0
  932     {GT:%SHORT}%INTEGER node;      !imp77:
  933     {GT:%SHORT}%INTEGERNAME z;     !imp77:
  934     %RECORD(arfm)%NAME arp;  !imp77:
  935     %SWITCH act(actions:phrasal), paction(0:15)
  936  
  937     %ROUTINE trace analysis
  938        !diagnostic trace routine (diagnose&1 # 0)
  939        %INTEGER a
  940        %ROUTINE show(%INTEGER a)
  941           %IF 0 < a < 130 %START
  942              space
  943              printstring(text(a))
  944           %FINISH %ELSE write(a, 3)
  945        %END
  946        %OWNINTEGER la1=0, la2=0, lsa=0, lt=0
  947        newline %IF mon pos # pos %AND sym # nl
  948        mon pos = pos
  949        write(g, 3)
  950        space
  951        printstring(text(class))
  952        printsymbol('"') %IF gg&trans bit # 0
  953        a = gg>>8&15
  954        %IF a # 0 %START
  955           printsymbol('{')
  956           write(a, 0)
  957           printsymbol('}')
  958        %FINISH
  959        %IF atom1 # la1 %OR atom2 # la2 %OR lsa # subatom %C
  960+                       %OR lt # type %START
  961           printstring(" [")
  962           la1 = atom1
  963           show(la1)
  964           la2 = atom2
  965           show(la2)
  966           lsa = subatom
  967           write(lsa, 3)
  968           lt = type
  969           write(lt, 5)
  970           printsymbol(']')
  971        %FINISH
  972        newline
  973     %END
  974  
  975  %ROUTINE read sym
  976  
  977  %routine get next source char
  978    %externalroutinespec readrecord(%integername len, %bytename b)
  979     %owninteger len=0
  980     %if sym = nl %start
  981        current char == char(1)
  982        readrecord (len, current char)                    ;! BUG??? readrecord reads from tanks but there are none to be read from in pass1.
  983        len = len + 1
  984        char(len) = nl
  985        pos = 0
  986        column = 0;           !???????????????????????????????????
  987     %finish
  988     pos = pos + 1
  989     sym = current char
  990  !!   current char == BYTEINTEGER(ADDR(current char)+1) ; !! WAS  ++ 1
  991     current char == current char++1
  992     printsymbol(sym) %if list <= 0
  993     column = column + 1
  994  %end
  995  
  996  %CONSTBYTEINTEGERARRAY mapped(0:127) = %C
  997+    0,  0,  0,  0,   0,  0,  0,  0,    0,  0, nl,  0,  3 ,  0,  0,  0,
  998+    0,  0,  0,  0,   0,  0,  0,  0,    0,  0,  0,  0,   0,  0,  0,  0,
  999+   0 ,'!','"','#', '$', 1 ,'&', 39,  '(',')','*','+', ',','-','.','/',
 1000+  '0','1','2','3', '4','5','6','7',  '8','9',':',';', '<','=','>','?',
 1001+  '@','A','B','C', 'D','E','F','G',  'H','I','J','K', 'L','M','N','O',
 1002+  'P','Q','R','S', 'T','U','V','W',  'X','Y','Z','[', '\',']','^','_',
 1003+  '`','A','B','C', 'D','E','F','G',  'H','I','J','K', 'L','M','N','O',
 1004+  'P','Q','R','S', 'T','U','V','W',  'X','Y','Z', 2 , '|','}','~',  0
 1005  
 1006  !!   0 = space
 1007  !!   1 = %
 1008  !!   2 = {
 1009  !!   3 = ff
 1010  !!   other values represent themselves
 1011  
 1012     %IF sym = nl %START
 1013  s1:   lines = lines+1
 1014        printsymbol(end mark) %if end mark # 0
 1015  s11:  pos = 0;  pos1 = 0;  pos2 = 0;  margin = 0;  column = 0
 1016        end mark = 0
 1017        %IF list <= 0 %START
 1018           %IF include # 0 %START
 1019              printstring(" &");  write(lines, -4)
 1020           %FINISH %ELSE  write(lines, 5)
 1021           csym = cont;  printsymbol(csym)
 1022           space
 1023           %IF error margin # 0 %START
 1024              lines = lines-1
 1025              spaces(error margin)
 1026              error margin = 0
 1027              %IF error sym # 0 %START
 1028                 printsymbol(error sym)
 1029                 pos = 1;  char(1) = error sym
 1030                 sym = error sym;  error sym = 0
 1031                 ->s5
 1032              %FINISH
 1033           %FINISH
 1034        %FINISH
 1035  s2:   symtype = 1
 1036     %FINISH
 1037  s3:get next source char
 1038  s5:%IF sym # nl %START
 1039        %RETURN %IF quote # 0;                     !dont alter strings
 1040        sym = mapped(sym&127)
 1041        %IF sym <= 3 %START;                       !special symbol
 1042           ->s2 %IF sym = 0;                       !space (or dubious control)
 1043           symtype = 2 %AND ->s3 %IF sym = 1;      !%
 1044           cont = '+' %AND ->s11 %IF sym = 3;      !ff
 1045           !must be {
 1046           %CYCLE
 1047              get next source char
 1048              ->s3 %IF sym = '}'
 1049              ->s4 %IF sym = nl
 1050           %REPEAT
 1051        %FINISH
 1052        key = kdict(sym)
 1053        %IF key&3 = 0 %AND symtype = 2 %START;            !keyword
 1054           %IF sym = 'C' %AND current char = nl %START;     !%C...
 1055              get next source char;  cont = '+';  ->s1
 1056           %FINISH
 1057        %ELSE
 1058           symtype = key&3-2
 1059        %FINISH
 1060        %RETURN
 1061     %FINISH
 1062  s4:cont = '+'
 1063     symtype = quote
 1064  %END
 1065  
 1066  %INTEGERFN format selected
 1067     format list = tag(format)_app;          !number of names
 1068     %IF format list < 0 %START;         !forward ref
 1069        atom1 = error+22
 1070        %RESULT = 0
 1071     %FINISH
 1072     %IF sym = '_' %START
 1073        escape class = esc rec
 1074        search base = tag(format)_format
 1075     %FINISH
 1076     %RESULT = 1
 1077  %END
 1078  
 1079  %ROUTINE code atom(%INTEGER target)
 1080     %INTEGER dbase, da
 1081     %INTEGER base, n, mul, pend quote
 1082     %INTEGER j,k,l, pt
 1083  
 1084     %ROUTINE lookup(%INTEGER d)
 1085        %CONSTINTEGER magic = 6700421
 1086        %INTEGER new name, vid, k1, k2, form
 1087        %RECORD(tagfm)%NAME t;      !imp77:
 1088        %INTEGER new
 1089  
 1090        !first locate the text of the name
 1091  
 1092        new = addr(dict(dmax+1))
 1093  
 1094              K2 = hash value*magic
 1095  
 1096              !*******************************************************
 1097  
 1098        k2 = k2>>(32-2*name bits)!1;         !IMP77:
 1099        k1 = k2>>name bits;                       !giving name bits
 1100        %CYCLE
 1101           newname = hash(k1)
 1102           %EXIT %IF newname = 0;                !not in
 1103           ->in %IF string(addr(dict(newname+1))) = string(new)
 1104           k1 = (k1+k2)&max names
 1105        %REPEAT
 1106  
 1107        ! not found
 1108  
 1109        spare names = spare names-1
 1110        abandon(2) %IF spare names <= 0
 1111        hash(k1) = dmax;                !put it in
 1112        dict(dmax) = -1
 1113        newname = dmax;  dmax = dp;  ->not in
 1114  
 1115  in:   search base = rbase %IF this >= 0 %AND d # 0;  !record elem defn
 1116        %IF search base # 0 %START;               !record subname
 1117           new = -1
 1118           x = search base
 1119           %CYCLE
 1120              ->not in %IF x < format list
 1121              %EXIT %IF tag(x)_text = new name
 1122              x = x-1
 1123           %REPEAT
 1124        %FINISH %ELSE %START;                                  !hash in for normal names
 1125           x = dict(newname)
 1126           ->not in %IF x <= limit;         !wrong level
 1127        %FINISH
 1128  
 1129        subatom = x;                            !name found, extract info
 1130        t == tag(x)
 1131        atom flags = t_flags
 1132        format = t_format;  app = t_app
 1133        protection = atom flags&prot
 1134        type = atom flags>>4&7;  atom1 = amap(atom flags&15)
 1135  
 1136        %IF diag&8 # 0 %START
 1137           printstring("lookup:")
 1138           write(atom1, 3)
 1139           write(type, 1)
 1140           write(app, 3)
 1141           write(format, 5)
 1142           write(atom flags, 3)
 1143           newline
 1144        %FINISH
 1145  
 1146        %IF d = 0 %START;                                !old name wanted
 1147           t_flags <- t_flags!used bit
 1148           search base = 0
 1149  
 1150           %IF atom flags&subname # 0 %AND format # 0 %START; !a record
 1151              %RETURN %IF format selected = 0
 1152           %FINISH
 1153  
 1154           %IF atom flags&parameters # 0 %START;        !proc or array
 1155  
 1156              %IF app = 0 %START;                  !no parameters needed
 1157                 atom2 = atom1
 1158                 atom1 = atom1-4
 1159                 %IF 97 <= atom1 <= 98 %START
 1160                    map gg = atom1;  atom1 = var
 1161                 %FINISH
 1162              %FINISH %ELSE %START
 1163                 %IF sym = '(' %START
 1164                    search base = 0;                  !ignore format for now
 1165                    %IF atom1 >= 106 %START;             !arrays
 1166                       app = phrase(app+200)
 1167                       escape class = esc array
 1168                       atom1 = (atom1-106)>>1+91;     !a,an->v  na,nan->n
 1169                    %FINISH %ELSE %START;                            !procedures
 1170                       escape class = esc proc
 1171                       atom1 = atom1-4
 1172                    %FINISH
 1173                    phrase(200) = app
 1174                 %FINISH
 1175              %FINISH
 1176              pos2 = pos;  %return
 1177           %FINISH
 1178  
 1179           !deal with constintegers etc
 1180  
 1181           %IF atom flags&const bit # 0 %AND atom1 = var %START
 1182                 map gg = const;  atom2 = const
 1183                 subatom = -subatom %IF type = integer
 1184           %FINISH
 1185           %RETURN
 1186  
 1187        %FINISH
 1188                                                   !new name wanted
 1189        ->not in %IF tbase # tstart;               !dont fault proc parm-parm
 1190        %IF d = lab+spec+used bit %START
 1191           t_flags = t_flags!used bit
 1192           %RETURN
 1193        %FINISH
 1194        %IF atom flags&spec # 0 %START;                 !a spec has been given
 1195           %IF d = lab %START;                     !define label
 1196              t_flags <- lab!used bit
 1197              %RETURN
 1198           %FINISH
 1199           %IF 7 <= decl&15 <= 10 %AND decl&spec = 0 %START
 1200  
 1201              !procedure definition after spec
 1202  
 1203              %IF (decl!!atom flags)&2_1111111 = 0 %START;  !correct type?
 1204                 t_flags = t_flags-spec
 1205                 spec given = 1
 1206                 %RETURN
 1207              %FINISH
 1208  
 1209              !note that an external procedure must be speced as a
 1210              !non-external procedure.
 1211  
 1212           %FINISH
 1213           %IF decl&15 = recfm %START;                   !recordformat
 1214              t_flags = record<<4+recfm
 1215              t_format = fdef
 1216              %RETURN
 1217           %FINISH
 1218        %FINISH
 1219        %RETURN %IF last1 = jump %AND atom1 = swit
 1220        copy = pos1 %IF copy = 0
 1221  
 1222  notin:app = 0;  vid = 0
 1223        atom1 = error+2
 1224  
 1225        %return %if d = 0;                               !old name wanted
 1226        type = d>>4&7;  form = d&15;  atom1 = amap(form)
 1227  
 1228        %IF this < 0 %START;                       !normal scope
 1229           new = newname
 1230           tmax = tmax+1;  x = tmax
 1231        %FINISH %ELSE %START;                      !recordformat scope
 1232           new = -1
 1233           recid = recid-1;  vid = recid
 1234           tmin = tmin-1;  x = tmin
 1235           format list = tmin
 1236        %FINISH
 1237  
 1238        %IF 11 <= form <= 14 %START;                     !arrays
 1239           dim = 1 %IF dim = 0;           !set dim for owns
 1240           app = dim
 1241        %FINISH
 1242  
 1243        d = d!used bit %IF (otype > 2 %AND d&spec = 0) %OR perm # 0
 1244  
 1245        !external definitions need not be used in the file in which
 1246        !they are defined, so inhibit a useless unused warning.
 1247  
 1248        t == tag(x)
 1249        %IF form = lab %START
 1250           id = id+1;  vid = id
 1251        %FINISH
 1252        t_index = vid
 1253        t_text   = new name
 1254        t_flags <- d
 1255        t_app    = app
 1256        t_format = fdef;  format = fdef
 1257        subatom = x
 1258  
 1259        %IF new >= 0 %START;                             !insert into hash table
 1260           t_link = dict(new);  dict(new) = x
 1261           %IF gmin = max grammar %START;                !proc param params
 1262              tmin = tmin-1;  subatom = tmin
 1263              tag(tmin) = t
 1264           %FINISH
 1265        %FINISH
 1266        abandon(3) %IF tmax >= tmin
 1267     %END
 1268  
 1269  
 1270  
 1271  top:  pos1 = pos
 1272        subatom = 0;  pend quote = 0
 1273  
 1274        !app and format must be left for assigning to papp & pformat
 1275  
 1276        ->name %IF symtype = -2;                   !letter
 1277        ->number %IF symtype < 0;                  !digit
 1278        %IF symtype = 0 %START
 1279           atom1 = termin;  atom2 = 0
 1280           %RETURN
 1281        %FINISH
 1282        %IF symtype # 2 %START;                    !catch keywords here
 1283           ->text %IF quote # 0;                   !completion of text
 1284           ->strings %IF sym = squote;             !start of string
 1285           ->symbols %IF sym = cquote;             !start of symbol
 1286           ->number %IF sym = '.' %AND '0' <= current char <= '9'
 1287        %FINISH
 1288  
 1289                                                   !locate atom in fixed dict
 1290        k = key>>2;  read sym
 1291        %CYCLE
 1292           j = kdict(k)
 1293           %EXIT %IF j&16_4000 # 0
 1294           %IF j&127 # sym %OR symtype < 0 %START
 1295              ->err %UNLESS j < 0
 1296              k = k+1
 1297           %FINISH %ELSE %START
 1298              l = j>>7&127;  read sym
 1299              %IF j > 0 %START
 1300                 %IF l # 0 %START
 1301                    ->err %IF l # sym %OR symtype < 0
 1302                    read sym
 1303                 %FINISH
 1304                 l = 1
 1305              %FINISH
 1306              k = k+l
 1307           %FINISH
 1308        %REPEAT
 1309        atom1 = j&127
 1310        %IF atom1 = 0 %START;                      !comma
 1311           atom1 = 19;  subatom = 19;  atom2 = 0
 1312           %IF sym = nl %START
 1313              %RETURN %IF ocount >= 0
 1314  
 1315              !special action needs to be taken with <comma nl> as
 1316              !const array lists can be enormous
 1317  
 1318              read sym
 1319           %FINISH
 1320           %RETURN
 1321        %FINISH
 1322        atom2 = j>>7&127
 1323        subatom = kdict(k+1)&16_3fff
 1324        !!!!!cont = ' '
 1325        %RETURN
 1326  
 1327        !report an error. adjust the error marker (pos1) to point
 1328        !to the faulty character in an atom, but care needs to be taken
 1329        !to prevent misleading reports in cases like ...?????
 1330  
 1331  err:  atom1 = error+1;  atom2 = 0
 1332        pos1 = pos %IF pos-pos1 > 2
 1333        %RETURN
 1334  
 1335          !take care with strings and symbol constants.
 1336          !make sure the constant is valid here before sucking it in
 1337          !(and potentially loosing many lines)
 1338  
 1339  symbols:atom1 = var;  atom2 = const;  type = integer
 1340          map gg = const;  protection = prot
 1341          subatom = lp;  abandon(3) %IF lp >= lit max
 1342          quote = \pend quote
 1343          %RETURN
 1344  
 1345        !an integer constant is acceptable so get it in and
 1346        !get the next atom
 1347  
 1348  chars:n = 0;  cont = cquote
 1349        %CYCLE
 1350           read sym
 1351           %IF sym = cquote %START
 1352              %EXIT %IF current char # cquote
 1353              read sym
 1354           %FINISH
 1355           %IF n&(\((-1)>>byte size)) # 0 %START; ! overflow
 1356              pos1 = pos;  atom1 = error+10;  %RETURN
 1357           %FINISH
 1358           ->err %IF quote = 0
 1359           n = n<<byte size+sym
 1360           quote = quote+1
 1361        %REPEAT
 1362        quote = 0;  cont = ' '
 1363        readsym %IF sym # nl
 1364        lit pool(lp) = n;  lp = lp+1
 1365        ->top
 1366  
 1367          !sniff the grammar before getting the string
 1368  
 1369  strings:atom1 = var;  atom2 = const;  type = stringv
 1370          subatom = (strp-stbase)!16_4000
 1371          map gg = const;  protection = prot
 1372          quote = subatom
 1373          text line = lines;                  !in case of errors
 1374          %RETURN
 1375  
 1376        !a string constant is ok here, so pull it in and get
 1377        !the next atom
 1378  
 1379  text: ->chars %IF quote < 0;                    !character consts
 1380        l = strp; n = strp
 1381        j = addr(glink(gmin-1));                  !absolute limit
 1382        k = l+256;                                !string length limit
 1383        k = j %IF j < k;                          !choose lower
 1384  
 1385        %CYCLE
 1386           cont = squote;  quote = 1
 1387           %CYCLE
 1388              read sym
 1389              %IF sym = squote %START;               !terminator?
 1390                 %EXIT %IF current char # squote;      !yes ->
 1391                 read sym;                           ! skip quote
 1392              %FINISH
 1393              l = l+1;  byteinteger(l) = sym
 1394              lines = text line %AND abandon(7) %IF l >= k;    !too many chars
 1395           %REPEAT
 1396           byteinteger(n) = l-n;               !plug in length
 1397  
 1398           strp = l+1;                               !ready for next string
 1399           quote = 0;  cont = ' ';  read sym
 1400           code atom(target)
 1401           %RETURN %UNLESS atom1 = 48 %AND sym = squote;    !fold "???"."+++"
 1402        %REPEAT
 1403  
 1404        %ROUTINE get(%INTEGER limit)
 1405           %INTEGER s, shift
 1406           shift = 0
 1407           %IF base # 10 %START
 1408              %IF base = 16 %START
 1409                 shift = 4
 1410              %FINISH %ELSE %START
 1411                 %IF base = 8 %START
 1412                    shift = 3
 1413                 %FINISH %ELSE %START
 1414                    %IF base = 2 %START
 1415                       shift = 1
 1416                    %FINISH
 1417                 %FINISH
 1418              %FINISH
 1419           %FINISH
 1420           n = 0
 1421           %CYCLE
 1422              %IF symtype = -1 %START;            !digit
 1423                 s = sym-'0'
 1424              %FINISH %ELSE %START
 1425                 %IF symtype < 0 %START;                  !letter
 1426                    s = sym-'A'+10
 1427                 %FINISH %ELSE %START
 1428                    %RETURN
 1429                 %FINISH
 1430              %FINISH
 1431              %RETURN %IF s >= limit
 1432              pt = pt+1;  byteinteger(pt) = sym
 1433              %IF base = 10 %START;            !check overflow
 1434                 %IF n >= max int %AND (s > max dig %OR n > max int) %START
 1435  
 1436                    !too big for an integer,
 1437                    !so call it a real
 1438  
 1439                    base = 0;  type = real;  n = 0
 1440                 %FINISH
 1441              %FINISH
 1442              %IF shift = 0 %START
 1443                 n = n*base+s
 1444              %FINISH %ELSE %START
 1445                 n = n<<shift+s
 1446              %FINISH
 1447              read sym
 1448           %REPEAT
 1449        %END
 1450  
 1451  number:base = 10
 1452  bxk:   atom1 = var;  atom2 = const;  type = integer;  subatom = lp
 1453         map gg = const;  protection = prot
 1454         abandon(3) %IF lp >= lit max
 1455         pt = strp;  mul = 0
 1456         %CYCLE
 1457            get(base)
 1458            %EXIT %UNLESS sym = '_' %AND base # 0 %AND pend quote = 0;    !change of base
 1459            read sym
 1460            base = n
 1461         %REPEAT
 1462  
 1463         %IF pend quote # 0 %START
 1464            ->err %IF sym # cquote
 1465            readsym
 1466         %FINISH
 1467         %IF sym = '.' %START;                        !a real constant
 1468            pt = pt+1;  byteinteger(pt) = '.'
 1469            read sym
 1470            type = real;  base = 0;  get(10)
 1471         %FINISH
 1472         %IF sym = '@' %START;                        !an exponent
 1473            pt = pt+1;  byteinteger(pt) = '@';  k = pt
 1474            readsym
 1475            type = integer;  base = 10
 1476            %IF sym = '-' %START
 1477               read sym;  get(10);  n = -n
 1478            %FINISH %ELSE %START
 1479               get(10)
 1480            %FINISH
 1481            pt = k+1;  byteinteger(pt) = lp;  litpool(lp) = n;  lp = lp+1
 1482            atom1 = error+10 %IF base = 0
 1483            type = real;                              !exponents force the type
 1484         %FINISH
 1485  
 1486         %IF type = real %START
 1487            byteinteger(strp) = pt-strp
 1488            subatom = (strp-stbase)!16_2000;  strp = pt+1
 1489         %FINISH %ELSE %START
 1490            litpool(lp) = n
 1491            lp = lp+1
 1492         %FINISH
 1493         %RETURN
 1494  
 1495  name: atom1 = 0 %AND %RETURN %IF 27 <= target <= 41
 1496        hash value = 0
 1497  
 1498        !*****************************
 1499        !*machine dependent for speed*
 1500        !*****************************
 1501  
 1502        dp = dmax+1
 1503        da = addr(dict(dp));  dbase = da
 1504        %CYCLE
 1505           hash value = hash value+(hash value+sym);        !is this good enough?
 1506           da = da+1;  byteinteger(da) = sym
 1507           read sym
 1508           %EXIT %IF symtype >= 0
 1509        %REPEAT
 1510        %IF sym = cquote %START
 1511           pend quote = 100
 1512           ->symbols %IF hash value = 'M'
 1513           read sym
 1514           %IF hash value = 'X' %THEN base = 16 %AND ->bxk
 1515           %IF hash value = 'K' %C
 1516+          %OR hash value = 'O' %THEN base = 8 %AND ->bxk
 1517           %IF hash value = 'B' %THEN base = 2 %AND ->bxk
 1518           ->err
 1519        %FINISH
 1520        n = da-dbase
 1521        byteinteger(dbase) = n
 1522        dp = dp+(n+2)>>1
 1523        abandon(8) %IF dp >= dmin
 1524  
 1525        atom2 = 90;                  !ident
 1526        %IF last1 = 0 %AND sym = ':' %START;           !label
 1527           limit = local;  lookup(lab);  %RETURN
 1528        %FINISH
 1529        %IF last1 = jump %START;                 !->label
 1530           limit = local;  lookup(lab+spec+used bit);  %RETURN
 1531        %FINISH
 1532        %IF decl # 0 %AND target = 90 %START;    !identifier
 1533           search base = fm base
 1534           limit = local;  lookup(decl)
 1535           search base = 0
 1536        %FINISH %ELSE %START
 1537           limit = 0;  lookup(0)
 1538        %FINISH
 1539     %END
 1540  
 1541     %INTEGERFN parsed machine code
 1542        !   *opcode_??????????
 1543        %routine octal(%integer n)
 1544           %integer m
 1545           m = n>>3
 1546           octal(m) %if m # 0
 1547           put(n&7+'0')
 1548        %end
 1549        atom1 = error %AND %RESULT=0 %UNLESS symtype = -2;  !starts with letter
 1550        put('w')
 1551        %CYCLE
 1552           put(sym)
 1553           read sym
 1554           %EXIT %IF symtype >= 0;           !pull in letters and digits
 1555        %REPEAT
 1556        put('_')
 1557        %IF symtype # 0 %START;                !not terminator
 1558           atom1 = error %AND %result=0 %UNLESS sym = '_'
 1559           read sym
 1560           %WHILE symtype # 0 %CYCLE
 1561              %IF symtype < 0 %START;             !complex
 1562                 code atom(0);  %result=0 %IF atom1&error # 0
 1563                 %IF atom2 = const %AND type = integer %START
 1564                    %IF subatom < 0 %THEN octal(tag(-subatom)_format) %C
 1565+                                   %ELSE octal(litpool(subatom))
 1566                 %FINISH %ELSE %START
 1567                    %IF 91 <= atom1 <= 109 %START
 1568                       put(' '); octal(tag(subatom)_index)
 1569                    %FINISH %ELSE %START
 1570                       atom1 = error;  %result=0
 1571                    %FINISH
 1572                 %FINISH
 1573              %FINISH %ELSE %START
 1574                 put(sym);  read sym
 1575              %FINISH
 1576           %REPEAT
 1577        %FINISH
 1578        put(';')
 1579        %RESULT=1
 1580     %END
 1581  
 1582     cont = ' ' %IF gg = 0
 1583     last1 = 0;  mapgg = 0
 1584     s = 0;  ss = 0;  sstype = -1; fdef = 0
 1585     fm base = 0
 1586     app = 0
 1587  
 1588     !deal with alignment following an error in one statement
 1589     !of several on a line
 1590  
 1591     margin = column;                         !start of statement
 1592  
 1593     pos = 0
 1594     stbase = addr(glink(gmax+1));  strp = stbase;  lp = 0
 1595     tbase = tstart;               !??????????????
 1596     local = tbase
 1597  
 1598     %IF gg = 0 %or ocount >= 0 %START;            !data or not continuation(z)
 1599  again:%WHILE sym type = 0 %CYCLE;                !skip redundant terminators
 1600           c = cont
 1601           cont = ' ';  cont = '+' %IF ocount >= 0
 1602           read sym
 1603           cont = c
 1604        %REPEAT
 1605        ->skip %IF sym = '!';                      !comment
 1606        this = -1
 1607        code atom(0)
 1608        %IF atom1 = comment %START
 1609  skip:    quote = 1
 1610           c = cont
 1611           read sym %AND cont = c %WHILE sym # nl; !skip to end of line
 1612           quote = 0;  symtype = 0
 1613           ->again
 1614        %FINISH
 1615     %FINISH
 1616     decl = 0;  mark = 0
 1617     gentype = 0;  force = 0
 1618     dim = 0;  prot err = 0
 1619     node = 0;  nmax = 0;  nmin = rec size+1
 1620     order = 1;  gmin = max grammar+1
 1621     sstype = 0 %AND ->more %IF gg # 0;             !continuation
 1622     ptype = 0;  spec given = 0
 1623  
 1624     stats = stats+1;  op('O', lines) %IF perm = 0
 1625  
 1626     ->fail1 %IF atom1&error # 0;                  !first atom faulty
 1627  
 1628     %IF escape class # 0 %START;                  !enter the hard way after
 1629        g = imp phrase;  sstype = -1;  ->a3
 1630     %FINISH
 1631  
 1632     g = initial(atom1);                           !pick up entry point
 1633     %IF g = 0 %START;                             !invalid first atom
 1634        g = initial(0);  sstype = 0;  ->a3;        !declarator?
 1635     %FINISH
 1636     %IF g < 0 %START;                             !phrase imp
 1637        g = g&255
 1638        nmax = 1
 1639        ar(1)_class = 0;  ar(1)_link = 0;  ar(1)_sub = imp phrase
 1640     %FINISH
 1641  
 1642     gg = gram(g);  class = gg&255;  sstype = gg>>12&3-1
 1643     ->a1
 1644  
 1645  act(194): ptype = type;  papp = app;  pformat = format;  ->more
 1646  act(196):k =g+1;  ->a610
 1647  act(188):k = ar(nmax)_sub+1
 1648  a610:     papp = glink(k)
 1649            k = gram(k)
 1650            ->more %IF k = 0;                        !%NAME
 1651            ptype = k&7;  pformat = k>>3
 1652  act(183):k = type;  gentype = k %IF gentype = 0 %OR k = real
 1653            %IF pformat < 0 %START;               !general type
 1654               app = papp;  format = pformat
 1655               k = real %IF ptype = real %AND type = integer
 1656               k = force %AND force = 0 %IF force # 0
 1657            %FINISH
 1658            ->fail2 %UNLESS papp = app %AND (ptype = k %OR ptype = 0)
 1659            ->more %IF pformat=format %OR pformat = 0 %OR format = 0
 1660            ->fail2
 1661  act(197):arp == ar(nmin)
 1662           k = arp_sub
 1663           ->fail3 %UNLESS block form = k&15
 1664           arp_sub = k>>4
 1665  
 1666           type = block type
 1667           ptype = block type;  pformat = block fm;  papp = app
 1668           pformat = -1 %IF ptype # record
 1669           ->more
 1670  act(195):arp == ar(nmin)
 1671           k = arp_sub
 1672           arp_sub = k>>2
 1673           k = k&3
 1674                                                        !1 = check integer
 1675                                                        !2 = check real
 1676                                                        !3 = check real + int
 1677            ->more %IF k = 0;                             !no action
 1678            %IF k = 1 %START
 1679               force = integer
 1680               ->more %IF type = integer %OR type = 0
 1681               ->fail2
 1682            %FINISH
 1683            ->fail2 %UNLESS ptype = real %or ptype = 0
 1684            force = integer %IF k = 3
 1685            ->more
 1686  act(198):!%OTHER
 1687           k = gg>>8&15
 1688           %IF k = 0 %START;      !restore atom
 1689              atom1 = last1
 1690              ->more
 1691           %FINISH
 1692           %IF k = 1 %START;      !test string
 1693              ->fail2 %UNLESS type = stringv
 1694              ->more
 1695           %FINISH
 1696           %if k = 2 %start
 1697              ->fail2 %if type = record
 1698              -> more
 1699           %finish
 1700           %if k = 3 %start;         !check OWN variable coming
 1701              code atom(0)
 1702              ->A7 %if atom flags&own bit = 0
 1703              ->more
 1704           %finish
 1705           for warn = pos1 %IF x <= local;      !%FORTEST
 1706           ->more
 1707  paction(1):%IF type = record %THEN g = phrase(242) %ELSE pformat = -1
 1708                                                 ->a3
 1709  paction(2):ptype = real;     pformat = -1;     ->a3
 1710  paction(3):ptype = stringv;  pformat = -1;     ->a3
 1711  paction(4):ptype = integer;  pformat = -1;     ->a3
 1712  paction(5):->a3 %if ptype = integer
 1713             g = phrase(212) %AND pformat=-1 %IF ptype = real
 1714             g = phrase(213) %IF ptype = stringv
 1715             ->a3
 1716  paction(6):ptype = gram(ar(nmax)_sub+1)&7;  pformat = -1;  ->a3
 1717  paction(7):ptype=real %IF ptype = integer;  pformat=-1; ->a3
 1718  
 1719  a1:   last1 = class;  atom1 = 0;  s = subatom
 1720  
 1721  a2:   %IF gg&trans bit = 0 %START;                !insert into analysis record
 1722           z == node
 1723           %CYCLE;                                  !insert cell in order
 1724              k = z
 1725              %EXIT %IF gg&order bits = 0 %OR k = 0
 1726              gg = gg-order bit;  z == ar(k)_link
 1727           %REPEAT
 1728           gg = map gg %IF map gg # 0 %AND gg&255 = var
 1729           nmin = nmin-1;  ->fail0 %IF nmin = nmax
 1730           z = nmin
 1731           arp == ar(nmin)
 1732           arp_sub = s;  arp_class = (gg&255)!mark
 1733           arp_link = k
 1734        %FINISH
 1735        mark = 0;  map gg = 0
 1736  
 1737  more: g = glink(g);                               !chain down the grammar
 1738  
 1739  paction(0):
 1740  a3:   gg = gram(g);  class = gg&255            ;! <------------------------------ gg set to -1...  THIS CAUSES MISSING SWITCH LABEL paction(15) BELOW
 1741  debug("gg = gram(g) = -1 ... g=".itos(g,0)." gg=".itos(gg,0)) %if gg = -1
 1742        trace analysis %IF diag&1 # 0
 1743        ->a5 %IF class = 0;                         !end of phrase
 1744  
 1745        %IF class < actions %START;                 !not a phrase or an action
 1746           class = atomic(class) %IF class >= figurative
 1747           ->a2 %IF class >= manifest
 1748           code atom(class) %IF atom1 = 0
 1749           %IF escape class # 0 %START;             !escape to new grammar
 1750              class = escape class;  escape class = 0
 1751              g = g+escape
 1752  
 1753              !note that following an escape the next item is
 1754              !forced to be transparent!
 1755  
 1756  esc:        gg = 0
 1757              arp == ar(nmax+1)
 1758              arp_papp = papp;  arp_x = x;  ->a4
 1759           %FINISH
 1760  
 1761           ->a1 %IF class = atom1 %OR class = atom2
 1762  
 1763  a7:      ->fail1 %IF gg >= 0;                     !no alternative
 1764           g = g+1
 1765           ->a3
 1766        %FINISH
 1767  
 1768        %IF class >= phrasal %START;                !a phrase
 1769  a4:      nmax = nmax+1;  ->fail0 %IF nmax = nmin
 1770           arp == ar(nmax)
 1771           arp_ptype = ptype
 1772           arp_pos = pos1
 1773           arp_pformat = pformat
 1774           arp_link = gentype
 1775           arp_class = node
 1776           arp_sub = g
 1777           node = 0
 1778           g = phrase(class)
 1779           ptype = force %AND force = 0 %IF force # 0
 1780           gentype = 0
 1781           ->paction(gg>>8&15)                                                       ;! <----------------- CAUSES CRASH
 1782  paction(*):debug("* Switch label not set: paction(".itos(gg>>8&15,0).") {gg=".itos(gg,0)."}"); %stop {avoid executing random code}
 1783        %FINISH
 1784  
 1785        ->act(class);                               !only actions left
 1786  act(*):debug("* Switch label not set: act(".itos(class,0).")"); %stop
 1787  a5:   !reverse links
 1788  
 1789        s = 0
 1790        %WHILE node # 0 %CYCLE
 1791           z == ar(node)_link
 1792           k = z;  z = s;  s = node;  node = k
 1793        %REPEAT
 1794        ss = s
 1795  
 1796  a6:   %IF nmax # 0 %START
 1797           k = gentype;                             !type of phrase
 1798           arp == ar(nmax);  nmax = nmax-1
 1799           node = arp_class
 1800           gentype = arp_link
 1801           ptype = arp_ptype
 1802           pformat = arp_pformat
 1803           g = arp_sub
 1804           %IF g&escape # 0 %START
 1805              g = g-escape
 1806              papp = arp_papp
 1807              mark = 255
 1808              subatom = s
 1809              ->a3
 1810           %FINISH
 1811           gentype = k %IF gentype = 0 %OR k = real
 1812           type = gen type
 1813  
 1814           k = gg;                                  !exit-point code
 1815           %CYCLE
 1816              gg = gram(g)
 1817              ->a2 %IF k = 0
 1818              ->fail1 %IF gg >= 0;                  !no alternative phrase
 1819              k = k-order bit
 1820              g = g+1;                              !sideways step
 1821           %REPEAT
 1822  
 1823        %FINISH
 1824  
 1825        pos1 = copy %AND fault(4) %IF copy # 0
 1826        fault(13) %IF order = 0
 1827        fault(-4) %IF for warn # 0
 1828        pos1 = 0
 1829        fault rate = fault rate-1
 1830        %RETURN
 1831  
 1832  act(193):gg = 0 %AND ->a5 %UNLESS sym = '=' %or sym = '<'; !cdummy
 1833  act(181):atom1 = amap(decl&15);                             !dummy
 1834           ->more
 1835  
 1836  act(182):class = escdec;  g = glink(g)!escape
 1837           decl = 0;  otype = 0;  ->esc;                      !decl
 1838  
 1839  act(199):
 1840           !reverse links;                                     !compile
 1841  
 1842           s = 0
 1843           %WHILE node # 0 %CYCLE
 1844              z == ar(node)_link
 1845              k = z;  z = s;  s = node;  node = k
 1846           %repeat
 1847           ss = s
 1848  
 1849           code atom(28) %IF quote # 0;                       !expend
 1850           compile;  ->more %IF atom1&error = 0
 1851           ->fail1
 1852  
 1853  act(184):->fail4 %UNLESS type = integer
 1854           %IF subatom < 0 %THEN lit = tag(-subatom)_format %C
 1855+                          %ELSE lit = lit pool(subatom)
 1856           ->fail4 %IF lit # 0
 1857           ->more
 1858  act(185):                                                   !apply parameters
 1859           s = 0
 1860           %WHILE node # 0 %CYCLE
 1861              z == ar(node)_link
 1862              k = z;  z = s;  s = node;  node = k
 1863           %REPEAT
 1864           ss = s
 1865  
 1866           atom1 = ar(s)_class;  atom2 = 0
 1867           atom1 = var %IF atom1 = 97 %OR atom1 = 98
 1868           arp == ar(nmax)
 1869           x = arp_x
 1870           pos1 = arp_pos
 1871           pos2 = 0
 1872           app = 0
 1873           format = tag(x)_format
 1874           flags = tag(x)_flags
 1875           type = flags>>4&7
 1876           protection = flags&prot
 1877           protection = 0 %IF flags&aname # 0
 1878  
 1879           %IF flags&subname # 0 %AND format # 0 %START
 1880              ->fail1 %if format selected = 0
 1881           %FINISH
 1882  
 1883           ->a6
 1884  
 1885  act(187):protection = prot;  ->more;                      !%SETPROT
 1886  act(186):->more %if protection&prot = 0
 1887           prot err = nmin
 1888           -> a7
 1889  act(191):k = protection;                           !%GUARD
 1890           code atom(0)
 1891           protection = k %IF atom flags&aname = 0
 1892           ->more
 1893  
 1894  act(192):->fail1 %IF parsed machine code=0
 1895           ->more
 1896  
 1897  act(189):k = gapp;                                     !%GAPP
 1898           delete names(1)
 1899           tmax = tbase;  tbase = gram (gmin);           !restore tmax
 1900           local= tbase
 1901           gmin = gmin+1
 1902  
 1903           x = ar(ar(nmax)_class)_sub
 1904           tag(x)_app = k;                               !update app
 1905           ->more
 1906  
 1907  act(190):gmin = gmin-1;                                !%LOCAL
 1908           abandon(2) %IF gmin <= gmax
 1909           gram (gmin) = tbase;  tbase = tmax
 1910           local = tbase
 1911           ->more
 1912  
 1913  ! errors
 1914  
 1915  fail4:k = error+10;            ->failed;        !*size
 1916  fail3:k = error+7;             ->failed;        !*context
 1917  fail2:k = error+5;  pos2 = 0;  ->failed;        !*type
 1918  fail0:k = error+3;             ->failed;        !*too complex
 1919  fail1:k = atom1;  pos2 = 0
 1920  
 1921  failed:
 1922        %IF diag&32 # 0 %START
 1923           printstring("Atom1 =")
 1924           write(atom1, 3)
 1925           printstring("  Atom2 =")
 1926           write(atom2, 3)
 1927           printstring("  subatom =")
 1928           write(subatom, 3)
 1929           newline
 1930           printstring("Type =")
 1931           write(type, 1)
 1932           printstring("   Ptype =")
 1933           write(ptype, 1)
 1934           newline
 1935           printstring("App =")
 1936           write(app, 1)
 1937           printstring("   Papp =")
 1938           write(papp, 1)
 1939           newline
 1940           printstring("Format =")
 1941           write(format, 1)
 1942           printstring("   Pformat =")
 1943           write(pformat, 1)
 1944           newline
 1945           %monitor
 1946         %FINISH
 1947  
 1948         quote = 0 %AND readsym %WHILE sym # nl %AND sym # ';'
 1949         %IF k&error # 0 %START
 1950            fault(k&255)
 1951         %FINISH %ELSE %START
 1952           %IF prot err = nmin %THEN fault(14) %ELSE fault(0)
 1953         %FINISH
 1954         gg = 0;  ss = 0;  symtype = 0
 1955     %END;                                               !of analyse
 1956  
 1957     %ROUTINE compile
 1958  
 1959        %CONSTINTEGER then = 4, else = 8, loop = 16
 1960  
 1961        %SWITCH c(0:actions), litop(1:12)
 1962  
 1963        %CONSTBYTEINTEGERARRAY operator(1:14) = %C
 1964+                          '[',  ']',  'X',  '/', '&',  '!',  '%',  '+',
 1965+                          '-',  '*',  'Q',  'x', '.',  'v'
 1966  
 1967        %CONSTBYTEINTEGERARRAY cc(0 : 7) = '#','=',')','<','(','>', 'k','t'
 1968  
 1969        %CONSTBYTEINTEGERARRAY anyform(0:15) = 1,0,1,1(4),1,0,1,1,0,1,1,1,1
 1970  
 1971        %CONSTSHORTINTEGERARRAY decmap(0:15) = %C
 1972+          1,             2,
 1973+          16_100B,       16_100D,       16_140C,      16_140E,
 1974+          3,             4,
 1975+          16_1007,       16_1008,       16_1009,      16_100A,
 1976+          6,             0,             0,            0
 1977        %OWNBYTEINTEGERARRAY cnest(0:15)
 1978        %INTEGER lmode, clab, dupid
 1979        %INTEGER resln
 1980        %OWNINTEGER last def = 0
 1981        %OWNINTEGER lb, ub
 1982        %INTEGER cp, ord
 1983        %INTEGER next, link, j, k, n, done
 1984        %INTEGER class
 1985        %INTEGER lit2, defs, decs, cident
 1986        %INTEGER pending;  %OWNINTEGERARRAY pstack(1:40)
 1987        %OWNSTRING(8) name = ""
 1988        %OWNINTEGER count = 0
 1989  
 1990        %ROUTINE def lab(%INTEGER l)
 1991           op(':', l)
 1992           access = 1
 1993        %END
 1994  
 1995        %ROUTINE get next
 1996           %RECORD(arfm)%NAME p;      !imp77:
 1997  gn:      %IF next = 0 %START;                        !end of phrase
 1998              class = 0 %AND %RETURN %IF link = 0;     !end of statement
 1999              p == ar(link)
 2000              next = p_link
 2001              link = p_sub
 2002           %FINISH
 2003           %CYCLE
 2004              p == ar(next)
 2005              x = p_sub
 2006              class = p_class
 2007              %EXIT %IF class < actions;               !an atom
 2008              %IF x = 0 %START;                        !null phrase
 2009                 next = p_link;  ->gn
 2010              %FINISH
 2011              %IF p_link # 0 %START;                   !follow a phrase
 2012                 p_sub = link;  link = next
 2013              %FINISH
 2014              next = x
 2015           %REPEAT
 2016           next = p_link
 2017           %IF diag&2 # 0 %START
 2018              spaces(8-length(name)) %UNLESS name = ""
 2019              name = text(class)
 2020              write(x, 2)
 2021              space
 2022              printstring(name)
 2023              space
 2024              count = count-1
 2025              %IF count <= 0 %START
 2026                 count = 5
 2027                 name = ""
 2028                 newline
 2029              %FINISH
 2030           %FINISH
 2031        %END
 2032  
 2033        %ROUTINE set subs(%INTEGER n)
 2034  
 2035           !update the app field in n array descriptors
 2036  
 2037           %INTEGER p
 2038           p = tmax
 2039           %WHILE n > 0 %CYCLE
 2040              %SIGNAL 15,15 %IF p < tbase
 2041              tag(p)_app = dimension
 2042              p = p-1;  n = n-1
 2043           %REPEAT
 2044        %END
 2045  
 2046        %ROUTINE set bp
 2047  
 2048           !define a constant bound pair from the last stacked constants
 2049  
 2050           pending = pending-2
 2051           lb = pstack(pending+1);  ub = pstack(pending+2)
 2052           %IF ub < lb-1 %START
 2053              pos1 = 0;  next = link;  fault(11)
 2054              ub = lb
 2055           %FINISH
 2056           set const(lb);  set const(ub)
 2057           put('b') %UNLESS class = 146
 2058        %END
 2059  
 2060        %ROUTINE compile end(%INTEGER type)
 2061  
 2062           ! type = 0:eof, 1:eop, 2:end
 2063  
 2064           %IF access # 0 %START
 2065              open = 0
 2066              fault(19) %IF block form > proc;           !can reach end
 2067           %FINISH
 2068  
 2069           %WHILE dict(dmin) >= 0 %CYCLE;                !finishes & repeats
 2070              fault(17+dict(dmin)&1)
 2071              dmin = dmin+1
 2072           %REPEAT
 2073           {delete names(0)}
 2074           put(';')
 2075           put(';') %IF type = 1;       !endofprogram
 2076  
 2077           bflags = bflags!open;                         !show if it returns
 2078  
 2079           def lab(0) %IF block tag # 0 %AND level # 1;  !for jump around
 2080           %IF type # 2 %START;                          !eop, eof
 2081              fault(16) %IF level # type;                !end missing
 2082           %FINISH %ELSE %START
 2083              %IF level = 0 %START
 2084                 fault(15);                                 !spurious end
 2085              %FINISH
 2086           %FINISH
 2087  
 2088           !end mark = 11;               !IMP77
 2089        %END
 2090  
 2091        %ROUTINE def(%INTEGER p)
 2092  
 2093           !dump a descriptor
 2094  
 2095           %INTEGER t, f, type
 2096           %RECORD(tagfm)%NAME v;      !imp77:
 2097           defs = defs+1
 2098           v == tag(p)
 2099           t = 0
 2100           put('$')
 2101           %UNLESS v_index < 0 %START;                   !no index for subnames
 2102              id = id+1 %AND v_index = id %IF v_index = 0
 2103              last def = v_index
 2104              putword(lastdef)
 2105           %FINISH %else putword(0)
 2106           print ident(p, 1);                            !output the name
 2107           t = v_flags
 2108           type = t
 2109           type = type&(\(7<<4)) %IF type&(7<<4) >= 6<<4;!routine & pred
 2110           put(','); put(type&2_1111111);            !type & form
 2111           f = v_format
 2112           f = tag(f)_index %IF t&16_70 = record<<4
 2113           f = v_index %IF f < 0
 2114           op(',', f);               !format
 2115           f = otype+t>>4&2_1111000
 2116           f = f!8 %IF class = 125;                      !add spec from %DUP
 2117           dim = v_app;                  !dimension
 2118           dim = 0 %unless 0 < dim <= dim limit
 2119           put(','); putlong(f+dim<<8);                              !otype & spec & prot
 2120           defs = 0 %IF t&parameters = 0
 2121           f = t&15
 2122           %IF v_flags&spec # 0 %START
 2123              v_flags = v_flags&(\spec) %UNLESS 3 <= f <= 10
 2124              ocount = -1;             ! external specs have no constants
 2125           %FINISH
 2126           dimension = 0
 2127           %if otype = 2 %and (f=2 %or f=12 %or f=14) %start
 2128              v_flags = v_flags-1;            !convert to simple
 2129           %finish
 2130        %END
 2131  
 2132        %ROUTINE def s lab(%INTEGER n)
 2133  
 2134           !define a switch label, x defines the switch tag
 2135  
 2136           %INTEGER p, l, b, w, bit
 2137           p = tag(x)_format;                            !pointer to table
 2138           l = dict(p);                                  !lower bound
 2139           %IF l <= n <= dict(p+1) %START
 2140              b = n-l
 2141              w = b>>4+p
 2142              bit = 1<<(b&15)
 2143              %IF dict(w+2)&bit # 0 %START;                 !already set
 2144                 fault(4) %IF pending # 0
 2145                 %RETURN
 2146              %FINISH
 2147              dict(w+2) <- dict(w+2)!bit %IF pending # 0
 2148              set const(n)
 2149              op('_', tag(x)_index)
 2150           %FINISH %ELSE %START
 2151              fault(12)
 2152           %FINISH
 2153           access = 1
 2154        %END
 2155  
 2156        %ROUTINE call
 2157           %RECORD(tagfm)%NAME T;      !IMP77:
 2158           t == tag(x)
 2159           op('@', t_index)
 2160           access = 0 %IF t_flags&closed # 0;         !never comes back
 2161           put('E') %IF t_app = 0;             !no parameters
 2162        %END
 2163  
 2164        %ROUTINE pop def
 2165           set const(pstack(pending));  pending = pending-1
 2166        %END
 2167  
 2168        %ROUTINE pop lit
 2169           %IF pending = 0 %THEN lit = 0 %ELSE %START
 2170              lit = pstack(pending);  pending = pending-1
 2171           %FINISH
 2172        %END
 2173  
 2174  
 2175        %IF sstype < 0 %START;                       !executable statement
 2176           %IF level = 0 %START;                     !outermost level
 2177              fault(13);                             !*order
 2178           %FINISH %ELSE %START
 2179              %IF access = 0 %START
 2180                 access = 1;  fault(-1);                !only a warning
 2181              %FINISH
 2182           %FINISH
 2183        %FINISH
 2184  
 2185        %IF diag&2 # 0 %START
 2186           newline %IF sym # nl
 2187           printstring("ss =")
 2188           write(ss, 1)
 2189           newline
 2190           count = 5
 2191           name = ""
 2192        %FINISH
 2193  
 2194        next = ss
 2195        pending = 0;  lmode = 0
 2196        link = 0;  decs = 0
 2197        defs = 0;  resln = 0;  done = 0
 2198        ord = level
 2199        ord = 1 %IF this >= 0;           !recordformat declarations
 2200  c(0):
 2201  top:  %IF next # link %START
 2202           get next;  ->c(class)
 2203  c(*):debug("* Switch label not set: c(".itos(class,0).")"); %stop
 2204        %FINISH
 2205  
 2206        !all done, tidy up declarations and jumps
 2207  
 2208        newline %IF diag&2 # 0 %AND count # 5
 2209  
 2210        %IF lmode&(loop!then!else) # 0 %START;    !pending labels and jumps
 2211           op('B', label-1) %IF lmode&loop # 0;   !repeat
 2212           def lab(label)   %IF lmode&then # 0;   !entry from then
 2213           def lab(label-1) %IF lmode&else # 0;   !entry from else
 2214        %FINISH
 2215  
 2216        %RETURN %IF decs = 0
 2217        atom1 = error %AND %RETURN %IF atom1 # 0;      !%INTEGERROUTINE
 2218        order = ord
 2219        decl = decl&(\15)+decmap(decl&15);           !construct declarator flags
 2220        atom1 = atoms(decl&15);                      !generate class
 2221        %IF otype # 0 %START;                  !own, const etc.
 2222           atom1 = atom1+1 %IF atom1 # proc
 2223           %IF otype = 2 %START;               !const
 2224              n = decl&15
 2225              %if n&1 # 0 %start
 2226                 decl = decl!prot
 2227                 decl = decl!const bit %IF decl&2_1111111 = iform
 2228              %finish
 2229           %else
 2230              decl = decl!own bit
 2231           %FINISH
 2232        %FINISH
 2233        sstype = 1 %IF sstype = 0 %AND atom1 = proc
 2234        atom1 = atom1+1 %IF decl&spec # 0;             !onto spec variant
 2235        ocount = 0 %AND cont = '+' %IF atom1 = 5;      !own array
 2236        %IF anyform(decl&15) = 0 %START;               !check meaningful
 2237           %IF decl>>4&7 = record %START
 2238              this = fdef %IF tag(fdef)_flags&spec # 0
 2239              atom1 = error+21 %IF fdef = this;        !*context for format
 2240           %FINISH
 2241           atom1 = error+10 %IF fdef = 0;              !*size
 2242        %FINISH
 2243        %RETURN
 2244  
 2245  atop:   access = 0;  ->top
 2246  
 2247  ! declarators
 2248  
 2249  c(88):                                                !rtype
 2250  c(28): decl = x&(\7);                                 !stype
 2251         fdef = x&7;                                    !precision
 2252         fdef = reals ln %IF x&2_1110001 = real<<4+1;  !convert to long
 2253         decs = 1;  ->top
 2254  c(34):                                                !own
 2255  c(35): otype = x;  ord = 1;  ->top;                   !external
 2256  c(152):decl = decl+x<<1;  ->top;                      !xname
 2257  c(31):                                                !proc
 2258  c(32): spec mode = level+1;                           !fn/map
 2259         decl = decl!prot %IF x = 9;                    !function
 2260  c(29): ord = 1;                                       !array
 2261         dim = 0
 2262  c(30): decl = decl+x;                                 !name
 2263         decs = 1
 2264         ->top
 2265  c(27): lit = 0;                                       ! arrayd
 2266         %IF pending # 0 %START
 2267            pop lit
 2268            %UNLESS 0<lit<=dim limit %START
 2269               atom1 = error + 11;  %RETURN
 2270            %FINISH
 2271         %FINISH
 2272         dim = lit
 2273         decl = decl + x;  decs = 1
 2274         -> top
 2275  c(37): x = x!subname;                                 !record
 2276  c(36): lit = 0;                                       !string
 2277         %IF pending # 0 %START
 2278           pop lit
 2279            %UNLESS 0 < lit <= 255 %START;              !max length wrong
 2280               atom1 = error+10;  %RETURN
 2281            %FINISH
 2282         %FINISH
 2283         fdef = lit;                                    !format or length
 2284  c(33): decl = x;                                      !switch
 2285         decs = 1
 2286         ->top
 2287  c(39): decl = decl!spec;                              !spec
 2288         ocount = -1;                                   !no initialisation
 2289         spec mode = -1
 2290         ->top
 2291  c(38): decl = 64+4;                                   !recordformat (spec)
 2292         order = 1
 2293         atom1 = x
 2294         decl = decl!spec %if atom1 = 12;               !formatspec
 2295         fdef = tmax+1;                                 !format tag
 2296         %return
 2297  c(175):id = id+1;  tag(x)_index = id;  %return;       !FSID
 2298  c(41): decs = 1;  decl = x!spec;  ->top;              !label
 2299  c(133):recid = 0;  rbase = tmin-1;                    !fname
 2300         this = x
 2301         fm base = fdef;  format list = tmin
 2302         def(this);                      ->top
 2303  c(148):fdef = 0 %AND ->top %IF next = 0;              !reclb
 2304         get next;                                      !skip name
 2305         fdef = x
 2306         ->top
 2307  c(127):put('}');  ->top;                              !%POUT
 2308  c(126):put('{');  ->top;                              !%PIN
 2309  
 2310  c(174):set bp;                                        !rangerb
 2311  c(171):                                               !fmlb
 2312  c(172):                                               !fmrb
 2313  c(173):put('~');  put(class-171+'A');  ->top;
 2314          !fmor
 2315  c(168):rbase = -rbase;                                !orrb
 2316         sstype = 0;  spec mode = 0
 2317  
 2318  c(147):search base = 0;                               !recrb
 2319         tag(this)_app = tmin
 2320         tag(this)_format = rbase
 2321         ->top
 2322  
 2323  c(45):put('U') %IF x = 36;  ->top;                    !sign
 2324  c(46):put('\');  ->top;                               !uop
 2325  c(47):                                                !mod
 2326  c(48):                                                !dot
 2327  c(42):                                                !op1
 2328  c(43):                                                !op2
 2329  c(44):put(operator(x));  ->top;                       !op3
 2330  
 2331  !conditions & jumps
 2332  
 2333        %ROUTINE push(%INTEGER x)
 2334           %IF cnest(cp)&2 # x %START
 2335              cnest(cp) = cnest(cp)!1;  x = x+4
 2336           %FINISH
 2337           clab = clab+1 %IF cnest(cp)&1 # 0
 2338           cnest(cp+1) = x;  cp = cp+1
 2339        %END
 2340  
 2341        %ROUTINE pop label(%INTEGER mode)
 2342           lmode = dict(dmin)
 2343           %IF lmode < 0 %OR lmode&1 # mode %START
 2344              fault(mode+8)
 2345           %FINISH %ELSE %START
 2346              dmin = dmin+1;  label = label-3
 2347           %FINISH
 2348        %END
 2349  
 2350  c(56):                                         !and
 2351  c(57):push(x);  ->top;                         !or
 2352  c(58):cnest(cp) = cnest(cp)!!2;  ->top;        !not
 2353  
 2354  c(138):x = 128+32+16+4;                        !csep: treat like %WHILE
 2355  c(59):                                         !while
 2356  c(60):%IF class = 138 %THEN op('f', label-1) %C
 2357+                       %ELSE def lab(label-1);  !until
 2358  c(166):                                        !runtil
 2359  c(62):lmode = (lmode&(else!loop)) !(x>>3);     !cword
 2360        clab = label;  cp = 1;  cnest(1) = x&7
 2361        ->top
 2362  c(72):pop label(0);                            !repeat
 2363        def lab(label+1) %IF lmode&32 # 0;  ->atop
 2364  c(69):pop label(1);               ->top;       !finish
 2365  c(163):                                        !xelse
 2366  c(70):pop label(1);                            !finish else ...
 2367        fault(7) %IF lmode&3 = 3;                !dangling else
 2368  c(68):lmode = (lmode&else)!3;                  !...else...
 2369        %IF access # 0 %START
 2370           op('F', label-1);  lmode = else!3
 2371        %FINISH
 2372        def lab(label)
 2373        ->top %IF next # 0
 2374  
 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        last array = tmax-1
 2387        n = 0
 2388        n = 16_FFFF %IF pending = 0;      !* = all events
 2389        %WHILE pending > 0 %CYCLE
 2390           pop lit;  fault(10) %IF lit&(\15) # 0;!too big
 2391           j = 1<<lit
 2392           dubious = 1 %IF n&j # 0
 2393           n = n!j;                              !construct bit mask
 2394        %REPEAT
 2395        op('o', n);  op(',', label)
 2396        lmode = then!1;  ->stcy
 2397  
 2398  
 2399  c(104):op('J', tag(x)_index);                  !l
 2400         inhibit = 1;            ->atop
 2401  c(149):stats = stats-1;                        !lab
 2402         access = 1;  inhibit = 1
 2403         fault(13) %IF x < last array;           !jump round array dec
 2404         op('L', tag(x)_index);  ->top
 2405  
 2406  c(63):j = dmin;  l = label-3;                  !exit, continue
 2407        %CYCLE
 2408           fault(7) %AND ->top %IF dict(j) < 0
 2409           %EXIT %IF dict(j)&1 = 0
 2410           j = j+1;  l = l-3
 2411        %REPEAT
 2412        l = l+1 %IF x = 32;                      !continue
 2413        op('F', l)
 2414        dict(j) = dict(j)!x;                     !show given
 2415        ->atop
 2416  
 2417  c(50):put('C');  ->cop;                        !acomp
 2418  
 2419  c(49):
 2420         %IF next # 0 %START;                     !comparator
 2421            put('"');  push(0);                  !double sided
 2422         %FINISH %ELSE %START
 2423            put('?')
 2424         %FINISH
 2425  
 2426  cop:   x = x!!1 %IF cnest(cp)&2 # 0;           !invert the condition
 2427         j = cp;  l = clab
 2428         %WHILE cnest(j)&4 = 0 %CYCLE
 2429            j = j-1;  l = l-cnest(j)&1
 2430         %REPEAT
 2431         op(cc(x), l)
 2432         def lab(clab+1) %IF cnest(cp)&1 # 0
 2433         cp = cp-1
 2434         clab = clab-cnest(cp)&1
 2435         ->top
 2436  
 2437  c(78):                                              !fresult
 2438  c(79):                                              !mresult
 2439  c(80):   open = 0;                                  !return, true, false
 2440  c(82):   access = 0;                                !stop
 2441  c(89):                                              !addop
 2442  c(81):   put(x);  ->top;                            !monitor
 2443  
 2444  c(65):   pop lit;  op('e', lit);  ->atop;  !signal
 2445  
 2446  c(51):   put('S');            ->top;                !eq
 2447  c(53):   put('j');            ->top;                !jam transfer
 2448  c(52):   put('Z');            ->top;                !eqeq
 2449  
 2450  c(74):%IF level = 0 %START;                         !begin
 2451           %IF progmode <= 0 %THEN progmode = 1 %ELSE fault(7)
 2452           {Permit BEGIN after external defs}
 2453        %FINISH
 2454        spec mode = level+1
 2455        block x = 0
 2456        put('H');  %RETURN
 2457  c(77):perm = 0;  lines = 0;  stats = 0;             !endofperm
 2458  debug("close input    {input stream=".itos(input stream,0)."}")
 2459        close input
 2460  debug("select input(source=".itos(source,0).")")
 2461        select input(source);
 2462        sym = nl
 2463        list = list-1
 2464        list = list -1 %if command & listbit # 0
 2465        tbase = tmax;  tstart = tmax
 2466        %RETURN
 2467  c(76):%IF include # 0 %AND x = 0 %START;            !end of ...
 2468           lines = include;  sstype =  0;             !include
 2469  debug("close input    {input stream=".itos(input stream,0)."}")
 2470           close input
 2471           list = include list
 2472           include = 0;
 2473  debug("select input(source=".itos(source,0).")")
 2474  	 select input(source);
 2475  	 sym = nl;
 2476  	 %RETURN
 2477        %FINISH
 2478        ss = -1;                                      !prog/file
 2479  c(75):compile end(x);  %RETURN;                     !%END
 2480  
 2481  c(85):%IF x=0 %THEN control=lit %ELSE %START;     !control
 2482           diag = lit&16_3FFF %IF lit>>14&3 = 1
 2483        %FINISH
 2484        op('z'-x, lit)
 2485        ->top
 2486  c(83):list = list+x-2;   ->top;                     !%LIST/%ENDOFLIST
 2487  c(84):reals ln = x;      ->top;                     !%REALS long/normal
 2488  c(86):%IF include # 0 %START;                       !include "file"
 2489           fault(7);  %RETURN
 2490        %FINISH
 2491        get next;                                  !sconst
 2492        include file = string(x-16_4000+stbase)
 2493        open input(3, include file)
 2494        include = lines;  lines = 0
 2495        include list = list
 2496  debug("select input(3)")
 2497        select input(3);
 2498        sym = nl
 2499        ->top
 2500  
 2501  c(154):dimension = dimension+1;                     !dbsep
 2502         fault(11) %IF dimension = dim limit+1
 2503         ->top
 2504  c(145):set bp;                       ->top;         !crb
 2505  c(146):set bp;                                      !rcrb
 2506  c(142):                                             !bplrb
 2507         dimension = 1 %IF dimension = 0
 2508         op('d', dimension);  op(',', defs)
 2509         %IF class # 146 %START
 2510            set subs(defs)
 2511            last array = tmax-1
 2512            fault(13) %IF dict(dmin) >= 0 %OR inhibit # 0 %OR level=0
 2513         %FINISH
 2514         dimension = 0;  defs = 0
 2515         ->top
 2516  c(128):id = dupid;  ->top;                          !EDUP
 2517  c(130):block x = x
 2518         op('F', 0) %IF decl&spec = 0 %AND level # 0; !jump round proc
 2519  c(125):dupid = id;                                  !%DUP
 2520  c(90): def(x);  ->top;                              !ident
 2521  c(131):                                             !cident
 2522         %IF tag(x)_flags&(2_1111111+const bit) = iform+const bit %START
 2523            tag(x)_format = lit
 2524         %FINISH %ELSE %START
 2525            set const(lit) %IF pending # 0
 2526            def(x)
 2527           put('A'); putlong(1)
 2528         %FINISH
 2529         cident = x
 2530         ->top
 2531  c(124):dubious = 1 %IF tag(cident)_flags&prot # 0; !%DUBIOUS
 2532         ->top
 2533  c(97):                                              !f
 2534  c(98):                                              !m
 2535  c(99):                                              !p
 2536  c(96): call;  ->top;                                !r
 2537  
 2538  c(165):                                             !nlab
 2539  c(100):                                             !rp
 2540  c(101):                                             !fp
 2541  c(102):                                             !mp
 2542  c(103):                                             !pp
 2543  c(91):                                              !v
 2544  c(92):                                              !n
 2545  c(106):                                             !a
 2546  c(107):                                             !an
 2547  c(108):                                             !na
 2548  c(109):                                             !nan
 2549        k = tag(x)_index
 2550        %IF k < 0 %THEN op('n', -k) %ELSE op('@', k)
 2551        ->top
 2552  c(121):set const(0);  ->top;                        !special for zero
 2553  c(167):put('G');  ->pstr;                           !aconst (alias)
 2554  c(const):                                           !const
 2555         %IF x < 0 %START;                            !constinteger
 2556            set const(tag(-x)_format);  ->top
 2557         %FINISH
 2558         %IF x&16_4000 # 0 %START;                    !strings
 2559            put('''')
 2560  pstr:     x = x-16_4000+stbase
 2561            k = byteinteger(x)
 2562           putblock(k+1, byteinteger(x))
 2563           -> top
 2564         %FINISH
 2565         %IF x&16_2000 # 0 %START;                    !real
 2566            x = x-16_2000+stbase
 2567            k = byteinteger(x)
 2568            op('D', k);  put(',')
 2569            k = k+x
 2570            %CYCLE
 2571               ->top %IF x = k
 2572               x = x+1;  j = byteinteger(x)
 2573               %IF j = '@' %START
 2574                  op('@', litpool(byteinteger(x+1)));  ->top
 2575               %FINISH
 2576               put(j)
 2577            %REPEAT
 2578         %FINISH
 2579         set const(lit pool(x))
 2580         ->top
 2581  
 2582  c(137):put('i');               ->top;         !asep
 2583  c(141):put('a');               ->top;         !arb
 2584  
 2585  !own arrays
 2586  
 2587  c(132):ocount = ub-lb+1
 2588         def(x);                               !oident
 2589         dimension = 1;  set subs(1)
 2590         %IF next = 0 %START;                  !no initialisation
 2591            %IF ocount > 0 %start
 2592              put('A'); putlong(ocount)
 2593              %finish
 2594            ocount = -1
 2595         %FINISH %ELSE %START;                 !initialisation given
 2596            get next
 2597         %FINISH
 2598         ->top
 2599  c(162):lit = ocount;  ->ins;                 !indef
 2600  c(143):pop lit;                              !orb
 2601  ins:   fault(10) %AND lit = 0 %IF lit < 0
 2602         get next
 2603         ->inst
 2604  c(139):                                      !osep (x=19)
 2605  c(153):lit = 1
 2606  inst:  pop def %IF pending # 0;              !ownt (x=0)
 2607        put('A'); putlong(lit)
 2608         ocount = ocount-lit
 2609         %IF ocount >= 0 %START
 2610            ->top %IF x # 0;      !more coming
 2611            ocount = -1 %AND %RETURN %IF ocount = 0;  !all done
 2612         %FINISH
 2613         fault(11);  %RETURN
 2614  
 2615  c(swit):op('W', tag(x)_index);  inhibit = 1;  ->atop
 2616  c(134):def(x);                               !swid
 2617         n = ub-lb+1
 2618         n = (n+15)>>4;                        !slots needed (includes zero)
 2619         j = dmax;  dmax = dmax+n+2
 2620         abandon(1) %IF dmax >= dmin
 2621         tag(x)_format = j
 2622         dict(j) = lb;  dict(j+1) = ub
 2623         %CYCLE
 2624            n = n-1
 2625            ->top %IF n < 0
 2626            j = j+1;  dict(j+1) = 0
 2627         %REPEAT
 2628  c(151):stats = stats-1;                      !slab
 2629         fault(7) %AND %RETURN %IF x < tbase
 2630         %IF pending # 0 %START;               !explicit label
 2631            def s lab(pstack(1))
 2632         %FINISH %ELSE %START
 2633            fault(4) %AND %RETURN %IF tag(x)_app # 0
 2634            tag(x)_app = 1
 2635            n = tag(x)_format
 2636            %FOR j = dict(n), 1, dict(n+1) %CYCLE;   !imp77:
 2637               def s lab(j);                         !imp77:
 2638            %REPEAT;                                 !imp77:
 2639         %FINISH
 2640         inhibit = 1
 2641         %RETURN
 2642  
 2643  c(140):put('p');             ->top;          !psep
 2644  c(144):put('p');  put('E');  ->top;          !prb
 2645  
 2646  !constant expressions
 2647  
 2648  c(155):                                      !pconst
 2649         %IF x < 0 %THEN lit = tag(-x)_format %ELSE lit = lit pool(x)
 2650         pending = pending+1;     pstack(pending) = lit;  ->top
 2651  c(156):lit = pstack(pending);  lit = -lit %IF lit < 0
 2652                                  pstack(pending) = lit;  ->top;  !cmod
 2653  c(157):-> top %if X#36          { JGH fix to %const %integer X = +1 => -1 bug }
 2654         lit = -pstack(pending);  pstack(pending) = lit;  ->top;  !csign
 2655  c(158):lit = \pstack(pending);  pstack(pending) = lit;  ->top;  !cuop
 2656  c(159):                                      !cop1
 2657  c(160):                                      !cop2
 2658  c(161):pending = pending-1;                  !cop3
 2659         lit2 = pstack(pending+1);  lit = pstack(pending)
 2660         ->litop(x>>2)
 2661  litop(*):debug("* Switch label not set: litop(".itos(x>>2,0).") {x=".itos(x,2)."}"); %stop
 2662  litop(10):lit = lit*lit2;   ->setl
 2663  litop(12):
 2664  litop(3):n = 1;                              !lit = lit\\lit2
 2665           fault(10) %IF lit2 < 0
 2666           %WHILE lit2 > 0 %CYCLE
 2667              lit2 = lit2-1
 2668              n = n*lit
 2669           %REPEAT
 2670           lit = n;           ->setl
 2671  litop(1):lit = lit<<lit2;   ->setl
 2672  litop(2):lit = lit>>lit2;   ->setl
 2673  litop(5):lit = lit&lit2;    ->setl
 2674  litop(11):
 2675  litop(4):%IF lit2 = 0 %THEN fault(10) %ELSE lit = lit//lit2
 2676                              ->setl
 2677  litop(8):lit = lit+lit2;    ->setl
 2678  litop(9):lit = lit-lit2;    ->setl
 2679  litop(6):lit = lit!lit2;    ->setl
 2680  litop(7):lit = lit!!lit2
 2681  
 2682  setl: pstack(pending) = lit;  ->top
 2683  
 2684  c(170):            !option string
 2685     put('~'); put('D')
 2686     ->pstr
 2687  
 2688  !string resolution
 2689  
 2690  c(135):resln = 2;         ->top;           !dotl
 2691  c(136):resln = resln+1;   ->top;           !dotr
 2692  c(55): op('r', resln);    resln = 0; ->top;           !resop
 2693  c(164):op('r', resln+4);  resln = 0;         !cresop
 2694  c(122):x = 6;            ->cop;            !%PRED
 2695  c(87):set const(pstack(1));            !mass
 2696        put('P');  ->top
 2697     %END
 2698  
 2699  %END;                                      !of compile block
 2700  
 2701  debug("ENTERED PASS1  object tank=".itos(object tank,0)." *************")
 2702  
 2703     %ON 9 %START
 2704  debug("[3]%ON 9 %START:")
 2705        abandon(5)
 2706     %FINISH
 2707  
 2708     selectoutput(listing)                               ;!!!!!!!!!!!!!!!! THIS FAILS
 2709  !debug("A: object tank=".itos(object tank,0))
 2710     %if command & list bit # 0 %start
 2711        printstring("
 2712+       Computer Science VAX-11 IMP77 Compiler.  Version 8.02
 2713+ 
 2714+             Compiled on ".date." at ".time)
 2715        newlines(2)
 2716  debug("select input(1)")
 2717        select input(1)
 2718        printstring("   Source file: ".infilename)
 2719        newline;  newline
 2720  !debug("B: object tank=".itos(object tank,0))
 2721     %finish
 2722  !debug("C: object tank=".itos(object tank,0))
 2723  debug("select input(prims=".itos(prims,0).")")
 2724     select input(prims)
 2725  debug("select output tank(object tank=".itos(object tank,0).")")
 2726     select output tank(object tank)
 2727     tag(max tag) = 0;                       !%BEGIN defn
 2728     tag(0) = 0;  tag(0)_flags = 7;          !%BEGIN tag!
 2729     %FOR x = 0, 1, max names %CYCLE;   !imp77:
 2730        hash(x) = 0;                    !imp77:
 2731     %REPEAT;                           !imp77:
 2732     include file = ""
 2733     put('l'); putword(0)
 2734     compile block(0, 0, max dict, 0, 0)
 2735     %result = -faulty %IF faulty # 0;   !imp77: %ENDOFPROGRAM
 2736     %result = stats
 2737  %end
?SYSMESS unused
 2738  %endoffile

 2319 Statements compiled
