    !IMP syntax checker - based on M68000 IMP compiler
    !                              (qv for fuller annotation)
    !  Hamish Dewar  Computer Science   Edinburgh University  1983
    !
    constinteger  MAXNAME=127
    recordformat  EDFILE(integer  start1,lim1, {part 1}
                                  start2,lim2, {part2}
                                  lim, {VMLIM}
                                  lbeg,fp,change,flag,
                                  line  {line number of current pos},
                                  diff  {diff between LINE and ROW},
                                  shift {right shift of window on file},
                    byteinteger   top  {top row of sub_window},
                                  win  {floating top},
                                  bot  {bottom row +1 of sub_window},
                                  min  {minimum window size},
                                  row  {last row position},
                                  col  {last col position},
                 string (maxname) name)
    !
    external routine spec  EDI(record (edfile)name  main,sec,
                             string (255) message)
    external routine spec  CONNECT EDFILE(record (edfile)name  f)
    external routine spec  DISCONNECT EDFILE(record (edfile)name  f)
    !
    !$IF VAX
    conststring (13) permfile="ECCE_PERM"
    !$IF AMDAHL
    {%conststring(18) permfile="ERCLIB:VECCE.IPERM"
    !$FINISH

    !!  control
    constinteger  logbit=   16_00040000 {print log},
                  warnbit=  16_00020000 {print warnings},
                  nonsbit=  16_00010000 {print nonstandard reports},
                  DICTLIST= 16_00001000 {list dict entries},
                  EXPLIST=  16_00000800 {list EXP entries}
    owninteger  control=warnbit+nonsbit
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    externalroutine  ECCECI(record (edfile)name  main)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ownstring (maxname) extraname
    ownrecord (edfile) extra=0,null=0
    integer  curstart,curlim
    integer  nonstop
    owninteger  change=0
    !!  Fault numbers
    constinteger  FORMERR=0, ATOMERR=1, NAMERR=2, CATERR=3, SIZERR=4,
                  ASSERR=5, TYPERR=6, DUPERR=7,
                  NOSTART=8, NOCYCLE=9,
                  ORDERERR=10, MATCHERR=11, RANGERR=12, NONLITERAL=13,
                  BOUNDSERR=14, ACCESSERR=15, NOTINLOOP=16,
                  NOTINROUT=17, NOTINFUN=18, NOTINPRED=19,
                  PLEXERR=20, NOIF=21, NONSTAND=22, NOTIN=23,
                  INDEXERR=24,
                  MOPERR=27, NOTERM=28, NONSTARTER=29,
                  NONVAR=30, NONREF=31, TOOMANY=32, TOOFEW=33,
                  UNWANTED=34, NOPARM=35, UNENDING=37,
                  SELFREF=38
    constinteger  NOEND=40, NOBEGIN=41,
                  IDMISSING=42, NOFINISH=43, NOREPEAT=44,
                  COUNTERR=45, NORESULT=46
    constinteger  ERRMAX=46
    constinteger  POINT=64,WARN=128
    owninteger  FAULTNUM=0
    owninteger  FAULTS=0;          !fault count
    !
    constinteger  MAXINT=16_7FFFFFFF, MININT=\MAXINT,
                  MAX10=maxint//10, MAXDIG=maxint-max10*10
    constinteger  FALSE=0, TRUE=1
    integer  I
    !
    !!  Program statistics
    owninteger  STATEMENTS=0;           !statement count
    !%owninteger ATOMS=0;                !atom count
    !%owninteger IDENTATOMS=0;           !identifier count
    !%owninteger NUMATOMS=0;             !numeric atom count
    !%owninteger MISSES=0;               !ident mismatches
    !%owninteger ZAPS=0
    !
    !!!!!!!!!!!!!!!!   Operand Representation  !!!!!!!!!!!!!!!!!!!

    constinteger  SMALLMIN=-1000, SMALLMAX=1000,
                  LITMIN=smallmax+1, LITMAX=smallmax+1000,
                  D0=litmax+1, D1=d0+1, D2=d0+2, D6=d0+6, D7=d0+7,
                  A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7,
                  INDA0=a0+8,
                  POSTA0=inda0+8, POSTA7=posta0+7,
                  PREA0=posta0+8, PREA7=prea0+7,
                  DICTMIN=prea0+8, DICTMAX=prea0+1200,
                  LABMIN=dictmax+1, LAB1=labmin+1, LABMAX=labmin+20,
                  EXPMIN=labmax+1, EXPMAX=labmax+300,
                  UNDEF=expmax+1, AD=16_4000
    constinteger  MAXDREG=d0+4, MAXAREG=a0+3
    constinteger  D0B=1, D1B=2, D2B=4,
                  A0B=16_100, A1B=16_200, A2B=16_400
    constinteger  ALLREGS=2_0000111100011111;  !a3:a0 & d4:d0
    owninteger  FREE=allregs
    constinteger  NULLTYPE=dictmin,
                  RECY=nulltype+1, ARRY=recy+1, STRINGY=arry+1,
                  REALY=stringy+1, INTY=realy+1,
                  CHARTYPE=inty+1, BOOLTYPE=chartype+1,
                  FALSECONST=booltype+1, TRUECONST=booltype+2,
                  INTTYPE=trueconst+1, SHORTTYPE=inttype+1,
                  HALFTYPE=shorttype+1, BYTETYPE=halftype+1,
                  MITETYPE=bytetype+1, BITTYPE=MITETYPE+1,
                  LONGINTTYPE=bittype+1,
                  REALTYPE=longinttype+1, LONGREALTYPE=realtype+1
    constinteger  PURETYPE=8191, DIRECT=8192, INDIRECT=16384
    constinteger  ANYINT=inty+direct, ANYINTVAR=inty+indirect,
                  ANYSTRING=stringy+direct, ANYSTRINGVAR=stringy+indirect
    constinteger  ANYNAME=nulltype+indirect

    !
    owninteger  dictshown=dictmin

    !!!!!!!!!!!!!!!!!!!!!!!   Big Literals  !!!!!!!!!!!!!!!!!!!!!!!
    owninteger  LITPOS=litmin, SLITPOS=litmax
    integerarray  LITSTORE(litmin:litmax)
    !
    !!!!!!!!!!!!!!!!!!!!!!!!!!  MODE VALUES  !!!!!!!!!!!!!!!!!!!!!!!!!
    !Size codes:
    constinteger  bytesize=1, wordsize=2, longsize=3
    constinteger  sizemask=16_C0, sizeshift=6
    !Address modes:
    constinteger  dmode=0, amode=2_001000,
                  indmode=2_010000, postmode=2_011000, premode=2_100000,
                  dispmode=2_101000, indexmode=2_110000, absmode=2_111000,
                  pcmode=2_111010, litmode=2_111100
    constinteger  ownmode=dispmode+6;  !d(A6)
    !
    !!!!!!!!!!!!!!!!!!!!!!!!  Identifiers  !!!!!!!!!!!!!!!!!!!!!!!!
    !
    recordformat  OBJINFO C
      (integer  flags,type,
        (integer  extra, byteinteger  spare,mode or  integer  low),
       integer  val)
    recordformat  IDENTINFO C
      ((integer  flags,type,
        (integer  extra, byteinteger  spare,mode or  integer  low),
       integer  val or  record (objinfo) details),
       integer  text,link)
    !
    ! Significance of FLAGS:
    constinteger  VAR=16_0001, LAB=16_0002, PROC=16_0004, STATIC=16_0008,
                  SPEC=16_0010, EXT=16_0020, PARM=16_0040, MORE=16_0080,
                  TYPEID=16_0100, OKFLAG=16_0200, ALT=16_0800,
                  RFLAG=16_1000,WFLAG=16_2000
    !
    ! Significance of VAL:
    !  for literal               : the actual value
    !  for variable              : machine address (displacement)
    !  for undefined label       : reference chain
    !  for undefined procedure   :       "
    !  for base type             : (index to) range
    !  for record type           : size of record in bytes
    !
    !  Identifier dictionary:
    record (identinfo)array  DICT(d0:labmax)
    !  indexing DICT:
    owninteger  DLIM=trueconst+1;         !dict limit (up)
    owninteger  DLIM0
    owninteger  PERMLIM=dictmin
    owninteger  DMIN=dictmax-1;       !dict upper limit (down)

    !  Text of identifiers (indexed by _TEXT):
    constinteger  CHARBOUND=6000
    byteintegerarray  CHAR(0:charbound)
    integer  CHARBASE,CHARLIM,CHARMIN;  !pointers
    integer  NEWLEN

    !  Hash index to DICT:
    integerarray  HASHINDEX(0:255)
    integername  HEAD;                  !head of ident search list
    !
    !!!!!!!!!!!!!!!!!!!!!  Complex operands  !!!!!!!!!!!!!!!!!!!!!!!
    !%recordformat EXPINFO(%integer act,x,y)
    !%record(expinfo)%array EXP(expmin:expmax)
    owninteger  EXPLO=expmax+1, OLDEXPLO=expmax+1
    constinteger  NP0=expmin
    owninteger  NP,CONDNP,INSTNP

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!  Keywords and operators  !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !*!!!!!!!  Keyword codes -- used by KEYGEN to produce tables  !!
    constinteger  END=1 {end},
      REPEAT=2       {repeat},
      FINISH=3       {finish},
      ELSE=4         {else},
      BEGIN=5        {begin},
      EXIT=6         {exit_1,continue_0},
      RETURN=7       {return},
      TF=8           {true_1,false_0},
      RESULT=9       {result},
      STOP=10        {stop},
      GOTO=11        {goto},
      SIGNAL=12      {signal},
      MONITOR=13     {monitor},
      ON=15          {on},
      IU=16          {if_0,unless_1},
      WHILE=17       {while},
      UNTIL=18       {until_1},
      FOR=19         {for},
      THEN=20        {then},
      START=21       {start},
      CYCLE=22       {cycle},
      KEYLABEL=23    {label},
      PREFIX=24 {const_9,constant_9,own_8,external_40,system_40,dynamic_40},
      KRANGE=25      {short_1,half_2,byte_3,mite_4,bit_5},
      KEYLONG=26     {long},
      KEYINTEGER=27  {integer},
      KEYREAL=28     {real},
      KEYSTRING=29   {string},
      KEYRECORD=30   {record},
      KEYFORMAT=31   {format},
      FNMAP=32       {fn_0,function_0,map_1},
      RPRED=33       {routine_0,predicate_1},
      KEYSPEC=34     {spec},
      KEYARRAY=35    {array},
      KEYNAME=36     {name},
      KEYSWITCH=37   {switch},
      OF=38          {of},
      KEYFILE=39     {file},
      PROGRAM=40     {program},
      KEYLIST=41     {list},
      KEYCONTROL=42  {control},
      COMMENT=43     {comment},
      KEYEVENT=44    {event},
      INCLUDE=45     {include},
      ALIAS=46       {alias},
      KEYNOT=47      {not},
      KEYAND=64      {and},
      KEYOR=65       {or}
    CONSTintegerARRAY  SYMINIT(97:122) =  C
      2, 15, 27, 57, 64, 87,118,122,126,  1,  1,141,154,168,175,184,
      1,199,230,270,278,  1,288,  1,  1,  1

    CONSTBYTEINTEGERARRAY  SYMBOL(1:292) =  C
    128,114,114, 97,121,163,108,105, 97,115,174,110,100,192,101,103,
    105,110,133,121,116,101,153,105,116,153,111,110,116,105,110,117,
    101,134,121, 99,108,101,150,109,109,101,110,116,171,115,116, 97,
    110,116,152,152,114,111,108,170,121,110, 97,109,105, 99,152,110,
    100,129,108,115,101,132,120,105,116,134,118,101,110,116,172,116,
    101,114,110, 97,108,152,105,110,105,115,104,131, 97,108,115,101,
    136,111,114,109, 97,116,159,110,160,117,110, 99,116,105,111,110,
    160,147,108,101,167,111,116,111,139, 97,108,102,153,102,144,110,
    116,101,103,101,114,155, 99,108,117,100,101,173, 97, 98,101,108,
    151,111,110,103,154,105,115,116,169,111,110,105,116,111,114,141,
    105,116,101,153, 97,112,160, 97,109,101,164,111,116,175,110,143,
    119,110,152,102,166,114,193,114,101,100,105, 99, 97,116,101,161,
    111,103,114, 97,109,168,101,112,101, 97,116,130,111,117,116,105,
    110,101,161,116,117,114,110,135,115,117,108,116,137, 97,108,156,
     99,111,114,100,158,116,111,112,138,105,103,110, 97,108,140,121,
    115,116,101,109,152,104,111,114,116,153,112,101, 99,162,119,105,
    116, 99,104,165, 97,114,116,149,114,105,110,103,157,114,117,101,
    136,104,101,110,148,110,108,101,115,115,144,116,105,108,146,104,
    105,108,101,145

    CONSTBYTEINTEGERARRAY  ALTDISP(1:292) =  C
      0,  5,  0,  0,  0,  0,  5,  0,  0,  0,  0,  0,  0,  0,  5,  0,
      0,  0,  0,  4,  0,  0,  3,  0,  0,  5,  8, 12, 17, 23,  0,  0,
      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  4,
      0,  0,  9,  9,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 40,  3,
      0,  0,  4,  0,  0,  0,  4,  8,  0,  1,  0,  0,  0,  0,  0,  0,
      0,  0,  0,  0,  0, 40,  6, 27,  0,  0,  0,  0,  5,  0,  0,  0,
      0,  6,  0, 14,  0,  0,  0,  2,  0,  0,  0,  0,  0,  0,  0,  0,
      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  2,  2,  0,  0,
      6,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  5,  0,  0,  0,
      0,  4,  0,  0,  0,  0,  0,  0,  0,  7,  0,  0,  0,  0,  0,  0,
      4,  0,  0,  4,  0,  0,  1,  4,  0,  0,  0,  0,  0,  0,  2,  0,
      3,  0,  8,  2,  0,  0,  0,  0,  8,  0,  0,  0,  0,  0,  0,  1,
      0,  0,  0,  0,  0,  0,  6, 12,  0,  0,  0,  0,  0,  0,  0,  0,
      0,  0,  0,  5,  0,  0,  0,  0,  5,  0,  0,  0,  0,  3,  0,  0,
      0,  0,  0,  0,  0,  4, 30,  0,  0,  6,  0,  0,  0,  0,  0,  6,
      0,  0,  0,  0, 40,  5,  0,  0,  0,  1,  4,  0,  0,  0,  0,  0,
      0,  0,  0,  0,  4,  0,  0,  0,  0,  0,  0,  0,  0,  4,  0,  0,
      1,  0,  0,  0,  0,  0,  5,  0,  0,  0,  1,  0,  0,  0,  1,  0,
      0,  0,  0,  0

    !*!!!!!!   end of generated tables    !!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    constinteger  TERMINATOR=52, CONST=53, IDENT=54,
                  AREF=55, RECREF=56,
                  MODSIGN=57,
                  COLON=58, COMMA=59, RIGHT=60, RIGHTBRACKET=61,
                  DUD=63

    !Operators (in banks of 8 acc to rank)
    constinteger  BOOLAND=64, BOOLOR=65, BOOLNOT=66,
                  FLOAT=67, IMOD=68, FMOD=69
    constinteger  EQUALS=70, NOTEQ=71, LESSEQ=72,
                  LESS=73, GREATEQ=74, GREATER=75,
                  EQEQ=76, NOTEQEQ=77, RESOLVE=79
    constinteger  PLUS=80, MINUS=81, LOGOR=82,
                  LOGXOR=83, CONCAT=84
    constinteger  MULT=88, FDIV=89, IDIV=90,
                  LOGAND=91
    constinteger  FPOWER=96, IPOWER=97,
                  LSHIFT=100, RSHIFT=101, LOGNOT=102
    constinteger  FCALL=106, MCALL=107
    constinteger  ATOMMAX=107

    ! Instruction actions:
    constinteger  swgoto=35, rcall=mcall+2,
                  assign=41, jamassign=42, plusass=43,
                  compare=44, jump=45, label=46, adecl=47
    constinteger  actmax=49
    !
    !Branch cases ( = machine condition-code)
    constinteger  EQ=2_0111, NE=2_0110,
                  GT=2_1110, LE=2_1111,
                  LT=2_1101, GE=2_1100,
                  CC=2_0100, CS=2_0101
    constinteger  DOUBLE=16

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Perm procedure identifiers which are recognised explicitly and
    !  either implemented in-line or mapped to system entry-point
    constinteger  DSHORT=dictmin+6, DLENGTH=dshort+1, DCHARNO=dlength+1,
                  DADDR=dcharno+1, DTOSTR=daddr+1,
                  DREM=dtostr+1,
                  DNEXTSYM=drem+1, DREADSYM=dnextsym+1,
                  DPRINTSTR=dreadsym+3,
                  DREAD=dictmin+27,
                  DNEWLINE=dictmin+41
    !System entry-points used explicitly
    constinteger  SIGENTRY=16_1114, SCOMPENTRY=16_1128,
                  BOUNDENTRY=16_1134, AGETENTRY=16_1138,
                  INDEXENTRY=16_113C, IREADENTRY=16_1118

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    owninteger  STARTS=0, CYCLES=0
    owninteger  LOOPLAB=0
    owninteger  CURLAB=lab1
    !
    recordformat  BLOCKINF(integer  sp, delta, fortemps, flags, type,
                      localdpos, parlim, localtext, localpc,
                      localspc, pidpos, access, forward, events,
                      eventpc, faults, return, shorts)
    !Flag bits (VAR=1 from D_FLAGS)
    constinteger  WRONGCC=2, NONLOCALREF=4, DYNARRAY=8
    constinteger  HADON=16_10, HADINST=16_20

    constinteger  OUTERLEVEL=0, MAXLEVEL=16
    owninteger  LEVEL=outerlevel;        !current block level
    record (blockinf) C;                !info for current block
    record (blockinf)array  HOLD(0:maxlevel-1); !info for global blocks

    ! Final core image
    constinteger  PUREBOUND=0, OWNBASE=purebound+1,
                  FINALBOUND=ownbase+8191
    byteintegerarray  FINAL(0:finalbound);  !for switch info only
    owninteger  FINALAD=2, OWNAD=ownbase
    !%owninteger FIRSTENTRY=finalbound, FIRSTDPOS=dictmax
    !%ownintegername CONSTAD;  !== ownad or finalad
    !%owninteger CONSTBOUND=purebound;   !for const/code
    !                     =finalbound;  !for own
    owninteger  PC=0, SPC=finalbound;  !for switch info

    !Recognition:-
    constinteger  CASEMASK=95, CASEBIT=32; !for case conversion

    !Memo variables for current statement:-
    owninteger  ITEM=0;          !current operand
    record (objinfo) T;          !full typeinfo for ITEM
    record (identinfo)name  DITEM
    owninteger  ELEMENTS; !range details
    owninteger  HASH
    owninteger  SPECCING=0, MCODING=0
    owninteger  DECLMODE, DSIZE
    ownrecord (identinfo) D;            !declaration details

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !!  Source file input and listing
    owninteger  ATOM=0;                 !current lexical atom
    owninteger  MATCHED=1;              !indic that atom has been matched
    owninteger  SYM=nl;                 !current input symbol
    owninteger  LINE=0;                 !current line number
    owninteger  MAINLINE=0
    owninteger  DIAGLINE=-9999
    owninteger  PROLINE=0
    owninteger  MODESYM='&';            !space or '+' or '&' or '"'
    !%owninteger OUTCOL=0;               !output line position
    !   Pointers to source file:
    owninteger  LINESTART=0
    owninteger  FP=0;                   !(file pointer) current position
    owninteger  CHARS=0
    owninteger  ATOMP=0;                !start of current atom
    owninteger  FAULTP=0;               !fault position
    owninteger  MAINFP
    owninteger  STRINGP,EXPP
    owninteger  listout=0
    !
    !! Listing, diagnostic and report routines
    !
    ownstring (255) rep=""
    !
    routine  NEWLINE
      print string(rep);  print symbol(nl)
      rep = ""
    end
    !
    routine  PUT SYM(integer  k)
      rep = rep.tostring(k) if  length(rep) < 132
    end
    !
    routine  PRINT STRING(string (255) s)
      rep = rep.s if  length(rep) < 132
    end
    !
    routine  SPACES(integer  n)
      while  n > 0 cycle
        rep = rep." ";  n = n-1
      repeat
    end
    !
    routine  WRITE(integer  val,p)
    routine  PD(integer  v)
      p = p-1
      pd(v//10) and  v = v-v//10*10 if  v <= -10
      spaces(p) and  p = 0 if  p > 0
      put sym('0'-v)
    end
      if  val < 0 start
        put sym('-');  pd(val)
      finish  else  pd(-val)
    end

    !%routine put ident(%integer t)
    !  rep = rep.string(charbase+t)
    !!%integer l
    !  t = t+charbase
    !  l = byteinteger(t);  l = 11 %if l > 11
    !  %while l > 0 %cycle
    !    l = l-1;  t = t+1
    !    put sym(byteinteger(t))
    !  %repeat
    !%end
    !
    !%routine mark at(%integer col)
    !  put sym(' ') %while outcol < col;  put sym('|')
    !%end
    !
    !%routine show dict(%integer from)
    !%integer f,i
    !%record(identinfo) d
    !%constbyteintegerarray flagsym(0:7) =
    !  'V','L','P','O','S','E', 'A', 'M'
    !%constbyteintegerarray dsym(0:3) =
    !  ' ','D','I','!'
    !%conststring(6)%array typetext(0:7) =
    !  "NULL  ", "RECORD", "ARRAY ", "STRING",
    !  "REALY ", "INTY  ", "CHAR  ", "BOOL  "
    !  %return %if from >= dlim
    !  newline %and outcol = 0 %if outcol # 0
    !  print string("          __identifier___flags___type___extra___value___")
    !  newline;  outcol = 0
    !  %cycle
    !    spaces(5);  outcol = 5
    !    pdec(from);  mark at(10)
    !    d = dict(from)
    !    put sym(' ')
    !    put ident(d_text)
    !    mark at(23)
    !    %for i = 7,-1,0 %cycle
    !      %if d_flags>>i&1 = 0 %then put sym(' ') %c
    !      %else put sym(flagsym(i))
    !    %repeat
    !    put sym('|')
    !    i = d_type-nulltype
    !    %if 0 <= i <= 7 %then printstring(typetext(i)) %c
    !    %else putsym(dsym(d_type>>13)) %and pdec(d_type&puretype)
    !    mark at(39)
    !    put sym(' ');  pdec(d_extra);  mark at(47)
    !    put sym(' ');  pdec(d_val);  mark at(56)
    !    newline;  outcol = 0
    !    from = from+1
    !  %repeat %until from = dlim
    !  print string("          +----------------------------------------------+")
    !  newline;  outcol = 0
    !%end
    !
    !%routine show exp(%integer from,to)
    !![out of date]
    !%conststring(7)%array acttext(0:63) =
    !  "?0", "?1", "ADD", "SUB",
    !  "?4", "LOGAND", "LOGOR", "LOGXOR",
    !  "NEGATE", "LOGNOT", "LSHIFT", "RSHIFT",
    !  "IABS", "FABS", "?14", "?15",
    !  "MULT", "IDIV", "IPOWER", "FPLUS",
    !  "FMINUS", "FMULT", "FDIV", "FPOWER",
    !  "FNEGATE", "FLOAT", "CONCAT", "BOOLNOT",
    !  "BOOLAND", "BOOLOR", "MEMBER", "MODULO",
    !  "RECREF", "AREF", "INDRECT", "SWJUMP",
    !  "FCALL", "MCALL", "?38", "RCALL",
    !  "?40", "ASSIGN", "JAMASS", "PLUSASS",
    !  "COMPARE", "JUMP", "LABEL", "ADECL",
    !  "?48", "?49", "?50", "?51",
    !  "?52", "?53", "?54", "?55",
    !  "?56", "?57", "?58", "?59",
    !  "?60", "?61", "?62", "?63"
    !%routine put operand(%integer i)
    !  %if dictmin <= i <= dictmax %then put ident(dict(i)_text) %else pdec(i)
    !%end
    !  %return %if from >= np
    !  newline %and outcol = 0 %if outcol # 0
    !  print string("          __action_____first_______second____")
    !  newline;  outcol = 0
    !  %cycle
    !    spaces(5);  outcol = 5
    !    pdec(from);  mark at(10)
    !    put sym(' ');  printstring(acttext(exp(from)_act&63))
    !    mark at(20);  put sym(' ')
    !    put operand(exp(from)_x)
    !    mark at(32);  put sym(' ')
    !    put operand(exp(from)_y)
    !    mark at(44)
    !    newline;  outcol = 0
    !    from = from+1
    !    %if from = to %start
    !      from = explo
    !      %exit %if from >= oldexplo
    !      printstring("          |---------------------------------|")
    !      newline;  outcol = 0
    !    %finish
    !  %repeat %until from >= oldexplo
    !  oldexplo = explo
    !  print string("          +---------------------------------+")
    !  newline;  outcol = 0
    !%end
    !
    !! Fault reporting
    !
    routine  REPORT(integer  n,joker)
    integer  mark,start,errline,k,editfp
    routine  PRINT IDENT(integer  x)
      put sym('"')
      print string(string(dict(x)_text+charbase))
      put sym('"')
    end
    routine  PRINT TEXT(integer  x,stream)
    constinteger  esc=27
    integer  k,p
    switch  s(0:errmax)
      put sym(mark)
      write(line,4)
      put sym(modesym);  put sym(' ')
      ->s(n&63)
    s(formerr):   printstring("Faulty form");   -> print
    s(atomerr):   printstring("Unknown atom");  -> print
    s(namerr):    printstring("Unknown name");  -> print
    s(caterr):    printstring("Unsuitable");    -> print
    s(sizerr):    printstring("Size");          -> print
    s(typerr):    printstring("Wrong type");    -> print
    s(boundserr): printstring("Inside out");    -> print
    s(unending):  printstring("Endless loop");  -> print
    s(indexerr):  printstring("Index");         -> print
    s(accesserr): printstring("Not accessible");-> print
    s(notinloop): printstring("Not in loop");   -> print
    s(notinrout): printstring("Not in routine");-> print
    s(notinfun):  printstring("Not in fn/map"); -> print
    s(notinpred): printstring("Not in pred");   -> print
    s(plexerr):   printstring("Too complex!");  -> print
    s(duperr):    printstring("Duplicate");     -> print
    s(ordererr):  printstring("Out of order");  -> print
    s(matcherr):  printstring("Mismatch");      -> print
    s(rangerr):   printstring("Out of range");  -> print
    s(nonliteral):printstring("Not literal");   -> print
    s(nonstand):  printstring("Nonstandard");   -> print
    s(notin):     printstring("Not in yet");    -> print
    s(moperr):    printstring("Faulty operand");-> print
    s(nocycle):   printstring("Missing %CYCLE"); -> print
    s(nostart):   printstring("Missing %START"); -> print
    s(noif):      printstring("Missing %IF");    -> print
    s(noterm):    printstring("';' missing");    -> print
    s(nonstarter):printstring("Non-starter");    -> print
    s(nonvar):    printstring("Not variable");   -> print
    s(nonref):    printstring("Not reference");  -> print
    s(noparm):    printstring("No parameters");  -> print
    s(toofew):    printstring("Too few");        -> print
    s(unwanted):  printstring("Unwanted");       -> print
    s(toomany):   printstring("Too many");       -> print
    s(selfref):   printstring("Self-reference"); -> print
    s(nobegin):   printstring("Extra %END");     -> print
    print:
      spaces(21-length(rep))
      p = start
      if  p < faultp-50 then  p = faultp-47 and  printstring("...") c
      else  put sym(' ')
      cycle
        k = byteintegeR(p);  p = p+1
        if  p = faultp start
    !$IF VAX
          put sym(esc) and  put sym('F') if  stream = 0
    !$FINISH
          put sym('~')
    !$IF VAX
          put sym(esc) and  put sym('G') if  stream = 0
    !$FINISH
        finish
        exit  if  k = nl
        if  ' ' <= k <= '~' then  put sym(k) c
        else  put sym('[') and  write(k,-1) and  put sym(']')
      repeat
      return
    s(noend):     printstring("%END");           ->mend
    s(noresult):  printstring("Result");         ->mend
    s(nofinish):  printstring("%FINISH");        ->mend0
    s(norepeat):  printstring("%REPEAT")
    mend0:        printstring(" etc") if  curlab > lab1+2
                  -> mend
    s(idmissing):
      cycle
    !    newline %and spaces(8) %and outcol = 8 %if outcol > 50
        put sym(' ')
        print ident(x)
        print string("(?)") if  dict(x)_flags&spec = 0;  !switch
        x = dict(x)_val
      repeat  until  x = 0
    mend:
      printstring(" missing")
      if  c_type # 0 start
        print string(" at END of ")
        print ident(c_pidpos)
      finish  else  n = 0
      return
    s(counterr):
      if  elements < 0 start
        write(-elements,0);  printstring(" extra")
      finish  else  start
        write(elements,0);  printstring(" missing")
      finish
      printstring(" value(s) for ")
      print ident(x)
      return
    s(asserr):
      print ident(x)
      print string(" void")
    end

    !Warning or error
      mark = '?'
      if  n&warn = 0 start
        mark = '*'
        c_faults = c_faults+1;  faults = faults+1
      finish
      faultnum = 0;  c_access = -1
    !Ignore uncorrected earlier error
      return  if  main_start1 <= fp < change
    !Track back if before current line
      start = linestart;  errline = line
      if  n&point = 0 then  faultp = 0 else  start
        faultp = joker if  joker > 0
        while  faultp <= start cycle
          start = start-1
          errline = errline-1 if  byteintegeR(start) = nl
        repeat
        start = start-1 while  start # curstart and  byteintegeR(start-1) # nl
      finish
      editfp = start;  editfp = faultp-1 if  faultp > start
      editfp = mainfp if  curlim = extra_lim2
      start = start+1 while  byteintegeR(start) = ' '
      print text(joker,0)
      newline and  return  if  n&warn # 0 or  nonstop # 0
      main_fp = editfp;  main_line = line
      if  change # 0 then  main_change = 16_7FFFFFFE
      edi(main,null,rep)
      rep = ""
      nonstop = 1 if  main_flag = 'I'
      stop  if  main_flag < 0
      signal  12 if  main_change < 16_7FFFFFFE {change made}
     end ;  !report

    routine  CROAK(string (255) s)
      print string("** ".s.".  Checking abandoned at line ")
      write(line,0);  newline
      nonstop = -999
      signal  12
    end

    routine  FAULT(integer  n)
    !Note fault number and position of (earliest) fault
    ! for subsequent reporting (warnings and weak errors)
      faultnum = n and  faultp = atomp if  faultnum = 0
    end
    routine  EXPFAULT(integer  n)
      faultnum = n!point and  faultp = expp if  faultnum = 0 or  expp < faultp
    end

    constinteger  pred=1, uparr=1<<1, nocomma=1<<2, overload=1<<3,
                  ranges=1<<4, nolength=1<<5, initass=1<<6, kgoto=1<<7,
                  hyphen=1<<8, naming=1<<9, klabel=1<<10, ibmhex=1<<11,
                  oldcycle=1<<12, loop2=1<<13
    routine  NONSTANDARD(integer  case)
    owninteger  hadit=0
      if  control&nonsbit # 0 and  case&hadit = 0 start
        hadit = hadit+case
        fault(nonstand+point+warn)
      finish
    end

    routine  ERROR(integer  case)
      report(case,atomp)
      signal  14
    end

    routine  NAME ERROR
    !check if the culprit has occurred before
    !and, if not, add it to the pool of unknowns stored at the
    !far end of the dictionary.
      while  item < 0 c
         and  string(dict(-item)_text+charbase) # string(charlim) cycle
         item = dict(-item)_link
      repeat
      if  item >= 0 start ;  !first time
        report(namerr+point,atomp)
        if  charmin-newlen-80 >= charlim start
          dmin = dmin-1
          charmin = charmin-newlen-1
          string(charmin) = string(charlim)
          dict(dmin)_text = charmin-charbase
          head == dict(head)_link while  head > 0;  !find last link
          dict(dmin)_link = head;  head = -dmin
        finish
      finish
      signal  14
    end

    routine  SYNTAX ERROR
    integer  e
      e = formerr+point;  e = atomerr+point if  atom = dud
      report(e,atomp)
      signal  14
    end

    !!!!!!!!!!!!!!!!!!!!   CELL  CONSTRUCTORS  !!!!!!!!!!!!!!!!!!!
    !
    !%integerfn litref(%integer v)
    !%integer i
    !  %result = v %if smallmin <= v <= smallmax
    !  litstore(litpos) = v
    !  i = litmin-1
    !  i = i+1 %until litstore(i) = v
    !  %if i = litpos %start
    !    litpos = litpos+1
    !    croak("Too many literals") %if litpos >= slitpos
    !  %finish
    !  %result = i
    !%end

    !%integerfn litval(%integer v)
    !  %result = v %if v <= smallmax
    !  %result = litstore(v)
    !%end

    integerfn  floated(integer  item)
      result  = 0 if  item = 0
      result  = explo;!expref(float,item,0)
    end

    !%predicate is short (%integer v)
    !  %true %if -32768 <= v <= 32767
    !  %false
    !%end

    !%predicate is mite (%integer v)
    !  %true %if -128 <= v <= 127
    !  %false
    !%end

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!    CODE  GENERATION   !!!!!!!!!!!!!!!!!!!!!!!!
    !
    routine  forget
    end
    routine  forget all
    integer  i,j
      litpos = litmin;  explo = expmax+1;  oldexplo = explo
    end
    !
    routine  set label(integer  b)
    end ;  !set label
    routine  set user label(integer  dpos)
    end
    routine  compile(integer  from,to)
    !  show exp(from,to) %if control&explist # 0
      np = np0
    end
    routine  compile entry
    end
    routine  compile end
    end ;  !compile end
    !!!!!!!!!!!!!!!  end of Code Generation  !!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    routine  PUT3(integer  act,x,y)
    !  exp(np)_act = act;  exp(np)_x = x;  exp(np)_y = y
    !  np = np+1
    end
    !
    routine  PUT2(integer  act,x)
    end
    !
    integerfn  TEMPVAR
      result  = dlim
    end

    routine  OPEN BLOCK(integer  pidpos)
      forget;  !a bit extreme
      croak("Too many levels") if  level = maxlevel
      hold(level) = c;  level = level+1
      c = 0
      starts = 0;  cycles = 0
      curlab = lab1;  looplab = 0
      forget all
      c_flags = 0;  c_type = d_type
      c_pidpos = pidpos
      c_localdpos = dlim;  c_parlim = dlim;  c_localtext = charlim
      c_localpc = pc;  c_localspc = spc
      c_access = 1
    end ;  !OPEN BLOCK

    routine  CLOSE BLOCK
    integer  i
    integer  miss,dpos
    integername  p
    record (identinfo)name  dp
      !Check identifier usage
      miss = 0;  p == miss
      dpos = c_localdpos
      while  dpos # dlim cycle
        dp == dict(dpos)
    !    %if (dp_xtype = ptrxtype %and dp_type = dpos)
        if  dp_flags&(proc+lab) # 0 and  dp_flags&(ext+spec) = spec start
              p = dpos;  p == dp_val;  p = 0
        finish
    !    %if hashindex(dp_spare) = dpos %start
    !      dp_link = dict(dp_link)_link %while dp_link >= c_localdpos
    !      hashindex(dp_spare) = dp_link
    !    %finish
    !    dpos = dp_xtype %if dp_type = 0 %and dp_xtype > dpos;  !skip fields
        dpos = dpos+1
      repeat
      report(idmissing,miss) if  miss # 0
      compile end
      pc = c_localpc;  spc = c_localspc
      dlim = c_parlim;  charlim = c_localtext
      for  i = 0,1,255 cycle
         hashindex(i) = dict(hashindex(i))_link while  hashindex(i) >= c_localdpos
      repeat
      level = level-1;  c = hold(level)
      starts = 0;  cycles = 0
    end ;  !CLOSE BLOCK

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!  Source input  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    routine  SWITCH INPUT
    !  croak("Input ended") %if fp = main_lim2
      signal  12 if  fp = main_lim2
      if  nonstop < 0 start ;  !perming
        nonstop = nonstop+3;  permlim = dlim
        c_localdpos = dlim;  c_parlim = dlim
        statements = 0
      finish
      if  fp # main_lim1 start
        nonstop = nonstop-1
        fp = mainfp;  line = mainline
        curstart = main_start1;  curlim = main_lim1
      finish  else  fp = main_start2
      if  main_start2 <= fp <= main_lim2 start
        curstart = main_start2;  curlim = main_lim2
      finish
      modesym = ' ';  sym = nl
    end

    routine  READ LINE
    ! Read (or otherwise make available) the next source line
    !     Skip remnant of previous line if SYM # NL        *NB*
    !     Set LINESTART to point to start of new line
      report(faultnum,faultp) if  faultnum # 0
      while  sym # nl cycle ;               !Skip remnant
        sym = byteintegeR(fp);  fp = fp+1
      repeat
      while  fp = curlim cycle
        switch input
      repeat
      line = line+1;  linestart = fp
      sym = 0
    end ;  !READ LINE
    !
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!  Lexical processing  !!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    owninteger  percent=0, subatom=0
    !
    !Aliases:
    constinteger  ARROW=resolve
    constinteger  EXCLAM=logor, EXCLAM2=logxor, DOT=concat
    constinteger  STAR=mult, SLASH=fdiv, SLASH2=idiv,
                  AMPERSAND=logand
    constinteger  BACKSLASH=fpower, BACKSLASH2=ipower,
                  UPARROW=fpower,   UPARROW2=ipower,
                  TILDE=lognot
    constinteger  LEFT=aref, UNDERLINE=recref, LEFTBRACKET=106

    constinteger  SIMPLE=104, MAJOR=plus,
                  SCOND=equals, COND=keyand
    !
    ! Type compatibility vectors:
    constinteger  RECOK=1<<0, ARROK=1<<1, STRINGOK=1<<2,
                  REALOK=1<<3, INTOK=1<<4, CHAROK=1<<5,
                  BOOLOK=1<<6, ENUMOK=1<<7, SETOK=1<<8
    constinteger  ZNOP=1<<9, REFONLY=1<<10, VARONLY=1<<11
    constinteger  ARITHOK=intok+realok,
                  ORDOK=intok+charok+boolok+enumok,
                  ANY=realok+ordok+stringok+arrok+recok
    !
    constintegerarray  opbits(64:atommax) =
      {BOOLAND}    boolok,
      {BOOLOR}     boolok,
                   0, 0, 0, 0,
      {EQUALS}     any,
      {NOTEQ}      any,
      {LESSEQ}     setok+stringok+ordok+realok,
      {LESS}       stringok+ordok+realok,
      {GREATEQ}    setok+stringok+ordok+realok,
      {GREATER}    stringok+ordok+realok,
                   any,
                   any,
                   0,
      {RESOLVE}    stringok,
      {PLUS}       znop+setok+arithok,
      {MINUS}      znop+setok+arithok,
      {LOGOR}      znop+intok,
      {LOGXOR}     znop+intok,
      {CONCAT}     stringok,
                   0, 0, 0,
      {MULT}       arithok,
      {FDIV}       arithok,
      {IDIV}       intok,
      {LOGAND}     intok,
                   0, 0, 0, 0,
      {FPOWER}     arithok,
      {IPOWER}     intok,
                   0, 0,
      {LSHIFT}     znop+intok,
      {RSHIFT}     znop+intok,
      {LOGNOT}     intok,
                   0,
      {AREF}       arrok,
      {RECREF}     recok,
      {}           0, 0
    !
    integerfn  NEXT ATOM
    !Encode next atom from source file
    ![Time-critical]
    switch  s(0:255)
    constinteger  tab=9
    integer  i,j,p,radix,digits
    real  rval
    constbyteintegerarray  map(0:127) =
      0 ('0'),
      '0','1','2','3','4','5','6','7','8','9',
      0, 0, 0, 0, 0, 0, 0,
      'a','b','c','d','e','f','g','h','i','j','k','l','m',
      'n','o','p','q','r','s','t','u','v','w','x','y','z',
      0, 0, 0, 0, 0, 0,
      'a','b','c','d','e','f','g','h','i','j','k','l','m',
      'n','o','p','q','r','s','t','u','v','w','x','y','z',
      0, 0, 0, 0, 0

    routine  assemble real
      j = 0
      cycle
        cycle
          sym = byteintegeR(fp);  fp = fp+1
        repeat  until  sym # ' '
        i = sym-'0'
        return  unless  0 <= i < radix
        rval = rval*radix+i;  j = j+1
      repeat
    end

    !  atoms = atoms+1
      matched = 0
    again: s(tab):
      read line if  sym = nl
      cycle
        sym = byteintegeR(fp);  fp = fp+1
      repeat  until  sym # ' '
      atomp = fp;     !(actually one after)
      -> s(sym)
    linebreak: s(nl):
      result  = terminator if  atom # comma
      -> again

    s('{'):
      cycle
        sym = byteintegeR(fp);  fp = fp+1
        -> linebreak if  sym = nl
      repeat  until  sym = '}'
      -> again

    s('+'): result  = plus
    s('-'): fp = fp+1 and  result  = arrow if  byteintegeR(fp) = '>'
            -> again if  byteintegeR(fp) = nl
            result  = minus
    s('*'): result  = star
    s('/'): fp = fp+1 and  result  = slash2 if  byteintegeR(fp) = '/'
            result  = slash
    s('\'): fp = fp+1 and  result  = backslash2 if  byteintegeR(fp) = '\'
            result  = backslash
    s('^'): nonstandard(uparr)
            fp = fp+1 and  result  = uparrow2 if  byteintegeR(fp) = '^'
            result  = uparrow
    s('!'): fp = fp+1 and  result  = exclam2 if  byteintegeR(fp) = '!'
            result  = exclam
    s('&'): result  = ampersand
    s('.'): result  = dot
    s('='): fp = fp+1 and  result  = eqeq if  byteintegeR(fp) = '='
            result  = equals
    s('#'): fp = fp+1 and  result  = noteqeq if  byteintegeR(fp) = '#'
            result  = noteq
    s('<'): fp = fp+1 and  result  = lesseq if  byteintegeR(fp) = '='
            fp = fp+1 and  result  = noteq if  byteintegeR(fp) = '>'
            fp = fp+1 and  result  = lshift if  byteintegeR(fp) = '<'
            result  = less
    s('>'): fp = fp+1 and  result  = greateq if  byteintegeR(fp) = '='
            fp = fp+1 and  result  = rshift if  byteintegeR(fp) = '>'
            result  = greater
    s('_'): result  = underline
    s(':'): result  = colon
    s(','): result  = comma
    s(';'): result  = terminator
    s('('): result  = left
    s(')'): result  = right
    s('|'): result  = modsign

    s('E'): s('e'):
      fp = fp+1 and  -> stringconst if  byteintegeR(fp) = '"'
    s('M'): s('m'): s('C'): s('c'):
      fp = fp+1 and  -> charconst if  byteintegeR(fp) = ''''
    s('A'):s('B'):s('D'):s('F'):s('G'):s('H'):
    s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'):
    s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'):
    s('Y'):s('Z'):s('a'):s('b'):s('d'):s('f'):
    s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'):
    s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'):
    s('w'):s('x'):s('y'):s('z'):
      -> keyword if  percent # 0
    !  identatoms = identatoms+1
      newlen = charlim+1;  hash = sym!casebit;  !lower-case (if letter)
      byteinteger(newlen) = hash
      cycle
        sym = byteintegeR(fp);  fp = fp+1
      repeat  until  sym # ' '
    !$IF AMDAHL
    {  %if sym = '''' %start
    {    radix = 16 %and -> ibm %if hash = 'x'
    {    radix = 8 %and -> ibm %if hash = 'k'
    {    radix = 2 %and -> ibm %if hash = 'b'
    {  %finish
    !$FINISH
      sym = map(sym)
      if  sym # 0 start
        cycle
          newlen = newlen+1;  byteinteger(newlen) = sym
          hash = hash<<1!!sym
          cycle
            sym = byteintegeR(fp);  fp = fp+1
          repeat  until  sym # ' '
          sym = map(sym)
        repeat  until  sym = 0
      finish
      fp = fp-1
      newlen = newlen-charlim;  byteinteger(charlim) = newlen
      head == hashindex(hash&255)
      item = head
      if  item > 0 start
        cycle
          result  = ident if  item <= 0
          ditem == dict(item)
          exit  if  string(ditem_text+charbase) = string(charlim)
    !      misses = misses+1
          item = ditem_link
        repeat  until  item <= 0
      finish
      result  = ident

    s('%'):
      sym = byteintegeR(fp)
      -> again unless  'a' <= sym!casebit <= 'z'
      fp = fp+1
    keyword:
      percent = 0
      p = syminit(sym!casebit)
      cycle
    !     %cycle
    !       sym = byteintegeR(fp)!casebit
    !       %exit %if symbol(p) # sym
        while  symbol(p) = byteintegeR(fp)!casebit cycle
          p = p+1;  fp = fp+1
        repeat
        exit  if  symbol(p) >= 128
        atom = altdisp(p)
        if  atom = 0 start
          result  = dud unless  sym!casebit = 'c' and  byteintegeR(fp) = nl
          read line
          ->again
        finish
        p = p+atom
      repeat
      percent = 1 if  'a' <= byteintegeR(fp)!casebit <= 'z'
      subatom = altdisp(p)
      atom = symbol(p)-128
      result  = dud if  atom = 0
      result  = atom

    !$IF AMDAHL
    {ibm:
    {  nonstandard(ibmhex)
    {  item = -1;  t_val = 0
    {  -> ibm1
    !$FINISH
    s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'):
      item = 0;  t_type = inty
      radix = 10;  t_val = sym-'0'
    ibm1:
      cycle
        cycle
          cycle
            sym = byteintegeR(fp);  fp = fp+1
          repeat  until  sym # ' '
          i = sym-'0'
          if  radix = 10 start
            exit  if  i < 0 or  i >= 10
            if  t_val > max10 or  (t_val=max10 and  i > maxdig) start
              t_type = realy;  rval = t_val
              assemble real
              exit
            finish
            t_val = t_val*10+i
          finish  else  start
            i = sym!casebit-'a'+10 if  i >= 10
            exit  if  i < 0 or  i >= radix
            j = radix
            cycle
              i = i+t_val if  j&1 # 0
              t_val = t_val<<1;  j = j>>1
            repeat  until  j = 0
            t_val = i
          finish
        repeat
        exit  unless  sym = '_'
        radix = t_val
        result  = dud if  radix = 0
        t_val = 0
      repeat
      if  sym = '.' start
        t_type = realy and  rval = t_val if  t_type = inty
        assemble real
        result  = dud if  j = 0
        rval = rval/radix\j
      finish
    !  %if t_type = realy %start;  !vax->ieee
    !    t_val = integer(addr(rval))
    !    t_val = t_val<<16+t_val>>16-16_01000000
    !  %finish
    !  numatoms = numatoms+1
    !$IF AMDAHL
    {  %if item < 0 %start
    {    %result = dud %if sym # ''''
    {    item = 0
    {  %finish %else %start
    {    fp = fp-1;  sym = 0
    {  %finish
    !$IF VAX OR APM
      fp = fp-1;  sym = 0
    !$FINISH
      result  = const

    s(''''):
    charconst:
      item = 0;  t_type = inty
      t_val = 0
      cycle
        sym = byteintegeR(fp);  fp = fp+1
        result  = dud if  sym = nl;  !?allow
        if  sym = '''' start
          exit  unless  byteintegeR(fp) = ''''
          fp = fp+1
        finish
        t_val = t_val<<8+sym
      repeat
      result  = const if  t_val # 0
      result  = dud

    s('"'):
    stringconst:
      item = 0;  t_type = stringy
      stringp = atomp;  !for include
      t_val = 0
      i = line;  j = linestart
      cycle
        sym = byteintegeR(fp);  fp = fp+1
        if  sym = '"' start
          exit  if  byteintegeR(fp) # '"'
          fp = fp+1
        finish
        t_val = t_val+1
        if  t_val > 255 start
          sym = 0
          fp = atomp;  linestart = j
          result  = dud
        finish
        read line if  sym = nl
      repeat
      result  = const

    s(*):
      result  = dud
    end ;  !NEXT ATOM

    routine  LOOKUP FIELD IDENT(integer  list)
      item = list;  return  if  item = 0
      cycle
        ditem == dict(item)
        if  ditem_flags&typeid = 0 start
          return  if  string(ditem_text+charbase) = string(charlim)
          exit  if  ditem_flags&more = 0
        finish
        item = item+1;  !misses = misses+1
      repeat
      item = 0
    end

    predicate  A (integer  k)
    !Basic atom-testing predicate
      atom = next atom if  matched # 0
      false  if  k # atom
      matched = 1
      true
    end

    routine  GET(integer  k)
      atom = next atom if  matched # 0
      matched = 1
      return  if  atom = k
      syntax error if  atom = dud
      faultp = atomp;  report(formerr+point,-k)
      signal  14
    end

    routine  ALLOW(integer  k)
      if  a(k) start
      finish
    end

    routine  DECLARE
      if  speccing = 0 start ;  !not within spec params
        if  item >= c_localdpos start ;  !there already
          if  d_flags&spec = 0 and  d_flags+spec = ditem_flags c
          and  ditem_type = d_type start
            ditem_flags = ditem_flags-spec
            return
          finish
          fault(duperr+point)
        finish
        d_link = head;  head = dlim;  !insert in list
    !    d_spare = hash&255
        if  item > 0 then  d_text = ditem_text c
        else  start
          d_text = charlim-charbase;  charlim = charlim+newlen+1
          croak("Identifier space exhausted") if  charlim+80 >= charmin
        finish
      finish  else  d_text = 0
      item = dlim;  ditem == dict(item)
      ditem = d
      dlim = dlim+1;  croak("Too many identifiers") if  dlim >= dmin
    end ;  !DECLARE

    routine  DECLARE ANON
      d_text = 0;  d_link = 0
      dict(dlim) = d
      dlim = dlim+1;  croak("Too many identifiers") if  dlim >= dmin
    end

    owninteger  jammy
    predicate  A ASSOP
      atom = next atom if  matched # 0
      if  atom # equals and  atom # eqeq start
        false  unless  atom = less and  byteintegeR(fp) = '-'
        jammy = 2;  fp = fp+1
      finish  else  jammy = 0
      matched = 1
      true
    end

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!  Expressions  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    owninteger  literal=0
    routinespec  get EXPRESSION(integer  rank,control)

    integerfn  COMPAT(integer  control)
      if  t_type = inty start
        if  control&intok = 0 and  control&realok # 0 start
          item = floated(item)
          t_type = realy
        finish
        result  = control&(intok+realok)
      finish
      result  = control&(boolok>>(booltype-t_type)) if  t_type <= booltype
      result  = control&enumok if  t_type < direct
      result  = control&arrok
    end
    !
    integerfn  LISTMATCH(integer  alist,blist)
    record (identinfo)name  ap,bp
      result  = 1 if  alist = blist
      result  = 0 if  alist < dictmin or  blist < dictmin
      cycle
        ap == dict(alist);  bp == dict(blist)
        result  = 0 if  ap_type # bp_type;  !for now
        alist = alist+1;  blist = blist+1
      repeat  until  ap_flags&bp_flags&more = 0
      result  = 0 if  ap_flags&more # 0 or  bp_flags&more # 0;  !for now
      result  = 1
    end
    !
    routine  GET REFERENCE(integer  reftype)
    integer  type,temp
      get EXPRESSION(simple,refonly+any)
      type = ditem_type&puretype;  reftype = reftype&puretype
      return  if  reftype = type
      if  type < reftype start
        temp = type;  type = reftype;  reftype = temp
      finish
      return  if  reftype = nulltype;  !untyped %name
      type = dict(type)_type
      return  if  type <= inty and  type = reftype
      return  if  type >= direct and  type = dict(reftype)_type;  !aname
      expfault(typerr+point)
    end
    !
    routine  GET VALUE(integer  valtype)
    record (identinfo)name  dp,p
      get EXPRESSION(major,any)
      valtype = valtype&puretype
      dp == dict(valtype)
      if  t_type # dp_type start ;  !base types differ
        return  if  item = 0 = t_val;  !zero
        if  dp_type = realy and  t_type = inty start
          !float
          t_type = realy
          return
        finish
      else  if  t_type >= inty;  !scalar
        if  item = 0 start
          return  if  dp_low <= t_val <= dp_val
          jammy = jammy!1 if  jammy >= 0
        finish  else  start
          if  t_low >= dp_low start
            return  if  t_val <= dp_val
            jammy = jammy!1 if  jammy >= 0
            return  if  t_low <= dp_val
          finish  else  start
            jammy = jammy!1 if  jammy >= 0
            return  if  t_val >= dp_low
          finish
        finish
        expfault(rangerr+point) if  jammy < 2
        return
      else  if  t_type = stringy
        if  t_val > dp_val start ;  !VALUE = LENGTH*
          jammy = jammy!1 if  jammy >= 0
          expfault(rangerr+point) if  item = 0 and  jammy < 2
        finish
        return
      else  if  t_type = recy
        return  if  t_extra = dp_extra
        jammy = jammy!1 and  return  if  jammy >= 2
        !partial assignment?
      else  if  t_type = realy
        return
      finish
      expfault(typerr+point)
    end ;  !GET VALUE
    !
    routine  GET LITERAL(integer  littype)
      literal = literal+1
      get VALUE(littype)
      literal = literal-1
    end
    !
    routine  GET LITINT
      literal = literal+1
      get EXPRESSION(major,intok)
      literal = literal-1
    end
    !
    routine  GET LITSTRING
    integer  holditem
    !Must be quoted string (for %alias and %include)
      holditem = item;  !preserve
      get(const)
      error(typerr+point) if  t_type # stringy
      item = holditem;  !restore
    end
    !
    routine  GET PARMLIST
    record (identinfo)name  hp,dp
    integer  i,j,headitem,headact,dpos,case,procnp,first
      headitem = item;  hp == ditem
      headact = rcall
      !stack procedure ident
    !  procnp = np;  put3(headact,headitem,0)
      i = 0;  first = 1
      dpos = headitem;  dp == hp
      cycle
      !Set up expression state from formal param details
        error(toomany+point) if  dp_flags&more = 0
        dpos = dpos+1 and  dp == dict(dpos) until  dp_flags&parm # 0
        if  dp_flags&proc # 0 start
          get(ident)
          name error if  item <= 0
          fault(typerr+point) if  ditem_flags&proc = 0;  !for now
          fault(caterr+point) if  item > headitem
        else  if  dp_type < indirect;  !value
    !      %if pp_type&numericmask # 0 %then case = i&7 %and i = i+1 %c
    !      %else case = i>>3+8 %and i = i+8
          case = i&7;  i = i+1
          get VALUE(dp_type)
        finish  else  start ;  !name or proc
          case = i>>3+8;  i = i+8
          get REFERENCE(dp_type)
        finish
    !    case = case<<8+headact
    !    item = litref(t_val) %if item = 0
    !    j = np-1
    !    %if first = 0 %start
    !      j = np
    !      !NB Don't re-order parameters for implicits
    !      %if item >= expmin %and headitem > dnewline %start
    !        %while j > procnp %and exp(j-1)_y < expmin %cycle
    !          exp(j)_act = exp(j-1)_act;  exp(j)_y = exp(j-1)_y
    !          j = j-1
    !        %repeat
    !      %finish
    !      exp(np)_x = 0;  np = np+1
    !    %finish
    !    exp(j)_act =  case;  exp(j)_y = item
    !    first = 0
      repeat  until  not  a(comma)
    !  %if hp_type # nulltype %start
    !    i = explo
    !    %while i <= expmax %cycle
    !      %if exp(i)_x = headitem %start;  ![enough?]
    !        item = i;  j = procnp
    !        %cycle
    !          %exit %if exp(i)_y # exp(j)_y
    !          i = i+1;  j = j+1
    !          ->okf %if j >= np
    !        %repeat
    !      %finish
    !      i = i+1
    !    %repeat
    !    %cycle
    !      explo = explo-1;  np = np-1
    !      exp(explo) = exp(np)
    !    %repeat %until np = procnp
        item = explo
    !okf:np = procnp
    !  %finish
    end ;  !get PARMLIST

    routine  GET RESOLUTION
      if  not  a(left) start
        get REFERENCE(anystringvar)
        get(dot)
        get(left)
      finish
      get VALUE(anystring)
      get(right)
      if  a(dot) start
        get REFERENCE(anystringvar)
      finish
    end
    !
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    routine  GET EXPRESSION(integer  rank,control)
    !Main expression recognition routine
    !To bring together the treatment of all binary operators
    ! and ensure fast recognition of simple expressions,
    ! expressions of different levels are handled by
    ! precedence techniques rather than syntactically
    !CONTROL defines acceptability
    integer  type,f,opok,c1,op,atomp1,item1
    record (objinfo) t1
    record (identinfo)name  dp

    integerfn  litval
    switch  lit(64:atommax)
      -> lit(op)
    lit(plus):    result  = t1_val+t_val
    lit(minus):   result  = t1_val-t_val
    lit(mult):    result  = t1_val*t_val
    lit(idiv):    result  = t1_val//t_val if  t_val # 0
                  fault(rangerr)
                  result  = 0
    lit(logand):
    lit(booland): result  = t1_val&t_val
    lit(logor):
    lit(boolor):  result  = t1_val!t_val
    lit(logxor):  result  = t1_val!!t_val
    lit(lshift):  result  = t1_val<<t_val
    lit(rshift):  result  = t1_val>>t_val
    lit(boolnot): result  = t_val!!true
    lit(lognot):  result  = \t_val
    !lit(negate):  %result = -t_val
    lit(equals):  result  = true if  t1_val = t_val
                  result  = false
    lit(noteq):   result  = true if  t1_val # t_val
                  result  = false
    lit(lesseq):  result  = true if  t1_val <= t_val
                  result  = false
    lit(less):    result  = true if  t1_val < t_val
                  result  = false
    lit(greateq): result  = true if  t1_val >= t_val
                  result  = false
    lit(greater): result  = true if  t1_val > t_val
                  result  = false
    lit(concat):  result  = t1_val+t_val
    lit(*):       !report(notwhat,-op)
                  result  = 1
    end

    !Get leading operand
      atom = next atom if  matched # 0
      atomp1 = atomp;  !note position for reports
      if  atom = ident start
        matched = 1
        name error if  item <= 0
        fault(selfref+point) if  item >= dlim0
        type = ditem_type
        if  control&(refonly+varonly) # 0 start
          error(nonvar+point) if  control&varonly # 0 and  f&var = 0
          error(nonref+point) if  type < direct
        finish
        f = ditem_flags
        if  inty <= type <= booltype and  f&proc = 0 start ;  !literal
          item = 0;  t = ditem_details
        else
          fault(nonliteral+point) if  literal > 0
          if  f&proc # 0 start
            ditem == dict(type) and  type = ditem_type if  f&parm # 0
            error(caterr+point) if  type = nulltype;  !routine
            if  a(left) start
              dp == ditem
              get PARMLIST;  get(right)
              ditem == dp
            else
              error(toofew+point) if  ditem_flags&more # 0
              item = explo;!expref(f&var+fcall,item,0)
            finish
          finish
          cycle
            dp == dict(type&puretype);  t = dp_details
            atom = next atom if  matched # 0
            exit  if  atom # underline and  atom # left
            matched = 1
            item1 = item
            if  atom = left start
              cycle
                syntax error if  t_type < direct;  !element type
                type = t_type
                get VALUE(t_val);  !index
                item = explo;!expref(aref,item1,item,t_val)
                ditem == dp
                exit  if  not  a(comma)
                dp == dict(type&puretype);  t = dp_details
                item1 = item
              repeat
              get(right)
            else ;  !rec subfield
              syntax error if  t_type # recy
              get(ident)
              lookup field ident(t_extra)
              error(namerr+point) if  item <= 0
              type = ditem_type
              item = explo;!expref(recref,item,item1)
            finish
          repeat
          -> final if  control&(varonly+refonly) # 0
        finish
      else
        error(nonvar+point) if  control&varonly # 0
        error(nonref+point) if  control&refonly # 0
        if  a(const) start
        else  if  atom = minus;  !leave unmatched
          item = 0;  t = 0;  t_type = inty
        else  if  a(left)
          if  rank < major start ;  !condition
            get EXPRESSION(cond,any)
          finish  else  start
            jammy = jammy-4
            c1 = control;  c1 = c1!intok if  c1&realok # 0
            get EXPRESSION(major,c1)
            jammy = jammy+4
          finish
          get(right)
        else  if  a(keynot)
          syntax error if  rank >= major
          get EXPRESSION(scond,any)
          if  item = 0 then  t_val = t_val!!true c
          else  item = explo;!expref(boolnot,item,0)
        else  if  atom = backslash
          item = 0;  t = 0;  t_type = inty
          atom = tilde
        else  if  a(modsign)
          fault(typerr+point) if  control&arithok = 0
          get EXPRESSION(major,arithok)
          get(modsign)
          if  item = 0 start
            if  t_val < 0 start
              if  t_val # minint then  t_val = -t_val else  expfault(rangerr)
            finish
          else  if  t_type = inty
            item = explo;!expref(imod,item,0)
          else  if  t_type = realy
            item = explo;!expref(fmod,item,0)
          else
            error(typerr)
          finish
        else
          syntax error
        finish
      finish
      atom = next atom if  matched # 0
      while  atom >= rank cycle
        op = atom;  matched = 1
        opok = opbits(op);  c1 = compat(opok);  ![may change ITEM,T_TYPE]
        fault(typerr+point) if  c1 = 0
        item1 = item;  t1 = t
        if  op >= major start ;  !non-conditional
          if  op = dot then  get EXPRESSION(dot,stringok) {right-associate} c
          else  get EXPRESSION(op&(\7)+8,c1)
          if  t_type = realy and  t1_type = inty start
            item1 = floated(item1);  t1_type = realy
          finish
    !      op = op+? %if t_type = realy %and opok&intok # 0
        else
           if  op = resolve start
             get RESOLUTION
          else  if  op >= eqeq
            get EXPRESSION(simple,any+refonly)
          else  if  op >= equals
            get EXPRESSION(major,c1)
            if  equals <= atom < eqeq start
              op = atom;  matched = 1
              get EXPRESSION(major,c1)
            finish
            if  t_type = realy and  t1_type = inty start
              item1 = floated(item1);  t1_type = realy
            finish
          else
            get EXPRESSION(scond,any)
            if  atom >= cond start
              syntax error if  atom # op
            finish
          finish
          t_type = booltype
          t_low = 0 and  t_val = 1 if  item # 0
        finish
        if  item1 = 0 start ;  !first operand literal
          if  item = 0 start ;  !both literal
            t_val = litval
            continue  if  item = 0
    !        item1 = litref(t1_val)
    !     %else %if inverse(op) # 0;  !invertable
    !        op = inverse(op)
    !        temp = t;  t = t1;  t1 = temp;  !standardise order
    !        item1 = item;  item = 0
          else
    !        item1 = litref(t1_val)
          finish
        finish
        if  item = 0 start ;  !second operand literal
          if  op = minus and  t_type = inty start ;  !standardise
            t_val = -t_val if  t_val # minint;  op = plus
          finish
          item = item1 and  continue  if  t_val = 0 and  opok&znop # 0
        finish
        item = explo;!expref(op,item1,item,t_val)
        t_low = minint;  t_val = maxint;  !?real
      repeat
    final:
      expp = atomp1;  !restore to start
      expfault(typerr) if  compat(control) = 0
    end ;  !get EXPRESSION

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!  Conditions and loops  !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    routine  GET CONDITION
    integer  polarity
      polarity = subatom
      condnp = np
      get EXPRESSION(cond,any)
    !  put3(jump+polarity,item,0)
    end ;  !get CONDITION

    routine  GET STATEMENTS(integer  stopper)
    integer  holdnp,holdlooplab
    switch  initial(0:atommax)

    routine  GET INSTRUCTION
    integer  item1,hold,act
    record (identinfo)name  ditem1
    routine  putact
    !  put3(act,t_val,hold)
    end
    !
      if  c_flags < hadinst start ;  !first in block
        c_flags = c_flags+hadinst
        fault(ordererr) if  level <= outerlevel
      finish
      instnp = np
      cycle
        if  a(ident) start
          name error if  item <= 0
          if  ditem_flags&var # 0 start
            matched = 0
            get EXPRESSION(simple,any)
            item1 = item;  ditem1 == ditem
            if  a(equals) start
              get VALUE(ditem1_type)
    !          put2(assign,item1)
           else  if  a(eqeq)
              syntax error if  ditem1_type < indirect
              get REFERENCE(ditem1_type)
              item = item+ad if  item # 0
    !          put2(assign,item1+ad)
           else  if  atom = less and  byteintegeR(fp) = '-'
              fp = fp+1;  matched = 1
              jammy = 2
              get VALUE(ditem1_type)
    !          put2(jamassign,item1)
            else
              syntax error if  not  a(arrow)
              get RESOLUTION
    !          put2(resolve,item1)
            finish
          else
            error(caterr+point) if  ditem_flags&proc = 0
            ditem == dict(ditem_type) if  ditem_flags&parm # 0
            error(caterr+point) if  ditem_type # nulltype
            if  a(left) start
              get PARMLIST;  get(right)
            else ;  !parameterless routine
              error(toofew+point) if  ditem_flags&more # 0
    !          put3(rcall,item,0)
            finish
          finish
        finish  else  start
          act = atom;  hold = subatom;  t_val = 0
          c_access = 0
          if  a(monitor) start
            c_access = 1
    !        fault(monitor<<8)
          else  if  a(exit);  !%exit, %continue
            if  looplab = 0 then  fault(notinloop+point) c
            else  t_val = looplab and  putact
            exit
          else  if  a(return)
            if  c_type # nulltype then  fault(notinrout+point) c
            else  putact
            exit
          else  if  a(result)
            error(notinfun+point) if  c_type <= nulltype
            syntax error if  not  a assop
            if  c_type < direct start ;  !function
              fault(caterr+point) if  atom = eqeq
              get VALUE(c_type)
    !          put2(result,0)
            else ;  !map
              fault(caterr+point) if  atom # eqeq
              get REFERENCE(c_type+(indirect-direct))
    !          put2(result,0)
            finish
            exit
          else  if  a(tf);  !%true, %false
            if  c_type # booltype then  fault(notinpred+point) c
            else  putact
            exit
          else  if  a(arrow) or  a(goto)
            nonstandard(kgoto) if  atom = goto
            get(ident)
            if  byteintegeR(fp) # '(' start
              if  item < c_localdpos or  ditem_flags&lab = 0 c
              or  ditem_type # nulltype start
                d_flags = spec+lab;  d_type = nulltype
                declare
              finish
    !          put3(jump,item,0)
            finish  else  start
              name error if  item < c_localdpos
              syntax error if  ditem_flags&lab = 0 or  ditem_type = nulltype
              get(left)
              get VALUE(ditem_type);  !index
              get(right)
            finish
            exit
          else  if  a(stop)
            putact
            exit
          else  if  a(signal)
            c_access = 1
            allow(keyevent)
            get LITINT
            expfault(rangerr+point) unless  0 <= t_val <= 15
            hold = t_val;  t_val = 0
            get LITINT if  a(comma)
            hold = t_val<<4+hold
            item = 0;  t_val = 0
            get VALUE(anyint) if  a(comma)
    !        put2(act,hold)
            exit
          else
            syntax error
          finish
        finish
      repeat  until  not  a(keyand)
    end ;  !GET INSTRUCTION

    routine  GET FOR CLAUSE
    integer  loopvar,k,s,start,sval,i,inc,ival,e,n,temp
    integer  eval
    record (identinfo)name  dp
      holdnp = np;  temp = 0
      dict(curlab)_val = 1;  !dummy
      condnp = np
      get(ident)
      name error if  item <= 0
      fault(typerr+point) if  dict(ditem_type&puretype)_type # inty
      fault(caterr+point+warn) if  ditem_type # direct+inttype
      loopvar = item;  dp == ditem
      get(equals)
      get VALUE(ditem_type)
      start = item;  sval = t_val
      get(comma)
      get VALUE(anyint)
      inc = item;  ival = t_val
      expfault(rangerr+point) and  ival = 1 if  inc = 0 = ival
      get(comma)
      get VALUE(ditem_type)
    !Deal with INC and replace START by START-INC
    !  k = undef
    !  k = exp(start)_y %if start >= expmin %and exp(start)_act = plus
      if  inc = 0 start ;  !literal increment
        i = 1;  !litref(ival)
        if  start = 0 start ;  !START and INC both literal
          sval = sval-ival;  s = 1;  !litref(sval)
    !   %else %if k <= litmax;  !START is x+lit
    !      k = ival-litval(k)
    !      s = exp(start)_x;  s = explo;!expref(plus,s,litref(k)) %if k # 0
        else
          s = explo;!expref(plus,start,litref(-ival))
        finish
      finish  else  start ;  !allocate temp var
    !    i = tempvar;  put3(assign,i,inc);  temp = temp-4
    !    %if start = inc %start;  !identical
    !      s = 0;  sval = 0
    !   %else %if k = inc;  !START is x+INC
    !      s = exp(start)_x
    !    %else
    !      s = start;  s = litref(sval) %if s = 0
          s = explo;!expref(minus,s,i)
    !    %finish
      finish
    !  %if item = 0 %start;  !literal end-value
    !    e = litref(t_val);  eval = t_val
    !  %finish %else %start
    !    e = tempvar;  put3(assign,e,item);  temp = temp-4
    !  %finish
    !  put3(assign,loopvar,s)
    !  put3(label,curlab,0)
      if  start!inc!item = 0 start ;  !all literal
        k = t_val-sval;  n = k//ival
        fault(boundserr) if  n < 0
        fault(unending) if  n*ival # k
    !    %if 0 <= t_val <= 32767 %start
    !      temp = loopvar
    !    %finish
      finish
    !  %if temp <= 0 %start
    !    c_fortemps = c_fortemps-temp;  !ie increment
    !    put3(compare,loopvar,e)
    !    put3(eq,0,curlab+1)
    !  %finish
    !  put3(plusass,loopvar,i)
    !  compile(holdnp,np)
    end ;  !get FORCLAUSE

    routine  GET SWITCH INDEX
    integer  item1
    record (identinfo)name  dp
      item1 = item;  dp == ditem
      get(left)
      item = 1
      if  a(star) start
        fault(duperr+point) if  dp_spare # 0
        dp_spare = 1
      else
        get LITERAL(dp_type)
       !beware faulty declaration or index
        if  dp_type > inttype and  faultnum = 0 start
          t_val = t_val-dict(dp_type)_low+dp_val
          expfault(duperr+point) if  final(t_val) # 0
    !      define jumps(final(t_val));  !in case of lit jumps
          final(t_val) = 1
        finish
      finish
      get(right)
      c_access = 1
    end

    ![unsure of efficiency implications of trapping overflow lower down]
    on  event  1,14 start
    !$IF VAX
      report(rangerr,0) if  event_event = 1
    !$IF AMDAHL
    {  report(rangerr,0) %if eventinf>>8 = 1
    !$FINISH
      -> skip
    finish
    !!!!!!!!!!!!!!!!!!!  Start of new statement  !!!!!!!!!!!!!!!!!!!
    next:
      statements = statements+1
    next1:
      report(faultnum,faultp) if  faultnum # 0
      d = 0;  declmode = 0;  dsize = 0
      dlim0 = dlim;  elements = 0
      speccing = 0;  mcoding = 0
      literal = 0;  jammy = 0
      dict(curlab)_val = 0;  dict(curlab+1)_val = 0
      np = np0;  instnp = np0;  condnp = np0
    !  constad == finalad;  constbound = purebound
      if  explo < expmin+50 or  litpos > litmax-50 start
        !zaps = zaps+1;  zaps = zaps+999 %if litpos > litmax-50
        forget all
      finish
      t_val = 0
    !
    initial(terminator):
      atom = next atom;  matched = 1
      -> initial(atom)
    initial(star): initial(exclam): initial(exclam2):
      read line
      -> next1
    term:
      get(terminator)
      -> next

    skip:
      c_access = -1
      if  atom # terminator start
        cycle
          subatom = atom;  atom = next atom
        repeat  until  atom = terminator
        starts = starts+1 if  subatom = start
        cycles = cycles+1 if  subatom = cycle
      finish
      -> next

    initial(dud):
      syntax error;  !ie atom error

    initial(*):
      error(nonstarter+point)

    initial(ident):
      if  byteintegeR(fp) = ':' start ;  !simple label
        fp = fp+1
        d_flags = lab;  d_type = nulltype
        declare
        set user label(item)
        ->next
      finish
      name error if  item <= 0
      if  ditem_flags&lab # 0 start
        get SWITCH INDEX
        get(colon)
        ->next
      finish
    initial(return): initial(result): initial(tf):
    initial(stop): initial(signal): initial(monitor):
    initial(exit): initial(goto): initial(arrow):
      matched = 0
      get INSTRUCTION
      -> next if  a(terminator)
      c_access = 1
      if  a(iu) start
        holdnp = np
        get CONDITION
    !    compile(holdnp,np)
      else  if  a(while)
        holdnp = np
    !    put3(label,curlab,0)
        get CONDITION
    !    compile(holdnp,np)
    !    put3(jump,curlab,0)
    !    put3(label,curlab+1,0)
      else  if  a(for)
        get FOR CLAUSE
    !    put3(jump,curlab,0)
    !    put3(label,curlab+1,0)
      else
        syntax error if  not  a(until)
        get CONDITION
      finish
      -> term

    initial(iu):  !if , unless
      cycle
        holdnp = np
        get CONDITION
    !    compile(holdnp,np)
        if  a(then) start
          -> fudge if  a(start)
          get INSTRUCTION
        finish  else  start
          get(start)
    fudge:
          cycle
            get(terminator)
            curlab = curlab+2
            get STATEMENTS(else)
            curlab = curlab-2
            exit  if  atom # else;  !%finish ->
            get CONDITION if  a(iu)
          repeat
          return  if  atom # finish
        finish
        exit  if  not  a(else)
        -> fudge if  a(start)
        get INSTRUCTION and  exit  if  not  a(iu)
      repeat
      -> term

    initial(cycle):
      if  a(terminator) start
        holdlooplab = looplab;  looplab = curlab
        curlab = curlab+2
        get STATEMENTS(repeat)
        curlab = curlab-2;  looplab = holdlooplab
        return  if  atom # repeat
        get CONDITION if  a(until)
        -> term
      finish
      nonstandard(oldcycle)
      get FOR CLAUSE
      -> for1
    initial(while):
      holdnp = np
    !  put3(label,curlab,0)
      get CONDITION
    !  compile(holdnp,np)
      get(cycle)
      get(terminator)
      holdlooplab = looplab;  looplab = curlab
      curlab = curlab+2
      get STATEMENTS(repeat)
      curlab = curlab-2;  looplab = holdlooplab
      return  if  atom # repeat
      nonstandard(loop2) and  get CONDITION if  a(until)
    !  put3(jump,curlab,0)
    !  put3(label,curlab+1,0)
      ->term
    initial(for):
      get FOR CLAUSE
      get(cycle)
    for1:
      get(terminator)
      holdlooplab = looplab;  looplab = curlab
      curlab = curlab+2
      get STATEMENTS(repeat)
      curlab = curlab-2;  looplab = holdlooplab
      return  if  atom # repeat
    !  put3(repeat,0,0)
      -> term

    initial(on):
      fault(ordererr+point) if  c_flags >= hadon or  level <= outerlevel
      c_flags = c_flags!hadon
      matched = 1
      allow(keyevent)
      cycle
        get LITINT
        expfault(rangerr+point) unless  0 <= t_val <= 15
        c_events = c_events!1<<t_val
      repeat  until  not  a(comma)
      get(start)
    !  put3(on,0,0)
      curlab = curlab+2
      get STATEMENTS(finish)
      curlab = curlab-2
      return  if  atom # finish
      -> term
    !
    initial(else):
      -> skip if  starts # 0
      return  if  stopper = else
      error(noif) if  stopper = finish
    initial(finish):
      starts = starts-1 and  -> skip if  starts # 0
      return  if  stopper = finish or  stopper = else
      error(nostart)
    initial(repeat):
      cycles = cycles-1 and  -> skip if  cycles # 0
      return  if  stopper = repeat
      error(nocycle)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!  Declarations  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    integerfn  NEWATYPE(integer  eltype,xtype)
    integer  dpos
    record (identinfo)name  dp
    ownrecord (identinfo) d=0
      dpos = dictmin
      cycle
        dp == dict(dpos)
        result  = dpos+direct if  dp_flags&typeid # 0 c
                       and  dp_type = eltype and  dp_val = xtype
        dpos = dpos+1
      repeat  until  dpos = dlim
      d_flags = typeid;  d_type = eltype;  d_val = xtype
      dict(dpos) = d
      dlim = dlim+1;  croak("Too many identifers") if  dlim >= dmin
      result  = dpos+direct
    end
    !
    integerfn  NEWSTYPE(integer  max)
    integer  dpos
    record (identinfo)name  dp
    ownrecord (identinfo) d=0
      dpos = dictmin
      cycle
        dp == dict(dpos)
        result  = dpos if  dp_type = stringy and  dp_val = max
        dpos = dpos+1
      repeat  until  dpos = dlim
      d_flags = typeid;  d_type = stringy
      d_val = max
      dict(dpos) = d
      dlim = dlim+1;  croak("Too many identifers") if  dlim >= dmin
      result  = dpos
    end
    !
    integerfn  NEWRANGE(integer  type,lower,upper)
    integer  dpos
    record (identinfo)name  dp
    ownrecord (identinfo) d=0
      fault(boundserr) and  upper = lower if  lower > upper
      elements = maxint
      elements = upper-lower if  upper!!lower >= 0 c
        or  minint+upper-lower < 0
      elements = elements+1 if  elements # maxint
      dpos = dictmin
      cycle
        dp == dict(dpos)
        result  = dpos if  dp_flags = typeid and  dp_type = type c
                       and  dp_low = lower and  dp_val = upper
        dpos = dpos+1
      repeat  until  dpos = dlim
      d_flags = typeid;  d_type = type
      d_low = lower;  d_val = upper
      dict(dpos) = d
      dlim = dlim+1;  croak("Too many identifers") if  dlim >= dmin
      result  = dpos
    end

    routine  GET LITBOUNDS
    integer  lower
      get(left)
      get LITINT;  lower = t_val
      get(colon)
      get LITINT;
      get(right)
      t_low = lower
      item = newrange(inty,t_low,t_val);  !always integer at present
    end

    routine  GET IDENT
      dlim0 = dlim
      get(ident)
      declare
      get LITSTRING if  d_flags&ext # 0 and  a(alias)
    end

    routine  GET IDENTLIST
      dlim0 = dlim
      cycle
        get(ident)
        declare
        get LITSTRING if  d_flags&ext # 0 and  a(alias)
       repeat  until  not  a(comma)
    end

    routine  GET TYPE(integer  flags)
    owninteger  fbase
    ownrecord (identinfo)name  formp,fieldp
    !
    routine  GET FORMATDEF;  !(%integername base)
    integer  disp,max,base
    routine  GET FIELD IDENT
      get(ident)
      if  item > 0 then  d_text = ditem_text c
      else  start
        d_text = charlim-charbase;  charlim = charlim+newlen+1
        croak("Identifier space exhausted") if  charlim+80 >= charmin
      finish
      ditem == dict(dlim);  fieldp == ditem
      ditem = d
      if  formp_extra = 0 then  formp_extra = dlim c
      else  start
    !    lookup field ident(formp_extra)
    !    fault(duperr+point) %and item = dlim %if item # dlim
      finish
      dlim = dlim+1;  croak("Too many identifiers") if  dlim >= dmin
    end
    routine  get UNIT
      cycle
        if  a(left) start
          get FORMATDEF;  get(right)
          return  if  not  a(comma)
        else
          get TYPE(static+more)
          if  d_flags&parm = 0 start ;  !not array
            cycle
              disp = disp+1 if  disp&1 # 0 and  dsize # 1
              d_val = disp
              disp = disp+dsize
              get FIELD IDENT
              return  if  not  a(comma)
              atom = next atom
            repeat  until  atom # ident
          else ;  !array
            d_flags = d_flags-parm
            disp = disp+1 if  disp&1 # 0;  d_val = disp
            get FIELD IDENT
            get LITBOUNDS
            fieldp_type = newatype(d_type,item)
            disp = disp+dsize*elements
            return  if  not  a(comma)
          finish
        finish
      repeat
    end
      max = 0;  base = 0
      cycle
        disp = base
        get UNIT
        max = disp if  max < disp
      repeat  until  not  a(keyor)
      base = max
    end ;  !get FORMATDEF

      dsize = 0;  d_mode = 0;  d_val = 0
      d_type = nulltype
      if  a(rpred) start ;  !%routine,(%integerfn)
        flags = flags&(\static) if  flags&ext # 0
        syntax error if  flags&static # 0
        nonstandard(pred) and  d_type = booltype if  subatom # 0
        d_flags = flags+proc;  declmode = declmode+pcmode
        return
      finish
      if  a(krange) start ;                 !%byte,%short,%half,%mite
        d_type = inttype+subatom;  dsize = 1
        dsize = 2 if  d_type = shorttype or  d_type = halftype
        nonstandard(ranges) if  d_type >= mitetype
        allow(keyinteger)
      else  if  a(keyinteger);                    !%integer
        d_type = inttype;  dsize = 4
        atom = next atom
        if  atom = left start
          get LITBOUNDS
          d_type = item
          dsize = 2 if  elements <= 65536 and  t_low >= -32768
          dsize = 1 if  elements <= 256 and  t_low >= -128
        finish
      else  if  a(keylong);                   !%long
        d_type = longinttype;  dsize = 8
        d_type = longrealtype and  get(keyreal) if  not  a(keyinteger)
      else  if  a(keyreal);                   !%real
        d_type = realtype;  dsize = 4
      else  if  a(keystring);                 !%string
        d_type = stringy
        t_val = 255;  dsize = 256
        if  a(left) start
          t_val = 0
          if  not  a(star) start
            get LITINT
            expfault(rangerr+point) and  t_val = 255 unless  0 < t_val <= 255
          finish
          get(right)
        finish  else  nonstandard(nolength)
        if  t_val # 0 start
          d_type = newstype(t_val)
          dsize = (t_val+2)&(\1);  !+1 & evened up
        finish
      else  if  a(keyrecord);                    !%record
        d_type = recy
        if  a(keyformat) start
          syntax error if  flags&(static+ext) # 0
          if  a(keyspec) start
            d_flags = typeid+spec
            get IDENT
          finish  else  start
            d_flags = typeid
            get IDENT
            formp == ditem
            get(left)
            fbase = 0
            get FORMATDEF
            fieldp_flags = fieldp_flags-more
            get(right)
          finish
          d_flags = typeid
          return
        finish
        get(left)
        if  not  a(star) start
          if  not  a(ident) start
            get FORMATDEF
            fieldp_flags = fieldp_flags-more
            get(right)
            d_flags = typeid
            declare anon
          finish
          name error if  item <= 0
          syntax error if  ditem_type # recy
          d_type = item;  dsize = ditem_val
        finish
        get(right)
      else
        syntax error if  atom # keyname;            !untyped %name
      finish
      !End of basic type info: set item size in DECLMODE
      if  dsize <= 4 start
        if  dsize <= 2 then  declmode = dsize<<sizeshift c
        else  declmode = longsize<<sizeshift
      finish
      !Appendages
      if  a(fnmap) start ;  !%fn, %map
        flags = flags&(\static) if  flags&ext # 0
        syntax error if  flags&static # 0
        flags = flags+var and  d_type = d_type+direct if  subatom # 0;  !map
        d_flags = flags+proc;  declmode = declmode+pcmode
        return
      finish
      d_type = d_type+direct
      while  a(keyarray) or  a(keyname) cycle
        if  atom = keyarray start ;                  !%array
          nonstandard(naming) if  d_type >= indirect
          if  not  a(keyname) start
            syntax error if  flags&parm # 0
            flags = flags+parm;  !as indic
            exit
          finish
          d_type = newatype(d_type,inty)
        finish
        syntax error if  d_type >= indirect
        d_type = d_type+(indirect-direct)
        dsize = 4
      repeat
      d_flags = flags!!var
    end ;  !GET TYPE
    !
    routine  GET OWN ARRAY DECLARATION
    integer  holdval,dpos
    record (identinfo)name  dp
    !  constad = constad+1 %if constad&1 # 0
    !  d_val = constad
    !  d_val = d_val-ownbase %if d_val >= ownbase
      get IDENT
      dpos = item;  dp == ditem
      get LITBOUNDS
      dp_type = newatype(d_type,item)
      if  a assop start
        allow(terminator)
        cycle
          get LITERAL(d_type)
          faultnum = rangerr+point+warn if  faultnum = rangerr+point
          holdval = t_val
          t_val = 1
          if  a(left) start
            t_val = elements
            get LITINT if  not  a(star)
            get(right)
          finish
    !      plant const(holdval,t_val)
          elements = elements-t_val
        repeat  until  not  a(comma)
        report(counterr,dpos) if  elements # 0 and  faultnum = 0
      finish
    !  plant const(0,elements) %if elements > 0
    end ;  !get OWN ADECL

    routine  GET ARRAY DECLARATION
    !ie get IDENTLISTS and BOUNDS
    integer  i,dlim1,hold,holdval,type

    !%routine put bound pair
    !  hold = litref(holdval) %if hold = 0
    !  item = litref(t_val) %if item = 0
    !  put3(r,hold,item);  !(range),lower,upper
    !%end

    routine  GET BOUNDS
    integer  range
      get VALUE(anyint)
      hold = item;  t_val = minint if  hold # 0
      holdval = t_val
      get(colon)
      get VALUE(anyint)
      t_val = maxint if  item # 0
      range = newrange(inty,holdval,t_val)
      GET BOUNDS if  a(comma)
      type = newatype(type,range)
    end

    cycle
      type = d_type
      get IDENTLIST
      dlim1 = dlim
      get(left)
      GET BOUNDS
      get(right)
    !  %if hold = 0 = item {both literal} %and np = np0 {1-dim} %c
    !  %and elements <= 32767 {safe to multiply?} %c
    !  %and (elements*dsize*(dlim-dpos))<<1-c_sp-c_delta <= 32000 %start
    !     d_par = parref(inty,0,r,0)
    !  %finish %else %start
    !    put bound pair
    !     d_par = 0
    !    i = np
    !    %while i # np0 %cycle
    !      i = i-1
    !       d_par = parref(inty,0,exp(i)_act,d_par)
    !    %repeat
    !    exp(np0)_act = adecl
    !  %finish
    !  i = np
      while  dlim0 # dlim1 cycle
    !    %if i = np0 %start
    !      c_delta = c_delta-elements*dsize
    !      c_delta = c_delta-1 %if c_delta&1 # 0
    !      dict(dlim0)_flags = dict(dlim0)_flags!static
    !    %finish %else %start
    !      np = i;  compile(np0,np0)
    !      c_flags = c_flags!dynarray
    !    %finish
    !    dict(dlim0)_val = c_sp+c_delta
        dict(dlim0)_type = type
        dlim0 = dlim0+1
      repeat
    repeat  until  not  a(comma)
    end ;  !get BOUNDS

    routine  GET PARMDEF
    integer  headitem,dpos,dlim1
    record (identinfo)name  headditem,dp
    integerfn  PARMMATCH(integer  apos)
    integer  bpos
    record (identinfo)name  ap,bp
      bpos = dlim1
      ap == dict(apos)
      while  bpos # dlim cycle
        result  = 0 if  ap_flags&more = 0
        apos = apos+1 and  ap == dict(apos) until  ap_flags&parm # 0
        bp == dict(bpos)
        result  = 0 if  ap_type # bp_type;  !for now
        bpos = bpos+1
      repeat
      result  = 1 if  ap_flags&more = 0
      result  = 0
    end
    !
      headitem = item;  headditem == ditem
      dlim1 = dlim
      if  a(left) start
        cycle
          get TYPE(parm!more) if  atom # ident
          if  d_flags&proc = 0 start
            get IDENT
            exit  if  not  a(comma) and  atom = right
            if  atom # comma then  nonstandard(nocomma) c
            else  atom = next atom
          finish  else  start
            get IDENT
            speccing = speccing+2
            get PARMDEF
            speccing = speccing-2
            exit  if  not  a(comma)
          finish
        repeat
        dict(dlim-1)_flags = dict(dlim-1)_flags-more
        get(right)
      finish
      if  speccing >= 2 start
        dpos = dictmin
        cycle
          dp == dict(dpos)
          if  dp_flags&proc # 0 and  dp_type = headditem_type start
            if  parmmatch(dpos) # 0 start
              headditem_type = dpos;  dlim = dlim1
              return
            finish
          finish
          dpos = dpos+1
        repeat  until  dpos >= headitem
        fault(caterr);  dlim = dlim1
        return
      finish
      if  speccing = 0 and  headditem_flags&spec # 0 start
        headditem_flags = headditem_flags-spec
        fault(matcherr) if  parmmatch(headitem) = 0
      else
        headditem_flags = headditem_flags!more if  dlim # dlim1
      finish
    end ;  !get PARMDEF

    initial(keylabel):  nonstandard(klabel)
      d_flags = lab+spec;  d_type = nulltype
      get IDENTLIST
      -> term

    initial(prefix):
      d_flags = subatom;  ! !wflag!okflag
    !  fault(prefix<<8) %if d_flags&extmask # 0
      atom = next atom
    initial(krange): initial(keylong):
    initial(keyinteger): initial(keyreal):
    initial(keystring):  initial(keyrecord):
    initial(rpred):
      matched = 0
      get TYPE(d_flags)
      if  a(keyspec) start
        if  a(left) start
          get LITINT;  get(right)
          declmode = declmode&sizemask+absmode
          d_val = t_val
          get IDENT
          speccing = 1 and  get PARMDEF if  d_flags&proc # 0
          -> term
        finish
        d_flags = d_flags+spec
        get IDENTLIST and  -> term if  d_flags&proc = 0
      finish
      if  d_flags&proc # 0 start
        get(ident)
        if  item >= c_localdpos and  ditem_type = d_type c
        and  ditem_flags&proc # 0 start
          if  ditem_flags&spec = 0 or  d_flags&spec # 0 start
            item = 0;  d_flags = d_flags+alt
            declare
          finish
        finish  else  declare
        get LITSTRING if  d_flags&ext # 0 and  a(alias)
        if  d_flags&spec # 0 start
          speccing = 1
          get PARMDEF
        finish  else  start
          open block(item)
          get PARMDEF
          c_parlim = dlim
          compile entry
          get(terminator)
          get STATEMENTS(end)
    !      %if c_access > 0 %start
    !        report(noresult,0) %if c_type > nulltype;  !fn/map/pred
    !      %finish
          close block
        finish
      else  if  d_flags = typeid {dealt with}
      else  if  d_flags&parm # 0;  !array
        d_flags = d_flags-parm
        if  d_flags&static # 0 start
          get OWN ARRAY DECLARATION
        finish  else  start
          if  d_flags&static = 0 and  c_flags >= hadon start
            fault(ordererr);  c_flags = c_flags&(\(hadon+hadinst))
          finish
          get ARRAY DECLARATION
        finish
      else  if  d_flags = static {const}
        d_type = dict(d_type&puretype)_type
        d_type = d_type+direct if  d_type = recy or  d_type = stringy
        cycle
          get IDENT
          syntax error if  not  a assop
          get LITERAL(d_type)
          faultnum = rangerr+point+warn if  faultnum = rangerr+point
          dict(dlim-1)_val = t_val
        repeat  until  not  a(comma)
      else  if  d_flags&static # 0 {own}
    !    constad == ownad;  constbound = finalbound
        declmode = declmode+ownmode
        cycle
    !      constad = constad+1 %if constad&1 # 0 %and dsize # 1
    !      t_val = constad-ownbase
          get IDENT
          t_val = 0
          if  a assop start
    !        %if d_flags&direct = 0
            get LITERAL(d_type)
            faultnum = rangerr+point+warn if  faultnum = rangerr+point
          finish
          elements = 1
        !      plant const(t_val,1)
        repeat  until  not  a(comma)
      else ;      !dynamic variable
    !    declmode = declmode+dispmode+level
        if  d_flags&static = 0 and  c_flags >= hadon start
          fault(ordererr);  c_flags = c_flags&(\(hadon+hadinst))
        finish
        cycle
    !problematic c_delta = c_delta-1 %if c_delta&1 # 0 %and dsize # 1
          c_delta = c_delta-dsize
          c_delta = c_delta-1 if  c_delta&1 # 0
          t_val = c_sp+c_delta
          get IDENT
          if  a assop start
            nonstandard(initass)
            if  d_type >= indirect start
              fault(caterr+point) if  atom # eqeq
              get REFERENCE(d_type)
              item = item+ad if  item # 0
    !          put3(assign,dlim-1+ad,item)
            finish  else  start
              fault(caterr+point) if  atom = eqeq
              get VALUE(d_type)
    !          put2(assign,dlim-1)
            finish
    !        compile(np0,np0)
          finish
        repeat  until  not  a(comma)
      finish
      -> term

    routine  GET SWITCH DECLARATION
    integer  i,j,dlim1
      matched = 1
      cycle
        d_flags = lab;  d_type = nulltype
        declmode = pcmode+wordsize<<sizeshift
        get IDENTLIST
        dlim1 = dlim
        get LITBOUNDS
        cycle ;  !For each ident in group
          exit  if  spc-elements <= 0;  !ignore if too many
          for  i = 1,1,elements cycle
            spc = spc-1;  final(spc) = 0
          repeat
          dict(dlim0)_val = spc
          dict(dlim0)_type = item
          dlim0 = dlim0+1
        repeat  until  dlim0 = dlim1
      repeat  until  not  a(comma)
    end
    initial(keyswitch):
      get SWITCH DECLARATION
      ->term

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!  Control statements  !!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    initial(keycontrol):
      get LITINT
      control = 0 if  t_val = 0
      control = control!!t_val
      ->term

    initial(include):
      get LITSTRING
      extra_name = ""
      while  t_val > 0 cycle
        extra_name = extra_name.tostring(byteintegeR(atomp))
        atomp = atomp+1;  t_val = t_val-1
      repeat
      get(terminator)
      if  faultnum = 0 start
        connect edfile(extra)
        nonstop = -999 and  signal  12 if  extra_flag # 0
        mainfp = fp;  mainline = line
        line = 0;  sym = nl
        fp = extra_start2;  curstart = fp;  curlim = extra_lim2
        modesym = '&';  nonstop = nonstop+1
      finish
      ->next

    initial(keylist):
      ->term

    initial(begin):
      c_sp = -8
      get(terminator)
      open block(0)
      get STATEMENTS(0)
      close block
      -> term if  stopper >= 0
      return

    initial(end):
      if  not  a(of) start
        fault(nofinish) if  stopper = else or  stopper = finish
        fault(norepeat) if  stopper = repeat
        return  if  stopper >= 0
        fault(nobegin)
        ->term
      finish
      if  a(keylist) start
        ->term
      finish
      if  a(keyfile) start
        if  curlim = extra_lim2 start
          switch input
          ->next
        finish
      finish  else  get(program)
    end ;  !GET STATEMENTS

    routine  INIT(integer  t,l,h)
      d_flags = typeid;  d_type = t;  d_low = l;  d_val = h
      dict(dlim) = d;  dlim = dlim+1
    end

    on  event  12 start
      -> printout if  fp = main_lim2
      -> ended if  main_flag < 0 or  nonstop = -999;  !abandon or CROAK
      change = main_change
    finish

      printstring("  IMP Checker  ");  newline
      hashindex(i) = 0 for  i = 0,1,255;  !hash table empty
      charbase = addr(char(0));  byteinteger(charbase) = 0;  !for anon ident
      charlim = charbase+1
      charmin = charlim+charbound;  !(1 over top)
      dict(i)_val = 0 for  i = d0,1,labmax
      d_flags = typeid;  d_low = minint;  d_val = maxint
      dmin = dictmax-1;  dlim = dictmin
      cycle
        d_type = dlim;  dict(dlim) = d
        dlim = dlim+1
      repeat  until  dlim > booltype
      d_flags = 0
      init(booltype,0,0)
      init(booltype,0,1)
      d_flags = typeid
      init(inty,minint,maxint)
      init(inty,-32768,32767)
      init(inty,0,65535)
      init(inty,0,255)
      init(inty,-128,127)
      init(inty,0,1)
      init(inty,minint,maxint)
      init(realy,minint,maxint)
      init(realy,minint,maxint)
      c = 0;  c_localdpos = dlim;  c_parlim = dlim
      level = outerlevel
      spc = finalbound
      faults = 0;  line = 0;  mainline = 0
    !
      mainfp = main_start1
      extra_name = permfile
      connect edfile(extra)
      nonstop = -999 and  signal  12 if  extra_flag # 0
      fp = extra_start2;  curstart = fp;  curlim = extra_lim2
      nonstop = -2;  nonstop = -1 if  main_flag = 'I'
      sym = nl
      get STATEMENTS(-1)
    !  report(noend,0) %if level < mainlevel
    !  report(nobegin,0) %if level > mainlevel
    !  compile end %while level >= mainlevel
    printout:
    !  time2 = cputime
      if  faults = 0 start
        write(statements,1)
        print string(" statements checked  ")
      finish  else  start
        write(faults,1)
        print string(" fault")
        put sym('s') if  faults > 1
        print string(" reported  ")
      finish
      newline
    ended:
      newline;  !*for now to ensure message not erased*
    !  %if control&logbit # 0 %start
    !!    write(zaps,1);  print symbol('Z')
    !    write(statements,1);  print symbol('S')
    !    statements = 1 %if statements = 0
    !    atoms = atoms+statements
    !    print(atoms/statements,1,1);  print symbol('A')
    !    print(numatoms/statements,1,1);  print symbol('N')
    !    print(identatoms/statements,1,1);  print symbol('I')
    !    print(misses/identatoms,1,2);  print symbol('H')
    !    print((time2-time1)/statements,3,3);  print symbol('M')
    !!    write(finalad,1);  print symbol('B')
    !!    write(ownad-ownbase,1);  print symbol('O')
    !    newline
    !  %finish

    end ;  !of ECCECI
    endoffile