%begin

!!%external%string(255)%fn%spec cliparam
!!%external%integer%fn%spec cputime

%external%routine%spec open output(%integer stream, %string (255) s)

%const %integer TRUE = 1, FALSE = 0

%string(255)cliparam; cliparam = "adec"

!$IF ECSVAX
{%conststring(51) title = %c
{"  EUCSD IMP Compiler for M68000.  VAX Version  2.2g"
!$IF APM
%conststring(51) title = %c
"  EUCSD IMP Compiler for M68000.  APM Version  2.2g"
!$FINISH
!
! Hamish Dewar  Computer Science   Edinburgh University  1982/83/84
!
%constinteger WHICH=M'.imp'

!<<BOTH [markers for parts common to Pascal]

!General notes:
!  The main data structure DICT is used for identifier, type, label
!  and expression representation (with some aliasing).  The fixedsize
!  cell has a number of advantages which outweigh the Procustean factor
!  (and the 16-byte size is efficiently addressed)
!
!  Major routines (like EVAL) which have variables heavily used by
!   nested routines are not placed below level 1 for efficiency of
!   addressing.  (Making the compiler an external procedure rather
!   than a main program would seriously impact this efficiency).
!
!!!!!!!!!!!!!!!!!!  File handling definitions  !!!!!!!!!!!!!!!!!!!!!
!
%constinteger MAXNAME=127
%string(maxname) MAINFILE,OBJFILE

! Editor-compatible file-mapping record:
%recordformat EDFILE(%integer start1,lim1, {part 1}
                              start2,lim2, {part 2}
                              lim, {VMLIM}
                              lbeg,fp,change,flag,
                              line  {line number of current pos},
                              diff  {diff between LINE and ROW},
                       %byte  top  {top row of sub_window},
                              win  {floating top},
                              bot  {bottom row 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)
{PAM: parameter acquisition module}
%constinteger NEWGROUP=1, NODEFAULT=2
!!%external%routine%spec DEFINE PARAM %alias "PAM_DEFSTRING" %c
!!          (%string(255) name, %name variable, %integer flags)
!!%external%routine%spec DEFINE INT PARAM %alias "PAM_DEFINT" %c
!!          (%string(255) name, %name variable, %integer flags)
!!%external%routine%spec DEFINE BOOLEAN PARAMS %alias "PAM_DEFBOOL" %c
!!    (%string(255) name, %name variable, %integer flags)
!!%external%routine%spec PROCESS PARAMETERS %alias "PAM_PROCESS"(%string(255)!! parm)
!!%external%routine%spec CONNECT EDFILE(%record(edfile)%name f)
!!%external%routine%spec DISCONNECT EDFILE(%record(edfile)%name f)
!!%external%string(8)%fnspec DATE
!!%external%string(5)%fnspec TIME

%string(8) DATE; DATE = "02/02/02"
%string(5) TIME; TIME = "02:02"
%integer CPUTIME; CPUTIME = 123
!
%owninteger ITEM=0;                ![high-frequency]
%owninteger LISTOUT=0 {set to 2 if listing to file}
!!  Compiler control

%constinteger ARRBIT=   16_80000000 {array bound check}
%constinteger LOOPBIT=  16_40000000 {%for loop check}
%constinteger CAPBIT=   16_20000000 {capacity check}
%constinteger OVERBIT=  16_10000000 {overflow check}
%constinteger ASSBIT=   16_08000000 {integer-unassigned check}
%constinteger STRASSBIT=16_04000000 {string-unassigned check}
%constinteger SASSBIT=  16_02000000 {short-unassigned check}
%constinteger BASSBIT=  16_01000000 {byte-unassigned check}
%constinteger ASSMASK=assbit!strassbit!sassbit!bassbit
%constinteger LINEBIT=  16_00800000 {set line number}
%constinteger DIAGBIT=  16_00400000
%constinteger TRACEBIT= 16_00200000 {plant TRAP 15}
%constinteger STACKBIT= 16_00100000 {stack over-run check}
%constinteger CHECKBIT= 16_00080000 {for NOCHECK}
%constinteger SYSBIT=   16_00040000 {special treatment of SIGNAL}
%constinteger STRICTBIT=16_00020000
%constinteger VOLBIT   =16_00010000
%constinteger HALFBIT=  16_00008000 {halfword MULT/DIV}
%constinteger LOWBIT  = 16_00004000 {low-level features permitted}
%constinteger EDITBIT=  16_00002000
%constinteger RUNBIT=   16_00001000
%constinteger FORCEBIT= 16_00000800
%constinteger LOGBIT=   16_00000400 {print log}
%constinteger WARNBIT=  16_00000200 {print warnings}
%constinteger NONSBIT=  16_00000100 {nonstandard features permitted}
%constinteger PERMBIT=  16_00000080 {for PRIM compilation}
%constinteger NEWBIT=   16_00000040 {Pascal: new treatment of pointers}
%constinteger CODELIST= 16_00000020 {list code}
%constinteger DICTLIST= 16_00000010 {list dict entries}
%constinteger EXPLIST=  16_00000008 {list EXP entries}
%constinteger MAPLIST=  16_00000004 {print space map}
%constinteger TTLIST=   16_00000002 {list to terminal}
%constinteger LIST=     16_00000001 {do list}

	      
%constinteger LISTBITS=codelist+dictlist+explist+maplist+ttlist+list
%owninteger CONTROL=warnbit+checkbit+linebit+diagbit+editbit+volbit %c
                   +strassbit+assbit+arrbit+loopbit+capbit+stackbit
%integer INITCON,TIME1,TIME2
!Events:-
%constinteger OFLOW=1, FAIL=11, DONE=12, REDO=13, ABANDON=14
!
!
%constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT
%constinteger SIGN16=\16_7FFF, SIGN=\16_7FFFFFFF
!
!!!!!!!!!!!!!!!!   Operand Representation  !!!!!!!!!!!!!!!!!!!
! Operands (largely, Expressions) are denoted by integers in a
! contiguous range as follows:
! 
! <= 0  Literals (including 'addresses' within FINAL)
!       [see LITREF and LITVAL for interpretation]
!                                    Dictionary
!                   __16___16____16____8____8____32____16___16__
! [dummy @ 0] ->    |flags|type| link| reg|mode|value|text|hlink|
! D0 [@1]  ->  R    |     |    | size|    |    |     |    |    |
!                   |     |    |xtype|    |    |     |    |    |
! D7       ->       |     |    |     |    |    |     |    |    |
! A0       ->  E    |     |    |     |    |    |     |    |    |
!                   |     |    |     |    |    |     |    |    |
! A7       ->  G    |     |    |     |    |    |     |    |    |
! INDA0    ->       |     |    |     |    |    |     |    |    |
!              S    |     |    |     |    |    |     |    |    |
! PREA7    ->       |     |    |     |    |    |     |    |    |
!              I    |     |    |     |    |    |     |    |    |
!              D    |     |    |     |    |    |     |    |    |
!              E    |     |    |     |    |    |     |    |    |
!              N    |     |    |     |    |    |     |    |    |
!              T    |     |    |     |    |    |     |    |    |
!              S    |     |    |     |    |    |     |    |    |
!                   |_____|____|_____|____|____|_____|____|____|
! DICTLIM  ->       | --  |--  |  -- | -- |mode|value| -- | -- |
!              C L  |     |    |     |    |    |     |    |    |
!              O A  |     |    |     |    |    |     |    |    |
!              M B  |     |    |     |    |    |     |    |    |
!              P S  |     |    |     |    |    |     |    |    |
!                   |_____|____|_____|____|____|_____|____|____|
! LABLIM   ->       |flags|type| act |----|mode|value|arg1|arg2|
!              C    |     |    |     |    |    |     |    |    |
!              O    |     |    |     |    |    |     |    |    |
!              M E  |     |    |     |    |    |     |    |    |
!              P X  |     |    |     |    |    |     |    |    |
!              L P  |     |    |     |    |    |     |    |    |
!              E S  |     |    |     |    |    |     |    |    |
!              X    |_____|____|_____|____|____|_____|____|____|
! EXPLIM   ->

%constinteger SMALLMIN=-1024, SMALLMAX=1023,
              LITMAX=smallmin-(smallmax+1), LITMIN=litmax-199,
              LITMITE=-255, LITQUICK=-16, ONE=-(1<<1)
%constinteger D0=1, D1=d0+1, D2=d0+2, D7=d0+7,
              A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7,
              INDA0=a0+8, INDA7=inda0+7,
              POSTA0=inda0+8, POSTA7=posta0+7,
              PREA0=posta0+8, PREA7=prea0+7,
              UNDEF=a7
%owninteger   DICTLIM=1000, FINALBOUND=64  {see Init for adjustment}
%integer      LABLIM,NP0,EXPLIM {continuing from DICTLIM}
%integer      CHARBOUND         {derived from DICTLIM}
%constinteger LABELS=42 {enough for Pascal reserveds},
              TRIPLES=200
%constinteger AD=16384  {any item + AD >= EXPLIM}

%constinteger BREG=D0+4, LINELOC=d0+5
%constinteger F1=a0+6, GB=a0+5, MB=a0+4;  !level 1, global base, main base
%constinteger MAXDREG=d0+3, MAXAREG=a0+3
%constinteger D0B=1, D1B=2, D2B=4, BREGB=16,
              A0B=16_100, A1B=16_200, A2B=16_400
%constinteger ANYDREG=16_00FF-bregb, ANYAREG=16_FF00,
              ANYREG=16_FFFF
%constinteger DEFAULTFREE=2<<(maxdreg-d0)-1+(2<<(maxareg-a0)-1)<<8+bregb
%integer MAXCALLDREG, MAXCALLAREG
%integer FREE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!   Big Literals  !!!!!!!!!!!!!!!!!!!!!!!
%integer LITPOS
%integerarray LITSTORE(litmin:litmax)
!
!!!!!!!!!  Registers, Identifiers, Labels, Expressions  !!!!!!!!!
!
!   Operand attributes:
%recordformat OBJINFO %C
  (%short FLAGS,TYPE,
   (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT),
   %byte REG,MODE,
   %integer VAL)
%recordformat IDENTINFO %C
  ((%short FLAGS,TYPE,
   (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT),
    %byte REG,MODE,
    %integer VAL %or %record(objinfo) DETAILS),
   (%short   TEXT,HLINK %or %short X,Y))
!
!Machine addressing modes:
%constinteger AREGMODE=2_001000,
              DISPMODE=2_101000, INDEXMODE=2_110000, ABSMODE=2_111000,
              PCMODE=2_111010, LITMODE=2_111100
!Conversion factors for address register modes (from AREGMODE)
%constinteger INDIR=8, POST=16, PRE=24
!Additional source-related modes:
%constinteger LABMODE=2_10000000+pcmode,
              PROCMODE=2_11000000+pcmode,
              GLOBALMODE=dispmode+(gb-a0),
              OWNMODE=2_01000000+dispmode+(mb-a0),
              CONSTMODE=2_01000000+pcmode,
              FRAMEMODE=2_10000000+dispmode
!                      +  01000000 for dynamic array
!
! MODE,VAL:
!  %const simple       : LITMODE     the actual value
!  %const structure    : CONSTMODE   address in code area
!  variable etc        : mode        byte address/displacement
!  undefined label     : LABMODE     reference chain
!  undefined procedure : PROCMODE    reference chain
!  record format       : 0           size of record in bytes
!
! Significance of FLAGS:
%constinteger CAT     =16_000F, {category: typeid only}
              WRITABLE=16_0001,
              READABLE=16_0002, {not write only}
              VOLATILE=16_0004,
              ARRFLAG =16_0008, {bound check needed}
                ALT   =16_0008, {alternative proc}
              WFLAG   =16_0010, {has been written to}
              RFLAG   =16_0020, {has been read from}
              OKFLAG  =16_0040, {no unassigned check needed, CC OK for fun}
                NORET =16_0040, {routine does not return}
              MFLAG   =16_0080, {has had mem access}
              SPEC    =16_0100, {unbodied spec or forward label}
              TYPEID  =16_0200, {type identifier}
              PACKED  =16_0400,
              INDIRECT=16_0800,
              PROC    =16_3000, {procedure not data}
                PROC1 =16_1000,
                PROC2 =16_2000,
              EXT     =16_4000, {external}
              NAME    =sign16
%constinteger HERITABLE=writable+readable+volatile %c
                       +wflag+rflag+okflag+arrflag
!
!CATegories (type identifiers only):
%constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3,
              POINTY=4, REALY=5,
              STRINGY=8, ARRY=9, SETY=10,
              RECY=12, FILEY=13,
              NONORD=12

%ownrecord(objinfo) DEFINEDLABEL=0,
                    FORWARDLABEL=0,
                    BEGINBLOCK=0,
                    TYPEIDENT=0
!!!!!!!!!!!!!!!!!  File and control initialisation  !!!!!!!!!!!!!!!
!
%constinteger MAIN=1
%record(edfile)%array FILE(1:3)
%record(edfile)%name CUR
%integerarray FCONTROL(1:3)
%integer CURFILE,LASTFILE;      !current source file no (0:3)
%integer CURSTART,CURLIM;        !current source file bounds

%routine SET OPTIONS(%string(255) parm)
%owninteger remove warning
%constinteger CHECKS=assmask+arrbit+loopbit+capbit+overbit
!!  define boolean params( %c
!!  "ARR,LOOP,CAP,OVER,ASS,STRASS,SASS,BASS,LINE,DIAG,TRACE,STACK,".%C
!!  "CHECK,SYS,STRICT,VOL,HALF,LOW,EDIT,RUN,FORCE,LOG,WARN,NONS,PERM,NEW,".%C
!!  "CODE,DICT,EXP,MAP,TT,LIST",control,0)
!!  process parameters(parm)
  remove warning = ADDR(parm)
 !NOCHECK => removal of checkbits
  control = control&(\checks) %if control&checkbit = 0
  control = control&(\editbit) %if control&listbits # 0
%end

%routine SET EXTENSION(%string(maxname)%name f,%string(4) ext)
%integer strip
%integer%fn last4(%string(*)%name s)
%integer i,e
  i = 0;  e = 0
  %while i < length(s) %cycle
    i = i+1;  e = e<<8+charno(s,i)
  %repeat
  %result = e
%end
  strip = last4(ext)
  f = mainfile %and strip = which %if f = ""
  length(f) = length(f)-4 %if last4(f)!16_202020 = strip
  f = f.ext
%end


%routine OPEN FILES
%string(maxname) LISTFILE; LISTFILE=""
  objfile = ""
!!  define param("SOURCE",mainfile,nodefault)
!!  define param("OFILE",objfile,newgroup)
!!  define param("LFILE",listfile,0)
!!  define int param("IDents",dictlim,newgroup)
!!  define int param("KBytes",finalbound,0)
  file(main) = 0
  set options(cliparam)
  control = control&(\linebit) %if control&diagbit = 0;  !*temp*
!Main file
  file(main)_name = mainfile;  file(main)_flag = 32768
  time1 = time1-cputime
!!  connect edfile(file(main))
  time1 = time1+cputime
  %stop %if file(main)_flag # 0

!Listing file
  %if listfile # "" %or control&(list+ttlist) # 0 %start
    %if control&ttlist = 0 %start
      set extension(listfile,".lis")
      listout = 2
      open output(listout,listfile)
    %finish
    control = control&(\(editbit+ttlist))
    control = control!list %if control&listbits = 0
  %finish
  select output(listout)
  %if control&listbits # 0 %start
    control = control!list %if control&listbits # maplist
    newlines(2)
    printstring(title)
    newlines(2)
    printstring("   ");  printstring(file(main)_name)
    printstring("  compiled on ");  printstring(date)
    printstring("  at  ");  printstring(time)
    newlines(2)
  %finish
  initcon = control
%end

  time1 = 0
  open files
  dictlim = dictlim+300;  !allow for presets
  charbound = dictlim*8
  finalbound = finalbound<<10+4095;  !kilobytes -> bytes + (min) owns
  lablim = dictlim+labels
  explim = lablim+triples
  np0 = lablim+4
  file(main)_change = 16_7FFFFFFF
  forwardlabel_flags = spec;  forwardlabel_mode = labmode
  definedlabel_mode = labmode
  beginblock_mode = procmode
  typeident_flags = typeid+recy
!
!!!!!!!!!!!!!!!!  end of file and control initialisation  !!!!!!!!
!
%record(identinfo)%array DICT(0:explim-1)
!  indexing DICT:
%integer DLIM;         !dict limit (up)
%integer DLIM0
%integer DMIN;       !dict upper limit (down)
%integer DMIN0
%integer DICTSHOWN
%integer INCLIM
%record(identinfo)%name DLINK,DFORMAT,DTEMP,DTEMP2,DTSPREL,DINT
%integer SUBBED
%integer RANGES

! The identifier dictionary grows as declarations are
! encountered, sequentially from 0 up, so that the
! identifiers within a declaration group and within any block
! are contiguous and may be processed thus (eg at block end).
! However, searching is always through the hash links, with a
! start-point given by the array HASHINDEX.  The final link
! value is zero.
!  Identifiers are normally added at the start of the hash list
! (hence pushing down any global instance of the same name),
! but identifiers which have been reported as 'not declared'
! are added at the end of the list, using a negative link value.
! This tail section is used to avoid repeated reports for the
! same name (and is ultra-global, ie never removed).
!
! For record formats, the format name is stored in the usual way
! and contains in LINK a pointer to the field-names which are linked
! through what is normally the hash link.  Searching for field-names
! proceeds along this chain, as if following hash links.
!
!  HLINK is the hash link (index to DICT)
!
!  TEXT is the pointer (index to CHAR) to the text of the identifier
!       stored as a standard string

!  Text of identifiers (indexed by _TEXT):
%bytearray CHAR(0:charbound)
%integer CHAR0,CHARLIM,CHARMIN;  !pointers
%integer NEWLEN

!  Hash index to DICT:
%shortarray HASHINDEX(0:255)
%shortname HEAD;                  !head of ident search list
!
!
!<<IMP

!* PRIMGEN marker 1
%constinteger NULL=41
%constinteger PROCSTAR=42
%constinteger INTTYPE=43
%constinteger SHORTTYPE=46
%constinteger HALFTYPE=49
%constinteger BYTETYPE=52
%constinteger MITETYPE=55
%constinteger BOOLTYPE=58
%constinteger CHARTYPE=61
%constinteger STRINGSTAR=62
%constinteger STRING1=63
%constinteger STRINGTYPE=64
%constinteger ARRSTAR=65
%constinteger NULLSETTYPE=66
%constinteger RECSTAR=67
%constinteger REALTYPE=69
%constinteger SIGNAL=73
%constinteger DADDR=74
%constinteger DSIZEOF=77
%constinteger INDEX=78
%constinteger LENREF=79
%constinteger SINDEX=82
%constinteger IMUL=86
%constinteger IDIV=87
%constinteger IPOW=88
%constinteger FNEG=89
%constinteger FADD=90
%constinteger FSUB=91
%constinteger FMUL=92
%constinteger FDIV=93
%constinteger FPOW=94
%constinteger FLOAT=95
%constinteger DREM=98
%constinteger UNASS=102
%constinteger ADOK=103
%constinteger STACKOK=104
%constinteger ASIZE=105
%constinteger CONCAT=106
%constinteger DTOSTRING=107
%constinteger AGET=109
%constinteger FOROK=110
%constinteger CHECK=111
%constinteger SCOMP=112
%constinteger STRCOPY=113
%constinteger STRTOSTK=114
%constinteger DNEW=115
%constinteger RESOLVES=117
%constinteger DEVENTF=128
%constinteger DEVENT=134
%constinteger DNIL=137
%constinteger DPRINTSTR=155
%constinteger DWRITE=183

%constinteger OPMAX=resolves

%routine SET HASHHEAD(%string(*)%name s)
%integer h,i
  h = 0
  h = h<<1!!charno(s,i) %for i = 1,1,length(s)
  head == hashindex(h&255)
%end

%routine PRESET
!* PRIMGEN marker 2
%const%integer CMAX=775
%OWN%byte%array CHARINIT(0:CMAX) = 
  0,
  2,'d','0',
  2,'d','1',
  2,'d','2',
  2,'d','3',
  2,'d','4',
  2,'d','5',
  2,'d','6',
  2,'d','7',
  2,'a','0',
  2,'a','1',
  2,'a','2',
  2,'a','3',
  2,'a','4',
  2,'a','5',
  2,'a','6',
  2,'a','7',
  7,'i','n','t','e','g','e','r',
  6,'M','A','X','I','N','T',
  12,'s','h','o','r','t','i','n','t','e','g','e','r',
  11,'h','a','l','f','i','n','t','e','g','e','r',
  11,'b','y','t','e','i','n','t','e','g','e','r',
  11,'m','i','t','e','i','n','t','e','g','e','r',
  7,'B','O','O','L','E','A','N',
  5,'F','A','L','S','E',
  4,'T','R','U','E',
  4,'c','h','a','r',
  6,'s','t','r','i','n','g',
  5,'a','r','r','a','y',
  6,'r','e','c','o','r','d',
  4,'T','E','X','T',
  4,'r','e','a','l',
  8,'l','o','n','g','r','e','a','l',
  6,'S','I','G','N','A','L',
  4,'a','d','d','r',
  6,'s','i','z','e','o','f',
  5,'I','N','D','E','X',
  6,'l','e','n','g','t','h',
  6,'c','h','a','r','n','o',
  4,'I','M','U','L',
  4,'I','D','I','V',
  4,'I','P','O','W',
  4,'F','N','E','G',
  4,'F','A','D','D',
  4,'F','S','U','B',
  4,'F','M','U','L',
  4,'F','D','I','V',
  4,'F','P','O','W',
  5,'f','l','o','a','t',
  3,'r','e','m',
  5,'U','N','A','S','S',
  4,'A','D','O','K',
  7,'S','T','A','C','K','O','K',
  5,'A','S','I','Z','E',
  6,'C','O','N','C','A','T',
  8,'t','o','s','t','r','i','n','g',
  4,'A','G','E','T',
  5,'F','O','R','O','K',
  5,'C','H','E','C','K',
  5,'S','C','O','M','P',
  7,'S','T','R','C','O','P','Y',
  8,'S','T','R','T','O','S','T','K',
  3,'n','e','w',
  8,'r','e','s','o','l','v','e','s',
  9,'s','u','b','s','t','r','i','n','g',
  7,'e','v','e','n','t','f','m',
  5,'e','v','e','n','t',
  3,'s','u','b',
  4,'l','i','n','e',
  5,'e','x','t','r','a',
  7,'m','e','s','s','a','g','e',
  5,'e','v','e','n','t',
  2,'n','l',
  3,'s','n','l',
  3,'n','i','l',
  7,'d','i','s','p','o','s','e',
  5,'r','o','u','n','d',
  5,'t','r','u','n','c',
  8,'f','r','a','c','t','i','o','n',
  3,'i','n','t',
  5,'i','n','t','p','t',
  6,'f','r','a','c','p','t',
  4,'s','q','r','t',
  10,'n','e','x','t','s','y','m','b','o','l',
  10,'r','e','a','d','s','y','m','b','o','l',
  10,'s','k','i','p','s','y','m','b','o','l',
  11,'p','r','i','n','t','s','y','m','b','o','l',
  11,'p','r','i','n','t','s','t','r','i','n','g',
  9,'o','p','e','n','i','n','p','u','t',
  10,'o','p','e','n','o','u','t','p','u','t',
  11,'s','e','l','e','c','t','i','n','p','u','t',
  12,'s','e','l','e','c','t','o','u','t','p','u','t',
  8,'s','e','t','i','n','p','u','t',
  9,'s','e','t','o','u','t','p','u','t',
  10,'r','e','s','e','t','i','n','p','u','t',
  11,'r','e','s','e','t','o','u','t','p','u','t',
  10,'c','l','o','s','e','i','n','p','u','t',
  11,'c','l','o','s','e','o','u','t','p','u','t',
  6,'p','r','o','m','p','t',
  7,'n','e','w','l','i','n','e',
  5,'s','p','a','c','e',
  6,'s','p','a','c','e','s',
  8,'n','e','w','l','i','n','e','s',
  4,'r','e','a','d', 138,'r','e','a','d','s','t','r','i','n','g',
  4,'r','e','a','d', 136,'r','e','a','d','r','e','a','l',
  4,'r','e','a','d',
  5,'w','r','i','t','e',
  7,'c','p','u','t','i','m','e',
  5,'p','r','i','n','t',
  7,'p','r','i','n','t','f','l',
  8,'i','n','s','t','r','e','a','m',
  9,'o','u','t','s','t','r','e','a','m',
  8,'c','l','i','p','a','r','a','m',
0
%constinteger PREMAX=196
%own%short%array DICTINIT(41*6:PREMAX*6+5) = 
 516,-1,0,0,0,0,
 527,-1,0,0,0,4,
 512,43,4,56,-32768,0,
 0,-44,4,60,-32768,0,
 0,43,4,60,32767,-1,
 512,43,2,56,-32768,0,
 0,-44,2,60,-1,-32768,
 0,-44,2,60,0,32767,
 512,43,2,56,-32768,0,
 0,-44,2,60,0,0,
 0,-44,2,60,0,-1,
 512,43,1,56,-32768,0,
 0,-44,1,60,0,0,
 0,-44,1,60,0,255,
 512,43,1,56,-32768,0,
 0,-44,1,60,-1,-128,
 0,-44,1,60,0,127,
 514,58,1,0,0,0,
 0,58,1,60,0,0,
 0,58,1,60,0,1,
 513,61,255,0,0,0,
 520,61,0,0,0,0,
 520,-62,-2,0,0,0,
 520,-62,-256,0,0,0,
 521,0,0,0,0,0,
 522,-1,0,0,0,0,
 524,0,0,0,0,0,
 525,61,4,0,0,0,
 517,0,4,0,0,0,
 517,0,4,0,0,0,
 0,-1,0,0,0,0,
 0,-1,0,0,0,0,
 4256,42,0,56,0,16122,
 4098,75,0,56,0,0,
 0,-44,76,0,0,4,
 -32701,-1,0,6313,-1,-4,
 4098,75,0,56,0,0,
 4096,42,0,56,-32767,2861,
 4099,80,0,56,0,0,
 0,-53,81,6144,0,4,
 -32701,-63,0,6313,-1,-4,
 4099,83,0,56,0,0,
 0,-53,84,6144,0,4,
 -32701,-63,85,6313,-1,-4,
 67,-44,0,169,-1,-8,
 4256,42,0,56,0,16116,
 4256,42,0,56,0,16110,
 4096,42,0,56,0,16098,
 4096,42,0,56,0,16092,
 4096,42,0,56,0,16086,
 4096,42,0,56,0,16080,
 4096,42,0,56,0,16074,
 4096,42,0,56,0,16068,
 4096,42,0,56,0,16062,
 4098,96,0,56,0,16056,
 0,-70,97,0,0,4,
 67,-44,0,169,-1,-4,
 4098,99,0,56,0,0,
 0,-44,100,0,0,4,
 67,-44,101,169,-1,-4,
 67,-44,0,425,-1,-8,
 4096,42,0,56,-32722,2578,
 4096,42,0,56,-32704,2064,
 4096,42,0,56,-32688,2839,
 4096,42,0,56,-32665,3097,
 4096,42,0,56,-32640,2077,
 4098,108,0,56,-32611,6,
 0,-64,97,6144,0,4,
 4096,42,0,56,-32605,2597,
 4096,42,0,56,-32568,2334,
 4096,42,0,56,-32538,1806,
 4096,42,0,56,-32524,2626,
 4096,42,0,56,-32458,2070,
 4096,42,0,56,-32436,2090,
 4103,116,0,56,0,16008,
 0,-68,76,6144,0,4,
 22786,118,0,108,0,0,
 0,-59,119,0,0,0,
 -32701,-63,120,6313,-1,-4,
 67,-65,121,6569,-1,-260,
 -32701,-63,122,6825,-1,-264,
 -32701,-63,0,7081,-1,-268,
 4098,124,0,56,-32394,15,
 0,-65,125,6144,0,4,
 -32701,-63,126,6313,-1,-4,
 67,-44,127,169,-1,-8,
 67,-44,0,425,-1,-12,
 524,0,129,0,-1,-264,
 3,52,0,0,0,0,
 3,52,0,0,0,1,
 3,46,0,0,0,2,
 3,43,0,0,0,4,
 3,64,0,0,0,8,
 67,128,0,45,0,32,
 66,43,0,60,0,10,
 66,61,0,60,0,10,
 67,67,0,56,0,0,
 4096,139,0,56,0,16002,
 0,-1,76,0,0,4,
 4098,141,0,56,0,16050,
 0,-44,142,0,0,4,
 67,-70,0,169,-1,-4,
 4098,141,0,56,0,16044,
 4098,145,0,56,0,16038,
 0,-70,142,0,0,4,
 4098,141,0,56,0,16032,
 4098,141,0,56,0,16026,
 4098,145,0,56,0,16020,
 4098,145,0,56,0,16014,
 4098,132,0,56,0,15996,
 4098,132,0,56,0,15990,
 4096,42,0,56,0,15990,
 4256,154,0,56,0,15984,
 0,-1,97,0,0,4,
 4096,156,0,56,0,15978,
 0,-1,157,0,0,4,
 67,-65,0,6313,-1,-256,
 26880,159,0,108,0,0,
 0,-1,160,0,0,0,
 67,-44,161,169,-1,-4,
 67,-65,0,6313,-1,-260,
 26880,159,0,108,0,0,
 4096,154,0,56,0,15960,
 4096,154,0,56,0,15954,
 26880,166,0,108,0,0,
 0,-1,97,0,0,0,
 26880,166,0,108,0,0,
 26880,0,0,108,0,0,
 26880,0,0,108,0,0,
 4096,42,0,56,0,15936,
 4096,42,0,56,0,15930,
 26880,173,0,108,0,0,
 0,-1,157,0,0,0,
 4096,42,0,56,-32379,4,
 4096,42,0,56,-32375,4,
 22784,166,0,108,0,0,
 22784,166,0,108,0,0,
 22790,179,0,108,0,0,
 0,-65,0,6144,0,0,
 22798,181,0,108,0,0,
 0,-70,0,0,0,0,
 22798,1,0,108,0,0,
 22784,184,0,108,0,0,
 0,-1,100,0,0,0,
 26886,1,0,108,0,0,
 22784,187,0,108,0,0,
 0,-1,188,0,0,0,
 67,-70,189,169,-1,-4,
 67,-44,190,425,-1,-8,
 67,-44,0,681,-1,-12,
 22784,192,0,108,0,0,
 0,-1,193,0,0,0,
 67,-70,101,169,-1,-4,
 67,43,0,45,0,392,
 67,43,0,45,0,396,
 67,64,0,45,0,464

%integer i,ci,anons
%record(identinfo)%name dp

%routine PUT CHAR
  byteinteger(charlim) = charinit(ci)
  charlim = charlim+1;  ci = ci+1
%end

%routine TEXTSET(%record(identinfo)%name dp)
%integer len
  dp_hlink = 0
  %if dp_type < 0 %start;     !convention for *anon*
    dp_type = \dp_type
    dp_text = 0
    anons = anons-1
    dp_hlink = ranges %and ranges = dlim %if anons = 0 %and dlim <= mitetype+2
  %else
    dp_text = ci
    %if charinit(ci+1)&32 # 0 %start;  !not upper-case
      %if deventf < dlim < devent %start
        head = dlim;  head == dp_hlink
      %else
        set hashhead(string(addr(charinit(ci))))
        dp_hlink = head;  head = dlim
        head == dp_link %if dlim = deventf
      %finish
    %finish
    len = charinit(ci)
    put char %and len = len-1 %until len < 0
    len = charinit(ci)-128
    put char %and len = len-1 %while len >= 0
    anons = 2
  %finish
%end

  hashindex(i) = 0 %for i = 0,1,255;  !hash table empty
  byteinteger(char0) = 0;  !for anon ident
  charlim = char0+1
  charmin = charlim+charbound;  !(1 over top)
  ranges = 0

  ci = 1
  anons = 100
  dict(0) = 0
  dlim = d0
  %cycle
    dp == dict(dlim)
    %if dlim <= prea7 %start
      dp = 0
      dp_flags = okflag+writable+readable;  dp_mode = dlim-d0
      dp_type = inttype
      textset(dp) %if dlim <= a7
    %else
      dp_details = record(addr(dictinit(dlim*6)))
      textset(dp)
    %finish
    dlim = dlim+1
    %exit %if control&permbit # 0 %and dlim >= signal
  %repeat %until dlim > premax
  dictshown = dlim
  i = dictlim
  %cycle
    dp == dict(i)
    dp = 0
    dp_mode = labmode
    i = i+1
  %repeat %until i = np0
%end;  !preset

!<<BOTH

!  The last part of DICT (from LABLIM to EXPLIM) is used for
! the intermediate representation of the components of source
! statements between the recognition stage and the code generation
! stage.
!  The part from LABLIM+4 (NP0) up is used as a temporary pipeline
! for non-expression cells (instructions, conditions, etc)
! and the part down from EXPLIM for the canonical and
! persistent representation of expressions (including name
! expressions).
! In this part of the array the ident components PLIST (etc), TEXT
!  and HLINK are replaced by ACT, X and Y representing an operation
!  and (up to) two operands.
%integer EXPLO,OLDEXPLO
%integer NP,STARTNP

!Operator codes:
! Machine operator index values 1-31:
%constinteger MOVE=1, ADD=2, SUB=3
%constinteger CMP=4, AND=5, OR=6, EOR=7
%constinteger NOT=8, NEG=9, LSL=10, LSR=11
%constinteger MULS=12, DIVS=13, MULU=14, DIVU=15
%constinteger BRA=16, BSR=17
%constinteger BCC=20, BCS=21, BNE=22, BEQ=23
%constinteger BVC=24, BVS=25
%constinteger BGE=28, BLT=29, BGT=30, BLE=31
%constinteger COMPARE=cmp, GOTO=bra
! Other built-in operators
%constinteger JAMASS=32, OKASS=33, ASSIGN=34, INCASS=35
%constinteger FORASS=36, STOP=37, RETURN=38, REPEAT=39
%constinteger ELSE=40, JUMPOUT=41, SETTRAP=42, SWGOTO=43
%constinteger LABEL=44, RECREF=45, PREL=46, STOREMAP=47
%constinteger IABS=48, FABS=49, END=50
! PLUS OPERATORS DEFINED IN DICTIONARY > BOPMAX <= OPMAX
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%integer STARTS, CYCLES
%integer CURLAB
%integer PENDOUT, PENDCOND, PENDIN, POLARITY, CONDOP
%ownshortinteger EXTSPECS=0, EXTERNS=0
!
%recordformat CONTENTINFO(%short ccx,ccy,line,
                          %shortarray content(d0:a7))
%recordformat BLOCKINF(%integer sp, stack, extra, totstack, free, status,
                type, localdpos, parlim, localtext, localad, vintage,
                localpc, localswpc, pid, access, forward, lab1, looplab,
                eventsp, faults, return, shorts, temps,
                dynarray, oldcontrol, mode,val,
                %record(identinfo)%name dpid,
                %record(contentinfo) reg)
!STATUS flag bits
%constinteger UNKNOWN    =16_0002,
              WRONGCC    =16_0004,
              ONSTACK    =16_0008,
              GLOBBED    =16_0010,
              LABGLOBBED =16_0020, {Pascal}
              HADSPEC    =16_0040,
              HADSWITCH  =16_0080,
              HADON      =16_1000,
              HADORDERERR=16_2000,
              HADINST    =16_4000  {max flag}

%constinteger OUTERLEVEL=0, MAXLEVEL=7
%integer LEVEL;           !current block level
%integer VINTAGE;         !current block number
%record(blockinf) C;      !info for current block
%record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks
%record(contentinfo)%array LREG(0:labels)

! Code storage for currently open blocks
%constinteger PROGBOUND=16383
%shortarray PROG(0:progbound)
%bytearray PFLAG(0:progbound)
%constinteger SHORTJUMP=1, JUMP=2, LONGJUMP=3,
              GLOBAL=4, {NEGGLOBAL=5, BIGGLOBAL=6,} INDGLOBAL=7,
              ZEROSHORTS=8
%integer PC,SWPC
! Final core image
%bytearray FINAL(0:finalbound)
! Declaration records (to select relevant context)
%integer CAD,OWNAD,JOKERAD,OWNBASE
%integer FINAL0,ACCOUNTED
!
%integer FIRSTENTRY, FIRSTPOS

!Memo variables for current statement:-
%own%integer {ITEM,}TYPE=0,VALUE=0;      !current operand
%record(identinfo)%name DITEM
%integer SPECCING
%integer DUMP

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

!!  Source file input and listing
%owninteger ATOM=0;       !current lexical atom
%integer MATCHED;         !indic that atom has been matched
%integer SYM;             !current input symbol
%integer LINE;            !current line number
%owninteger CODEFLAG=' '; !or ^
%integer LISTFLAG;        !' ' or '&' or '+' or '"'
!   Pointers to source file:
%integer LINESTART
%integer FP;              !(file pointer) current position
%integer ATOMP;           !start of current atom
%integer EXPP
!
!! Utility routines

%integerfn IS SHORT(%integer v)
  %result = TRUE %if -32768 <= v <= 32767
  %result = FALSE
%end

%integerfn IS MITE(%integer v)
  %result = TRUE %if -128 <= v <= 127
  %result = FALSE
%end

%integer%fn MITE(%integer v)
  v = v&255;  v = v-256 %if v&128 # 0
  %result = v
%end

%record(identinfo)%map TYPECELL(%integer t)
  %result == dict(t)
%end

%integer%fn CATEGORY(%integer t)
  %result = dict(t)_flags&(packed+cat)
%end

%integer%fn LITVAL(%integer v)
  %result = v %if v = 0
  %if v > litmax %start;  !not stored literal
    %result = (-v)>>1 %if v&1 = 0
    %result = \((-v)>>1)
  %finish
  %result = litstore(v)
%end
!
!!!!!!!!!!!!!! Listing, diagnostic and report routines  !!!!!!!!!!!!!!
!
%integer FAULTS, OTHERS, FAULTNUM, FAULTP
!
!!  Program statistics
%integer STATEMENTS;           !statement count
%integer COMMENTS;             !comment count
%integer ATOMS;                !atom count
%integer IDENTATOMS;           !identifier count
%integer LITATOMS;             !numeric atom count
%integer ZAPS;                 !enforced cleardown of lits/exps
%integer STEPS;                !stepping stones inserted
!%integer MAXIDENTS, MAXCHARS, MAXLITS
%integer JUMPS,SHORTS
!
%string(255) REP
!
%routine PRINT LINE
  print string(rep);  print symbol(nl)
  rep = ""
%end
!
%routine PUT SYM(%integer k)
  rep = rep.tostring(k)
%end
!
%routine PUT STRING(%string(255) s)
  rep = rep.s
%end
!
!
%routine PUT NUM(%integer val)
%routine PD(%integer v)
  pd(v//10) %and v = v-v//10*10 %if v <= -10
  put sym('0'-v)
%end
  %if val < 0 %then put sym('-') %and pd(val) %c
  %else pd(-val)
%end
!
%routine PUT IDENT(%integer p,mode)
%record(identinfo)%name dp
  %cycle
    print line %if length(rep) > 50
    spaces(6) %if rep = ""
    dp == dict(p)
    put sym(' ') %and put sym('"') %if mode # 0
    %if dp_text > 0 %start
        put string(string(char0+dp_text))
    %finish %else %if dp_text < 0 %start
        put num(\dp_text)
    %else
        put num(p)
    %finish
    put sym('"') %if mode # 0
    %return %if mode <= 0
    p = dp_hlink
  %repeat %until p = 0
%end
!
{?}%routine SPACES(%integer n)
{?}  %while n > 0 %cycle
{?}    put sym(' ');  n = n-1
{?}  %repeat
{?}%end
{?}!
{?}%routine PUT SPNUM(%integer val)
{?}  put sym(' ') %if val >= 0
{?}  put num(val)
{?}%end
{?}
{?}%constbytearray hexsym(0:15) =
{?}'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
{?}
{?}%routine PUT HEX(%integer val)
{?}%integer i
{?}  put sym(hexsym(val>>i&15)) %for i = 12,-4,0
{?}%end
{?}!
{?}%routine PUT OPERAND(%integer v)
{?}%integer i
{?}%routine INTERPRET(%integer mode)
{?}%switch s(0:7)
{?}  ->s(mode>>3&7)
{?}s(0):                 !DREG
{?}  put sym('D')
{?}putrno:
{?}  put sym(mode&7+'0')
{?}  %return
{?}s(1):                 !AREG
{?}  %if mode >= framemode-dispmode %then put sym('F') %else put sym('A')
{?}  -> putrno
{?}s(4):                 !PRE
{?}  put sym('-')
{?}s(2):                 !INDIRECT
{?}ind:
{?}  put sym('(')
{?}  interpret(mode&2_11000111+aregmode)
{?}  put sym(')')
{?}  %return
{?}s(3):                 !POST
{?}  interpret(mode-8);  !ind
{?}  put sym('+')
{?}  %return
{?}s(5):                 !DISP
{?}  put num(i)
{?}  ->ind
{?}s(6):                 !INDEX
{?}  put num(mite(i))
{?}  put sym('(')
{?}  interpret(mode+(aregmode-indexmode))
{?}  put sym(',')
{?}  interpret(i>>12&15)
{?}  put sym('.')
{?}  %if i&16_800 = 0 %then put sym('W') %else put sym('L')
{?}  put sym(')')
{?}  %return
{?}s(7):                 !MISC
{?}  %if mode&63 = pcmode %start
{?}    put num(i) %if mode = pcmode;  !suppress if not explicit
{?}    put string("(PC)")
{?}    %return
{?}  %finish
{?}  %if mode <= absmode+1 %start
{?}    put sym('$')
{?}    put hex(i>>16) %if mode = absmode+1 %or %not is short(i)=TRUE
{?}  %else
{?}    put sym(hexsym(mode>>4&3))
{?}    put sym(hexsym(mode&15))
{?}    put sym('_')
{?}  %finish
{?}  put hex(i)
{?}%end
{?}
{?}  %if v <= 0 %start;               !literal
{?}    v = litval(v)
{?}    put sym('#')
{?}    %if is mite(v)=TRUE %then put num(v) %else %start
{?}      put sym('$')
{?}      put hex(v>>16) %if v>>16 # 0
{?}      put hex(v&16_FFFF)
{?}    %finish
{?}  %finish %else %if v <= prea7 %start;    !register
{?}    interpret(v-d0)
{?}  %finish %else %if v < dictlim %start;  !identifier
{?}    put ident(v,0)
{?}  %finish %else %if v < lablim %start;  !internal label
{?}    put sym('L')
{?}    put num(v-dictlim)
{?}  %else;                 !complex
{?}    i = dict(v)_val
{?}    interpret(dict(v)_mode)
{?}  %finish
{?}%end;  !put operand
{?}
{?}%routine MARK AT(%integer col)
{?}  put sym(' ') %while length(rep) < col;  put sym('|')
{?}%end
{?}!
{?}%routine SHOW DICT(%integer from)
{?}%integer i
{?}%record(identinfo) d
{?}%constbytearray flagsym(0:15) =
{?}  'W','R','V','A','w','r','o','m','S','T','K','?','P','p','E','*'
{?}%constbytearray catsym(0:15) =
{?}  'I', 'C', 'B', 'E', '@', 'X', '?', '?',
{?}  'S', 'A', 'Z', '?', 'R', 'F', '?', '?'
{?}
{?}  %return %if from >= dlim
!<<IMP
{?}  print line %if rep # ""
{?}  byteinteger(charlim) = 0
{?}  spaces(6)
{?}  put string("___identifier____flags___type__link__par_mode___value____")
{?}  print line
{?}  %cycle
{?}    put spnum(from);  mark at(6)
{?}    d = dict(from)
{?}    put sym(' ');  put ident(from,0)
{?}    %if d_text > 0 %start
{?}      i = char0+d_text;  i = i+byteinteger(i)+1
{?}      %if byteinteger(i)&128 # 0 %start
{?}        byteinteger(i) = byteinteger(i)-128
{?}        put sym(':');  put string(string(i))
{?}        byteinteger(i) = byteinteger(i)+128
{?}      %finish
{?}    %finish
{?}    mark at(22)
{?}    %if d_flags&typeid # 0 %then put sym(catsym(d_flags&cat)) %and i = 4 %c
{?}    %else put sym(' ') %and i = 0
{?}    %cycle
{?}      put sym(flagsym(i)) %if d_flags>>i&1 # 0
{?}      i = i+1
{?}    %repeat %until i > 15
{?}    mark at(30)
{?}    put spnum(d_type);  mark at(35)
{?}    put spnum(d_link);  mark at(42)
{?}    put spnum(d_reg);  mark at(46)
{?}    put spnum(d_mode);  mark at(51)
{?}    put spnum(d_val);  mark at(63)
{?}    print line
{?}    from = from+1
{?}  %repeat %until from = dlim
{?}  spaces(6)
{?}  put string("+-------------------------------------------------------+")
{?}  print line
!<<BOTH
{?}%end
{?}%routine PUT MNEMONIC(%integer m)
{?}  m = m<<2
{?}  %cycle
{?}    put sym(m>>27+'A'-1)
{?}    m = m<<5
{?}  %repeat %until m = 0
{?}%end
{?}%routine%spec PUT OPCODE(%integer op)
{?}%routine SHOW EXP(%integer startp)
{?}%integer p,q
{?}%record(identinfo)%name dp
{?}
%constinteger bopmax=51
%constintegerarray EXTRA(32:bopmax) =
'j'<<25+('a'&31)<<20+('m'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
'o'<<25+('k'&31)<<20+('a'&31)<<15+('s'&31)<<10+('s'&31)<<5,
'a'<<25+('s'&31)<<20+('s'&31)<<15+('i'&31)<<10+('g'&31)<<5+('n'&31),
'i'<<25+('n'&31)<<20+('c'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
'f'<<25+('o'&31)<<20+('r'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
'r'<<25+('e'&31)<<20+('t'&31)<<15+('u'&31)<<10+('r'&31)<<5+('n'&31),
'r'<<25+('e'&31)<<20+('p'&31)<<15+('e'&31)<<10+('a'&31)<<5+('t'&31),
'e'<<25+('l'&31)<<20+('s'&31)<<15+('e'&31)<<10,
'e'<<25+('x'&31)<<20+('i'&31)<<15+('t'&31)<<10,
't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
's'<<25+('w'&31)<<20+('g'&31)<<15+('o'&31)<<10+('t'&31)<<5+('o'&31),
'l'<<25+('a'&31)<<20+('b'&31)<<15+('e'&31)<<10+('l'&31)<<5,
'r'<<25+('e'&31)<<20+('c'&31)<<15+('r'&31)<<10+('e'&31)<<5+('f'&31),
'p'<<25+('r'&31)<<20+('e'&31)<<15+('l'&31)<<10,
's'<<25+('t'&31)<<20+('r'&31)<<15+('m'&31)<<10+('a'&31)<<5+('p'&31),
'i'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
'f'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
'e'<<25+('n'&31)<<20+('d'&31)<<15,
'l'<<25+('o'&31)<<20+('g'&31)<<15+('s'&31)<<10+('u'&31)<<5+('b'&31)

{?}%routine PUT OPRAND(%integer v)
{?}  put sym('#') %and v = v-ad %if v >= explim
{?}  %if v < np0 %then put operand(v) %else put num(v)
{?}%end
{?}  print line %if rep # ""
{?}  %return %unless np > np0
{?}  put string("      ______action_______first_______second____")
{?}  print line
{?}  p = np0
{?}  %cycle
{?}    %if p = np %start
{?}      p = explo
{?}      %exit %if p >= oldexplo
{?}      put string("      |---------------------------------------|")
{?}      print line
{?}    %finish
{?}    %if p = startp %then put sym('>') %else put sym(' ')
{?}    put num(p);  mark at(6)
{?}    dp == dict(p)
{?}    put sym(' ')
{?}    q = dp_act
{?}    %if q <= 31 %start
{?}         put opcode(q)
{?}    %finish %else %if q <= bopmax %start
{?}       put mnemonic(extra(q))
{?}    %else
{?}        put ident(q,0)
{?}    %finish
{?}    mark at(22)
{?}    put sym(' ');  put oprand(dp_x);  mark at(34)
{?}    put sym(' ');  put oprand(dp_y);  mark at(46)
{?}    %if p >= explo %start
{?}      put spnum(dp_type)
{?}      put sym('*') %if dp_flags < 0
{?}    %finish
{?}    print line
{?}    p = p+1
{?}  %repeat %until p >= oldexplo
{?}  oldexplo = explo
{?}  put string("      +---------------------------------------+")
{?}  print line
{?}%end
{?}!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!! Fault reporting  !!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%routine CROAK(%string(255) s)
  select output(0)
  put string("** ");  put string(s)
  put string(".  Compilation abandoned at line ");  put num(line)
  print line
  %signal abandon
%end

!<<IMP

!!  Fault numbers
%constinteger INTERNERR=1, PLEXERR=2, CREACHERR=3, REACHERR=4
%constinteger NORESULT=5, DREACHERR=6
%constinteger FORMERR=7, ATOMERR=8, NAMERR=9, CLASSERR=10
%constinteger SIZERR=11, TYPERR=12, BOUNDSERR=13, UNENDING=14
%constinteger LOWLEVEL=15, ACCESSERR=16, NOTINLOOP=17, NOTINROUT=18
%constinteger NOTINFUN=19, NOTINPRED=20, DUPERR=21
%constinteger ORDERERR=22, MATCHERR=23, RANGERR=24, NONLITERAL=25
%constinteger MOPERR=26, NOCYCLE=27
%constinteger NOSTART=28, NOIF=29, ILLSTARRED=30, NONSTARTER=31
%constinteger NONVAR=32, NONREF=33, TOOFEW=34, TOOMANY=35
%constinteger NOBEGIN=36, DUBIOUS=37, NOTINBLOCK=38
%constinteger NONSTAND=39, NOTIN=40, ASSERR=41
%constinteger NOEND=42, NOFINISH=43, NOREPEAT=44
%constinteger COUNTERR=45, SLABMISSING=46, IDMISSING=47
%constinteger POINT=64, WARN=-128, NOW=128
!
%routine REPORT(%integer n,id,num)
%owninteger lastchange=0
%integer mark,start,errline

%routine PRINT TEXT(%integer stream)
%constinteger esc=27
%integer k,p

%conststring(15)%array MESSAGE(1:44) =
  "Internal error ", "Reg not free",
  "Out of reach ",  " out of reach!",
  "RESULT missing", "Out of reach",
  "Faulty form", "Unknown atom",
  "Unknown name", "Wrong class",
  "Wrong size", "Wrong type",
  "Inside out", "Endless loop",
  "Low level", "Not accessible",
  "Not in loop", "Not in routine",
  "Not in fn/map", "Not in pred",
  "Duplicate",
  "Out of order", "Mismatch",
  "Out of range", "Not literal",
  "Faulty operand", "%CYCLE missing",
  "%START missing", "Extra %ELSE",
  "Ill-starred", "Non-starter",
  "Not variable", "Not reference",
  "Too few args", "Too many args",
  "%BEGIN missing",
  "Dubious usage", "Not in block",
  "Nonstandard ", "Not supported",
  " void",
  "%END missing",
  "%FINISH missing", "%REPEAT missing"

!<<BOTH

  put sym(mark)
  put sym(' ') %if errline < 1000
  put sym(' ') %if errline < 100
  put sym(' ') %if errline < 10
  put num(errline)
  put sym(listflag);  put sym(' ')
  k = n&63
  %if k >= counterr %start
    %if k = counterr %start
      %if num < 0 %start
        put num(-num);  put string(" extra")
      %else
        put num(num) %if num # 0;  put string(" missing")
      %finish
      put string(" value(s) for ")
      put ident(id,0)
      %return
    %finish
    %if k # slabmissing %start
      put ident(id,1)
    %else
      put ident(id,0)
      put sym('(');  put num(num);  put sym(')')
    %finish
    put string(" missing")
mend:
    %if c_dpid_text # 0 %start
      put string(" in ")
      put ident(c_pid,-1)
    %finish
    %return
  %finish
  put ident(id,0) %if id > 0
  put string(message(k))
  put num(num) %if num > 0
  -> mend %if creacherr <= k <= noresult
  spaces(22-length(rep))
  p = start
  p = p+1 %while byteinteger(p) = ' '
  %if p < faultp-50 %then p = faultp-47 %and put string("...") %c
  %else put sym(' ')
  %cycle
    k = byteintegeR(p);  p = p+1
    %if p = faultp %start
!      %if stream # 0 %then put sym('|') %else %start
!       !**V200**
!        put sym(esc);  put sym('F');  !graphics
!        put sym('~')
!        put sym(esc);  put sym('G');  !normal
!      %finish
      put sym('|')
    %finish
    %exit %if k = nl
    put sym(k)
!    %if ' ' <= k <= '~' %then put sym(k) %c
!    %else put sym('[') %and put num(k) %and put sym(']')
  %repeat
  %return
%end

!Warning or error
  mark = '?'
  %if n > 0 %start
    mark = '*'
    c_faults = c_faults+1;  faults = faults+1
  %finish
  faultnum = 0;  c_access = -1
!Ignore uncorrected earlier error
  %return %if file(main)_start1 <= fp < lastchange
!Establish what to print
  start = linestart;  errline = line
  %if n&point = 0 %start
    faultp = 0;  !no pointing
  %else
    %while start >= faultp %cycle;  !before current line
      start = start-1
      errline = errline-1 %if byteintegeR(start) = nl
    %repeat
    start = start-1 %while start # curstart %and byteintegeR(start-1) # nl
  %finish
  time1 = time1-cputime
  %if listout # 0 %start;  !listing file
    print text(listout);  print line
  %finish
  select output(0)
  %if curfile # lastfile %start
    lastfile = curfile;  put string(cur_name);  print line
  %finish
  print text(0)
  %if n > reacherr %and curfile = main %and control&editbit # 0 %start
    start = faultp-1 %if faultp > start
    cur_fp = start;  cur_line = line
    cur_change = 16_7FFFFFFE %if lastchange # 0
    select input(0)
    file(main+1) = 0
!!    edi(file(main),file(main+1),rep);  !main+1 to keep editor happy
    rep = ""
    select output(listout)
    time1 = time1+cputime
    %signal abandon %if cur_flag < 0 {abandoned}
    control = control&(\editbit) %if cur_flag = 'I'
    lastchange = cur_change %and %signal redo %if cur_change < 16_7FFFFFFE
  %else
    print line
    select output(listout)
    time1 = time1+cputime
  %finish
%end;  !report

%routine FAULT(%integer n)
!Note fault number and position of (earliest) fault
! for subsequent reporting (warnings and weak errors)
  %if faultnum = 0 %or (n > 0 %and faultnum < 0) %start
    faultnum = n;  faultp = atomp
    report(faultnum&127,0,0) %if faultnum >= now
  %finish
%end

%routine INTERN(%integer n)
  report(internerr,0,n)
%end

!!!!!!!!!!!!!!!!!!!!   CELL  CONSTRUCTORS  !!!!!!!!!!!!!!!!!!!
!
%integer%fn LITREF(%integer v)
%integer i
  %result = v %if v = 0
  %if v > 0 %start
    %result = -(v<<1) %if v <= smallmax
  %else
    %result = v<<1+1 %if v >= smallmin
  %finish
  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 >= litmax
  %finish
  %result = i
%end
!
%routine PUTEXP(%integer act,x,y,t)
  type = t
  item = explim
  item = x %if explo <= x < item
  item = y %if explo <= y < item
  %cycle
    item = item-1
    ditem == dict(item)
    %if item < explo %start
      explo = item
      ditem_act = act;  ditem_x = x;  ditem_y = y
      ditem_flags = 0;  ditem_type = t;  ditem_mode = 0
      %exit
    %finish
  %repeat %until ditem_act = act %and ditem_x = x %and ditem_y = y
%end

!$IF VAX
{%integer%fn IEEE(%integer v)
{  %result = 0 %if v = 0
{  %result = v<<16+v>>16-16_01000000
{%end
!$FINISH

%routine PUTEXP2(%integer op,first,t)
  %if item = 0 %start
!$IF VAX
{  value = ieee(value) %if type = realtype;  !vax->ieee
!$FINISH
    item = litref(value)
  %finish
  putexp(op,first,item,t)
%end

%integer%fn NORMITEM
  %result = item %if item # 0
!$IF VAX
{  value = ieee(value) %if type = realtype;  !vax->ieee
!$FINISH
  %result = litref(value)
%end

%routine TOREAL
  %if item # 0 %then putexp(float,item,0,realtype) %c
  %else real(addr(value)) = value %and type = realtype
%end

%integer%fn TEMP(%integer m,v)
  dtemp_mode = m;  dtemp_val = v
  %result = lablim
%end
%integer%fn TEMPX(%integer r1,r2)
  dtemp_mode = r1+(indexmode-a0);  dtemp_val = (r2-d0)<<12+16_0800
  %result = lablim
%end
%integer%fn TEMPD(%integer a,disp)
  dtemp_mode = a+(dispmode-a0);  dtemp_val = disp
  %result = lablim
%end
%integer%fn TEMPX2(%integer r1,r2)
  dtemp2_mode = r1+(indexmode-a0);  dtemp2_val = (r2-d0)<<12+16_0800
  %result = lablim+1
%end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!    CODE  GENERATION   !!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  The array DEF contains packed mnemonics for M68000 machine
! instructions and, for each mnemonic, the basic opcode and
! a type indicator.
!  The type indicator contains flag bits for various special cases
! and two 6-bit fields defining the operand types
! [should be const record array]
!  The mnemonics and variant distinctions broadly follow the
!  manufacturer's Assembly Language conventions
!
! Opcode index values needed globally:-
%constinteger LEA=78, PEA=55, CLR=52, DBRA=81, JSR=56,
              LINK=72, UNLK=73, RTS=68,
              MOVEM=100, TRAPI=101, DC=102

!Machine-code operand types
![EA needs to be further distinguished]
%constinteger SHIFT=32
%constinteger REG=1, AREG=2, IREG=3, QUICK=4, MQUICK=5
%constinteger EA=6, RWEA=7, WEA=8
%constinteger IMM=9, TQUICK=10, REL=11, LONGREL=12
%constinteger QREG=13, POSTAREG=14, QEA=15
%constinteger REVEA=16, XIMM=17, DATA=18, PREAREG=19, QPRE=20
%constinteger EXREG=21+shift
%constinteger REG9=reg+shift, QREG9=qreg+shift, IREG9=ireg+shift,
              POSTAREG9=postareg+shift,
              QUICK9=quick+shift, AREG9=areg+shift
%constinteger SIZED=1<<15, ASIZED=1<<14;  !2 spare bits
%constinteger REVERSIBLE=revea<<6+reg9+sized, MULTIPLE=ximm<<6+ea+asized
%constinteger DEFMAX=129
%constintegerarray DEF(0:defmax+defmax) =
  0,
 {MOVE} 16_0000<<16+ ea<<6+wea+shift +sized,
  'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10,
 {ADD} 16_D000<<16+ reversible,
  'a'<<25+('d'&31)<<20+('d'&31)<<15,
 {SUB} 16_9000<<16+ reversible,
  's'<<25+('u'&31)<<20+('b'&31)<<15,
 {CMP} 16_B000<<16+ ea<<6+reg9 +sized,
  'c'<<25+('m'&31)<<20+('p'&31)<<15,
 {AND} 16_C000<<16+ reversible,
  'a'<<25+('n'&31)<<20+('d'&31)<<15,
 {OR} 16_8000<<16+ reversible,
  'o'<<25+('r'&31)<<20,
 {EOR} 16_B100<<16+ reg9<<6+rwea +sized,
  'e'<<25+('o'&31)<<20+('r'&31)<<15,
 {NOT} 16_4600<<16+ rwea +sized,
  'n'<<25+('o'&31)<<20+('t'&31)<<15,
 {NEG} 16_4400<<16+ rwea +sized,
  'n'<<25+('e'&31)<<20+('g'&31)<<15,
 {LSL} 16_E108<<16+ qreg9<<6+reg +sized,
  'l'<<25+('s'&31)<<20+('l'&31)<<15,
 {LSR} 16_E008<<16+ qreg9<<6+reg +sized,
  'l'<<25+('s'&31)<<20+('r'&31)<<15,
 {MULS} 16_C1C0<<16+ ea<<6+reg9,
  'm'<<25+('u'&31)<<20+('l'&31)<<15+('s'&31)<<10,
 {DIVS} 16_81C0<<16+ ea<<6+reg9,
  'd'<<25+('i'&31)<<20+('v'&31)<<15+('s'&31)<<10,
 {MULU} 16_C0C0<<16+ ea<<6+reg9,
  'm'<<25+('u'&31)<<20+('l'&31)<<15+('u'&31)<<10,
 {DIVU} 16_80C0<<16+ ea<<6+reg9,
  'd'<<25+('i'&31)<<20+('v'&31)<<15+('u'&31)<<10,
 {BRA} 16_6000<<16+ rel,
  'b'<<25+('r'&31)<<20+('a'&31)<<15,
 {BSR} 16_6100<<16+ rel,
  'b'<<25+('s'&31)<<20+('r'&31)<<15,
 {BHI} 16_6200<<16+ rel,
  'b'<<25+('h'&31)<<20+('i'&31)<<15,
 {BLS} 16_6300<<16+ rel,
  'b'<<25+('l'&31)<<20+('s'&31)<<15,
 {BCC} 16_6400<<16+ rel,
  'b'<<25+('c'&31)<<20+('c'&31)<<15,
 {BCS} 16_6500<<16+ rel,
  'b'<<25+('c'&31)<<20+('s'&31)<<15,
 {BNE} 16_6600<<16+ rel,
  'b'<<25+('n'&31)<<20+('e'&31)<<15,
 {BEQ} 16_6700<<16+ rel,
  'b'<<25+('e'&31)<<20+('q'&31)<<15,
 {BVC} 16_6800<<16+ rel,
  'b'<<25+('v'&31)<<20+('c'&31)<<15,
 {BVS} 16_6900<<16+ rel,
  'b'<<25+('v'&31)<<20+('s'&31)<<15,
 {BPL} 16_6A00<<16+ rel,
  'b'<<25+('p'&31)<<20+('l'&31)<<15,
 {BMI} 16_6B00<<16+ rel,
  'b'<<25+('m'&31)<<20+('i'&31)<<15,
 {BGE} 16_6C00<<16+ rel,
  'b'<<25+('g'&31)<<20+('e'&31)<<15,
 {BLT} 16_6D00<<16+ rel,
  'b'<<25+('l'&31)<<20+('t'&31)<<15,
 {BGT} 16_6E00<<16+ rel,
  'b'<<25+('g'&31)<<20+('t'&31)<<15,
 {BLE} 16_6F00<<16+ rel,
  'b'<<25+('l'&31)<<20+('e'&31)<<15,
 {ASL} 16_E100<<16+ qreg9<<6+reg +sized,
  'a'<<25+('s'&31)<<20+('l'&31)<<15,
 {ASR} 16_E000<<16+ qreg9<<6+reg +sized,
  'a'<<25+('s'&31)<<20+('r'&31)<<15,
 {ROL} 16_E118<<16+ qreg9<<6+reg +sized,
  'r'<<25+('o'&31)<<20+('l'&31)<<15,
 {ROR} 16_E018<<16+ qreg9<<6+reg +sized,
  'r'<<25+('o'&31)<<20+('r'&31)<<15,
 {MOVEQ} 16_7000<<16+ mquick<<6+reg9,
  'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('q'&31)<<5,
 {ADDQ} 16_5000<<16+ quick9<<6+rwea +sized,
  'a'<<25+('d'&31)<<20+('d'&31)<<15+('q'&31)<<10,
 {SUBQ} 16_5100<<16+ quick9<<6+rwea +sized,
  's'<<25+('u'&31)<<20+('b'&31)<<15+('q'&31)<<10,
 {MOVEA} 16_3040<<16+ ea<<6+areg9 +asized,
  'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('a'&31)<<5,
 {ADDA} 16_D0C0<<16+ ea<<6+areg9 +asized,
  'a'<<25+('d'&31)<<20+('d'&31)<<15+('a'&31)<<10,
 {SUBA} 16_90C0<<16+ ea<<6+areg9 +asized,
  's'<<25+('u'&31)<<20+('b'&31)<<15+('a'&31)<<10,
 {CMPA} 16_B0C0<<16+ ea<<6+areg9 +asized,
  'c'<<25+('m'&31)<<20+('p'&31)<<15+('a'&31)<<10,
 {CMPM} 16_B108<<16+ postareg<<6+postareg9,
  'c'<<25+('m'&31)<<20+('p'&31)<<15+('m'&31)<<10,
 {ADDI} 16_0600<<16+ imm<<6+rwea +sized,
  'a'<<25+('d'&31)<<20+('d'&31)<<15+('i'&31)<<10,
 {SUBI} 16_0400<<16+ imm<<6+rwea +sized,
  's'<<25+('u'&31)<<20+('b'&31)<<15+('i'&31)<<10,
 {CMPI} 16_0C00<<16+ imm<<6+ea +sized,
  'c'<<25+('m'&31)<<20+('p'&31)<<15+('i'&31)<<10,
 {ANDI} 16_0200<<16+ imm<<6+rwea +sized,
  'a'<<25+('n'&31)<<20+('d'&31)<<15+('i'&31)<<10,
 {ORI} 16_0000<<16+ imm<<6+rwea +sized,
  'o'<<25+('r'&31)<<20+('i'&31)<<15,
 {EORI} 16_0A00<<16+ imm<<6+rwea +sized,
  'e'<<25+('o'&31)<<20+('r'&31)<<15+('i'&31)<<10,
 {ROXL} 16_E110<<16+ qreg9<<6+reg +sized,
  'r'<<25+('o'&31)<<20+('x'&31)<<15+('l'&31)<<10,
 {ROXR} 16_E010<<16+ qreg9<<6+reg +sized,
  'r'<<25+('o'&31)<<20+('x'&31)<<15+('r'&31)<<10,
 {CLR} 16_4200<<16+ wea +sized,
  'c'<<25+('l'&31)<<20+('r'&31)<<15,
 {NEGX} 16_4000<<16+ rwea +sized,
  'n'<<25+('e'&31)<<20+('g'&31)<<15+('x'&31)<<10,
 {NBCD} 16_4800<<16+ rwea,
  'n'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
 {PEA} 16_4840<<16+ ea,
  'p'<<25+('e'&31)<<20+('a'&31)<<15,
 {JSR} 16_4E80<<16+ ea,
  'j'<<25+('s'&31)<<20+('r'&31)<<15,
 {JMP} 16_4EC0<<16+ ea,
  'j'<<25+('m'&31)<<20+('p'&31)<<15,
 {TAS} 16_4AC0<<16+ rwea,
  't'<<25+('a'&31)<<20+('s'&31)<<15,
 {TST} 16_4A00<<16+ ea +sized,
  't'<<25+('s'&31)<<20+('t'&31)<<15,
 {ABCD} 16_C100<<16+ qpre<<6+reg9,
  'a'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
 {SBCD} 16_8100<<16+ qpre<<6+reg9,
  's'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
 {ADDX} 16_D100<<16+ qpre<<6+reg9 +sized,
  'a'<<25+('d'&31)<<20+('d'&31)<<15+('x'&31)<<10,
 {SUBX} 16_9100<<16+ qpre<<6+reg9 +sized,
  's'<<25+('u'&31)<<20+('b'&31)<<15+('x'&31)<<10,
 {NOP} 16_4E71<<16,
  'n'<<25+('o'&31)<<20+('p'&31)<<15,
 {RESET} 16_4E70<<16,
  'r'<<25+('e'&31)<<20+('s'&31)<<15+('e'&31)<<10+('t'&31)<<5,
 {RTE} 16_4E73<<16,
  'r'<<25+('t'&31)<<20+('e'&31)<<15,
 {RTR} 16_4E77<<16,
  'r'<<25+('t'&31)<<20+('r'&31)<<15,
 {RTS} 16_4E75<<16,
  'r'<<25+('t'&31)<<20+('s'&31)<<15,
 {STOP} 16_4E72<<16 +imm,
  's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
 {TRAPV} 16_4E76<<16,
  't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('v'&31)<<5,
 {TRAP} 16_4E40<<16+ tquick,
  't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
 {LINK} 16_4E50<<16+ imm<<6+areg,
  'l'<<25+('i'&31)<<20+('n'&31)<<15+('k'&31)<<10,
 {UNLK} 16_4E58<<16+ areg,
  'u'<<25+('n'&31)<<20+('l'&31)<<15+('k'&31)<<10,
 {SWAP} 16_4840<<16+ reg,
  's'<<25+('w'&31)<<20+('a'&31)<<15+('p'&31)<<10,
 {EXTW} 16_4880<<16+ reg,
  'e'<<25+('x'&31)<<20+('t'&31)<<15+('w'&31)<<10,
 {EXTL} 16_48C0<<16+ reg,
  'e'<<25+('x'&31)<<20+('t'&31)<<15+('l'&31)<<10,
 {EXG} 16_C140<<16+ exreg<<6+reg,
  'e'<<25+('x'&31)<<20+('g'&31)<<15,
 {LEA} 16_41C0<<16+ qea<<6+areg9,
  'l'<<25+('e'&31)<<20+('a'&31)<<15,
 {CHK} 16_4180<<16+ ea<<6+reg9,
  'c'<<25+('h'&31)<<20+('k'&31)<<15,
 {DBXX} 16_50C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('x'&31)<<15+('x'&31)<<10,
 {DBRA} 16_51C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('r'&31)<<15+('a'&31)<<10,
 {DBHI} 16_52C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('h'&31)<<15+('i'&31)<<10,
 {DBLS} 16_53C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('l'&31)<<15+('s'&31)<<10,
 {DBCC} 16_54C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('c'&31)<<15+('c'&31)<<10,
 {DBCS} 16_55C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('c'&31)<<15+('s'&31)<<10,
 {DBNE} 16_56C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('n'&31)<<15+('e'&31)<<10,
 {DBEQ} 16_57C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('e'&31)<<15+('q'&31)<<10,
 {DBVC} 16_58C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('v'&31)<<15+('c'&31)<<10,
 {DBVS} 16_59C8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('v'&31)<<15+('s'&31)<<10,
 {DBPL} 16_5AC8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('p'&31)<<15+('l'&31)<<10,
 {DBMI} 16_5BC8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('m'&31)<<15+('i'&31)<<10,
 {DBGE} 16_5CC8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('g'&31)<<15+('e'&31)<<10,
 {DBLT} 16_5DC8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('l'&31)<<15+('t'&31)<<10,
 {DBGT} 16_5EC8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('g'&31)<<15+('t'&31)<<10,
 {DBLE} 16_5FC8<<16+ reg<<6+longrel,
  'd'<<25+('b'&31)<<20+('l'&31)<<15+('e'&31)<<10,
 {BCHG} 16_0140<<16+ ireg9<<6+rwea,
  'b'<<25+('c'&31)<<20+('h'&31)<<15+('g'&31)<<10,
 {BCLR} 16_0180<<16+ ireg9<<6+wea,
  'b'<<25+('c'&31)<<20+('l'&31)<<15+('r'&31)<<10,
 {BSET} 16_01C0<<16+ ireg9<<6+wea,
  'b'<<25+('s'&31)<<20+('e'&31)<<15+('t'&31)<<10,
 {BTST} 16_0100<<16+ ireg9<<6+ea,
  'b'<<25+('t'&31)<<20+('s'&31)<<15+('t'&31)<<10,
 {MOVEM} 16_4880<<16+ multiple,
  'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('m'&31)<<5,
 {TRAPI} 16_4E40<<16+ imm<<6+tquick,
  't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('i'&31)<<5,
 {DC}         data,
     'd'<<25+('c'&31)<<20,
 {ST} 16_50C0<<16+ wea,
  's'<<25+('t'&31)<<20,
 {SF} 16_51C0<<16+ wea,
  's'<<25+('f'&31)<<20,
 {SHI} 16_52C0<<16+ wea,
  's'<<25+('h'&31)<<20+('i'&31)<<15,
 {SLS} 16_53C0<<16+ wea,
  's'<<25+('l'&31)<<20+('s'&31)<<15,
 {SCC} 16_54C0<<16+ wea,
  's'<<25+('c'&31)<<20+('c'&31)<<15,
 {SCS} 16_55C0<<16+ wea,
  's'<<25+('c'&31)<<20+('s'&31)<<15,
 {SNE} 16_56C0<<16+ wea,
  's'<<25+('n'&31)<<20+('e'&31)<<15,
 {SEQ} 16_57C0<<16+ wea,
  's'<<25+('e'&31)<<20+('q'&31)<<15,
 {SVC} 16_58C0<<16+ wea,
  's'<<25+('v'&31)<<20+('c'&31)<<15,
 {SVS} 16_59C0<<16+ wea,
  's'<<25+('v'&31)<<20+('s'&31)<<15,
 {SPL} 16_5AC0<<16+ wea,
  's'<<25+('p'&31)<<20+('l'&31)<<15,
 {SMI} 16_5BC0<<16+ wea,
  's'<<25+('m'&31)<<20+('i'&31)<<15,
 {SGE} 16_5CC0<<16+ wea,
  's'<<25+('g'&31)<<20+('e'&31)<<15,
 {SLT} 16_5DC0<<16+ wea,
  's'<<25+('l'&31)<<20+('t'&31)<<15,
 {SGT} 16_5EC0<<16+ wea,
  's'<<25+('g'&31)<<20+('t'&31)<<15,
 {SLE} 16_5FC0<<16+ wea,
  's'<<25+('l'&31)<<20+('e'&31)<<15,
 {MTCCR} 16_44C0<<16+ ea<<6,
  'm'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 {MTSR} 16_46C0<<16+ ea<<6,
  'm'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 {MFSR} 16_40C0<<16+ wea,
  'm'<<25+('f'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 {MTUSP} 16_4E60<<16+ areg,
  'm'<<25+('t'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
 {MFUSP} 16_4E68<<16+ areg,
  'm'<<25+('f'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
 {ATCCR} 16_023C<<16+ imm,
  'a'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 {ATSR} 16_027C<<16+ imm,
  'a'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 {ETCCR} 16_0A3C<<16+ imm,
  'e'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 {ETSR} 16_0A7C<<16+ imm,
  'e'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 {OTCCR} 16_003C<<16+ imm,
  'o'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 {OTSR} 16_007C<<16+ imm,
  'o'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10

{?}%routine PUT OPCODE(%integer op)
{?}  put mnemonic(def(op+op))
{?}%end

%routine STORE(%integer v,f)
!$IF VAX
{  v = v&16_FFFF;  v = v!sign16 %if v&sign16 # 0
!$FINISH
  prog(pc) <- v;  pflag(pc) = f;  pc = pc+1
%end

%routine MAKE ROOM(%integer size)
%integer newbase,newlim
  size = (size+127)&(\127)
  ownbase = ownbase-size
  croak("Program too big") %if ownbase <= cad
  newbase = ownbase;  newlim = newbase+ownad
  %cycle
    final(newbase) = final(newbase+size)
    newbase = newbase+1
  %repeat %until newbase >= newlim
%end

%routine FILL CODE(%integer n)
%integer i
  i = cad;  cad = cad+n
  %while n > 0 %cycle
    final(i) = 16_80;  i = i+1;  n = n-1
  %repeat
%end
%routine FILL OWN(%integer n)
%integer i
  make room(n)
  i = ownbase+ownad;  ownad = ownad+n
  %while n > 0 %cycle
    final(i) = 16_80;  i = i+1;  n = n-1
  %repeat
%end

%routine SET CODE WORD(%integer v)
!$IF VAX (works irrespective of host byte sex)
{  final(cad) <- v>>8;  final(cad+1) <- v
!$IF APM (for efficiency)
  shortinteger(final0+cad) <- v
!$FINISH
  cad = cad+2
%end

%integer%fn CODE WORD(%integer cad)
!$IF VAX (works irrespective of host byte sex)
{  %result = final(cad)<<8+final(cad+1)
!$IF APM (for efficiency)
  %result = shortinteger(final0+cad)
!$FINISH
%end

%routine SET CODE LONGWORD(%integer v)
  set code word(v>>16);  set code word(v)
%end

%routine SET OWN WORD(%integer v)
  make room(2) %if ownbase+ownad > finalbound
!$IF VAX
{  final(ownbase+ownad) <- v>>8;  final(ownbase+ownad+1) <- v
!$IF APM
  shortinteger(final0+ownbase+ownad) <- v
!$FINISH
  ownad = ownad+2
%end

%routine EXTEND STACK(%integer delta)
  c_sp = c_sp-delta
  %if c_sp < c_stack %start
    c_stack = c_sp
    c_totstack = c_stack %if c_stack < c_totstack
  %finish
%end

%routine PLANT(%integer op,y,x)
!Basic code planting procedure
! OP is an index to the array defining op-codes
!  (it can be flagged to force SIZE)
! For unary operations the operand is given by X (Y zero)
! For binary operations the operands are Y (source) and X (dest)
%integer OPCODE,PC1,I,F,EXTWORD,INFO,KIND,MODE,MODEX,SIZE
%record(identinfo)%name DX,DY
%switch S(0:21)
%constbytearray SIZESYM(0:3) = 'L','B','W','?'

%integer%fn NONLOCAL(%integer l)
%integer r
  %result = mb %if l = outerlevel
  hold(l)_status = hold(l)_status!globbed %if l # level
  %result = f1 %if l = outerlevel+1
  r = maxareg
  %cycle
    %result = r %if c_reg_content(r) = d7+l;  ![unique]
    r = r-1
  %repeat %until r < a0
![not good enough: 1. may need two
!                  2. FREE updated elsewhere without regard to this]
  r = maxareg
  %while a0b<<(r-a0)&free = 0 %cycle
    fault(plexerr) %and %exit %if r = a0
    r = r-1
  %repeat
  c_reg_content(r) = d7+l
  dtsprel_mode = globalmode;  dtsprel_val = l<<2
  plant(move,lablim+2,r)
  %result = r
%end

%constinteger MOVEQ=36, ADDQ=37, MOVEA=39,
              ADDA=40, ADDI=44

  %if x > 0 %start
    intern(1) %and %return %if x >= explim
    dx == dict(x)
    modex = dx_mode
    %if modex >= framemode %and modex # c_mode %c
    %and modex&2_111000 # 2_111000 %start
      modex = nonlocal(modex&7)-a0+(modex&(7<<3))
    %finish
  %finish %else modex = litmode %and dx == dint
  %if y > 0 %start
    intern(1) %and %return %if y >= explim
    dy == dict(y)
    mode = dy_mode
    %if mode >= framemode %and mode # c_mode %c
    %and mode&2_111000 # 2_111000 %start
      mode = nonlocal(mode&7)-a0+(mode&(7<<3))
    %finish
  %finish %else mode = litmode %and dy == dint
  size = op>>8;  op = op&255
  %if op = move %start
    %if modex&2_111000 = 0 %start;  !D
      op = moveq %if y <= 0 %and y >= litmite %and size&3 = 0
    %finish %else %if modex&2_110000 = 0 %start;   !A
      op = movea
    %finish
  %finish %else %if op <= cmp %start
    %if op < cmp %and y < 0 %and y >= litquick %and y&1 = 0 %c
    %then op=op+(addq-add) {ADDQ,SUBQ} %c
    %else %if modex&2_111000 = aregmode %c
    %then op=op+(adda-add) {ADDA,SUBA,CMPA} %c
    %else %if y <= 0 %c
    %then op=op+(addi-add) {ADDI,SUBI,CMPI}
  %finish %else %if op <= eor %start
    op = op+(addi-add) %if y <= 0 {ANDI,ORI,EORI}
  %finish
  info = def(op+op-1)
  opcode = info>>16
  %if info&sized # 0 %start;  !data size required
    size = 4 %if size = 0
    %if op = move %start
      %if size = 4 %start
        opcode = opcode+16_2000
      %finish %else %if size = 2 %start
        opcode = opcode+16_3000
      %else
        opcode = opcode+16_1000
      %finish
    %else
      %if size = 4 %start
        opcode = opcode+16_80
      %finish %else %if size = 2 %start
        opcode = opcode+16_40
      %finish
    %finish
  %finish %else %if info&asized # 0 %start;  !areg size required
    fault(sizerr) %if size = 1
    %if op # movem %start
      %if size = 0 %start
        size = 4 %unless y <= 0 %and is short(litval(y))=TRUE
      %finish
      %if size = 4 %start
        %if op = movea %then opcode = opcode!!16_1000 %c
        %else opcode = opcode+16_0100
      %finish
    %else;  !MOVEM
      size = 4 %if size = 0
      opcode = opcode+16_0040 %if size = 4
    %finish
  %finish
{?}  %if control&codelist # 0 %and control&list # 0 %start
{?}    print line %if length(rep) >= 4
{?}    put sym(codeflag);  spaces(4-length(rep))
{?}    put opcode(op)
{?}    %if size # 0 %start
{?}      put sym('.')
{?}      put sym(sizesym(size&3))
{?}    %finish
{?}    spaces(12-length(rep))
{?}    %if info&(63<<6) # 0 %start
{?}      put operand(y)
{?}      put sym(',') %if info&63 # 0
{?}    %finish
{?}    put operand(x) %if info&63 # 0
{?}    spaces(33-length(rep));  put sym(':')
{?}  %finish

  pc1 = pc;  pflag(pc1) = c_shorts;  !op-code word
  pc = pc+1
  croak("Code space exhausted") %if pc >= swpc-8
  kind = info>>6
again:
  ->s(kind&31)
s(0):
next:
  kind = info
  %if kind # 0 %start
    dy == dx;  y = x;  mode = modex
    info = 0
    ->again
  %finish
!
!$IF VAX
{  opcode = opcode!sign16 %if opcode&sign16 # 0
!$FINISH
  prog(pc1) <- opcode
{?}  %if control&codelist # 0 %and control&list # 0 %start
{?}    %cycle
{?}      put sym(' ')
{?}      put hex(prog(pc1))
{?}      pc1 = pc1+1
{?}    %repeat %until pc1 >= pc
{?}    print line
{?}  %finish
  %return

!Set flag value for PC-relative reference
! distinguishing GLOBAL (const access), INDIRECT GLOBAL (procedure),
! and LOCAL (label) -- the last further distinguished according to
! whether the instruction permits shortening
%routine PCREL(%integer shorten)
  %if dy_mode = labmode %start
    f = jump;  f = longjump %if shorten = 0
    %if extword > 0 %start;  !label defined
      %if shorten # 0 %and (extword-pflag(extword)-pc+c_shorts)<<1 >= -128 %start
        %if c_shorts = 255 %start
          zaps = zaps+100
        %else
          shorts = shorts+1;  c_shorts = c_shorts+1
          f = shortjump
        %finish
      %finish
    %else
      extword = -extword
      dy_val = -pc
    %finish
  %finish %else %if dy_mode = procmode %start;  !procedure
    f = indglobal;  extword = y;  !rather than DY_VAL
  %finish %else %if dy_mode = constmode %start;  !constant data ref
    f = global
    f = f+1 %if extword < 0
    f = f+2 %if extword > 65535
  %finish %else %if dy_mode # pcmode %start
    fault(moperr)
  %finish
%end

s(qea):  !LEA
  -> ea0 %unless mode&63 = x-(a0-indexmode) %and dy_val&255 = 0
  !  LEA 0(Ax,Dy)  =>  ADDA Dy,Ax
  opcode = 16_D1C0+dy_val>>12&15
  -> next

s(wea):
  dy_flags = dy_flags!(mflag!wflag)
  -> wea1
s(rwea):  ![for our purposes, read&write counts as neither]
  dy_flags = dy_flags!mflag
wea1:
  -> err %if y <= 0 %or mode&63 >= pcmode
  -> ea1
s(revea):  !reversible cases (EA,REG or REG,EA)
  %if modex&2_111000 # 0 %start;  !dest not D
    kind = shift;  info = rwea
    opcode = opcode!!16_0100
    ->sreg
  %finish
s(ea): ea0:
  %if y <= 0 %start
    opcode = opcode+litmode;  !immediate
    ->simm
  %finish
  %if dy_flags&(ext+spec+rflag+wflag) = ext+spec %c
  %and dy_flags&proc # 0 %start
    ! Create transfer vector for external procedure
    fill own(1) %if ownad&1 # 0
    dy_val = ownad
    set own word(16_207C+(mb-a0)<<9);  !MOVE.L #xxxxxxxx,MB
    set own word(0);  set own word(0)
    set own word(16_4EF9);  !JMP xxxxxxxx
    set own word(0);  set own word(0)
  %finish
  %if (op = lea %or op = pea) %and mode&63 # pcmode %start
    !taking address: might read or write
    dy_flags = dy_flags!(mflag+rflag+wflag)
    ->err %if mode&2_111000 < aregmode+indir
  %else
    dy_flags = dy_flags!(mflag+rflag)
  %finish
ea1:
  extword = dy_val
  %if mode = c_mode %start;  !local
    mode = dispmode+7;  extword = extword-c_sp;  !convert to use SP
    %if extword < 0 %start
      intern(4) %if extword < -4
      mode = aregmode+pre+7
      extend stack(-extword)
      extword = 0
    %finish
  %finish
  mode = mode&63;   !strip extra flags
  %if mode >= dispmode %start;  !+extra
    f = 0
    %if mode = pcmode %start
      pcrel(0)
    %finish
    %if mode <= dispmode+7 %start
      %if extword = 0 %start
        ! Premode (just created) or Dispmode (=>Indmode)
        mode = mode+(aregmode+indir-dispmode) %if mode >= dispmode
      %else
        fault(dreacherr) %unless -32768 <= extword <= 32767
        store(extword,f)
      %finish
    %else
      mode = absmode+1 %if mode = absmode %and %not is short(extword)=TRUE
      store(extword>>16,0) %if mode = absmode+1
      store(extword,f)
    %finish
  %finish
  mode = ((mode&7)<<3 + mode>>3)<<6 %if kind&shift # 0
  opcode = opcode+mode
  ->next

s(exreg&31):  !EXG (D,D / A,A / D,A)
  %if mode&2_111000 = 0 %start;  !D
    %if modex&2_111000 # 0 %start;  !not D
      opcode = opcode!!16_C8;  info = areg
    %finish
    -> sreg
  %finish
  opcode = opcode+8;  info = areg
  -> sareg
s(qpre):
  -> sreg %if mode&2_111000 = 0;  !D
  opcode = opcode+8;  info = preareg+shift
s(preareg):
  mode = mode+(post-pre)
s(postareg):
  mode = mode-post
s(areg): sareg:
  mode = mode-8
s(reg): sreg:
  -> err %unless mode&2_111000 = 0
  mode = mode&7
  mode = mode<<9 %if kind&shift # 0
  opcode = opcode+mode
  ->next

s(qreg):  !Shift formats -- quick,Dx / Dy,Dx / 1,<ea> (W)
  opcode = opcode+16_20 %and ->sreg %if y > 0
  %if y = one %and size = 2 %and modex&2_111000 # 0 %start
    opcode = opcode!!16_290
    ->next
     %finish
s(quick):
  -> err %if y >= 0
  y = litval(y)
  ->err %unless y <= 8
  opcode = opcode+(y&7)<<9;  !(always aligned to bit9)
  ->next

s(tquick):  !(TRAP)
  -> err %unless -30 <= y %and y&1 = 0;  !{0<=}litval(y)<=15
s(mquick):
  ->err %unless y <= 0 %and y >= litmite
  y = litval(y)
  opcode = opcode+y&255
  ->next
s(rel):
  ->s(mquick) %if y <= 0 %and y >= litmite
s(longrel):
  ->simm %if y <= 0
  dy_flags = dy_flags!rflag
  extword = dy_val
  f = 0
  pcrel(longrel-kind&31)
  store(extword,f)
  ->next

s(ireg):  !immediate or reg
  ->sreg %if y > 0
  opcode = opcode!!16_900
s(imm):
  ->err %if y > 0
simm:
  y = litval(y)
  store(y>>16,0) %if size = 4
put:
  store(y,0)
  ->next
s(ximm):  !MOVEM (IMM,EA or EA,IMM)
  %if y > 0 %start;  !EA,IMM
    opcode = opcode!!16_0400
    i = x;  x = y;  y = i
    dx == dy;  modex = mode
  %finish
  y = litval(y)
  %if prea0 <= x <= prea7 %start;  !-(SP)
    i = 0;  !Reverse bits
    i = i<<1+y&1 %and y = y>>1 %for extword = 1,1,16
    y = i
  %finish
  ->put
s(data):
  -> err %if y <= 0
  -> err %if mode # absmode
  opcode = dy_val
  ->next
err:
  fault(moperr)
  ->next
%end;  !plant

%routine PLANTLIT(%integer op,v,x)
  %if v >= 0 %start
    %if v > smallmax %then litstore(litmax) = v %and v = litmax %c
    %else v = -(v<<1)
  %else
    %if v < smallmin %then litstore(litmax) = v %and v = litmax %c
    %else v = v<<1+1
  %finish
  plant(op,v,x)
%end

%routine PLANTLIT2(%integer op,y,v)
  %if v >= 0 %start
    %if v > smallmax %then litstore(litmax) = v %and v = litmax %c
    %else v = -(v<<1)
  %else
    %if v < smallmin %then litstore(litmax) = v %and v = litmax %c
    %else v = v<<1+1
  %finish
  plant(op,y,v)
%end

%routine ALIGN(%integername AD, %integer size)
!Impose alignment requirements on address AD for
! operand of length SIZE
!provisional basis for bit addressing
! -- multiples of 16 on Word boundary
! -- multiples of 8 on Byte boundary
! -- other < 32 within one Longword
!%constinteger BITMASK=16_E0000000
!  %if size&7 = 0 %start
!    ad = (ad&(\bitmask))+1 %if ad&bitmask # 0;  !ensure on byte boundary
!    %return %if size&8 # 0
!  %else
!    %return %if size < 16
!    %return %if ad>>29+(ad&1)<<3+size <= 32
!    ad = (ad&(\bitmask))+1 %if ad&bitmask # 0
!  %finish
  ad = ad+1 %if size # 1 %and ad&1 # 0
%end

%routine ADDIMM(%integer bytes,dest)
  %if bytes <= 0 %start
    %return %if bytes = 0
    %if bytes >= -8 %start
      plantlit(sub,-bytes,dest)
      %return
    %finish
  %finish %else %if bytes <= 8 %start
    plantlit(add,bytes,dest)
    %return
  %finish
  %if a0 <= dest <= a7 %and is short(bytes)=TRUE %start
    plant(lea,tempd(dest,bytes),dest)
    %return
  %finish
  plantlit(add,bytes,dest)
%end

%integer%fn FREE REG(%integer rset)
%integer r,r1
  r = d0;  rset = rset&free
  %if rset = 0 %then fault(plexerr) %else %start
    r = r+1 %and rset = rset>>1 %while rset&1 = 0
    r1 = r
    %while c_reg_content(r) # undef %cycle
      r = r+1;  rset = rset>>1
      r = r1 %and %exit %if rset = 0
      r = r+1 %and rset = rset>>1 %while rset&1 = 0
    %repeat
    free = free-d0b<<(r-d0)
  %finish
  %result = r
%end

%routine MOVE BLOCK(%integer source,dest,bytes)
!Generate code to move a fixed number of bytes
! from SOURCE (0,reg,pre,post) to DEST (pre,post)
! -- source & dest addresses both even if BYTES even
%integer op,f,r,pc1
  op = move;  op = clr %if source = 0
  %if bytes <= 16 %and bytes&1 = 0 %start
    plant(op,source,dest) %and bytes = bytes-4 %while bytes >= 4
    plant(op+2<<8,source,dest) %if bytes >= 2
  %else;  !use loop
    op = op+1<<8
    %if bytes&1 = 0 %start
      bytes = bytes>>1;  op = op+1<<8;  !.B -> .W
      %if bytes&1 = 0 %start
        bytes = bytes>>1;  op = op+2<<8;  !.W -> .L
      %finish
    %finish
    f = free
    %if bytes <= 32768 %and free&anydreg # 0 %start
      r = free reg(anydreg)
      plantlit(move,bytes-1,r)
      pc1 = pc
      plant(op,source,dest)
      plantlit2(dbra,r,(pc1-pc-1)<<1)
      bytes = undef
    %else
      r = free reg(anydreg!bregb)
      plantlit(move,bytes,r)
      pc1 = pc
      plant(op,source,dest)
      plant(sub,one,r)
      plantlit2(bne,0,(pc1-pc-1)<<1)
      bytes = 0
    %finish
    c_reg_content(r) = bytes;  free = f
  %finish
%end

%routine UPDATE SP
  %return %if c_val = 0
  %if c_val < 0 %start
    addimm(-c_val,a7);  c_sp = c_sp-c_val
  %else
    %if control&assmask = 0 %then addimm(-c_val,a7) {no unass check} %c
    %else move block(d7,prea7,c_val)
    extend stack(c_val)
  %finish
  c_val = 0
%end

%routine GET BOUNDS(%integer t,%integername lo,hi)
![Note: sets HI after LO -- see dummy params in VALOK] 
  %if dict(t)_type = t # inttype %start;  !basetype
    lo = 0;  hi = dict(t)_size
  %else
    %if dict(t+1)_mode # litmode %then lo = minint %c
    %else lo = dict(t+1)_val
    %if dict(t+2)_mode # litmode %then hi = maxint %c
    %else hi = dict(t+2)_val
  %finish
%end

%integer%fn SIZE(%integer t)
!Storage size for given object type in bytes
! > 0 for operand passable in register
! < 0 otherwise
%integer s,ss,lo,hi
%record(identinfo)%name tp
  tp == dict(t)
  %if tp_flags&nonord = 0 %start
    %result = tp_size %if tp_type # t;  !subrange
    %result = 4 %if tp_type = inttype
    %result = 1 %if tp_size <= 255
    %result = 2
  %finish
  %result = tp_val %if tp_flags&cat = recy
  %result = tp_size %if tp_flags&cat # arry
  %result = 0 %if tp_mode >= framemode;  !dynamic bounds
  s = 4;  s = size(tp_type) %if tp_flags >= 0
  get bounds(tp_xtype,lo,hi)
  %result = 0 %if lo = minint %or hi = maxint
  ss = (hi-lo+1)*s
  %result = ss %if ss <= 0
  %if s = 1 %start;  !byte element size (not nec aligned)
    %result = ss %if ss = 1
  %else;  !word,long element size (aligned)
    %result = ss %if ss <= 4
  %finish
  %result = -ss
%end

%integer%fn NSIZE(%record(identinfo)%name dp)
  %result = 4 %if dp_flags&(name+indirect) # 0
  %result = 0 %if dp_flags&proc # 0;       ![??]
  %result = size(dp_type)
%end

%integer%fn TSIZE(%integer t)
  %result = size(dict(t)_type)
%end

%routine FORGET(%integer r)
  c_reg_content(r) = undef
%end
%routine FORGET CC
  c_reg_ccy = undef
%end
%routine FORGET REGS
%shortname cc
  %integer i
  i = maxareg
  cc==c_reg_content(i)
  %cycle
    cc = undef
    %exit %if cc == c_reg_content(d0)
    i = i-1; cc==c_reg_content(i)
  %repeat
  c_reg_ccy = undef;  c_reg_line = -9
%end
%routine FORGET TRIPLES
  litpos = litmin;  explo = explim;  oldexplo = explim
%end
%routine FORGET ALL
%integer i,j
%record(contentinfo)%name lr
  forget regs
  j = dictlim
  %cycle
    j = j+1
    %exit %if j >= curlab
    lr == lreg(j-dictlim)
    lr_content(i) = undef %for i = d0,1,maxareg
    lr_ccx = undef
  %repeat
  forget triples
%end

%routine DEFINE JUMPS(%integer chain)
%integer i,j,k
  chain = -chain
  %return %if chain <= 0;  !no jumps to this label
  c_forward = c_forward-1;  c_access = 1
  %cycle
    i = prog(chain)
    %if pflag(chain) = jump %start;  !shortenable
      j = chain-pflag(chain-1);  !adjusted jump position
      k = (pc-c_shorts-j)<<1;  !displacement
      %if k > 2 %and k <= 127 %start
        %if c_shorts = 255 %start
          zaps = zaps+100
        %else
          c_shorts = c_shorts+1;  shorts = shorts+1
          pflag(chain) = shortjump
          j = chain
          %cycle
            pflag(j) = pflag(j)+1 %if pflag(j) >= zeroshorts
            j = j+1
          %repeat %until j = pc
        %finish
      %finish
    %finish
    prog(chain) = pc
    chain = i
  %repeat %until chain <= 0
%end

%routine SAVE CONTEXT(%integer l)
!Store register content associated with label L
! (prior to generating forward branch)
%integer r
%record(contentinfo)%name lr
  %return %if l-dictlim < 0    {user label}
  lr == lreg(l-dictlim)
  %if dict(l)_val >= 0 %start;  !first jump to this label
    dict(l)_val = 0
    lr = c_reg
    c_forward = c_forward+1
  %else
    %for r = d0,1,maxareg %cycle
      lr_content(r) = undef %if lr_content(r) # c_reg_content(r)
    %repeat
    lr_ccy = undef %if lr_ccx # c_reg_ccx %or lr_ccy # c_reg_ccy
    lr_line = -9 %if lr_line # c_reg_line
  %finish
%end

%routine SRCALL(%integer x)
%routine PUT PRIM(%record(identinfo)%name DX)
!<<IMP
!* PRIMGEN marker 3
%own%short%array PRIMCODE(1:396) = 
16_1541,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_6578,
16_6365,16_6564,16_6564,16_B098,16_6E06,16_9098,16_6C10,16_D0A0,
16_41FA,16_FFDE,16_2400,16_7202,16_7076,16_4EF8,16_3EFA,16_4A58,
16_660C,16_4840,16_4A40,16_6610,16_4840,16_C0D8,16_4E75,
16_2F01,16_2200,16_C2E8,16_FFFE,16_6008,16_2F01,16_2200,16_4840,
16_C2D0,16_4841,16_C0D8,16_D081,16_221F,16_4E75,
16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
16_6162,16_6C65,16_660C,16_41FA,16_FFE8,16_7201,16_7058,16_4EF8,
16_3EFA,16_4E75,
16_0F49,16_6E76,16_616C,16_6964,16_2061,16_6464,16_7265,16_7373,
16_6E0C,16_41FA,16_FFEC,16_7201,16_7058,16_4EF8,16_3EFA,16_4E75,
16_1553,16_7461,16_636B,16_2073,16_7061,16_6365,16_2065,16_7868,
16_6175,16_7374,16_6564,16_D88F,16_B886,16_6C0E,16_4284,16_41FA,
16_FFE0,16_7203,16_7055,16_4EF8,16_3EFA,16_4284,16_4E75,
16_1741,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_696E,
16_7369,16_6465,16_206F,16_7574,16_9282,16_6F0C,16_41FA,16_FFE2,
16_7203,16_7055,16_4EF8,16_3EFA,16_4481,16_5281,16_4EF8,16_3EF4,
16_4E75,
16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
16_1811,16_9004,16_6504,16_9010,16_640C,16_41FA,16_FFE4,16_7203,
16_7051,16_4EF8,16_3EFA,16_1018,16_670C,16_D111,16_1398,16_4801,
16_5204,16_5300,16_66F6,16_2049,16_4E75,
16_3F00,16_7001,16_1E80,16_204F,16_548F,16_4E75,
16_124E,16_6F20,16_7370,16_6163,16_6520,16_666F,16_7220,16_6172,
16_7261,16_7980,16_5680,16_E480,16_E588,16_6D08,16_204F,16_91C0,
16_B1C6,16_6C0E,16_2400,16_41FA,16_FFD8,16_7201,16_7072,16_4EF8,
16_3EFA,16_205F,16_E488,16_6004,16_4840,16_2F07,16_51C8,16_FFFC,
16_4840,16_51C8,16_FFF4,16_4ED0,16_4E75,
16_1149,16_6E76,16_616C,16_6964,16_2025,16_666F,16_7220,16_6C6F,
16_6F70,16_2F00,16_9082,16_6720,16_2F01,16_6708,16_4EB8,16_3EEE,
16_4A80,16_6D0E,16_508F,16_41FA,16_FFD8,16_7201,16_7055,16_4EF8,
16_3EFA,16_4A81,16_66EE,16_221F,16_201F,16_4E75,
16_0C4F,16_7574,16_206F,16_6620,16_7261,16_6E67,16_6580,16_41FA,
16_FFF0,16_7201,16_7056,16_4EF8,16_3EFA,16_4E75,
16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
16_6162,16_6C65,16_B0FC,16_0000,16_6F1A,16_B2FC,16_0000,16_6F14,
16_BE10,16_6606,16_BE28,16_0001,16_670A,16_BE11,16_6612,16_BE29,
16_0001,16_660C,16_41FA,16_FFCA,16_7202,16_7054,16_4EF8,16_3EFA,
16_48E7,16_C0C0,16_4240,16_1018,16_6730,16_4241,16_1219,16_6722,
16_5380,16_5381,16_B041,16_6E12,16_9240,16_B109,16_56C8,16_FFFC,
16_6602,16_4441,16_4CDF,16_0303,16_4E75,
16_B109,16_56C9,16_FFFC,16_66F2,16_7201,16_4CDF,16_0303,16_4E75,
16_1011,16_4440,16_4CDF,16_0303,16_4E75,
16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
16_B010,16_640C,16_41FA,16_FFEA,16_7203,16_7051,16_4EF8,16_3EFA,
16_4280,16_1010,16_12D8,16_51C8,16_FFFC,16_4E75,
16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
16_B010,16_640C,16_41FA,16_FFEA,16_7201,16_7056,16_4EF8,16_3EFA,
16_0240,16_00FE,16_245F,16_9EC0,16_558F,16_224F,16_BFC8,16_6E0E,
16_1010,16_12D8,16_51C8,16_FFFC,16_204F,16_224F,16_4ED2,16_1018,
16_5289,16_D0C0,16_D2C0,16_1320,16_51C8,16_FFFC,16_204F,16_224F,
16_4ED2,16_4E75,
16_43EF,16_FF00,16_2448,16_D5C0,16_2049,16_9280,16_6C04,16_4211,
16_4E75,
16_1281,16_5219,16_12DA,16_51C9,16_FFFC,16_4E75,
16_700A,16_4EF8,16_3E70,16_4E75,
16_7020,16_4EF8,16_3E70,16_4E75

!<<BOTH
%integer start,limit
%record(identinfo)%name DDX
  fill code(1) %if cad&1 # 0
  start = dx_val>>16&511;  limit = start+dx_val&255
  dx_val = cad+dx_val>>7&(255<<1);  !entry
  dx_mode = procmode
  %if start = limit %start;  !range check
    ddx == dict(check)
    put prim(ddx) %and dx_val = cad %if ddx_mode = absmode
    set code word(16_0C80);  !CMPI.L #?,D0
    set code longword(dict(x+1)_val);  !lower
    set code word(16_6D00);  !BLT
    set code word(ddx_val-cad)
    set code word(16_0C80);  !CMPI.L #?,D0
    set code longword(dict(x+2)_val);  !upper
    set code word(16_6E00);  !BGT
    set code word(ddx_val-cad)
    set code word(16_4E75);  !RTS
  %else
    set code word(primcode(start)) %and start=start+1 %until start >= limit
  %finish
%end

%record(identinfo)%name dx,tp
  dx==dict(x); tp==typecell(dx_type)
  %if dx_mode = absmode %and dx_val < 0 %start;  !prim routine
   ![**for now**: the convention is inadequate because excludes abs neg]
    put prim(dx)
  %else
    c_status = c_status!unknown %if tp_val <= 0
    c_totstack = c_sp-imod(tp_val) %if c_sp-imod(tp_val) < c_totstack
  %finish
  %if dx_mode&63 = pcmode %start;  !internal
    c_forward = c_forward+1 %if dx_flags&spec # 0 %and dx_flags&rflag = 0
    plant(bsr,0,x)
  %finish %else %if dx_flags&(name+indirect) = 0 %or dx_flags&ext # 0 {temp} %start
    plant(jsr,0,x)
  %finish %else %if free&a0b<<3 # 0 %start
    plant(move,x,a0+3)
    plant(jsr,0,a0+3+indir)
    forget(a0+3)
  %else
    plant(move,x,tempd(a7,-4))
    plantlit(move,16_4EF9,tempd(a7,-6))
    plant(jsr,0,lablim)
  %finish
%end;  !srcall
!
%routine DEFINE LABEL(%integer lab)
%integer r,chain
%record(contentinfo)%name lr
  chain = dict(lab)_val
  %if chain >= 0 %start;  !label before jumps
    update sp
    forget regs
  %else
    lr == lreg(lab-dictlim)
    %if c_access = 0 %start;  !no fall-through
      c_reg = lr;  !so just incoming context
    %else;  !join
      %for r = d0,1,maxareg %cycle
        forget(r) %if c_reg_content(r) # lr_content(r)
      %repeat
      forget cc %if c_reg_ccx # lr_ccx %or c_reg_ccy # lr_ccy
      c_reg_line = -9 %if lr_line # c_reg_line
    %finish
  %finish
  define jumps(chain)
  dict(lab)_val = pc
{?}  put operand(lab) %if control&codelist # 0 %and control&list # 0
%end;  !define label

%routine SET USER LABEL(%integername chain)
  update sp
  addimm(c_temps,a7) %if c_temps # 0 %and c_access # 0  {remove temps}
  define jumps(chain)
  chain = pc
  c_access = 1;  !anyway
  addimm(-c_temps,a7) %if c_temps # 0  {restore temps}
  forget regs
  forget triples %if curlab = c_lab1
%end

%routine FLUSH
  %if pendcond < 0 %start;  !indicator for line num update
    litstore(litpos) = line
    %if control&tracebit # 0 %then plantlit2(trapi,litpos,15) %c
    %else %if line-c_reg_line > 8 %then plant(move+2<<8,litpos,lineloc) %c
    %else plantlit(add+2<<8,line-c_reg_line,lineloc)
    forget cc;  c_reg_line = line
  %else
    %if pendout # 0 %start
      pendcond = pendcond&15
      c_access = 0 %if pendcond = 0
      %if pendcond # 1 %start
        save context(pendout)
        plant(bra+pendcond,0,pendout)
      %finish
    %finish
    define label(pendin) %if pendin # 0
  %finish
  pendcond = 0
%end

!!!!!!!!!!!!!!!!   Main code generation procedure  !!!!!!!!!!!!!!!!!!!!!

%constinteger INST=1<<30

%routine EVAL(%integername pp, %integer rset)
!Evaluate the operand identified by PP as defined by RSET:
!  RSET = boolean vector of acceptable registers
!  + SIGN to indicate that stopping at EA is acceptable
!  + 1<<16 to indicate byte value ok
!  + 2<<16 to indicate short value ok
!  + STACK if stack ok [not yet: too complex]
%constinteger ASL=32,
              CMPM=43,
              TRAPV=70,
              SWAP=74, EXTL=76,
              JMP=57, TST=59, DBNE=86
              
%constinteger MOVEW=move+2<<8, ADDW=add+2<<8,
              MOVEB=move+1<<8, ADDB=add+1<<8,
              SUBB=sub+1<<8, CMPB=cmp+1<<8,
              CMPMB=cmpm+1<<8

%constinteger VAL=sign+anyreg, REF=sign,
              SIZESHIFT=16,
              TOBYTE=1<<16, TOSHORT=1<<17, {1<<18 not sig}
              TOSTACK=1<<19, ASAD=1<<20

%switch DO(0:opmax)
%owninteger STSIZ=0;  !this variable is used to convey a
    !rarely required 3rd parameter to EVAL
    !Its value is captured into STSIZE on entry
    !A negative value indicates a string;
    ! a positive value a fixed length structure
    ! * CF normal use of negative/positive size *
%integer I,J,P,ACT,X,Y,XX,YY,WX,WY,SX,SY,R,OLDFREE,FREED
%integer M,V,SP,STSIZE,OP,CASE
%record(identinfo)%name DP,DX,DY,TX

%integer%fn FREE DREG
  %result = free reg(anydreg)
%end

%integer%fn FREE AREG(%integer content)
%integer r
  r = free reg(anyareg)
  c_reg_content(r) = content
  %result = r
%end

%routine PUSH(%integer x)
  plant(move,x,prea7);  extend stack(4)
%end
%routine POP(%integer x)
  plant(move,posta7,x);  c_sp = c_sp+4
%end
%routine PUSHS(%integer x,s)
  plant(move+s<<8,x,prea7)
  %if s < 4 %then extend stack(2) %else extend stack(4)
%end

%routine PUSH BLOCK(%integer areg,bytes)
  %if bytes <= 4 %then move block(areg+indir,prea7,bytes) %c
  %else addimm(bytes,areg) %and move block(areg+pre,prea7,bytes)
  extend stack(bytes)
%end

%routine COMPILE UNCOND BRANCH(%integer l)
  %if pendcond # 0 %start
    %if pendcond < 0 %start
      pendcond = 0;  !ok?
    %finish %else %if pendin # 0 %start
      flush;                ![safe - improvable?]
    %else
      pendcond = pendcond!!1
      c_access = -2 %if pp+1 < np %and dict(pp+1)_act = else
    %finish
  %finish
  pendcond = pendcond&15
  c_access = 0 %if pendcond = 0
  plant(bra+pendcond,0,l) %if pendcond # 1
  pendcond = 0
%end

%integer%fn CLEAN REG
%integer r
  free = free-bregb %and %result = breg %if free&bregb # 0
  r = free dreg
  plant(clr,0,r)
  %result = r
%end

%integer%fn WEIGHT(%integer p)
!(Heuristic: can't anticipate all generation decisions)
%integer a,wy
%record(identinfo)%name dp
  p = p-ad %if p >= explim
  %result = 1 %if p < np0
  dp == dict(p)
  a = dp_act
  %result = 999 %if a >= imul;  !funcall,mapcall
  wy = weight(dp_y)
  %result = wy %if wy >= 999
  wy = wy-1 %if a = recref %and dict(dp_x)_flags >= 0
  %result = wy+weight(dp_x)
%end

%routine CHECK ADDRESS(%integer v)
  %if a0 <= v <= a7 %then plant(cmp+2<<8,0,v) %else plant(tst,0,v)
  srcall(adok)
  forget cc
%end

!!!!!!!!!!!!!!!!!!!  Procedure call  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      _____ACT_________X__________Y____
! P -> | procident | param 1 | param 2 |
!      |     0     | param 3 | param 4 |
!      .           .         .         .
!
%routine CALL
!Load parameters following P and call procedure ACT (DX)
! Update PP for RCALL
%integer sp,stage,maxq,awkward

%routine EVAL PARLIST(%integer arg,q)
%record(identinfo)%name darg,dv
%integer v,w,f,r,s
!Stage 0 (forward):
!Stage 0 (returning):
!Stage 1 (forward):
!Stage 1 (returning):
  %return %if arg = 0
  darg == dict(arg)
  q = q+1;  maxq = q %if q > maxq
  %if q&1 = 0 %then v = dict(p+q>>1)_x %else v = dict(p+q>>1)_y
  r = darg_reg&15
  s = size(darg_type)
  %if darg_flags&proc # 0 %start
    s = 0
    %if awkward # 0 %start
      f = v;  f = f-ad %if f >= explim
      dv == dict(f)
      %if dv_flags&(ext+spec) # ext+spec %start
      !non-external to (maybe) external
        eval parlist(darg_link,q) %and %return %if stage # 0
        %if dv_flags&(name+indirect) # 0 %then plant(move,f,prea7) %C
        %else plant(pea,0,f)
        plantlit(move+2<<8,16_4EF9,prea7)  {JMP entry}
        plant(move,mb,prea7)
        plantlit(move+2<<8,16_287C,prea7)  {MOVE #xxxx,mb}
        extend stack(12)
        s = c_sp
        eval parlist(darg_link,q)
        %if darg_val > 0 %start
          plant(pea,0,temp(c_mode,s))
        %else
          plant(lea,temp(c_mode,s),r+d0)
          free = free&(\(d0b<<r))
        %finish
        %return
      %finish
    %finish
  %finish
  %if darg_val > 0 %start;  !passed on stack
    eval parlist(darg_link,q)
    %return %if stage # 0
    %if darg_flags < 0 %start;     !name
      f = free
!      eval(v,ref)
!      plant(pea,0,v);  extend stack(4)
      eval(v,anyareg)
      push(v)
      free = f
      %return
    %finish
    %if s > 0 %start;              !simple value
      f = free;  eval(v,val)
      pushs(v,s)
      free = f
    %else;                        !structure by value
      stsiz = s
      stsiz = -stsiz %if category(darg_type) # stringy
      eval(v,tostack)
    %finish
    %return
  %finish
  %if s <= 0 %and darg_flags >= 0 %start
    !structure by value -- ad in reg
    v = v-ad %if v >= explim
    %if v >= np0 %start
      dv == dict(v)
      %if dv_act >= concat %and dv_mode = 0 %start
        !string/record function
        %if stage = 0 %start
          stsiz = s
          stsiz = -stsiz %if category(darg_type) # stringy
          r = v;  eval(r,tostack);  free = free!a0b;  ![?here?]
          c_reg_content(a0) = v+ad
          dv_val = c_sp
          eval parlist(darg_link,q)
        %else
          eval parlist(darg_link,q)
          %if c_reg_content(r+d0) # v+ad %start
            dv_mode = c_mode
            plant(lea,v,r+d0)
            dv_mode = 0
          %finish
          free = free&(\(d0b<<r))
        %finish
        %return
      %finish
    %finish
    v = v+ad
  %finish
  w = weight(v)
  %if w >= 999 %start
    eval parlist(darg_link,q)
    %return %if stage # 0
  %else
    %if w >= 2 %and stage # 0 %start
      eval(v,d0b<<r)
      eval parlist(darg_link,q)
      %return
    %finish
    eval parlist(darg_link,q)
    %return %if stage = 0
  %finish
  eval(v,d0b<<r)
%end

  awkward = 0
  awkward = 1 %and push(mb) %if dx_flags&proc2 # 0 %c
           %and (dx_flags&ext = 0 %or dx_flags&spec # 0);  !param or external
  sp = c_sp
  maxq = 0
  stage = 0
  eval parlist(dict(dx_type)_link,-1)
  stage = 1
  eval parlist(dict(dx_type)_link,-1)
  srcall(act)
  %if c_sp # sp %start
    addimm(sp-c_sp,a7);  c_sp = sp
  %finish
  pop(mb) %if awkward # 0
  pp = p+maxq>>1 %if p < np;  !update for RCALL + RESOL
  forget regs
  c_reg_line = line %if dx_flags&(ext+proc) = ext+proc1;  !%system
%end;  !call
!
%routine STRUCTCALL(%integer entry,size)
  size = mite(-size-1) %and forget(breg) %if size <= 0;  !string
  plantlit(move,size,d0)
  srcall(entry)
  forget(d0)
%end

%routine PUSH STRUCTURE
  %if stsize <= 0 %start;               !string
    structcall(strtostk,stsize)
    forget(a0);  forget(a1);  forget(a0+2)
    extend stack(256-(stsize&254))
  %else;                               !fixed size structure
    push block(a0,(stsize+1)&(\1))
  %finish
%end

%routine OK REG(%integer got)
  r = got
  %if d0b<<(got-d0)&rset = 0 %start
    c_reg_content(got) = pp
    %if rset&free = 0 %and rset&tostack # 0 %start
      push structure;  r = a7
!      push(got);  r = a7
!      c_reg_ccx = pp;  c_reg_ccy = 0
    %else
      r = free reg(rset&(\bregb));  plant(move,got,r)
      c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
    %finish
  %finish
%end

%routine OK AREG(%integer got,ok)
  r = got
  %if a0b<<(got-a0)&ok = 0 %start
    r = free reg(ok);  plant(move,got,r)
  %finish
%end

%routine LOAD ADDRESS(%integer p)
%integer i,f
  %if rset&anyareg&free # 0 %start
    %if dp_mode&2_111000 = indexmode %and dp_val&255 = 0 %start
      i = a0b<<(dp_mode&7)
      rset = i %if rset&free&i # 0
    %finish
    r = free reg(rset&anyareg)
    plant(lea,p,r)
  %else
    f = free
    i = free areg(p+ad);  plant(lea,p,i)
    free = f
    r = free reg(rset&(\bregb));  plant(move,i,r)
  %finish
%end

%routine COMMANDEER(%integer regs)
%integer r
  freed = \free&regs
  %if freed # 0 %start
    regs = freed;  r = d0
    %while regs # 0 %cycle
      push(r) %and forget cc %if regs&1 # 0
      regs = regs>>1;  r = r+1
    %repeat
    free = free!freed;  rset = rset&(\freed)
  %finish
%end
%routine RESTORE(%integer regs)
%integer r
  r = a7
  %while regs # 0 %cycle
    %if regs&16_8000 # 0 %start
      pop(r);  forget(r);  !*should have remembered it*
      forget cc
    %finish
    regs = regs<<1&16_FFFF;  r = r-1
  %repeat
%end

%routine PARTREG
! Something smaller than integer has been loaded to R
! Determine what else to do (using SX,SY)
  sy = 4 %if r = breg %or r >= a0
  %while imod(sy) < sx %cycle
    %if sy > 0 %start;  !signed
      plant(extl-2+sy,0,r);  !ext.w,ext.l
      sy = sy+sy
    %else
      %if sy = -1 %start;  !unsigned byte
        plantlit(and,255,r)
      %else;            !unsigned word (half)
        plantlit(and,16_FFFF,r)
      %finish
      sy = 4
    %finish
  %repeat
%end

!!Start of EVAL

  stsize = stsiz;  !additional parameter (for TOSTACK cases)
  rset = rset&(\anyareg) %if rset&tobyte # 0;  ![1 bit]
  p = pp;  p = p-ad %if p >= explim
  rset = rset-asad %and pp = p+ad %if rset&asad # 0
  %if p <= 0 %then dp == dint %else dp == dict(p)
  oldfree = free;  freed = 0

%if rset # inst %start
  %unless dp_mode&2_110000 = 0 %and pp < np0 %start;  !not already reg
    j = pp
    %if rset&(anydreg!bregb{+tostack}) # 0 %start;  !data reg acceptable
      i = d0
      %cycle;  !See if available
        j = i %and %exit %if c_reg_content(i) = j
        i = i+1;  i = a0 %if i = maxdreg+1
      %repeat %until i > maxareg
    %finish %else %if rset&anyareg # 0 %start;  !try address regs first
      i = maxareg
      %cycle
        j = i %and %exit %if c_reg_content(i) = j
        i = i-1;  i = maxdreg %if i = a0-1
      %repeat %until i < d0
    %finish %else %if j < explim %and rset # tostack %start;  !REF: try for address
      i = a0
      %cycle
        %if c_reg_content(i) = j+ad %start
          free = free&(\(a0b<<(i-a0)))
          dp_flags = dp_flags!(rflag+wflag)
          pp = i+indir
          %return
        %finish
        i = i+1
      %repeat %until i > maxareg
    %finish
  %else;  !already reg
    j = dp_mode+d0;       !in case reg alias
    %if rset < 0 %start;  !EA ok means any reg ok
      pp = j
      %return
    %finish
    pp = c_reg_content(j); !fiddle for update
  %finish

  %if 0 < j <= a7 %start;  !operand (now) in reg
    ok reg(j)
    dp_flags = dp_flags!rflag
    -> endload
  %finish

  %if p <= 0 %start;  !literal
    %return %if rset < 0
    %if rset = tostack %start
      i = constmode;  i = pcmode %if p = 0;  !null string [sneaky]
      plant(lea,temp(i,litval(p)),a0);           !A0 must be free
      forget(a0)
      push structure
      %return
    %finish
    %if pp < explim %start;  !normal value
      rset = rset&(\bregb) %if p < -(255<<1) %or p&1 # 0;  !0:255 ok
      r = free reg(rset)
      %if r < a0 %or p # 0 %then plant(move,p,r) %c
      %else plant(sub,r,r)
    %else;                    !address within FINAL
      i = constmode;  i = pcmode %if p = 0;  !null string [sneaky]
      load address(temp(i,litval(p)))
    %finish
    c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
    ->endload
  %finish
%finish
  %if p >= np0 %start;  !complex
more:
    act = dp_act;  x = dp_x;  y = dp_y
    xx = x;  yy = y
    -> proccall %if act > opmax
    -> do(act)
  %finish

do(move):
load:
  i = 0
  i = i+1 %if dp_flags&indirect # 0
  i = i+2 %if dp_flags < 0
  %if pp >= explim %start {address wanted}
    %if i = 0 %start
      free = oldfree
      load address(p)
    %else
      %if i = 3 %start;  !indirect name
        free = oldfree
        r = free areg(undef);  plant(move,p,r)
        p = r+indir
      %finish
      pp = p %and %return %if rset < 0
      free = oldfree
      r = free reg(rset);  plant(move,p,r)
    %finish
    c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
  %else
    %if i > 0 %start
      free = oldfree
      r = maxareg+1
      %cycle
        r = r-1
        %if r < a0 %start
          r = free areg(p+ad);  plant(move,p,r)
          plant(move,r+indir,r) %if i = 3
          check address(r) %if i > 1 %and control&assbit # 0
        %finish
      %repeat %until c_reg_content(r) = p+ad
      free = free&(\(a0b<<(r-a0)))
      p = r+indir
    %finish
    pp = p %and %return %if rset = ref
    sx = rset>>sizeshift&3;  sx = 4 %if sx = 0
    i = dp_flags
    sy = size(dp_type)
    %if c_localdpos <= p < dictlim %and i&okflag = 0 %and c_forward = 0 %start
      !local, simple, always accessed
      %if i&wflag = 0 %start;  !unassigned
        report(asserr+warn,p,0) %if c_faults = 0
      %finish
      dp_flags = dp_flags+okflag %if dp_flags >= 0 %and sy > 0
    %finish
    %if rset = tostack %start
      free = oldfree
      plant(lea,p,a0);           !A0 must be free
      forget(a0)
      push structure
      %return
    %finish
    intern(5) %and %return %if sy <= 0
    i = i!okflag %if control&bassbit>>1<<sy = 0
    %if i&okflag # 0 %and rset < 0 %start;  !not necessary to load?
      %if sy = sx %start;  !same size
         pp = p
        %return
      %finish
    %finish
    free = oldfree
    %if i&okflag # 0 %then i = -1 %else i = sy
    sy = -sy %if sy # 4 %and (dict(dp_type)_flags&nonord # 0 %c
                        %or dict(dp_type+1)_val = 0);  !unsigned
    %if sy = -1 %start;  !unsigned byte
      %if free&bregb # 0 %start
        %if rset&bregb # 0 %start
          rset = bregb
        %else
          plant(moveb,p,breg)
          forget(breg)
          p = breg;  sy = 4
        %finish
      %finish
    %finish %else rset = rset&(\bregb)
    %if sy < 2 %or sx = 1 %start
      %if rset&(anydreg!bregb) = 0 %start
      !Can't load bytes,halfs to address regs
      ! or store bytes from them
        r = free dreg
        plant(move+imod(sy)<<8,p,r)
        partreg
        p = r;  free = oldfree
      %finish %else rset = rset&(\anyareg)
    %finish
    %if sy = 2 %and rset&anyareg&free # 0 %start
      rset = rset&(\anydreg);  !prefer areg for word (auto-extend)
    %finish
    r = free reg(rset)
    plant(move+imod(sy)<<8,p,r)
    c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
    %if sy # 4 %start
      partreg
    %finish
    %if i >= 0 %start
      plant(cmp+i<<8,r,d7);  !check unassigned
      srcall(unass)
      forget cc
    %finish
    %if sy # 4 %and r # breg %start;  !not full reg
      forget(r)
      -> endload1
    %finish
  %finish
endload:
  c_reg_content(r) = pp
endload1:
  free = free&(\(d0b<<(r-d0)))
  r = r+indir %if rset = ref
  pp = r
  %return

dataload:
  eval(p,anydreg)
  ok reg(p)
  -> endload

!!!!!!!!!!!!!!!!   Array   /   Record    /   Map   !!!!!!!!!!!!!!!!!!

%integer%fn FREEISH AREG(%integer for)
!Use the register component of M if alterable
! to avoid excessive dissipation of address registers
%integer i
  i = m&7
  %result = free areg(for) %if a0b<<i&oldfree = 0 %or m >= framemode
  free = free&(\(a0b<<i))
  i = i+a0;  c_reg_content(i) = for
  %result = i
%end
%routine ADEVAL(%integer x,y,q)
!Base X, scaled index Y, displacement Q
%integer i,j
  %if x <= 0 %start;  !%const
    m = constmode;  v = litval(x)
  %else
    eval(x,ref)
    m = dict(x)_mode;  v = dict(x)_val
    %if m = c_mode %and v < 0 %start
     !*Assertion: SP will have same value when address used
      m = dispmode+7;  v = v-c_sp
    %finish %else %if m&2_111000 = aregmode+indir %start
      m = m+(dispmode-(aregmode+indir))
    %finish
  %finish
  eval(y,anyreg) %if y # 0;  !subscript
  %if m&2_111000 = indexmode %start;  !X already involves index
    %if y = 0 %start
     !See if Q can be combined with existing disp
      j = mite(v)
      i = j+q
      %if is mite(i)=TRUE %start
        v = v-j+i&255
        %return
      %finish
    %finish
    i = freeish areg(x+ad)
    plant(lea,x,i)
    m = i+(dispmode-a0);  v = 0
  %finish
  %if y # 0 %start
    %if m&63 = pcmode %start
      i = free areg(undef);  plant(lea,temp(m,v+q),i)
      m = i+(dispmode-a0);  v = 0;  q = 0
    %finish %else %unless is mite(v+q)=TRUE %start;  !indexmode out
      %unless is mite(q)=TRUE %start; !& out even if V absorbed
        i = freeish areg(undef)
        %if is short(v+q)=TRUE %start
          plant(lea,temp(m,v+q),i)
        %else
          plant(lea,x,i);  addimm(q,i)
        %finish
        q = 0
      %else
        i = freeish areg(x+ad)
        plant(lea,x,i)
      %finish
      m = i+(dispmode-a0);  v = 0
    %finish
  %finish
  v = v+q
  %if y # 0 %start
    m = m+(indexmode-dispmode)
    v = (y-d0)<<12+16_0800+v&255
  %finish
%end

do(index):
!  P      => {index,ARRAY,SUBSCRIPT}
!  ARRAY  => ARRID
!         or {index,ARRAY,SUBSCRIPT}
!         or {recref,RECORD,ARRAY}
!  TYPE INFO : TYPE = ELTYPE, XTYPE = INDEX-TYPE
!              MODE,VAL = DOPE ADDRESS
  dx == dict(x)
  i = dx_type;                   !array type cell
  tx == dict(i)
  get bounds(tx_xtype,sx,sy)
 !establish multiplier (element size)
  m = imod(nsize(tx))
 !ARRFLAG is set for either ABC requested or dynamic
  %if dx_flags&arrflag # 0 %and (y > 0 %or sx = minint %or m = 0) %start
    commandeer(d0b+d1b+a0b);  ![D1 ??]
   ! subscript
    eval(y,d0b)
   ! dope vector
    j = 0
    j = j+12 %and i = i+1 %and tx == dict(i) %while tx_mode = 0
    %if tx_flags&indirect # 0 %start
      plant(move,i,a0)
      addimm(j,a0) %if j # 0
    %else
      %if tx_val = 0 %and tx_mode = constmode %start
      ! dope info not yet created
        fill code(1) %if cad&1 # 0
        tx_val = cad
        set code longword(sy)
        set code longword(sx)
        set code longword(m)
      %finish
      plant(lea,i,a0)
    %finish
    srcall(index)
    forget(d0);  forget(a0)
    restore(freed&(\d0b))
    free = oldfree&(\d0b)
    freed = freed&d0b
    i = x;  eval(i,anyareg&free+asad)
    plant(add,d0,i)
    %if dp_flags < 0 %then forget(i) {ad of ad of P} %c
    %else c_reg_content(i) = p+ad
    free = free!d0b %if freed = 0
    restore(freed)
    m = i+(dispmode-a0);  v = 0
    -> setflags
  %finish
index1:
  !deal with subscript
  j = 0
  %if y <= 0 %start;  !literal subscript
    j = litval(y);  y = 0
  %finish
  %if y >= np0 %and dict(y)_act = add %c
   %and dict(y)_y <= 0 %start;  !Y => {add,exp,lit}
    j = litval(dict(y)_y);  y = dict(y)_x
  %finish
  %if m > 1 %start
    %if y # 0 %start
      %if m&(m-1) # 0 %and m <= 32767 %and sy <= 32767 %and sx >= -32768 %start
        putexp(muls,y,litref(m),inttype)
      %else
        putexp(imul,y,litref(m),inttype)
      %finish
      y = item
    %finish
  %finish
  %if dx_flags&(name+ext+arrflag+indirect) = indirect %and sx # 0 %start
    dx_val = dx_val+4;  !0-based
    adeval(x,y,j*m)
    dx_val = dx_val-4
  %else
    j = j-sx;  j = j*m %if m > 1
    adeval(x,y,j);  !array,index,displacement
  %finish
setflags:
  dx_flags = dx_flags!(mflag+wflag+rflag);  !don't know
setmode:
![what about FRAMEMODE?]
  %if dispmode <= m < indexmode %start
    %unless is short(v)=TRUE %start
      ok areg(m+(a0-dispmode),oldfree&anyareg)
      addimm(v,r);  forget(r)
      m = r-(a0-dispmode);  v = 0
    %finish
    %if pp >= explim %and v = 0 %and rset # ref %and dp_flags >= 0 %start
    !address wanted, disp zero, as value, not name
    ! so the address is simply in the register
      ok reg(m+(a0-dispmode))
      free = oldfree
      -> endload
    %finish
  %finish
  dp_mode = m;  dp_val = v
  ->load

do(recref):
!  P => {recref,RECORD,SUBEL}
  dx == dict(x)
  adeval(x,0,dict(y)_val);  !record,subscript,displacement
  ->setflags

do(storemap):
  v = 0
  %if y >= explim %start
    y = y-ad;  eval(y,ref)
    m = dict(y)_mode;  v = dict(y)_val
  %else
    %if y >= np0 %start
      %if dict(y)_act = add %start
        m = dict(y)_y
        y = dict(y)_x %and v = litval(m) %if m <= 0
!       eval(y,val) %if y >= dictlim
      %finish;! %else eval(y,val)
    %finish
    eval(y,anyareg)
    check address(y) %if control&assbit # 0  %and pp < explim
    m = y+(dispmode-a0)
  %finish
  -> setmode

do(lenref):
do(sindex):
  x = x-ad %if x >= explim
  dx == dict(x)
  %if y <= 0 %then adeval(x,0,litval(y)) %c
  %else eval(y,anydreg) %and adeval(x,y,0)
  -> setflags

do(dnew):
  commandeer(c_free)
  plant(move,y,d0)
  srcall(act)
  forget regs
  c_reg_line = line
  -> endmap

do(dtostring):
proccall:
  dx == dict(act)
  -> rcall %if p < np
  -> funcall %if dx_flags&writable = 0
!mapcall
  commandeer(c_free)
  call
endmap:
  free = oldfree
  r = a0
  ok areg(a0,\freed&anyareg) %if rset # ref
  restore(freed)
  free = free&(\(a0b<<(r-a0)))
  c_reg_content(r) = p+ad
  m = r+(dispmode-a0);  v = 0;  !0(A?)
  ->setmode

funcall:
  commandeer(c_free)
  call
  r = typecell(dx_type)_reg&15+d0
  c_reg_ccx = pp %and c_reg_ccy = 0 %if dx_flags&okflag # 0
endloadr:
  free = oldfree
  %if rset # ref %then ok reg(r)
  restore(freed)
  ->endload

rcall:
  flush %if pendcond # 0
  update sp
!<<IMP
  %while act = dprintstr %and x >= np0 %and dict(x)_act = concat %cycle
    dp_x = dict(x)_x;  !first of pair
    call;  free = c_free
    x = dict(x)_y;  dp_x = x
  %repeat
!<<BOTH
  call
  c_access = 0 %if dx_flags&noret # 0
  forget triples %if pp+1 = np %and curlab = c_lab1 %c
                 %and dict(curlab)_val >= 0 %and dict(curlab+1)_val >= 0
  %return

!!!!!!!!!!!!!!!!!!!!!!!!!   Operators   !!!!!!!!!!!!!!!!!!!!!!!!!!!

%routine EVALXY
  rset = rset&(\bregb)
  commandeer(d0b+d1b)
  %if 999 > weight(x) < weight(y) %start
    eval(y,d1b);  eval(x,d0b)
  %else
    eval(x,d0b);  eval(y,d1b)
  %finish
%end

%routine STACKOP(%integer s)
  stsiz = s
  sp = c_sp
  eval(x,tostack);  free = free!a0b
  eval(y,a0b+asad)
  plant(move,a7,a1);      !dest (stack)
  structcall(act,s)
  forget(a0);  forget(a1);  forget(a0+2)
%end

!<<IMP
do(prel):
!  P => {prel,BASENAME,INDEX}
  dx == dict(x)
  m = imod(size(dx_type))
  sx = 0;  sy = 999999
  -> index1

!<<BOTH

do(check):        !CHECK rangetype,value
  commandeer(d0b)
  eval(y,d0b)
  srcall(x)
  r = d0
  -> endloadr

![Note that all literal subtraction comes through as ADD]
do(add):
  %if control&overbit # 0 %start
    -> dataload %if rset&(\anyareg) = 0
    rset = rset&(\anyareg)
  %finish
  -> dataload %if rset&(\bregb) = 0
  rset = rset&(\bregb)
  %if y < 0 %start
    %if y >= litquick %start;  !(ADDQ,SUBQ)
      y = y-1 %and act = sub %if y&1 # 0;  !'negate' if 'negative'
      eval(x,rset&free)
      ->fin1
    %finish
    %if y = -(128<<1) %start;  !+128
      act = sub;  y = y+1;  !- -128 (MOVEQ)
      -> op2
    %finish
  %finish
  -> op1
do(eor):
  -> dataload %if rset&(\bregb) = 0
  rset = rset&(\bregb)
do(or):
do(and):
  -> dataload %if rset&(\anyareg) = 0
  rset = rset&(\anyareg)
op1:
  wx = weight(x)
  %if wx <= 1 %and y <= 0 %and y >= litmite %and rset&(\anyareg) # 0 %start
    rset = rset&(\anyareg)
    i = x;  x = y;  y = i
  %finish %else %if 999 > wx < weight(y) %start
    i = x;  x = y;  y = i
  %finish
  -> op2
do(sub):
  %if control&overbit # 0 %start
    -> dataload %if rset&(\anyareg) = 0
    rset = rset&(\anyareg)
  %finish
  rset = rset&(\bregb)
op2:
  eval(x,rset&free)
op3:
  oldfree = free
  %if y <= 0 %and y >= litmite %and free&(anydreg!bregb) # 0 %start
    eval(y,anydreg!bregb);           !bring Y to reg
  %finish %else %if act = eor %and y > 0 %start
    eval(y,anydreg)
  %finish %else %if act > sub %start
    %if x = breg %and y > 0 %start
      sy = tsize(y)
      %if sy = 1 %or (sy = 2 %and act = and) %start
        eval(y,val&(\anyareg)+sy<<sizeshift)
        act = act+sy<<8 %if y > d7
      %finish %else eval(y,val&(\anyareg))
    %finish %else eval(y,val&(\anyareg))
  %else
    eval(y,val)
  %finish
  free = oldfree
fin1:
  plant(act,y,x)
  -> fin3 %if act > sub
fin2:
  plant(trapv,0,0) %if control&overbit # 0
fin3:
  pp = x;  c_reg_content(x) = p
  %if act <= opmax %then c_reg_ccx = p %and c_reg_ccy = 0 %c
  %else forget cc
  %return

do(muls): do(mulu):
  -> dataload %if rset&(\(anyareg!bregb)) = 0
  rset = rset&(\(anyareg!bregb))
  eval(x,rset&free)
  oldfree = free
  eval(y,anydreg) %if y > 0;  ![could do better for short]
  free = oldfree
  plant(act,y,x)
  -> fin2

do(lsl): do(lsr):
  -> dataload %if rset&(\(anyareg!bregb)) = 0
  rset = rset&(\(anyareg!bregb))
  eval(x,rset&free)
  %if y < 0 %and y >= litquick %start
    act = act!!(lsl!!lsr) %and y = y-1 %if y&1 # 0;  !negate if neg
  %else
    oldfree = free;  eval(y,anydreg);  free = oldfree
  %finish
  ->fin1
do(neg):
  %if y # 0 %start
   r = y;  y = x;  x = r
   act = sub
   -> do(sub)
  %finish
do(not):
  -> dataload %if rset&(\(anyareg!bregb)) = 0
  rset = rset&(\(anyareg!bregb))
  eval(x,rset&free)
  plant(act,0,x)
  -> fin3
do(iabs):
  -> dataload %if rset&(\(anyareg!bregb)) = 0
  rset = rset&(\(anyareg!bregb))
  x = y
  eval(x,rset&free)
  plant(move,x,x) %if c_reg_ccx # y %or c_reg_ccy # 0
  plantlit2(bge,0,2)
  plant(neg,0,x)
  ->fin2
do(fabs):
  -> dataload %if rset&(\(anyareg!bregb)) = 0
  rset = rset&(\(anyareg!bregb))
  x = y
  eval(x,rset&free)
  plantlit(and,16_7FFFFFFF,x)
  ->fin3

%routine DO SHIFT
%integer i;
  i=0
  i = i+1 %and j = j>>1 %until j&1 # 0
  %if i = 1 %then plant(add,x,x) %else %start
    i = litref(i)
    %if i < litquick %start
      oldfree = free;  eval(i,anydreg);  free = oldfree
    %finish
    plant(asl,i,x)
  %finish
%end

do(imul):
  -> dataload %if rset&(\(anyareg!bregb)) = 0
  rset = rset&(\(anyareg!bregb))
 !Test for power of 2 or pair of powers of 2
  %if y < 0 %start
    j = litval(y)
    i = j&(j-1)
    %if i = 0 %or i&(i-1) = 0 %start
      eval(x,rset&free)
      do shift %if j&1 = 0
      %if j # 1 %start
        plant(move,x,prea7)
        do shift
        plant(add,posta7,x)
      %finish
      ->fin2
    %finish
  %finish
do(fsub): do(fdiv):
do(ipow): do(fpow):
do(fadd): do(fmul):
  evalxy
  srcall(act)
  plant(trapv,0,0) %if act = imul %and control&overbit # 0
  forget(d1);  r = d0
  forget cc
  -> endloadr

do(idiv): do(drem):
  %if control&halfbit # 0 %start
    act = divs %if act = idiv
do(divs): do(divu):
    -> dataload %if rset&(\(anyareg!bregb)) = 0
    rset = rset&(\(anyareg!bregb))
    eval(x,rset&free)
    oldfree = free
    eval(y,anydreg)
    free = oldfree
    %if act = drem %then plant(divs,y,x) %and plant(swap,0,x) %c
    %else plant(act,y,x)
    plant(extl,0,x)
    -> fin3
  %finish
  evalxy
  srcall(idiv)
  putexp(act!!(idiv!!drem),xx,yy,inttype)
  %if act = idiv %start
    c_reg_content(d1) = item;  r = d0
  %else
    c_reg_content(d0) = item;  r = d1
  %finish
  forget cc
  ->endloadr

do(float):
do(fneg):
  commandeer(d0b)
  eval(x,d0b)
  srcall(act)
  forget cc
  r = d0
  ->endloadr

do(concat):      !not special case
![they have to be free]  commandeer(d0b+bregb+a0b+a1b+a2b)
  fault(plexerr) %if free&(a0b+a1b+a2b+d0b+bregb) # a0b+a1b+a2b+d0b+bregb
  stackop(-256)
endconc:
  %if rset&tostack = 0 %start
    %if c_sp # sp %start
      addimm(sp-c_sp,a7);  c_sp = sp
    %finish
  %finish %else rset = a0b
  r = a0
  ->endloadr

!!!!!!!!!!!!!!!!!!!!!   Conditions   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%routine CONDSWOP
!Swop condition operands, adjusting operator accordingly
%integer temp
  temp = x;  x = y;  y = temp
  temp = xx;  xx = yy;  yy = temp
  temp = sx;  sx = sy;  sy = temp
  temp = wx;  wx = wy;  wy = temp
  case = case!!3 %if case&8 # 0;  !no change for '=','#'
%end

%routine UNSIGNED
  %if case&8 # 0 %start;  !no change for '=','#'
    case = case!!8
    case = case!!4 %if case&2 # 0
  %finish
%end

![Some confusion here of which operand (weightier) to evaluate first
![                   and which to bring to register
![EVAL improvements make possible greater finesse:
![               1. Decide which to evaluate first (weightier)
![               2. EVAL both 'val'
![               3. If either in register, OK
![               4. Load one
![*for IMP, conditions cannot be embedded in other expressions;
![*for Pascal, they can.  This needs improvement to cover that.
do(compare):
  flush %if pendcond # 0
  update sp
  sp = c_sp
  pp = pp+1;  dp == dict(pp)
  case = dp_act
  %if x <= 0 %start;  ![1st literal: only for true,false]
    case = case!!1 %if x = 0;  !invert for false
    pendcond = case&1+bra
    -> endcomp
  %finish
  %if x >= explim %start;        !address
    dx == dict(x-ad);  sx = 4
  %else
    dx == dict(x)
    tx == dict(dx_type);  sx = size(dx_type)
  %finish
  dx_flags = dx_flags!rflag
  %if y >= explim %or y <= 0 %then sy = 4 %else sy = tsize(y)
  wx = 0 %and wy = 0 %and condswop %if c_reg_ccx = y %and c_reg_ccy = x
  %if c_reg_ccx # x %or c_reg_ccy # y %start;  ![???unsigned???]
    %if y # 0 %start;  !not comparison with zero
      wx = weight(x);  wy = weight(y)
      condswop %if wx < 999 %and wy > wx+1
      %if x >= explim %or y >= explim %start;  !one or other is address
        !swop if Y is not name (to use LEA)
        condswop %if 0 <= y-ad < dictlim %and dict(y-ad)_flags >= 0
        eval(x,anyareg)
        eval(y,sign+anyareg)
        plant(cmp,y,x)
        c_reg_ccx = xx;  c_reg_ccy = yy
      %finish %else %if sx > 0 %start;  !simple operand
        %if tx_flags&cat = realy %start
          eval(x,d0b);  eval(y,d1b)
          srcall(fsub)
          forget(x)
          c_reg_ccx = xx;  c_reg_ccy = yy
        %finish %else %if y < 0 %start;         !comparison with literal
          %if y >= litmite %start
            eval(x,val+sx<<sizeshift)
            %if (sx = 4 %and free&anydreg # 0) %c
            %or (x > a7 %and dict(x)_mode&63 = pcmode) %start
              eval(y,anydreg)
              condswop %and sx = sy %unless x <= d7
            %finish
          %else
            sx = 0 %if sx = 1;   ![to ensure comparison fails?]
            eval(x,val+sx<<sizeshift)
            sx = 2 %if a0 <= x <= a7 %and is short(litval(y))=TRUE
          %finish
          plant(cmp+sx<<8,y,x)
          unsigned %if sx = 1
          c_reg_ccx = xx;  c_reg_ccy = yy
        %else;  !Y not literal
          condswop %if sy < sx
          eval(x,anyreg)
          %if sy <= 2 %and sy = sx %and (sy=1 %or x < a0) %start
            eval(y,val+sy<<sizeshift)
            plant(cmp+sy<<8,y,x)
            unsigned %if sy = 1
            forget cc
          %else
            eval(y,val)
            plant(cmp,y,x)
            c_reg_ccx = xx;  c_reg_ccy = yy
          %finish
        %finish
      %else;            !structure
        stsiz = sx;  stsiz = -stsiz %if tx_flags&cat # stringy
        %if (case&8 = 0 %and control&strassbit = 0) %C
        %or stringy # tx_flags&cat # sety %start
          !equals,notequals or rec,array
          ! [No routine call required to implement]
          %if wy >= 999 %start;  !both complex
            eval(x,tostack);  free = free!a0b
            eval(y,anyareg&free+asad)
            x = freeareg(undef)
            plant(move,a7,x)
          %else
            eval(x,anyareg&free+asad)
            forget(x)
            eval(y,anyareg&free+asad)
          %finish
          i = free dreg
          %if tx_flags&cat = stringy %start;  !string comparison
            plant(clr,0,i)
            plant(moveb,x+indir,i)
          %else
            plantlit(move,-sx-1,i)
          %finish
          plant(cmpmb,x+post,y+post)
          plantlit2(dbne,i,-4)
          forget(i);  forget(y)
        %else
         ! [Routine call required: must bring complex to stack]
          %if wx >= 999 %start
            eval(x,tostack);  free = free!a0b
            %if wy >= 999 %start
              stsiz = sy;  stsiz = -stsiz %if tx_flags&cat # stringy
              eval(y,tostack)
              y = a1;  plant(move,a7,y)
              sy = (imod(sy)+1)&(\1);  sy = 256 %if sy = 0
              x = a0;  plant(lea,tempd(a7,sy),x)
            %else
              eval(y,a1b+asad)
              x = a0;  plant(move,a7,x)
            %finish
          %else
            eval(x,a0b+asad);  eval(y,a1b+asad)
          %finish
!<<IMP
          srcall(scomp)
          unsigned
!<<BOTH
        %finish
        forget cc
      %finish
    %else;  !comparison with zero
      %if sx <= 0 %or (sx = 1 %and dx_mode >= dispmode) %start
        %if tx_flags&cat = stringy %or sx = 1 %start
          eval(x,ref)
          plant(tst+1<<8,0,x)
          forget cc;  !*for now*
          unsigned
        %else
          eval(x,anyareg&free+asad)
          i = free dreg
          plantlit(move,-sx-1,i)
          plant(tst+1<<8,0,x+post)
          plantlit2(dbne,i,-4)
          forget(i);  forget(x)
        %finish
      %else
        eval(x,anydreg)
        %if c_reg_ccx # xx %or c_reg_ccy # 0 %start
          plant(move,x,x);  c_reg_ccx = xx;  c_reg_ccy = 0
        %finish
      %finish
    %finish
  %finish
  pendcond = case
endcomp:
  pendin = dp_x;  pendout = dp_y
checksp:
  %if c_sp # sp %start
    addimm(sp-c_sp,a7);  c_sp = sp
  %finish
!<<IMP
  %return

do(resolves):
  flush %if pendcond # 0
  update sp
  sp = c_sp
!  push(mb)
!  eval(x,a0b+asad);  !string to be resolved
!  act = dict(y)_act;  x = dict(y)_x;  y = dict(y)_y
!  eval(x,a1b);  eval(act,a0b<<2);  eval(y,a0b<<3);  !match, fore, aft
!  srcall(resolves)
!  pop(mb)
!  forget regs
  dx == dict(act)
  call
  pp = pp+2;  dp == dict(pp)
  pendcond = dp_act
  -> endcomp

!<<BOTH
!!!!!!!!!!!!!!!!!!!!!!!!   Assignment   !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%integerfn EASY(%integer y)
! Determine if structure assignment (string, set)
!  can be done by store-to-store op(s) and if so, do it.
%integer r1,f
%record(identinfo)%name dy
%owninteger s=0
  %result = FALSE %if y < np0
  dy == dict(y)
  %result = FALSE %if dy_act > concat %or dy_act = prel
  f = free
  %if dy_x = x %start;  !recursion ends, successfully
    s = tsize(x);  s = -s %if dy_act # concat;  !+ve unless string
    eval(x,a1b+asad)
  %else
    %result = FALSE %if dy_y >= np0 %or dy_y = x %c
    %or %not easy(dy_x)=TRUE
  %finish
  y = dy_y
  %if y >= np0 %and dict(y)_act = dtostring %start
    y = dict(y)_x;  eval(y,tobyte+val);  !character value
    r1 = clean reg
    plant(addb,one,x+indir);              !inc length(dest)
    plant(moveb,x+indir,r1)
    plant(moveb,y,tempx(x,r1));          !append char
    forget(r1)
  %else
    eval(y,a0b+asad)
    structcall(dy_act,s)
    forget(a0);  forget(a1)
    forget(d1);  forget(d2)
  %finish
  free = f&(\a1b)
  %result = TRUE
%end

%routine BEWARE(%integer dest)
![not foolproof: ?too expensive to do properly
!                 too inefficient to fail safe]
%integer r,d
%integerfn UNSAFE(%integer p)
![a bit cavalier]
  %cycle
    %result = FALSE %if p <= undef;        !literal, basereg or undef
    %result = TRUE %if p = dest %or p = d {%or d >= np0
    p = p-ad %if p >= explim
    %result = FALSE %if p < np0
    %result = TRUE %if dict(p)_act > opmax;  !funcall,mapcall
    %result = TRUE %unless dest # dict(p)_y < np0
    p = dict(p)_x
  %repeat
%end
  forget(dest) %and %return %if dest <= a7
  d = dest;  d = d-ad %if d >= explim
  %for r = d0,1,maxareg %cycle
    forget(r) %if unsafe(c_reg_content(r))=TRUE
  %repeat
  forget cc %if unsafe(c_reg_ccx)=TRUE %or unsafe(c_reg_ccy)=TRUE
%end

%integerfn XFREE(%integer v,strong)
%record(identinfo)%name dp
  %cycle
    v = v-ad %if v >= explim
    %exit %if v < dictlim
    dp == dict(v)
    %result = FALSE %unless xfree(dp_y,1)=TRUE
    strong = 1 %if dp_y >= dictlim
    v = dp_x
  %repeat
  %result = TRUE %if v # x %or strong = 0
  %result = FALSE
%end

!<<IMP
do(forass):  !FORASS:loopvar:start'
             ! --   :inc    :end
  eval(y,d0b)
  pp = pp+1;  dp == dict(pp)
  i = dp_x;  eval(i,d1b);  i = dp_y;  eval(i,d2b)
  srcall(forok)
!<<BOTH
do(jamass):
do(assign):
do(okass):
  flush %if pendcond # 0
  %if xx >= explim %start;  !ad of ...
    wx = weight(xx-ad)
    dx == dict(xx-ad)
    sx = 4
  %else
    wx = weight(xx)
    dx == dict(xx)
    sx = size(dx_type)
  %finish
  tx == dict(dx_type)
  sp = c_sp-c_val
  %if sx <= 0 %start;  !structure assignment
    !Structure
    ![for rec/string assignment beware corruption of stacked
    ! structure in computing DEST]
    update sp
    %if tx_flags&cat = stringy %start
      sx = -256 %if sx = 0;   !string(*)
      op = -1;  op = dict(y)_act %if y >= np0
      %if y = 0 %start;  !""
        eval(x,ref)
        plant(clr+1<<8,0,x)
      %finish %else %if op = dtostring %start
        y = dict(y)_x
        eval(y,tobyte+val);  !character value
        eval(x,anyareg&free+asad)
        plant(moveb,one,x+post)
        plant(moveb,y,x+indir)
        forget(x)
        forget cc
      %finish %else %if act = jamass %or %not easy(y)=TRUE %start
        %if op >= concat %and wx > 1 %start
        ! Danger of corruption of RHS
          stsiz = sx
          eval(y,tostack);  free = free!a0b
          eval(x,a1b+asad)
          plant(move,a7,a0);  y = a0
          structcall(strcopy,sx)
        %finish %else %if act # assign %or sx = -256 %or control&capbit = 0 %start
        ! No check needed
          %if wx > 1 %then eval(x,anyareg&free+asad) %and eval(y,anyareg&free+asad) %c
          %else eval(y,anyareg&free+asad) %and eval(x,anyareg&free+asad)
!not worth %if act # jamass %and sx >= -4 %start
!            %cycle
!              plant(moveb,y+post,x+post)
!              sx = sx+1
!            %repeat %until sx >= 0
!          %else
            i = free reg(anydreg!bregb)
            %if act = jamass %start
              plantlit(move,mite(-sx-1),i)
              plant(moveb,i,x+post)
              plant(cmpb,y+post,i)
              plantlit2(bcs,0,6);     ! 3 2-byte instructions **
              plant(sub,one,x)
              plant(moveb,y+pre,i)
            %else
              plant(moveb,y+indir,i);   !length (dirty OK)
            %finish
            plant(moveb,y+post,x+post)
            plant(subb,one,i)
            plantlit2(bcc,0,-6)
            forget(i)
!          %finish
        %else
          %if wx > 1 %then eval(x,a1b+asad) %and eval(y,a0b+asad) %c
          %else eval(y,a0b+asad) %and eval(x,a1b+asad)
          structcall(strcopy,sx)
        %finish
        forget(x);  forget(y)
        forget cc
      %finish
    %finish %else %unless easy(y)=TRUE %start
      eval(x,anyareg&free+asad) %if y = 0 %or wx > 1
      %if y # 0 %start
        sx = tsize(y) %if sx = 0
        eval(y,anyareg&free+asad)
        forget(y)
        y = y+post
        eval(x,anyareg&free+asad) %if wx <= 1
      %finish
      forget(x)
      %if sx = 0 %then fault(sizerr) %else move block(y,x+post,-sx)
    %finish
    beware(xx)
    -> checksp
  %finish
!Simple operand
  %if c_val # 0 %start
    %if dx_val = sp %and dx_mode = c_mode %start
      %if sx = 4 %or x >= explim %then c_val = c_val-4 %c
      %else c_val = c_val-2
    %finish
    update sp
  %finish
  op = move
  case = val;  case = case+sx<<sizeshift %if sx # 4
  %if x <= a7 %start;  !explicit assignment to reg
    %if xfree(y,0)=TRUE %start
      case = 1<<(x-d0);  free = free!case
    %else
      free = free&(\(1<<(x-d0)))
    %finish
  %finish
  %if sx # 4 %and act = assign %and control&capbit # 0 %start
    eval(y,d0b)
    srcall(dx_type);  !range check
  %finish
  i = y;  i = i-ad %if i >= explim
  %if i >= np0 %start;                        !SOURCE complex
    %if dx_flags&okflag # 0 %or control&bassbit>>1<<sx = 0 %start
      dy == dict(i)
      %if y >= explim %start
        %if dy_act = prel %and dy_x = x-ad %c
        %and (dy_y < 0 %or dy_type = bytetype) %start
          y = dy_y
          y = litref(litval(y)*imod(size(dy_type))) %if dy_type # bytetype
          act = add
          -> tostore
        %finish
      %else
        %if dy_x = x %c
        %and (dy_act < neg %or (dy_act = neg %and dy_y = 0)) %start
          act = dy_act;  y = dy_y
          -> tostore
        %finish
      %finish
    %finish
    %if wx < 999 %then eval(y,case) %and eval(x,ref) %c
    %else eval(x,ref) %and eval(y,case)
  %else
    eval(x,ref)
    %if y <= 0 %start
      %if y = 0 %and dx_flags&readable # 0 %then op = clr %c
      %else %if y >= litmite %and sx = 4 %then eval(y,anydreg)
    %else
      eval(y,case) %unless y <= a7
    %finish
  %finish
  %if y # x %start
    %if 0 < y <= maxareg %and 0 < yy = c_reg_content(y) %start
      beware(xx)
      c_reg_content(y) = xx
    %finish %else beware(xx)
    plant(op+(sx&3)<<8,y,x)
    c_reg_ccx = xx;  c_reg_ccy = 0
  %finish %else beware(xx)
endass:
  dx_flags = dx_flags!okflag %if c_localdpos <= xx < dictlim %c
           %and c_forward = 0
  %return

do(incass):  !(for %for loop)
  flush %if pendcond # 0
  dx == dict(xx)
  sx = size(dx_type)
  wx = weight(x)
  act = add
tostore:
  %if y = 0 %start;  ![only for NOT,NEG]
    eval(x,ref)
  %finish %else %if y < 0 %start
    %if act = add %start;  ![+- literal]
      %if y >= litquick %start;  !-8:-1 or 1:8
        act = sub %and y = y-1 %if y&1 # 0;  !negate if neg
        eval(x,ref)
        -> past
      %finish
      act = sub %and y = y+1 %if y = -(128<<1);  !128=>-128
    %finish
    eval(x,ref)
    eval(y,anydreg) %if y >= litmite %and anydreg&free # 0
  %finish %else %if x <= a7 %start
    eval(y,val)
  %else
    %if 999 > wx < weight(y) %then eval(y,anydreg) %and eval(x,ref) %c
    %else eval(x,ref) %and eval(y,anydreg)
  %finish
past:
  plant(act+sx<<8,y,x)
  plant(trapv,0,0) %if control&overbit # 0 %and act <= sub
  beware(xx)
  c_reg_ccx = xx;  c_reg_ccy = 0
  ->endass


!!!!!!!!!!!!!!!!!!!!!!   Returns and jumps   !!!!!!!!!!!!!!!!!!!!!!!!
!
do(return):                 !terminate procedure
  update sp
  %if c_type # 0 %start;       !function,map
    r = typecell(c_dpid_type)_reg&15
    %if c_type > 0 %and size(c_type) > 0 %start;  !simple fn
      flush %if pendcond # 0 %and pendin # 0
      i = y
      %if c_reg_content(r+d0) # y %start
        flush %if pendcond # 0
        eval(y,d0b<<r)
      %finish
      c_status = c_status!wrongcc %unless c_reg_ccx = i %and c_reg_ccy = 0
    %else;   !struct fn or map
      c_status = c_status!wrongcc
      flush %if pendcond # 0
      y = y+ad %if c_type > 0;  !ie struct fn
      sp = c_sp
      eval(y,d0b<<r)
      %if c_sp # sp %start
        addimm(sp-c_sp,a7);  c_sp = sp
      %finish
    %finish
  %finish
  %if c_temps # 0 %start
    flush %if pendcond # 0
    addimm(c_temps,a7)
  %finish
  dict(dictlim)_val = c_return
  compile uncond branch(dictlim)
  c_return = -(pc-1)
  %return

do(jumpout):
  update sp
  flush %if pendcond > 0 %and pendin # 0
  save context(y) %if y # x;  !exit not continue
  compile uncond branch(y)
  %return

do(repeat):
  update sp
  compile uncond branch(x)
  define label(x+1) %if dict(x+1)_val < 0
  %if y < 0 %start;  !temp(s) declared
    c_val = y;  c_temps = c_temps+y;  !decrement temps
    update sp
  %finish
  %return

do(else):
  %if c_access # 0 %and c_access # -2 %start
    save context(y)
    compile uncond branch(y);  !outward branch for %else
  %finish
  define label(x) %if x # 0 %and dict(x)_val < 0;  !inward from false cond
  %return

do(goto):                        !user jump
  update sp
  c_forward = c_forward+1 %if dict(y)_val = 0
  addimm(c_temps,a7) %if c_temps # 0
  i = pendcond
  compile uncond branch(y)
  addimm(-c_temps,a7) %if i # 0 %and c_temps # 0
  %return

do(label):
  update sp
  define label(x)
  %return

do(stop):
  update sp
  flush %if pendcond # 0
  plant(clr,0,d0)
  srcall(signal)
  c_access = 0
  %return

do(signal):
  update sp
  flush %if pendcond # 0
  sp = c_sp
  pp = pp+1;  dp == dict(pp)
  xx = dp_x;  yy = dp_y
  x = litval(x)
  %if yy # undef %start
    eval(yy,a0b+asad);  x = x+64
  %finish
  %if xx # undef %start
    eval(xx,d2b);  x = x+32
  %finish
  %if y # undef %start
    eval(y,d1b);  x = x+16
  %finish
  x = litref(x)
  eval(x,d0b)
  %if control&sysbit # 0 %then plant(jmp,0,signal) %else plant(jsr,0,signal)
  %if c_sp # sp %start;  ![earlier?]
    addimm(sp-c_sp,a7);  c_sp = sp
  %finish
  c_access = 0
  %return

do(settrap):
  update sp
  push(d0+6);                     ![historical]
  push(mb)
  plant(pea,0,temp(pcmode,10));  !address of mask [2+2+2+4]
  c_sp = c_sp-4
  push(gb+indir);                ![2 bytes]
  plant(move,a7,gb+indir);       ![2 bytes]
  c_eventsp = c_sp
  c_forward = c_forward+1
  lreg(c_lab1-dictlim) = c_reg
  plant(bra,0,c_lab1);           ![4 bytes]
  pflag(pc-1) = longjump;  !**not to be shortened
  forget regs
  plant(dc,0,temp(absmode,litval(y)));  !event mask
!  store(litval(y),0);  !event mask
  %return

do(swgoto):                     !switch jump
  flush %if pendcond # 0
  update sp
  dx == dict(x)
  dx_flags = dx_flags!rflag
  i = dx_val;  !start of table
  dy == typecell(dx_type)
  get bounds(dy_xtype,sx,sy)
  %if y <= 0 %start;  !literal subscript
    y = litval(y)
    i = i+y-sx
    addimm(c_temps,a7) %if c_temps # 0
    plant(bra,0,temp(labmode,prog(i)))
    prog(i) = dtemp_val;               !updated by PCREL
  %else
    eval(y,d0b)
    %if i > pc %start;                  !first jump (I >= SWPC)
      c_forward = c_forward+(sy-sx+1)
      %if dx_flags&arrflag = 0 %start;  !no check
        addimm(c_temps,a7) %if c_temps # 0
        plant(lea,temp(pcmode,10-sx-sx),a0); !LEA ?(PC),A0
        plant(add,d0,d0);                 !ADD D0,D0
      %else
        wx = 12
        %if c_temps # 0 %start
          wx = wx+2;  wx = wx+2 %if c_temps > 8
        %finish
        plant(lea,temp(pcmode,wx),a0)
        srcall(index)
        addimm(c_temps,a7) %if c_temps # 0
      %finish
      plant(add+2<<8,tempx(a0,d0),a0); !ADD.W 0(A0,D0),A0
      plant(jmp,0,a0+indir);         !JUMP (A0)
      %if dx_flags&arrflag # 0 %start
        store(sy>>16,0);  store(sy,0)
        store(sx>>16,0);  store(sx,0)
        store(0,0);  store(2,0)
      %finish
      dx_val = pc
      %cycle
        store(prog(i),0)
        swpc = swpc+1 %if i = swpc;  i = i+1
        sx = sx+1
      %repeat %until sx > sy
    %else;  !just branch to earlier sequence
            ![gives wrong line number for error]
            ![wrong if temps]
      i = i-7 %if dx_flags&arrflag # 0
      plant(bra,0,temp(labmode,i-6))
    %finish
  %finish
  c_access = 0
  %return

do(asize):
  %if y # 0 %start;  !first: prime D0
    update sp
    eval(y,d0b);  !basic itemsize
  %else
    srcall(asize)
  %finish
  pp = pp+1;  dp == dict(pp)
  xx = dp_x;  yy = dp_y
  free = c_free-d0b;  !not d0
  eval(xx,d1b);  !lower
  eval(yy,d2b);  !upper
  push(d0);  !size
  push(d1);  push(d2)
  forget regs
  free = free!(d1b+d2b)
  dict(x)_val = c_sp
  %return
!
do(adok):  ![spare code]
!Push size of dynamic array (& 0-base value) for AGET
  update sp
  %if x # 0 %start
    %if x # d0 %then eval(x,d0b) %else srcall(asize)
  %finish
  push(y) %if y # 0
  push(d0)
  %return

do(aget):
  plant(move,x,d0)
  srcall(aget)
  plant(move,a7,x)
  %if y # 0 %start
    dx == dict(x)
    dx_val = dx_val+4
    plant(move,a7,d0)
    plant(add,d0,x)
    dx_val = dx_val-4
  %finish
  forget(d0);  forget(a0)
  %return

%routine COMPILE ENTRY(%integer linked,arg)
!Entry sequence generated at end
%integer i,r,vsp,lastvsp,holdsp
%record(identinfo)%name darg,tp
  holdsp = c_sp
  c_sp = 0;  lastvsp = 0
  c_stack = c_stack-4 %if linked > 0;  !allow for link
  %if linked = 0 %and c_status&onstack # 0 %start
    !justify addressing assumed for onstack parameters
    c_sp = 4;  holdsp = holdsp-4;  c_stack = c_stack-4
  %finish
  c_stack = c_stack-4;              !and return address
  c_totstack = c_stack %if c_stack < c_totstack
  %if control&stackbit # 0 %c
  %and (c_status&unknown # 0 %or c_totstack < -128) %start
    plantlit(move,c_stack,breg);  !*ok - gets cleared*
    srcall(stackok)
  %finish
  %if level > outerlevel %and linked > 0 %start;  !link required
    %if level > 1 %start
      plant(move,tempd(gb,level<<2),prea7);  !MOVE ?(GB),-(SP)
      plant(move,a7,tempd(gb,level<<2));  !MOVE SP,?(GB)
    %else
      plant(link,0,f1);       !LINK #0,Ax
    %finish
  %finish
  darg == dict(arg)
  %cycle
    arg = darg_link
    %exit %if arg = 0
    darg == dict(arg)
    %if darg_val <= 0 %start;  !passed in reg, not on stack
      vsp = darg_val
      r = darg_reg&15+d0
      %if darg_flags&mflag # 0 %or linked > 0 %start
        addimm(lastvsp-c_sp,a7);  c_sp = lastvsp
        i = nsize(darg)
        %if i > 0 %start
          ! name or simple operand by value
         !NB MOVE.B transfers to hi byte
          plant(move+i<<8,r,prea7)
        %finish %else %if darg_flags&proc # 0 %start;  !proc as param
          plant(move,r,prea7)
          plantlit(movew,16_4EF9,prea7)
        %else;                          !structure by value
          tp == typecell(darg_type)
          %if tp_flags&cat = stringy %start
            %if control&capbit # 0 %and tp_size > -256 %start
              plantlit(cmp+1<<8,-tp_size,r+indir)
              plantlit2(bcs,0,4)
              srcall(check)
            %finish
            i = c_sp-vsp
            addimm(-i,a7);            !SP = SP-bytes
            extend stack(i)
           !MOVE.B length,Dx
            plant(moveb,r+indir,breg)
           !MOVE.B 0(Ay,Dx),0(SP,Dx)
            plant(moveb,tempx(r,breg),tempx2(a7,breg))
            plant(subb,one,breg)
            plantlit2(bcc,0,-10)
          %else;  !fixed length structure
            free = bregb
            push block(r,c_sp-vsp)
          %finish
        %finish
        c_sp = vsp
      %finish
      lastvsp = vsp
    %finish
  %repeat
  %if c_sp # 0 %start;  !there are accesses to params
    addimm(lastvsp-c_sp,a7)
    c_sp = holdsp
  %finish %else c_sp = holdsp-lastvsp;  !reduce
%end

do(end):
  compile entry(c_status&globbed,c_dpid_type)
  %return

do(*): intern(8)
do(0):  !null action
%end;  !eval

%routine COMPILE(%integer startp)
%integer p
{?}  show exp(startp) %if control&explist # 0 %and control&list # 0
  np = np0 %and %return %if faultnum > 0
  pendcond = 0
  p = startp-1
  %cycle
    free = c_free
    p = p+1
    %if p >= np %start
      %if startp = np0 %start
        np = np0
        flush %if pendcond > 0
        %return
      %finish
      np = startp;  startp = np0;  p = startp
    %finish
    %if c_reg_line # line %and control&(tracebit!diagbit!linebit) # 0 %start
      flush %if pendcond > 0
      pendcond = -1
    %finish
    eval(p,inst)
  %repeat
%end;  !compile

%routine SET FIRST ENTRY
%integer j,k,p
%record(identinfo)%name dp
  firstpos = dictlim;  firstentry = finalbound
  p = 0
  %cycle
    p = p+1
    %exit %if p >= dlim
    dp == dict(p)
    %continue %if dp_mode # procmode
    %continue %if dp_val >= firstentry
    j = dp_val
    %if j <= 0 %start
      %continue %if j = 0
      k = -j
      %cycle
        j = k<<1
        k = code word(j)&16_FFFF
      %repeat %until k = 0
      %continue %if j >= firstentry
    %finish
    firstentry = j;  firstpos = p
  %repeat
%end

%routine DEFINE ENTRY(%integer chain,entry,pid)
%integer j
  %cycle
    chain = chain<<1
    report(reacherr,pid,0) %unless is short(entry-chain)=TRUE
    j = code word(chain)&16_FFFF
!$IF VAX
{  final(chain) <- (entry-chain)>>8;  final(chain+1) <- entry-chain
!$IF APM
  shortinteger(final0+chain) <- entry-chain
!$FINISH
    chain = j
  %repeat %until chain = 0
%end

%routine CHECK REACH(%integer blocksize)
!Add stepping stones if necessary
%integer i
  %cycle
    i = blocksize+cad
    croak("Program too big") %if i >= ownbase
    %return %if i-firstentry < 31000;  !enough leeway
    %return %if blocksize >= 32000 %or cad-firstentry >= 32760;  !hopeless
    %if dict(firstpos)_val < 0 %start
      define entry(-dict(firstpos)_val,cad,firstpos)
      set code word(16_6000);  !BRA
      dict(firstpos)_val = -cad>>1
      set code word(0)
    %else
      dict(firstpos)_val = cad
      set code word(16_6000);  !BRA
      set code word(firstentry-cad)
    %finish
    steps = steps+2
    set first entry
  %repeat
%end

%routine PUT WORD(%integer v)
    printsymbol(v>>8&255);  printsymbol(v&255)
%end

%routine DO EXTERNALS(%integer chain,specs)
%integer k,a,b
%record(identinfo)%name dp,tp

  byteinteger(charlim) = 0;  ![see test for %alias]
  value = 2
  %cycle
    dp == dict(chain)
    a = dp_text+char0;  b = byteinteger(a)
    %if byteinteger(a+b+1)&128 # 0 %start;  !aliased
      a = a+b+1;  b = byteinteger(a)-128
    %finish
    value = value+(b+14)&(\1)
    %if specs >= 0  %start;  !for real
      put word(dp_flags&(ext+proc)!sign16)
      put word(dp_mode)
      k = 0
      %if dp_flags&proc # 0 %start
       !create type word
        tp == dict(dp_type)
        k = 4;  k = 6 %if tp_type # 0;  !100:R 11x:F,M
        %cycle
          k = k+1 %if tp_reg&8 # 0;    !0:dreg, 1:areg
          %exit %if tp_link <= 0
          tp == dict(tp_link);  k = k<<1
        %repeat
        !special code (11) for %routine ...(%string(255) parm)
        k = k+2 %if k = 9 %and tp_type = stringtype %and tp_flags >= 0
      %finish
      put word(k>>16);  put word(k)
      put word(dp_val>>16);  put word(dp_val)
      put word(b<<8+byteinteger(a+1))
      %cycle
        a = a+2;  b = b-2
        %exit %if b < 0
        k = byteinteger(a)<<8
        k = k+byteinteger(a+1) %if b > 0
        put word(k)
      %repeat
    %finish
    chain = dp_link
  %repeat %until chain = 0
  %if specs >= 0 %start
    put word(0)
    put word(0) %if value&3 # 0
  %finish
  value = (value+3)&(\3)
%end
!
%routine PUTACT(%integer act,x,y)
  dict(np)_act = act;  dict(np)_x = x;  dict(np)_y = y
  np = np+1
%end

%routine COMPILE END
%integer i,j,x,y,entry,lim
  %if c_reg_line # line %and control&(diagbit!linebit!tracebit) # 0 %c
  %and level > outerlevel %and c_access # 0 %start
    pendcond = -1
    flush
  %finish
  !Pop event block
  %if c_eventsp # 0 %start
    plant(move,temp(c_mode,c_eventsp),gb+indir)
    forget cc
  %finish
!Put pre-amble
  codeflag = '^';  x = pc;  !preserve
  putact(end,0,0)
  compile(np0)
  fill code(1) %if cad&1 # 0
  check reach((pc-c_localpc)<<1)
  entry = cad
  y = x
  %while y < pc %cycle
    %if pflag(y) = indglobal %then set code word(dict(prog(y))_val-cad) %c
    %else set code word(prog(y))
    y = y+1
  %repeat
  codeflag = ' ';  pc = x;  !restore
!Generate final sequence
  %if c_access # 0 %start
    %if level > outerlevel %and c_status&globbed # 0 %start
      %if level > 1 %start;  !display in store
        plant(move,tempd(gb,level<<2),a7);     !MOVE ?(GB),SP
        plant(move,posta7,tempd(gb,level<<2)); !MOVE (SP)+,?(GB)
        forget cc
      %else
        plant(unlk,0,f1)
      %finish
    %finish %else %if c_sp < 0 %start;  !some stack extension
      addimm(-c_sp,a7)
    %finish
    %if level > outerlevel %start
      c_dpid_flags = c_dpid_flags!okflag %if c_type > 0 %c
          %and c_status&wrongcc!c_reg_ccx!c_reg_ccy = 0
      plant(rts,0,0)
    %else
      plant(move,0,d0);  srcall(signal);  !%stop
    %finish
  %else;  !no return from procedure
    c_dpid_flags = c_dpid_flags!noret
  %finish
!Set start address
  x = c_dpid_val
  define entry(-x,entry,c_pid) %if x < 0;  !forward refs in FINAL
  c_dpid_val = entry
!
  lim = cad+(pc-c_localpc-c_shorts+zeroshorts)<<1
  x = c_localpc;  c_shorts = zeroshorts;  !reset
  %while x < pc %cycle
    y = prog(x);  j = pflag(x)
    %if j # 0 %start
      %if j < zeroshorts %start
        %if j <= longjump %start;  !shortjump/jump/longjump
          jumps = jumps+1
          y = (y-pflag(y)-x+c_shorts)<<1
          %if j = shortjump %start
            cad = cad-2
            y = prog(x-1)+y&255
            c_shorts = c_shorts+1
          %finish
        %finish %else %if j = indglobal %start;  !procedure
          i = dict(y)_val
          %if i <= 0 %start;  !not yet encountered
            dict(y)_val = -(cad>>1);  y = -i
          %else
            i = i-cad
            report(reacherr,y,0) %unless is short(i)=TRUE
            y = i
          %finish
        %else {global,negglobal,bigglobal}
          %if j # global+1 %start
            y = y&16_FFFF
            y = y+65536 %if j # global;  !bigglobal
          %finish
          y = y-cad
          %unless is short(y)=TRUE %start
            %if prog(x-1)&16_F1FF # 16_41FA %start;  !LEA (PC),Ax
              report(creacherr,0,cad)
            %else
              i = cad;  cad = lim
              set code word(prog(x-1)!!(16_41FA!!16_207C)); !MOVEI #,Ax
              set code longword(y-2)
              set code word(prog(x-1)!!(16_41FA!!16_D1D7)); !ADD (SP),Ax
              set code word(16_4E75);                       !RTS
              lim = cad;  cad = i-2
              set code word(16_6100);  !BSR
              y = lim-10-cad
              steps = steps+5
            %finish
          %finish
        %finish
      %finish
    %finish
!$IF VAX
{    final(cad) <- y>>8;  final(cad+1) <- y
!$IF APM
    shortinteger(final0+cad) <- y
!$FINISH
    cad = cad+2
    x = x+1
  %repeat
  cad = lim
  forget all
%end;  !compile end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!  end of Code Generation  !!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!<<IMP
%routine TOPRED
  item = litref(value) %if item = 0
  putact(compare,item,0)
  condop = bne!!polarity
  item = np-1
%end
!<<BOTH
!
%routine RESET CONTEXT(%integer pid,free)
  starts = 0;  cycles = 0
  c = 0
  forget all
  c_localdpos = dlim;  c_parlim = dlim;  c_localtext = charlim
  c_localpc = pc;  c_localswpc = swpc;  c_lab1 = curlab
  c_shorts = zeroshorts;  c_free = free
  c_mode = framemode+level;  c_vintage = vintage
  c_pid = pid;  c_dpid == dict(c_pid)
%end

%routine OPEN BLOCK(%integer pid)
  forget regs;  !a bit extreme, but don't want to let LIT/EXP
                 ! get out of hand so RESET CONTEXT forgets triples
  croak("Too many levels") %if level = maxlevel
  c_oldcontrol = control
  hold(level) = c;  level = level+1;  vintage = vintage+1
  reset context(pid,c_free)
  c_access = 1;  c_localad = cad-accounted
%end;  !OPEN BLOCK

%integerfn PARMATCH(%integer apos,bpos)
%record(identinfo)%name ap,bp,atp,btp
  %cycle
    ap == dict(apos);  bp == dict(bpos)
    %result = FALSE %if ap_flags!!bp_flags < 0
    {%result = FALSE %if ap_mode # bp_mode}
    %if ap_type # bp_type %start
      ![for now -- nominal]
      atp == typecell(ap_type);  btp == typecell(bp_type)
      %result = FALSE %unless atp_flags&cat = arry = btp_flags&cat
    %finish
    apos = ap_link;  bpos = bp_link
    %if apos = 0 %start
      %result = FALSE %if bpos # 0
      %result = TRUE
    %finish %else %if bpos = 0 %start
      %result = FALSE
    %finish
  %repeat
%end

%integer%fn CRUNCHED(%integer p)
%record(identinfo)%name dq,dp
%owninteger q=0,l=0
  dp==dict(p)
  dp_text = 0;  q = 0
  l = dp_link
  %if l # 0 %start
    l = crunched(l) %if dp_type < p
    %result = p %if p <= l
    dp_link = l
    q = l-1
  %finish
  dq == dict(q)
  %while q < p %cycle
    %if dq_type = dp_type %c
    %and dq_link = l %and dq_reg = dp_reg %and dq_val = dp_val %start
      dlim = p
      %result = q
    %finish
    q = q+1;  dq == dict(q)
  %repeat
  %result = p
%end

%routine POP CONTEXT
  pc = c_localpc;  swpc = c_localswpc;  curlab = c_lab1
  dlim = c_parlim
!  %for i = 0,1,255 %cycle
!    hashindex(i) = dict(hashindex(i))_hlink %while hashindex(i) >= c_localdpos
!  %repeat
  %if level > outerlevel %start
    charlim = c_localtext
    ranges = dict(ranges)_hlink %while ranges >= c_parlim
    c_dpid_type = crunched(c_dpid_type)
    level = level-1;  c = hold(level)
    control = control&editbit ! c_oldcontrol&(\editbit)
  %finish
  dictshown = dlim %if dictshown > dlim
  starts = 0;  cycles = 0
%end

%routine FIXUP SWITCH VECTOR(%integer pos,%record(identinfo)%name dp)
%integer x,y,j,default,temp,lo,hi
%record(identinfo)%name tp
  tp==typecell(dp_type)
  x = dp_val
  default = dp_link;  default = pc %if default = 0
  get bounds(tp_xtype,lo,hi)
  %if dp_flags&arrflag = 0 %then j = pflag(x-1)+lo %c
  %else j = pflag(x-7);  !allow for dope info
  j = x-j;  !base position
  %while lo <= hi %cycle;  !For each element
    y = prog(x)
    %if y <= 0 %start;  !not set
      %if dp_link = 0 %start;  !no default
        report(slabmissing+warn,pos,lo)
        c_access = 1
      %finish
      %if y < 0 %start;  !explicit jump(s) to this one
        y = -y
        %cycle;  !define jumps to default
          temp = y;  y = prog(temp);  prog(temp) = default
        %repeat %until y = 0
      %finish
      y = default
    %finish
    prog(x) = (y-pflag(y)-j)<<1
    x = x+1;  lo = lo+1
  %repeat
%end

%routine CLOSE BLOCK
%integer miss,under,pos,base
%record(identinfo)%name dp
 ! WRONGCC is clear if all %result statements leave correct CC
  %if c_type > 0 %and c_status&wrongcc = 0 %start
   ! set special values and see if they survive exit sequence
    c_reg_ccx = 0;  c_reg_ccy = 0
  %finish
  %if c_return # 0 %start
    %if c_return = -(pc-1) %and c_access = 0 %start
      c_return = -prog(pc-1);  pc = pc-2 
    %finish
    define jumps(c_return);  !must precede switch fixup
    c_access = -1
  %finish
  pflag(pc) = c_shorts;      !in case of terminal switch labels
  %if c_status&hadswitch # 0 %start
    pos = c_localdpos
    %while pos < dlim %cycle
      dp == dict(pos)
      fixup switch vector(pos,dp) %if dp_mode = labmode %and dp_type # 0
      pos = pos+1
    %repeat
  %finish
  compile end
  c_totstack = c_totstack-c_extra
  c_totstack = -c_totstack %if c_status&unknown = 0;  !positive if firm
  typecell(c_dpid_type)_val = c_totstack
{?}  %if control&maplist # 0 %start
{?}    put ident(c_pid,0)
{?}    mark at(20)
{?}    put string(" code:")
{?}    put num(cad-c_localad-accounted)
{?}    put string("  entry:")
{?}    put num(c_dpid_val-c_localad-accounted)
{?}    put string("  stack:");  put num(-c_stack)
{?}    putsym('/');  put num(imod(c_totstack))
{?}    put sym('+') %if c_totstack < 0
{?}    accounted = cad-c_localad
{?}    print line
{?}  %finish
  !Check identifier usage
  miss = 0;  under = 0
  base = c_localdpos;  base = 0 %if level = outerlevel
  pos = dlim;  dp == dict(pos)
  %while pos > base %cycle
    pos = pos-1;  dp == dict(pos)
    %if dp_flags&ext = 0 %start
!<<IMP
!<<BOTH
      %if dp_text > 0 %start;               !user id
        set hashhead(string(dp_text+char0))
        %if head = pos %start;              !still active
          head = dp_hlink;                  !remove from hash list
check:    %if dp_flags&spec # 0 %start
            dp_hlink = miss;  miss = pos
          %finish %else %if ((dp_flags&(readable+rflag) = readable %and dp_mode # litmode) %c
            %or (dp_flags&(writable+okflag+wflag+spec) = writable)) %c
            %and pos >= c_localdpos %and dp_mode # 0 %and dp_flags&typeid = 0 %c
            %and control&(list!maplist) # 0 %start
            dp_hlink = under;  under = pos
          %finish
        %finish
      %finish
    %finish %else %if level = outerlevel %start;  !external, external spec
      %if dp_flags&spec = 0 %start;  !external object
        dp_link = externs;  externs = pos
      %finish %else %if dp_flags&(rflag+wflag) # 0 %start
       !external spec (used)
        dp_link = extspecs;  extspecs = pos
      %finish
    %finish
  %repeat
  report(idmissing,miss,0) %if miss # 0
  %if under # 0 %and c_faults = 0 %start
    put ident(under,1)
    put string(" underused")
    print line
  %finish
  pop context
  set first entry %if firstpos >= dlim
%end;  !CLOSE BLOCK

%routine ERROR(%integer case)
  faultp = atomp
  report(case,0,0)
  %signal fail
%end

%constinteger DUD=63
%routine SYNTAX ERROR
  %if atom = dud %then error(atomerr+point) %else error(formerr+point)
%end

%routine EXPFAULT(%integer case)
  %if faultnum = 0 %or expp < faultp %start
    faultnum = case!point;  faultp = expp
  %finish
%end

%routine NONSTANDARD(%integer case)
%integer b
%owninteger hadit=0
  b = 1<<case
  %if b&hadit = 0 %and control&nonsbit = 0 %and faultnum = 0 %start
    hadit = hadit+b;  faultp = atomp
    %if control&strictbit # 0 %then report(nonstand+point,0,case) %c
    %else report(nonstand+point+warn,0,case)
  %finish
%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.
  %if item >= 0 %start;  !first time
    fault(namerr+point+now)
    %if charmin-newlen-80 >= charlim %start
      dmin = dmin-1;  dmin0 = dmin
      charmin = charmin-newlen-1
      string(charmin) = string(charlim)
      dict(dmin)_text = charmin-char0
      head == dict(head)_hlink %while head > 0;  !find last link
      dict(dmin)_hlink = head;  head = -dmin
    %finish
  %finish %else others = others+1
  %signal fail
%end

%routine FIND OP(%integer mnemonic,%integername op,types)
%integer i
  i = 0
  %cycle
    i = i+2
    error(namerr) %if i > defmax+defmax
  %repeat %until def(i) = mnemonic 
  types = def(i-1);  op = i>>1
%end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!  Source input  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%routine READ LINE(%integer flag)
! Read (or otherwise make available) the next source line
!     Output any pending error report;                 *NB*
!     Skip remnant of previous line if SYM # NL        *NB*
!     Set LINESTART to point to start of new line
!     Print new line on list output stream if listing requested
!       (Direct output routines CF diagnostics)
  report(faultnum,0,0) %if faultnum # 0
  %while sym > nl %cycle;               !Skip remnant
    sym = byteintegeR(fp);  fp = fp+1
  %repeat
  line = line+1
  %while fp = curlim %cycle
    %if curlim # cur_lim2 %start;  !in part1 of file
      fp = cur_start2
    %finish %else %if curfile = main %start;      !on main
      %signal done
    %else
      cur_flag = -1
!!      disconnect edfile(cur)
      curfile = curfile-1
      cur == file(curfile)
      fp = cur_fp;  line = cur_line
      control = fcontrol(curfile)
      inclim = dlim %if level = outerlevel %and c_status < hadon
    %finish
    curstart = cur_start2;  curlim = cur_lim2
    %if fp < curstart %or fp > curlim %start
      curstart = cur_start1;  curlim = cur_lim1
    %finish
  %repeat
  linestart = fp
  %if flag = 0 %start
    flag = ' ';  flag = '&' %if curfile # main
  %finish
  listflag = flag
  %if control&list # 0 %start
    time1 = time1-cputime
    print line %if rep # ""
    show dict(dictshown) %if control&dictlist # 0
    dictshown = dlim
    write(line,4);  print symbol(listflag)
    print symbol(' ')
    %cycle
      sym = byteintegeR(fp);  fp = fp+1
      print symbol(sym)
    %repeat %until sym <= nl
    fp = linestart
    time1 = time1+cputime
  %finish
  sym = 0
%end;  !READ LINE

!<<IMP

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!  Lexical processing  !!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%constinteger CASEBIT=32
%owninteger PERCENT=0, SUBATOM=0
!
!~!!!!!!!  Keyword codes -- used by KEYGEN to produce tables  !!
%constinteger %c
  KEYEND=1 {end},
  KEYREPEAT=2   {repeat},
  KEYFINISH=3   {finish},
  KEYELSE=4     {else},
  KEYBEGIN=5    {begin},
  EXIT=6        {exit_1,continue_0}
%constinteger %c
  KEYRETURN=7   {return},
  TF=8          {true_1,false_0},
  KEYRESULT=9   {result},
  KEYSTOP=10    {stop},
  KEYGOTO=11    {goto},
  KEYSIGNAL=12  {signal}
%constinteger %c
  KEYMONITOR=13 {monitor},
  KEYON=14      {on},
  IU=15         {if_0,unless_1},
  KEYWHILE=16   {while},
  KEYUNTIL=17   {until_1},
  KEYFOR=18     {for},
  KEYTHEN=19    {then}
%constinteger %c
  KEYSTART=20   {start},
  KEYCYCLE=21   {cycle},
  KEYLABEL=22   {label},
  KEYCONST=23   {const,constant},
  KEYOWN=24     {own},
  KEYEXT=25     {external_6,system_5,dynamic_7}
%constinteger %c
  KATTRIB=26    {readonly_0,writeonly_1,volatile_2},
  KTYPE=27      {short_3,half_6,byte_9,mite_12,boolean_15,char_18,text_25},
  KEYINTEGER=28 {integer},
  KEYLONG=29    {long},
  KEYREAL=30    {real},
  KEYSTRING=31  {string_0,cstring_1}
%constinteger %c
  KEYRECORD=32  {record},
  KEYNAME=33    {name},
  KEYFORMAT=34  {format},
  FNMAP=35      {fn_0,function_0,map_1},
  RPRED=36      {routine_0,predicate_1},
  KEYSPEC=37    {spec}
%constinteger %c
  KEYARRAY=38   {array},
  KEYSWITCH=39  {switch},
  KEYOF=40      {of},
  KEYFILE=41    {file},
  KEYPROGRAM=42 {program},
  KEYLIST=43    {list}
%constinteger %c
  KEYCONTROL=44 {control},
  KEYCOMMENT=45 {comment},
  KEYEVENT=46   {event},
  KEYINCLUDE=47 {include},
  KEYOPTION=48  {option},
  KEYALIAS=49   {alias}
%constinteger %c
  KEYNOT=50     {not},
  KEYAND=72     {and},
  KEYOR=73      {or}
!!  end of keyword codes
!
!Symbol lexical codes other than operators:
%constinteger TERMINATOR=51, CONST=52, IDENT=53, MODSIGN=54,
              COLON=59, COMMA=60, RIGHT=61, RIGHTB=62
{DUD=63}
%constinteger LEFT=55, LEFTB=56, ATSIGN=57, UNDERLINE=58

%constinteger ARROW=74, EQEQ=75, NOTEQEQ=76,
              EQUALS=77, NOTEQ=78, LESSEQ=79,
              LESS=80, GREATEQ=81, GREATER=82
%constinteger PLUS=83, MINUS=84, EXCLAM=85, EXCLAM2=86, DOT=87
%constinteger STAR=88, SLASH2=89, SLASH=90, AMPERSAND=91
%constinteger STAR2=92, BACKSLASH=93, UPARROW=94,
              BACKSLASH2=95, UPARROW2=96,
              TILDE=97,
              LSHIFT=98, RSHIFT=99
%constinteger ATOMMAX=99
%constinteger ALEFT=left, ARIGHT=right, RECSUB=underline,
              OVER=slash2, SCONC=dot

%constinteger SIMPLE=atommax+1, VSIMPLE=simple+1,
              MAJOR=plus, SCOND=arrow, COND=keyand, CONDQ=71
!
%integer%fn NEXT ATOM
!Encode next atom from source file
![Time-critical]
%switch s(0:255)
%constinteger TAB=9,
              MAX10=maxint//10, MAXDIG=maxint-max10*10
%integer i,j,p,radix,hash
%real rval
%constbytearray 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

!~!!!!!!!!!!!!!!!  Ex KEYGEN  !!!!!!!!!!!!!!!!!!!!
%CONSTSHORTINTEGERARRAY SYMINIT(97:122) =  %C
2,15,31,72,79,102,133,137,141,1,1,156,169,183,190,205,
1,220,257,297,309,319,327,1,1,1

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

%CONSTBYTEINTEGERARRAY ALTDISP(1:340) =  %C
0,5,0,0,0,0,5,0,0,0,0,0,0,0,5,0,
0,0,0,4,0,0,9,0,0,0,0,0,0,15,8,23,
28,34,0,0,0,0,5,0,0,0,0,4,0,0,18,0,
0,0,0,0,0,1,0,0,0,0,0,0,0,0,4,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,7,3,0,
0,4,0,0,0,4,8,0,1,0,0,0,0,0,0,0,
0,0,0,0,6,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,6,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,12,0,0,1,4,0,0,0,0,0,0,2,0,3,
0,0,2,0,6,0,0,0,0,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,7,11,0,0,0,0,0,0,0,0,0,0,0,0,
4,30,0,0,6,0,0,0,0,0,6,0,0,0,0,5,
5,0,0,0,3,4,0,0,0,0,0,0,0,0,0,4,
0,0,0,0,0,0,0,0,4,0,0,1,4,0,0,0,
0,0,0,25,0,5,0,0,0,1,0,0,0,1,0,0,
0,0,0,0,0,2,5,0,0,0,0,0,0,0,0,0,
0,0,0,1


!! end of generated tables

%routine GET SYM
  %cycle
    sym = byteintegeR(fp);  fp = fp+1
  %repeat %until sym # ' '
  i = sym-'0'
  %if i >= 10 %start
    i = sym!casebit-'a';  i = i+10 %if i >= 0
  %finish
%end

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

s('{'):
  comments = comments+1
  %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) = '>'
        -> continuation %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) = '\'
        fp = fp+1 %and %result = noteq %if byteinteger(fp) = '='
        %result = backslash
s('^'): fp = fp+1 %and %result = uparrow2 %if byteintegeR(fp) = '^'
        %result = uparrow
s('~'): %result = tilde
s('!'): fp = fp+1 %and %result = exclam2 %if byteintegeR(fp) = '!'
        %result = exclam
s('&'): %result = ampersand
s('.'): rval = 0 %and -> fraction %if '0' <= byteinteger(fp) <= '9'
        %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 = leftb
s(')'): %result = right
s(']'): %result = rightb
s('|'): %result = modsign
s('@'): %result = atsign

s('M'): s('m'):
  fp = fp+1 %and -> charconst %if byteintegeR(fp) = ''''
s('A'):s('B'):s('C'):s('D'):s('E'):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('c'):s('d'):s('e'):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
  newlen = charlim+1;  hash = sym!casebit;  !lower-case (if letter)
  byteinteger(newlen) = hash
  %cycle
    sym = byteintegeR(fp);  fp = fp+1
  %repeat %until sym # ' '
  %if sym = '''' %start;  !damned IBM-style literals
    radix = 16 %and ->ibm %if hash = 'x'
    radix = 8 %and ->ibm %if hash = 'k'
    radix = 2 %and ->ibm %if hash = 'b'
  %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
  %if subbed # 0 %then head == dformat_link %c
  %else head == hashindex(hash&255)
  item = head
  %if item # 0 %start
    %cycle
      ditem == dict(imod(item))
      %exit %if string(ditem_text+char0) = string(charlim) %c
            %and (item > a7 %or item < 0 %or control&lowbit # 0)
      item = ditem_hlink
    %repeat %until item = 0
  %finish
  identatoms = identatoms+1
  %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) > 127
    atom = altdisp(p)
    %if atom = 0 %start
      %result = dud %unless sym!casebit = 'c' %and byteintegeR(fp) = nl
      ->continuation
    %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

ibm:
  nonstandard(20)
  item = -1;  value = 0
  -> ibm1
s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'):
  item = 0;  type = inttype
  radix = 10;  value = 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
        fault(rangerr+point+warn) %if value > max10 %or (value=max10 %and i > maxdig)
        value = (value<<2+value)<<1+i
      %else
        i = sym!casebit-'a'+10 %if i >= 10
        %exit %if i < 0 %or i >= radix
        j = radix
        %cycle
          i = i+value %if j&1 # 0
          value = value<<1;  j = j>>1
        %repeat %until j = 0
        value = i
      %finish
    %repeat
    %exit %unless sym = '_'
    radix = value
    %result = dud %if radix = 0
    value = 0
  %repeat
  %if item < 0 %start;  !IBM-style
    %result = dud %if sym # ''''
    item = 0
  %else
    j = 0
    %if sym = '.' %start
      rval = value %if type = inttype
fraction:
      j = 0
      type = realtype
      %cycle
        get sym
        %exit %unless 0 <= i < radix
        rval = rval*radix+i;  j = j-1
      %repeat
      %result = dud %if j = 0
    %finish
    %if sym = '@' %start
      type = realtype %and rval = value %if type = inttype
      get sym
      value = 0
      %if sym = '+' %then get sym %c
      %else %if sym = '-' %then value = 1 %and get sym
      %result = dud %unless 0 <= i < radix
      p = 0
      %cycle
        p = p*radix+i
        get sym
      %repeat %until %not 0 <= i < radix
      p = -p %if value # 0
      j = j+p
    %finish
    %if type = realtype %start
      rval = rval*radix****j %if j # 0
      value = integer(addr(rval)) %if type = realtype
    %finish
    fp = fp-1;  sym = 0
  %finish
  litatoms = litatoms+1
  %result = const

s(''''):
charconst:
  item = 0;  type = inttype
  value = 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
    value = value<<8+sym
  %repeat
  %result = const %if value # 0
  %result = dud

s('"'):
  item = 0
  value = cad;  type = stringtype
  i = line;  j = linestart;  p = 0
  %cycle
    sym = byteintegeR(fp);  fp = fp+1
    %if sym = '"' %start
      %exit %if byteintegeR(fp) # '"'
      fp = fp+1
    %finish
    p = p+1
    %if p > 255 %start
      sym = 0
      fp = atomp;  linestart = j
      %result = dud
    %finish
    final(value+p) = sym
    read line('"') %if sym = nl
  %repeat
  %if p # 0 %start;  !not empty string
    final(value) = p
    cad = cad+(p+1)
  %finish %else value = 0
  litatoms = litatoms+1
  %result = const

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

!<<BOTH

%integerfn A (%integer k)
!Basic atom-testing predicate
  atom = next atom %if matched # 0
  %result = FALSE %if k # atom
  matched = 1
  %result = 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,0)
!  %signal fail
%end

!<<IMP

%routine ALLOW(%integer k)
  %if a(k)=TRUE %start
  %finish
%end

%routine GET LITSTRING
%integer holditem
!Must be quoted string (for %alias and %include)
  holditem = item;  !preserve
  get(const)
  error(typerr+point) %unless type = stringtype
  cad = value;  !reset
  item = holditem;  !restore
%end

!<<BOTH

%integer%fn IDTEXT(%integer f)
%integer k
  %result = ditem_text %if item > 0 %and f&ext = 0;  !already exists
  charlim = charlim+newlen+1
  croak("Identifier space exhausted") %if charlim+80 >= charmin
  k = charlim-newlen-1-char0
  %if f&ext # 0 %and a(keyalias)=TRUE %start
    get LITSTRING
    string(charlim) = string(final0+value)
    byteinteger(charlim) = byteinteger(charlim)+128
    charlim = charlim+byteinteger(charlim)-127
  %finish
  %result = k
%end

%record(objinfo)%map DETAILS(%integer f,t,m,v)
%ownrecord(objinfo) D=0
  d_flags = f;  d_type = t
  d_mode = m;  d_val = v
  %result == d
%end

%routine DECLARE(%record(objinfo)%name d)
%integer i
%record(identinfo)%name dp
  dp == dict(dlim)
  %if speccing = 0 %start;  !not within spec params
    %if item >= c_localdpos %start;  !there already
      %if d_flags&spec = 0 %and ditem_flags&spec # 0 %start
        !body after spec (proc,label,typeid)
        %if d_flags&(ext+proc+typeid) = ditem_flags&(ext+proc+typeid) %start
          i = item
          %if d_flags&ext # 0 %start
            ![can't allow %ext%spec, then use, then %ext object]
            ->ok %if ditem_flags&rflag # 0;  ![so create new entry]
            ditem_mode = d_mode;  ditem_val = d_val
            %if a(keyalias)=TRUE %start
              get LITSTRING;  !ignore [should be identical]
              item = i
            %finish
          %finish
          %if d_flags&proc = 0 %start
            ditem_flags = ditem_flags&(\(spec+indirect))
          %finish
          %return
        %finish
        %if ditem_flags&(ext+proc) = proc1 %and d_flags&ext # 0 %c
            %and d_flags&proc # 0 %start;  !(internal) %spec then %ext
          ditem_flags = ditem_flags-proc1+(d_flags&(ext+proc))
          ditem_text = idtext(ext);  !in case alias
          %return
        %finish
      %finish
!<<IMP
      %if item < inclim %and ditem_flags&(rflag+wflag) = 0 %c
      %then fault(duperr+warn+point) %else fault(duperr+point)
!<<BOTH
    %finish
ok: dp_hlink = head;  head = dlim;  !insert in list
    dp_text = idtext(d_flags)
  %finish %else dp_hlink = 0 %and dp_text = 0
  item = dlim;  ditem == dp
  ditem_details = d
  dlim = dlim+1
  %if dlim >= dmin %start
{?}    show dict(0) %if control&logbit # 0
    croak("Too many identifiers")
  %finish
%end;  !DECLARE

%routine DECLARE ANON(%record(objinfo)%name d)
  speccing = speccing+1
  item = 0
  declare(d)
  speccing = speccing-1
%end
!
%routine DECLARE TEMP(%integer t)
  c_val = c_val+4;  c_temps = c_temps+4
  declare anon(details(okflag+writable+readable,t,c_mode,c_sp-c_val))
%end
!
%routine DECLARE RANGE(%integer type,lower,upper)
!Type ident just declared
%integer s
%integerfn OK(%integer l,u)
  %result = TRUE %if (l <= lower %and upper <= u) {signed} %c
        %or (0 <= lower %and upper <= u-l) {unsigned}
  %result = FALSE
%end
  s = 4
  %if ok(-32768,32767)=TRUE %start
    s = 2;  s = 1 %if ok(-128,127)=TRUE
  %finish
  ditem_details = details(typeid,type,absmode,sign)
  ditem_size = s
  declare anon(details(okflag,type,litmode,lower))
  declare anon(details(okflag,type,litmode,upper))
  ditem_hlink = ranges;  ranges = item
  item = item-2
%end

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

%owninteger LITERAL=0, JAMMY=0

%routine%spec GET EXPRESSION(%integer rank,etype)
!
%integerfn VALOK(%integer wanted,t)
%integer lo,hi,l,h,wc,tc
%record(identinfo)%name wp,tp
  %result = TRUE %if wanted = t # recstar
  wp == typecell(wanted);  tp == typecell(t)
  wc = wp_flags&(packed+cat);  tc = tp_flags&(packed+cat)
  %if wc = tc %start;  !same class
    %if wc&nonord = 0 %start;  !ordinal wanted
      %if wp_type = tp_type %start;  !same base-type
        %result = TRUE %if wp_type = wanted;  !base-type (rather than subrange)
        %if dict(wanted+1)_mode # litmode %then get bounds(dict(wanted+1)_type,lo,hi) %c
        %else lo = dict(wanted+1)_val
        %if dict(wanted+2)_mode # litmode %then get bounds(dict(wanted+2)_type,hi,hi) %c
        %else hi = dict(wanted+2)_val
        %if item = 0 %start;  !literal
          %result = TRUE %if lo <= value <= hi
          jammy = jammy!!1
        %else
          jammy = jammy!!1 %and %result = TRUE %if tp_type = t
          %if dict(t+1)_mode # litmode %then get bounds(dict(t+1)_type,l,h) %c
          %else l = dict(t+1)_val
          %if dict(t+2)_mode # litmode %then get bounds(dict(t+2)_type,h,h) %c
          %else h = dict(t+2)_val
          %if l >= lo %start
            %result = TRUE %if h <= hi
            jammy = jammy!!1
            %result = TRUE %if l <= hi
          %else
            jammy = jammy!!1
            %result = TRUE %if h >= lo
          %finish
        %finish
        expfault(rangerr) %if jammy # 0
        %result = TRUE
      %finish
    %finish %else %if wc = realy %start
      %result = TRUE
    %finish %else %if wc = stringy %start;  !string wanted
      %result = TRUE %if wanted = stringstar
      %if item = 0 %start
        %result = TRUE %if value = 0;  !empty string
        l = final(value)+1
      %else
        l = imod(tp_size)
        l = 256 %if l = 0
      %finish
      %if l > imod(wp_size) # 0 %start
        jammy = jammy!!1
        expfault(rangerr) %if item = 0 %and jammy # 0
      %finish
      %result = TRUE
!<<IMP
    %finish %else %if wc&cat = arry %start
      %result = TRUE %if wp_type = tp_type %and valok(wp_xtype,tp_xtype)=TRUE
!<<BOTH
    %else;                          !record etc
      %if wanted = recstar %start
        %result = TRUE %if t # recstar
      %else
        %result = TRUE %if t = recstar %or item!value = 0
      %finish
    %finish
  %else;                            !category difference
    %if tc = inty %start
      %result = TRUE %if wc = recy %and item!value = 0;  !RECORD = 0
      toreal %and %result = TRUE %if wc = realy;         !REAL   = INT
    %finish %else %if wc = stringy %and t = chartype %start;   !STRING = CHAR
      %if item = 0 %start;           !null string
        final(cad) = 1;  final(cad+1) = value
        value = cad;  cad = cad+2
        type = stringtype
      %finish %else putexp(dtostring,normitem,0,string1)
      %result = TRUE
!<<IMP
! sets again
!<<BOTH
    %finish
  %finish
  %result = FALSE
%end
!
%routine GET VALUE(%integer valtype)
  get EXPRESSION(major,valtype)
%end;  !GET VALUE
!
%routine GET LITERAL(%integer t)
  literal = literal+1
  get EXPRESSION(major,t)
  literal = literal-1
%end
!
!!!!!!!!!!!!!!!!!!!!!!  Machine-code  !!!!!!!!!!!!!!!!!!!!!!!!!!
!
%routine GET MIDENT(%integer min,max)
  get(ident)
  %if item <= 0 %start
    name error %if string(charlim) # "sp"
    item = a7
    ditem == dict(item)
  %finish
  %if ditem_mode = litmode %start
    value = ditem_val;  item = 0
  %finish
  syntax error %unless min <= item <= max
%end

%routine GET REGSET
%integer hold,set
  set=0
  %cycle
    get mident(d0,a7)
    hold = item
    get mident(hold,a7) %if a(minus)=TRUE
    %cycle
      set = set!1<<(hold-d0)
      hold = hold+1
    %repeat %until hold > item
  %repeat %until %not a(slash)=TRUE
  item = 0;  value = set
%end

%routine get MCODE
%integer op,x,y,types

%integer%fn OPSIZE(%integer okbyte)
  %result = 0 %unless a(dot)=TRUE
  sym = byteinteger(fp)&(\casebit);  fp = fp+1
  %result = 4 %if sym = 'L'
  %result = 2 %if sym = 'W'
  %result = 1 %if sym = okbyte
  syntax error
%end

%routine get MOP(%integer t,dummy,%record(identinfo)%name dp)
!Get Mcode operand
%constinteger HASHSIGN=noteq
%integer sign,hold,holdval,m
  %if a(hashsign)=TRUE %start
    get LITERAL(inttype)
    %return
  %finish
  sign = 0;  hold = -1;  holdval = 0
  sign = 1 %if a(minus)=TRUE
  %if a(ident)=TRUE %start
    matched = 0
    get mident(0,dlim)
    hold = item
    %if hold # 0 %start
      syntax error %if sign # 0
      %if item > a7 %start
        dp_flags = ditem_flags
        dp_mode = ditem_mode;  dp_val = ditem_val
        %while a(recsub)=TRUE %cycle
          dformat == typecell(ditem_type)
          syntax error %unless dformat_flags&cat = recy %c
                       %and ditem_flags&(name+indirect) = 0
          subbed = 1;  get(ident);  subbed = 0
          error(namerr+point) %if item <= 0
          dp_flags = ditem_flags;  dp_type = ditem_type
          dp_val = dp_val+ditem_val
          item = dummy;  ditem == dp
        %repeat
        %return
      %finish
      %if op&255 = movem %and item > 0 %start
        matched = 0
        get regset
      %finish
      %return
    %finish
    holdval = value
  %finish %else %if a(const)=TRUE %start
    hold = 0;  holdval = value
  %finish
  holdval = -holdval %if sign # 0
  %if a(left)=TRUE %start
    get mident(a0,a7)
    %if hold < 0 %start
      get(right)
      %if sign # 0 %then item = item+pre %c
      %else %unless a(plus)=TRUE %then item = item+indir %c
      %else item = item+post
      %return
    %finish
    m = item+(dispmode-a0)
    %if a(comma)=TRUE %start
      get mident(d0,a7)
      fault(rangerr) %unless is mite(holdval)=TRUE
      m = m+(indexmode-dispmode)
      holdval = (item-d0)<<12+holdval&255
      holdval = holdval+16_0800 %if opsize(0) # 2
    %finish
    get(right)
  %else
    syntax error %if hold < 0
    m = absmode
  %finish
  dp_mode = m;  dp_val = holdval
  item = dummy
%end

%constinteger temp=((('t'&31)<<5+('e'&31))<<5+('m'&31))<<5+('p'&31)
  update sp
!Pack mnemonic
  atomp = fp+1
  x = 0
  %cycle
    sym = byteinteger(fp);  fp = fp+1
    %exit %unless 'A' <= sym&(\casebit) <= 'Z'
    sym = sym&31
    x = x<<5+sym
  %repeat
  fp = fp-1;  sym = 0
  syntax error %if x = 0
  %if x = temp %start;       !*TEMP ...
    value = 0
    matched = 0 %and get regset %if a(ident)=TRUE
    c_free = value
    %return
  %finish
  x = x<<5 %until x&(31<<25) # 0
  x = x!16_C0000000
  find op(x,op,types)
  op = op+opsize('B')<<8 %if types&(sized!asized) # 0
  x = 0;  y = 0
  %if types>>6&63 # 0 %start
    get MOP(types>>6&63,lablim,dtemp)
    x = normitem
    get(comma) %if types&63 # 0
  %finish
  %if types&63 # 0 %start
    get MOP(types&63,lablim+1,dtemp2)
    y = normitem
  %finish
  plant(op,x,y)
  forget regs;  c_access = -1
%end;  !get MCODE

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

%integerfn REFOK(%integer wanted,t)
%record(identinfo)%name wp,tp
  %result = TRUE %if t = wanted %or wanted = 0 %or t = 0 %or item!value = 0
  wp == typecell(wanted);  tp == typecell(t)
  %if (wp_flags!!tp_flags)&(name+packed+cat) = 0 %start
    %if wp_flags&cat = arry %start
      !**check index compatible
      %result = TRUE %if refok(wp_type,tp_type)=TRUE
    %finish %else %if wp_flags&cat = stringy %start
      %result = TRUE %if tp_size = 0 %or wp_size = 0
!<<IMP
!<<BOTH
    %else
      %result = TRUE %if t = recstar %or wanted = recstar
    %finish
  %finish
  %result = FALSE
%end

%routine TOREF
  atomp=expp %and error(nonref+point) %if item <= 0 %or ditem_mode < dispmode
  %if item >= dictlim %start
!    %if ditem_act = prel %and (ditem_y < 0 %or ditem_type = bytetype) %start
!      value = ditem_y
!      value = litref(litval(value)*imod(size(ditem_type))) %if ditem_type # bytetype
!      putexp(add,ditem_x+ad,value,ditem_type)
!      %return
!    %finish
  %else
    %if ditem_mode = absmode %and ditem_flags >= 0 %start
      item = 0;  value = ditem_val
      %return
    %finish
  %finish
  item = item+ad
%end
!
%routine COPY DOWN(%integer np1)
  %while np > np1 %cycle
    np = np-1;  explo = explo-1
    dict(explo) = dict(np)
  %repeat
%end

%routine GET REFERENCE(%integer reftype)
  get EXPRESSION(simple,reftype!sign16)
%end
!
%routine GET PARLIST(%integer special)
%integer procnp,pact,hold,count,headitem,arg,p,q,restype
%record(identinfo)%name hp,tp
%record(identinfo)%name darg

%routine PUT ACTUAL
  item = litref(value) %if item = 0
  %if count&1 = 0 %then hold = item %c
  %else putact(pact,hold,item) %and pact = 0
  count = count+1
%end

%integerfn NO ALT
  %if hp_flags&alt = 0 %start;  !no alternative
    expfault(typerr)
    %result = TRUE
  %finish
  item = hp_hlink
  %cycle
    report(internerr,0,6) %and %signal fail %if item <= 0
    ditem == dict(item)
    %exit %if string(ditem_text+char0) = string(hp_text+char0)
    item = ditem_hlink
  %repeat
  headitem = item;  pact = headitem;  hp == ditem
  arg = hp_type;  darg == dict(arg);  restype = darg_type
  %result = FALSE
%end

%routine PUT BOUNDS(%integer ft,at)
! FT is TYPE of formal, AT of actual array
%integer maxarg
%record(identinfo)%name ftp,atp,fxp,axp
maxarg=arg
%cycle
  ftp == typecell(ft);  atp == typecell(at)
!  %if ftp_flags&indirect # 0 %start;           !complete dope vector
!    ![now only for %string(*)%array%name]
!    intern(11) %unless ftp_type = stringstar
!    item = at
!    put actual
!    maxarg = ft %if ft > maxarg
!    %exit
!  %finish
  %if ftp_flags&cat = stringy %start
    %exit %if ftp_size # 0
    %if atp_size # 0 %then item = litref(imod(atp_size)) %C
    %else item = at-1
    put actual
    maxarg = ft-1 %if ft-1 > maxarg
    %exit
  %finish
  %if ftp_xtype >= arg %start;    !index type
    fxp == typecell(ftp_xtype);  axp == typecell(atp_xtype)
    %if dict(ftp_xtype+1)_mode # litmode %start;  !non-literal lower
      item = atp_xtype+1
      item = 0 %and value = dict(atp_xtype+1)_val %if dict(atp_xtype+1)_mode = litmode
      put actual
      maxarg = ftp_xtype+1 %if ftp_xtype >= maxarg
    %finish
    %if dict(ftp_xtype+2)_mode # litmode %start;  !non-literal upper
      item = atp_xtype+2
      item = 0 %and value = dict(atp_xtype+2)_val %if dict(atp_xtype+2)_mode = litmode
      put actual
      maxarg = ftp_xtype+2 %if ftp_xtype+1 >= maxarg
    %finish
  %finish
  ft = ftp_type;  at = atp_type;        !element types
%repeat %until ft <= arg
arg = maxarg;  darg == dict(arg)
%end

  count = 0;  hold = 0
  procnp = np
  headitem = item;  pact = headitem;  hp == ditem
  arg = hp_type;  darg == dict(arg);  restype = darg_type
  %if a(left)=TRUE %start
    %cycle
      arg = darg_link
      %if arg = 0 %start
        error(toomany+point) %if special = 0
        get REFERENCE(0)
        value = item-ad;  !save extra item
        %cycle
          %if type = realtype %start
            %exit %if restype = realtype;  !no coercion
          %else
            %exit %if valok(type,restype)=TRUE
          %finish
        %repeat %until no alt=TRUE
        special = 0
      %else
        darg == dict(arg)
        %if darg_flags&proc # 0 %start
          get(ident)
          name error %if item <= 0
          fault(typerr+point) %if ditem_flags&proc = 0 %c
                              %or %not parmatch(darg_type,ditem_type)=TRUE
          fault(classerr+point) %if item > headitem %C
                                %and ditem_mode = procmode {OK if param?}
          item = item+ad
          put actual
        %finish %else %if darg_flags >= 0 %start
          jammy = 0
          get EXPRESSION(major,0)
          %cycle
            %exit %if valok(darg_type,type)=TRUE
          %repeat %until no alt=TRUE
          putexp(check,darg_type,item,darg_type) %if jammy # 0 %c
                                        %and control&capbit # 0 %c
                                        %and category(darg_type) < realy
          put actual
        %else;  !name
          get REFERENCE(0)
          %cycle
            %exit %if refok(darg_type,type)=TRUE
          %repeat %until no alt=TRUE
          put actual
          tp == typecell(darg_type)
          %if tp_flags&cat = arry %c
          %and dict(arg+1)_type # darg_type %c
          %and tp_mode >= framemode %start
            !array name (last in group) with non-literal dope vector
            put bounds(darg_type,type)
          %finish
        %finish
      %finish
    %repeat %until %not a(comma)=TRUE
    error(toofew+point) %if darg_link # 0 %or special # 0
    get(right)
  %else;                              !no LEFT
    error(toofew+point) %if darg_link # 0
  %finish
  put act(pact,hold,0) %if count&1 # 0 %or count = 0
  type = restype
  %if type # 0 %start;  !not routine
    %if hp_flags&volatile = 0 %start
      p = explo
      %while p < explim %cycle
        %if dict(p)_act = headitem %start;  ![enough?]
          item = p;  q = procnp
          %cycle
            %exit %if dict(p)_x # dict(q)_x %or dict(p)_y # dict(q)_y
            p = p+1;  q = q+1
            ->okf %if q >= np
          %repeat
        %finish
        p = p+1
      %repeat
    %finish
    copy down(procnp)
    item = explo
okf:ditem == dict(item)
    ditem_flags = hp_flags&heritable
    ditem_mode = 0
    %if hp_flags&writable # 0 %start;  !map
      ditem_mode = dispmode
    %finish
    ditem_type = type
    np = procnp
  %finish
%end;  !get PARLIST

!<<IMP

%routine get RESOLUTION(%integer t,item1)
%integer fore,ftype,s
!  type check needed
  s = size(t)
  s = -256 %if s = 0
  fore = 0
  %unless a(left)=TRUE %start
    get REFERENCE(stringstar)
    fore = item;  ftype = type
    get(dot);  get(left)
  %finish
  get VALUE(stringtype);  get(right)
  %if item = 0 %start
    item = litref(value);  s = s+final(value)
  %finish
  fault(rangerr+warn) %if fore # 0 %and s < size(ftype) # 0
  putact(resolves,item1+ad,item+ad)
  item = 0
  %if a(dot)=TRUE %start
    get REFERENCE(stringstar)
    fault(rangerr+warn) %if s < size(type) # 0
  %finish
  putact(0,fore,item)
  putact(0,0,0);       !preserve 'parity'
%end

%integer%fn ANON(%record(objinfo)%name d)
  dict(lablim+3)_details = d
  %result = lablim+3
%end

%integerfn A ASSOP(%integer t)
  %if t <= 0 %start
    %result = FALSE %unless a(eqeq)=TRUE
  %else
    atom = next atom %if matched # 0
    %if atom # equals %start
      %result = FALSE %unless atom = less %and byteintegeR(fp) = '-'
      jammy = 1;  fp = fp+1
    %finish %else jammy = 0
    matched = 1
  %finish
  %result = TRUE
%end

!<<BOTH

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%routine GET EXPRESSION(%integer rank,etype)
!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
%integer atomp0,item1,type1,cat1,val1,double,op
%record(identinfo)%name ditem1,tp
%constinteger nop=0;  !to distinguish from numeric zero in OPVAL

%routine GET RECORD
![literal only at this stage]
%integer fid,ad,arg,hold,count,max,s
%record(identinfo)%name darg,fidp
  literal = literal+1
  fill code(1) %if cad&1 # 0
  ad = cad
  fid = item;  fidp == ditem
  arg = fidp_link
  count = 0;  max = -1
  get(left)
  %cycle
    ![*beware premature lexical coding: may alter CAD*]
    %cycle
      error(toomany+point) %if arg <= 0
      darg == dict(arg)
      %exit %if ad+darg_val-cad >= 0
      arg = darg_hlink
    %repeat
    fill code(ad+darg_val-cad)
   ! [*now OK to code atom*]
    %if a(recsub)=TRUE %start
      subbed = 1;  dformat == fidp
      get(ident)
      subbed = 0
      name error %if item < arg
      fill code(ditem_val-darg_val)
      arg = item;  darg == ditem
      syntax error %unless a assop(darg_flags&name+darg_type)=TRUE
    %finish
    s = nsize(darg)
    %unless a(comma)=TRUE %start
      get VALUE(darg_flags&name+darg_type)
      %if s > 0 %start
        %if s = 4 %start
!$IF VAX
{          value = ieee(value) %if darg_type = realtype %and darg_flags >= 0
!$FINISH
          set code longword(value)
        %finish %else %if s = 2 %start
         set code word(value)
        %else
          final(cad) <- value;  cad = cad+1
        %finish
      %finish
      %exit %if a(right)=TRUE
      get(comma)
    %finish %else %if s > 0 %start
      fill code(s)
    %finish
    arg = darg_hlink
  %repeat
  fill code(ad+imod(fidp_val)-cad)
  item = 0;  value = ad
  literal = literal-1
%end

%routine SWOP
%integer temp
  temp = item1;  item1 = item;  item = temp
  temp = val1;  val1 = value;  value = temp
  temp = type1;  type1 = type;  type = temp
%end

%constinteger INTOK=1<<inty, CHAROK=1<<chary,
              BOOLOK=1<<booly, ENUMOK=1<<enumy,
              REALOK=1<<realy, STRINGOK=1<<stringy,
              ARROK=1<<arry, SETOK=1<<sety,
              RECOK=1<<recy, POINTOK=1<<pointy,
              NUMOK=intok!realok,
              ORDOK=intok!charok!boolok!enumok,
              RELOK=ordok!realok!stringok
%routine CHECK1(%integer ok)
  cat1 = category(type)
  %if ok>>(cat1&cat)&1 = 0 %start
    %if cat1 = inty %and ok&realok # 0 %start
      toreal;  cat1 = realy
    %finish %else %if ok&stringok # 0 %and valok(stringtype,type)=TRUE %start
      cat1 = stringy
    %else
      fault(typerr+point)
    %finish
  %finish
  type1 = type;  item1 = item;  val1 = value
%end

%integer%fn FROZEN LIT(%integer t,v)
! Used when the type of a literal will not be recoverable from context
%integer hold,res
  hold = item
  putexp(move,0,litref(v),t);  !NO-OP (distinctive Y)
  ditem_flags = okflag+wflag
  ditem_mode = constmode;  ditem_val = v
  res = item;  item = hold
  %result = res
%end

%routine COERCE(%integer c)
  %if c = inty %and cat1 = realy %start
    toreal
  %finish %else %if cat1 = inty %and c = realy %start
    ![rather sloppy]
    %if item1 # 0 %start
      val1 = item;  item = item1
      toreal
      item1 = item;  item = val1
    %finish %else real(addr(val1)) = val1
    type1 = realtype;  cat1 = realy
  %else
    expfault(typerr)
  %finish
%end

%routine GET ARITH(%integer rank)
  get EXPRESSION(rank,0)
  rank = category(type)
  coerce(rank) %if rank # cat1
%end

%integer%fn RCOND(%integer op)
%constinteger EQUAL=2_1001000010,
              LESS =2_1010000001,
            GREATER=2_0101000001
%integer which,c
!<<IMP
  check1(relok)
  get EXPRESSION(major,0)
  c = category(type)
  coerce(c) %if c # cat1
  %if equals <= atom <= greater %start;  ![ATOM always primed]
    syntax error %if double >= 0
    double = item
  %finish %else %if double < 0 %start
    double = -2
  %finish
!<<BOTH
  %if item1 = 0 %start
    %if item = 0 %start
      %if size(type1) > 0 %or item1!val1 = 0 %or item!value = 0 %start
        !non-structure (compile-time)
        ![integer tests ok for real?]
        %if val1 < value %then which = less %c
        %else %if val1 = value %then which = equal %c
        %else which = greater
        %result = which>>(op-bne)&1
      %finish
      item1 = frozen lit(type1,val1)
    %else
      swop
      op = op!!3 %if op&8 # 0;  !no change for '=','#'
    %finish
  %finish
  %result = op
%end;  !RCOND
!<<IMP

%integer%fn OPVAL
! Returns result value for literal (ITEM=ITEM1=0)
!         0 for no-op (result is ITEM1,TYPE1)
!         operator otherwise (result type is TYPE)
! NB literal INTY type is always INTTYPE (not subrange)
%switch op(keyand:rshift)
  -> op(atom)
op(plus):
  check1(numok+setok)
  get ARITH(star)
  %if cat1 = inty %start
    %if item1 = 0 %start
      %result = val1+value %if item = 0
      swop
    %finish
    %result = nop %if item!value = 0
    type = inttype
    %result = add
  %else
    %if item1 = 0 %start
      %if item = 0 %start
        real(addr(val1)) = real(addr(val1))+real(addr(value))
        %result = val1
      %finish
      swop
    %finish
    %result = nop %if item!value = 0
    %result = fadd
  %finish
op(minus):
  check1(numok+setok)
  get ARITH(star)
  %if cat1 = inty %start
    %if item1 = 0 %start
      %result = val1-value %if item = 0
      swop %and %result = neg %if val1 = 0
    %finish
    type = inttype
    %if item = 0 %start
      %result = nop %if value = 0
      value = -value %if value # minint
      %result = add
    %finish
    %result = sub
  %else
    %if item = 0 %start
      %if item1 = 0 %start
        real(addr(val1)) = real(addr(val1))-real(addr(value))
        %result = val1
      %finish
      %result = nop %if value = 0
    %finish
    %result = fsub
  %finish
op(exclam):
  check1(intok);  get EXPRESSION(star,inttype)
  %if item1 = 0 %start
    %result = val1!value %if item = 0
    swop
  %finish
  %result = nop %if item!value = 0
  type = inttype
  %result = or
op(exclam2):
  check1(intok);  get EXPRESSION(star,inttype)
  %if item1 = 0 %start
    %result = val1!!value %if item = 0
    swop
  %finish
  %result = nop %if item!value = 0
  type = inttype
  %result = eor
op(ampersand):
  check1(intok);  get EXPRESSION(star2,inttype)
  %if item1 = 0 %start
    %result = val1&value %if item = 0
    swop
  %finish
  item1 = 0 %and %result = 0 %if item!value = 0
  type = inttype
  %result = and
op(star):
  check1(numok+setok)
  get ARITH(star2)
  item1 = 0 %and %result = 0 %if item!value = 0
  %if cat1 = inty %start
    %if item1 = 0 %start
      %result = val1*value %if item = 0
      swop
    %finish
    type = inttype
    %result = imul %if control&halfbit = 0
    %result = muls
  %else
    %if item1 = 0 %start
      %if item = 0 %start
        real(addr(val1)) = real(addr(val1))*real(addr(value))
        %result = val1
      %finish
      swop
    %finish
    %result = fmul
  %finish
op(over):
  check1(intok);  get EXPRESSION(star2,inttype)
  %if item = 0 %start
    fault(rangerr) %and %result = nop %if value = 0
    %result = val1//value %if item1 = 0
  %finish
  type = inttype
  %result = idiv
op(slash):
  check1(realok)
  get EXPRESSION(star2,realtype)
  %if item = 0 %start
    fault(rangerr) %and %result = nop %if value = 0
    %if item1 = 0 %start
      real(addr(val1)) = real(addr(val1))/real(addr(value))
      %result = val1
    %finish
  %finish
  %result = fdiv
op(backslash2): op(uparrow2):
  check1(intok);  get EXPRESSION(simple,inttype)
  %if item = 0 %start
    %result = val1\\value %if item1 = 0
    item1 = 0 %and %result = 1 %if value = 0
    %result = nop %if value = 1
    item = item1 %and %result = imul %if value = 2
  %finish
  type = inttype
  %result = ipow
op(backslash): op(uparrow): op(star2):
  check1(realok)
  get EXPRESSION(simple,inttype)
  type = realtype
  %if item!item1 = 0 %start
    real(addr(val1)) = real(addr(val1))\value
    %result = val1
  %finish
  %result = fpow
op(lshift):
  check1(intok);  get EXPRESSION(simple,inttype)
  %if item = 0 %start
    %result = val1<<value %if item1 = 0
    %result = nop %if value = 0
  %finish
  type = inttype
  %result = lsl
op(rshift):
  check1(intok);  get EXPRESSION(simple,inttype)
  %if item = 0 %start
    %result = val1>>value %if item1 = 0
    %result = nop %if value = 0
  %finish
  type = inttype
  %result = lsr
op(tilde):
  check1(intok)
  get EXPRESSION(simple,inttype)
  %result = \value %if item = 0
  swop
  type = inttype
  %result = not
op(sconc):
  check1(stringok);  get EXPRESSION(dot+1,stringtype)
  %if item = 0 %start
    %if item1 = 0 %start
      %result = val1 %if value = 0
      %result = value %if val1 = 0
      %if final(val1)+final(value) <= 255 %start
        string(final0+val1) = string(final0+val1) %c
                                 . string(final0+value)
        cad = cad-1
      %finish %else fault(rangerr)
      %result = val1
    %finish
    %result = nop %if value = 0
  %finish %else %if item1!val1 = 0 %start
    item1 = item;  val1 = value;  type1 = type
    %result = nop
  %finish
  type = stringtype
  %result = concat
op(equals):
  %result = RCOND(beq)
op(noteq):
  %result = RCOND(bne)
op(lesseq):
  %result = RCOND(ble)
op(less):
  %result = RCOND(blt)
op(greateq):
  %result = RCOND(bge)
op(greater):
  %result = RCOND(bgt)
%integer%fn RACOND(%integer op)
  toref
  item1 = normitem;  type1 = type
  get REFERENCE(type1)
  val1 = 0 %and swop %if item1 = 0
  syntax error %if arrow <= atom <= greater;  ![ATOM always primed]
  double = -2
  %result = op
%end
op(eqeq):
  %result = RACOND(beq)
op(noteqeq):
  %result = RACOND(bne)
op(arrow):
  check1(stringok)
  item1 = litref(val1) %if item1 = 0
  get RESOLUTION(type,item1)
  item1 = np-3
  condop = bne!!polarity
  type1 = booltype
  %result = nop
op(keyand):
  topred %if condop = 0
  item1 = np;  type1 = booltype
  putact(condop!!polarity!!1+polarity<<7,item,0)
  condop = 0
  get EXPRESSION(scond,booltype)
  dict(item1)_y = item
  syntax error %if a(keyor)=TRUE
  %result = nop
op(keyor):
  topred %if condop = 0
  item1 = np;  type1 = booltype
  putact(condop!!polarity+(polarity!!1)<<7,item,0)
  condop = 0
  get EXPRESSION(scond,booltype)
  dict(item1)_y = item
  syntax error %if a(keyand)=TRUE
  %result = nop
%end

!Get leading operand
  atom = next atom %if matched # 0
  atomp0 = atomp;  jammy = jammy<<1;  !preserve
  %if atom = ident %start
    matched = 1
    name error %if item <= 0 %or (ditem_mode = labmode %and item < c_localdpos)
    fault(namerr+point) %if item >= dlim0
    type = ditem_type
    %if ditem_flags&typeid # 0 %start
      %if ditem_flags&cat = recy %and item > dnil %start
        get RECORD
        %return
      %else
        item1 = item;  ditem1 == ditem
        %if a(less)=TRUE %start;  !type coercion
          get VALUE(0);  get(greater)
          type = item1
        %else
          get(left);          !store mapping
          get VALUE(inttype)
          get(right)
          putexp2(storemap,item1,item1)
          ditem_flags = writable!readable
          ditem_mode = dispmode
        %finish
      %finish
    %finish %else %if ditem_mode = litmode %start
      item = 0;  value = ditem_val
    %else;                                    !non-literal ident
      %cycle
        %if ditem_flags&proc # 0 %start
          %if item = daddr %or item = dsizeof %or item = dnew %start
            get(left)
            %if item = daddr %start
              get REFERENCE(0)
              type = inttype
            %else
              item1 = item
              get REFERENCE(0)
              value = imod(size(type))
              expfault(sizerr) %if value = 0
              %if item1 = dsizeof %start
                item = 0;  type = inttype
              %else
                putexp(dnew,0,litref(value),0)
                ditem_mode = dispmode
              %finish
            %finish
            get(right)
!          %finish %else %if item = dsnl %start
!            putexp(dtostring,nl,0,string1)
          %else
            get PARLIST(0)
            atomp=atomp0 %and error(classerr+point) %if type = 0;  !routine
          %finish
        %else;                                   !not procedure
          atom = next atom %if matched # 0
          %exit %unless aleft <= atom <= recsub %and rank <= simple
          %if atom = aleft %start;  !array subscript
            %cycle
              item1 = item;  ditem1 == ditem
              tp == typecell(type)
              %if tp_flags&cat = stringy %start
                matched = 1
                nonstandard(2)
                get VALUE(bytetype)
                putexp2(sindex,item1,chartype)
              %else
                -> out %unless tp_flags&cat = arry
                matched = 1
                get VALUE(tp_xtype);  !get index
                putexp2(index,item1,tp_type)
              %finish
              ditem_flags = ditem1_flags&heritable
              ditem_mode = ditem1_mode
            %repeat %until %not a(comma)=TRUE
            ditem_flags = ditem_flags+(tp_flags&name)
            get(right)
          %finish %else %if atom = recsub %start;  !record subfield
            item1 = item;  ditem1 == ditem
            dformat == typecell(ditem_type)
            syntax error %unless dformat_flags&cat = recy
            matched = 1
            subbed = 1;  get(ident);  subbed = 0
            error(namerr+point) %if item <= 0
            val1 = ditem1_flags&heritable!ditem_flags
            putexp2(recref,item1,ditem_type)
            ditem_flags = val1
            ditem_mode = ditem1_mode
          %finish %else %if atom = atsign %start
            nonstandard(4)
            syntax error %if ditem_flags&typeid = 0
            matched = 1
            ditem1 == ditem;  item1 = item
            get EXPRESSION(vsimple,inttype)
            putexp2(storemap,item1,item1)
            ditem_flags = writable!readable
            ditem_mode = dispmode
          %else;  !pointer relative
            error(nonref+point) %if ditem_mode < dispmode
            fault(sizerr) %if size(ditem_type) = 0
            matched = 1
            ditem1 == ditem;  item1 = item
            get VALUE(inttype);  get(rightb)
            putexp2(prel,item1,ditem1_type)
            ditem_flags = writable!readable
            ditem_mode = ditem1_mode
          %finish
        %finish
      %repeat
    %finish
  %else
    %if atom = const %start
      matched = 1
    %finish %else %if atom = minus %start;  !leave unmatched
      item = 0;  value = 0;  type = inttype
    %finish %else %if atom = left %start
      matched = 1
      %if rank < major %start;  !condition
        get EXPRESSION(condq,0)
      %else
        get EXPRESSION(major,0)
      %finish
      get(right)
    %finish %else %if a(keynot)=TRUE %start
      syntax error %if rank >= major
      polarity = polarity!!1
      get EXPRESSION(scond,booltype)
      %if item = 0 %then value = value!!1
      polarity = polarity!!1
    %finish %else %if atom = backslash %start
      item = 0;  value = 0;  type = inttype
      atom = tilde
    %finish %else %if a(modsign)=TRUE %start
      get EXPRESSION(major,0)
      %if valok(inttype,type)=TRUE %start
        %if item = 0 %start
          %if value < 0 %start
            %if value # minint %then value = -value %else expfault(rangerr)
          %finish
        %else
          putexp2(iabs,0,inttype)
        %finish
      %finish %else %if valok(realtype,type)=TRUE %start
        putexp2(fabs,0,realtype)
      %else
        error(typerr+point)
      %finish
      get(modsign)
    %else
      syntax error
    %finish
  %finish
out:
  atom = next atom %if matched # 0;  ![always primed on return]

  %if etype < 0 %start;  !reference required
    expp = atomp0;  jammy = jammy>>1;  !restore
%unless item!value = 0 %start;  !*temp*
    toref
    expfault(typerr) %unless refok(etype-sign16,type)=TRUE
%finish %else atomp = atomp0 %and nonstandard(21)
  %else
    %while atom >= rank %cycle
      matched = 1
      double = -1
      op = opval
      %if item1!item = 0 %start;  !both literal
        %if double # -1 %start
          %if double >= 0 %start
            literal = literal+1;  !enforce all literal
            op = op&opval
            literal = literal-1
          %finish
          type = booltype
        %finish
        value = op
      %finish %else %if double = -1 %start;         !not relop
        %if op # 0 %start
          item1 = litref(val1) %if item1 = 0
          putexp(op,item1,normitem,type)
        %else;         !nop
          item = item1;  type = type1
        %finish
      %else;                      !conditional operation
        condop = op!!polarity
        putact(compare,item1,normitem)
        item = np-1
        %if double >= 0 %start
          putact(condop!!polarity!!1+polarity<<7,np-1,np+1);  !implicit %and
          item = double;  ![TYPE,VALUE unchanged]
          matched = 1
          op = opval
          error(nonliteral) %if item1!item = 0;  !mixed non-lit, lit
          condop = op!!polarity
          putact(compare,item1,normitem)
          item = np-2
        %finish
        type = booltype
      %finish
    %repeat
    expp = atomp0;  jammy = jammy>>1
    %if etype # 0 %start
      %if type = booltype %start
        topred %if (rank = cond %or rank = scond) %and condop = 0
      %finish
      expfault(typerr) %unless valok(etype,type)=TRUE
    %finish
  %finish
  atomp=expp %and error(nonliteral+point) %if literal # 0 %and item # 0
%end;  !get EXPRESSION
  
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!  Conditions and loops  !!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%routine GET CONDITION
%integer maxlab,condnp

%routine ASSIGN LABELS(%integer p,lab,pol)
%integer base
%record(identinfo)%name dp
  base=maxlab
  %while (p-condnp)&1 # 0 %cycle;  !compound
    dp == dict(p);  p = dp_y
    %if dp_act&1<<7 = pol %then assign labels(dp_x,lab,pol) %c
    %else maxlab = base+1 %and assign labels(dp_x,maxlab,pol!!1<<7)
  %repeat
  dp == dict(p+1);  dp == dict(p+3) %if dp_act = 0;  !resolution
  %if maxlab > base %then dp_x = maxlab %and maxlab = base %c
  %else dp_x = 0
  dp_y = lab
  dp_act = dp_act&127
%end

  condnp = np
  polarity = subatom;  condop = 0
  get EXPRESSION(cond,booltype)
  putact(condop!!1,item,0)
  %return %if faultnum > 0
  maxlab = curlab+1
  assign labels(item,maxlab,0)
%end;  !get CONDITION

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

%routine DO DYNAMIC ARRAYS
  update sp
  c_mode = c_mode!2_01000000;   !bar to SP rel addressing
  c_status = c_status!globbed;  !needs link
  %while c_dynarray # 0 %cycle
    %if c_dynarray < 0 %then putact(aget,-c_dynarray,one) %c
    %else putact(aget,c_dynarray,0)
    c_dynarray = dict(imod(c_dynarray))_link
  %repeat
  compile(np0)
%end

%routine GET STATEMENTS(%integer stopper)
! STOPPER = 0          -- initial call
!           1 (END)    -- for procedure or block body
!           2 (REPEAT) -- for loop body
!           3 (FINISH) -- for condition body (ELSE not valid)
!           4 (ELSE)   --         "          (ELSE valid)
%switch initial(0:atommax)
%integer forinf,endval,loopstart

%routine THIS IS INST
  %if c_status < hadinst %start;  !first in block
    c_status = c_status+hadinst
    fault(ordererr) %if stopper = 0
  %finish
  fault(accesserr+warn) %if c_access = 0 %and np = np0
  do dynamic arrays %if c_dynarray # 0
%end

%routine PUTACT2(%integer act,item1)
  putact(act,item1,normitem)
%end

%routine GET RESULT
  get VALUE(c_type)
!  fault(rangerr+warn) %if c_type > 0 %and item # 0 %c
!                      %and imod(size(type)) > imod(size(c_type))
%end

%routine GET INSTRUCTION
%integer item1
%record(identinfo)%name tp
  this is inst
  %cycle
    %if a(ident)=TRUE %start
      name error %if item <= 0
      %if ditem_flags&(writable!typeid) # 0 %start
        matched = 0
        get EXPRESSION(simple,0)
        item1 = item
        %if a(equals)=TRUE %start
          jammy = 0
          get VALUE(type)
          putact2(okass+jammy,item1);  !okass,assign
        %finish %else %if a(eqeq)=TRUE %start
          syntax error %if ditem_flags >= 0
          get REFERENCE(type)
          putact2(assign,item1+ad)
        %finish %else %if atom = less %and byteintegeR(fp) = '-' %start
          fp = fp+1;  matched = 1
          jammy = 1
          get VALUE(type)
          putact2(jamass+jammy,item1);  !jamass,okass
        %else
          syntax error %unless a(arrow)=TRUE
          get RESOLUTION(type,item1)
          putact(bne,0,curlab)
          putact(signal,litref(7),undef)
          putact(0,undef,undef)
        %finish
      %else
        error(classerr+point) %if ditem_flags&proc = 0
        tp == typecell(ditem_type)
        %if tp_type # 0 %start;  !function as routine
          get PARLIST(tp_type)
          putact2(assign,value)
        %else
          get PARLIST(0)
        %finish
      %finish
    %else
      c_access = 0 %if np = np0;  !unconditional
      %if a(keymonitor)=TRUE %start
        c_access = 1
!        fault(monitor<<8)
     %finish %else %if a(exit)=TRUE %start;  !%exit, %continue
        %if c_looplab = 0 %then fault(notinloop+point) %c
        %else putact(jumpout,c_looplab,c_looplab+subatom)
        %exit
     %finish %else %if a(keyreturn)=TRUE %start
        item = 0;  value = 0
        get RESULT %if c_type # 0
        putact2(return,0)
        %exit
     %finish %else %if a(keyresult)=TRUE %start
        error(notinfun+point) %if c_type = 0
        syntax error %unless a assop(c_type)=TRUE
        get RESULT
        putact2(return,0)
        %exit
     %finish %else %if a(tf)=TRUE %start;  !%true, %false
        %if c_type # booltype %then fault(notinpred+point) %c
        %else putact(return,0,litref(subatom))
        %exit
     %finish %else %if a(arrow)=TRUE %or a(keygoto)=TRUE %start
        nonstandard(5) %if atom = keygoto
        get(ident)
        %if byteinteger(fp) # '(' %start
          declare(forwardlabel) %if item < c_localdpos {new} %c
                                %or ditem_type # 0 {error}
          putact2(goto,0)
        %else
          name error %if item < c_localdpos
          error(classerr+point) %unless ditem_mode = labmode %c
                                %and ditem_type # 0
          item1 = item
          get(left)
          get VALUE(typecell(ditem_type)_xtype);  !index
          get(right)
          putact2(swgoto,item1)
        %finish
        %exit
     %finish %else %if a(keystop)=TRUE %start
        putact(stop,0,0)
        %exit
     %finish %else %if a(keysignal)=TRUE %start
        c_access = 1
        allow(keyevent)
        get LITERAL(inttype)
        expfault(rangerr) %unless 0 <= value <= 15
        item1 = litref(value);  item = undef
        %if a(comma)=TRUE %start
l1:       %if a(comma)=TRUE %then matched = 0 %else get VALUE(bytetype)
        %finish
        putact2(signal,item1)
        item = undef
        %if a(comma)=TRUE %start
l2:       %if a(comma)=TRUE %then matched = 0 %else get VALUE(inttype)
        %finish
        item1 = normitem;  item = undef
        get VALUE(stringtype) %if a(comma)=TRUE
        putact2(0,item1)
        %exit
      %else
        syntax error
      %finish
    %finish
  %repeat %until %not a(keyand)=TRUE
%end;  !GET INSTRUCTION

%routine GET FOR CLAUSE
!Global: FORINF,ENDVAL
%integer loopvar,lvtype,k,s,start,sval,i,inc,ival,e,n
%integer end
%record(identinfo)%name tp
  forinf = 0
  get(ident)
  name error %if item <= 0
  lvtype = ditem_type;  tp == typecell(lvtype)
  fault(typerr+point) %if tp_flags&nonord # 0
  loopvar = item
  get(equals)
  get VALUE(lvtype)
  start = item;  sval = value
  get(comma)
  get VALUE(lvtype)
  inc = item;  ival = value
  expfault(rangerr) %and ival = 1 %if inc = 0 = ival
!Deal with INC and replace START by START-INC
  k = undef
  k = dict(start)_y %if start >= np0 %and dict(start)_act = add
  %if inc = 0 %start;  !literal increment
    i = litref(ival)
    %if start = 0 %start;  !START and INC both literal
      sval = sval-ival;  item = litref(sval)
    %finish %else %if k <= 0 %start;  !START is x+lit
      k = litval(k)-ival
      item = dict(start)_x
      putexp(add,item,litref(k),inttype) %if k # 0
    %else
      putexp(add,start,litref(-ival),inttype)
    %finish
  %else;  !variable
    i = inc
    %if control&volbit # 0 %start
      declare temp(inttype);  i = item
      putact(assign,i,inc);  forinf = forinf-4
    %finish
    %if start = inc %start;  !identical
      item = 0;  sval = 0
    %finish %else %if k = inc %start;  !START is x+INC
      item = dict(start)_x
    %else
      item = start;  item = litref(sval) %if item = 0
      putexp(sub,item,i,inttype)
    %finish
  %finish
  s = item
!Get end-value
  get(comma)
  get VALUE(lvtype)
  end = item
  %if end = 0 %start;  !literal end-value
    e = litref(value);  endval = value
  %else
    e = item
    %if control&volbit # 0 %start
      declare temp(inttype);  e = item
      putact(assign,e,end);  forinf = forinf-4
    %finish
  %finish
  %if start!inc!end # 0 %and control&loopbit # 0 %start
    putact(forass,loopvar,s)
    putact(forass,i,e)
  %else
    putact(assign,loopvar,s)
  %finish
  putact(label,curlab,0)
  %if start!inc!end = 0 %start;  !all literal
    k = endval-sval;  n = k//ival
    %if n = 0 %start
      fault(dubious+warn)
      putact(else,0,curlab+1);  !ie unconditional branch
      %return
    %finish
    fault(boundserr) %if n < 0
    fault(unending) %if n*ival # k
    forinf = loopvar
  %else
    putact(compare,loopvar,e)
    putact(beq,0,curlab+1)
  %finish
  putact(incass,loopvar,i)
%end;  !get FORCLAUSE

%routine GET LOOP BODY
%integer hold
  hold=c_looplab
  c_looplab = curlab;  curlab = curlab+2
  get STATEMENTS(keyrepeat)
  curlab = curlab-2;  c_looplab = hold
%end

%routine GET SWITCH INDEX
%integer i,lo,hi
%record(identinfo)%name dp,tp
%routine SET LABEL(%shortname p)
  value = p
  expfault(duperr) %if value > 0
  set user label(value)
  p = value
%end
  dp == ditem;  tp == typecell(ditem_type)
  get(left)
  %if a(star)=TRUE %start
    set label(dp_link)
  %else
    get VALUE(tp_xtype)
   !beware faulty declaration or index
    %if tp_xtype > inttype %and faultnum = 0 %start
      get bounds(tp_xtype,lo,hi)
      i = value-lo+dp_val
      c_forward = c_forward-1 %if i < pc;  !(had goto)
      set label(prog(i))
    %finish
  %finish
  get(right)
%end

![unsure of efficiency implications of trapping overflow lower down]
%on %event oflow,fail,done %start
  %if event_event = 0 %start;  !failure in %option,%include or ^Y
    %stop %if event_sub # 0
    %signal abandon
  %finish
  %if event_event = done %start
    croak("Premature end of input") %if stopper # 0
    close block
    c_dpid_val = 0;  !zero entry-point
    %return
  %finish
  fault(rangerr+now) %if event_event = oflow
  -> ignore
%finish
!!!!!!!!!!!!!!!!!!!  Start of new statement  !!!!!!!!!!!!!!!!!!!
next:
  statements = statements+1
  compile(startnp) %if np > np0
  define label(curlab) %if dict(curlab)_val < 0
  define label(curlab+1) %if dict(curlab+1)_val < 0
next1:
  report(faultnum,0,0) %if faultnum # 0
  dlim0 = dlim
  speccing = 0;  subbed = 0
  literal = 0;  jammy = 0;  condop = 0
  dict(curlab)_val = 0;  dict(curlab+1)_val = 0
  np = np0;  startnp = np0
  maxcalldreg = maxdreg;  maxcallareg = maxareg
  zaps = zaps+1 %and forget all %if explo < np0+50
  zaps = zaps+1000 %and forget all %if litpos > litmax-40
  value = 0
!
initial(terminator):
  atom = next atom;  matched = 1
  -> initial(atom)

initial(keycomment): initial(exclam): initial(exclam2):
  comments = comments+1
  read line(0)
  -> next1
term:
  get(terminator)
  -> next

ignore:
  c_access = -1
  %if atom # terminator %start
    %cycle
      subatom = atom;  atom = next atom
    %repeat %until atom = terminator
    starts = starts+1 %if subatom = keystart
    cycles = cycles+1 %if subatom = keycycle
  %finish
  -> next1

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

initial(*):
  error(nonstarter+point)

initial(ident):
  %if byteintegeR(fp) = ':' %start;  !simple label
    fp = fp+1
    declare(definedlabel)
    set user label(ditem_val)
    ->next
  %finish
  name error %if item <= 0
  %if ditem_mode = labmode %and ditem_type # 0 %start
    literal = 1
    get SWITCH INDEX
    get(colon)
    ->next
  %finish
initial(keyreturn): initial(keyresult): initial(tf):
initial(keystop): initial(keysignal): initial(keymonitor):
initial(exit): initial(keygoto): initial(arrow):
  matched = 0
  get INSTRUCTION
  -> next %if a(terminator)=TRUE
  c_access = 1
  %if a(iu)=TRUE %start
    startnp = np
    get CONDITION
  %finish %else %if a(keywhile)=TRUE %start
    putact(repeat,curlab,0);  !append repeat
    startnp = np
    define label(curlab)
    get CONDITION
 %finish %else %if a(keyfor)=TRUE %start
    putact(0,0,0)
    putact(0,0,0)
    putact(repeat,curlab,0);  !append repeat
    startnp = np
    get FOR CLAUSE
    value = np;  np = startnp-3
    %if forinf > 0 %start
      putact(compare,forinf,litref(endval))
      putact(beq,0,curlab)
    %finish %else np = np+2
    putact(repeat,curlab,forinf)
    np = value
  %else
    syntax error %unless a(keyuntil)=TRUE
    get CONDITION
    putact(repeat,curlab,0)
    define label(curlab)
  %finish
  -> term

initial(iu):  !%if, %unless
  this is inst
  %cycle
    get CONDITION
    %if a(keythen)=TRUE %and %not a(keystart)=TRUE %start
      get INSTRUCTION
    %else
      matched = 0;   ![unsee %start]
      get(keystart)
      %cycle
        get(terminator)
        curlab = curlab+2
        get STATEMENTS(keyelse)
        curlab = curlab-2
        %exit %if atom # keyelse;  !%finish ->
        putact(else,curlab+1,curlab)
        -> exit2 %unless a(iu)=TRUE
        get CONDITION
      %repeat
      -> initial(keyend) %if atom = keyend
    %finish
    -> term %unless a(keyelse)=TRUE
    putact(else,curlab+1,curlab)
  %repeat %until %not a(iu)=TRUE
  %unless a(keystart)=TRUE %start
    get INSTRUCTION
  %else
exit2:
    get(terminator)
    curlab = curlab+2
    get STATEMENTS(keyfinish)
    curlab = curlab-2
    -> initial(keyend) %if atom = keyend
  %finish
  -> term

initial(keycycle):
  this is inst
  %if a(terminator)=TRUE %start
    define label(curlab)
    get LOOP BODY
    -> initial(keyend) %if atom = keyend
    get CONDITION %if a(keyuntil)=TRUE
    putact(repeat,curlab,0)
    -> term
  %finish
  nonstandard(22)
  get FOR CLAUSE
  -> for1
initial(keywhile):
  this is inst
  define label(curlab)
  get CONDITION
  get(keycycle)
  get(terminator)
  compile(np0)
  get LOOP BODY
  -> initial(keyend) %if atom = keyend
  nonstandard(6) %and get CONDITION %if a(keyuntil)=TRUE
  putact(repeat,curlab,0)
  ->term
initial(keyfor):
  this is inst
  get FOR CLAUSE
  get(keycycle)
for1:
  get(terminator)
  compile(np0)
  %if forinf > 0 %start;           !Literal for loop
   !%continue must come to end for increment
    loopstart = dict(curlab)_val;  !save start position
    dict(curlab)_val = 0
  %finish
  get LOOP BODY
  -> initial(keyend) %if atom = keyend
  %if forinf > 0 %start;  !literal FOR loop
    define label(curlab)
    dict(curlab)_val = loopstart;  !restore
    putact(compare,forinf,litref(endval))
    putact(beq,0,curlab)
  %finish
  putact(repeat,curlab,forinf)
  -> term

initial(keyon):
  fault(ordererr+point) %if c_status >= hadon %or stopper = 0
  do dynamic arrays %if c_dynarray # 0
  c_status = c_status!hadon
  matched = 1
  allow(keyevent)
  dump = 0
  %cycle
    get LITERAL(inttype)
    expfault(rangerr) %unless 0 <= value <= 15
    dump = dump!1<<value
  %repeat %until %not a(comma)=TRUE
  get(keystart)
  putact(settrap,0,litref(dump))
  curlab = curlab+2
  get STATEMENTS(keyfinish)
  curlab = curlab-2
  -> initial(keyend) %if atom = keyend
  -> term
!
initial(keyelse):
  -> ignore %if starts # 0
  %return %if stopper = keyelse
  error(noif) %if stopper = keyfinish
initial(keyfinish):
  starts = starts-1 %and -> ignore %if starts # 0
  %return %if stopper = keyfinish %or stopper = keyelse
  error(nostart)
initial(keyrepeat):
  cycles = cycles-1 %and -> ignore %if cycles # 0
  %return %if stopper = keyrepeat
  error(nocycle)

initial(star):
  fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0
  matched = 1
  %if byteinteger(fp) = '=' %start
    fp = fp+1
    get LITERAL(inttype)
    plant(dc,0,temp(absmode,value))
  %else
    get MCODE
  %finish
  ->term

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!  Declarations  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%routine DECLARE LIT RANGE(%integer basetype,lo,hi)
%own%record(objinfo) D=0
  fault(boundserr) %and hi = lo %if lo > hi
  item = ranges
  %cycle
    ditem == dict(item)
    item = item-2 %and %return %if ditem_val = hi %and ditem_type = basetype %c
          %and dict(item-1)_val = lo
    item = ditem_hlink
  %repeat %until item = 0
  declare anon(d);               !blank (for updating)
  declare range(basetype,lo,hi)
%end

%routine DECLARE STRING TYPE(%integer size)
  item = stringtype %and %return %if size = -256
  item = string1 %and %return %if size = -2
  item = ranges
  %cycle
    ditem == dict(item)
    %return %if ditem_size = size %and ditem_type = chartype
    item = ditem_hlink
  %repeat %until item = 0
  declare anon(details(typeid+stringy,chartype,0,0))
  ditem_size = size
  ditem_hlink = ranges;  ranges = item
%end

%routine GET LIT RANGE(%integer basetype)
%integer holdval
  get LITERAL(basetype);  holdval = value
  get(colon)
  get LITERAL(basetype)
  declare lit range(basetype,holdval,value)
%end

%routine GET IDENTLIST(%record(objinfo)%name d)
  dlim0 = dlim
  get(ident) %and declare(d) %until %not a(comma)=TRUE
%end

%routine RECALIGN(%integername val)
  align(val,2)
  val = -val %if val > 4
%end

%routine GET DECLARATION(%integer FLAGS,MODE,%integer%name DISP,%integer DEPTH)
%record(objinfo) DECL
%record(identinfo)%name DFHOLD
%owninteger ITEMTYPE=0,ITEMSIZE=0,ADIM=0
%integer BASE,HOLD,MAX,STMAX,DREG,AREG

%routine%spec GET VAR BOUND

%routine GET DATA TYPE
%switch s(ktype:keyname)
  atom = next atom %if matched # 0
  syntax error %unless kattrib <= atom <= keyname
  matched = 1
  -> s(atom)
s(ktype):
  itemtype = inttype+subatom
  itemsize = size(itemtype)
  nonstandard(7) %if itemtype >= mitetype
  allow(keyinteger)
  %return
s(keyinteger):                    !%integer
  itemtype = inttype;  itemsize = 4
  %if a(left)=TRUE %start
    nonstandard(8)
    get LIT RANGE(inttype)
    get(right)
    itemtype = item
    itemsize = typecell(itemtype)_size
  %finish
  %return
s(keylong):                   !%long
  itemtype = inttype;  itemsize = 4;  !**for now**
  %if a(keyinteger)=TRUE %then fault(notin+point+warn) %c
  %else itemtype = realtype %and get(keyreal)
  %return
s(keyreal):                   !%real
  itemtype = realtype;  itemsize = 4
  %return
s(keystring):                 !%string
  itemsize = 0
  %if a(left)=TRUE %start
    atom = next atom
!    %if depth # 0 %and ktype <= atom <= keyinteger %start
!      get VAR BOUND
!      itemtype = stringstar
!    %finish %else %if a(star)=TRUE %start
     %if a(star)=TRUE %start
      itemtype = stringstar
    %else
      get LITERAL(bytetype)
      itemsize = -(value+1)
      declare string type(itemsize)
      itemtype = item
    %finish
    get(right)
  %else
    syntax error %if mode # constmode
    itemtype = stringtype
  %finish
  %return
s(keyrecord):                    !%record
  get(left)
  %unless a(star)=TRUE %start
    %unless a(ident)=TRUE %start
      declare anon(typeident)
      hold = item;  dfhold == dformat
      dformat == ditem
      get DECLARATION(writable+readable,0,dformat_val,0)
      recalign(dformat_val)
      ditem == dformat
      dformat == dfhold;  item = hold
    %finish
    name error %if item <= 0
    error(classerr+point) %if ditem_flags&(\spec) # typeid+recy
    itemtype = item;  itemsize = ditem_val
  %else
    itemtype = recstar;  itemsize = 0
  %finish
  get(right)
  %return
s(keyname):    !untyped %name - leave unmatched
  itemtype = 0;  matched = 0
%end

%routine ASSIGN ADDRESS(%integer size)

%routine ASSIGN STACK ADDRESS
  align(stmax,2);  ditem_val = stmax
  stmax = stmax+imod(size)
  c_status = c_status!onstack %if depth = 1 %and speccing = 0
%end

  size = -4 %if ditem_flags&(name+indirect) # 0
  %if depth # 0 %start
    dlink_link = item;  dlink == ditem
    %if size > 0 %start
     !simple value
      %if dreg > maxcalldreg %start
        assign stack address
        %return
      %finish
      c_reg_content(dreg) = item %if speccing = 0
      ditem_reg = dreg-d0;  dreg = dreg+1
    %else
      %if areg > maxcallareg %start
        assign stack address
        ditem_reg = 8     {would have been in AREG}
        %return
      %finish
      c_reg_content(areg) = item+ad %if speccing = 0 %and ditem_flags < 0
      ditem_reg = areg-d0;  areg = areg+1
    %finish
  %finish
  size = imod(size)
  align(disp,size)
  ditem_val = disp
  %if constmode # ditem_mode # ownmode %start
    disp = disp+size
    %if ditem_mode >= framemode %start
      align(disp,2)
      ditem_val = c_sp-disp;  !neg stack disp.
    %finish
  %finish
%end
!
%routine GET QIDENT
  get(ident)
  %if mode = 0 %start;  !within record format
    head == dformat_link;  item = head
    %if item > 0 %start
      %cycle
        ditem == dict(item)
        fault(duperr+point) %if string(ditem_text+char0) = string(charlim)
        head == ditem_hlink;  item = head
      %repeat %until item <= 0
    %finish
  %finish
  declare(decl)
%end

!<<BOTH
%routine DUMP CONST(%integer v,n)
! Plant N replications of value V (of type ITEMTYPE and size ITEMSIZE)
! For simple operand V is value, otherwise V is address in FINAL
! Alignment requirement has been enforced (since it depends on context)
%integer i,j,k,kk,vv
  k = itemsize
  %if k <= 0 %start;  !structure
    k = -k
    k = final(v)+1 %if k = 0;  ![string]
    cad = v %if v # 0;  !reset cad
  %finish
  kk = k
  %return %if n < 1
  kk = kk*n %if n > 1
  %if mode = constmode %start
    i = cad;  cad = cad+kk
    croak("Program too big") %if cad >= ownbase
  %else
    %if ownbase+ownad+kk-finalbound > 0 %start
      make room(ownbase+ownad+kk-finalbound)
    %finish
    i = ownbase+ownad;  ownad = ownad+kk
  %finish
  %if itemsize <= 0 %start
    %while n > 0 %cycle
      n = n-1;  j = i+k
      %if v # 0 %start
        vv = v
        %cycle
          final(i) = final(vv)
          i = i+1;  vv = vv+1
        %repeat %until i =j
      %else
        final(i) = 0 %and i = i+1 %while i < j
      %finish
    %repeat
  %else
!$IF VAX
{    v = ieee(v) %if itemtype = realtype;  !vax->ieee
!$FINISH
    %while n > 0 %cycle
      n = n-1
      %if itemsize >= 2 %start
        %if itemsize > 2 %start;  !longword
          final(i) <- v>>24
          final(i+1) <- v>>16
          i = i+2
        %finish
        final(i) <- v>>8
        i = i+1
      %finish
      final(i) <- v
      i = i+1
    %repeat
  %finish
%end;  !dump const
!<<IMP

%routine GET VAR BOUND
%integer f
  f = decl_flags
  get DATA TYPE
  decl_flags = okflag+mflag;  decl_type = itemtype
  get(ident);  declare(decl)
  decl_flags = f
  assign address(itemsize)
%end

%routine DECLARE BOUND(%integer mode,val)
  declare anon(details(okflag,inttype,mode,val))
  %if depth # 0 %and mode >= framemode %start
    ditem_flags = ditem_flags!mflag
    assign address(4)
  %finish
%end

%routine GET ARRAY DECLARATION(%integer dim)
%integer pos,dlim1,holdval,holdz,jam,elements,tot,totsize,lo1,size1
%record(identinfo)%name dp
%ownrecord(objinfo) ATYPE=0

%integer%fn XTYPE
  declare anon(details(typeid,inttype,0,0))
  %result = item
%end

%routine STRING STAR ARRAY
  fault(notin+point) %if depth = 0
 ! VAR for size
  declare anon(details(okflag+mflag+inty,inttype,mode,0))
  tot = item
  assign address(4)
 ! TYPEID for string(*)
  declare anon(details(typeid+stringy,inttype,0,0))
  atype_type = item
  elements = maxint
%end

%routine GET REST
%integer e,r,lo,loval,hi,hival
  r = 0
  atom = next atom %if matched # 0
  %if decl_flags < 0 %start;  !%array%name
    %if depth > 0 %and ktype <= atom <= keyinteger %start;  !variable
      r = xtype;  get VAR BOUND
    %else
      get LITERAL(inttype)
    %finish
  %else;                   !%array
    get VALUE(inttype)
  %finish
  loval = value;  lo = item
  loval = minint %if lo # 0
  get(colon)
  atom = next atom %if matched # 0
  %if decl_flags < 0 %start
    %if depth > 0 %and ktype <= atom <= keyinteger %start;  !variable
      %if r = 0 %start
        r = xtype;  declare bound(litmode,loval)
      %finish
      get VAR BOUND
    %else
      %if dim!r = 0 %and a(star)=TRUE %start
        item = 0;  value = maxint
      %else
        get LITERAL(inttype)
        declare bound(litmode,value) %if r # 0
      %finish
    %finish
  %else
    get VALUE(inttype)
  %finish
  hival = value;  hi = item
  hival = maxint %if hi # 0
  e = maxint
  %if r = 0 %start;  !no range yet declared
    %if lo!hi = 0 %start
      e = hival-loval %if hival!!loval >= 0 %or minint+hival-loval < 0
      e = e+1 %if e # maxint
      e = 0 %if hival = maxint
      declare lit range(inttype,loval,hival)
    %else
      declare anon(typeident);               !blank (for updating)
      declare range(inttype,loval,hival)
    %finish
    r = item
  %finish
  elements = e
  %if a(comma)=TRUE %start
    dim = dim+1
    get REST
    %if elements # maxint %and e # maxint %start
      elements = elements*e
    %else
      elements = maxint
    %finish
  %finish
  atype_xtype = r
  size1 = totsize;  lo1 = loval;       !for outer dimension
  string star array %if atype_type = stringstar
  %if elements = maxint %start;             !non-literal bounds
    atype_mode = mode
    declare anon(atype)
    atype_type = item;          !save type id
    %if decl_flags >= 0 %or (depth = 1 %and speccing = 0) %start
      lo = litref(loval) %if lo = 0
      hi = litref(hival) %if hi = 0
      tot = litref(totsize) %if tot = 0
      putact(asize,item,tot)
      putact(0,lo,hi)
      %if decl_flags >= 0  %start
        compile(np0)
        dict(r+1)_mode = c_mode %and dict(r+1)_val = c_sp+4 %if lo > 0
        dict(r+2)_mode = c_mode %and dict(r+2)_val = c_sp %if hi > 0
      %finish
    %finish
    tot = 0;  totsize = 0
  %else;  !literal bounds
    item = 0
    %cycle
      ditem == dict(item)
      %exit %if ditem_type = atype_type %and ditem_xtype = atype_xtype %c
            %and ditem_flags = atype_flags
      item = item+1
      %if item = dlim %start
        declare anon(atype)
        %exit
      %finish
    %repeat
    atype_type = item
    totsize = totsize*e
  %finish
%end;  !get REST

%routine PUT BOUNDS
%integer i
  i = xtype;                         !index type
  declare bound(mode,0);             !lower
  declare bound(mode,0);             !upper
  dim = dim-1
  put bounds %if dim > 0
  string star array %if atype_type = stringstar
  atype_xtype = i
  declare anon(atype);                  !array type
  %if speccing = 0 %start
    tot = litref(totsize) %if tot = 0
    putact(asize,item,tot)
    putact(0,i+1,i+2)
  %finish
  tot = 0;  totsize = 0;  lo1 = minint
  atype_type = item
%end

  pos = dlim0;  dlim1 = dlim;  dp == ditem
  atype_flags = typeid+arry+okflag;  atype_type = itemtype
  %if atype_type < 0 %start;  !element %name
    atype_flags = atype_flags+name;  atype_type = atype_type-name
  %finish
  atype_mode = constmode;   !by default (literal bounds)
  tot = 0;  totsize = imod(itemsize)
  %if dim > 0 %start;  !%array(n)%name
    atype_mode = mode
    put bounds
    elements = maxint
  %else;  !left parenthesis recognised
    get REST
    get(right)
  %finish
  dp_type = atype_type
  %if mode # constmode %and mode # ownmode %start
    holdval = d0
    %while pos # dlim1 %cycle
      dp == dict(pos)
      dp_type = atype_type
      %if mode >= framemode %start
        dp_flags = dp_flags!arrflag %if lo1 = minint %or size1 = 0
        %if decl_flags >= 0 %start;  !%array not %array%name
          %if totsize # 0 {all literal bounds} %c
          %and totsize<<1-c_sp+disp <= 32000 %start
            !if array will occupy less than half remaining reach
            !then allocate directly on stack
            disp = disp+totsize
            align(disp,2)
          %else
            fault(ordererr) %if c_mode&2_01000000 # 0; !hard order error
            %if totsize # 0 %start;  !known bounds but too big
              c_extra = c_extra+totsize
              holdval = litref(totsize)
            %finish
            ![ADOK updates C_SP]
            holdz = 0;  holdz = litref(-lo1*size1) %if dp_flags&arrflag = 0
            putact(adok,holdval,holdz);  !compute & store space needed
            compile(np0)
            dp_flags = dp_flags+indirect
            dp_link = c_dynarray
            c_dynarray = pos;  c_dynarray = -c_dynarray %if holdz # 0
            c_status = c_status!unknown
            holdval = 0
          %finish
          dp_val = c_sp-disp
        %finish
      %else { %if decl_flags >= 0};  !record field or absolute
                                  !** to be corrected **
                                  !name already allocated
{        dp_val = disp;  disp = disp+totsize}
        dp_val = disp
        %if decl_flags < 0 %then disp = disp+4 %else disp = disp+totsize
      %finish
      pos = pos+1
    %repeat
  %else;                           !const,own
    %if decl_flags&(name+indirect) # 0 %start
      %if mode = constmode %then fill code(4) %else fill own(4)
    %else
      %if a assop(itemtype)=TRUE %start
        jam = jammy
        dp_flags = dp_flags!okflag;  ![hum]
        allow(terminator)
        %cycle
          jammy = jam
          get VALUE(itemtype)
          faultnum = rangerr+point+warn %if faultnum = rangerr+point
          holdval = value
          value = 1
          %if a(left)=TRUE %start
            value = elements
            get LITERAL(halftype) %unless a(star)=TRUE
            get(right)
          %finish
          elements = elements-value
          value = value+elements %if elements < 0
          dump const(holdval,value)
        %repeat %until %not a(comma)=TRUE
        %if faultnum = 0 %and elements # 0 %start
          %if elements < 0 %then report(counterr,pos,elements) %c
          %else report(counterr+warn,pos,elements)
        %finish
      %finish
      dump const(0,elements) %if elements > 0
    %finish
  %finish
%end;  !get ARRAY DECLARATION
!
%routine GET PROCEDURE DECLARATION
%integer pos,dlim1,argmode,argad,restype,stack
%record(identinfo)%name headditem,dhold

%integerfn DUPOK
!Check that the proc being declared can reasonably alias existing id
%record(identinfo)%name tp
  %result = FALSE %if ditem_flags&proc = 0
  tp == typecell(ditem_type)
  %if restype = 0 %start;  !routine
    %result = FALSE %if tp_type # 0 %or tp_link = 0; !not routine, or no pars
  %else
    %result = FALSE %if restype = tp_type;  !function of same type
  %finish
  %result = TRUE
%end

  restype = itemtype
  stack = 0;  !unknown
  decl_flags = decl_flags&(\okflag)
  decl_type = procstar;             !by default
  %if depth # 0 %start;             !procedure as param
    decl_flags = decl_flags!proc2;  ![must push MB in case external]
  %finish %else %if mode >= framemode %start
    decl_mode = procmode;  decl_val = 0
    decl_flags = decl_flags!proc1
    decl_flags = decl_flags!spec %if a(keyspec)=TRUE
  %finish %else %if mode = ownmode %start;               !external (not @)
    decl_mode = procmode;  decl_val = 0
    %if a(keyspec)=TRUE %start
      decl_mode = ownmode;  decl_flags = decl_flags!spec
    %finish
  %else;   !@...
    decl_flags = decl_flags!proc1
    decl_val = disp
    stack = 4
  %finish
  %if decl_flags&ext # 0 %and a(keyalias)=TRUE %start
    nonstandard(9)
    get(ident)
    %if item <= 0 %start
      fault(namerr+point)
    %else
      item = 0 %and decl_flags = decl_flags!alt %if dupok=TRUE
    %finish
  %else
    get(ident)
  %finish
  declare(decl)
  headditem == ditem
  assign address(-6) %if depth # 0
  argmode = c_mode&(\2_01000000)+1
  %if decl_flags&spec # 0 %or decl_mode # procmode %start
    speccing = speccing+1
  %else
    c_forward = c_forward-1 %if ditem_flags&rflag # 0
    open block(item)
    c_type = restype
    c_type = c_type!sign16 %if decl_flags&writable # 0 {%map}
  %finish
  dlim1 = dlim
  declare anon(details(0,restype,0,stack))
 ! Result in A0 for %map or structure %fn
  ditem_reg = 8 %if decl_flags&writable # 0 {%map} %C
                %or size(restype) <= 0 {structure %fn}
!Declare parameters
  argad = c_sp;     !ok for both spec and body
  %if a(left)=TRUE %start
    dhold == dlink;  dlink == ditem
    get DECLARATION(okflag+writable+readable,argmode,argad,1)
    dlink == dhold
    get(right)
  %finish
  %if speccing # 0 %start
    speccing = speccing-1
    pos = crunched(dlim1)
    %if pos < dlim1 %or speccing = 0 %start
      headditem_type = pos
    %else;                    !proc as param
      fault(classerr);  dlim = dlim1
    %finish
  %else;                        !procedure body
    %if c_dpid_flags&spec # 0 %start
      c_dpid_flags = c_dpid_flags-spec
      %unless parmatch(c_dpid_type,dlim1)=TRUE %start
        %if c_pid = dlim1-2 %then fault(matcherr+warn) %c
        %else fault(matcherr)
      %finish
    %finish
    headditem_type = dlim1
    c_parlim = dlim
    c_sp = -argad
    compile(np0)
    get(terminator)
    get STATEMENTS(keyend)
  %finish
%end;  !get procedure declaration

%routine GET INITIAL VALUE(%record(identinfo)%name dp)
%integer present
  present=0
  jammy = 0
  %if a assop(itemtype)=TRUE %start
    get VALUE(itemtype)
    dp_flags = dp_flags!okflag
    present = 1
  %finish
  %if mode >= framemode %start;  !dynamic
    %if present # 0 %start
      atomp = expp %and nonstandard(1) %if item # 0
      %if itemtype < 0 %start
        putact(okass,dlim0+ad,normitem)
      %else
        putact(okass+jammy,dlim0,normitem)
      %finish
      compile(np0)
    %finish
  %finish %else %if mode = constmode %start
    syntax error %if present = 0
    %if itemtype < 0 %start;  !name
      dp_flags = writable+readable
      dp_mode = absmode;  dp_val = value
    %else
      faultnum = rangerr+point+warn %if faultnum = rangerr+point
      %if itemsize <= 0 %then dump const(value,1) %c
      %else dp_mode = litmode %and dp_val = value
    %finish
  %else;  !own
    %if present # 0 %start
      faultnum = rangerr+point+warn %if faultnum = rangerr+point
      dump const(value,1)
    %else
      %if itemtype < 0 %then fill own(4) %else fill own(imod(itemsize))
    %finish
  %finish
%end;  !get initial value

dreg = d0;  areg = a0;  stmax = 8;  !allow for RETAD & LINK
max = 0;  base = disp
%cycle
  disp = base
  %cycle
    decl = 0
    decl_flags = flags;  decl_mode = mode
    adim = -1
    %while a(kattrib)=TRUE %cycle
      decl_flags = decl_flags!!(1<<subatom)
    %repeat
    %if depth = 0 %and a(left)=TRUE %start;  !start of sub-group
      align(disp,2)
!      ad_cat = ad_cat+1 %if mode = 0
      get DECLARATION(flags,mode,disp,0);  get(right)
!      ad_cat = ad_cat-1 %if mode = 0
    %finish %else %if a(rpred)=TRUE %start;  !%routine,(%predicate)
      %if subatom # 0 %start;  !pred
        decl_flags = decl_flags&(\(writable))
        decl_flags = decl_flags!volatile %if control&volbit # 0
        itemtype = booltype
      %else
        decl_flags = decl_flags&(\(writable+readable))
        itemtype = 0
      %finish
      get PROCEDURE DECLARATION
      %return %if depth = 0
    %else
      get DATA TYPE
      !Appendages
      %if a(fnmap)=TRUE %start;  !%fn, %map
        decl_flags = decl_flags!volatile %if control&volbit # 0
        %if subatom = 0 %start
          decl_flags = decl_flags&(\writable)
          fault(illstarred) %if itemsize = 0
        %finish
        get PROCEDURE DECLARATION
        %return %if depth = 0
      %else
        decl_flags = decl_flags&(\proc)
        decl_type = itemtype
        %if a(keyname)=TRUE %start
          decl_flags = decl_flags+name;  itemtype = itemtype+name
          itemsize = 4
        %finish
        %if a(keyarray)=TRUE %start
          fault(illstarred) %if itemtype = recstar;  !%record(*)%array
          adim = 0
         ! ITEMTYPE now reflects element type (+name)
         ! DECL is for the array itself
          decl_flags = decl_flags&(\name)
          decl_type = arrstar
          decl_flags = decl_flags!arrflag %if control&arrbit # 0
          %if a(left)=TRUE %start
            fault(notin+point) %if depth = 0
            get LITERAL(inttype)
            %if value&(\7) # 0 %then expfault(rangerr) %else adim = value
            get(right)
            get(keyname);  matched = 0
          %finish
         ! %array%name versus %array
          decl_flags = decl_flags+name %if a(keyname)=TRUE
        %finish
       ! %record(*) or %string(*) needs %name (or @)
       ! %string alone allowed only for %const%string
        fault(illstarred) %if itemsize = 0 %c
                          %and decl_flags >= 0 %and disp ## jokerad %c
                          %and decl_type # stringtype {const}
        %if disp == c_val %start;  !main declaration
          fault(notinblock) %if stopper = 0
          %if c_status >= hadon %start
            %if c_forward!c_return # 0 %or curlab # c_lab1 %start
              fault(ordererr)
            %finish %else %if c_status&hadordererr = 0 %start
              fault(ordererr+warn);  c_status = c_status+hadordererr
            %finish
          %finish
        %finish %else %if decl_flags&ext # 0 %and a(keyspec)=TRUE %start
          decl_flags = decl_flags!(spec+indirect)
        %finish
       !Read identifier list
        %cycle
          dlim0 = dlim
          %unless decl_type = arrstar %start;  !not array
            get QIDENT
            assign address(itemsize)
            %if mode >= ownmode %and depth = 0 %start
              %if decl_flags&spec = 0 %then get INITIAL VALUE(ditem) %c
              %else set own word(0) %and set own word(0)
            %finish
          %else
            %cycle
              get QIDENT
              assign address(0);  !(4 if name)
              %exit %unless a(comma)=TRUE
              atom = next atom
              %if atom # ident %start;  !ie new type
                %if adim = 0 %start;    !treat %array%name as %array(1)%name
                  syntax error %if decl_flags >= 0
                  adim = 1
                %finish
                get ARRAY DECLARATION(adim)
                -> exit22
              %finish
            %repeat
            %if adim # 0 %or %not a(left)=TRUE %start
               %if adim = 0 %start
                 syntax error %if decl_flags >= 0
                 adim = 1
               %finish
               get ARRAY DECLARATION(adim)
               -> exit2
            %finish
            get ARRAY DECLARATION(adim)
          %finish
          -> exit2 %unless a(comma)=TRUE
          atom = next atom
        %repeat %until atom # ident
exit22:
        %continue
      %finish
    %finish
    %exit %unless a(comma)=TRUE;  ![NB %continue above]
  %repeat
exit2:
  max = disp %if disp > max
%repeat %until %not a(keyor)=TRUE
disp = max
%end;  !get declaration

initial(keyconst):
  literal = 1
  get DECLARATION(okflag+readable,constmode,cad,0)
  -> term

initial(atsign):
  dump = 0
atted:
  fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0
  get LITERAL(inttype)
  jokerad = value
  %if a(left)=TRUE %start
    get MIDENT(a0,a7)
    get(right)
    value = item+(dispmode-a0)
  %finish %else value = absmode
  literal = 1
  get DECLARATION(dump!(okflag+writable+readable),value,jokerad,0)
  -> term

initial(keyown):
  literal = 1
  get DECLARATION(writable+readable,ownmode,ownad,0)
  -> term

initial(keyext):
  fault(ordererr) %if level # outerlevel
  literal = 1
  dump = subatom<<12
  -> atted %if a(atsign)=TRUE
  %if a(left)=TRUE %start
    get LITERAL(inttype);  get(right)
    maxcalldreg = (d0-1)+value&15
    maxcallareg = (a0-1)+value>>4&15
    dump = dump!!(value&(\255))
  %finish
  get DECLARATION(dump!(writable+readable),ownmode,ownad,0)
  -> term

initial(keyrecord):
  %unless a(left)=TRUE %start
    get(keyformat)
    %if a(keyspec)=TRUE %start
      typeident_flags = typeid+spec+recy
      get(ident);  declare(typeident)
    %else
      typeident_flags = typeid+recy
      get(ident);  declare(typeident)
      get(left)
      dformat == ditem
      get DECLARATION(writable+readable,0,dformat_val,0)
      recalign(dformat_val)
      get(right)
    %finish
    -> term
  %finish
  fp = fp-1;  atom = keyrecord;  !back-up
initial(ktype): initial(keylong):
initial(keyinteger): initial(keyreal):
initial(kattrib): initial(keystring):
initial(rpred):
  matched = 0
  get DECLARATION(writable+readable,c_mode,c_val,0)
  -> term

initial(keylabel):
  get IDENTLIST(forwardlabel)
  -> term

%routine GET SWITCH DECLARATION
%integer i,lo,hi,dlim1
%ownrecord(objinfo) d=0
  matched = 1
  %cycle
    d_type = arrstar;  !(in case of error)
    d_flags = d_flags+arrflag %if control&arrbit # 0
    d_mode = labmode
    get IDENTLIST(d)
    dlim1 = dlim
    declare anon(details(typeid+arry,0,0,0))
    get(left);  get LIT RANGE(inttype);  get(right)
    dict(dlim1)_xtype = item
    get bounds(item,lo,hi)
    %cycle;  !For each ident in group
      %for i = lo,1,hi %cycle
        swpc = swpc-1;  prog(swpc) = 0
        croak("Code space exhausted") %if swpc <= pc
      %repeat
      dict(dlim0)_val = swpc
      dict(dlim0)_type = dlim1
      dlim0 = dlim0+1
    %repeat %until dlim0 = dlim1
  %repeat %until %not a(comma)=TRUE
%end
initial(keyswitch):
  literal = 1
  get SWITCH DECLARATION
  c_status = c_status!hadswitch
  ->term

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!  Control statements  !!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%routine OPT
%integer c
  c=control
  set options(string(final0+value))
  select output(listout);  !**for now - PAM may alter**
  control = control&(\list) %if initcon&list = 0
  control = control!list %if control&(\c)&(ttlist+codelist+explist+dictlist) # 0
%end

initial(keyoption):
  get LITSTRING
  get(terminator)
  opt %if faultnum = 0
  -> next

initial(keyinclude):
  get LITSTRING
  get(terminator)
  %if faultnum = 0 %start
    croak("Too many nested includes") %if curfile = 3
    line = line+1 %if sym = nl
    cur_fp = fp;  cur_line = line
    fcontrol(curfile) = control
    control = control&(\list) %if control&(codelist+explist+dictlist) = 0
    curfile = curfile+1
    lastfile = -1 %if curfile = lastfile
    cur == file(curfile);  cur = 0
    time1 = time1-cputime
!!    define param("INC",cur_name,nodefault)
    opt
!!    connect edfile(cur)
    time1 = time1+cputime
    %signal abandon %if cur_flag # 0
    line = 0;  sym = nl
    curstart = cur_start2;  curlim = cur_lim2
    fp = cur_start2
  %finish
  ->next

initial(keycontrol):
  get LITERAL(inttype)
  control = 0 %if value = 0
  control = control!!value
  show dict(0) %if control&dictlist # 0
  ->term

initial(keylist):
  control = control!list
  ->term

initial(keybegin):
  get(terminator)
  %if stopper = 0 %start;  !first %begin
    c_localdpos = dlim;  c_parlim = dlim
    c_access = 1
    get STATEMENTS(keyend)
    %return
  %finish
  declare anon(beginblock)
  open block(dlim0)
  get STATEMENTS(keyend)
  update sp
  this is inst
  srcall(dlim-1)
  -> term

initial(keyend):
  %if stopper > keyend %start
    %if stopper = keyrepeat %then fault(norepeat+now) %C
    %else fault(nofinish+now)
  %else
    %if a(keyof)=TRUE %start
      %if a(keylist)=TRUE %start
        control = control&(\list)
        ->term
      %finish
      %if a(keyfile)=TRUE %start
       fp = curlim;  sym = nl
        ->next
      %finish
      get(keyprogram)
      fault(noend+now) %if level # outerlevel
    %finish
    fault(nobegin+now) %if stopper = 0
    %if c_access > 0 %start
      fault(noresult+now) %if c_type # 0;  !fn/map/pred
    %finish
    close block
  %finish
%end;  !GET STATEMENTS

!<<BOTH

%routine ANNOUNCE(%integer value,%string(255) message)
  write(value,1);  space;  printstring(message)
  printsymbol('s') %if value # 1
%end

%routine OUTPUT OBJECT FILE
%constinteger OBJOUT=1
%constinteger INITSIZE=18
!%constinteger INITSIZE=30
%integer i,reset,totsize,ownsize
! INIT SEQUENCE
!   code to copy own values from end of code area to data area
!
!    Program area                 Data area
!   ________________         __________________
!   |              |         |                |
!   |              |         |  STACK SPACE   |
!   |    CODE      |         |                |
!   |              |     SP->|~~~~~~~~~~~~~~~~|
!   |______________|         |                |
!   |    init      |         |                |
!   |~~~~~~~~~~~~~~|         |GLOBAL DYNAMICS |
!   |              |         |                |
!   |  OWN VALUES  |     MB->|~~~~~~~~~~~~~~~~|
!   |              |         |                |
!   |              |         |    OWNS        |
!   |______________|         |                |
!                        orig|                |
!                        SP->|~~~~~~~~~~~~~~~~|
!
 
  reset = 0;  totsize = cad
  ownsize =  ownad
  %if ownsize # 0 %start
    fill own(4-ownad&3) %if ownad&3 # 0
    ownsize = ownad
    reset = cad;    !entry-point for RESET
    totsize = totsize+(initsize+ownad);  !total code size
  %finish
  set extension(objfile,".mob")
  time1 = time1-cputime
  open output(objout,objfile)
  select output(objout)
  put word(16_FE02);  !object module flag, version
  put word(control>>20<<4);  !checking options
  value = 0
  do externals(externs,-1) %if externs # 0;  !find size
  put word(value);        !length of exports
  value = 0
  do externals(extspecs,-1) %if extspecs # 0;  !find size
  put word(value);        !length of imports
  put word(totsize>>16);  !length of code + init pattern
  put word(totsize)
  put word(reset>>1);     !reset entry-point
  put word(c_dpid_val>>1);  !main entry-point
  put word(ownsize>>16);       !static data requirement
  put word(ownsize)
  put word(c_totstack>>16);  !stack requirement
  put word(c_totstack)
  put word(0);            !spare for diag
  put word(0)
  put word(0)
  put word(0)
  do externals(externs,0) %if externs # 0
  do externals(extspecs,1) %if extspecs # 0
  final(0) = 16_4E;  final(1) =16_75;  !RTS (as null reset,main?)
  i = 0
  %cycle
    print symbol(final(i));  i = i+1
  %repeat %until i = cad
  %if ownsize # 0 %start
    put word(16_2248+mb-a0);       !   move.l mb,a1
    put word(16_41FA);             !   lea initpatt,a0
    put word(16_000E)
    put word(16_303C);             !   move.w #????,d0
    put word(ownad>>1-1);          ![individual owns in shortwords - 1]
    put word(16_32D8);             !l1 move.w (a0)+,(a1)+
    put word(16_51C8);             !   dbra d0,l1
    put word(-4)
    put word(16_4E75);             !   rts
    i = 0
    %cycle
      print symbol(final(i+ownbase));  i = i+1
    %repeat %until i = ownad
  %finish
  time1 = time1+cputime
%end

%routine CLOSE EDIT
!_FLAG is negative if edit abandoned
!_CHANGE is untouched (inf) if no changes
  %if file(main)_flag >= 0 %and 0 < file(main)_change # 16_7FFFFFFF %start
    file(main)_name = mainfile;  ![in case modified by OPEN IN]
    time1 = time1-cputime
!!    disconnect edfile(file(main))
    printstring(file(main)_name."  updated");  newline
    time1 = time1+cputime
  %finish
%end

%begin
%on %event redo,abandon %start
  close edit %and %stop %if event_event = abandon
%finish
  time2 = cputime-time1
  statements = 1;  comments = 0;  atoms = 0
  identatoms = 0;  litatoms = 0
  faults = 0;  others = 0;  faultnum = 0
  zaps = 0;  steps = 0;  jumps = 0;  shorts = 0
  rep = ""
  forget triples;  !reset LITPOS,EXPLO,OLDEXPLO
  char0 = addr(char(0));  final0 = addr(final(0))
  preset
  dint == dict(inttype)
  dtemp == dict(lablim);  dtemp2 == dict(lablim+1)
  dtsprel == dict(lablib+2)
  dmin = dictlim;  dmin0 = dmin
  inclim = 0
  accounted = 0
  firstentry = finalbound;  firstpos = dictlim
  pc = 1;  swpc = progbound+1
  cad = 2
  final(0) = 0;  !for empty string (compile-time only)
  ownbase = finalbound-4095;  ownad = 0
  level = outerlevel;  vintage = 1
  pendout = 0;  pendin = 0;  polarity = 0
  curlab = dictlim+1
  reset context(procstar,defaultfree)
  c_sp = -4;   !allow for BSR

  control = initcon
  lastfile = main
  curfile = main;  cur == file(main)
  curstart = file(main)_start1;  curlim = file(main)_lim1
  fp = file(main)_start1
  line = 0;  sym = nl
  np = np0
!<<IMP
  get STATEMENTS(0)
!<<BOTH
%end

  time2 = cputime-time2-time1
  close edit
  output object file %if faults = 0 %or control&forcebit # 0
  %cycle
    select output(listout)
    printstring(file(main)_name)
    %if faults = 0 %or control&forcebit # 0 %start
      printstring(" compiled:")
      announce(statements,"statement")
      print string(" (+")
      announce(comments,"comment")
      printstring(") to")
      announce(cad,"byte")
      printstring(" (+");  write(ownad,1)
      printsymbol(')')
      newline
    %finish
    %if faults # 0 %start
      printsymbol(':')
      announce(faults,"fault")
      printstring(" reported")
      %if others # 0 %start
        printstring(" (+");  announce(others,"other")
        printsymbol(')')
      %finish
      newline
    %finish
    %if control&logbit # 0 %start
      printstring(%c
"  CODE  OWNS  JUMPS SHORT STEPS  ZAPS | ATOMS LITS IDS  TIME")
      newline
      write(cad,5)
      write(ownad,5)
      write(jumps,6);  write(shorts,5)
      write(steps,5);  write(zaps,5)
      print(atoms/statements,5,1)
      print(litatoms/statements,2,1)
      print(identatoms/statements,1,1)
      print(time2/statements,2,3)
      printsymbol('+')
      print(time1/statements,0,3)
      newline
    %finish
    %exit %if listout = 0
    listout = 0
  %repeat
!<<IMP
%endofprogram