         Edinburgh IMP77 Compiler - Version 8.4

    1  !IMP syntax checker - based on M68000 IMP compiler
    2  !                              (qv for fuller annotation)
    3  !  Hamish Dewar  Computer Science   Edinburgh University  1983
    4  !
    5  %constinteger MAXNAME=127
    6  %recordformat EDFILE(%integer start1,lim1, {part 1}
    7+                               start2,lim2, {part2}
    8+                               lim, {VMLIM}
    9+                               lbeg,fp,change,flag,
   10+                               line  {line number of current pos},
   11+                               diff  {diff between LINE and ROW},
   12+                               shift {right shift of window on file},
   13+                 %byteinteger  top  {top row of sub_window},
   14+                               win  {floating top},
   15+                               bot  {bottom row +1 of sub_window},
   16+                               min  {minimum window size},
   17+                               row  {last row position},
   18+                               col  {last col position},
   19+              %string(maxname) name)
   20  !
   21  %external%routine EDI(%record(edfile)%name main,sec,
   22+                       %string(255) message)
   23  %end
?MESSAGE unused
?SEC unused
?MAIN unused
   24                        
   25  %external%routine CONNECT EDFILE(%record(edfile)%name f)
   26  %end
?F unused
   27  
   28  %external%routine DISCONNECT EDFILE(%record(edfile)%name f)
   29  %end
?F unused
   30  
   31  
   32  !%external%routine%spec EDI(%record(edfile)%name main,sec,
   33  !                         %string(255) message)
   34  !%external%routine%spec CONNECT EDFILE(%record(edfile)%name f)
   35  !%external%routine%spec DISCONNECT EDFILE(%record(edfile)%name f)
   36  
   37  !
   38  !$IF VAX
   39  %conststring(13) permfile="ECCE_PERM"
   40  !$IF AMDAHL
   41  {%conststring(18) permfile="ERCLIB:VECCE.IPERM"
   42  !$FINISH
   43  
   44  !!  control
   45  %constinteger logbit=   16_00040000 {print log},
   46+               warnbit=  16_00020000 {print warnings},
   47+               nonsbit=  16_00010000 {print nonstandard reports},
   48+               DICTLIST= 16_00001000 {list dict entries},
   49+               EXPLIST=  16_00000800 {list EXP entries}
   50  %owninteger control=warnbit+nonsbit
   51  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   52  %externalroutine ECCECI(%record(edfile)%name main)
   53  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   54  %ownstring(maxname) extraname
   55  %ownrecord(edfile) extra=0,null=0
   56  %integer curstart,curlim
   57  %integer nonstop
   58  %owninteger change=0
   59  !!  Fault numbers
   60  %constinteger FORMERR=0, ATOMERR=1, NAMERR=2, CATERR=3, SIZERR=4,
   61+               ASSERR=5, TYPERR=6, DUPERR=7,
   62+               NOSTART=8, NOCYCLE=9,
   63+               ORDERERR=10, MATCHERR=11, RANGERR=12, NONLITERAL=13,
   64+               BOUNDSERR=14, ACCESSERR=15, NOTINLOOP=16,
   65+               NOTINROUT=17, NOTINFUN=18, NOTINPRED=19,
   66+               PLEXERR=20, NOIF=21, NONSTAND=22, NOTIN=23,
   67+               INDEXERR=24,
   68+               MOPERR=27, NOTERM=28, NONSTARTER=29,
   69+               NONVAR=30, NONREF=31, TOOMANY=32, TOOFEW=33,
   70+               UNWANTED=34, NOPARM=35, UNENDING=37,
   71+               SELFREF=38
   72  %constinteger NOEND=40, NOBEGIN=41,
   73+               IDMISSING=42, NOFINISH=43, NOREPEAT=44,
   74+               COUNTERR=45, NORESULT=46
   75  %constinteger ERRMAX=46
   76  %constinteger POINT=64,WARN=128
   77  %owninteger FAULTNUM=0
   78  %owninteger FAULTS=0;          !fault count
   79  !
   80  %constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT,
   81+               MAX10=maxint//10, MAXDIG=maxint-max10*10
   82  %constinteger FALSE=0, TRUE=1
   83  %integer I
   84  !
   85  !!  Program statistics
   86  %owninteger STATEMENTS=0;           !statement count
   87  !%owninteger ATOMS=0;                !atom count
   88  !%owninteger IDENTATOMS=0;           !identifier count
   89  !%owninteger NUMATOMS=0;             !numeric atom count
   90  !%owninteger MISSES=0;               !ident mismatches
   91  !%owninteger ZAPS=0
   92  !
   93  !!!!!!!!!!!!!!!!   Operand Representation  !!!!!!!!!!!!!!!!!!!
   94  
   95  %constinteger SMALLMIN=-1000, SMALLMAX=1000,
   96+               LITMIN=smallmax+1, LITMAX=smallmax+1000,
   97+               D0=litmax+1, D1=d0+1, D2=d0+2, D6=d0+6, D7=d0+7,
   98+               A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7,
   99+               INDA0=a0+8,
  100+               POSTA0=inda0+8, POSTA7=posta0+7,
  101+               PREA0=posta0+8, PREA7=prea0+7,
  102+               DICTMIN=prea0+8, DICTMAX=prea0+1200,
  103+               LABMIN=dictmax+1, LAB1=labmin+1, LABMAX=labmin+20,
  104+               EXPMIN=labmax+1, EXPMAX=labmax+300,
  105+               UNDEF=expmax+1, AD=16_4000
  106  %constinteger MAXDREG=d0+4, MAXAREG=a0+3
  107  %constinteger D0B=1, D1B=2, D2B=4,
  108+               A0B=16_100, A1B=16_200, A2B=16_400
  109  %constinteger ALLREGS=2_0000111100011111;  !a3:a0 & d4:d0
  110  %owninteger FREE=allregs
  111  %constinteger NULLTYPE=dictmin,
  112+               RECY=nulltype+1, ARRY=recy+1, STRINGY=arry+1,
  113+               REALY=stringy+1, INTY=realy+1,
  114+               CHARTYPE=inty+1, BOOLTYPE=chartype+1,
  115+               FALSECONST=booltype+1, TRUECONST=booltype+2,
  116+               INTTYPE=trueconst+1, SHORTTYPE=inttype+1,
  117+               HALFTYPE=shorttype+1, BYTETYPE=halftype+1,
  118+               MITETYPE=bytetype+1, BITTYPE=MITETYPE+1,
  119+               LONGINTTYPE=bittype+1,
  120+               REALTYPE=longinttype+1, LONGREALTYPE=realtype+1
  121  %constinteger PURETYPE=8191, DIRECT=8192, INDIRECT=16384
  122  %constinteger ANYINT=inty+direct, ANYINTVAR=inty+indirect,
  123+               ANYSTRING=stringy+direct, ANYSTRINGVAR=stringy+indirect
  124  %constinteger ANYNAME=nulltype+indirect
  125  
  126  !
  127  %owninteger dictshown=dictmin
  128  
  129  !!!!!!!!!!!!!!!!!!!!!!!   Big Literals  !!!!!!!!!!!!!!!!!!!!!!!
  130  %owninteger LITPOS=litmin, SLITPOS=litmax
  131  %integerarray LITSTORE(litmin:litmax)
  132  !
  133  !!!!!!!!!!!!!!!!!!!!!!!!!!  MODE VALUES  !!!!!!!!!!!!!!!!!!!!!!!!!
  134  !Size codes:
  135  %constinteger bytesize=1, wordsize=2, longsize=3
  136  %constinteger sizemask=16_C0, sizeshift=6
  137  !Address modes:
  138  %constinteger dmode=0, amode=2_001000,
  139+               indmode=2_010000, postmode=2_011000, premode=2_100000,
  140+               dispmode=2_101000, indexmode=2_110000, absmode=2_111000,
  141+               pcmode=2_111010, litmode=2_111100
  142  %constinteger ownmode=dispmode+6;  !d(A6)
  143  !
  144  !!!!!!!!!!!!!!!!!!!!!!!!  Identifiers  !!!!!!!!!!!!!!!!!!!!!!!!
  145  !
  146  %recordformat OBJINFO %C
  147+   (%integer flags,type,
  148+     (%integer extra, %byteinteger spare,mode %or %integer low),
  149+    %integer val)
  150  %recordformat IDENTINFO %C
  151+   ((%integer flags,type,
  152+     (%integer extra, %byteinteger spare,mode %or %integer low),
  153+    %integer val %or %record(objinfo) details),
  154+    %integer text,link)
  155  !
  156  ! Significance of FLAGS:
  157  %constinteger VAR=16_0001, LAB=16_0002, PROC=16_0004, STATIC=16_0008,
  158+               SPEC=16_0010, EXT=16_0020, PARM=16_0040, MORE=16_0080,
  159+               TYPEID=16_0100, OKFLAG=16_0200, ALT=16_0800,
  160+               RFLAG=16_1000,WFLAG=16_2000
  161  !
  162  ! Significance of VAL:
  163  !  for literal               : the actual value
  164  !  for variable              : machine address (displacement)
  165  !  for undefined label       : reference chain
  166  !  for undefined procedure   :       "
  167  !  for base type             : (index to) range
  168  !  for record type           : size of record in bytes
  169  !
  170  !  Identifier dictionary:
  171  %record(identinfo)%array DICT(d0:labmax)
  172  !  indexing DICT:
  173  %owninteger DLIM=trueconst+1;         !dict limit (up)
  174  %owninteger DLIM0
  175  %owninteger PERMLIM=dictmin
  176  %owninteger DMIN=dictmax-1;       !dict upper limit (down)
  177  
  178  !  Text of identifiers (indexed by _TEXT):
  179  %constinteger CHARBOUND=6000
  180  %byteintegerarray CHAR(0:charbound)
  181  %integer CHARBASE,CHARLIM,CHARMIN;  !pointers
  182  %integer NEWLEN
  183  
  184  !  Hash index to DICT:
  185  %integerarray HASHINDEX(0:255)
  186  %integername HEAD;                  !head of ident search list
  187  !
  188  !!!!!!!!!!!!!!!!!!!!!  Complex operands  !!!!!!!!!!!!!!!!!!!!!!!
  189  !%recordformat EXPINFO(%integer act,x,y)
  190  !%record(expinfo)%array EXP(expmin:expmax)
  191  %owninteger EXPLO=expmax+1, OLDEXPLO=expmax+1
  192  %constinteger NP0=expmin
  193  %owninteger NP,CONDNP,INSTNP
  194  
  195  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  196  !!!!!!!!!!!!!!!!!!  Keywords and operators  !!!!!!!!!!!!!!!!!!!!
  197  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  198  !*!!!!!!!  Keyword codes -- used by KEYGEN to produce tables  !!
  199  %constinteger END=1 {end},
  200+   REPEAT=2       {repeat},
  201+   FINISH=3       {finish},
  202+   ELSE=4         {else},
  203+   BEGIN=5        {begin},
  204+   EXIT=6         {exit_1,continue_0},
  205+   RETURN=7       {return},
  206+   TF=8           {true_1,false_0},
  207+   RESULT=9       {result},
  208+   STOP=10        {stop},
  209+   GOTO=11        {goto},
  210+   SIGNAL=12      {signal},
  211+   MONITOR=13     {monitor},
  212+   ON=15          {on},
  213+   IU=16          {if_0,unless_1},
  214+   WHILE=17       {while},
  215+   UNTIL=18       {until_1},
  216+   FOR=19         {for},
  217+   THEN=20        {then},
  218+   START=21       {start},
  219+   CYCLE=22       {cycle},
  220+   KEYLABEL=23    {label},
  221+   PREFIX=24 {const_9,constant_9,own_8,external_40,system_40,dynamic_40},
  222+   KRANGE=25      {short_1,half_2,byte_3,mite_4,bit_5},
  223+   KEYLONG=26     {long},
  224+   KEYINTEGER=27  {integer},
  225+   KEYREAL=28     {real},
  226+   KEYSTRING=29   {string},
  227+   KEYRECORD=30   {record},
  228+   KEYFORMAT=31   {format},
  229+   FNMAP=32       {fn_0,function_0,map_1},
  230+   RPRED=33       {routine_0,predicate_1},
  231+   KEYSPEC=34     {spec},
  232+   KEYARRAY=35    {array},
  233+   KEYNAME=36     {name},
  234+   KEYSWITCH=37   {switch},
  235+   OF=38          {of},
  236+   KEYFILE=39     {file},
  237+   PROGRAM=40     {program},
  238+   KEYLIST=41     {list},
  239+   KEYCONTROL=42  {control},
  240+   COMMENT=43     {comment},
  241+   KEYEVENT=44    {event},
  242+   INCLUDE=45     {include},
  243+   ALIAS=46       {alias},
  244+   KEYNOT=47      {not},
  245+   KEYAND=64      {and},
  246+   KEYOR=65       {or}
  247  %CONSTintegerARRAY SYMINIT(97:122) =  %C
  248+   2, 15, 27, 57, 64, 87,118,122,126,  1,  1,141,154,168,175,184,
  249+   1,199,230,270,278,  1,288,  1,  1,  1
  250  
  251  %CONSTBYTEINTEGERARRAY SYMBOL(1:292) =  %C
  252+ 128,114,114, 97,121,163,108,105, 97,115,174,110,100,192,101,103,
  253+ 105,110,133,121,116,101,153,105,116,153,111,110,116,105,110,117,
  254+ 101,134,121, 99,108,101,150,109,109,101,110,116,171,115,116, 97,
  255+ 110,116,152,152,114,111,108,170,121,110, 97,109,105, 99,152,110,
  256+ 100,129,108,115,101,132,120,105,116,134,118,101,110,116,172,116,
  257+ 101,114,110, 97,108,152,105,110,105,115,104,131, 97,108,115,101,
  258+ 136,111,114,109, 97,116,159,110,160,117,110, 99,116,105,111,110,
  259+ 160,147,108,101,167,111,116,111,139, 97,108,102,153,102,144,110,
  260+ 116,101,103,101,114,155, 99,108,117,100,101,173, 97, 98,101,108,
  261+ 151,111,110,103,154,105,115,116,169,111,110,105,116,111,114,141,
  262+ 105,116,101,153, 97,112,160, 97,109,101,164,111,116,175,110,143,
  263+ 119,110,152,102,166,114,193,114,101,100,105, 99, 97,116,101,161,
  264+ 111,103,114, 97,109,168,101,112,101, 97,116,130,111,117,116,105,
  265+ 110,101,161,116,117,114,110,135,115,117,108,116,137, 97,108,156,
  266+  99,111,114,100,158,116,111,112,138,105,103,110, 97,108,140,121,
  267+ 115,116,101,109,152,104,111,114,116,153,112,101, 99,162,119,105,
  268+ 116, 99,104,165, 97,114,116,149,114,105,110,103,157,114,117,101,
  269+ 136,104,101,110,148,110,108,101,115,115,144,116,105,108,146,104,
  270+ 105,108,101,145
  271  
  272  %CONSTBYTEINTEGERARRAY ALTDISP(1:292) =  %C
  273+   0,  5,  0,  0,  0,  0,  5,  0,  0,  0,  0,  0,  0,  0,  5,  0,
  274+   0,  0,  0,  4,  0,  0,  3,  0,  0,  5,  8, 12, 17, 23,  0,  0,
  275+   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  4,
  276+   0,  0,  9,  9,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 40,  3,
  277+   0,  0,  4,  0,  0,  0,  4,  8,  0,  1,  0,  0,  0,  0,  0,  0,
  278+   0,  0,  0,  0,  0, 40,  6, 27,  0,  0,  0,  0,  5,  0,  0,  0,
  279+   0,  6,  0, 14,  0,  0,  0,  2,  0,  0,  0,  0,  0,  0,  0,  0,
  280+   0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  2,  2,  0,  0,
  281+   6,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  5,  0,  0,  0,
  282+   0,  4,  0,  0,  0,  0,  0,  0,  0,  7,  0,  0,  0,  0,  0,  0,
  283+   4,  0,  0,  4,  0,  0,  1,  4,  0,  0,  0,  0,  0,  0,  2,  0,
  284+   3,  0,  8,  2,  0,  0,  0,  0,  8,  0,  0,  0,  0,  0,  0,  1,
  285+   0,  0,  0,  0,  0,  0,  6, 12,  0,  0,  0,  0,  0,  0,  0,  0,
  286+   0,  0,  0,  5,  0,  0,  0,  0,  5,  0,  0,  0,  0,  3,  0,  0,
  287+   0,  0,  0,  0,  0,  4, 30,  0,  0,  6,  0,  0,  0,  0,  0,  6,
  288+   0,  0,  0,  0, 40,  5,  0,  0,  0,  1,  4,  0,  0,  0,  0,  0,
  289+   0,  0,  0,  0,  4,  0,  0,  0,  0,  0,  0,  0,  0,  4,  0,  0,
  290+   1,  0,  0,  0,  0,  0,  5,  0,  0,  0,  1,  0,  0,  0,  1,  0,
  291+   0,  0,  0,  0
  292  
  293  
  294  !*!!!!!!   end of generated tables    !!!!!!!!!!!!!!!!!!!!!!!!!!!
  295  !
  296  %constinteger TERMINATOR=52, CONST=53, IDENT=54,
  297+               AREF=55, RECREF=56,
  298+               MODSIGN=57,
  299+               COLON=58, COMMA=59, RIGHT=60, RIGHTBRACKET=61,
  300+               DUD=63
  301  
  302  !Operators (in banks of 8 acc to rank)
  303  %constinteger BOOLAND=64, BOOLOR=65, BOOLNOT=66,
  304+               FLOAT=67, IMOD=68, FMOD=69
  305  %constinteger EQUALS=70, NOTEQ=71, LESSEQ=72,
  306+               LESS=73, GREATEQ=74, GREATER=75,
  307+               EQEQ=76, NOTEQEQ=77, RESOLVE=79
  308  %constinteger PLUS=80, MINUS=81, LOGOR=82,
  309+               LOGXOR=83, CONCAT=84
  310  %constinteger MULT=88, FDIV=89, IDIV=90,
  311+               LOGAND=91
  312  %constinteger FPOWER=96, IPOWER=97,
  313+               LSHIFT=100, RSHIFT=101, LOGNOT=102
  314  %constinteger FCALL=106, MCALL=107
  315  %constinteger ATOMMAX=107
  316  
  317  ! Instruction actions:
  318  %constinteger swgoto=35, rcall=mcall+2,
  319+               assign=41, jamassign=42, plusass=43,
  320+               compare=44, jump=45, label=46, adecl=47
  321  %constinteger actmax=49
  322  !
  323  !Branch cases ( = machine condition-code)
  324  %constinteger EQ=2_0111, NE=2_0110,
  325+               GT=2_1110, LE=2_1111,
  326+               LT=2_1101, GE=2_1100,
  327+               CC=2_0100, CS=2_0101
  328  %constinteger DOUBLE=16
  329  
  330  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  331  ! Perm procedure identifiers which are recognised explicitly and
  332  !  either implemented in-line or mapped to system entry-point
  333  %constinteger DSHORT=dictmin+6, DLENGTH=dshort+1, DCHARNO=dlength+1,
  334+               DADDR=dcharno+1, DTOSTR=daddr+1,
  335+               DREM=dtostr+1,
  336+               DNEXTSYM=drem+1, DREADSYM=dnextsym+1,
  337+               DPRINTSTR=dreadsym+3,
  338+               DREAD=dictmin+27,
  339+               DNEWLINE=dictmin+41
  340  !System entry-points used explicitly
  341  %constinteger SIGENTRY=16_1114, SCOMPENTRY=16_1128,
  342+               BOUNDENTRY=16_1134, AGETENTRY=16_1138,
  343+               INDEXENTRY=16_113C, IREADENTRY=16_1118
  344  
  345  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  346  
  347  %owninteger STARTS=0, CYCLES=0
  348  %owninteger LOOPLAB=0
  349  %owninteger CURLAB=lab1
  350  !
  351  %recordformat BLOCKINF(%integer sp, delta, fortemps, flags, type,
  352+                   localdpos, parlim, localtext, localpc,
  353+                   localspc, pidpos, access, forward, events,
  354+                   eventpc, faults, return, shorts)
  355  !Flag bits (VAR=1 from D_FLAGS)
  356  %constinteger WRONGCC=2, NONLOCALREF=4, DYNARRAY=8
  357  %constinteger HADON=16_10, HADINST=16_20
  358  
  359  %constinteger OUTERLEVEL=0, MAXLEVEL=16
  360  %owninteger LEVEL=outerlevel;        !current block level
  361  %record(blockinf) C;                !info for current block
  362  %record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks
  363  
  364  ! Final core image
  365  %constinteger PUREBOUND=0, OWNBASE=purebound+1,
  366+               FINALBOUND=ownbase+8191
  367  %byteintegerarray FINAL(0:finalbound);  !for switch info only
  368  %owninteger FINALAD=2, OWNAD=ownbase
  369  !%owninteger FIRSTENTRY=finalbound, FIRSTDPOS=dictmax
  370  !%ownintegername CONSTAD;  !== ownad or finalad
  371  !%owninteger CONSTBOUND=purebound;   !for const/code
  372  !                     =finalbound;  !for own
  373  %owninteger PC=0, SPC=finalbound;  !for switch info
  374  
  375  !Recognition:-
  376  %constinteger CASEMASK=95, CASEBIT=32; !for case conversion
  377  
  378  !Memo variables for current statement:-
  379  %owninteger ITEM=0;          !current operand
  380  %record(objinfo) T;          !full typeinfo for ITEM
  381  %record(identinfo)%name DITEM
  382  %owninteger ELEMENTS; !range details
  383  %owninteger HASH
  384  %owninteger SPECCING=0, MCODING=0
  385  %owninteger DECLMODE, DSIZE
  386  %ownrecord(identinfo) D;            !declaration details
  387  
  388  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  389  
  390  !!  Source file input and listing
  391  %owninteger ATOM=0;                 !current lexical atom
  392  %owninteger MATCHED=1;              !indic that atom has been matched
  393  %owninteger SYM=nl;                 !current input symbol
  394  %owninteger LINE=0;                 !current line number
  395  %owninteger MAINLINE=0
  396  %owninteger DIAGLINE=-9999
  397  %owninteger PROLINE=0
  398  %owninteger MODESYM='&';            !space or '+' or '&' or '"'
  399  !%owninteger OUTCOL=0;               !output line position
  400  !   Pointers to source file:
  401  %owninteger LINESTART=0
  402  %owninteger FP=0;                   !(file pointer) current position
  403  %owninteger CHARS=0
  404  %owninteger ATOMP=0;                !start of current atom
  405  %owninteger FAULTP=0;               !fault position
  406  %owninteger MAINFP
  407  %owninteger STRINGP,EXPP
  408  %owninteger listout=0
  409  !
  410  !! Listing, diagnostic and report routines
  411  !
  412  %ownstring(255) rep=""
  413  !
  414  %routine NEWLINE
  415    print string(rep);  print symbol(nl)
  416    rep = ""
  417  %end
  418  !
  419  %routine PUT SYM(%integer k)
  420    rep = rep.tostring(k) %if length(rep) < 132
  421  %end
  422  !
  423  %routine PRINT STRING(%string(255) s)
  424    rep = rep.s %if length(rep) < 132
  425  %end
  426  !
  427  %routine SPACES(%integer n)
  428    %while n > 0 %cycle
  429      rep = rep." ";  n = n-1
  430    %repeat
  431  %end
  432  !
  433  %routine WRITE(%integer val,p)
  434  %routine PD(%integer v)
  435    p = p-1
  436    pd(v//10) %and v = v-v//10*10 %if v <= -10
  437    spaces(p) %and p = 0 %if p > 0
  438    put sym('0'-v)
  439  %end
  440    %if val < 0 %start
  441      put sym('-');  pd(val)
  442    %finish %else pd(-val)
  443  %end
  444  
  445  !%routine put ident(%integer t)
  446  !  rep = rep.string(charbase+t)
  447  !!%integer l
  448  !  t = t+charbase
  449  !  l = byteinteger(t);  l = 11 %if l > 11
  450  !  %while l > 0 %cycle
  451  !    l = l-1;  t = t+1
  452  !    put sym(byteinteger(t))
  453  !  %repeat
  454  !%end
  455  !
  456  !%routine mark at(%integer col)
  457  !  put sym(' ') %while outcol < col;  put sym('|')
  458  !%end
  459  !
  460  !%routine show dict(%integer from)
  461  !%integer f,i
  462  !%record(identinfo) d
  463  !%constbyteintegerarray flagsym(0:7) =
  464  !  'V','L','P','O','S','E', 'A', 'M'
  465  !%constbyteintegerarray dsym(0:3) =
  466  !  ' ','D','I','!'
  467  !%conststring(6)%array typetext(0:7) =
  468  !  "NULL  ", "RECORD", "ARRAY ", "STRING",
  469  !  "REALY ", "INTY  ", "CHAR  ", "BOOL  "
  470  !  %return %if from >= dlim
  471  !  newline %and outcol = 0 %if outcol # 0
  472  !  print string("          __identifier___flags___type___extra___value___")
  473  !  newline;  outcol = 0
  474  !  %cycle
  475  !    spaces(5);  outcol = 5
  476  !    pdec(from);  mark at(10)
  477  !    d = dict(from)
  478  !    put sym(' ')
  479  !    put ident(d_text)
  480  !    mark at(23)
  481  !    %for i = 7,-1,0 %cycle
  482  !      %if d_flags>>i&1 = 0 %then put sym(' ') %c
  483  !      %else put sym(flagsym(i))
  484  !    %repeat
  485  !    put sym('|')
  486  !    i = d_type-nulltype
  487  !    %if 0 <= i <= 7 %then printstring(typetext(i)) %c
  488  !    %else putsym(dsym(d_type>>13)) %and pdec(d_type&puretype)
  489  !    mark at(39)
  490  !    put sym(' ');  pdec(d_extra);  mark at(47)
  491  !    put sym(' ');  pdec(d_val);  mark at(56)
  492  !    newline;  outcol = 0
  493  !    from = from+1
  494  !  %repeat %until from = dlim
  495  !  print string("          +----------------------------------------------+")
  496  !  newline;  outcol = 0
  497  !%end
  498  !
  499  !%routine show exp(%integer from,to)
  500  !![out of date]
  501  !%conststring(7)%array acttext(0:63) =
  502  !  "?0", "?1", "ADD", "SUB",
  503  !  "?4", "LOGAND", "LOGOR", "LOGXOR",
  504  !  "NEGATE", "LOGNOT", "LSHIFT", "RSHIFT",
  505  !  "IABS", "FABS", "?14", "?15",
  506  !  "MULT", "IDIV", "IPOWER", "FPLUS",
  507  !  "FMINUS", "FMULT", "FDIV", "FPOWER",
  508  !  "FNEGATE", "FLOAT", "CONCAT", "BOOLNOT",
  509  !  "BOOLAND", "BOOLOR", "MEMBER", "MODULO",
  510  !  "RECREF", "AREF", "INDRECT", "SWJUMP",
  511  !  "FCALL", "MCALL", "?38", "RCALL",
  512  !  "?40", "ASSIGN", "JAMASS", "PLUSASS",
  513  !  "COMPARE", "JUMP", "LABEL", "ADECL",
  514  !  "?48", "?49", "?50", "?51",
  515  !  "?52", "?53", "?54", "?55",
  516  !  "?56", "?57", "?58", "?59",
  517  !  "?60", "?61", "?62", "?63"
  518  !%routine put operand(%integer i)
  519  !  %if dictmin <= i <= dictmax %then put ident(dict(i)_text) %else pdec(i)
  520  !%end
  521  !  %return %if from >= np
  522  !  newline %and outcol = 0 %if outcol # 0
  523  !  print string("          __action_____first_______second____")
  524  !  newline;  outcol = 0
  525  !  %cycle
  526  !    spaces(5);  outcol = 5
  527  !    pdec(from);  mark at(10)
  528  !    put sym(' ');  printstring(acttext(exp(from)_act&63))
  529  !    mark at(20);  put sym(' ')
  530  !    put operand(exp(from)_x)
  531  !    mark at(32);  put sym(' ')
  532  !    put operand(exp(from)_y)
  533  !    mark at(44)
  534  !    newline;  outcol = 0
  535  !    from = from+1
  536  !    %if from = to %start
  537  !      from = explo
  538  !      %exit %if from >= oldexplo
  539  !      printstring("          |---------------------------------|")
  540  !      newline;  outcol = 0
  541  !    %finish
  542  !  %repeat %until from >= oldexplo
  543  !  oldexplo = explo
  544  !  print string("          +---------------------------------+")
  545  !  newline;  outcol = 0
  546  !%end
  547  !
  548  !! Fault reporting
  549  !
  550  %routine REPORT(%integer n,joker)
  551  %integer mark,start,errline,k,editfp
  552  %routine PRINT IDENT(%integer x)
  553    put sym('"')
  554    print string(string(dict(x)_text+charbase))
  555    put sym('"')
  556  %end
  557  %routine PRINT TEXT(%integer x,stream)
  558  %constinteger esc=27
  559  %integer k,p
  560  %switch s(0:errmax)
  561    put sym(mark)
  562    write(line,4)
  563    put sym(modesym);  put sym(' ')
  564    ->s(n&63)
  565  s(formerr):   printstring("Faulty form");   -> print
  566  s(atomerr):   printstring("Unknown atom");  -> print
  567  s(namerr):    printstring("Unknown name");  -> print
  568  s(caterr):    printstring("Unsuitable");    -> print
  569  s(sizerr):    printstring("Size");          -> print
  570  s(typerr):    printstring("Wrong type");    -> print
  571  s(boundserr): printstring("Inside out");    -> print
  572  s(unending):  printstring("Endless loop");  -> print
  573  s(indexerr):  printstring("Index");         -> print
  574  s(accesserr): printstring("Not accessible");-> print
  575  s(notinloop): printstring("Not in loop");   -> print
  576  s(notinrout): printstring("Not in routine");-> print
  577  s(notinfun):  printstring("Not in fn/map"); -> print
  578  s(notinpred): printstring("Not in pred");   -> print
  579  s(plexerr):   printstring("Too complex!");  -> print
  580  s(duperr):    printstring("Duplicate");     -> print
  581  s(ordererr):  printstring("Out of order");  -> print
  582  s(matcherr):  printstring("Mismatch");      -> print
  583  s(rangerr):   printstring("Out of range");  -> print
  584  s(nonliteral):printstring("Not literal");   -> print
  585  s(nonstand):  printstring("Nonstandard");   -> print
  586  s(notin):     printstring("Not in yet");    -> print
  587  s(moperr):    printstring("Faulty operand");-> print
  588  s(nocycle):   printstring("Missing %CYCLE"); -> print
  589  s(nostart):   printstring("Missing %START"); -> print
  590  s(noif):      printstring("Missing %IF");    -> print
  591  s(noterm):    printstring("';' missing");    -> print
  592  s(nonstarter):printstring("Non-starter");    -> print
  593  s(nonvar):    printstring("Not variable");   -> print
  594  s(nonref):    printstring("Not reference");  -> print
  595  s(noparm):    printstring("No parameters");  -> print
  596  s(toofew):    printstring("Too few");        -> print
  597  s(unwanted):  printstring("Unwanted");       -> print
  598  s(toomany):   printstring("Too many");       -> print
  599  s(selfref):   printstring("Self-reference"); -> print
  600  s(nobegin):   printstring("Extra %END");     -> print
  601  print:
  602    spaces(21-length(rep))
  603    p = start
  604    %if p < faultp-50 %then p = faultp-47 %and printstring("...") %c
  605+   %else put sym(' ')
  606    %cycle
  607      k = byteinteger(p);  p = p+1
  608      %if p = faultp %start
  609  !$IF VAX
  610        put sym(esc) %and put sym('F') %if stream = 0
  611  !$FINISH
  612        put sym('~')
  613  !$IF VAX
  614        put sym(esc) %and put sym('G') %if stream = 0
  615  !$FINISH
  616      %finish
  617      %exit %if k = nl
  618      %if ' ' <= k <= '~' %then put sym(k) %c
  619+     %else put sym('[') %and write(k,-1) %and put sym(']')
  620    %repeat
  621    %return
  622  s(noend):     printstring("%END");           ->mend
  623  s(noresult):  printstring("Result");         ->mend
  624  s(nofinish):  printstring("%FINISH");        ->mend0
  625  s(norepeat):  printstring("%REPEAT")
  626  mend0:        printstring(" etc") %if curlab > lab1+2
  627                -> mend
  628  s(idmissing):
  629    %cycle
  630  !    newline %and spaces(8) %and outcol = 8 %if outcol > 50
  631      put sym(' ')
  632      print ident(x)
  633      print string("(?)") %if dict(x)_flags&spec = 0;  !switch
  634      x = dict(x)_val
  635    %repeat %until x = 0
  636  mend:
  637    printstring(" missing")
  638    %if c_type # 0 %start
  639      print string(" at END of ")
  640      print ident(c_pidpos)
  641    %finish %else n = 0
  642    %return
  643  s(counterr):
  644    %if elements < 0 %start
  645      write(-elements,0);  printstring(" extra")
  646    %finish %else %start
  647      write(elements,0);  printstring(" missing")
  648    %finish
  649    printstring(" value(s) for ")
  650    print ident(x)
  651    %return
  652  s(asserr):
  653    print ident(x)
  654    print string(" void")
  655  %end
  656  
  657  !Warning or error
  658    mark = '?'
  659    %if n&warn = 0 %start
  660      mark = '*'
  661      c_faults = c_faults+1;  faults = faults+1
  662    %finish
  663    faultnum = 0;  c_access = -1
  664  !Ignore uncorrected earlier error
  665    %return %if main_start1 <= fp < change
  666  !Track back if before current line
  667    start = linestart;  errline = line
  668    %if n&point = 0 %then faultp = 0 %else %start
  669      faultp = joker %if joker > 0
  670      %while faultp <= start %cycle
  671        start = start-1
  672        errline = errline-1 %if byteinteger(start) = nl
  673      %repeat
  674      start = start-1 %while start # curstart %and byteinteger(start-1) # nl
  675    %finish
  676    editfp = start;  editfp = faultp-1 %if faultp > start
  677    editfp = mainfp %if curlim = extra_lim2
  678    start = start+1 %while byteinteger(start) = ' '
  679    print text(joker,0)
  680    newline %and %return %if n&warn # 0 %or nonstop # 0
  681    main_fp = editfp;  main_line = line
  682    %if change # 0 %then main_change = 16_7FFFFFFE
  683    edi(main,null,rep)
  684    rep = ""
  685    nonstop = 1 %if main_flag = 'I'
  686    %stop %if main_flag < 0
  687    %signal 12 %if main_change < 16_7FFFFFFE {change made}
  688   %end;
?K unused
  689        ;  !report
  689  
  690  %routine CROAK(%string(255) s)
  691    print string("** ".s.".  Checking abandoned at line ")
  692    write(line,0);  newline
  693    nonstop = -999
  694    %signal 12
  695  %end
  696  
  697  %routine FAULT(%integer n)
  698  !Note fault number and position of (earliest) fault
  699  ! for subsequent reporting (warnings and weak errors)
  700    faultnum = n %and faultp = atomp %if faultnum = 0
  701  %end
  702  %routine EXPFAULT(%integer n)
  703    faultnum = n!point %and faultp = expp %if faultnum = 0 %or expp < faultp
  704  %end
  705  
  706  %constinteger pred=1, uparr=1<<1, nocomma=1<<2, overload=1<<3,
  707+               ranges=1<<4, nolength=1<<5, initass=1<<6, kgoto=1<<7,
  708+               hyphen=1<<8, naming=1<<9, klabel=1<<10, ibmhex=1<<11,
  709+               oldcycle=1<<12, loop2=1<<13
  710  %routine NONSTANDARD(%integer case)
  711  %owninteger hadit=0
  712    %if control&nonsbit # 0 %and case&hadit = 0 %start
  713      hadit = hadit+case
  714      fault(nonstand+point+warn)
  715    %finish
  716  %end
  717  
  718  %routine ERROR(%integer case)
  719    report(case,atomp)
  720    %signal 14
  721  %end
  722  
  723  %routine NAME ERROR
  724  !check if the culprit has occurred before
  725  !and, if not, add it to the pool of unknowns stored at the
  726  !far end of the dictionary.
  727    %while item < 0 %c
  728+      %and string(dict(-item)_text+charbase) # string(charlim) %cycle
  729       item = dict(-item)_link
  730    %repeat
  731    %if item >= 0 %start;  !first time
  732      report(namerr+point,atomp)
  733      %if charmin-newlen-80 >= charlim %start
  734        dmin = dmin-1
  735        charmin = charmin-newlen-1
  736        string(charmin) = string(charlim)
  737        dict(dmin)_text = charmin-charbase
  738        head == dict(head)_link %while head > 0;  !find last link
  739        dict(dmin)_link = head;  head = -dmin
  740      %finish
  741    %finish
  742    %signal 14
  743  %end
  744  
  745  %routine SYNTAX ERROR
  746  %integer e
  747    e = formerr+point;  e = atomerr+point %if atom = dud
  748    report(e,atomp)
  749    %signal 14
  750  %end
  751  
  752  !!!!!!!!!!!!!!!!!!!!   CELL  CONSTRUCTORS  !!!!!!!!!!!!!!!!!!!
  753  !
  754  !%integerfn litref(%integer v)
  755  !%integer i
  756  !  %result = v %if smallmin <= v <= smallmax
  757  !  litstore(litpos) = v
  758  !  i = litmin-1
  759  !  i = i+1 %until litstore(i) = v
  760  !  %if i = litpos %start
  761  !    litpos = litpos+1
  762  !    croak("Too many literals") %if litpos >= slitpos
  763  !  %finish
  764  !  %result = i
  765  !%end
  766  
  767  !%integerfn litval(%integer v)
  768  !  %result = v %if v <= smallmax
  769  !  %result = litstore(v)
  770  !%end
  771  
  772  %integerfn floated(%integer item)
  773    %result = 0 %if item = 0
  774    %result = explo;!expref(float,item,0)
  775  %end
  776  
  777  !%predicate is short (%integer v)
  778  !  %true %if -32768 <= v <= 32767
  779  !  %false
  780  !%end
  781  
  782  !%predicate is mite (%integer v)
  783  !  %true %if -128 <= v <= 127
  784  !  %false
  785  !%end
  786  
  787  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  788  !!!!!!!!!!!!!!!!!    CODE  GENERATION   !!!!!!!!!!!!!!!!!!!!!!!!
  789  !
  790  %routine forget
  791  %end
  792  %routine forget all
  793  %integer i,j
  794    litpos = litmin;  explo = expmax+1;  oldexplo = explo
  795  %end
?J unused
?I unused
  796  !
  797  %routine set label(%integer b)
  798  %end;
?B unused
  799       ;  !set label
  799  %routine set user label(%integer dpos)
  800  %end
?DPOS unused
  801  %routine compile(%integer from,to)
  802  !  show exp(from,to) %if control&explist # 0
  803    np = np0
  804  %end
?TO unused
?FROM unused
  805  %routine compile entry
  806  %end
  807  %routine compile end
  808  %end;  !compile end
  809  !!!!!!!!!!!!!!!  end of Code Generation  !!!!!!!!!!!!!!!!!!!!!!!
  810  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  811  
  812  %routine PUT3(%integer act,x,y)
  813  !  exp(np)_act = act;  exp(np)_x = x;  exp(np)_y = y
  814  !  np = np+1
  815  %end
?Y unused
?X unused
?ACT unused
  816  !
  817  %routine PUT2(%integer act,x)
  818  %end
?X unused
?ACT unused
  819  !
  820  %integerfn TEMPVAR
  821    %result = dlim
  822  %end
  823  
  824  %routine OPEN BLOCK(%integer pidpos)
  825    forget;  !a bit extreme
  826    croak("Too many levels") %if level = maxlevel
  827    hold(level) = c;  level = level+1
  828    c = 0
  829    starts = 0;  cycles = 0
  830    curlab = lab1;  looplab = 0
  831    forget all
  832    c_flags = 0;  c_type = d_type
  833    c_pidpos = pidpos
  834    c_localdpos = dlim;  c_parlim = dlim;  c_localtext = charlim
  835    c_localpc = pc;  c_localspc = spc
  836    c_access = 1
  837  %end;  !OPEN BLOCK
  838  
  839  %routine CLOSE BLOCK
  840  %integer i
  841  %integer miss,dpos
  842  %integername p
  843  %record(identinfo)%name dp
  844    !Check identifier usage
  845    miss = 0;  p == miss
  846    dpos = c_localdpos
  847    %while dpos # dlim %cycle
  848      dp == dict(dpos)
  849  !    %if (dp_xtype = ptrxtype %and dp_type = dpos)
  850      %if dp_flags&(proc+lab) # 0 %and dp_flags&(ext+spec) = spec %start
  851            p = dpos;  p == dp_val;  p = 0
  852      %finish
  853  !    %if hashindex(dp_spare) = dpos %start
  854  !      dp_link = dict(dp_link)_link %while dp_link >= c_localdpos
  855  !      hashindex(dp_spare) = dp_link
  856  !    %finish
  857  !    dpos = dp_xtype %if dp_type = 0 %and dp_xtype > dpos;  !skip fields
  858      dpos = dpos+1
  859    %repeat
  860    report(idmissing,miss) %if miss # 0
  861    compile end
  862    pc = c_localpc;  spc = c_localspc
  863    dlim = c_parlim;  charlim = c_localtext
  864    %for i = 0,1,255 %cycle
  865       hashindex(i) = dict(hashindex(i))_link %while hashindex(i) >= c_localdpos
  866    %repeat
  867    level = level-1;  c = hold(level)
  868    starts = 0;  cycles = 0
  869  %end;  !CLOSE BLOCK
  870  
  871  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  872  !!!!!!!!!!!!!!!!!!!!  Source input  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
  873  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  874  !
  875  %routine SWITCH INPUT
  876  !  croak("Input ended") %if fp = main_lim2
  877    %signal 12 %if fp = main_lim2
  878    %if nonstop < 0 %start;  !perming
  879      nonstop = nonstop+3;  permlim = dlim
  880      c_localdpos = dlim;  c_parlim = dlim
  881      statements = 0
  882    %finish
  883    %if fp # main_lim1 %start
  884      nonstop = nonstop-1
  885      fp = mainfp;  line = mainline
  886      curstart = main_start1;  curlim = main_lim1
  887    %finish %else fp = main_start2
  888    %if main_start2 <= fp <= main_lim2 %start
  889      curstart = main_start2;  curlim = main_lim2
  890    %finish
  891    modesym = ' ';  sym = nl
  892  %end
  893  
  894  %routine READ LINE
  895  ! Read (or otherwise make available) the next source line
  896  !     Skip remnant of previous line if SYM # NL        *NB*
  897  !     Set LINESTART to point to start of new line
  898    report(faultnum,faultp) %if faultnum # 0
  899    %while sym # nl %cycle;               !Skip remnant
  900      sym = byteinteger(fp);  fp = fp+1
  901    %repeat
  902    %while fp = curlim %cycle
  903      switch input
  904    %repeat
  905    line = line+1;  linestart = fp
  906    sym = 0
  907  %end;  !READ LINE
  908  !
  909  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  910  !!!!!!!!!!!!!!!!!!!!  Lexical processing  !!!!!!!!!!!!!!!!!!!!!!
  911  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  912  
  913  %owninteger percent=0, subatom=0
  914  !
  915  !Aliases:
  916  %constinteger ARROW=resolve
  917  %constinteger EXCLAM=logor, EXCLAM2=logxor, DOT=concat
  918  %constinteger STAR=mult, SLASH=fdiv, SLASH2=idiv,
  919+               AMPERSAND=logand
  920  %constinteger BACKSLASH=fpower, BACKSLASH2=ipower,
  921+               UPARROW=fpower,   UPARROW2=ipower,
  922+               TILDE=lognot
  923  %constinteger LEFT=aref, UNDERLINE=recref, LEFTBRACKET=106
  924  
  925  %constinteger SIMPLE=104, MAJOR=plus,
  926+               SCOND=equals, COND=keyand
  927  !
  928  ! Type compatibility vectors:
  929  %constinteger RECOK=1<<0, ARROK=1<<1, STRINGOK=1<<2,
  930+               REALOK=1<<3, INTOK=1<<4, CHAROK=1<<5, 
  931+               BOOLOK=1<<6, ENUMOK=1<<7, SETOK=1<<8
  932  %constinteger ZNOP=1<<9, REFONLY=1<<10, VARONLY=1<<11
  933  %constinteger ARITHOK=intok+realok,
  934+               ORDOK=intok+charok+boolok+enumok,
  935+               ANY=realok+ordok+stringok+arrok+recok
  936  !
  937  %constintegerarray opbits(64:atommax) =
  938+   {BOOLAND}    boolok,
  939+   {BOOLOR}     boolok,
  940+                0, 0, 0, 0,
  941+   {EQUALS}     any,
  942+   {NOTEQ}      any,
  943+   {LESSEQ}     setok+stringok+ordok+realok,
  944+   {LESS}       stringok+ordok+realok,
  945+   {GREATEQ}    setok+stringok+ordok+realok,
  946+   {GREATER}    stringok+ordok+realok,
  947+                any,
  948+                any,
  949+                0,
  950+   {RESOLVE}    stringok,
  951+   {PLUS}       znop+setok+arithok,
  952+   {MINUS}      znop+setok+arithok,
  953+   {LOGOR}      znop+intok,
  954+   {LOGXOR}     znop+intok,
  955+   {CONCAT}     stringok,
  956+                0, 0, 0,
  957+   {MULT}       arithok,
  958+   {FDIV}       arithok,
  959+   {IDIV}       intok,
  960+   {LOGAND}     intok,
  961+                0, 0, 0, 0,
  962+   {FPOWER}     arithok,
  963+   {IPOWER}     intok,
  964+                0, 0,
  965+   {LSHIFT}     znop+intok,
  966+   {RSHIFT}     znop+intok,
  967+   {LOGNOT}     intok,
  968+                0,
  969+   {AREF}       arrok,
  970+   {RECREF}     recok,
  971+   {}           0, 0
  972  !
  973  %integerfn NEXT ATOM
  974  !Encode next atom from source file
  975  ![Time-critical]
  976  %switch s(0:255)
  977  %constinteger tab=9
  978  %integer i,j,p,radix,digits
  979  %real rval
  980  %constbyteintegerarray map(0:127) =
  981+   0 ('0'),
  982+   '0','1','2','3','4','5','6','7','8','9',
  983+   0, 0, 0, 0, 0, 0, 0,
  984+   'a','b','c','d','e','f','g','h','i','j','k','l','m',
  985+   'n','o','p','q','r','s','t','u','v','w','x','y','z',
  986+   0, 0, 0, 0, 0, 0,
  987+   'a','b','c','d','e','f','g','h','i','j','k','l','m',
  988+   'n','o','p','q','r','s','t','u','v','w','x','y','z',
  989+   0, 0, 0, 0, 0
  990  
  991  %routine assemble real
  992    j = 0
  993    %cycle
  994      %cycle
  995        sym = byteinteger(fp);  fp = fp+1
  996      %repeat %until sym # ' '
  997      i = sym-'0'
  998      %return %unless 0 <= i < radix
  999      rval = rval*radix+i;  j = j+1
 1000    %repeat
 1001  %end
 1002  
 1003  !  atoms = atoms+1
 1004    matched = 0
 1005  again: s(tab):
 1006    read line %if sym = nl
 1007    %cycle
 1008      sym = byteinteger(fp);  fp = fp+1
 1009    %repeat %until sym # ' '
 1010    atomp = fp;     !(actually one after)
 1011    -> s(sym)
 1012  linebreak: s(nl):
 1013    %result = terminator %if atom # comma
 1014    -> again
 1015  
 1016  s('{'):
 1017    %cycle
 1018      sym = byteinteger(fp);  fp = fp+1
 1019      -> linebreak %if sym = nl
 1020    %repeat %until sym = '}'
 1021    -> again
 1022  
 1023  s('+'): %result = plus
 1024  s('-'): fp = fp+1 %and %result = arrow %if byteinteger(fp) = '>'
 1025          -> again %if byteinteger(fp) = nl
 1026          %result = minus
 1027  s('*'): %result = star
 1028  s('/'): fp = fp+1 %and %result = slash2 %if byteinteger(fp) = '/'
 1029          %result = slash
 1030  s('\'): fp = fp+1 %and %result = backslash2 %if byteinteger(fp) = '\'
 1031          %result = backslash
 1032  s('^'): nonstandard(uparr)
 1033          fp = fp+1 %and %result = uparrow2 %if byteinteger(fp) = '^'
 1034          %result = uparrow
 1035  s('!'): fp = fp+1 %and %result = exclam2 %if byteinteger(fp) = '!'
 1036          %result = exclam
 1037  s('&'): %result = ampersand
 1038  s('.'): %result = dot
 1039  s('='): fp = fp+1 %and %result = eqeq %if byteinteger(fp) = '='
 1040          %result = equals
 1041  s('#'): fp = fp+1 %and %result = noteqeq %if byteinteger(fp) = '#'
 1042          %result = noteq
 1043  s('<'): fp = fp+1 %and %result = lesseq %if byteinteger(fp) = '='
 1044          fp = fp+1 %and %result = noteq %if byteinteger(fp) = '>'
 1045          fp = fp+1 %and %result = lshift %if byteinteger(fp) = '<'
 1046          %result = less
 1047  s('>'): fp = fp+1 %and %result = greateq %if byteinteger(fp) = '='
 1048          fp = fp+1 %and %result = rshift %if byteinteger(fp) = '>'
 1049          %result = greater
 1050  s('_'): %result = underline
 1051  s(':'): %result = colon
 1052  s(','): %result = comma
 1053  s(';'): %result = terminator
 1054  s('('): %result = left
 1055  s(')'): %result = right
 1056  s('|'): %result = modsign
 1057  
 1058  s('E'): s('e'):
 1059    fp = fp+1 %and -> stringconst %if byteinteger(fp) = '"'
 1060  s('M'): s('m'): s('C'): s('c'):
 1061    fp = fp+1 %and -> charconst %if byteinteger(fp) = ''''
 1062  s('A'):s('B'):s('D'):s('F'):s('G'):s('H'):
 1063  s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'):
 1064  s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'):
 1065  s('Y'):s('Z'):s('a'):s('b'):s('d'):s('f'):
 1066  s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'):
 1067  s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'):
 1068  s('w'):s('x'):s('y'):s('z'):
 1069    -> keyword %if percent # 0
 1070  !  identatoms = identatoms+1
 1071    newlen = charlim+1;  hash = sym!casebit;  !lower-case (if letter)
 1072    byteinteger(newlen) = hash
 1073    %cycle
 1074      sym = byteinteger(fp);  fp = fp+1
 1075    %repeat %until sym # ' '
 1076  !$IF AMDAHL
 1077  {  %if sym = '''' %start
 1078  {    radix = 16 %and -> ibm %if hash = 'x'
 1079  {    radix = 8 %and -> ibm %if hash = 'k'
 1080  {    radix = 2 %and -> ibm %if hash = 'b'
 1081  {  %finish
 1082  !$FINISH
 1083    sym = map(sym)
 1084    %if sym # 0 %start
 1085      %cycle
 1086        newlen = newlen+1;  byteinteger(newlen) = sym
 1087        hash = hash<<1!!sym
 1088        %cycle
 1089          sym = byteinteger(fp);  fp = fp+1
 1090        %repeat %until sym # ' '
 1091        sym = map(sym)
 1092      %repeat %until sym = 0
 1093    %finish
 1094    fp = fp-1
 1095    newlen = newlen-charlim;  byteinteger(charlim) = newlen
 1096    head == hashindex(hash&255)
 1097    item = head
 1098    %if item > 0 %start
 1099      %cycle
 1100        %result = ident %if item <= 0
 1101        ditem == dict(item)
 1102        %exit %if string(ditem_text+charbase) = string(charlim)
 1103  !      misses = misses+1
 1104        item = ditem_link
 1105      %repeat %until item <= 0
 1106    %finish
 1107    %result = ident
 1108  
 1109  s('%'):
 1110    sym = byteinteger(fp)
 1111    -> again %unless 'a' <= sym!casebit <= 'z'
 1112    fp = fp+1
 1113  keyword:
 1114    percent = 0
 1115    p = syminit(sym!casebit)
 1116    %cycle
 1117  !     %cycle
 1118  !       sym = byteinteger(fp)!casebit
 1119  !       %exit %if symbol(p) # sym
 1120      %while symbol(p) = byteinteger(fp)!casebit %cycle
 1121        p = p+1;  fp = fp+1
 1122      %repeat
 1123      %exit %if symbol(p) >= 128
 1124      atom = altdisp(p)
 1125      %if atom = 0 %start
 1126        %result = dud %unless sym!casebit = 'c' %and byteinteger(fp) = nl
 1127        read line
 1128        ->again
 1129      %finish
 1130      p = p+atom
 1131    %repeat
 1132    percent = 1 %if 'a' <= byteinteger(fp)!casebit <= 'z'
 1133    subatom = altdisp(p)
 1134    atom = symbol(p)-128
 1135    %result = dud %if atom = 0
 1136    %result = atom
 1137  
 1138  !$IF AMDAHL
 1139  {ibm:
 1140  {  nonstandard(ibmhex)
 1141  {  item = -1;  t_val = 0
 1142  {  -> ibm1
 1143  !$FINISH
 1144  s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'):
 1145    item = 0;  t_type = inty
 1146    radix = 10;  t_val = sym-'0'
 1147  ibm1:
 1148    %cycle
 1149      %cycle
 1150        %cycle
 1151          sym = byteinteger(fp);  fp = fp+1
 1152        %repeat %until sym # ' '
 1153        i = sym-'0'
 1154        %if radix = 10 %start
 1155          %exit %if i < 0 %or i >= 10
 1156          %if t_val > max10 %or (t_val=max10 %and i > maxdig) %start
 1157            t_type = realy;  rval = t_val
 1158            assemble real
 1159            %exit
 1160          %finish
 1161          t_val = t_val*10+i
 1162        %finish %else %start
 1163          i = sym!casebit-'a'+10 %if i >= 10
 1164          %exit %if i < 0 %or i >= radix
 1165          j = radix
 1166          %cycle
 1167            i = i+t_val %if j&1 # 0
 1168            t_val = t_val<<1;  j = j>>1
 1169          %repeat %until j = 0
 1170          t_val = i
 1171        %finish
 1172      %repeat
 1173      %exit %unless sym = '_'
 1174      radix = t_val
 1175      %result = dud %if radix = 0
 1176      t_val = 0
 1177    %repeat
 1178    %if sym = '.' %start
 1179      t_type = realy %and rval = t_val %if t_type = inty
 1180      assemble real
 1181      %result = dud %if j = 0
 1182      rval = rval/radix\j
 1183    %finish
 1184  !  %if t_type = realy %start;  !vax->ieee
 1185  !    t_val = integer(addr(rval))
 1186  !    t_val = t_val<<16+t_val>>16-16_01000000
 1187  !  %finish
 1188  !  numatoms = numatoms+1
 1189  !$IF AMDAHL
 1190  {  %if item < 0 %start
 1191  {    %result = dud %if sym # ''''
 1192  {    item = 0
 1193  {  %finish %else %start
 1194  {    fp = fp-1;  sym = 0
 1195  {  %finish
 1196  !$IF VAX OR APM
 1197    fp = fp-1;  sym = 0
 1198  !$FINISH
 1199    %result = const
 1200  
 1201  s(''''):
 1202  charconst:
 1203    item = 0;  t_type = inty
 1204    t_val = 0
 1205    %cycle
 1206      sym = byteinteger(fp);  fp = fp+1
 1207      %result = dud %if sym = nl;  !?allow
 1208      %if sym = '''' %start
 1209        %exit %unless byteinteger(fp) = ''''
 1210        fp = fp+1
 1211      %finish
 1212      t_val = t_val<<8+sym
 1213    %repeat
 1214    %result = const %if t_val # 0
 1215    %result = dud
 1216  
 1217  s('"'):
 1218  stringconst:
 1219    item = 0;  t_type = stringy
 1220    stringp = atomp;  !for include
 1221    t_val = 0
 1222    i = line;  j = linestart
 1223    %cycle
 1224      sym = byteinteger(fp);  fp = fp+1
 1225      %if sym = '"' %start
 1226        %exit %if byteinteger(fp) # '"'
 1227        fp = fp+1
 1228      %finish
 1229      t_val = t_val+1
 1230      %if t_val > 255 %start
 1231        sym = 0
 1232        fp = atomp;  linestart = j
 1233        %result = dud
 1234      %finish
 1235      read line %if sym = nl
 1236    %repeat
 1237    %result = const
 1238  
 1239  s(*):
 1240    %result = dud
 1241  %end;
?IBM1 unused
?DIGITS unused
 1242       ;  !NEXT ATOM
 1242  
 1243  %routine LOOKUP FIELD IDENT(%integer list)
 1244    item = list;  %return %if item = 0
 1245    %cycle
 1246      ditem == dict(item)
 1247      %if ditem_flags&typeid = 0 %start
 1248        %return %if string(ditem_text+charbase) = string(charlim)
 1249        %exit %if ditem_flags&more = 0
 1250      %finish
 1251      item = item+1;  !misses = misses+1
 1252    %repeat
 1253    item = 0
 1254  %end
 1255  
 1256  %predicate A (%integer k)
 1257  !Basic atom-testing predicate
 1258    atom = next atom %if matched # 0
 1259    %false %if k # atom
 1260    matched = 1
 1261    %true
 1262  %end
 1263  
 1264  %routine GET(%integer k)
 1265    atom = next atom %if matched # 0
 1266    matched = 1
 1267    %return %if atom = k
 1268    syntax error %if atom = dud
 1269    faultp = atomp;  report(formerr+point,-k)
 1270    %signal 14
 1271  %end
 1272  
 1273  %routine ALLOW(%integer k)
 1274    %if a(k) %start
 1275    %finish
 1276  %end
 1277  
 1278  %routine DECLARE
 1279    %if speccing = 0 %start;  !not within spec params
 1280      %if item >= c_localdpos %start;  !there already
 1281        %if d_flags&spec = 0 %and d_flags+spec = ditem_flags %c
 1282+       %and ditem_type = d_type %start
 1283          ditem_flags = ditem_flags-spec
 1284          %return
 1285        %finish
 1286        fault(duperr+point)
 1287      %finish
 1288      d_link = head;  head = dlim;  !insert in list
 1289  !    d_spare = hash&255
 1290      %if item > 0 %then d_text = ditem_text %c
 1291+     %else %start
 1292        d_text = charlim-charbase;  charlim = charlim+newlen+1
 1293        croak("Identifier space exhausted") %if charlim+80 >= charmin
 1294      %finish
 1295    %finish %else d_text = 0
 1296    item = dlim;  ditem == dict(item)
 1297    ditem = d
 1298    dlim = dlim+1;  croak("Too many identifiers") %if dlim >= dmin
 1299  %end;  !DECLARE
 1300  
 1301  %routine DECLARE ANON
 1302    d_text = 0;  d_link = 0
 1303    dict(dlim) = d
 1304    dlim = dlim+1;  croak("Too many identifiers") %if dlim >= dmin
 1305  %end
 1306  
 1307  %owninteger jammy
 1308  %predicate A ASSOP
 1309    atom = next atom %if matched # 0
 1310    %if atom # equals %and atom # eqeq %start
 1311      %false %unless atom = less %and byteinteger(fp) = '-'
 1312      jammy = 2;  fp = fp+1
 1313    %finish %else jammy = 0
 1314    matched = 1
 1315    %true
 1316  %end
 1317  
 1318  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1319  !!!!!!!!!!!!!!!!!!!!  Expressions  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1320  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1321  
 1322  %owninteger literal=0
 1323  %routinespec get EXPRESSION(%integer rank,control)
 1324  
 1325  %integerfn COMPAT(%integer control)
 1326    %if t_type = inty %start
 1327      %if control&intok = 0 %and control&realok # 0 %start
 1328        item = floated(item)
 1329        t_type = realy
 1330      %finish
 1331      %result = control&(intok+realok)
 1332    %finish
 1333    %result = control&(boolok>>(booltype-t_type)) %if t_type <= booltype
 1334    %result = control&enumok %if t_type < direct
 1335    %result = control&arrok
 1336  %end
 1337  !
 1338  %integerfn LISTMATCH(%integer alist,blist)
 1339  %record(identinfo)%name ap,bp
 1340    %result = 1 %if alist = blist
 1341    %result = 0 %if alist < dictmin %or blist < dictmin
 1342    %cycle
 1343      ap == dict(alist);  bp == dict(blist)
 1344      %result = 0 %if ap_type # bp_type;  !for now
 1345      alist = alist+1;  blist = blist+1
 1346    %repeat %until ap_flags&bp_flags&more = 0
 1347    %result = 0 %if ap_flags&more # 0 %or bp_flags&more # 0;  !for now
 1348    %result = 1
 1349  %end
 1350  !
 1351  %routine GET REFERENCE(%integer reftype)
 1352  %integer type,temp
 1353    get EXPRESSION(simple,refonly+any)
 1354    type = ditem_type&puretype;  reftype = reftype&puretype
 1355    %return %if reftype = type
 1356    %if type < reftype %start
 1357      temp = type;  type = reftype;  reftype = temp
 1358    %finish
 1359    %return %if reftype = nulltype;  !untyped %name
 1360    type = dict(type)_type
 1361    %return %if type <= inty %and type = reftype
 1362    %return %if type >= direct %and type = dict(reftype)_type;  !aname
 1363    expfault(typerr+point)
 1364  %end
 1365  !
 1366  %routine GET VALUE(%integer valtype)
 1367  %record(identinfo)%name dp,p
 1368    get EXPRESSION(major,any)
 1369    valtype = valtype&puretype
 1370    dp == dict(valtype)
 1371    %if t_type # dp_type %start;  !base types differ
 1372      %return %if item = 0 = t_val;  !zero
 1373      %if dp_type = realy %and t_type = inty %start
 1374        !float
 1375        t_type = realy
 1376        %return
 1377      %finish
 1378    %else %if t_type >= inty;  !scalar
 1379      %if item = 0 %start
 1380        %return %if dp_low <= t_val <= dp_val
 1381        jammy = jammy!1 %if jammy >= 0
 1382      %finish %else %start
 1383        %if t_low >= dp_low %start
 1384          %return %if t_val <= dp_val
 1385          jammy = jammy!1 %if jammy >= 0
 1386          %return %if t_low <= dp_val
 1387        %finish %else %start
 1388          jammy = jammy!1 %if jammy >= 0
 1389          %return %if t_val >= dp_low
 1390        %finish
 1391      %finish
 1392      expfault(rangerr+point) %if jammy < 2
 1393      %return
 1394    %else %if t_type = stringy
 1395      %if t_val > dp_val %start;  !VALUE = LENGTH*
 1396        jammy = jammy!1 %if jammy >= 0
 1397        expfault(rangerr+point) %if item = 0 %and jammy < 2
 1398      %finish
 1399      %return
 1400    %else %if t_type = recy
 1401      %return %if t_extra = dp_extra
 1402      jammy = jammy!1 %and %return %if jammy >= 2
 1403      !partial assignment?
 1404    %else %if t_type = realy
 1405      %return
 1406    %finish
 1407    expfault(typerr+point)
 1408  %end;
?P unused
 1409       ;  !GET VALUE
 1409  !
 1410  %routine GET LITERAL(%integer littype)
 1411    literal = literal+1
 1412    get VALUE(littype)
 1413    literal = literal-1
 1414  %end
 1415  !
 1416  %routine GET LITINT
 1417    literal = literal+1
 1418    get EXPRESSION(major,intok)
 1419    literal = literal-1
 1420  %end
 1421  !
 1422  %routine GET LITSTRING
 1423  %integer holditem
 1424  !Must be quoted string (for %alias and %include)
 1425    holditem = item;  !preserve
 1426    get(const)
 1427    error(typerr+point) %if t_type # stringy
 1428    item = holditem;  !restore
 1429  %end
 1430  !
 1431  %routine GET PARMLIST
 1432  %record(identinfo)%name hp,dp
 1433  %integer i,j,headitem,headact,dpos,case,procnp,first
 1434    headitem = item;  hp == ditem
 1435    headact = rcall
 1436    !stack procedure ident
 1437  !  procnp = np;  put3(headact,headitem,0)
 1438    i = 0;  first = 1
 1439    dpos = headitem;  dp == hp
 1440    %cycle
 1441    !Set up expression state from formal param details
 1442      error(toomany+point) %if dp_flags&more = 0
 1443      dpos = dpos+1 %and dp == dict(dpos) %until dp_flags&parm # 0
 1444      %if dp_flags&proc # 0 %start
 1445        get(ident)
 1446        name error %if item <= 0
 1447        fault(typerr+point) %if ditem_flags&proc = 0;  !for now
 1448        fault(caterr+point) %if item > headitem
 1449      %else %if dp_type < indirect;  !value
 1450  !      %if pp_type&numericmask # 0 %then case = i&7 %and i = i+1 %c
 1451  !      %else case = i>>3+8 %and i = i+8
 1452        case = i&7;  i = i+1
 1453        get VALUE(dp_type)
 1454      %finish %else %start;  !name or proc
 1455        case = i>>3+8;  i = i+8
 1456        get REFERENCE(dp_type)
 1457      %finish
 1458  !    case = case<<8+headact
 1459  !    item = litref(t_val) %if item = 0
 1460  !    j = np-1
 1461  !    %if first = 0 %start
 1462  !      j = np
 1463  !      !NB Don't re-order parameters for implicits
 1464  !      %if item >= expmin %and headitem > dnewline %start
 1465  !        %while j > procnp %and exp(j-1)_y < expmin %cycle
 1466  !          exp(j)_act = exp(j-1)_act;  exp(j)_y = exp(j-1)_y
 1467  !          j = j-1
 1468  !        %repeat
 1469  !      %finish
 1470  !      exp(np)_x = 0;  np = np+1
 1471  !    %finish
 1472  !    exp(j)_act =  case;  exp(j)_y = item
 1473  !    first = 0
 1474    %repeat %until %not a(comma)
 1475  !  %if hp_type # nulltype %start
 1476  !    i = explo
 1477  !    %while i <= expmax %cycle
 1478  !      %if exp(i)_x = headitem %start;  ![enough?]
 1479  !        item = i;  j = procnp
 1480  !        %cycle
 1481  !          %exit %if exp(i)_y # exp(j)_y
 1482  !          i = i+1;  j = j+1
 1483  !          ->okf %if j >= np
 1484  !        %repeat
 1485  !      %finish
 1486  !      i = i+1
 1487  !    %repeat
 1488  !    %cycle
 1489  !      explo = explo-1;  np = np-1
 1490  !      exp(explo) = exp(np)
 1491  !    %repeat %until np = procnp
 1492      item = explo
 1493  !okf:np = procnp
 1494  !  %finish
 1495  %end;
?PROCNP unused
?J unused
 1496       ;  !get PARMLIST
 1496  
 1497  %routine GET RESOLUTION
 1498    %if %not a(left) %start
 1499      get REFERENCE(anystringvar)
 1500      get(dot)
 1501      get(left)
 1502    %finish
 1503    get VALUE(anystring)
 1504    get(right)
 1505    %if a(dot) %start
 1506      get REFERENCE(anystringvar)
 1507    %finish
 1508  %end
 1509  !
 1510  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1511  !
 1512  %routine GET EXPRESSION(%integer rank,control)
 1513  !Main expression recognition routine
 1514  !To bring together the treatment of all binary operators
 1515  ! and ensure fast recognition of simple expressions,
 1516  ! expressions of different levels are handled by
 1517  ! precedence techniques rather than syntactically
 1518  !CONTROL defines acceptability
 1519  %integer type,f,opok,c1,op,atomp1,item1
 1520  %record(objinfo) t1
 1521  %record(identinfo)%name dp
 1522  
 1523  %integerfn litval
 1524  %switch lit(64:atommax)
 1525    -> lit(op)
 1526  lit(plus):    %result = t1_val+t_val
 1527  lit(minus):   %result = t1_val-t_val
 1528  lit(mult):    %result = t1_val*t_val
 1529  lit(idiv):    %result = t1_val//t_val %if t_val # 0
 1530                fault(rangerr)
 1531                %result = 0
 1532  lit(logand):
 1533  lit(booland): %result = t1_val&t_val
 1534  lit(logor):
 1535  lit(boolor):  %result = t1_val!t_val
 1536  lit(logxor):  %result = t1_val!!t_val
 1537  lit(lshift):  %result = t1_val<<t_val
 1538  lit(rshift):  %result = t1_val>>t_val
 1539  lit(boolnot): %result = t_val!!true
 1540  lit(lognot):  %result = \t_val
 1541  !lit(negate):  %result = -t_val
 1542  lit(equals):  %result = true %if t1_val = t_val
 1543                %result = false
 1544  lit(noteq):   %result = true %if t1_val # t_val
 1545                %result = false
 1546  lit(lesseq):  %result = true %if t1_val <= t_val
 1547                %result = false
 1548  lit(less):    %result = true %if t1_val < t_val
 1549                %result = false
 1550  lit(greateq): %result = true %if t1_val >= t_val
 1551                %result = false
 1552  lit(greater): %result = true %if t1_val > t_val
 1553                %result = false
 1554  lit(concat):  %result = t1_val+t_val
 1555  lit(*):       !report(notwhat,-op)
 1556                %result = 1
 1557  %end
 1558  
 1559  !Get leading operand
 1560    atom = next atom %if matched # 0
 1561    atomp1 = atomp;  !note position for reports
 1562    %if atom = ident %start
 1563      matched = 1
 1564      name error %if item <= 0
 1565      fault(selfref+point) %if item >= dlim0
 1566      type = ditem_type
 1567      %if control&(refonly+varonly) # 0 %start
 1568        error(nonvar+point) %if control&varonly # 0 %and f&var = 0
 1569        error(nonref+point) %if type < direct
 1570      %finish
 1571      f = ditem_flags
 1572      %if inty <= type <= booltype %and f&proc = 0 %start;  !literal
 1573        item = 0;  t = ditem_details
 1574      %else
 1575        fault(nonliteral+point) %if literal > 0
 1576        %if f&proc # 0 %start
 1577          ditem == dict(type) %and type = ditem_type %if f&parm # 0
 1578          error(caterr+point) %if type = nulltype;  !routine
 1579          %if a(left) %start
 1580            dp == ditem
 1581            get PARMLIST;  get(right)
 1582            ditem == dp
 1583          %else
 1584            error(toofew+point) %if ditem_flags&more # 0
 1585            item = explo;!expref(f&var+fcall,item,0)
 1586          %finish
 1587        %finish
 1588        %cycle
 1589          dp == dict(type&puretype);  t = dp_details
 1590          atom = next atom %if matched # 0
 1591          %exit %if atom # underline %and atom # left
 1592          matched = 1
 1593          item1 = item
 1594          %if atom = left %start
 1595            %cycle
 1596              syntax error %if t_type < direct;  !element type
 1597              type = t_type
 1598              get VALUE(t_val);  !index
 1599              item = explo;!expref(aref,item1,item,t_val)
 1600              ditem == dp
 1601              %exit %if %not a(comma)
 1602              dp == dict(type&puretype);  t = dp_details
 1603              item1 = item
 1604            %repeat
 1605            get(right)
 1606          %else;  !rec subfield
 1607            syntax error %if t_type # recy
 1608            get(ident)
 1609            lookup field ident(t_extra)
 1610            error(namerr+point) %if item <= 0
 1611            type = ditem_type
 1612            item = explo;!expref(recref,item,item1)
 1613          %finish
 1614        %repeat
 1615        -> final %if control&(varonly+refonly) # 0
 1616      %finish
 1617    %else
 1618      error(nonvar+point) %if control&varonly # 0
 1619      error(nonref+point) %if control&refonly # 0
 1620      %if a(const) %start
 1621      %else %if atom = minus;  !leave unmatched
 1622        item = 0;  t = 0;  t_type = inty
 1623      %else %if a(left)
 1624        %if rank < major %start;  !condition
 1625          get EXPRESSION(cond,any)
 1626        %finish %else %start
 1627          jammy = jammy-4
 1628          c1 = control;  c1 = c1!intok %if c1&realok # 0
 1629          get EXPRESSION(major,c1)
 1630          jammy = jammy+4
 1631        %finish
 1632        get(right)
 1633      %else %if a(keynot)
 1634        syntax error %if rank >= major
 1635        get EXPRESSION(scond,any)
 1636        %if item = 0 %then t_val = t_val!!true %c
 1637+       %else item = explo;!expref(boolnot,item,0)
 1638      %else %if atom = backslash
 1639        item = 0;  t = 0;  t_type = inty
 1640        atom = tilde
 1641      %else %if a(modsign)
 1642        fault(typerr+point) %if control&arithok = 0
 1643        get EXPRESSION(major,arithok)
 1644        get(modsign)
 1645        %if item = 0 %start
 1646          %if t_val < 0 %start
 1647            %if t_val # minint %then t_val = -t_val %else expfault(rangerr)
 1648          %finish
 1649        %else %if t_type = inty
 1650          item = explo;!expref(imod,item,0)
 1651        %else %if t_type = realy
 1652          item = explo;!expref(fmod,item,0)
 1653        %else
 1654          error(typerr)
 1655        %finish
 1656      %else
 1657        syntax error
 1658      %finish
 1659    %finish
 1660    atom = next atom %if matched # 0
 1661    %while atom >= rank %cycle
 1662      op = atom;  matched = 1
 1663      opok = opbits(op);  c1 = compat(opok);  ![may change ITEM,T_TYPE]
 1664      fault(typerr+point) %if c1 = 0
 1665      item1 = item;  t1 = t
 1666      %if op >= major %start;  !non-conditional
 1667        %if op = dot %then get EXPRESSION(dot,stringok) {right-associate} %c
 1668+       %else get EXPRESSION(op&(\7)+8,c1)
 1669        %if t_type = realy %and t1_type = inty %start
 1670          item1 = floated(item1);  t1_type = realy
 1671        %finish
 1672  !      op = op+? %if t_type = realy %and opok&intok # 0
 1673      %else
 1674         %if op = resolve %start
 1675           get RESOLUTION
 1676        %else %if op >= eqeq
 1677          get EXPRESSION(simple,any+refonly)
 1678        %else %if op >= equals
 1679          get EXPRESSION(major,c1)
 1680          %if equals <= atom < eqeq %start
 1681            op = atom;  matched = 1
 1682            get EXPRESSION(major,c1)
 1683          %finish
 1684          %if t_type = realy %and t1_type = inty %start
 1685            item1 = floated(item1);  t1_type = realy
 1686          %finish
 1687        %else
 1688          get EXPRESSION(scond,any)
 1689          %if atom >= cond %start
 1690            syntax error %if atom # op
 1691          %finish
 1692        %finish
 1693        t_type = booltype
 1694        t_low = 0 %and t_val = 1 %if item # 0
 1695      %finish
 1696      %if item1 = 0 %start;  !first operand literal
 1697        %if item = 0 %start;  !both literal
 1698          t_val = litval
 1699          %continue %if item = 0
 1700  !        item1 = litref(t1_val)
 1701  !     %else %if inverse(op) # 0;  !invertable
 1702  !        op = inverse(op)
 1703  !        temp = t;  t = t1;  t1 = temp;  !standardise order
 1704  !        item1 = item;  item = 0
 1705        %else
 1706  !        item1 = litref(t1_val)
 1707        %finish
 1708      %finish
 1709      %if item = 0 %start;  !second operand literal
 1710        %if op = minus %and t_type = inty %start;  !standardise
 1711          t_val = -t_val %if t_val # minint;  op = plus
 1712        %finish
 1713        item = item1 %and %continue %if t_val = 0 %and opok&znop # 0
 1714      %finish
 1715      item = explo;!expref(op,item1,item,t_val)
 1716      t_low = minint;  t_val = maxint;  !?real
 1717    %repeat
 1718  final:
 1719    expp = atomp1;  !restore to start
 1720    expfault(typerr) %if compat(control) = 0
 1721  %end;  !get EXPRESSION
 1722    
 1723  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1724  !!!!!!!!!!!!!!!!!!!!  Conditions and loops  !!!!!!!!!!!!!!!!!!!!
 1725  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1726  !
 1727  %routine GET CONDITION
 1728  %integer polarity
 1729    polarity = subatom
 1730    condnp = np
 1731    get EXPRESSION(cond,any)
 1732  !  put3(jump+polarity,item,0)
 1733  %end;  !get CONDITION
 1734  
 1735  %routine GET STATEMENTS(%integer stopper)
 1736  %integer holdnp,holdlooplab
 1737  %switch initial(0:atommax)
 1738  
 1739  %routine GET INSTRUCTION
 1740  %integer item1,hold,act
 1741  %record(identinfo)%name ditem1
 1742  %routine putact
 1743  !  put3(act,t_val,hold)
 1744  %end
 1745  !
 1746    %if c_flags < hadinst %start;  !first in block
 1747      c_flags = c_flags+hadinst
 1748      fault(ordererr) %if level <= outerlevel
 1749    %finish
 1750    instnp = np
 1751    %cycle
 1752      %if a(ident) %start
 1753        name error %if item <= 0
 1754        %if ditem_flags&var # 0 %start
 1755          matched = 0
 1756          get EXPRESSION(simple,any)
 1757          item1 = item;  ditem1 == ditem
 1758          %if a(equals) %start
 1759            get VALUE(ditem1_type)
 1760  !          put2(assign,item1)
 1761         %else %if a(eqeq)
 1762            syntax error %if ditem1_type < indirect
 1763            get REFERENCE(ditem1_type)
 1764            item = item+ad %if item # 0
 1765  !          put2(assign,item1+ad)
 1766         %else %if atom = less %and byteinteger(fp) = '-'
 1767            fp = fp+1;  matched = 1
 1768            jammy = 2
 1769            get VALUE(ditem1_type)
 1770  !          put2(jamassign,item1)
 1771          %else
 1772            syntax error %if %not a(arrow)
 1773            get RESOLUTION
 1774  !          put2(resolve,item1)
 1775          %finish
 1776        %else
 1777          error(caterr+point) %if ditem_flags&proc = 0
 1778          ditem == dict(ditem_type) %if ditem_flags&parm # 0
 1779          error(caterr+point) %if ditem_type # nulltype
 1780          %if a(left) %start
 1781            get PARMLIST;  get(right)
 1782          %else;  !parameterless routine
 1783            error(toofew+point) %if ditem_flags&more # 0
 1784  !          put3(rcall,item,0)
 1785          %finish
 1786        %finish
 1787      %finish %else %start
 1788        act = atom;  hold = subatom;  t_val = 0
 1789        c_access = 0
 1790        %if a(monitor) %start
 1791          c_access = 1
 1792  !        fault(monitor<<8)
 1793        %else %if a(exit);  !%exit, %continue
 1794          %if looplab = 0 %then fault(notinloop+point) %c
 1795+         %else t_val = looplab %and putact
 1796          %exit
 1797        %else %if a(return)
 1798          %if c_type # nulltype %then fault(notinrout+point) %c
 1799+         %else putact
 1800          %exit
 1801        %else %if a(result)
 1802          error(notinfun+point) %if c_type <= nulltype
 1803          syntax error %if %not a assop
 1804          %if c_type < direct %start;  !function
 1805            fault(caterr+point) %if atom = eqeq
 1806            get VALUE(c_type)
 1807  !          put2(result,0)
 1808          %else;  !map
 1809            fault(caterr+point) %if atom # eqeq
 1810            get REFERENCE(c_type+(indirect-direct))
 1811  !          put2(result,0)
 1812          %finish
 1813          %exit
 1814        %else %if a(tf);  !%true, %false
 1815          %if c_type # booltype %then fault(notinpred+point) %c
 1816+         %else putact
 1817          %exit
 1818        %else %if a(arrow) %or a(goto)
 1819          nonstandard(kgoto) %if atom = goto
 1820          get(ident)
 1821          %if byteinteger(fp) # '(' %start
 1822            %if item < c_localdpos %or ditem_flags&lab = 0 %c
 1823+           %or ditem_type # nulltype %start
 1824              d_flags = spec+lab;  d_type = nulltype
 1825              declare
 1826            %finish
 1827  !          put3(jump,item,0)
 1828          %finish %else %start
 1829            name error %if item < c_localdpos
 1830            syntax error %if ditem_flags&lab = 0 %or ditem_type = nulltype
 1831            get(left)
 1832            get VALUE(ditem_type);  !index
 1833            get(right)
 1834          %finish
 1835          %exit
 1836        %else %if a(stop)
 1837          putact
 1838          %exit
 1839        %else %if a(signal)
 1840          c_access = 1
 1841          allow(keyevent)
 1842          get LITINT
 1843          expfault(rangerr+point) %unless 0 <= t_val <= 15
 1844          hold = t_val;  t_val = 0
 1845          get LITINT %if a(comma)
 1846          hold = t_val<<4+hold
 1847          item = 0;  t_val = 0
 1848          get VALUE(anyint) %if a(comma)
 1849  !        put2(act,hold)
 1850          %exit
 1851        %else
 1852          syntax error
 1853        %finish
 1854      %finish
 1855    %repeat %until %not a(keyand)
 1856  %end;  !GET INSTRUCTION
 1857  
 1858  %routine GET FOR CLAUSE
 1859  %integer loopvar,k,s,start,sval,i,inc,ival,e,n,temp
 1860  %integer eval
 1861  %record(identinfo)%name dp
 1862    holdnp = np;  temp = 0
 1863    dict(curlab)_val = 1;  !dummy
 1864    condnp = np
 1865    get(ident)
 1866    name error %if item <= 0
 1867    fault(typerr+point) %if dict(ditem_type&puretype)_type # inty
 1868    fault(caterr+point+warn) %if ditem_type # direct+inttype
 1869    loopvar = item;  dp == ditem
 1870    get(equals)
 1871    get VALUE(ditem_type)
 1872    start = item;  sval = t_val
 1873    get(comma)
 1874    get VALUE(anyint)
 1875    inc = item;  ival = t_val
 1876    expfault(rangerr+point) %and ival = 1 %if inc = 0 = ival
 1877    get(comma)
 1878    get VALUE(ditem_type)
 1879  !Deal with INC and replace START by START-INC
 1880  !  k = undef
 1881  !  k = exp(start)_y %if start >= expmin %and exp(start)_act = plus
 1882    %if inc = 0 %start;  !literal increment
 1883      i = 1;  !litref(ival)
 1884      %if start = 0 %start;  !START and INC both literal
 1885        sval = sval-ival;  s = 1;  !litref(sval)
 1886  !   %else %if k <= litmax;  !START is x+lit
 1887  !      k = ival-litval(k)
 1888  !      s = exp(start)_x;  s = explo;!expref(plus,s,litref(k)) %if k # 0
 1889      %else
 1890        s = explo;!expref(plus,start,litref(-ival))
 1891      %finish
 1892    %finish %else %start;  !allocate temp var
 1893  !    i = tempvar;  put3(assign,i,inc);  temp = temp-4
 1894  !    %if start = inc %start;  !identical
 1895  !      s = 0;  sval = 0
 1896  !   %else %if k = inc;  !START is x+INC
 1897  !      s = exp(start)_x
 1898  !    %else
 1899  !      s = start;  s = litref(sval) %if s = 0
 1900        s = explo;!expref(minus,s,i)
 1901  !    %finish
 1902    %finish
 1903  !  %if item = 0 %start;  !literal end-value
 1904  !    e = litref(t_val);  eval = t_val
 1905  !  %finish %else %start
 1906  !    e = tempvar;  put3(assign,e,item);  temp = temp-4
 1907  !  %finish
 1908  !  put3(assign,loopvar,s)
 1909  !  put3(label,curlab,0)
 1910    %if start!inc!item = 0 %start;  !all literal
 1911      k = t_val-sval;  n = k//ival
 1912      fault(boundserr) %if n < 0
 1913      fault(unending) %if n*ival # k
 1914  !    %if 0 <= t_val <= 32767 %start
 1915  !      temp = loopvar
 1916  !    %finish
 1917    %finish
 1918  !  %if temp <= 0 %start
 1919  !    c_fortemps = c_fortemps-temp;  !ie increment
 1920  !    put3(compare,loopvar,e)
 1921  !    put3(eq,0,curlab+1)
 1922  !  %finish
 1923  !  put3(plusass,loopvar,i)
 1924  !  compile(holdnp,np)
 1925  %end;
?EVAL unused
?E unused
 1926       ;  !get FORCLAUSE
 1926  
 1927  %routine GET SWITCH INDEX
 1928  %integer item1
 1929  %record(identinfo)%name dp
 1930    item1 = item;  dp == ditem
 1931    get(left)
 1932    item = 1
 1933    %if a(star) %start
 1934      fault(duperr+point) %if dp_spare # 0
 1935      dp_spare = 1
 1936    %else
 1937      get LITERAL(dp_type)
 1938     !beware faulty declaration or index
 1939      %if dp_type > inttype %and faultnum = 0 %start
 1940        t_val = t_val-dict(dp_type)_low+dp_val
 1941        expfault(duperr+point) %if final(t_val) # 0
 1942  !      define jumps(final(t_val));  !in case of lit jumps
 1943        final(t_val) = 1
 1944      %finish
 1945    %finish
 1946    get(right)
 1947    c_access = 1
 1948  %end
 1949  
 1950  ![unsure of efficiency implications of trapping overflow lower down]
 1951  %on %event 1,14 %start
 1952  !$IF VAX
 1953    report(rangerr,0) %if event_event = 1
 1954  !$IF AMDAHL
 1955  {  report(rangerr,0) %if eventinf>>8 = 1
 1956  !$FINISH
 1957    -> skip
 1958  %finish
 1959  !!!!!!!!!!!!!!!!!!!  Start of new statement  !!!!!!!!!!!!!!!!!!!
 1960  next:
 1961    statements = statements+1
 1962  next1:
 1963    report(faultnum,faultp) %if faultnum # 0
 1964    d = 0;  declmode = 0;  dsize = 0
 1965    dlim0 = dlim;  elements = 0
 1966    speccing = 0;  mcoding = 0
 1967    literal = 0;  jammy = 0
 1968    dict(curlab)_val = 0;  dict(curlab+1)_val = 0
 1969    np = np0;  instnp = np0;  condnp = np0
 1970  !  constad == finalad;  constbound = purebound
 1971    %if explo < expmin+50 %or litpos > litmax-50 %start
 1972      !zaps = zaps+1;  zaps = zaps+999 %if litpos > litmax-50
 1973      forget all
 1974    %finish
 1975    t_val = 0
 1976  !
 1977  initial(terminator):
 1978    atom = next atom;  matched = 1
 1979    -> initial(atom)
 1980  initial(star): initial(exclam): initial(exclam2):
 1981    read line
 1982    -> next1
 1983  term:
 1984    get(terminator)
 1985    -> next
 1986  
 1987  skip:
 1988    c_access = -1
 1989    %if atom # terminator %start
 1990      %cycle
 1991        subatom = atom;  atom = next atom
 1992      %repeat %until atom = terminator
 1993      starts = starts+1 %if subatom = start
 1994      cycles = cycles+1 %if subatom = cycle
 1995    %finish
 1996    -> next
 1997  
 1998  initial(dud):
 1999    syntax error;  !ie atom error
 2000  
 2001  initial(*):
 2002    error(nonstarter+point)
 2003  
 2004  initial(ident):
 2005    %if byteinteger(fp) = ':' %start;  !simple label
 2006      fp = fp+1
 2007      d_flags = lab;  d_type = nulltype
 2008      declare
 2009      set user label(item)
 2010      ->next
 2011    %finish
 2012    name error %if item <= 0
 2013    %if ditem_flags&lab # 0 %start
 2014      get SWITCH INDEX
 2015      get(colon)
 2016      ->next
 2017    %finish
 2018  initial(return): initial(result): initial(tf):
 2019  initial(stop): initial(signal): initial(monitor):
 2020  initial(exit): initial(goto): initial(arrow):
 2021    matched = 0
 2022    get INSTRUCTION
 2023    -> next %if a(terminator)
 2024    c_access = 1
 2025    %if a(iu) %start
 2026      holdnp = np
 2027      get CONDITION
 2028  !    compile(holdnp,np)
 2029    %else %if a(while)
 2030      holdnp = np
 2031  !    put3(label,curlab,0)
 2032      get CONDITION
 2033  !    compile(holdnp,np)
 2034  !    put3(jump,curlab,0)
 2035  !    put3(label,curlab+1,0)
 2036    %else %if a(for)
 2037      get FOR CLAUSE
 2038  !    put3(jump,curlab,0)
 2039  !    put3(label,curlab+1,0)
 2040    %else
 2041      syntax error %if %not a(until)
 2042      get CONDITION
 2043    %finish
 2044    -> term
 2045  
 2046  initial(iu):  !%if, %unless
 2047    %cycle
 2048      holdnp = np
 2049      get CONDITION
 2050  !    compile(holdnp,np)
 2051      %if a(then) %start
 2052        -> fudge %if a(start)
 2053        get INSTRUCTION
 2054      %finish %else %start
 2055        get(start)
 2056  fudge:
 2057        %cycle
 2058          get(terminator)
 2059          curlab = curlab+2
 2060          get STATEMENTS(else)
 2061          curlab = curlab-2
 2062          %exit %if atom # else;  !%finish ->
 2063          get CONDITION %if a(iu)
 2064        %repeat
 2065        %return %if atom # finish
 2066      %finish
 2067      %exit %if %not a(else)
 2068      -> fudge %if a(start)
 2069      get INSTRUCTION %and %exit %if %not a(iu)
 2070    %repeat
 2071    -> term
 2072  
 2073  initial(cycle):
 2074    %if a(terminator) %start
 2075      holdlooplab = looplab;  looplab = curlab
 2076      curlab = curlab+2
 2077      get STATEMENTS(repeat)
 2078      curlab = curlab-2;  looplab = holdlooplab
 2079      %return %if atom # repeat
 2080      get CONDITION %if a(until)
 2081      -> term
 2082    %finish
 2083    nonstandard(oldcycle)
 2084    get FOR CLAUSE
 2085    -> for1
 2086  initial(while):
 2087    holdnp = np
 2088  !  put3(label,curlab,0)
 2089    get CONDITION
 2090  !  compile(holdnp,np)
 2091    get(cycle)
 2092    get(terminator)
 2093    holdlooplab = looplab;  looplab = curlab
 2094    curlab = curlab+2
 2095    get STATEMENTS(repeat)
 2096    curlab = curlab-2;  looplab = holdlooplab
 2097    %return %if atom # repeat
 2098    nonstandard(loop2) %and get CONDITION %if a(until)
 2099  !  put3(jump,curlab,0)
 2100  !  put3(label,curlab+1,0)
 2101    ->term
 2102  initial(for):
 2103    get FOR CLAUSE
 2104    get(cycle)
 2105  for1:
 2106    get(terminator)
 2107    holdlooplab = looplab;  looplab = curlab
 2108    curlab = curlab+2
 2109    get STATEMENTS(repeat)
 2110    curlab = curlab-2;  looplab = holdlooplab
 2111    %return %if atom # repeat
 2112  !  put3(repeat,0,0)
 2113    -> term
 2114  
 2115  initial(on):
 2116    fault(ordererr+point) %if c_flags >= hadon %or level <= outerlevel
 2117    c_flags = c_flags!hadon
 2118    matched = 1
 2119    allow(keyevent)
 2120    %cycle
 2121      get LITINT
 2122      expfault(rangerr+point) %unless 0 <= t_val <= 15
 2123      c_events = c_events!1<<t_val
 2124    %repeat %until %not a(comma)
 2125    get(start)
 2126  !  put3(on,0,0)
 2127    curlab = curlab+2
 2128    get STATEMENTS(finish)
 2129    curlab = curlab-2
 2130    %return %if atom # finish
 2131    -> term
 2132  !
 2133  initial(else):
 2134    -> skip %if starts # 0
 2135    %return %if stopper = else
 2136    error(noif) %if stopper = finish
 2137  initial(finish):
 2138    starts = starts-1 %and -> skip %if starts # 0
 2139    %return %if stopper = finish %or stopper = else
 2140    error(nostart)
 2141  initial(repeat):
 2142    cycles = cycles-1 %and -> skip %if cycles # 0
 2143    %return %if stopper = repeat
 2144    error(nocycle)
 2145  
 2146  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 2147  !!!!!!!!!!!!!!!!!!!!  Declarations  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 2148  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 2149  !
 2150  %integerfn NEWATYPE(%integer eltype,xtype)
 2151  %integer dpos
 2152  %record(identinfo)%name dp
 2153  %ownrecord(identinfo) d=0
 2154    dpos = dictmin
 2155    %cycle
 2156      dp == dict(dpos)
 2157      %result = dpos+direct %if dp_flags&typeid # 0 %c
 2158+                    %and dp_type = eltype %and dp_val = xtype
 2159      dpos = dpos+1
 2160    %repeat %until dpos = dlim
 2161    d_flags = typeid;  d_type = eltype;  d_val = xtype
 2162    dict(dpos) = d
 2163    dlim = dlim+1;  croak("Too many identifers") %if dlim >= dmin
 2164    %result = dpos+direct
 2165  %end
 2166  !
 2167  %integerfn NEWSTYPE(%integer max)
 2168  %integer dpos
 2169  %record(identinfo)%name dp
 2170  %ownrecord(identinfo) d=0
 2171    dpos = dictmin
 2172    %cycle
 2173      dp == dict(dpos)
 2174      %result = dpos %if dp_type = stringy %and dp_val = max
 2175      dpos = dpos+1
 2176    %repeat %until dpos = dlim
 2177    d_flags = typeid;  d_type = stringy
 2178    d_val = max
 2179    dict(dpos) = d
 2180    dlim = dlim+1;  croak("Too many identifers") %if dlim >= dmin
 2181    %result = dpos
 2182  %end
 2183  !
 2184  %integerfn NEWRANGE(%integer type,lower,upper)
 2185  %integer dpos
 2186  %record(identinfo)%name dp
 2187  %ownrecord(identinfo) d=0
 2188    fault(boundserr) %and upper = lower %if lower > upper
 2189    elements = maxint
 2190    elements = upper-lower %if upper!!lower >= 0 %c
 2191+     %or minint+upper-lower < 0
 2192    elements = elements+1 %if elements # maxint
 2193    dpos = dictmin
 2194    %cycle
 2195      dp == dict(dpos)
 2196      %result = dpos %if dp_flags = typeid %and dp_type = type %c
 2197+                    %and dp_low = lower %and dp_val = upper
 2198      dpos = dpos+1
 2199    %repeat %until dpos = dlim
 2200    d_flags = typeid;  d_type = type
 2201    d_low = lower;  d_val = upper
 2202    dict(dpos) = d
 2203    dlim = dlim+1;  croak("Too many identifers") %if dlim >= dmin
 2204    %result = dpos
 2205  %end
 2206  
 2207  %routine GET LITBOUNDS
 2208  %integer lower
 2209    get(left)
 2210    get LITINT;  lower = t_val
 2211    get(colon)
 2212    get LITINT;
 2213    get(right)
 2214    t_low = lower
 2215    item = newrange(inty,t_low,t_val);  !always integer at present
 2216  %end
 2217  
 2218  %routine GET IDENT
 2219    dlim0 = dlim
 2220    get(ident)
 2221    declare
 2222    get LITSTRING %if d_flags&ext # 0 %and a(alias)
 2223  %end
 2224  
 2225  %routine GET IDENTLIST
 2226    dlim0 = dlim
 2227    %cycle
 2228      get(ident)
 2229      declare
 2230      get LITSTRING %if d_flags&ext # 0 %and a(alias)
 2231     %repeat %until %not a(comma)
 2232  %end
 2233  
 2234  %routine GET TYPE(%integer flags)
 2235  %owninteger fbase
 2236  %ownrecord(identinfo)%name formp,fieldp
 2237  !
 2238  %routine GET FORMATDEF;  !(%integername base)
 2239  %integer disp,max,base
 2240  %routine GET FIELD IDENT
 2241    get(ident)
 2242    %if item > 0 %then d_text = ditem_text %c
 2243+   %else %start
 2244      d_text = charlim-charbase;  charlim = charlim+newlen+1
 2245      croak("Identifier space exhausted") %if charlim+80 >= charmin
 2246    %finish
 2247    ditem == dict(dlim);  fieldp == ditem
 2248    ditem = d
 2249    %if formp_extra = 0 %then formp_extra = dlim %c
 2250+   %else %start
 2251  !    lookup field ident(formp_extra)
 2252  !    fault(duperr+point) %and item = dlim %if item # dlim
 2253    %finish
 2254    dlim = dlim+1;  croak("Too many identifiers") %if dlim >= dmin
 2255  %end
 2256  %routine get UNIT
 2257    %cycle
 2258      %if a(left) %start
 2259        get FORMATDEF;  get(right)
 2260        %return %if %not a(comma)
 2261      %else
 2262        get TYPE(static+more)
 2263        %if d_flags&parm = 0 %start;  !not array
 2264          %cycle
 2265            disp = disp+1 %if disp&1 # 0 %and dsize # 1
 2266            d_val = disp
 2267            disp = disp+dsize
 2268            get FIELD IDENT
 2269            %return %if %not a(comma)
 2270            atom = next atom
 2271          %repeat %until atom # ident
 2272        %else;  !array
 2273          d_flags = d_flags-parm
 2274          disp = disp+1 %if disp&1 # 0;  d_val = disp
 2275          get FIELD IDENT
 2276          get LITBOUNDS
 2277          fieldp_type = newatype(d_type,item)
 2278          disp = disp+dsize*elements
 2279          %return %if %not a(comma)
 2280        %finish
 2281      %finish
 2282    %repeat
 2283  %end
 2284    max = 0;  base = 0
 2285    %cycle
 2286      disp = base
 2287      get UNIT
 2288      max = disp %if max < disp
 2289    %repeat %until %not a(keyor)
 2290    base = max
 2291  %end;  !get FORMATDEF
 2292  
 2293    dsize = 0;  d_mode = 0;  d_val = 0
 2294    d_type = nulltype
 2295    %if a(rpred) %start;  !%routine,(%integerfn)
 2296      flags = flags&(\static) %if flags&ext # 0
 2297      syntax error %if flags&static # 0
 2298      nonstandard(pred) %and d_type = booltype %if subatom # 0
 2299      d_flags = flags+proc;  declmode = declmode+pcmode
 2300      %return
 2301    %finish
 2302    %if a(krange) %start;                 !%byte,%short,%half,%mite
 2303      d_type = inttype+subatom;  dsize = 1
 2304      dsize = 2 %if d_type = shorttype %or d_type = halftype
 2305      nonstandard(ranges) %if d_type >= mitetype
 2306      allow(keyinteger)
 2307    %else %if a(keyinteger);                    !%integer
 2308      d_type = inttype;  dsize = 4
 2309      atom = next atom
 2310      %if atom = left %start
 2311        get LITBOUNDS
 2312        d_type = item
 2313        dsize = 2 %if elements <= 65536 %and t_low >= -32768
 2314        dsize = 1 %if elements <= 256 %and t_low >= -128
 2315      %finish
 2316    %else %if a(keylong);                   !%long
 2317      d_type = longinttype;  dsize = 8
 2318      d_type = longrealtype %and get(keyreal) %if %not a(keyinteger)
 2319    %else %if a(keyreal);                   !%real
 2320      d_type = realtype;  dsize = 4
 2321    %else %if a(keystring);                 !%string
 2322      d_type = stringy
 2323      t_val = 255;  dsize = 256
 2324      %if a(left) %start
 2325        t_val = 0
 2326        %if %not a(star) %start
 2327          get LITINT
 2328          expfault(rangerr+point) %and t_val = 255 %unless 0 < t_val <= 255
 2329        %finish
 2330        get(right)
 2331      %finish %else nonstandard(nolength)
 2332      %if t_val # 0 %start
 2333        d_type = newstype(t_val)
 2334        dsize = (t_val+2)&(\1);  !+1 & evened up
 2335      %finish
 2336    %else %if a(keyrecord);                    !%record
 2337      d_type = recy
 2338      %if a(keyformat) %start
 2339        syntax error %if flags&(static+ext) # 0
 2340        %if a(keyspec) %start
 2341          d_flags = typeid+spec
 2342          get IDENT
 2343        %finish %else %start
 2344          d_flags = typeid
 2345          get IDENT
 2346          formp == ditem
 2347          get(left)
 2348          fbase = 0
 2349          get FORMATDEF
 2350          fieldp_flags = fieldp_flags-more
 2351          get(right)
 2352        %finish
 2353        d_flags = typeid
 2354        %return
 2355      %finish
 2356      get(left)
 2357      %if %not a(star) %start
 2358        %if %not a(ident) %start
 2359          get FORMATDEF
 2360          fieldp_flags = fieldp_flags-more
 2361          get(right)
 2362          d_flags = typeid
 2363          declare anon
 2364        %finish
 2365        name error %if item <= 0
 2366        syntax error %if ditem_type # recy
 2367        d_type = item;  dsize = ditem_val
 2368      %finish
 2369      get(right)
 2370    %else
 2371      syntax error %if atom # keyname;            !untyped %name
 2372    %finish
 2373    !End of basic type info: set item size in DECLMODE
 2374    %if dsize <= 4 %start
 2375      %if dsize <= 2 %then declmode = dsize<<sizeshift %c
 2376+     %else declmode = longsize<<sizeshift
 2377    %finish
 2378    !Appendages
 2379    %if a(fnmap) %start;  !%fn, %map
 2380      flags = flags&(\static) %if flags&ext # 0
 2381      syntax error %if flags&static # 0
 2382      flags = flags+var %and d_type = d_type+direct %if subatom # 0;  !map
 2383      d_flags = flags+proc;  declmode = declmode+pcmode
 2384      %return
 2385    %finish
 2386    d_type = d_type+direct
 2387    %while a(keyarray) %or a(keyname) %cycle
 2388      %if atom = keyarray %start;                  !%array
 2389        nonstandard(naming) %if d_type >= indirect
 2390        %if %not a(keyname) %start
 2391          syntax error %if flags&parm # 0
 2392          flags = flags+parm;  !as indic
 2393          %exit
 2394        %finish
 2395        d_type = newatype(d_type,inty)
 2396      %finish
 2397      syntax error %if d_type >= indirect
 2398      d_type = d_type+(indirect-direct)
 2399      dsize = 4
 2400    %repeat
 2401    d_flags = flags!!var
 2402  %end;  !GET TYPE
 2403  !
 2404  %routine GET OWN ARRAY DECLARATION
 2405  %integer holdval,dpos
 2406  %record(identinfo)%name dp
 2407  !  constad = constad+1 %if constad&1 # 0
 2408  !  d_val = constad
 2409  !  d_val = d_val-ownbase %if d_val >= ownbase
 2410    get IDENT
 2411    dpos = item;  dp == ditem
 2412    get LITBOUNDS
 2413    dp_type = newatype(d_type,item)
 2414    %if a assop %start
 2415      allow(terminator)
 2416      %cycle
 2417        get LITERAL(d_type)
 2418        faultnum = rangerr+point+warn %if faultnum = rangerr+point
 2419        holdval = t_val
 2420        t_val = 1
 2421        %if a(left) %start
 2422          t_val = elements
 2423          get LITINT %if %not a(star)
 2424          get(right)
 2425        %finish
 2426  !      plant const(holdval,t_val)
 2427        elements = elements-t_val
 2428      %repeat %until %not a(comma)
 2429      report(counterr,dpos) %if elements # 0 %and faultnum = 0
 2430    %finish
 2431  !  plant const(0,elements) %if elements > 0
 2432  %end;  !get OWN ADECL
 2433  
 2434  %routine GET ARRAY DECLARATION
 2435  !ie get IDENTLISTS and BOUNDS
 2436  %integer i,dlim1,hold,holdval,type
 2437  
 2438  !%routine put bound pair
 2439  !  hold = litref(holdval) %if hold = 0
 2440  !  item = litref(t_val) %if item = 0
 2441  !  put3(r,hold,item);  !(range),lower,upper
 2442  !%end
 2443  
 2444  %routine GET BOUNDS
 2445  %integer range
 2446    get VALUE(anyint)
 2447    hold = item;  t_val = minint %if hold # 0
 2448    holdval = t_val
 2449    get(colon)
 2450    get VALUE(anyint)
 2451    t_val = maxint %if item # 0
 2452    range = newrange(inty,holdval,t_val)
 2453    GET BOUNDS %if a(comma)
 2454    type = newatype(type,range)
 2455  %end
 2456  
 2457  %cycle
 2458    type = d_type
 2459    get IDENTLIST
 2460    dlim1 = dlim
 2461    get(left)
 2462    GET BOUNDS
 2463    get(right)
 2464  !  %if hold = 0 = item {both literal} %and np = np0 {1-dim} %c
 2465  !  %and elements <= 32767 {safe to multiply?} %c
 2466  !  %and (elements*dsize*(dlim-dpos))<<1-c_sp-c_delta <= 32000 %start
 2467  !     d_par = parref(inty,0,r,0)
 2468  !  %finish %else %start
 2469  !    put bound pair
 2470  !     d_par = 0
 2471  !    i = np
 2472  !    %while i # np0 %cycle
 2473  !      i = i-1
 2474  !       d_par = parref(inty,0,exp(i)_act,d_par)
 2475  !    %repeat
 2476  !    exp(np0)_act = adecl
 2477  !  %finish
 2478  !  i = np
 2479    %while dlim0 # dlim1 %cycle
 2480  !    %if i = np0 %start
 2481  !      c_delta = c_delta-elements*dsize
 2482  !      c_delta = c_delta-1 %if c_delta&1 # 0
 2483  !      dict(dlim0)_flags = dict(dlim0)_flags!static
 2484  !    %finish %else %start
 2485  !      np = i;  compile(np0,np0)
 2486  !      c_flags = c_flags!dynarray
 2487  !    %finish
 2488  !    dict(dlim0)_val = c_sp+c_delta
 2489      dict(dlim0)_type = type
 2490      dlim0 = dlim0+1
 2491    %repeat
 2492  %repeat %until %not a(comma)
 2493  %end;
?I unused
 2494       ;  !get BOUNDS
 2494  
 2495  %routine GET PARMDEF
 2496  %integer headitem,dpos,dlim1
 2497  %record(identinfo)%name headditem,dp
 2498  %integerfn PARMMATCH(%integer apos)
 2499  %integer bpos
 2500  %record(identinfo)%name ap,bp
 2501    bpos = dlim1
 2502    ap == dict(apos)
 2503    %while bpos # dlim %cycle
 2504      %result = 0 %if ap_flags&more = 0
 2505      apos = apos+1 %and ap == dict(apos) %until ap_flags&parm # 0
 2506      bp == dict(bpos)
 2507      %result = 0 %if ap_type # bp_type;  !for now
 2508      bpos = bpos+1
 2509    %repeat
 2510    %result = 1 %if ap_flags&more = 0
 2511    %result = 0
 2512  %end
 2513  !
 2514    headitem = item;  headditem == ditem
 2515    dlim1 = dlim
 2516    %if a(left) %start
 2517      %cycle
 2518        get TYPE(parm!more) %if atom # ident
 2519        %if d_flags&proc = 0 %start
 2520          get IDENT
 2521          %exit %if %not a(comma) %and atom = right
 2522          %if atom # comma %then nonstandard(nocomma) %c
 2523+         %else atom = next atom
 2524        %finish %else %start
 2525          get IDENT
 2526          speccing = speccing+2
 2527          get PARMDEF
 2528          speccing = speccing-2
 2529          %exit %if %not a(comma)
 2530        %finish
 2531      %repeat
 2532      dict(dlim-1)_flags = dict(dlim-1)_flags-more
 2533      get(right)
 2534    %finish
 2535    %if speccing >= 2 %start
 2536      dpos = dictmin
 2537      %cycle
 2538        dp == dict(dpos)
 2539        %if dp_flags&proc # 0 %and dp_type = headditem_type %start
 2540          %if parmmatch(dpos) # 0 %start
 2541            headditem_type = dpos;  dlim = dlim1
 2542            %return
 2543          %finish
 2544        %finish
 2545        dpos = dpos+1
 2546      %repeat %until dpos >= headitem
 2547      fault(caterr);  dlim = dlim1
 2548      %return
 2549    %finish
 2550    %if speccing = 0 %and headditem_flags&spec # 0 %start
 2551      headditem_flags = headditem_flags-spec
 2552      fault(matcherr) %if parmmatch(headitem) = 0
 2553    %else
 2554      headditem_flags = headditem_flags!more %if dlim # dlim1
 2555    %finish
 2556  %end;  !get PARMDEF
 2557  
 2558  initial(keylabel):  nonstandard(klabel)
 2559    d_flags = lab+spec;  d_type = nulltype
 2560    get IDENTLIST
 2561    -> term
 2562  
 2563  initial(prefix):
 2564    d_flags = subatom;  ! !wflag!okflag
 2565  !  fault(prefix<<8) %if d_flags&extmask # 0
 2566    atom = next atom
 2567  initial(krange): initial(keylong):
 2568  initial(keyinteger): initial(keyreal):
 2569  initial(keystring):  initial(keyrecord):
 2570  initial(rpred):
 2571    matched = 0
 2572    get TYPE(d_flags)
 2573    %if a(keyspec) %start
 2574      %if a(left) %start
 2575        get LITINT;  get(right)
 2576        declmode = declmode&sizemask+absmode
 2577        d_val = t_val
 2578        get IDENT
 2579        speccing = 1 %and get PARMDEF %if d_flags&proc # 0
 2580        -> term
 2581      %finish
 2582      d_flags = d_flags+spec
 2583      get IDENTLIST %and -> term %if d_flags&proc = 0
 2584    %finish
 2585    %if d_flags&proc # 0 %start
 2586      get(ident)
 2587      %if item >= c_localdpos %and ditem_type = d_type %c
 2588+     %and ditem_flags&proc # 0 %start
 2589        %if ditem_flags&spec = 0 %or d_flags&spec # 0 %start
 2590          item = 0;  d_flags = d_flags+alt
 2591          declare
 2592        %finish
 2593      %finish %else declare
 2594      get LITSTRING %if d_flags&ext # 0 %and a(alias)
 2595      %if d_flags&spec # 0 %start
 2596        speccing = 1
 2597        get PARMDEF
 2598      %finish %else %start
 2599        open block(item)
 2600        get PARMDEF
 2601        c_parlim = dlim
 2602        compile entry
 2603        get(terminator)
 2604        get STATEMENTS(end)
 2605  !      %if c_access > 0 %start
 2606  !        report(noresult,0) %if c_type > nulltype;  !fn/map/pred
 2607  !      %finish
 2608        close block
 2609      %finish
 2610    %else %if d_flags = typeid {dealt with}
 2611    %else %if d_flags&parm # 0;  !array
 2612      d_flags = d_flags-parm
 2613      %if d_flags&static # 0 %start
 2614        get OWN ARRAY DECLARATION
 2615      %finish %else %start
 2616        %if d_flags&static = 0 %and c_flags >= hadon %start
 2617          fault(ordererr);  c_flags = c_flags&(\(hadon+hadinst))
 2618        %finish
 2619        get ARRAY DECLARATION
 2620      %finish
 2621    %else %if d_flags = static {const}
 2622      d_type = dict(d_type&puretype)_type
 2623      d_type = d_type+direct %if d_type = recy %or d_type = stringy
 2624      %cycle
 2625        get IDENT
 2626        syntax error %if %not a assop
 2627        get LITERAL(d_type)
 2628        faultnum = rangerr+point+warn %if faultnum = rangerr+point
 2629        dict(dlim-1)_val = t_val
 2630      %repeat %until %not a(comma)
 2631    %else %if d_flags&static # 0 {own}
 2632  !    constad == ownad;  constbound = finalbound
 2633      declmode = declmode+ownmode
 2634      %cycle
 2635  !      constad = constad+1 %if constad&1 # 0 %and dsize # 1
 2636  !      t_val = constad-ownbase
 2637        get IDENT
 2638        t_val = 0
 2639        %if a assop %start
 2640  !        %if d_flags&direct = 0
 2641          get LITERAL(d_type)
 2642          faultnum = rangerr+point+warn %if faultnum = rangerr+point
 2643        %finish
 2644        elements = 1
 2645      !      plant const(t_val,1)
 2646      %repeat %until %not a(comma)
 2647    %else;      !dynamic variable
 2648  !    declmode = declmode+dispmode+level
 2649      %if d_flags&static = 0 %and c_flags >= hadon %start
 2650        fault(ordererr);  c_flags = c_flags&(\(hadon+hadinst))
 2651      %finish
 2652      %cycle
 2653  !problematic c_delta = c_delta-1 %if c_delta&1 # 0 %and dsize # 1
 2654        c_delta = c_delta-dsize
 2655        c_delta = c_delta-1 %if c_delta&1 # 0
 2656        t_val = c_sp+c_delta
 2657        get IDENT
 2658        %if a assop %start
 2659          nonstandard(initass)
 2660          %if d_type >= indirect %start
 2661            fault(caterr+point) %if atom # eqeq
 2662            get REFERENCE(d_type)
 2663            item = item+ad %if item # 0
 2664  !          put3(assign,dlim-1+ad,item)
 2665          %finish %else %start
 2666            fault(caterr+point) %if atom = eqeq
 2667            get VALUE(d_type)
 2668  !          put2(assign,dlim-1)
 2669          %finish
 2670  !        compile(np0,np0)
 2671        %finish
 2672      %repeat %until %not a(comma)
 2673    %finish
 2674    -> term
 2675  
 2676  %routine GET SWITCH DECLARATION
 2677  %integer i,j,dlim1
 2678    matched = 1
 2679    %cycle
 2680      d_flags = lab;  d_type = nulltype
 2681      declmode = pcmode+wordsize<<sizeshift
 2682      get IDENTLIST
 2683      dlim1 = dlim
 2684      get LITBOUNDS
 2685      %cycle;  !For each ident in group
 2686        %exit %if spc-elements <= 0;  !ignore if too many
 2687        %for i = 1,1,elements %cycle
 2688          spc = spc-1;  final(spc) = 0
 2689        %repeat
 2690        dict(dlim0)_val = spc
 2691        dict(dlim0)_type = item
 2692        dlim0 = dlim0+1
 2693      %repeat %until dlim0 = dlim1
 2694    %repeat %until %not a(comma)
 2695  %end
?J unused
 2696  initial(keyswitch):
 2697    get SWITCH DECLARATION
 2698    ->term
 2699  
 2700  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 2701  !!!!!!!!!!!!!!!  Control statements  !!!!!!!!!!!!!!!!!!!!!!!!!!!
 2702  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 2703  !
 2704  initial(keycontrol):
 2705    get LITINT
 2706    control = 0 %if t_val = 0
 2707    control = control!!t_val
 2708    ->term
 2709  
 2710  initial(include):
 2711    get LITSTRING
 2712    extra_name = ""
 2713    %while t_val > 0 %cycle
 2714      extra_name = extra_name.tostring(byteinteger(atomp))
 2715      atomp = atomp+1;  t_val = t_val-1
 2716    %repeat
 2717    get(terminator)
 2718    %if faultnum = 0 %start
 2719      connect edfile(extra)
 2720      nonstop = -999 %and %signal 12 %if extra_flag # 0
 2721      mainfp = fp;  mainline = line
 2722      line = 0;  sym = nl
 2723      fp = extra_start2;  curstart = fp;  curlim = extra_lim2
 2724      modesym = '&';  nonstop = nonstop+1
 2725    %finish
 2726    ->next
 2727  
 2728  initial(keylist):
 2729    ->term
 2730  
 2731  initial(begin):
 2732    c_sp = -8
 2733    get(terminator)
 2734    open block(0)
 2735    get STATEMENTS(0)
 2736    close block
 2737    -> term %if stopper >= 0
 2738    %return
 2739  
 2740  initial(end):
 2741    %if %not a(of) %start
 2742      fault(nofinish) %if stopper = else %or stopper = finish
 2743      fault(norepeat) %if stopper = repeat
 2744      %return %if stopper >= 0
 2745      fault(nobegin)
 2746      ->term
 2747    %finish
 2748    %if a(keylist) %start
 2749      ->term
 2750    %finish
 2751    %if a(keyfile) %start
 2752      %if curlim = extra_lim2 %start
 2753        switch input
 2754        ->next
 2755      %finish
 2756    %finish %else get(program)
 2757  %end;  !GET STATEMENTS
 2758  
 2759  %routine INIT(%integer t,l,h)
 2760    d_flags = typeid;  d_type = t;  d_low = l;  d_val = h
 2761    dict(dlim) = d;  dlim = dlim+1
 2762  %end
 2763  
 2764  %on %event 12 %start
 2765    -> printout %if fp = main_lim2
 2766    -> ended %if main_flag < 0 %or nonstop = -999;  !abandon or CROAK
 2767    change = main_change
 2768  %finish
 2769  
 2770    printstring("  IMP Checker  ");  newline
 2771    hashindex(i) = 0 %for i = 0,1,255;  !hash table empty
 2772    charbase = addr(char(0));  byteinteger(charbase) = 0;  !for anon ident
 2773    charlim = charbase+1
 2774    charmin = charlim+charbound;  !(1 over top)
 2775    dict(i)_val = 0 %for i = d0,1,labmax
 2776    d_flags = typeid;  d_low = minint;  d_val = maxint
 2777    dmin = dictmax-1;  dlim = dictmin
 2778    %cycle
 2779      d_type = dlim;  dict(dlim) = d
 2780      dlim = dlim+1
 2781    %repeat %until dlim > booltype
 2782    d_flags = 0
 2783    init(booltype,0,0)
 2784    init(booltype,0,1)
 2785    d_flags = typeid
 2786    init(inty,minint,maxint)
 2787    init(inty,-32768,32767)
 2788    init(inty,0,65535)
 2789    init(inty,0,255)
 2790    init(inty,-128,127)
 2791    init(inty,0,1)
 2792    init(inty,minint,maxint)
 2793    init(realy,minint,maxint)
 2794    init(realy,minint,maxint)
 2795    c = 0;  c_localdpos = dlim;  c_parlim = dlim
 2796    level = outerlevel
 2797    spc = finalbound
 2798    faults = 0;  line = 0;  mainline = 0
 2799  !
 2800    mainfp = main_start1
 2801    extra_name = permfile
 2802    connect edfile(extra)
 2803    nonstop = -999 %and %signal 12 %if extra_flag # 0
 2804    fp = extra_start2;  curstart = fp;  curlim = extra_lim2
 2805    nonstop = -2;  nonstop = -1 %if main_flag = 'I'
 2806    sym = nl
 2807    get STATEMENTS(-1)
 2808  !  report(noend,0) %if level < mainlevel
 2809  !  report(nobegin,0) %if level > mainlevel
 2810  !  compile end %while level >= mainlevel
 2811  printout:
 2812  !  time2 = cputime
 2813    %if faults = 0 %start
 2814      write(statements,1)
 2815      print string(" statements checked  ")
 2816    %finish %else %start
 2817      write(faults,1)
 2818      print string(" fault")
 2819      put sym('s') %if faults > 1
 2820      print string(" reported  ")
 2821    %finish
 2822    newline
 2823  ended:
 2824    newline;  !*for now to ensure message not erased*
 2825  !  %if control&logbit # 0 %start
 2826  !!    write(zaps,1);  print symbol('Z')
 2827  !    write(statements,1);  print symbol('S')
 2828  !    statements = 1 %if statements = 0
 2829  !    atoms = atoms+statements
 2830  !    print(atoms/statements,1,1);  print symbol('A')
 2831  !    print(numatoms/statements,1,1);  print symbol('N')
 2832  !    print(identatoms/statements,1,1);  print symbol('I')
 2833  !    print(misses/identatoms,1,2);  print symbol('H')
 2834  !    print((time2-time1)/statements,3,3);  print symbol('M')
 2835  !!    write(finalad,1);  print symbol('B')
 2836  !!    write(ownad-ownbase,1);  print symbol('O')
 2837  !    newline
 2838  !  %finish
 2839  
 2840  %end;
?LISTMATCH unused
?LEFTBRACKET unused
?TEMPVAR unused
?PUT2 unused
?PUT3 unused
?COMPILE unused
?SETLABEL unused
?IBMHEX unused
?HYPHEN unused
?OVERLOAD unused
?LISTOUT unused
?CHARS unused
?PROLINE unused
?DIAGLINE unused
?CASEMASK unused
?OWNAD unused
?FINALAD unused
?DYNARRAY unused
?NONLOCALREF unused
?WRONGCC unused
?IREADENTRY unused
?INDEXENTRY unused
?AGETENTRY unused
?BOUNDENTRY unused
?SCOMPENTRY unused
?SIGENTRY unused
?DNEWLINE unused
?DREAD unused
?DPRINTSTR unused
?DOUBLE unused
?CS unused
?CC unused
?GE unused
?LT unused
?LE unused
?GT unused
?NE unused
?EQ unused
?ACTMAX unused
?ADECL unused
?LABEL unused
?JUMP unused
?COMPARE unused
?PLUSASS unused
?JAMASSIGN unused
?ASSIGN unused
?SWGOTO unused
?FCALL unused
?FMOD unused
?IMOD unused
?FLOAT unused
?RIGHTBRACKET unused
?COMMENT unused
?WFLAG unused
?RFLAG unused
?OKFLAG unused
?LITMODE unused
?INDEXMODE unused
?PREMODE unused
?POSTMODE unused
?INDMODE unused
?AMODE unused
?DMODE unused
?BYTESIZE unused
?LITSTORE unused
?SLITPOS unused
?DICTSHOWN unused
?ANYNAME unused
?ANYINTVAR unused
?FALSECONST unused
?FREE unused
?A2B unused
?A1B unused
?A0B unused
?D2B unused
?D1B unused
?D0B unused
?MAXAREG unused
?MAXDREG unused
?UNDEF unused
?PREA7 unused
?POSTA7 unused
?A7 unused
?A6 unused
?A1 unused
?D7 unused
?D6 unused
?D2 unused
?D1 unused
?SMALLMIN unused
?EXTRANAME unused
 2841       ;  !of ECCECI
 2841  
 2842  %BEGIN
 2843  %END
 2844  
 2845  %endoffile

 2107 Statements compiled
