         Edinburgh IMP77 Compiler - Version 8.4

    1  %begin
    2  
    3  !!%external%string(255)%fn%spec cliparam
    4  !!%external%integer%fn%spec cputime
    5  
    6  !!%external%routine%spec open output(%integer stream, %string (255) s)
    7  
    8  %const %integer TRUE = 1, FALSE = 0
    9  
   10  %string(255)cliparam; cliparam = "adec"
   11  
   12  !$IF ECSVAX
   13  {%conststring(51) title = %c
   14  {"  EUCSD IMP Compiler for M68000.  VAX Version  2.2g"
   15  !$IF APM
   16  %conststring(51) title = %c
   17+ "  EUCSD IMP Compiler for M68000.  APM Version  2.2g"
   18  !$FINISH
   19  !
   20  ! Hamish Dewar  Computer Science   Edinburgh University  1982/83/84
   21  !
   22  %constinteger WHICH=M'.imp'
   23  
   24  !<<BOTH [markers for parts common to Pascal]
   25  
   26  !General notes:
   27  !  The main data structure DICT is used for identifier, type, label
   28  !  and expression representation (with some aliasing).  The fixedsize
   29  !  cell has a number of advantages which outweigh the Procustean factor
   30  !  (and the 16-byte size is efficiently addressed)
   31  !
   32  !  Major routines (like EVAL) which have variables heavily used by
   33  !   nested routines are not placed below level 1 for efficiency of
   34  !   addressing.  (Making the compiler an external procedure rather
   35  !   than a main program would seriously impact this efficiency).
   36  !
   37  !!!!!!!!!!!!!!!!!!  File handling definitions  !!!!!!!!!!!!!!!!!!!!!
   38  !
   39  %constinteger MAXNAME=127
   40  %string(maxname) MAINFILE,OBJFILE
   41  
   42  ! Editor-compatible file-mapping record:
   43  %recordformat EDFILE(%integer start1,lim1, {part 1}
   44+                               start2,lim2, {part 2}
   45+                               lim, {VMLIM}
   46+                               lbeg,fp,change,flag,
   47+                               line  {line number of current pos},
   48+                               diff  {diff between LINE and ROW},
   49+                        %byte  top  {top row of sub_window},
   50+                               win  {floating top},
   51+                               bot  {bottom row of sub_window},
   52+                               min  {minimum window size},
   53+                               row  {last row position},
   54+                               col  {last col position},
   55+              %string(maxname) name)
   56  !
   57  !!%external%routine%spec EDI(%record(edfile)%name main,sec,
   58  !!                         %string(255) message)
   59  {PAM: parameter acquisition module}
   60  %constinteger NEWGROUP=1, NODEFAULT=2
   61  !!%external%routine%spec DEFINE PARAM %alias "PAM_DEFSTRING" %c
   62  !!          (%string(255) name, %name variable, %integer flags)
   63  !!%external%routine%spec DEFINE INT PARAM %alias "PAM_DEFINT" %c
   64  !!          (%string(255) name, %name variable, %integer flags)
   65  !!%external%routine%spec DEFINE BOOLEAN PARAMS %alias "PAM_DEFBOOL" %c
   66  !!    (%string(255) name, %name variable, %integer flags)
   67  !!%external%routine%spec PROCESS PARAMETERS %alias "PAM_PROCESS"(%string(255)!! parm)
   68  !!%external%routine%spec CONNECT EDFILE(%record(edfile)%name f)
   69  !!%external%routine%spec DISCONNECT EDFILE(%record(edfile)%name f)
   70  !!%external%string(8)%fnspec DATE
   71  !!%external%string(5)%fnspec TIME
   72  
   73  %string(8) DATE; DATE = "02/02/02"
   74  %string(5) TIME; TIME = "02:02"
   75  %integer CPUTIME; CPUTIME = 123
   76  !
   77  %owninteger ITEM=0;                ![high-frequency]
   78  %owninteger LISTOUT=0 {set to 2 if listing to file}
   79  !!  Compiler control
   80  
   81  %constinteger ARRBIT=   16_80000000 {array bound check}
   82  %constinteger LOOPBIT=  16_40000000 {%for loop check}
   83  %constinteger CAPBIT=   16_20000000 {capacity check}
   84  %constinteger OVERBIT=  16_10000000 {overflow check}
   85  %constinteger ASSBIT=   16_08000000 {integer-unassigned check}
   86  %constinteger STRASSBIT=16_04000000 {string-unassigned check}
   87  %constinteger SASSBIT=  16_02000000 {short-unassigned check}
   88  %constinteger BASSBIT=  16_01000000 {byte-unassigned check}
   89  %constinteger ASSMASK=assbit!strassbit!sassbit!bassbit
   90  %constinteger LINEBIT=  16_00800000 {set line number}
   91  %constinteger DIAGBIT=  16_00400000
   92  %constinteger TRACEBIT= 16_00200000 {plant TRAP 15}
   93  %constinteger STACKBIT= 16_00100000 {stack over-run check}
   94  %constinteger CHECKBIT= 16_00080000 {for NOCHECK}
   95  %constinteger SYSBIT=   16_00040000 {special treatment of SIGNAL}
   96  %constinteger STRICTBIT=16_00020000
   97  %constinteger VOLBIT   =16_00010000
   98  %constinteger HALFBIT=  16_00008000 {halfword MULT/DIV}
   99  %constinteger LOWBIT  = 16_00004000 {low-level features permitted}
  100  %constinteger EDITBIT=  16_00002000
  101  %constinteger RUNBIT=   16_00001000
  102  %constinteger FORCEBIT= 16_00000800
  103  %constinteger LOGBIT=   16_00000400 {print log}
  104  %constinteger WARNBIT=  16_00000200 {print warnings}
  105  %constinteger NONSBIT=  16_00000100 {nonstandard features permitted}
  106  %constinteger PERMBIT=  16_00000080 {for PRIM compilation}
  107  %constinteger NEWBIT=   16_00000040 {Pascal: new treatment of pointers}
  108  %constinteger CODELIST= 16_00000020 {list code}
  109  %constinteger DICTLIST= 16_00000010 {list dict entries}
  110  %constinteger EXPLIST=  16_00000008 {list EXP entries}
  111  %constinteger MAPLIST=  16_00000004 {print space map}
  112  %constinteger TTLIST=   16_00000002 {list to terminal}
  113  %constinteger LIST=     16_00000001 {do list}
  114  
  115  	      
  116  %constinteger LISTBITS=codelist+dictlist+explist+maplist+ttlist+list
  117  %owninteger CONTROL=warnbit+checkbit+linebit+diagbit+editbit+volbit %c
  118+                    +strassbit+assbit+arrbit+loopbit+capbit+stackbit
  119  %integer INITCON,TIME1,TIME2
  120  !Events:-
  121  %constinteger OFLOW=1, FAIL=11, DONE=12, REDO=13, ABANDON=14
  122  !
  123  !
  124  %constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT
  125  %constinteger SIGN16=\16_7FFF, SIGN=\16_7FFFFFFF
  126  !
  127  !!!!!!!!!!!!!!!!   Operand Representation  !!!!!!!!!!!!!!!!!!!
  128  ! Operands (largely, Expressions) are denoted by integers in a
  129  ! contiguous range as follows:
  130  ! 
  131  ! <= 0  Literals (including 'addresses' within FINAL)
  132  !       [see LITREF and LITVAL for interpretation]
  133  !                                    Dictionary
  134  !                   __16___16____16____8____8____32____16___16__
  135  ! [dummy @ 0] ->    |flags|type| link| reg|mode|value|text|hlink|
  136  ! D0 [@1]  ->  R    |     |    | size|    |    |     |    |    |
  137  !                   |     |    |xtype|    |    |     |    |    |
  138  ! D7       ->       |     |    |     |    |    |     |    |    |
  139  ! A0       ->  E    |     |    |     |    |    |     |    |    |
  140  !                   |     |    |     |    |    |     |    |    |
  141  ! A7       ->  G    |     |    |     |    |    |     |    |    |
  142  ! INDA0    ->       |     |    |     |    |    |     |    |    |
  143  !              S    |     |    |     |    |    |     |    |    |
  144  ! PREA7    ->       |     |    |     |    |    |     |    |    |
  145  !              I    |     |    |     |    |    |     |    |    |
  146  !              D    |     |    |     |    |    |     |    |    |
  147  !              E    |     |    |     |    |    |     |    |    |
  148  !              N    |     |    |     |    |    |     |    |    |
  149  !              T    |     |    |     |    |    |     |    |    |
  150  !              S    |     |    |     |    |    |     |    |    |
  151  !                   |_____|____|_____|____|____|_____|____|____|
  152  ! DICTLIM  ->       | --  |--  |  -- | -- |mode|value| -- | -- |
  153  !              C L  |     |    |     |    |    |     |    |    |
  154  !              O A  |     |    |     |    |    |     |    |    |
  155  !              M B  |     |    |     |    |    |     |    |    |
  156  !              P S  |     |    |     |    |    |     |    |    |
  157  !                   |_____|____|_____|____|____|_____|____|____|
  158  ! LABLIM   ->       |flags|type| act |----|mode|value|arg1|arg2|
  159  !              C    |     |    |     |    |    |     |    |    |
  160  !              O    |     |    |     |    |    |     |    |    |
  161  !              M E  |     |    |     |    |    |     |    |    |
  162  !              P X  |     |    |     |    |    |     |    |    |
  163  !              L P  |     |    |     |    |    |     |    |    |
  164  !              E S  |     |    |     |    |    |     |    |    |
  165  !              X    |_____|____|_____|____|____|_____|____|____|
  166  ! EXPLIM   ->
  167  
  168  %constinteger SMALLMIN=-1024, SMALLMAX=1023,
  169+               LITMAX=smallmin-(smallmax+1), LITMIN=litmax-199,
  170+               LITMITE=-255, LITQUICK=-16, ONE=-(1<<1)
  171  %constinteger D0=1, D1=d0+1, D2=d0+2, D7=d0+7,
  172+               A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7,
  173+               INDA0=a0+8, INDA7=inda0+7,
  174+               POSTA0=inda0+8, POSTA7=posta0+7,
  175+               PREA0=posta0+8, PREA7=prea0+7,
  176+               UNDEF=a7
  177  %owninteger   DICTLIM=1000, FINALBOUND=64  {see Init for adjustment}
  178  %integer      LABLIM,NP0,EXPLIM {continuing from DICTLIM}
  179  %integer      CHARBOUND         {derived from DICTLIM}
  180  %constinteger LABELS=42 {enough for Pascal reserveds},
  181+               TRIPLES=200
  182  %constinteger AD=16384  {any item + AD >= EXPLIM}
  183  
  184  %constinteger BREG=D0+4, LINELOC=d0+5
  185  %constinteger F1=a0+6, GB=a0+5, MB=a0+4;  !level 1, global base, main base
  186  %constinteger MAXDREG=d0+3, MAXAREG=a0+3
  187  %constinteger D0B=1, D1B=2, D2B=4, BREGB=16,
  188+               A0B=16_100, A1B=16_200, A2B=16_400
  189  %constinteger ANYDREG=16_00FF-bregb, ANYAREG=16_FF00,
  190+               ANYREG=16_FFFF
  191  %constinteger DEFAULTFREE=2<<(maxdreg-d0)-1+(2<<(maxareg-a0)-1)<<8+bregb
  192  %integer MAXCALLDREG, MAXCALLAREG
  193  %integer FREE
  194  
  195  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  196  !!!!!!!!!!!!!!!!!!!!!!!   Big Literals  !!!!!!!!!!!!!!!!!!!!!!!
  197  %integer LITPOS
  198  %integerarray LITSTORE(litmin:litmax)
  199  !
  200  !!!!!!!!!  Registers, Identifiers, Labels, Expressions  !!!!!!!!!
  201  !
  202  !   Operand attributes:
  203  %recordformat OBJINFO %C
  204+   (%short FLAGS,TYPE,
  205+    (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT),
  206+    %byte REG,MODE,
  207+    %integer VAL)
  208  %recordformat IDENTINFO %C
  209+   ((%short FLAGS,TYPE,
  210+    (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT),
  211+     %byte REG,MODE,
  212+     %integer VAL %or %record(objinfo) DETAILS),
  213+    (%short   TEXT,HLINK %or %short X,Y))
  214  !
  215  !Machine addressing modes:
  216  %constinteger AREGMODE=2_001000,
  217+               DISPMODE=2_101000, INDEXMODE=2_110000, ABSMODE=2_111000,
  218+               PCMODE=2_111010, LITMODE=2_111100
  219  !Conversion factors for address register modes (from AREGMODE)
  220  %constinteger INDIR=8, POST=16, PRE=24
  221  !Additional source-related modes:
  222  %constinteger LABMODE=2_10000000+pcmode,
  223+               PROCMODE=2_11000000+pcmode,
  224+               GLOBALMODE=dispmode+(gb-a0),
  225+               OWNMODE=2_01000000+dispmode+(mb-a0),
  226+               CONSTMODE=2_01000000+pcmode,
  227+               FRAMEMODE=2_10000000+dispmode
  228  !                      +  01000000 for dynamic array
  229  !
  230  ! MODE,VAL:
  231  !  %const simple       : LITMODE     the actual value
  232  !  %const structure    : CONSTMODE   address in code area
  233  !  variable etc        : mode        byte address/displacement
  234  !  undefined label     : LABMODE     reference chain
  235  !  undefined procedure : PROCMODE    reference chain
  236  !  record format       : 0           size of record in bytes
  237  !
  238  ! Significance of FLAGS:
  239  %constinteger CAT     =16_000F, {category: typeid only}
  240+               WRITABLE=16_0001,
  241+               READABLE=16_0002, {not write only}
  242+               VOLATILE=16_0004,
  243+               ARRFLAG =16_0008, {bound check needed}
  244+                 ALT   =16_0008, {alternative proc}
  245+               WFLAG   =16_0010, {has been written to}
  246+               RFLAG   =16_0020, {has been read from}
  247+               OKFLAG  =16_0040, {no unassigned check needed, CC OK for fun}
  248+                 NORET =16_0040, {routine does not return}
  249+               MFLAG   =16_0080, {has had mem access}
  250+               SPEC    =16_0100, {unbodied spec or forward label}
  251+               TYPEID  =16_0200, {type identifier}
  252+               PACKED  =16_0400,
  253+               INDIRECT=16_0800,
  254+               PROC    =16_3000, {procedure not data}
  255+                 PROC1 =16_1000,
  256+                 PROC2 =16_2000,
  257+               EXT     =16_4000, {external}
  258+               NAME    =sign16
  259  %constinteger HERITABLE=writable+readable+volatile %c
  260+                        +wflag+rflag+okflag+arrflag
  261  !
  262  !CATegories (type identifiers only):
  263  %constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3,
  264+               POINTY=4, REALY=5,
  265+               STRINGY=8, ARRY=9, SETY=10,
  266+               RECY=12, FILEY=13,
  267+               NONORD=12
  268  
  269  %ownrecord(objinfo) DEFINEDLABEL=0,
  270+                     FORWARDLABEL=0,
  271+                     BEGINBLOCK=0,
  272+                     TYPEIDENT=0
  273  !!!!!!!!!!!!!!!!!  File and control initialisation  !!!!!!!!!!!!!!!
  274  !
  275  %constinteger MAIN=1
  276  %record(edfile)%array FILE(1:3)
  277  %record(edfile)%name CUR
  278  %integerarray FCONTROL(1:3)
  279  %integer CURFILE,LASTFILE;      !current source file no (0:3)
  280  %integer CURSTART,CURLIM;        !current source file bounds
  281  
  282  %routine SET OPTIONS(%string(255) parm)
  283  %owninteger remove warning
  284  %constinteger CHECKS=assmask+arrbit+loopbit+capbit+overbit
  285  !!  define boolean params( %c
  286  !!  "ARR,LOOP,CAP,OVER,ASS,STRASS,SASS,BASS,LINE,DIAG,TRACE,STACK,".%C
  287  !!  "CHECK,SYS,STRICT,VOL,HALF,LOW,EDIT,RUN,FORCE,LOG,WARN,NONS,PERM,NEW,".%C
  288  !!  "CODE,DICT,EXP,MAP,TT,LIST",control,0)
  289  !!  process parameters(parm)
  290    remove warning = ADDR(parm)
  291   !NOCHECK => removal of checkbits
  292    control = control&(\checks) %if control&checkbit = 0
  293    control = control&(\editbit) %if control&listbits # 0
  294  %end
  295  
  296  %routine SET EXTENSION(%string(maxname)%name f,%string(4) ext)
  297  %integer strip
  298  %integer%fn last4(%string(*)%name s)
  299  %integer i,e
  300    i = 0;  e = 0
  301    %while i < length(s) %cycle
  302      i = i+1;  e = e<<8+charno(s,i)
  303    %repeat
  304    %result = e
  305  %end
  306    strip = last4(ext)
  307    f = mainfile %and strip = which %if f = ""
  308    length(f) = length(f)-4 %if last4(f)!16_202020 = strip
  309    f = f.ext
  310  %end
  311  
  312  
  313  %routine OPEN FILES
  314  %string(maxname) LISTFILE; LISTFILE=""
  315    objfile = ""
  316  !!  define param("SOURCE",mainfile,nodefault)
  317  !!  define param("OFILE",objfile,newgroup)
  318  !!  define param("LFILE",listfile,0)
  319  !!  define int param("IDents",dictlim,newgroup)
  320  !!  define int param("KBytes",finalbound,0)
  321    file(main) = 0
  322    set options(cliparam)
  323    control = control&(\linebit) %if control&diagbit = 0;  !*temp*
  324  !Main file
  325    file(main)_name = mainfile;  file(main)_flag = 32768
  326    time1 = time1-cputime
  327  !!  connect edfile(file(main))
  328    time1 = time1+cputime
  329    %stop %if file(main)_flag # 0
  330  
  331  !Listing file
  332    %if listfile # "" %or control&(list+ttlist) # 0 %start
  333      %if control&ttlist = 0 %start
  334        set extension(listfile,".lis")
  335        listout = 2
  336        open output(listout,listfile)
  337      %finish
  338      control = control&(\(editbit+ttlist))
  339      control = control!list %if control&listbits = 0
  340    %finish
  341    select output(listout)
  342    %if control&listbits # 0 %start
  343      control = control!list %if control&listbits # maplist
  344      newlines(2)
  345      printstring(title)
  346      newlines(2)
  347      printstring("   ");  printstring(file(main)_name)
  348      printstring("  compiled on ");  printstring(date)
  349      printstring("  at  ");  printstring(time)
  350      newlines(2)
  351    %finish
  352    initcon = control
  353  %end
  354  
  355    time1 = 0
  356    open files
  357    dictlim = dictlim+300;  !allow for presets
  358    charbound = dictlim*8
  359    finalbound = finalbound<<10+4095;  !kilobytes -> bytes + (min) owns
  360    lablim = dictlim+labels
  361    explim = lablim+triples
  362    np0 = lablim+4
  363    file(main)_change = 16_7FFFFFFF
  364    forwardlabel_flags = spec;  forwardlabel_mode = labmode
  365    definedlabel_mode = labmode
  366    beginblock_mode = procmode
  367    typeident_flags = typeid+recy
  368  !
  369  !!!!!!!!!!!!!!!!  end of file and control initialisation  !!!!!!!!
  370  !
  371  %record(identinfo)%array DICT(0:explim-1)
  372  !  indexing DICT:
  373  %integer DLIM;         !dict limit (up)
  374  %integer DLIM0
  375  %integer DMIN;       !dict upper limit (down)
  376  %integer DMIN0
  377  %integer DICTSHOWN
  378  %integer INCLIM
  379  %record(identinfo)%name DLINK,DFORMAT,DTEMP,DTEMP2,DTSPREL,DINT
  380  %integer SUBBED
  381  %integer RANGES
  382  
  383  ! The identifier dictionary grows as declarations are
  384  ! encountered, sequentially from 0 up, so that the
  385  ! identifiers within a declaration group and within any block
  386  ! are contiguous and may be processed thus (eg at block end).
  387  ! However, searching is always through the hash links, with a
  388  ! start-point given by the array HASHINDEX.  The final link
  389  ! value is zero.
  390  !  Identifiers are normally added at the start of the hash list
  391  ! (hence pushing down any global instance of the same name),
  392  ! but identifiers which have been reported as 'not declared'
  393  ! are added at the end of the list, using a negative link value.
  394  ! This tail section is used to avoid repeated reports for the
  395  ! same name (and is ultra-global, ie never removed).
  396  !
  397  ! For record formats, the format name is stored in the usual way
  398  ! and contains in LINK a pointer to the field-names which are linked
  399  ! through what is normally the hash link.  Searching for field-names
  400  ! proceeds along this chain, as if following hash links.
  401  !
  402  !  HLINK is the hash link (index to DICT)
  403  !
  404  !  TEXT is the pointer (index to CHAR) to the text of the identifier
  405  !       stored as a standard string
  406  
  407  !  Text of identifiers (indexed by _TEXT):
  408  %bytearray CHAR(0:charbound)
  409  %integer CHAR0,CHARLIM,CHARMIN;  !pointers
  410  %integer NEWLEN
  411  
  412  !  Hash index to DICT:
  413  %shortarray HASHINDEX(0:255)
  414  %shortname HEAD;                  !head of ident search list
  415  !
  416  !
  417  !<<IMP
  418  
  419  !* PRIMGEN marker 1
  420  %constinteger NULL=41
  421  %constinteger PROCSTAR=42
  422  %constinteger INTTYPE=43
  423  %constinteger SHORTTYPE=46
  424  %constinteger HALFTYPE=49
  425  %constinteger BYTETYPE=52
  426  %constinteger MITETYPE=55
  427  %constinteger BOOLTYPE=58
  428  %constinteger CHARTYPE=61
  429  %constinteger STRINGSTAR=62
  430  %constinteger STRING1=63
  431  %constinteger STRINGTYPE=64
  432  %constinteger ARRSTAR=65
  433  %constinteger NULLSETTYPE=66
  434  %constinteger RECSTAR=67
  435  %constinteger REALTYPE=69
  436  %constinteger SIGNAL=73
  437  %constinteger DADDR=74
  438  %constinteger DSIZEOF=77
  439  %constinteger INDEX=78
  440  %constinteger LENREF=79
  441  %constinteger SINDEX=82
  442  %constinteger IMUL=86
  443  %constinteger IDIV=87
  444  %constinteger IPOW=88
  445  %constinteger FNEG=89
  446  %constinteger FADD=90
  447  %constinteger FSUB=91
  448  %constinteger FMUL=92
  449  %constinteger FDIV=93
  450  %constinteger FPOW=94
  451  %constinteger FLOAT=95
  452  %constinteger DREM=98
  453  %constinteger UNASS=102
  454  %constinteger ADOK=103
  455  %constinteger STACKOK=104
  456  %constinteger ASIZE=105
  457  %constinteger CONCAT=106
  458  %constinteger DTOSTRING=107
  459  %constinteger AGET=109
  460  %constinteger FOROK=110
  461  %constinteger CHECK=111
  462  %constinteger SCOMP=112
  463  %constinteger STRCOPY=113
  464  %constinteger STRTOSTK=114
  465  %constinteger DNEW=115
  466  %constinteger RESOLVES=117
  467  %constinteger DEVENTF=128
  468  %constinteger DEVENT=134
  469  %constinteger DNIL=137
  470  %constinteger DPRINTSTR=155
  471  %constinteger DWRITE=183
  472  
  473  %constinteger OPMAX=resolves
  474  
  475  %routine SET HASHHEAD(%string(*)%name s)
  476  %integer h,i
  477    h = 0
  478    h = h<<1!!charno(s,i) %for i = 1,1,length(s)
  479    head == hashindex(h&255)
  480  %end
  481  
  482  %routine PRESET
  483  !* PRIMGEN marker 2
  484  %const%integer CMAX=775
  485  %OWN%byte%array CHARINIT(0:CMAX) = 
  486+   0,
  487+   2,'d','0',
  488+   2,'d','1',
  489+   2,'d','2',
  490+   2,'d','3',
  491+   2,'d','4',
  492+   2,'d','5',
  493+   2,'d','6',
  494+   2,'d','7',
  495+   2,'a','0',
  496+   2,'a','1',
  497+   2,'a','2',
  498+   2,'a','3',
  499+   2,'a','4',
  500+   2,'a','5',
  501+   2,'a','6',
  502+   2,'a','7',
  503+   7,'i','n','t','e','g','e','r',
  504+   6,'M','A','X','I','N','T',
  505+   12,'s','h','o','r','t','i','n','t','e','g','e','r',
  506+   11,'h','a','l','f','i','n','t','e','g','e','r',
  507+   11,'b','y','t','e','i','n','t','e','g','e','r',
  508+   11,'m','i','t','e','i','n','t','e','g','e','r',
  509+   7,'B','O','O','L','E','A','N',
  510+   5,'F','A','L','S','E',
  511+   4,'T','R','U','E',
  512+   4,'c','h','a','r',
  513+   6,'s','t','r','i','n','g',
  514+   5,'a','r','r','a','y',
  515+   6,'r','e','c','o','r','d',
  516+   4,'T','E','X','T',
  517+   4,'r','e','a','l',
  518+   8,'l','o','n','g','r','e','a','l',
  519+   6,'S','I','G','N','A','L',
  520+   4,'a','d','d','r',
  521+   6,'s','i','z','e','o','f',
  522+   5,'I','N','D','E','X',
  523+   6,'l','e','n','g','t','h',
  524+   6,'c','h','a','r','n','o',
  525+   4,'I','M','U','L',
  526+   4,'I','D','I','V',
  527+   4,'I','P','O','W',
  528+   4,'F','N','E','G',
  529+   4,'F','A','D','D',
  530+   4,'F','S','U','B',
  531+   4,'F','M','U','L',
  532+   4,'F','D','I','V',
  533+   4,'F','P','O','W',
  534+   5,'f','l','o','a','t',
  535+   3,'r','e','m',
  536+   5,'U','N','A','S','S',
  537+   4,'A','D','O','K',
  538+   7,'S','T','A','C','K','O','K',
  539+   5,'A','S','I','Z','E',
  540+   6,'C','O','N','C','A','T',
  541+   8,'t','o','s','t','r','i','n','g',
  542+   4,'A','G','E','T',
  543+   5,'F','O','R','O','K',
  544+   5,'C','H','E','C','K',
  545+   5,'S','C','O','M','P',
  546+   7,'S','T','R','C','O','P','Y',
  547+   8,'S','T','R','T','O','S','T','K',
  548+   3,'n','e','w',
  549+   8,'r','e','s','o','l','v','e','s',
  550+   9,'s','u','b','s','t','r','i','n','g',
  551+   7,'e','v','e','n','t','f','m',
  552+   5,'e','v','e','n','t',
  553+   3,'s','u','b',
  554+   4,'l','i','n','e',
  555+   5,'e','x','t','r','a',
  556+   7,'m','e','s','s','a','g','e',
  557+   5,'e','v','e','n','t',
  558+   2,'n','l',
  559+   3,'s','n','l',
  560+   3,'n','i','l',
  561+   7,'d','i','s','p','o','s','e',
  562+   5,'r','o','u','n','d',
  563+   5,'t','r','u','n','c',
  564+   8,'f','r','a','c','t','i','o','n',
  565+   3,'i','n','t',
  566+   5,'i','n','t','p','t',
  567+   6,'f','r','a','c','p','t',
  568+   4,'s','q','r','t',
  569+   10,'n','e','x','t','s','y','m','b','o','l',
  570+   10,'r','e','a','d','s','y','m','b','o','l',
  571+   10,'s','k','i','p','s','y','m','b','o','l',
  572+   11,'p','r','i','n','t','s','y','m','b','o','l',
  573+   11,'p','r','i','n','t','s','t','r','i','n','g',
  574+   9,'o','p','e','n','i','n','p','u','t',
  575+   10,'o','p','e','n','o','u','t','p','u','t',
  576+   11,'s','e','l','e','c','t','i','n','p','u','t',
  577+   12,'s','e','l','e','c','t','o','u','t','p','u','t',
  578+   8,'s','e','t','i','n','p','u','t',
  579+   9,'s','e','t','o','u','t','p','u','t',
  580+   10,'r','e','s','e','t','i','n','p','u','t',
  581+   11,'r','e','s','e','t','o','u','t','p','u','t',
  582+   10,'c','l','o','s','e','i','n','p','u','t',
  583+   11,'c','l','o','s','e','o','u','t','p','u','t',
  584+   6,'p','r','o','m','p','t',
  585+   7,'n','e','w','l','i','n','e',
  586+   5,'s','p','a','c','e',
  587+   6,'s','p','a','c','e','s',
  588+   8,'n','e','w','l','i','n','e','s',
  589+   4,'r','e','a','d', 138,'r','e','a','d','s','t','r','i','n','g',
  590+   4,'r','e','a','d', 136,'r','e','a','d','r','e','a','l',
  591+   4,'r','e','a','d',
  592+   5,'w','r','i','t','e',
  593+   7,'c','p','u','t','i','m','e',
  594+   5,'p','r','i','n','t',
  595+   7,'p','r','i','n','t','f','l',
  596+   8,'i','n','s','t','r','e','a','m',
  597+   9,'o','u','t','s','t','r','e','a','m',
  598+   8,'c','l','i','p','a','r','a','m',
  599+ 0
  600  %constinteger PREMAX=196
  601  %own%short%array DICTINIT(41*6:PREMAX*6+5) = 
  602+  516,-1,0,0,0,0,
  603+  527,-1,0,0,0,4,
  604+  512,43,4,56,-32768,0,
  605+  0,-44,4,60,-32768,0,
  606+  0,43,4,60,32767,-1,
  607+  512,43,2,56,-32768,0,
  608+  0,-44,2,60,-1,-32768,
  609+  0,-44,2,60,0,32767,
  610+  512,43,2,56,-32768,0,
  611+  0,-44,2,60,0,0,
  612+  0,-44,2,60,0,-1,
  613+  512,43,1,56,-32768,0,
  614+  0,-44,1,60,0,0,
  615+  0,-44,1,60,0,255,
  616+  512,43,1,56,-32768,0,
  617+  0,-44,1,60,-1,-128,
  618+  0,-44,1,60,0,127,
  619+  514,58,1,0,0,0,
  620+  0,58,1,60,0,0,
  621+  0,58,1,60,0,1,
  622+  513,61,255,0,0,0,
  623+  520,61,0,0,0,0,
  624+  520,-62,-2,0,0,0,
  625+  520,-62,-256,0,0,0,
  626+  521,0,0,0,0,0,
  627+  522,-1,0,0,0,0,
  628+  524,0,0,0,0,0,
  629+  525,61,4,0,0,0,
  630+  517,0,4,0,0,0,
  631+  517,0,4,0,0,0,
  632+  0,-1,0,0,0,0,
  633+  0,-1,0,0,0,0,
  634+  4256,42,0,56,0,16122,
  635+  4098,75,0,56,0,0,
  636+  0,-44,76,0,0,4,
  637+  -32701,-1,0,6313,-1,-4,
  638+  4098,75,0,56,0,0,
  639+  4096,42,0,56,-32767,2861,
  640+  4099,80,0,56,0,0,
  641+  0,-53,81,6144,0,4,
  642+  -32701,-63,0,6313,-1,-4,
  643+  4099,83,0,56,0,0,
  644+  0,-53,84,6144,0,4,
  645+  -32701,-63,85,6313,-1,-4,
  646+  67,-44,0,169,-1,-8,
  647+  4256,42,0,56,0,16116,
  648+  4256,42,0,56,0,16110,
  649+  4096,42,0,56,0,16098,
  650+  4096,42,0,56,0,16092,
  651+  4096,42,0,56,0,16086,
  652+  4096,42,0,56,0,16080,
  653+  4096,42,0,56,0,16074,
  654+  4096,42,0,56,0,16068,
  655+  4096,42,0,56,0,16062,
  656+  4098,96,0,56,0,16056,
  657+  0,-70,97,0,0,4,
  658+  67,-44,0,169,-1,-4,
  659+  4098,99,0,56,0,0,
  660+  0,-44,100,0,0,4,
  661+  67,-44,101,169,-1,-4,
  662+  67,-44,0,425,-1,-8,
  663+  4096,42,0,56,-32722,2578,
  664+  4096,42,0,56,-32704,2064,
  665+  4096,42,0,56,-32688,2839,
  666+  4096,42,0,56,-32665,3097,
  667+  4096,42,0,56,-32640,2077,
  668+  4098,108,0,56,-32611,6,
  669+  0,-64,97,6144,0,4,
  670+  4096,42,0,56,-32605,2597,
  671+  4096,42,0,56,-32568,2334,
  672+  4096,42,0,56,-32538,1806,
  673+  4096,42,0,56,-32524,2626,
  674+  4096,42,0,56,-32458,2070,
  675+  4096,42,0,56,-32436,2090,
  676+  4103,116,0,56,0,16008,
  677+  0,-68,76,6144,0,4,
  678+  22786,118,0,108,0,0,
  679+  0,-59,119,0,0,0,
  680+  -32701,-63,120,6313,-1,-4,
  681+  67,-65,121,6569,-1,-260,
  682+  -32701,-63,122,6825,-1,-264,
  683+  -32701,-63,0,7081,-1,-268,
  684+  4098,124,0,56,-32394,15,
  685+  0,-65,125,6144,0,4,
  686+  -32701,-63,126,6313,-1,-4,
  687+  67,-44,127,169,-1,-8,
  688+  67,-44,0,425,-1,-12,
  689+  524,0,129,0,-1,-264,
  690+  3,52,0,0,0,0,
  691+  3,52,0,0,0,1,
  692+  3,46,0,0,0,2,
  693+  3,43,0,0,0,4,
  694+  3,64,0,0,0,8,
  695+  67,128,0,45,0,32,
  696+  66,43,0,60,0,10,
  697+  66,61,0,60,0,10,
  698+  67,67,0,56,0,0,
  699+  4096,139,0,56,0,16002,
  700+  0,-1,76,0,0,4,
  701+  4098,141,0,56,0,16050,
  702+  0,-44,142,0,0,4,
  703+  67,-70,0,169,-1,-4,
  704+  4098,141,0,56,0,16044,
  705+  4098,145,0,56,0,16038,
  706+  0,-70,142,0,0,4,
  707+  4098,141,0,56,0,16032,
  708+  4098,141,0,56,0,16026,
  709+  4098,145,0,56,0,16020,
  710+  4098,145,0,56,0,16014,
  711+  4098,132,0,56,0,15996,
  712+  4098,132,0,56,0,15990,
  713+  4096,42,0,56,0,15990,
  714+  4256,154,0,56,0,15984,
  715+  0,-1,97,0,0,4,
  716+  4096,156,0,56,0,15978,
  717+  0,-1,157,0,0,4,
  718+  67,-65,0,6313,-1,-256,
  719+  26880,159,0,108,0,0,
  720+  0,-1,160,0,0,0,
  721+  67,-44,161,169,-1,-4,
  722+  67,-65,0,6313,-1,-260,
  723+  26880,159,0,108,0,0,
  724+  4096,154,0,56,0,15960,
  725+  4096,154,0,56,0,15954,
  726+  26880,166,0,108,0,0,
  727+  0,-1,97,0,0,0,
  728+  26880,166,0,108,0,0,
  729+  26880,0,0,108,0,0,
  730+  26880,0,0,108,0,0,
  731+  4096,42,0,56,0,15936,
  732+  4096,42,0,56,0,15930,
  733+  26880,173,0,108,0,0,
  734+  0,-1,157,0,0,0,
  735+  4096,42,0,56,-32379,4,
  736+  4096,42,0,56,-32375,4,
  737+  22784,166,0,108,0,0,
  738+  22784,166,0,108,0,0,
  739+  22790,179,0,108,0,0,
  740+  0,-65,0,6144,0,0,
  741+  22798,181,0,108,0,0,
  742+  0,-70,0,0,0,0,
  743+  22798,1,0,108,0,0,
  744+  22784,184,0,108,0,0,
  745+  0,-1,100,0,0,0,
  746+  26886,1,0,108,0,0,
  747+  22784,187,0,108,0,0,
  748+  0,-1,188,0,0,0,
  749+  67,-70,189,169,-1,-4,
  750+  67,-44,190,425,-1,-8,
  751+  67,-44,0,681,-1,-12,
  752+  22784,192,0,108,0,0,
  753+  0,-1,193,0,0,0,
  754+  67,-70,101,169,-1,-4,
  755+  67,43,0,45,0,392,
  756+  67,43,0,45,0,396,
  757+  67,64,0,45,0,464
  758  
  759  %integer i,ci,anons
  760  %record(identinfo)%name dp
  761  
  762  %routine PUT CHAR
  763    byteinteger(charlim) = charinit(ci)
  764    charlim = charlim+1;  ci = ci+1
  765  %end
  766  
  767  %routine TEXTSET(%record(identinfo)%name dp)
  768  %integer len
  769    dp_hlink = 0
  770    %if dp_type < 0 %start;     !convention for *anon*
  771      dp_type = \dp_type
  772      dp_text = 0
  773      anons = anons-1
  774      dp_hlink = ranges %and ranges = dlim %if anons = 0 %and dlim <= mitetype+2
  775    %else
  776      dp_text = ci
  777      %if charinit(ci+1)&32 # 0 %start;  !not upper-case
  778        %if deventf < dlim < devent %start
  779          head = dlim;  head == dp_hlink
  780        %else
  781          set hashhead(string(addr(charinit(ci))))
  782          dp_hlink = head;  head = dlim
  783          head == dp_link %if dlim = deventf
  784        %finish
  785      %finish
  786      len = charinit(ci)
  787      put char %and len = len-1 %until len < 0
  788      len = charinit(ci)-128
  789      put char %and len = len-1 %while len >= 0
  790      anons = 2
  791    %finish
  792  %end
  793  
  794    hashindex(i) = 0 %for i = 0,1,255;  !hash table empty
  795    byteinteger(char0) = 0;  !for anon ident
  796    charlim = char0+1
  797    charmin = charlim+charbound;  !(1 over top)
  798    ranges = 0
  799  
  800    ci = 1
  801    anons = 100
  802    dict(0) = 0
  803    dlim = d0
  804    %cycle
  805      dp == dict(dlim)
  806      %if dlim <= prea7 %start
  807        dp = 0
  808        dp_flags = okflag+writable+readable;  dp_mode = dlim-d0
  809        dp_type = inttype
  810        textset(dp) %if dlim <= a7
  811      %else
  812        dp_details = record(addr(dictinit(dlim*6)))
  813        textset(dp)
  814      %finish
  815      dlim = dlim+1
  816      %exit %if control&permbit # 0 %and dlim >= signal
  817    %repeat %until dlim > premax
  818    dictshown = dlim
  819    i = dictlim
  820    %cycle
  821      dp == dict(i)
  822      dp = 0
  823      dp_mode = labmode
  824      i = i+1
  825    %repeat %until i = np0
  826  %end;  !preset
  827  
  828  !<<BOTH
  829  
  830  !  The last part of DICT (from LABLIM to EXPLIM) is used for
  831  ! the intermediate representation of the components of source
  832  ! statements between the recognition stage and the code generation
  833  ! stage.
  834  !  The part from LABLIM+4 (NP0) up is used as a temporary pipeline
  835  ! for non-expression cells (instructions, conditions, etc)
  836  ! and the part down from EXPLIM for the canonical and
  837  ! persistent representation of expressions (including name
  838  ! expressions).
  839  ! In this part of the array the ident components PLIST (etc), TEXT
  840  !  and HLINK are replaced by ACT, X and Y representing an operation
  841  !  and (up to) two operands.
  842  %integer EXPLO,OLDEXPLO
  843  %integer NP,STARTNP
  844  
  845  !Operator codes:
  846  ! Machine operator index values 1-31:
  847  %constinteger MOVE=1, ADD=2, SUB=3
  848  %constinteger CMP=4, AND=5, OR=6, EOR=7
  849  %constinteger NOT=8, NEG=9, LSL=10, LSR=11
  850  %constinteger MULS=12, DIVS=13, MULU=14, DIVU=15
  851  %constinteger BRA=16, BSR=17
  852  %constinteger BCC=20, BCS=21, BNE=22, BEQ=23
  853  %constinteger BVC=24, BVS=25
  854  %constinteger BGE=28, BLT=29, BGT=30, BLE=31
  855  %constinteger COMPARE=cmp, GOTO=bra
  856  ! Other built-in operators
  857  %constinteger JAMASS=32, OKASS=33, ASSIGN=34, INCASS=35
  858  %constinteger FORASS=36, STOP=37, RETURN=38, REPEAT=39
  859  %constinteger ELSE=40, JUMPOUT=41, SETTRAP=42, SWGOTO=43
  860  %constinteger LABEL=44, RECREF=45, PREL=46, STOREMAP=47
  861  %constinteger IABS=48, FABS=49, END=50
  862  ! PLUS OPERATORS DEFINED IN DICTIONARY > BOPMAX <= OPMAX
  863  !
  864  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  865  
  866  %integer STARTS, CYCLES
  867  %integer CURLAB
  868  %integer PENDOUT, PENDCOND, PENDIN, POLARITY, CONDOP
  869  %ownshortinteger EXTSPECS=0, EXTERNS=0
  870  !
  871  %recordformat CONTENTINFO(%short ccx,ccy,line,
  872+                           %shortarray content(d0:a7))
  873  %recordformat BLOCKINF(%integer sp, stack, extra, totstack, free, status,
  874+                 type, localdpos, parlim, localtext, localad, vintage,
  875+                 localpc, localswpc, pid, access, forward, lab1, looplab,
  876+                 eventsp, faults, return, shorts, temps,
  877+                 dynarray, oldcontrol, mode,val,
  878+                 %record(identinfo)%name dpid,
  879+                 %record(contentinfo) reg)
  880  !STATUS flag bits
  881  %constinteger UNKNOWN    =16_0002,
  882+               WRONGCC    =16_0004,
  883+               ONSTACK    =16_0008,
  884+               GLOBBED    =16_0010,
  885+               LABGLOBBED =16_0020, {Pascal}
  886+               HADSPEC    =16_0040,
  887+               HADSWITCH  =16_0080,
  888+               HADON      =16_1000,
  889+               HADORDERERR=16_2000,
  890+               HADINST    =16_4000  {max flag}
  891  
  892  %constinteger OUTERLEVEL=0, MAXLEVEL=7
  893  %integer LEVEL;           !current block level
  894  %integer VINTAGE;         !current block number
  895  %record(blockinf) C;      !info for current block
  896  %record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks
  897  %record(contentinfo)%array LREG(0:labels)
  898  
  899  ! Code storage for currently open blocks
  900  %constinteger PROGBOUND=16383
  901  %shortarray PROG(0:progbound)
  902  %bytearray PFLAG(0:progbound)
  903  %constinteger SHORTJUMP=1, JUMP=2, LONGJUMP=3,
  904+               GLOBAL=4, {NEGGLOBAL=5, BIGGLOBAL=6,} INDGLOBAL=7,
  905+               ZEROSHORTS=8
  906  %integer PC,SWPC
  907  ! Final core image
  908  %bytearray FINAL(0:finalbound)
  909  ! Declaration records (to select relevant context)
  910  %integer CAD,OWNAD,JOKERAD,OWNBASE
  911  %integer FINAL0,ACCOUNTED
  912  !
  913  %integer FIRSTENTRY, FIRSTPOS
  914  
  915  !Memo variables for current statement:-
  916  %own%integer {ITEM,}TYPE=0,VALUE=0;      !current operand
  917  %record(identinfo)%name DITEM
  918  %integer SPECCING
  919  %integer DUMP
  920  
  921  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  922  
  923  !!  Source file input and listing
  924  %owninteger ATOM=0;       !current lexical atom
  925  %integer MATCHED;         !indic that atom has been matched
  926  %integer SYM;             !current input symbol
  927  %integer LINE;            !current line number
  928  %owninteger CODEFLAG=' '; !or ^
  929  %integer LISTFLAG;        !' ' or '&' or '+' or '"'
  930  !   Pointers to source file:
  931  %integer LINESTART
  932  %integer FP;              !(file pointer) current position
  933  %integer ATOMP;           !start of current atom
  934  %integer EXPP
  935  !
  936  !! Utility routines
  937  
  938  %integerfn IS SHORT(%integer v)
  939    %result = TRUE %if -32768 <= v <= 32767
  940    %result = FALSE
  941  %end
  942  
  943  %integerfn IS MITE(%integer v)
  944    %result = TRUE %if -128 <= v <= 127
  945    %result = FALSE
  946  %end
  947  
  948  %integer%fn MITE(%integer v)
  949    v = v&255;  v = v-256 %if v&128 # 0
  950    %result = v
  951  %end
  952  
  953  %record(identinfo)%map TYPECELL(%integer t)
  954    %result == dict(t)
  955  %end
  956  
  957  %integer%fn CATEGORY(%integer t)
  958    %result = dict(t)_flags&(packed+cat)
  959  %end
  960  
  961  %integer%fn LITVAL(%integer v)
  962    %result = v %if v = 0
  963    %if v > litmax %start;  !not stored literal
  964      %result = (-v)>>1 %if v&1 = 0
  965      %result = \((-v)>>1)
  966    %finish
  967    %result = litstore(v)
  968  %end
  969  !
  970  !!!!!!!!!!!!!! Listing, diagnostic and report routines  !!!!!!!!!!!!!!
  971  !
  972  %integer FAULTS, OTHERS, FAULTNUM, FAULTP
  973  !
  974  !!  Program statistics
  975  %integer STATEMENTS;           !statement count
  976  %integer COMMENTS;             !comment count
  977  %integer ATOMS;                !atom count
  978  %integer IDENTATOMS;           !identifier count
  979  %integer LITATOMS;             !numeric atom count
  980  %integer ZAPS;                 !enforced cleardown of lits/exps
  981  %integer STEPS;                !stepping stones inserted
  982  !%integer MAXIDENTS, MAXCHARS, MAXLITS
  983  %integer JUMPS,SHORTS
  984  !
  985  %string(255) REP
  986  !
  987  %routine PRINT LINE
  988    print string(rep);  print symbol(nl)
  989    rep = ""
  990  %end
  991  !
  992  %routine PUT SYM(%integer k)
  993    rep = rep.tostring(k)
  994  %end
  995  !
  996  %routine PUT STRING(%string(255) s)
  997    rep = rep.s
  998  %end
  999  !
 1000  !
 1001  %routine PUT NUM(%integer val)
 1002  %routine PD(%integer v)
 1003    pd(v//10) %and v = v-v//10*10 %if v <= -10
 1004    put sym('0'-v)
 1005  %end
 1006    %if val < 0 %then put sym('-') %and pd(val) %c
 1007+   %else pd(-val)
 1008  %end
 1009  !
 1010  %routine PUT IDENT(%integer p,mode)
 1011  %record(identinfo)%name dp
 1012    %cycle
 1013      print line %if length(rep) > 50
 1014      spaces(6) %if rep = ""
 1015      dp == dict(p)
 1016      put sym(' ') %and put sym('"') %if mode # 0
 1017      %if dp_text > 0 %start
 1018          put string(string(char0+dp_text))
 1019      %finish %else %if dp_text < 0 %start
 1020          put num(\dp_text)
 1021      %else
 1022          put num(p)
 1023      %finish
 1024      put sym('"') %if mode # 0
 1025      %return %if mode <= 0
 1026      p = dp_hlink
 1027    %repeat %until p = 0
 1028  %end
 1029  !
 1030  {?}%routine SPACES(%integer n)
 1031  {?}  %while n > 0 %cycle
 1032  {?}    put sym(' ');  n = n-1
 1033  {?}  %repeat
 1034  {?}%end
 1035  {?}!
 1036  {?}%routine PUT SPNUM(%integer val)
 1037  {?}  put sym(' ') %if val >= 0
 1038  {?}  put num(val)
 1039  {?}%end
 1040  {?}
 1041  {?}%constbytearray hexsym(0:15) =
 1042+ {?}'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
 1043  {?}
 1044  {?}%routine PUT HEX(%integer val)
 1045  {?}%integer i
 1046  {?}  put sym(hexsym(val>>i&15)) %for i = 12,-4,0
 1047  {?}%end
 1048  {?}!
 1049  {?}%routine PUT OPERAND(%integer v)
 1050  {?}%integer i
 1051  {?}%routine INTERPRET(%integer mode)
 1052  {?}%switch s(0:7)
 1053  {?}  ->s(mode>>3&7)
 1054  {?}s(0):                 !DREG
 1055  {?}  put sym('D')
 1056  {?}putrno:
 1057  {?}  put sym(mode&7+'0')
 1058  {?}  %return
 1059  {?}s(1):                 !AREG
 1060  {?}  %if mode >= framemode-dispmode %then put sym('F') %else put sym('A')
 1061  {?}  -> putrno
 1062  {?}s(4):                 !PRE
 1063  {?}  put sym('-')
 1064  {?}s(2):                 !INDIRECT
 1065  {?}ind:
 1066  {?}  put sym('(')
 1067  {?}  interpret(mode&2_11000111+aregmode)
 1068  {?}  put sym(')')
 1069  {?}  %return
 1070  {?}s(3):                 !POST
 1071  {?}  interpret(mode-8);  !ind
 1072  {?}  put sym('+')
 1073  {?}  %return
 1074  {?}s(5):                 !DISP
 1075  {?}  put num(i)
 1076  {?}  ->ind
 1077  {?}s(6):                 !INDEX
 1078  {?}  put num(mite(i))
 1079  {?}  put sym('(')
 1080  {?}  interpret(mode+(aregmode-indexmode))
 1081  {?}  put sym(',')
 1082  {?}  interpret(i>>12&15)
 1083  {?}  put sym('.')
 1084  {?}  %if i&16_800 = 0 %then put sym('W') %else put sym('L')
 1085  {?}  put sym(')')
 1086  {?}  %return
 1087  {?}s(7):                 !MISC
 1088  {?}  %if mode&63 = pcmode %start
 1089  {?}    put num(i) %if mode = pcmode;  !suppress if not explicit
 1090  {?}    put string("(PC)")
 1091  {?}    %return
 1092  {?}  %finish
 1093  {?}  %if mode <= absmode+1 %start
 1094  {?}    put sym('$')
 1095  {?}    put hex(i>>16) %if mode = absmode+1 %or %not is short(i)=TRUE
 1096  {?}  %else
 1097  {?}    put sym(hexsym(mode>>4&3))
 1098  {?}    put sym(hexsym(mode&15))
 1099  {?}    put sym('_')
 1100  {?}  %finish
 1101  {?}  put hex(i)
 1102  {?}%end
 1103  {?}
 1104  {?}  %if v <= 0 %start;               !literal
 1105  {?}    v = litval(v)
 1106  {?}    put sym('#')
 1107  {?}    %if is mite(v)=TRUE %then put num(v) %else %start
 1108  {?}      put sym('$')
 1109  {?}      put hex(v>>16) %if v>>16 # 0
 1110  {?}      put hex(v&16_FFFF)
 1111  {?}    %finish
 1112  {?}  %finish %else %if v <= prea7 %start;    !register
 1113  {?}    interpret(v-d0)
 1114  {?}  %finish %else %if v < dictlim %start;  !identifier
 1115  {?}    put ident(v,0)
 1116  {?}  %finish %else %if v < lablim %start;  !internal label
 1117  {?}    put sym('L')
 1118  {?}    put num(v-dictlim)
 1119  {?}  %else;                 !complex
 1120  {?}    i = dict(v)_val
 1121  {?}    interpret(dict(v)_mode)
 1122  {?}  %finish
 1123  {?}%end;  !put operand
 1124  {?}
 1125  {?}%routine MARK AT(%integer col)
 1126  {?}  put sym(' ') %while length(rep) < col;  put sym('|')
 1127  {?}%end
 1128  {?}!
 1129  {?}%routine SHOW DICT(%integer from)
 1130  {?}%integer i
 1131  {?}%record(identinfo) d
 1132  {?}%constbytearray flagsym(0:15) =
 1133+ {?}  'W','R','V','A','w','r','o','m','S','T','K','?','P','p','E','*'
 1134  {?}%constbytearray catsym(0:15) =
 1135+ {?}  'I', 'C', 'B', 'E', '@', 'X', '?', '?',
 1136+ {?}  'S', 'A', 'Z', '?', 'R', 'F', '?', '?'
 1137  {?}
 1138  {?}  %return %if from >= dlim
 1139  !<<IMP
 1140  {?}  print line %if rep # ""
 1141  {?}  byteinteger(charlim) = 0
 1142  {?}  spaces(6)
 1143  {?}  put string("___identifier____flags___type__link__par_mode___value____")
 1144  {?}  print line
 1145  {?}  %cycle
 1146  {?}    put spnum(from);  mark at(6)
 1147  {?}    d = dict(from)
 1148  {?}    put sym(' ');  put ident(from,0)
 1149  {?}    %if d_text > 0 %start
 1150  {?}      i = char0+d_text;  i = i+byteinteger(i)+1
 1151  {?}      %if byteinteger(i)&128 # 0 %start
 1152  {?}        byteinteger(i) = byteinteger(i)-128
 1153  {?}        put sym(':');  put string(string(i))
 1154  {?}        byteinteger(i) = byteinteger(i)+128
 1155  {?}      %finish
 1156  {?}    %finish
 1157  {?}    mark at(22)
 1158  {?}    %if d_flags&typeid # 0 %then put sym(catsym(d_flags&cat)) %and i = 4 %c
 1159+ {?}    %else put sym(' ') %and i = 0
 1160  {?}    %cycle
 1161  {?}      put sym(flagsym(i)) %if d_flags>>i&1 # 0
 1162  {?}      i = i+1
 1163  {?}    %repeat %until i > 15
 1164  {?}    mark at(30)
 1165  {?}    put spnum(d_type);  mark at(35)
 1166  {?}    put spnum(d_link);  mark at(42)
 1167  {?}    put spnum(d_reg);  mark at(46)
 1168  {?}    put spnum(d_mode);  mark at(51)
 1169  {?}    put spnum(d_val);  mark at(63)
 1170  {?}    print line
 1171  {?}    from = from+1
 1172  {?}  %repeat %until from = dlim
 1173  {?}  spaces(6)
 1174  {?}  put string("+-------------------------------------------------------+")
 1175  {?}  print line
 1176  !<<BOTH
 1177  {?}%end
 1178  {?}%routine PUT MNEMONIC(%integer m)
 1179  {?}  m = m<<2
 1180  {?}  %cycle
 1181  {?}    put sym(m>>27+'A'-1)
 1182  {?}    m = m<<5
 1183  {?}  %repeat %until m = 0
 1184  {?}%end
 1185  {?}%routine%spec PUT OPCODE(%integer op)
 1186  {?}%routine SHOW EXP(%integer startp)
 1187  {?}%integer p,q
 1188  {?}%record(identinfo)%name dp
 1189  {?}
 1190  %constinteger bopmax=51
 1191  %constintegerarray EXTRA(32:bopmax) =
 1192+ 'j'<<25+('a'&31)<<20+('m'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
 1193+ 'o'<<25+('k'&31)<<20+('a'&31)<<15+('s'&31)<<10+('s'&31)<<5,
 1194+ 'a'<<25+('s'&31)<<20+('s'&31)<<15+('i'&31)<<10+('g'&31)<<5+('n'&31),
 1195+ 'i'<<25+('n'&31)<<20+('c'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
 1196+ 'f'<<25+('o'&31)<<20+('r'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
 1197+ 's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
 1198+ 'r'<<25+('e'&31)<<20+('t'&31)<<15+('u'&31)<<10+('r'&31)<<5+('n'&31),
 1199+ 'r'<<25+('e'&31)<<20+('p'&31)<<15+('e'&31)<<10+('a'&31)<<5+('t'&31),
 1200+ 'e'<<25+('l'&31)<<20+('s'&31)<<15+('e'&31)<<10,
 1201+ 'e'<<25+('x'&31)<<20+('i'&31)<<15+('t'&31)<<10,
 1202+ 't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
 1203+ 's'<<25+('w'&31)<<20+('g'&31)<<15+('o'&31)<<10+('t'&31)<<5+('o'&31),
 1204+ 'l'<<25+('a'&31)<<20+('b'&31)<<15+('e'&31)<<10+('l'&31)<<5,
 1205+ 'r'<<25+('e'&31)<<20+('c'&31)<<15+('r'&31)<<10+('e'&31)<<5+('f'&31),
 1206+ 'p'<<25+('r'&31)<<20+('e'&31)<<15+('l'&31)<<10,
 1207+ 's'<<25+('t'&31)<<20+('r'&31)<<15+('m'&31)<<10+('a'&31)<<5+('p'&31),
 1208+ 'i'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
 1209+ 'f'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
 1210+ 'e'<<25+('n'&31)<<20+('d'&31)<<15,
 1211+ 'l'<<25+('o'&31)<<20+('g'&31)<<15+('s'&31)<<10+('u'&31)<<5+('b'&31)
 1212  
 1213  {?}%routine PUT OPRAND(%integer v)
 1214  {?}  put sym('#') %and v = v-ad %if v >= explim
 1215  {?}  %if v < np0 %then put operand(v) %else put num(v)
 1216  {?}%end
 1217  {?}  print line %if rep # ""
 1218  {?}  %return %unless np > np0
 1219  {?}  put string("      ______action_______first_______second____")
 1220  {?}  print line
 1221  {?}  p = np0
 1222  {?}  %cycle
 1223  {?}    %if p = np %start
 1224  {?}      p = explo
 1225  {?}      %exit %if p >= oldexplo
 1226  {?}      put string("      |---------------------------------------|")
 1227  {?}      print line
 1228  {?}    %finish
 1229  {?}    %if p = startp %then put sym('>') %else put sym(' ')
 1230  {?}    put num(p);  mark at(6)
 1231  {?}    dp == dict(p)
 1232  {?}    put sym(' ')
 1233  {?}    q = dp_act
 1234  {?}    %if q <= 31 %start
 1235  {?}         put opcode(q)
 1236  {?}    %finish %else %if q <= bopmax %start
 1237  {?}       put mnemonic(extra(q))
 1238  {?}    %else
 1239  {?}        put ident(q,0)
 1240  {?}    %finish
 1241  {?}    mark at(22)
 1242  {?}    put sym(' ');  put oprand(dp_x);  mark at(34)
 1243  {?}    put sym(' ');  put oprand(dp_y);  mark at(46)
 1244  {?}    %if p >= explo %start
 1245  {?}      put spnum(dp_type)
 1246  {?}      put sym('*') %if dp_flags < 0
 1247  {?}    %finish
 1248  {?}    print line
 1249  {?}    p = p+1
 1250  {?}  %repeat %until p >= oldexplo
 1251  {?}  oldexplo = explo
 1252  {?}  put string("      +---------------------------------------+")
 1253  {?}  print line
 1254  {?}%end
 1255  {?}!
 1256  !
 1257  !!!!!!!!!!!!!!!!!!!!!!!!!!!! Fault reporting  !!!!!!!!!!!!!!!!!!!!!!!!!!!
 1258  !
 1259  %routine CROAK(%string(255) s)
 1260    select output(0)
 1261    put string("** ");  put string(s)
 1262    put string(".  Compilation abandoned at line ");  put num(line)
 1263    print line
 1264    %signal abandon
 1265  %end
 1266  
 1267  !<<IMP
 1268  
 1269  !!  Fault numbers
 1270  %constinteger INTERNERR=1, PLEXERR=2, CREACHERR=3, REACHERR=4
 1271  %constinteger NORESULT=5, DREACHERR=6
 1272  %constinteger FORMERR=7, ATOMERR=8, NAMERR=9, CLASSERR=10
 1273  %constinteger SIZERR=11, TYPERR=12, BOUNDSERR=13, UNENDING=14
 1274  %constinteger LOWLEVEL=15, ACCESSERR=16, NOTINLOOP=17, NOTINROUT=18
 1275  %constinteger NOTINFUN=19, NOTINPRED=20, DUPERR=21
 1276  %constinteger ORDERERR=22, MATCHERR=23, RANGERR=24, NONLITERAL=25
 1277  %constinteger MOPERR=26, NOCYCLE=27
 1278  %constinteger NOSTART=28, NOIF=29, ILLSTARRED=30, NONSTARTER=31
 1279  %constinteger NONVAR=32, NONREF=33, TOOFEW=34, TOOMANY=35
 1280  %constinteger NOBEGIN=36, DUBIOUS=37, NOTINBLOCK=38
 1281  %constinteger NONSTAND=39, NOTIN=40, ASSERR=41
 1282  %constinteger NOEND=42, NOFINISH=43, NOREPEAT=44
 1283  %constinteger COUNTERR=45, SLABMISSING=46, IDMISSING=47
 1284  %constinteger POINT=64, WARN=-128, NOW=128
 1285  !
 1286  %routine REPORT(%integer n,id,num)
 1287  %owninteger lastchange=0
 1288  %integer mark,start,errline
 1289  
 1290  %routine PRINT TEXT(%integer stream)
 1291  %constinteger esc=27
 1292  %integer k,p
 1293  
 1294  %conststring(15)%array MESSAGE(1:44) =
 1295+   "Internal error ", "Reg not free",
 1296+   "Out of reach ",  " out of reach!",
 1297+   "RESULT missing", "Out of reach",
 1298+   "Faulty form", "Unknown atom",
 1299+   "Unknown name", "Wrong class",
 1300+   "Wrong size", "Wrong type",
 1301+   "Inside out", "Endless loop",
 1302+   "Low level", "Not accessible",
 1303+   "Not in loop", "Not in routine",
 1304+   "Not in fn/map", "Not in pred",
 1305+   "Duplicate",
 1306+   "Out of order", "Mismatch",
 1307+   "Out of range", "Not literal",
 1308+   "Faulty operand", "%CYCLE missing",
 1309+   "%START missing", "Extra %ELSE",
 1310+   "Ill-starred", "Non-starter",
 1311+   "Not variable", "Not reference",
 1312+   "Too few args", "Too many args",
 1313+   "%BEGIN missing",
 1314+   "Dubious usage", "Not in block",
 1315+   "Nonstandard ", "Not supported",
 1316+   " void",
 1317+   "%END missing",
 1318+   "%FINISH missing", "%REPEAT missing"
 1319  
 1320  !<<BOTH
 1321  
 1322    put sym(mark)
 1323    put sym(' ') %if errline < 1000
 1324    put sym(' ') %if errline < 100
 1325    put sym(' ') %if errline < 10
 1326    put num(errline)
 1327    put sym(listflag);  put sym(' ')
 1328    k = n&63
 1329    %if k >= counterr %start
 1330      %if k = counterr %start
 1331        %if num < 0 %start
 1332          put num(-num);  put string(" extra")
 1333        %else
 1334          put num(num) %if num # 0;  put string(" missing")
 1335        %finish
 1336        put string(" value(s) for ")
 1337        put ident(id,0)
 1338        %return
 1339      %finish
 1340      %if k # slabmissing %start
 1341        put ident(id,1)
 1342      %else
 1343        put ident(id,0)
 1344        put sym('(');  put num(num);  put sym(')')
 1345      %finish
 1346      put string(" missing")
 1347  mend:
 1348      %if c_dpid_text # 0 %start
 1349        put string(" in ")
 1350        put ident(c_pid,-1)
 1351      %finish
 1352      %return
 1353    %finish
 1354    put ident(id,0) %if id > 0
 1355    put string(message(k))
 1356    put num(num) %if num > 0
 1357    -> mend %if creacherr <= k <= noresult
 1358    spaces(22-length(rep))
 1359    p = start
 1360    p = p+1 %while byteinteger(p) = ' '
 1361    %if p < faultp-50 %then p = faultp-47 %and put string("...") %c
 1362+   %else put sym(' ')
 1363    %cycle
 1364      k = byteintegeR(p);  p = p+1
 1365      %if p = faultp %start
 1366  !      %if stream # 0 %then put sym('|') %else %start
 1367  !       !**V200**
 1368  !        put sym(esc);  put sym('F');  !graphics
 1369  !        put sym('~')
 1370  !        put sym(esc);  put sym('G');  !normal
 1371  !      %finish
 1372        put sym('|')
 1373      %finish
 1374      %exit %if k = nl
 1375      put sym(k)
 1376  !    %if ' ' <= k <= '~' %then put sym(k) %c
 1377  !    %else put sym('[') %and put num(k) %and put sym(']')
 1378    %repeat
 1379    %return
 1380  %end
?ESC unused
?STREAM unused
 1381  
 1382  !Warning or error
 1383    mark = '?'
 1384    %if n > 0 %start
 1385      mark = '*'
 1386      c_faults = c_faults+1;  faults = faults+1
 1387    %finish
 1388    faultnum = 0;  c_access = -1
 1389  !Ignore uncorrected earlier error
 1390    %return %if file(main)_start1 <= fp < lastchange
 1391  !Establish what to print
 1392    start = linestart;  errline = line
 1393    %if n&point = 0 %start
 1394      faultp = 0;  !no pointing
 1395    %else
 1396      %while start >= faultp %cycle;  !before current line
 1397        start = start-1
 1398        errline = errline-1 %if byteintegeR(start) = nl
 1399      %repeat
 1400      start = start-1 %while start # curstart %and byteintegeR(start-1) # nl
 1401    %finish
 1402    time1 = time1-cputime
 1403    %if listout # 0 %start;  !listing file
 1404      print text(listout);  print line
 1405    %finish
 1406    select output(0)
 1407    %if curfile # lastfile %start
 1408      lastfile = curfile;  put string(cur_name);  print line
 1409    %finish
 1410    print text(0)
 1411    %if n > reacherr %and curfile = main %and control&editbit # 0 %start
 1412      start = faultp-1 %if faultp > start
 1413      cur_fp = start;  cur_line = line
 1414      cur_change = 16_7FFFFFFE %if lastchange # 0
 1415      select input(0)
 1416      file(main+1) = 0
 1417  !!    edi(file(main),file(main+1),rep);  !main+1 to keep editor happy
 1418      rep = ""
 1419      select output(listout)
 1420      time1 = time1+cputime
 1421      %signal abandon %if cur_flag < 0 {abandoned}
 1422      control = control&(\editbit) %if cur_flag = 'I'
 1423      lastchange = cur_change %and %signal redo %if cur_change < 16_7FFFFFFE
 1424    %else
 1425      print line
 1426      select output(listout)
 1427      time1 = time1+cputime
 1428    %finish
 1429  %end;  !report
 1430  
 1431  %routine FAULT(%integer n)
 1432  !Note fault number and position of (earliest) fault
 1433  ! for subsequent reporting (warnings and weak errors)
 1434    %if faultnum = 0 %or (n > 0 %and faultnum < 0) %start
 1435      faultnum = n;  faultp = atomp
 1436      report(faultnum&127,0,0) %if faultnum >= now
 1437    %finish
 1438  %end
 1439  
 1440  %routine INTERN(%integer n)
 1441    report(internerr,0,n)
 1442  %end
 1443  
 1444  !!!!!!!!!!!!!!!!!!!!   CELL  CONSTRUCTORS  !!!!!!!!!!!!!!!!!!!
 1445  !
 1446  %integer%fn LITREF(%integer v)
 1447  %integer i
 1448    %result = v %if v = 0
 1449    %if v > 0 %start
 1450      %result = -(v<<1) %if v <= smallmax
 1451    %else
 1452      %result = v<<1+1 %if v >= smallmin
 1453    %finish
 1454    litstore(litpos) = v
 1455    i = litmin-1
 1456    i = i+1 %until litstore(i) = v
 1457    %if i = litpos %start
 1458      litpos = litpos+1
 1459      croak("Too many literals") %if litpos >= litmax
 1460    %finish
 1461    %result = i
 1462  %end
 1463  !
 1464  %routine PUTEXP(%integer act,x,y,t)
 1465    type = t
 1466    item = explim
 1467    item = x %if explo <= x < item
 1468    item = y %if explo <= y < item
 1469    %cycle
 1470      item = item-1
 1471      ditem == dict(item)
 1472      %if item < explo %start
 1473        explo = item
 1474        ditem_act = act;  ditem_x = x;  ditem_y = y
 1475        ditem_flags = 0;  ditem_type = t;  ditem_mode = 0
 1476        %exit
 1477      %finish
 1478    %repeat %until ditem_act = act %and ditem_x = x %and ditem_y = y
 1479  %end
 1480  
 1481  !$IF VAX
 1482  {%integer%fn IEEE(%integer v)
 1483  {  %result = 0 %if v = 0
 1484  {  %result = v<<16+v>>16-16_01000000
 1485  {%end
 1486  !$FINISH
 1487  
 1488  %routine PUTEXP2(%integer op,first,t)
 1489    %if item = 0 %start
 1490  !$IF VAX
 1491  {  value = ieee(value) %if type = realtype;  !vax->ieee
 1492  !$FINISH
 1493      item = litref(value)
 1494    %finish
 1495    putexp(op,first,item,t)
 1496  %end
 1497  
 1498  %integer%fn NORMITEM
 1499    %result = item %if item # 0
 1500  !$IF VAX
 1501  {  value = ieee(value) %if type = realtype;  !vax->ieee
 1502  !$FINISH
 1503    %result = litref(value)
 1504  %end
 1505  
 1506  %routine TOREAL
 1507    %if item # 0 %then putexp(float,item,0,realtype) %c
 1508+   %else real(addr(value)) = value %and type = realtype
 1509  %end
 1510  
 1511  %integer%fn TEMP(%integer m,v)
 1512    dtemp_mode = m;  dtemp_val = v
 1513    %result = lablim
 1514  %end
 1515  %integer%fn TEMPX(%integer r1,r2)
 1516    dtemp_mode = r1+(indexmode-a0);  dtemp_val = (r2-d0)<<12+16_0800
 1517    %result = lablim
 1518  %end
 1519  %integer%fn TEMPD(%integer a,disp)
 1520    dtemp_mode = a+(dispmode-a0);  dtemp_val = disp
 1521    %result = lablim
 1522  %end
 1523  %integer%fn TEMPX2(%integer r1,r2)
 1524    dtemp2_mode = r1+(indexmode-a0);  dtemp2_val = (r2-d0)<<12+16_0800
 1525    %result = lablim+1
 1526  %end
 1527  
 1528  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1529  !!!!!!!!!!!!!!!!!    CODE  GENERATION   !!!!!!!!!!!!!!!!!!!!!!!!
 1530  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1531  !
 1532  !  The array DEF contains packed mnemonics for M68000 machine
 1533  ! instructions and, for each mnemonic, the basic opcode and
 1534  ! a type indicator.
 1535  !  The type indicator contains flag bits for various special cases
 1536  ! and two 6-bit fields defining the operand types
 1537  ! [should be const record array]
 1538  !  The mnemonics and variant distinctions broadly follow the
 1539  !  manufacturer's Assembly Language conventions
 1540  !
 1541  ! Opcode index values needed globally:-
 1542  %constinteger LEA=78, PEA=55, CLR=52, DBRA=81, JSR=56,
 1543+               LINK=72, UNLK=73, RTS=68,
 1544+               MOVEM=100, TRAPI=101, DC=102
 1545  
 1546  !Machine-code operand types
 1547  ![EA needs to be further distinguished]
 1548  %constinteger SHIFT=32
 1549  %constinteger REG=1, AREG=2, IREG=3, QUICK=4, MQUICK=5
 1550  %constinteger EA=6, RWEA=7, WEA=8
 1551  %constinteger IMM=9, TQUICK=10, REL=11, LONGREL=12
 1552  %constinteger QREG=13, POSTAREG=14, QEA=15
 1553  %constinteger REVEA=16, XIMM=17, DATA=18, PREAREG=19, QPRE=20
 1554  %constinteger EXREG=21+shift
 1555  %constinteger REG9=reg+shift, QREG9=qreg+shift, IREG9=ireg+shift,
 1556+               POSTAREG9=postareg+shift,
 1557+               QUICK9=quick+shift, AREG9=areg+shift
 1558  %constinteger SIZED=1<<15, ASIZED=1<<14;  !2 spare bits
 1559  %constinteger REVERSIBLE=revea<<6+reg9+sized, MULTIPLE=ximm<<6+ea+asized
 1560  %constinteger DEFMAX=129
 1561  %constintegerarray DEF(0:defmax+defmax) =
 1562+   0,
 1563+  {MOVE} 16_0000<<16+ ea<<6+wea+shift +sized,
 1564+   'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10,
 1565+  {ADD} 16_D000<<16+ reversible,
 1566+   'a'<<25+('d'&31)<<20+('d'&31)<<15,
 1567+  {SUB} 16_9000<<16+ reversible,
 1568+   's'<<25+('u'&31)<<20+('b'&31)<<15,
 1569+  {CMP} 16_B000<<16+ ea<<6+reg9 +sized,
 1570+   'c'<<25+('m'&31)<<20+('p'&31)<<15,
 1571+  {AND} 16_C000<<16+ reversible,
 1572+   'a'<<25+('n'&31)<<20+('d'&31)<<15,
 1573+  {OR} 16_8000<<16+ reversible,
 1574+   'o'<<25+('r'&31)<<20,
 1575+  {EOR} 16_B100<<16+ reg9<<6+rwea +sized,
 1576+   'e'<<25+('o'&31)<<20+('r'&31)<<15,
 1577+  {NOT} 16_4600<<16+ rwea +sized,
 1578+   'n'<<25+('o'&31)<<20+('t'&31)<<15,
 1579+  {NEG} 16_4400<<16+ rwea +sized,
 1580+   'n'<<25+('e'&31)<<20+('g'&31)<<15,
 1581+  {LSL} 16_E108<<16+ qreg9<<6+reg +sized,
 1582+   'l'<<25+('s'&31)<<20+('l'&31)<<15,
 1583+  {LSR} 16_E008<<16+ qreg9<<6+reg +sized,
 1584+   'l'<<25+('s'&31)<<20+('r'&31)<<15,
 1585+  {MULS} 16_C1C0<<16+ ea<<6+reg9,
 1586+   'm'<<25+('u'&31)<<20+('l'&31)<<15+('s'&31)<<10,
 1587+  {DIVS} 16_81C0<<16+ ea<<6+reg9,
 1588+   'd'<<25+('i'&31)<<20+('v'&31)<<15+('s'&31)<<10,
 1589+  {MULU} 16_C0C0<<16+ ea<<6+reg9,
 1590+   'm'<<25+('u'&31)<<20+('l'&31)<<15+('u'&31)<<10,
 1591+  {DIVU} 16_80C0<<16+ ea<<6+reg9,
 1592+   'd'<<25+('i'&31)<<20+('v'&31)<<15+('u'&31)<<10,
 1593+  {BRA} 16_6000<<16+ rel,
 1594+   'b'<<25+('r'&31)<<20+('a'&31)<<15,
 1595+  {BSR} 16_6100<<16+ rel,
 1596+   'b'<<25+('s'&31)<<20+('r'&31)<<15,
 1597+  {BHI} 16_6200<<16+ rel,
 1598+   'b'<<25+('h'&31)<<20+('i'&31)<<15,
 1599+  {BLS} 16_6300<<16+ rel,
 1600+   'b'<<25+('l'&31)<<20+('s'&31)<<15,
 1601+  {BCC} 16_6400<<16+ rel,
 1602+   'b'<<25+('c'&31)<<20+('c'&31)<<15,
 1603+  {BCS} 16_6500<<16+ rel,
 1604+   'b'<<25+('c'&31)<<20+('s'&31)<<15,
 1605+  {BNE} 16_6600<<16+ rel,
 1606+   'b'<<25+('n'&31)<<20+('e'&31)<<15,
 1607+  {BEQ} 16_6700<<16+ rel,
 1608+   'b'<<25+('e'&31)<<20+('q'&31)<<15,
 1609+  {BVC} 16_6800<<16+ rel,
 1610+   'b'<<25+('v'&31)<<20+('c'&31)<<15,
 1611+  {BVS} 16_6900<<16+ rel,
 1612+   'b'<<25+('v'&31)<<20+('s'&31)<<15,
 1613+  {BPL} 16_6A00<<16+ rel,
 1614+   'b'<<25+('p'&31)<<20+('l'&31)<<15,
 1615+  {BMI} 16_6B00<<16+ rel,
 1616+   'b'<<25+('m'&31)<<20+('i'&31)<<15,
 1617+  {BGE} 16_6C00<<16+ rel,
 1618+   'b'<<25+('g'&31)<<20+('e'&31)<<15,
 1619+  {BLT} 16_6D00<<16+ rel,
 1620+   'b'<<25+('l'&31)<<20+('t'&31)<<15,
 1621+  {BGT} 16_6E00<<16+ rel,
 1622+   'b'<<25+('g'&31)<<20+('t'&31)<<15,
 1623+  {BLE} 16_6F00<<16+ rel,
 1624+   'b'<<25+('l'&31)<<20+('e'&31)<<15,
 1625+  {ASL} 16_E100<<16+ qreg9<<6+reg +sized,
 1626+   'a'<<25+('s'&31)<<20+('l'&31)<<15,
 1627+  {ASR} 16_E000<<16+ qreg9<<6+reg +sized,
 1628+   'a'<<25+('s'&31)<<20+('r'&31)<<15,
 1629+  {ROL} 16_E118<<16+ qreg9<<6+reg +sized,
 1630+   'r'<<25+('o'&31)<<20+('l'&31)<<15,
 1631+  {ROR} 16_E018<<16+ qreg9<<6+reg +sized,
 1632+   'r'<<25+('o'&31)<<20+('r'&31)<<15,
 1633+  {MOVEQ} 16_7000<<16+ mquick<<6+reg9,
 1634+   'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('q'&31)<<5,
 1635+  {ADDQ} 16_5000<<16+ quick9<<6+rwea +sized,
 1636+   'a'<<25+('d'&31)<<20+('d'&31)<<15+('q'&31)<<10,
 1637+  {SUBQ} 16_5100<<16+ quick9<<6+rwea +sized,
 1638+   's'<<25+('u'&31)<<20+('b'&31)<<15+('q'&31)<<10,
 1639+  {MOVEA} 16_3040<<16+ ea<<6+areg9 +asized,
 1640+   'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('a'&31)<<5,
 1641+  {ADDA} 16_D0C0<<16+ ea<<6+areg9 +asized,
 1642+   'a'<<25+('d'&31)<<20+('d'&31)<<15+('a'&31)<<10,
 1643+  {SUBA} 16_90C0<<16+ ea<<6+areg9 +asized,
 1644+   's'<<25+('u'&31)<<20+('b'&31)<<15+('a'&31)<<10,
 1645+  {CMPA} 16_B0C0<<16+ ea<<6+areg9 +asized,
 1646+   'c'<<25+('m'&31)<<20+('p'&31)<<15+('a'&31)<<10,
 1647+  {CMPM} 16_B108<<16+ postareg<<6+postareg9,
 1648+   'c'<<25+('m'&31)<<20+('p'&31)<<15+('m'&31)<<10,
 1649+  {ADDI} 16_0600<<16+ imm<<6+rwea +sized,
 1650+   'a'<<25+('d'&31)<<20+('d'&31)<<15+('i'&31)<<10,
 1651+  {SUBI} 16_0400<<16+ imm<<6+rwea +sized,
 1652+   's'<<25+('u'&31)<<20+('b'&31)<<15+('i'&31)<<10,
 1653+  {CMPI} 16_0C00<<16+ imm<<6+ea +sized,
 1654+   'c'<<25+('m'&31)<<20+('p'&31)<<15+('i'&31)<<10,
 1655+  {ANDI} 16_0200<<16+ imm<<6+rwea +sized,
 1656+   'a'<<25+('n'&31)<<20+('d'&31)<<15+('i'&31)<<10,
 1657+  {ORI} 16_0000<<16+ imm<<6+rwea +sized,
 1658+   'o'<<25+('r'&31)<<20+('i'&31)<<15,
 1659+  {EORI} 16_0A00<<16+ imm<<6+rwea +sized,
 1660+   'e'<<25+('o'&31)<<20+('r'&31)<<15+('i'&31)<<10,
 1661+  {ROXL} 16_E110<<16+ qreg9<<6+reg +sized,
 1662+   'r'<<25+('o'&31)<<20+('x'&31)<<15+('l'&31)<<10,
 1663+  {ROXR} 16_E010<<16+ qreg9<<6+reg +sized,
 1664+   'r'<<25+('o'&31)<<20+('x'&31)<<15+('r'&31)<<10,
 1665+  {CLR} 16_4200<<16+ wea +sized,
 1666+   'c'<<25+('l'&31)<<20+('r'&31)<<15,
 1667+  {NEGX} 16_4000<<16+ rwea +sized,
 1668+   'n'<<25+('e'&31)<<20+('g'&31)<<15+('x'&31)<<10,
 1669+  {NBCD} 16_4800<<16+ rwea,
 1670+   'n'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
 1671+  {PEA} 16_4840<<16+ ea,
 1672+   'p'<<25+('e'&31)<<20+('a'&31)<<15,
 1673+  {JSR} 16_4E80<<16+ ea,
 1674+   'j'<<25+('s'&31)<<20+('r'&31)<<15,
 1675+  {JMP} 16_4EC0<<16+ ea,
 1676+   'j'<<25+('m'&31)<<20+('p'&31)<<15,
 1677+  {TAS} 16_4AC0<<16+ rwea,
 1678+   't'<<25+('a'&31)<<20+('s'&31)<<15,
 1679+  {TST} 16_4A00<<16+ ea +sized,
 1680+   't'<<25+('s'&31)<<20+('t'&31)<<15,
 1681+  {ABCD} 16_C100<<16+ qpre<<6+reg9,
 1682+   'a'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
 1683+  {SBCD} 16_8100<<16+ qpre<<6+reg9,
 1684+   's'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
 1685+  {ADDX} 16_D100<<16+ qpre<<6+reg9 +sized,
 1686+   'a'<<25+('d'&31)<<20+('d'&31)<<15+('x'&31)<<10,
 1687+  {SUBX} 16_9100<<16+ qpre<<6+reg9 +sized,
 1688+   's'<<25+('u'&31)<<20+('b'&31)<<15+('x'&31)<<10,
 1689+  {NOP} 16_4E71<<16,
 1690+   'n'<<25+('o'&31)<<20+('p'&31)<<15,
 1691+  {RESET} 16_4E70<<16,
 1692+   'r'<<25+('e'&31)<<20+('s'&31)<<15+('e'&31)<<10+('t'&31)<<5,
 1693+  {RTE} 16_4E73<<16,
 1694+   'r'<<25+('t'&31)<<20+('e'&31)<<15,
 1695+  {RTR} 16_4E77<<16,
 1696+   'r'<<25+('t'&31)<<20+('r'&31)<<15,
 1697+  {RTS} 16_4E75<<16,
 1698+   'r'<<25+('t'&31)<<20+('s'&31)<<15,
 1699+  {STOP} 16_4E72<<16 +imm,
 1700+   's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
 1701+  {TRAPV} 16_4E76<<16,
 1702+   't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('v'&31)<<5,
 1703+  {TRAP} 16_4E40<<16+ tquick,
 1704+   't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
 1705+  {LINK} 16_4E50<<16+ imm<<6+areg,
 1706+   'l'<<25+('i'&31)<<20+('n'&31)<<15+('k'&31)<<10,
 1707+  {UNLK} 16_4E58<<16+ areg,
 1708+   'u'<<25+('n'&31)<<20+('l'&31)<<15+('k'&31)<<10,
 1709+  {SWAP} 16_4840<<16+ reg,
 1710+   's'<<25+('w'&31)<<20+('a'&31)<<15+('p'&31)<<10,
 1711+  {EXTW} 16_4880<<16+ reg,
 1712+   'e'<<25+('x'&31)<<20+('t'&31)<<15+('w'&31)<<10,
 1713+  {EXTL} 16_48C0<<16+ reg,
 1714+   'e'<<25+('x'&31)<<20+('t'&31)<<15+('l'&31)<<10,
 1715+  {EXG} 16_C140<<16+ exreg<<6+reg,
 1716+   'e'<<25+('x'&31)<<20+('g'&31)<<15,
 1717+  {LEA} 16_41C0<<16+ qea<<6+areg9,
 1718+   'l'<<25+('e'&31)<<20+('a'&31)<<15,
 1719+  {CHK} 16_4180<<16+ ea<<6+reg9,
 1720+   'c'<<25+('h'&31)<<20+('k'&31)<<15,
 1721+  {DBXX} 16_50C8<<16+ reg<<6+longrel,
 1722+   'd'<<25+('b'&31)<<20+('x'&31)<<15+('x'&31)<<10,
 1723+  {DBRA} 16_51C8<<16+ reg<<6+longrel,
 1724+   'd'<<25+('b'&31)<<20+('r'&31)<<15+('a'&31)<<10,
 1725+  {DBHI} 16_52C8<<16+ reg<<6+longrel,
 1726+   'd'<<25+('b'&31)<<20+('h'&31)<<15+('i'&31)<<10,
 1727+  {DBLS} 16_53C8<<16+ reg<<6+longrel,
 1728+   'd'<<25+('b'&31)<<20+('l'&31)<<15+('s'&31)<<10,
 1729+  {DBCC} 16_54C8<<16+ reg<<6+longrel,
 1730+   'd'<<25+('b'&31)<<20+('c'&31)<<15+('c'&31)<<10,
 1731+  {DBCS} 16_55C8<<16+ reg<<6+longrel,
 1732+   'd'<<25+('b'&31)<<20+('c'&31)<<15+('s'&31)<<10,
 1733+  {DBNE} 16_56C8<<16+ reg<<6+longrel,
 1734+   'd'<<25+('b'&31)<<20+('n'&31)<<15+('e'&31)<<10,
 1735+  {DBEQ} 16_57C8<<16+ reg<<6+longrel,
 1736+   'd'<<25+('b'&31)<<20+('e'&31)<<15+('q'&31)<<10,
 1737+  {DBVC} 16_58C8<<16+ reg<<6+longrel,
 1738+   'd'<<25+('b'&31)<<20+('v'&31)<<15+('c'&31)<<10,
 1739+  {DBVS} 16_59C8<<16+ reg<<6+longrel,
 1740+   'd'<<25+('b'&31)<<20+('v'&31)<<15+('s'&31)<<10,
 1741+  {DBPL} 16_5AC8<<16+ reg<<6+longrel,
 1742+   'd'<<25+('b'&31)<<20+('p'&31)<<15+('l'&31)<<10,
 1743+  {DBMI} 16_5BC8<<16+ reg<<6+longrel,
 1744+   'd'<<25+('b'&31)<<20+('m'&31)<<15+('i'&31)<<10,
 1745+  {DBGE} 16_5CC8<<16+ reg<<6+longrel,
 1746+   'd'<<25+('b'&31)<<20+('g'&31)<<15+('e'&31)<<10,
 1747+  {DBLT} 16_5DC8<<16+ reg<<6+longrel,
 1748+   'd'<<25+('b'&31)<<20+('l'&31)<<15+('t'&31)<<10,
 1749+  {DBGT} 16_5EC8<<16+ reg<<6+longrel,
 1750+   'd'<<25+('b'&31)<<20+('g'&31)<<15+('t'&31)<<10,
 1751+  {DBLE} 16_5FC8<<16+ reg<<6+longrel,
 1752+   'd'<<25+('b'&31)<<20+('l'&31)<<15+('e'&31)<<10,
 1753+  {BCHG} 16_0140<<16+ ireg9<<6+rwea,
 1754+   'b'<<25+('c'&31)<<20+('h'&31)<<15+('g'&31)<<10,
 1755+  {BCLR} 16_0180<<16+ ireg9<<6+wea,
 1756+   'b'<<25+('c'&31)<<20+('l'&31)<<15+('r'&31)<<10,
 1757+  {BSET} 16_01C0<<16+ ireg9<<6+wea,
 1758+   'b'<<25+('s'&31)<<20+('e'&31)<<15+('t'&31)<<10,
 1759+  {BTST} 16_0100<<16+ ireg9<<6+ea,
 1760+   'b'<<25+('t'&31)<<20+('s'&31)<<15+('t'&31)<<10,
 1761+  {MOVEM} 16_4880<<16+ multiple,
 1762+   'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('m'&31)<<5,
 1763+  {TRAPI} 16_4E40<<16+ imm<<6+tquick,
 1764+   't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('i'&31)<<5,
 1765+  {DC}         data,
 1766+      'd'<<25+('c'&31)<<20,
 1767+  {ST} 16_50C0<<16+ wea,
 1768+   's'<<25+('t'&31)<<20,
 1769+  {SF} 16_51C0<<16+ wea,
 1770+   's'<<25+('f'&31)<<20,
 1771+  {SHI} 16_52C0<<16+ wea,
 1772+   's'<<25+('h'&31)<<20+('i'&31)<<15,
 1773+  {SLS} 16_53C0<<16+ wea,
 1774+   's'<<25+('l'&31)<<20+('s'&31)<<15,
 1775+  {SCC} 16_54C0<<16+ wea,
 1776+   's'<<25+('c'&31)<<20+('c'&31)<<15,
 1777+  {SCS} 16_55C0<<16+ wea,
 1778+   's'<<25+('c'&31)<<20+('s'&31)<<15,
 1779+  {SNE} 16_56C0<<16+ wea,
 1780+   's'<<25+('n'&31)<<20+('e'&31)<<15,
 1781+  {SEQ} 16_57C0<<16+ wea,
 1782+   's'<<25+('e'&31)<<20+('q'&31)<<15,
 1783+  {SVC} 16_58C0<<16+ wea,
 1784+   's'<<25+('v'&31)<<20+('c'&31)<<15,
 1785+  {SVS} 16_59C0<<16+ wea,
 1786+   's'<<25+('v'&31)<<20+('s'&31)<<15,
 1787+  {SPL} 16_5AC0<<16+ wea,
 1788+   's'<<25+('p'&31)<<20+('l'&31)<<15,
 1789+  {SMI} 16_5BC0<<16+ wea,
 1790+   's'<<25+('m'&31)<<20+('i'&31)<<15,
 1791+  {SGE} 16_5CC0<<16+ wea,
 1792+   's'<<25+('g'&31)<<20+('e'&31)<<15,
 1793+  {SLT} 16_5DC0<<16+ wea,
 1794+   's'<<25+('l'&31)<<20+('t'&31)<<15,
 1795+  {SGT} 16_5EC0<<16+ wea,
 1796+   's'<<25+('g'&31)<<20+('t'&31)<<15,
 1797+  {SLE} 16_5FC0<<16+ wea,
 1798+   's'<<25+('l'&31)<<20+('e'&31)<<15,
 1799+  {MTCCR} 16_44C0<<16+ ea<<6,
 1800+   'm'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 1801+  {MTSR} 16_46C0<<16+ ea<<6,
 1802+   'm'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 1803+  {MFSR} 16_40C0<<16+ wea,
 1804+   'm'<<25+('f'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 1805+  {MTUSP} 16_4E60<<16+ areg,
 1806+   'm'<<25+('t'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
 1807+  {MFUSP} 16_4E68<<16+ areg,
 1808+   'm'<<25+('f'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
 1809+  {ATCCR} 16_023C<<16+ imm,
 1810+   'a'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 1811+  {ATSR} 16_027C<<16+ imm,
 1812+   'a'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 1813+  {ETCCR} 16_0A3C<<16+ imm,
 1814+   'e'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 1815+  {ETSR} 16_0A7C<<16+ imm,
 1816+   'e'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
 1817+  {OTCCR} 16_003C<<16+ imm,
 1818+   'o'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
 1819+  {OTSR} 16_007C<<16+ imm,
 1820+   'o'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10
 1821  
 1822  {?}%routine PUT OPCODE(%integer op)
 1823  {?}  put mnemonic(def(op+op))
 1824  {?}%end
 1825  
 1826  %routine STORE(%integer v,f)
 1827  !$IF VAX
 1828  {  v = v&16_FFFF;  v = v!sign16 %if v&sign16 # 0
 1829  !$FINISH
 1830    prog(pc) <- v;  pflag(pc) = f;  pc = pc+1
 1831  %end
 1832  
 1833  %routine MAKE ROOM(%integer size)
 1834  %integer newbase,newlim
 1835    size = (size+127)&(\127)
 1836    ownbase = ownbase-size
 1837    croak("Program too big") %if ownbase <= cad
 1838    newbase = ownbase;  newlim = newbase+ownad
 1839    %cycle
 1840      final(newbase) = final(newbase+size)
 1841      newbase = newbase+1
 1842    %repeat %until newbase >= newlim
 1843  %end
 1844  
 1845  %routine FILL CODE(%integer n)
 1846  %integer i
 1847    i = cad;  cad = cad+n
 1848    %while n > 0 %cycle
 1849      final(i) = 16_80;  i = i+1;  n = n-1
 1850    %repeat
 1851  %end
 1852  %routine FILL OWN(%integer n)
 1853  %integer i
 1854    make room(n)
 1855    i = ownbase+ownad;  ownad = ownad+n
 1856    %while n > 0 %cycle
 1857      final(i) = 16_80;  i = i+1;  n = n-1
 1858    %repeat
 1859  %end
 1860  
 1861  %routine SET CODE WORD(%integer v)
 1862  !$IF VAX (works irrespective of host byte sex)
 1863  {  final(cad) <- v>>8;  final(cad+1) <- v
 1864  !$IF APM (for efficiency)
 1865    shortinteger(final0+cad) <- v
 1866  !$FINISH
 1867    cad = cad+2
 1868  %end
 1869  
 1870  %integer%fn CODE WORD(%integer cad)
 1871  !$IF VAX (works irrespective of host byte sex)
 1872  {  %result = final(cad)<<8+final(cad+1)
 1873  !$IF APM (for efficiency)
 1874    %result = shortinteger(final0+cad)
 1875  !$FINISH
 1876  %end
 1877  
 1878  %routine SET CODE LONGWORD(%integer v)
 1879    set code word(v>>16);  set code word(v)
 1880  %end
 1881  
 1882  %routine SET OWN WORD(%integer v)
 1883    make room(2) %if ownbase+ownad > finalbound
 1884  !$IF VAX
 1885  {  final(ownbase+ownad) <- v>>8;  final(ownbase+ownad+1) <- v
 1886  !$IF APM
 1887    shortinteger(final0+ownbase+ownad) <- v
 1888  !$FINISH
 1889    ownad = ownad+2
 1890  %end
 1891  
 1892  %routine EXTEND STACK(%integer delta)
 1893    c_sp = c_sp-delta
 1894    %if c_sp < c_stack %start
 1895      c_stack = c_sp
 1896      c_totstack = c_stack %if c_stack < c_totstack
 1897    %finish
 1898  %end
 1899  
 1900  %routine PLANT(%integer op,y,x)
 1901  !Basic code planting procedure
 1902  ! OP is an index to the array defining op-codes
 1903  !  (it can be flagged to force SIZE)
 1904  ! For unary operations the operand is given by X (Y zero)
 1905  ! For binary operations the operands are Y (source) and X (dest)
 1906  %integer OPCODE,PC1,I,F,EXTWORD,INFO,KIND,MODE,MODEX,SIZE
 1907  %record(identinfo)%name DX,DY
 1908  %switch S(0:21)
 1909  %constbytearray SIZESYM(0:3) = 'L','B','W','?'
 1910  
 1911  %integer%fn NONLOCAL(%integer l)
 1912  %integer r
 1913    %result = mb %if l = outerlevel
 1914    hold(l)_status = hold(l)_status!globbed %if l # level
 1915    %result = f1 %if l = outerlevel+1
 1916    r = maxareg
 1917    %cycle
 1918      %result = r %if c_reg_content(r) = d7+l;  ![unique]
 1919      r = r-1
 1920    %repeat %until r < a0
 1921  ![not good enough: 1. may need two
 1922  !                  2. FREE updated elsewhere without regard to this]
 1923    r = maxareg
 1924    %while a0b<<(r-a0)&free = 0 %cycle
 1925      fault(plexerr) %and %exit %if r = a0
 1926      r = r-1
 1927    %repeat
 1928    c_reg_content(r) = d7+l
 1929    dtsprel_mode = globalmode;  dtsprel_val = l<<2
 1930    plant(move,lablim+2,r)
 1931    %result = r
 1932  %end
 1933  
 1934  %constinteger MOVEQ=36, ADDQ=37, MOVEA=39,
 1935+               ADDA=40, ADDI=44
 1936  
 1937    %if x > 0 %start
 1938      intern(1) %and %return %if x >= explim
 1939      dx == dict(x)
 1940      modex = dx_mode
 1941      %if modex >= framemode %and modex # c_mode %c
 1942+     %and modex&2_111000 # 2_111000 %start
 1943        modex = nonlocal(modex&7)-a0+(modex&(7<<3))
 1944      %finish
 1945    %finish %else modex = litmode %and dx == dint
 1946    %if y > 0 %start
 1947      intern(1) %and %return %if y >= explim
 1948      dy == dict(y)
 1949      mode = dy_mode
 1950      %if mode >= framemode %and mode # c_mode %c
 1951+     %and mode&2_111000 # 2_111000 %start
 1952        mode = nonlocal(mode&7)-a0+(mode&(7<<3))
 1953      %finish
 1954    %finish %else mode = litmode %and dy == dint
 1955    size = op>>8;  op = op&255
 1956    %if op = move %start
 1957      %if modex&2_111000 = 0 %start;  !D
 1958        op = moveq %if y <= 0 %and y >= litmite %and size&3 = 0
 1959      %finish %else %if modex&2_110000 = 0 %start;   !A
 1960        op = movea
 1961      %finish
 1962    %finish %else %if op <= cmp %start
 1963      %if op < cmp %and y < 0 %and y >= litquick %and y&1 = 0 %c
 1964+     %then op=op+(addq-add) {ADDQ,SUBQ} %c
 1965+     %else %if modex&2_111000 = aregmode %c
 1966+     %then op=op+(adda-add) {ADDA,SUBA,CMPA} %c
 1967+     %else %if y <= 0 %c
 1968+     %then op=op+(addi-add) {ADDI,SUBI,CMPI}
 1969    %finish %else %if op <= eor %start
 1970      op = op+(addi-add) %if y <= 0 {ANDI,ORI,EORI}
 1971    %finish
 1972    info = def(op+op-1)
 1973    opcode = info>>16
 1974    %if info&sized # 0 %start;  !data size required
 1975      size = 4 %if size = 0
 1976      %if op = move %start
 1977        %if size = 4 %start
 1978          opcode = opcode+16_2000
 1979        %finish %else %if size = 2 %start
 1980          opcode = opcode+16_3000
 1981        %else
 1982          opcode = opcode+16_1000
 1983        %finish
 1984      %else
 1985        %if size = 4 %start
 1986          opcode = opcode+16_80
 1987        %finish %else %if size = 2 %start
 1988          opcode = opcode+16_40
 1989        %finish
 1990      %finish
 1991    %finish %else %if info&asized # 0 %start;  !areg size required
 1992      fault(sizerr) %if size = 1
 1993      %if op # movem %start
 1994        %if size = 0 %start
 1995          size = 4 %unless y <= 0 %and is short(litval(y))=TRUE
 1996        %finish
 1997        %if size = 4 %start
 1998          %if op = movea %then opcode = opcode!!16_1000 %c
 1999+         %else opcode = opcode+16_0100
 2000        %finish
 2001      %else;  !MOVEM
 2002        size = 4 %if size = 0
 2003        opcode = opcode+16_0040 %if size = 4
 2004      %finish
 2005    %finish
 2006  {?}  %if control&codelist # 0 %and control&list # 0 %start
 2007  {?}    print line %if length(rep) >= 4
 2008  {?}    put sym(codeflag);  spaces(4-length(rep))
 2009  {?}    put opcode(op)
 2010  {?}    %if size # 0 %start
 2011  {?}      put sym('.')
 2012  {?}      put sym(sizesym(size&3))
 2013  {?}    %finish
 2014  {?}    spaces(12-length(rep))
 2015  {?}    %if info&(63<<6) # 0 %start
 2016  {?}      put operand(y)
 2017  {?}      put sym(',') %if info&63 # 0
 2018  {?}    %finish
 2019  {?}    put operand(x) %if info&63 # 0
 2020  {?}    spaces(33-length(rep));  put sym(':')
 2021  {?}  %finish
 2022  
 2023    pc1 = pc;  pflag(pc1) = c_shorts;  !op-code word
 2024    pc = pc+1
 2025    croak("Code space exhausted") %if pc >= swpc-8
 2026    kind = info>>6
 2027  again:
 2028    ->s(kind&31)
 2029  s(0):
 2030  next:
 2031    kind = info
 2032    %if kind # 0 %start
 2033      dy == dx;  y = x;  mode = modex
 2034      info = 0
 2035      ->again
 2036    %finish
 2037  !
 2038  !$IF VAX
 2039  {  opcode = opcode!sign16 %if opcode&sign16 # 0
 2040  !$FINISH
 2041    prog(pc1) <- opcode
 2042  {?}  %if control&codelist # 0 %and control&list # 0 %start
 2043  {?}    %cycle
 2044  {?}      put sym(' ')
 2045  {?}      put hex(prog(pc1))
 2046  {?}      pc1 = pc1+1
 2047  {?}    %repeat %until pc1 >= pc
 2048  {?}    print line
 2049  {?}  %finish
 2050    %return
 2051  
 2052  !Set flag value for PC-relative reference
 2053  ! distinguishing GLOBAL (const access), INDIRECT GLOBAL (procedure),
 2054  ! and LOCAL (label) -- the last further distinguished according to
 2055  ! whether the instruction permits shortening
 2056  %routine PCREL(%integer shorten)
 2057    %if dy_mode = labmode %start
 2058      f = jump;  f = longjump %if shorten = 0
 2059      %if extword > 0 %start;  !label defined
 2060        %if shorten # 0 %and (extword-pflag(extword)-pc+c_shorts)<<1 >= -128 %start
 2061          %if c_shorts = 255 %start
 2062            zaps = zaps+100
 2063          %else
 2064            shorts = shorts+1;  c_shorts = c_shorts+1
 2065            f = shortjump
 2066          %finish
 2067        %finish
 2068      %else
 2069        extword = -extword
 2070        dy_val = -pc
 2071      %finish
 2072    %finish %else %if dy_mode = procmode %start;  !procedure
 2073      f = indglobal;  extword = y;  !rather than DY_VAL
 2074    %finish %else %if dy_mode = constmode %start;  !constant data ref
 2075      f = global
 2076      f = f+1 %if extword < 0
 2077      f = f+2 %if extword > 65535
 2078    %finish %else %if dy_mode # pcmode %start
 2079      fault(moperr)
 2080    %finish
 2081  %end
 2082  
 2083  s(qea):  !LEA
 2084    -> ea0 %unless mode&63 = x-(a0-indexmode) %and dy_val&255 = 0
 2085    !  LEA 0(Ax,Dy)  =>  ADDA Dy,Ax
 2086    opcode = 16_D1C0+dy_val>>12&15
 2087    -> next
 2088  
 2089  s(wea):
 2090    dy_flags = dy_flags!(mflag!wflag)
 2091    -> wea1
 2092  s(rwea):  ![for our purposes, read&write counts as neither]
 2093    dy_flags = dy_flags!mflag
 2094  wea1:
 2095    -> err %if y <= 0 %or mode&63 >= pcmode
 2096    -> ea1
 2097  s(revea):  !reversible cases (EA,REG or REG,EA)
 2098    %if modex&2_111000 # 0 %start;  !dest not D
 2099      kind = shift;  info = rwea
 2100      opcode = opcode!!16_0100
 2101      ->sreg
 2102    %finish
 2103  s(ea): ea0:
 2104    %if y <= 0 %start
 2105      opcode = opcode+litmode;  !immediate
 2106      ->simm
 2107    %finish
 2108    %if dy_flags&(ext+spec+rflag+wflag) = ext+spec %c
 2109+   %and dy_flags&proc # 0 %start
 2110      ! Create transfer vector for external procedure
 2111      fill own(1) %if ownad&1 # 0
 2112      dy_val = ownad
 2113      set own word(16_207C+(mb-a0)<<9);  !MOVE.L #xxxxxxxx,MB
 2114      set own word(0);  set own word(0)
 2115      set own word(16_4EF9);  !JMP xxxxxxxx
 2116      set own word(0);  set own word(0)
 2117    %finish
 2118    %if (op = lea %or op = pea) %and mode&63 # pcmode %start
 2119      !taking address: might read or write
 2120      dy_flags = dy_flags!(mflag+rflag+wflag)
 2121      ->err %if mode&2_111000 < aregmode+indir
 2122    %else
 2123      dy_flags = dy_flags!(mflag+rflag)
 2124    %finish
 2125  ea1:
 2126    extword = dy_val
 2127    %if mode = c_mode %start;  !local
 2128      mode = dispmode+7;  extword = extword-c_sp;  !convert to use SP
 2129      %if extword < 0 %start
 2130        intern(4) %if extword < -4
 2131        mode = aregmode+pre+7
 2132        extend stack(-extword)
 2133        extword = 0
 2134      %finish
 2135    %finish
 2136    mode = mode&63;   !strip extra flags
 2137    %if mode >= dispmode %start;  !+extra
 2138      f = 0
 2139      %if mode = pcmode %start
 2140        pcrel(0)
 2141      %finish
 2142      %if mode <= dispmode+7 %start
 2143        %if extword = 0 %start
 2144          ! Premode (just created) or Dispmode (=>Indmode)
 2145          mode = mode+(aregmode+indir-dispmode) %if mode >= dispmode
 2146        %else
 2147          fault(dreacherr) %unless -32768 <= extword <= 32767
 2148          store(extword,f)
 2149        %finish
 2150      %else
 2151        mode = absmode+1 %if mode = absmode %and %not is short(extword)=TRUE
 2152        store(extword>>16,0) %if mode = absmode+1
 2153        store(extword,f)
 2154      %finish
 2155    %finish
 2156    mode = ((mode&7)<<3 + mode>>3)<<6 %if kind&shift # 0
 2157    opcode = opcode+mode
 2158    ->next
 2159  
 2160  s(exreg&31):  !EXG (D,D / A,A / D,A)
 2161    %if mode&2_111000 = 0 %start;  !D
 2162      %if modex&2_111000 # 0 %start;  !not D
 2163        opcode = opcode!!16_C8;  info = areg
 2164      %finish
 2165      -> sreg
 2166    %finish
 2167    opcode = opcode+8;  info = areg
 2168    -> sareg
 2169  s(qpre):
 2170    -> sreg %if mode&2_111000 = 0;  !D
 2171    opcode = opcode+8;  info = preareg+shift
 2172  s(preareg):
 2173    mode = mode+(post-pre)
 2174  s(postareg):
 2175    mode = mode-post
 2176  s(areg): sareg:
 2177    mode = mode-8
 2178  s(reg): sreg:
 2179    -> err %unless mode&2_111000 = 0
 2180    mode = mode&7
 2181    mode = mode<<9 %if kind&shift # 0
 2182    opcode = opcode+mode
 2183    ->next
 2184  
 2185  s(qreg):  !Shift formats -- quick,Dx / Dy,Dx / 1,<ea> (W)
 2186    opcode = opcode+16_20 %and ->sreg %if y > 0
 2187    %if y = one %and size = 2 %and modex&2_111000 # 0 %start
 2188      opcode = opcode!!16_290
 2189      ->next
 2190       %finish
 2191  s(quick):
 2192    -> err %if y >= 0
 2193    y = litval(y)
 2194    ->err %unless y <= 8
 2195    opcode = opcode+(y&7)<<9;  !(always aligned to bit9)
 2196    ->next
 2197  
 2198  s(tquick):  !(TRAP)
 2199    -> err %unless -30 <= y %and y&1 = 0;  !{0<=}litval(y)<=15
 2200  s(mquick):
 2201    ->err %unless y <= 0 %and y >= litmite
 2202    y = litval(y)
 2203    opcode = opcode+y&255
 2204    ->next
 2205  s(rel):
 2206    ->s(mquick) %if y <= 0 %and y >= litmite
 2207  s(longrel):
 2208    ->simm %if y <= 0
 2209    dy_flags = dy_flags!rflag
 2210    extword = dy_val
 2211    f = 0
 2212    pcrel(longrel-kind&31)
 2213    store(extword,f)
 2214    ->next
 2215  
 2216  s(ireg):  !immediate or reg
 2217    ->sreg %if y > 0
 2218    opcode = opcode!!16_900
 2219  s(imm):
 2220    ->err %if y > 0
 2221  simm:
 2222    y = litval(y)
 2223    store(y>>16,0) %if size = 4
 2224  put:
 2225    store(y,0)
 2226    ->next
 2227  s(ximm):  !MOVEM (IMM,EA or EA,IMM)
 2228    %if y > 0 %start;  !EA,IMM
 2229      opcode = opcode!!16_0400
 2230      i = x;  x = y;  y = i
 2231      dx == dy;  modex = mode
 2232    %finish
 2233    y = litval(y)
 2234    %if prea0 <= x <= prea7 %start;  !-(SP)
 2235      i = 0;  !Reverse bits
 2236      i = i<<1+y&1 %and y = y>>1 %for extword = 1,1,16
 2237      y = i
 2238    %finish
 2239    ->put
 2240  s(data):
 2241    -> err %if y <= 0
 2242    -> err %if mode # absmode
 2243    opcode = dy_val
 2244    ->next
 2245  err:
 2246    fault(moperr)
 2247    ->next
 2248  %end;  !plant
 2249  
 2250  %routine PLANTLIT(%integer op,v,x)
 2251    %if v >= 0 %start
 2252      %if v > smallmax %then litstore(litmax) = v %and v = litmax %c
 2253+     %else v = -(v<<1)
 2254    %else
 2255      %if v < smallmin %then litstore(litmax) = v %and v = litmax %c
 2256+     %else v = v<<1+1
 2257    %finish
 2258    plant(op,v,x)
 2259  %end
 2260  
 2261  %routine PLANTLIT2(%integer op,y,v)
 2262    %if v >= 0 %start
 2263      %if v > smallmax %then litstore(litmax) = v %and v = litmax %c
 2264+     %else v = -(v<<1)
 2265    %else
 2266      %if v < smallmin %then litstore(litmax) = v %and v = litmax %c
 2267+     %else v = v<<1+1
 2268    %finish
 2269    plant(op,y,v)
 2270  %end
 2271  
 2272  %routine ALIGN(%integername AD, %integer size)
 2273  !Impose alignment requirements on address AD for
 2274  ! operand of length SIZE
 2275  !provisional basis for bit addressing
 2276  ! -- multiples of 16 on Word boundary
 2277  ! -- multiples of 8 on Byte boundary
 2278  ! -- other < 32 within one Longword
 2279  !%constinteger BITMASK=16_E0000000
 2280  !  %if size&7 = 0 %start
 2281  !    ad = (ad&(\bitmask))+1 %if ad&bitmask # 0;  !ensure on byte boundary
 2282  !    %return %if size&8 # 0
 2283  !  %else
 2284  !    %return %if size < 16
 2285  !    %return %if ad>>29+(ad&1)<<3+size <= 32
 2286  !    ad = (ad&(\bitmask))+1 %if ad&bitmask # 0
 2287  !  %finish
 2288    ad = ad+1 %if size # 1 %and ad&1 # 0
 2289  %end
 2290  
 2291  %routine ADDIMM(%integer bytes,dest)
 2292    %if bytes <= 0 %start
 2293      %return %if bytes = 0
 2294      %if bytes >= -8 %start
 2295        plantlit(sub,-bytes,dest)
 2296        %return
 2297      %finish
 2298    %finish %else %if bytes <= 8 %start
 2299      plantlit(add,bytes,dest)
 2300      %return
 2301    %finish
 2302    %if a0 <= dest <= a7 %and is short(bytes)=TRUE %start
 2303      plant(lea,tempd(dest,bytes),dest)
 2304      %return
 2305    %finish
 2306    plantlit(add,bytes,dest)
 2307  %end
 2308  
 2309  %integer%fn FREE REG(%integer rset)
 2310  %integer r,r1
 2311    r = d0;  rset = rset&free
 2312    %if rset = 0 %then fault(plexerr) %else %start
 2313      r = r+1 %and rset = rset>>1 %while rset&1 = 0
 2314      r1 = r
 2315      %while c_reg_content(r) # undef %cycle
 2316        r = r+1;  rset = rset>>1
 2317        r = r1 %and %exit %if rset = 0
 2318        r = r+1 %and rset = rset>>1 %while rset&1 = 0
 2319      %repeat
 2320      free = free-d0b<<(r-d0)
 2321    %finish
 2322    %result = r
 2323  %end
 2324  
 2325  %routine MOVE BLOCK(%integer source,dest,bytes)
 2326  !Generate code to move a fixed number of bytes
 2327  ! from SOURCE (0,reg,pre,post) to DEST (pre,post)
 2328  ! -- source & dest addresses both even if BYTES even
 2329  %integer op,f,r,pc1
 2330    op = move;  op = clr %if source = 0
 2331    %if bytes <= 16 %and bytes&1 = 0 %start
 2332      plant(op,source,dest) %and bytes = bytes-4 %while bytes >= 4
 2333      plant(op+2<<8,source,dest) %if bytes >= 2
 2334    %else;  !use loop
 2335      op = op+1<<8
 2336      %if bytes&1 = 0 %start
 2337        bytes = bytes>>1;  op = op+1<<8;  !.B -> .W
 2338        %if bytes&1 = 0 %start
 2339          bytes = bytes>>1;  op = op+2<<8;  !.W -> .L
 2340        %finish
 2341      %finish
 2342      f = free
 2343      %if bytes <= 32768 %and free&anydreg # 0 %start
 2344        r = free reg(anydreg)
 2345        plantlit(move,bytes-1,r)
 2346        pc1 = pc
 2347        plant(op,source,dest)
 2348        plantlit2(dbra,r,(pc1-pc-1)<<1)
 2349        bytes = undef
 2350      %else
 2351        r = free reg(anydreg!bregb)
 2352        plantlit(move,bytes,r)
 2353        pc1 = pc
 2354        plant(op,source,dest)
 2355        plant(sub,one,r)
 2356        plantlit2(bne,0,(pc1-pc-1)<<1)
 2357        bytes = 0
 2358      %finish
 2359      c_reg_content(r) = bytes;  free = f
 2360    %finish
 2361  %end
 2362  
 2363  %routine UPDATE SP
 2364    %return %if c_val = 0
 2365    %if c_val < 0 %start
 2366      addimm(-c_val,a7);  c_sp = c_sp-c_val
 2367    %else
 2368      %if control&assmask = 0 %then addimm(-c_val,a7) {no unass check} %c
 2369+     %else move block(d7,prea7,c_val)
 2370      extend stack(c_val)
 2371    %finish
 2372    c_val = 0
 2373  %end
 2374  
 2375  %routine GET BOUNDS(%integer t,%integername lo,hi)
 2376  ![Note: sets HI after LO -- see dummy params in VALOK] 
 2377    %if dict(t)_type = t # inttype %start;  !basetype
 2378      lo = 0;  hi = dict(t)_size
 2379    %else
 2380      %if dict(t+1)_mode # litmode %then lo = minint %c
 2381+     %else lo = dict(t+1)_val
 2382      %if dict(t+2)_mode # litmode %then hi = maxint %c
 2383+     %else hi = dict(t+2)_val
 2384    %finish
 2385  %end
 2386  
 2387  %integer%fn SIZE(%integer t)
 2388  !Storage size for given object type in bytes
 2389  ! > 0 for operand passable in register
 2390  ! < 0 otherwise
 2391  %integer s,ss,lo,hi
 2392  %record(identinfo)%name tp
 2393    tp == dict(t)
 2394    %if tp_flags&nonord = 0 %start
 2395      %result = tp_size %if tp_type # t;  !subrange
 2396      %result = 4 %if tp_type = inttype
 2397      %result = 1 %if tp_size <= 255
 2398      %result = 2
 2399    %finish
 2400    %result = tp_val %if tp_flags&cat = recy
 2401    %result = tp_size %if tp_flags&cat # arry
 2402    %result = 0 %if tp_mode >= framemode;  !dynamic bounds
 2403    s = 4;  s = size(tp_type) %if tp_flags >= 0
 2404    get bounds(tp_xtype,lo,hi)
 2405    %result = 0 %if lo = minint %or hi = maxint
 2406    ss = (hi-lo+1)*s
 2407    %result = ss %if ss <= 0
 2408    %if s = 1 %start;  !byte element size (not nec aligned)
 2409      %result = ss %if ss = 1
 2410    %else;  !word,long element size (aligned)
 2411      %result = ss %if ss <= 4
 2412    %finish
 2413    %result = -ss
 2414  %end
 2415  
 2416  %integer%fn NSIZE(%record(identinfo)%name dp)
 2417    %result = 4 %if dp_flags&(name+indirect) # 0
 2418    %result = 0 %if dp_flags&proc # 0;       ![??]
 2419    %result = size(dp_type)
 2420  %end
 2421  
 2422  %integer%fn TSIZE(%integer t)
 2423    %result = size(dict(t)_type)
 2424  %end
 2425  
 2426  %routine FORGET(%integer r)
 2427    c_reg_content(r) = undef
 2428  %end
 2429  %routine FORGET CC
 2430    c_reg_ccy = undef
 2431  %end
 2432  %routine FORGET REGS
 2433  %shortname cc
 2434    %integer i
 2435    i = maxareg
 2436    cc==c_reg_content(i)
 2437    %cycle
 2438      cc = undef
 2439      %exit %if cc == c_reg_content(d0)
 2440      i = i-1; cc==c_reg_content(i)
 2441    %repeat
 2442    c_reg_ccy = undef;  c_reg_line = -9
 2443  %end
 2444  %routine FORGET TRIPLES
 2445    litpos = litmin;  explo = explim;  oldexplo = explim
 2446  %end
 2447  %routine FORGET ALL
 2448  %integer i,j
 2449  %record(contentinfo)%name lr
 2450    forget regs
 2451    j = dictlim
 2452    %cycle
 2453      j = j+1
 2454      %exit %if j >= curlab
 2455      lr == lreg(j-dictlim)
 2456      lr_content(i) = undef %for i = d0,1,maxareg
 2457      lr_ccx = undef
 2458    %repeat
 2459    forget triples
 2460  %end
 2461  
 2462  %routine DEFINE JUMPS(%integer chain)
 2463  %integer i,j,k
 2464    chain = -chain
 2465    %return %if chain <= 0;  !no jumps to this label
 2466    c_forward = c_forward-1;  c_access = 1
 2467    %cycle
 2468      i = prog(chain)
 2469      %if pflag(chain) = jump %start;  !shortenable
 2470        j = chain-pflag(chain-1);  !adjusted jump position
 2471        k = (pc-c_shorts-j)<<1;  !displacement
 2472        %if k > 2 %and k <= 127 %start
 2473          %if c_shorts = 255 %start
 2474            zaps = zaps+100
 2475          %else
 2476            c_shorts = c_shorts+1;  shorts = shorts+1
 2477            pflag(chain) = shortjump
 2478            j = chain
 2479            %cycle
 2480              pflag(j) = pflag(j)+1 %if pflag(j) >= zeroshorts
 2481              j = j+1
 2482            %repeat %until j = pc
 2483          %finish
 2484        %finish
 2485      %finish
 2486      prog(chain) = pc
 2487      chain = i
 2488    %repeat %until chain <= 0
 2489  %end
 2490  
 2491  %routine SAVE CONTEXT(%integer l)
 2492  !Store register content associated with label L
 2493  ! (prior to generating forward branch)
 2494  %integer r
 2495  %record(contentinfo)%name lr
 2496    %return %if l-dictlim < 0    {user label}
 2497    lr == lreg(l-dictlim)
 2498    %if dict(l)_val >= 0 %start;  !first jump to this label
 2499      dict(l)_val = 0
 2500      lr = c_reg
 2501      c_forward = c_forward+1
 2502    %else
 2503      %for r = d0,1,maxareg %cycle
 2504        lr_content(r) = undef %if lr_content(r) # c_reg_content(r)
 2505      %repeat
 2506      lr_ccy = undef %if lr_ccx # c_reg_ccx %or lr_ccy # c_reg_ccy
 2507      lr_line = -9 %if lr_line # c_reg_line
 2508    %finish
 2509  %end
 2510  
 2511  %routine SRCALL(%integer x)
 2512  %routine PUT PRIM(%record(identinfo)%name DX)
 2513  !<<IMP
 2514  !* PRIMGEN marker 3
 2515  %own%short%array PRIMCODE(1:396) = 
 2516+ 16_1541,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_6578,
 2517+ 16_6365,16_6564,16_6564,16_B098,16_6E06,16_9098,16_6C10,16_D0A0,
 2518+ 16_41FA,16_FFDE,16_2400,16_7202,16_7076,16_4EF8,16_3EFA,16_4A58,
 2519+ 16_660C,16_4840,16_4A40,16_6610,16_4840,16_C0D8,16_4E75,
 2520+ 16_2F01,16_2200,16_C2E8,16_FFFE,16_6008,16_2F01,16_2200,16_4840,
 2521+ 16_C2D0,16_4841,16_C0D8,16_D081,16_221F,16_4E75,
 2522+ 16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
 2523+ 16_6162,16_6C65,16_660C,16_41FA,16_FFE8,16_7201,16_7058,16_4EF8,
 2524+ 16_3EFA,16_4E75,
 2525+ 16_0F49,16_6E76,16_616C,16_6964,16_2061,16_6464,16_7265,16_7373,
 2526+ 16_6E0C,16_41FA,16_FFEC,16_7201,16_7058,16_4EF8,16_3EFA,16_4E75,
 2527+ 16_1553,16_7461,16_636B,16_2073,16_7061,16_6365,16_2065,16_7868,
 2528+ 16_6175,16_7374,16_6564,16_D88F,16_B886,16_6C0E,16_4284,16_41FA,
 2529+ 16_FFE0,16_7203,16_7055,16_4EF8,16_3EFA,16_4284,16_4E75,
 2530+ 16_1741,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_696E,
 2531+ 16_7369,16_6465,16_206F,16_7574,16_9282,16_6F0C,16_41FA,16_FFE2,
 2532+ 16_7203,16_7055,16_4EF8,16_3EFA,16_4481,16_5281,16_4EF8,16_3EF4,
 2533+ 16_4E75,
 2534+ 16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
 2535+ 16_1811,16_9004,16_6504,16_9010,16_640C,16_41FA,16_FFE4,16_7203,
 2536+ 16_7051,16_4EF8,16_3EFA,16_1018,16_670C,16_D111,16_1398,16_4801,
 2537+ 16_5204,16_5300,16_66F6,16_2049,16_4E75,
 2538+ 16_3F00,16_7001,16_1E80,16_204F,16_548F,16_4E75,
 2539+ 16_124E,16_6F20,16_7370,16_6163,16_6520,16_666F,16_7220,16_6172,
 2540+ 16_7261,16_7980,16_5680,16_E480,16_E588,16_6D08,16_204F,16_91C0,
 2541+ 16_B1C6,16_6C0E,16_2400,16_41FA,16_FFD8,16_7201,16_7072,16_4EF8,
 2542+ 16_3EFA,16_205F,16_E488,16_6004,16_4840,16_2F07,16_51C8,16_FFFC,
 2543+ 16_4840,16_51C8,16_FFF4,16_4ED0,16_4E75,
 2544+ 16_1149,16_6E76,16_616C,16_6964,16_2025,16_666F,16_7220,16_6C6F,
 2545+ 16_6F70,16_2F00,16_9082,16_6720,16_2F01,16_6708,16_4EB8,16_3EEE,
 2546+ 16_4A80,16_6D0E,16_508F,16_41FA,16_FFD8,16_7201,16_7055,16_4EF8,
 2547+ 16_3EFA,16_4A81,16_66EE,16_221F,16_201F,16_4E75,
 2548+ 16_0C4F,16_7574,16_206F,16_6620,16_7261,16_6E67,16_6580,16_41FA,
 2549+ 16_FFF0,16_7201,16_7056,16_4EF8,16_3EFA,16_4E75,
 2550+ 16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
 2551+ 16_6162,16_6C65,16_B0FC,16_0000,16_6F1A,16_B2FC,16_0000,16_6F14,
 2552+ 16_BE10,16_6606,16_BE28,16_0001,16_670A,16_BE11,16_6612,16_BE29,
 2553+ 16_0001,16_660C,16_41FA,16_FFCA,16_7202,16_7054,16_4EF8,16_3EFA,
 2554+ 16_48E7,16_C0C0,16_4240,16_1018,16_6730,16_4241,16_1219,16_6722,
 2555+ 16_5380,16_5381,16_B041,16_6E12,16_9240,16_B109,16_56C8,16_FFFC,
 2556+ 16_6602,16_4441,16_4CDF,16_0303,16_4E75,
 2557+ 16_B109,16_56C9,16_FFFC,16_66F2,16_7201,16_4CDF,16_0303,16_4E75,
 2558+ 16_1011,16_4440,16_4CDF,16_0303,16_4E75,
 2559+ 16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
 2560+ 16_B010,16_640C,16_41FA,16_FFEA,16_7203,16_7051,16_4EF8,16_3EFA,
 2561+ 16_4280,16_1010,16_12D8,16_51C8,16_FFFC,16_4E75,
 2562+ 16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
 2563+ 16_B010,16_640C,16_41FA,16_FFEA,16_7201,16_7056,16_4EF8,16_3EFA,
 2564+ 16_0240,16_00FE,16_245F,16_9EC0,16_558F,16_224F,16_BFC8,16_6E0E,
 2565+ 16_1010,16_12D8,16_51C8,16_FFFC,16_204F,16_224F,16_4ED2,16_1018,
 2566+ 16_5289,16_D0C0,16_D2C0,16_1320,16_51C8,16_FFFC,16_204F,16_224F,
 2567+ 16_4ED2,16_4E75,
 2568+ 16_43EF,16_FF00,16_2448,16_D5C0,16_2049,16_9280,16_6C04,16_4211,
 2569+ 16_4E75,
 2570+ 16_1281,16_5219,16_12DA,16_51C9,16_FFFC,16_4E75,
 2571+ 16_700A,16_4EF8,16_3E70,16_4E75,
 2572+ 16_7020,16_4EF8,16_3E70,16_4E75
 2573  
 2574  !<<BOTH
 2575  %integer start,limit
 2576  %record(identinfo)%name DDX
 2577    fill code(1) %if cad&1 # 0
 2578    start = dx_val>>16&511;  limit = start+dx_val&255
 2579    dx_val = cad+dx_val>>7&(255<<1);  !entry
 2580    dx_mode = procmode
 2581    %if start = limit %start;  !range check
 2582      ddx == dict(check)
 2583      put prim(ddx) %and dx_val = cad %if ddx_mode = absmode
 2584      set code word(16_0C80);  !CMPI.L #?,D0
 2585      set code longword(dict(x+1)_val);  !lower
 2586      set code word(16_6D00);  !BLT
 2587      set code word(ddx_val-cad)
 2588      set code word(16_0C80);  !CMPI.L #?,D0
 2589      set code longword(dict(x+2)_val);  !upper
 2590      set code word(16_6E00);  !BGT
 2591      set code word(ddx_val-cad)
 2592      set code word(16_4E75);  !RTS
 2593    %else
 2594      set code word(primcode(start)) %and start=start+1 %until start >= limit
 2595    %finish
 2596  %end
 2597  
 2598  %record(identinfo)%name dx,tp
 2599    dx==dict(x); tp==typecell(dx_type)
 2600    %if dx_mode = absmode %and dx_val < 0 %start;  !prim routine
 2601     ![**for now**: the convention is inadequate because excludes abs neg]
 2602      put prim(dx)
 2603    %else
 2604      c_status = c_status!unknown %if tp_val <= 0
 2605      c_totstack = c_sp-imod(tp_val) %if c_sp-imod(tp_val) < c_totstack
 2606    %finish
 2607    %if dx_mode&63 = pcmode %start;  !internal
 2608      c_forward = c_forward+1 %if dx_flags&spec # 0 %and dx_flags&rflag = 0
 2609      plant(bsr,0,x)
 2610    %finish %else %if dx_flags&(name+indirect) = 0 %or dx_flags&ext # 0 {temp} %start
 2611      plant(jsr,0,x)
 2612    %finish %else %if free&a0b<<3 # 0 %start
 2613      plant(move,x,a0+3)
 2614      plant(jsr,0,a0+3+indir)
 2615      forget(a0+3)
 2616    %else
 2617      plant(move,x,tempd(a7,-4))
 2618      plantlit(move,16_4EF9,tempd(a7,-6))
 2619      plant(jsr,0,lablim)
 2620    %finish
 2621  %end;  !srcall
 2622  !
 2623  %routine DEFINE LABEL(%integer lab)
 2624  %integer r,chain
 2625  %record(contentinfo)%name lr
 2626    chain = dict(lab)_val
 2627    %if chain >= 0 %start;  !label before jumps
 2628      update sp
 2629      forget regs
 2630    %else
 2631      lr == lreg(lab-dictlim)
 2632      %if c_access = 0 %start;  !no fall-through
 2633        c_reg = lr;  !so just incoming context
 2634      %else;  !join
 2635        %for r = d0,1,maxareg %cycle
 2636          forget(r) %if c_reg_content(r) # lr_content(r)
 2637        %repeat
 2638        forget cc %if c_reg_ccx # lr_ccx %or c_reg_ccy # lr_ccy
 2639        c_reg_line = -9 %if lr_line # c_reg_line
 2640      %finish
 2641    %finish
 2642    define jumps(chain)
 2643    dict(lab)_val = pc
 2644  {?}  put operand(lab) %if control&codelist # 0 %and control&list # 0
 2645  %end;  !define label
 2646  
 2647  %routine SET USER LABEL(%integername chain)
 2648    update sp
 2649    addimm(c_temps,a7) %if c_temps # 0 %and c_access # 0  {remove temps}
 2650    define jumps(chain)
 2651    chain = pc
 2652    c_access = 1;  !anyway
 2653    addimm(-c_temps,a7) %if c_temps # 0  {restore temps}
 2654    forget regs
 2655    forget triples %if curlab = c_lab1
 2656  %end
 2657  
 2658  %routine FLUSH
 2659    %if pendcond < 0 %start;  !indicator for line num update
 2660      litstore(litpos) = line
 2661      %if control&tracebit # 0 %then plantlit2(trapi,litpos,15) %c
 2662+     %else %if line-c_reg_line > 8 %then plant(move+2<<8,litpos,lineloc) %c
 2663+     %else plantlit(add+2<<8,line-c_reg_line,lineloc)
 2664      forget cc;  c_reg_line = line
 2665    %else
 2666      %if pendout # 0 %start
 2667        pendcond = pendcond&15
 2668        c_access = 0 %if pendcond = 0
 2669        %if pendcond # 1 %start
 2670          save context(pendout)
 2671          plant(bra+pendcond,0,pendout)
 2672        %finish
 2673      %finish
 2674      define label(pendin) %if pendin # 0
 2675    %finish
 2676    pendcond = 0
 2677  %end
 2678  
 2679  !!!!!!!!!!!!!!!!   Main code generation procedure  !!!!!!!!!!!!!!!!!!!!!
 2680  
 2681  %constinteger INST=1<<30
 2682  
 2683  %routine EVAL(%integername pp, %integer rset)
 2684  !Evaluate the operand identified by PP as defined by RSET:
 2685  !  RSET = boolean vector of acceptable registers
 2686  !  + SIGN to indicate that stopping at EA is acceptable
 2687  !  + 1<<16 to indicate byte value ok
 2688  !  + 2<<16 to indicate short value ok
 2689  !  + STACK if stack ok [not yet: too complex]
 2690  %constinteger ASL=32,
 2691+               CMPM=43,
 2692+               TRAPV=70,
 2693+               SWAP=74, EXTL=76,
 2694+               JMP=57, TST=59, DBNE=86
 2695                
 2696  %constinteger MOVEW=move+2<<8, ADDW=add+2<<8,
 2697+               MOVEB=move+1<<8, ADDB=add+1<<8,
 2698+               SUBB=sub+1<<8, CMPB=cmp+1<<8,
 2699+               CMPMB=cmpm+1<<8
 2700  
 2701  %constinteger VAL=sign+anyreg, REF=sign,
 2702+               SIZESHIFT=16,
 2703+               TOBYTE=1<<16, TOSHORT=1<<17, {1<<18 not sig}
 2704+               TOSTACK=1<<19, ASAD=1<<20
 2705  
 2706  %switch DO(0:opmax)
 2707  %owninteger STSIZ=0;  !this variable is used to convey a
 2708      !rarely required 3rd parameter to EVAL
 2709      !Its value is captured into STSIZE on entry
 2710      !A negative value indicates a string;
 2711      ! a positive value a fixed length structure
 2712      ! * CF normal use of negative/positive size *
 2713  %integer I,J,P,ACT,X,Y,XX,YY,WX,WY,SX,SY,R,OLDFREE,FREED
 2714  %integer M,V,SP,STSIZE,OP,CASE
 2715  %record(identinfo)%name DP,DX,DY,TX
 2716  
 2717  %integer%fn FREE DREG
 2718    %result = free reg(anydreg)
 2719  %end
 2720  
 2721  %integer%fn FREE AREG(%integer content)
 2722  %integer r
 2723    r = free reg(anyareg)
 2724    c_reg_content(r) = content
 2725    %result = r
 2726  %end
 2727  
 2728  %routine PUSH(%integer x)
 2729    plant(move,x,prea7);  extend stack(4)
 2730  %end
 2731  %routine POP(%integer x)
 2732    plant(move,posta7,x);  c_sp = c_sp+4
 2733  %end
 2734  %routine PUSHS(%integer x,s)
 2735    plant(move+s<<8,x,prea7)
 2736    %if s < 4 %then extend stack(2) %else extend stack(4)
 2737  %end
 2738  
 2739  %routine PUSH BLOCK(%integer areg,bytes)
 2740    %if bytes <= 4 %then move block(areg+indir,prea7,bytes) %c
 2741+   %else addimm(bytes,areg) %and move block(areg+pre,prea7,bytes)
 2742    extend stack(bytes)
 2743  %end
 2744  
 2745  %routine COMPILE UNCOND BRANCH(%integer l)
 2746    %if pendcond # 0 %start
 2747      %if pendcond < 0 %start
 2748        pendcond = 0;  !ok?
 2749      %finish %else %if pendin # 0 %start
 2750        flush;                ![safe - improvable?]
 2751      %else
 2752        pendcond = pendcond!!1
 2753        c_access = -2 %if pp+1 < np %and dict(pp+1)_act = else
 2754      %finish
 2755    %finish
 2756    pendcond = pendcond&15
 2757    c_access = 0 %if pendcond = 0
 2758    plant(bra+pendcond,0,l) %if pendcond # 1
 2759    pendcond = 0
 2760  %end
 2761  
 2762  %integer%fn CLEAN REG
 2763  %integer r
 2764    free = free-bregb %and %result = breg %if free&bregb # 0
 2765    r = free dreg
 2766    plant(clr,0,r)
 2767    %result = r
 2768  %end
 2769  
 2770  %integer%fn WEIGHT(%integer p)
 2771  !(Heuristic: can't anticipate all generation decisions)
 2772  %integer a,wy
 2773  %record(identinfo)%name dp
 2774    p = p-ad %if p >= explim
 2775    %result = 1 %if p < np0
 2776    dp == dict(p)
 2777    a = dp_act
 2778    %result = 999 %if a >= imul;  !funcall,mapcall
 2779    wy = weight(dp_y)
 2780    %result = wy %if wy >= 999
 2781    wy = wy-1 %if a = recref %and dict(dp_x)_flags >= 0
 2782    %result = wy+weight(dp_x)
 2783  %end
 2784  
 2785  %routine CHECK ADDRESS(%integer v)
 2786    %if a0 <= v <= a7 %then plant(cmp+2<<8,0,v) %else plant(tst,0,v)
 2787    srcall(adok)
 2788    forget cc
 2789  %end
 2790  
 2791  !!!!!!!!!!!!!!!!!!!  Procedure call  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 2792  !
 2793  !      _____ACT_________X__________Y____
 2794  ! P -> | procident | param 1 | param 2 |
 2795  !      |     0     | param 3 | param 4 |
 2796  !      .           .         .         .
 2797  !
 2798  %routine CALL
 2799  !Load parameters following P and call procedure ACT (DX)
 2800  ! Update PP for RCALL
 2801  %integer sp,stage,maxq,awkward
 2802  
 2803  %routine EVAL PARLIST(%integer arg,q)
 2804  %record(identinfo)%name darg,dv
 2805  %integer v,w,f,r,s
 2806  !Stage 0 (forward):
 2807  !Stage 0 (returning):
 2808  !Stage 1 (forward):
 2809  !Stage 1 (returning):
 2810    %return %if arg = 0
 2811    darg == dict(arg)
 2812    q = q+1;  maxq = q %if q > maxq
 2813    %if q&1 = 0 %then v = dict(p+q>>1)_x %else v = dict(p+q>>1)_y
 2814    r = darg_reg&15
 2815    s = size(darg_type)
 2816    %if darg_flags&proc # 0 %start
 2817      s = 0
 2818      %if awkward # 0 %start
 2819        f = v;  f = f-ad %if f >= explim
 2820        dv == dict(f)
 2821        %if dv_flags&(ext+spec) # ext+spec %start
 2822        !non-external to (maybe) external
 2823          eval parlist(darg_link,q) %and %return %if stage # 0
 2824          %if dv_flags&(name+indirect) # 0 %then plant(move,f,prea7) %C
 2825+         %else plant(pea,0,f)
 2826          plantlit(move+2<<8,16_4EF9,prea7)  {JMP entry}
 2827          plant(move,mb,prea7)
 2828          plantlit(move+2<<8,16_287C,prea7)  {MOVE #xxxx,mb}
 2829          extend stack(12)
 2830          s = c_sp
 2831          eval parlist(darg_link,q)
 2832          %if darg_val > 0 %start
 2833            plant(pea,0,temp(c_mode,s))
 2834          %else
 2835            plant(lea,temp(c_mode,s),r+d0)
 2836            free = free&(\(d0b<<r))
 2837          %finish
 2838          %return
 2839        %finish
 2840      %finish
 2841    %finish
 2842    %if darg_val > 0 %start;  !passed on stack
 2843      eval parlist(darg_link,q)
 2844      %return %if stage # 0
 2845      %if darg_flags < 0 %start;     !name
 2846        f = free
 2847  !      eval(v,ref)
 2848  !      plant(pea,0,v);  extend stack(4)
 2849        eval(v,anyareg)
 2850        push(v)
 2851        free = f
 2852        %return
 2853      %finish
 2854      %if s > 0 %start;              !simple value
 2855        f = free;  eval(v,val)
 2856        pushs(v,s)
 2857        free = f
 2858      %else;                        !structure by value
 2859        stsiz = s
 2860        stsiz = -stsiz %if category(darg_type) # stringy
 2861        eval(v,tostack)
 2862      %finish
 2863      %return
 2864    %finish
 2865    %if s <= 0 %and darg_flags >= 0 %start
 2866      !structure by value -- ad in reg
 2867      v = v-ad %if v >= explim
 2868      %if v >= np0 %start
 2869        dv == dict(v)
 2870        %if dv_act >= concat %and dv_mode = 0 %start
 2871          !string/record function
 2872          %if stage = 0 %start
 2873            stsiz = s
 2874            stsiz = -stsiz %if category(darg_type) # stringy
 2875            r = v;  eval(r,tostack);  free = free!a0b;  ![?here?]
 2876            c_reg_content(a0) = v+ad
 2877            dv_val = c_sp
 2878            eval parlist(darg_link,q)
 2879          %else
 2880            eval parlist(darg_link,q)
 2881            %if c_reg_content(r+d0) # v+ad %start
 2882              dv_mode = c_mode
 2883              plant(lea,v,r+d0)
 2884              dv_mode = 0
 2885            %finish
 2886            free = free&(\(d0b<<r))
 2887          %finish
 2888          %return
 2889        %finish
 2890      %finish
 2891      v = v+ad
 2892    %finish
 2893    w = weight(v)
 2894    %if w >= 999 %start
 2895      eval parlist(darg_link,q)
 2896      %return %if stage # 0
 2897    %else
 2898      %if w >= 2 %and stage # 0 %start
 2899        eval(v,d0b<<r)
 2900        eval parlist(darg_link,q)
 2901        %return
 2902      %finish
 2903      eval parlist(darg_link,q)
 2904      %return %if stage = 0
 2905    %finish
 2906    eval(v,d0b<<r)
 2907  %end
 2908  
 2909    awkward = 0
 2910    awkward = 1 %and push(mb) %if dx_flags&proc2 # 0 %c
 2911+            %and (dx_flags&ext = 0 %or dx_flags&spec # 0);  !param or external
 2912    sp = c_sp
 2913    maxq = 0
 2914    stage = 0
 2915    eval parlist(dict(dx_type)_link,-1)
 2916    stage = 1
 2917    eval parlist(dict(dx_type)_link,-1)
 2918    srcall(act)
 2919    %if c_sp # sp %start
 2920      addimm(sp-c_sp,a7);  c_sp = sp
 2921    %finish
 2922    pop(mb) %if awkward # 0
 2923    pp = p+maxq>>1 %if p < np;  !update for RCALL + RESOL
 2924    forget regs
 2925    c_reg_line = line %if dx_flags&(ext+proc) = ext+proc1;  !%system
 2926  %end;  !call
 2927  !
 2928  %routine STRUCTCALL(%integer entry,size)
 2929    size = mite(-size-1) %and forget(breg) %if size <= 0;  !string
 2930    plantlit(move,size,d0)
 2931    srcall(entry)
 2932    forget(d0)
 2933  %end
 2934  
 2935  %routine PUSH STRUCTURE
 2936    %if stsize <= 0 %start;               !string
 2937      structcall(strtostk,stsize)
 2938      forget(a0);  forget(a1);  forget(a0+2)
 2939      extend stack(256-(stsize&254))
 2940    %else;                               !fixed size structure
 2941      push block(a0,(stsize+1)&(\1))
 2942    %finish
 2943  %end
 2944  
 2945  %routine OK REG(%integer got)
 2946    r = got
 2947    %if d0b<<(got-d0)&rset = 0 %start
 2948      c_reg_content(got) = pp
 2949      %if rset&free = 0 %and rset&tostack # 0 %start
 2950        push structure;  r = a7
 2951  !      push(got);  r = a7
 2952  !      c_reg_ccx = pp;  c_reg_ccy = 0
 2953      %else
 2954        r = free reg(rset&(\bregb));  plant(move,got,r)
 2955        c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
 2956      %finish
 2957    %finish
 2958  %end
 2959  
 2960  %routine OK AREG(%integer got,ok)
 2961    r = got
 2962    %if a0b<<(got-a0)&ok = 0 %start
 2963      r = free reg(ok);  plant(move,got,r)
 2964    %finish
 2965  %end
 2966  
 2967  %routine LOAD ADDRESS(%integer p)
 2968  %integer i,f
 2969    %if rset&anyareg&free # 0 %start
 2970      %if dp_mode&2_111000 = indexmode %and dp_val&255 = 0 %start
 2971        i = a0b<<(dp_mode&7)
 2972        rset = i %if rset&free&i # 0
 2973      %finish
 2974      r = free reg(rset&anyareg)
 2975      plant(lea,p,r)
 2976    %else
 2977      f = free
 2978      i = free areg(p+ad);  plant(lea,p,i)
 2979      free = f
 2980      r = free reg(rset&(\bregb));  plant(move,i,r)
 2981    %finish
 2982  %end
 2983  
 2984  %routine COMMANDEER(%integer regs)
 2985  %integer r
 2986    freed = \free&regs
 2987    %if freed # 0 %start
 2988      regs = freed;  r = d0
 2989      %while regs # 0 %cycle
 2990        push(r) %and forget cc %if regs&1 # 0
 2991        regs = regs>>1;  r = r+1
 2992      %repeat
 2993      free = free!freed;  rset = rset&(\freed)
 2994    %finish
 2995  %end
 2996  %routine RESTORE(%integer regs)
 2997  %integer r
 2998    r = a7
 2999    %while regs # 0 %cycle
 3000      %if regs&16_8000 # 0 %start
 3001        pop(r);  forget(r);  !*should have remembered it*
 3002        forget cc
 3003      %finish
 3004      regs = regs<<1&16_FFFF;  r = r-1
 3005    %repeat
 3006  %end
 3007  
 3008  %routine PARTREG
 3009  ! Something smaller than integer has been loaded to R
 3010  ! Determine what else to do (using SX,SY)
 3011    sy = 4 %if r = breg %or r >= a0
 3012    %while imod(sy) < sx %cycle
 3013      %if sy > 0 %start;  !signed
 3014        plant(extl-2+sy,0,r);  !ext.w,ext.l
 3015        sy = sy+sy
 3016      %else
 3017        %if sy = -1 %start;  !unsigned byte
 3018          plantlit(and,255,r)
 3019        %else;            !unsigned word (half)
 3020          plantlit(and,16_FFFF,r)
 3021        %finish
 3022        sy = 4
 3023      %finish
 3024    %repeat
 3025  %end
 3026  
 3027  !!Start of EVAL
 3028  
 3029    stsize = stsiz;  !additional parameter (for TOSTACK cases)
 3030    rset = rset&(\anyareg) %if rset&tobyte # 0;  ![1 bit]
 3031    p = pp;  p = p-ad %if p >= explim
 3032    rset = rset-asad %and pp = p+ad %if rset&asad # 0
 3033    %if p <= 0 %then dp == dint %else dp == dict(p)
 3034    oldfree = free;  freed = 0
 3035  
 3036  %if rset # inst %start
 3037    %unless dp_mode&2_110000 = 0 %and pp < np0 %start;  !not already reg
 3038      j = pp
 3039      %if rset&(anydreg!bregb{+tostack}) # 0 %start;  !data reg acceptable
 3040        i = d0
 3041        %cycle;  !See if available
 3042          j = i %and %exit %if c_reg_content(i) = j
 3043          i = i+1;  i = a0 %if i = maxdreg+1
 3044        %repeat %until i > maxareg
 3045      %finish %else %if rset&anyareg # 0 %start;  !try address regs first
 3046        i = maxareg
 3047        %cycle
 3048          j = i %and %exit %if c_reg_content(i) = j
 3049          i = i-1;  i = maxdreg %if i = a0-1
 3050        %repeat %until i < d0
 3051      %finish %else %if j < explim %and rset # tostack %start;  !REF: try for address
 3052        i = a0
 3053        %cycle
 3054          %if c_reg_content(i) = j+ad %start
 3055            free = free&(\(a0b<<(i-a0)))
 3056            dp_flags = dp_flags!(rflag+wflag)
 3057            pp = i+indir
 3058            %return
 3059          %finish
 3060          i = i+1
 3061        %repeat %until i > maxareg
 3062      %finish
 3063    %else;  !already reg
 3064      j = dp_mode+d0;       !in case reg alias
 3065      %if rset < 0 %start;  !EA ok means any reg ok
 3066        pp = j
 3067        %return
 3068      %finish
 3069      pp = c_reg_content(j); !fiddle for update
 3070    %finish
 3071  
 3072    %if 0 < j <= a7 %start;  !operand (now) in reg
 3073      ok reg(j)
 3074      dp_flags = dp_flags!rflag
 3075      -> endload
 3076    %finish
 3077  
 3078    %if p <= 0 %start;  !literal
 3079      %return %if rset < 0
 3080      %if rset = tostack %start
 3081        i = constmode;  i = pcmode %if p = 0;  !null string [sneaky]
 3082        plant(lea,temp(i,litval(p)),a0);           !A0 must be free
 3083        forget(a0)
 3084        push structure
 3085        %return
 3086      %finish
 3087      %if pp < explim %start;  !normal value
 3088        rset = rset&(\bregb) %if p < -(255<<1) %or p&1 # 0;  !0:255 ok
 3089        r = free reg(rset)
 3090        %if r < a0 %or p # 0 %then plant(move,p,r) %c
 3091+       %else plant(sub,r,r)
 3092      %else;                    !address within FINAL
 3093        i = constmode;  i = pcmode %if p = 0;  !null string [sneaky]
 3094        load address(temp(i,litval(p)))
 3095      %finish
 3096      c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
 3097      ->endload
 3098    %finish
 3099  %finish
 3100    %if p >= np0 %start;  !complex
 3101  more:
 3102      act = dp_act;  x = dp_x;  y = dp_y
 3103      xx = x;  yy = y
 3104      -> proccall %if act > opmax
 3105      -> do(act)
 3106    %finish
 3107  
 3108  do(move):
 3109  load:
 3110    i = 0
 3111    i = i+1 %if dp_flags&indirect # 0
 3112    i = i+2 %if dp_flags < 0
 3113    %if pp >= explim %start {address wanted}
 3114      %if i = 0 %start
 3115        free = oldfree
 3116        load address(p)
 3117      %else
 3118        %if i = 3 %start;  !indirect name
 3119          free = oldfree
 3120          r = free areg(undef);  plant(move,p,r)
 3121          p = r+indir
 3122        %finish
 3123        pp = p %and %return %if rset < 0
 3124        free = oldfree
 3125        r = free reg(rset);  plant(move,p,r)
 3126      %finish
 3127      c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
 3128    %else
 3129      %if i > 0 %start
 3130        free = oldfree
 3131        r = maxareg+1
 3132        %cycle
 3133          r = r-1
 3134          %if r < a0 %start
 3135            r = free areg(p+ad);  plant(move,p,r)
 3136            plant(move,r+indir,r) %if i = 3
 3137            check address(r) %if i > 1 %and control&assbit # 0
 3138          %finish
 3139        %repeat %until c_reg_content(r) = p+ad
 3140        free = free&(\(a0b<<(r-a0)))
 3141        p = r+indir
 3142      %finish
 3143      pp = p %and %return %if rset = ref
 3144      sx = rset>>sizeshift&3;  sx = 4 %if sx = 0
 3145      i = dp_flags
 3146      sy = size(dp_type)
 3147      %if c_localdpos <= p < dictlim %and i&okflag = 0 %and c_forward = 0 %start
 3148        !local, simple, always accessed
 3149        %if i&wflag = 0 %start;  !unassigned
 3150          report(asserr+warn,p,0) %if c_faults = 0
 3151        %finish
 3152        dp_flags = dp_flags+okflag %if dp_flags >= 0 %and sy > 0
 3153      %finish
 3154      %if rset = tostack %start
 3155        free = oldfree
 3156        plant(lea,p,a0);           !A0 must be free
 3157        forget(a0)
 3158        push structure
 3159        %return
 3160      %finish
 3161      intern(5) %and %return %if sy <= 0
 3162      i = i!okflag %if control&bassbit>>1<<sy = 0
 3163      %if i&okflag # 0 %and rset < 0 %start;  !not necessary to load?
 3164        %if sy = sx %start;  !same size
 3165           pp = p
 3166          %return
 3167        %finish
 3168      %finish
 3169      free = oldfree
 3170      %if i&okflag # 0 %then i = -1 %else i = sy
 3171      sy = -sy %if sy # 4 %and (dict(dp_type)_flags&nonord # 0 %c
 3172+                         %or dict(dp_type+1)_val = 0);  !unsigned
 3173      %if sy = -1 %start;  !unsigned byte
 3174        %if free&bregb # 0 %start
 3175          %if rset&bregb # 0 %start
 3176            rset = bregb
 3177          %else
 3178            plant(moveb,p,breg)
 3179            forget(breg)
 3180            p = breg;  sy = 4
 3181          %finish
 3182        %finish
 3183      %finish %else rset = rset&(\bregb)
 3184      %if sy < 2 %or sx = 1 %start
 3185        %if rset&(anydreg!bregb) = 0 %start
 3186        !Can't load bytes,halfs to address regs
 3187        ! or store bytes from them
 3188          r = free dreg
 3189          plant(move+imod(sy)<<8,p,r)
 3190          partreg
 3191          p = r;  free = oldfree
 3192        %finish %else rset = rset&(\anyareg)
 3193      %finish
 3194      %if sy = 2 %and rset&anyareg&free # 0 %start
 3195        rset = rset&(\anydreg);  !prefer areg for word (auto-extend)
 3196      %finish
 3197      r = free reg(rset)
 3198      plant(move+imod(sy)<<8,p,r)
 3199      c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0
 3200      %if sy # 4 %start
 3201        partreg
 3202      %finish
 3203      %if i >= 0 %start
 3204        plant(cmp+i<<8,r,d7);  !check unassigned
 3205        srcall(unass)
 3206        forget cc
 3207      %finish
 3208      %if sy # 4 %and r # breg %start;  !not full reg
 3209        forget(r)
 3210        -> endload1
 3211      %finish
 3212    %finish
 3213  endload:
 3214    c_reg_content(r) = pp
 3215  endload1:
 3216    free = free&(\(d0b<<(r-d0)))
 3217    r = r+indir %if rset = ref
 3218    pp = r
 3219    %return
 3220  
 3221  dataload:
 3222    eval(p,anydreg)
 3223    ok reg(p)
 3224    -> endload
 3225  
 3226  !!!!!!!!!!!!!!!!   Array   /   Record    /   Map   !!!!!!!!!!!!!!!!!!
 3227  
 3228  %integer%fn FREEISH AREG(%integer for)
 3229  !Use the register component of M if alterable
 3230  ! to avoid excessive dissipation of address registers
 3231  %integer i
 3232    i = m&7
 3233    %result = free areg(for) %if a0b<<i&oldfree = 0 %or m >= framemode
 3234    free = free&(\(a0b<<i))
 3235    i = i+a0;  c_reg_content(i) = for
 3236    %result = i
 3237  %end
 3238  %routine ADEVAL(%integer x,y,q)
 3239  !Base X, scaled index Y, displacement Q
 3240  %integer i,j
 3241    %if x <= 0 %start;  !%const
 3242      m = constmode;  v = litval(x)
 3243    %else
 3244      eval(x,ref)
 3245      m = dict(x)_mode;  v = dict(x)_val
 3246      %if m = c_mode %and v < 0 %start
 3247       !*Assertion: SP will have same value when address used
 3248        m = dispmode+7;  v = v-c_sp
 3249      %finish %else %if m&2_111000 = aregmode+indir %start
 3250        m = m+(dispmode-(aregmode+indir))
 3251      %finish
 3252    %finish
 3253    eval(y,anyreg) %if y # 0;  !subscript
 3254    %if m&2_111000 = indexmode %start;  !X already involves index
 3255      %if y = 0 %start
 3256       !See if Q can be combined with existing disp
 3257        j = mite(v)
 3258        i = j+q
 3259        %if is mite(i)=TRUE %start
 3260          v = v-j+i&255
 3261          %return
 3262        %finish
 3263      %finish
 3264      i = freeish areg(x+ad)
 3265      plant(lea,x,i)
 3266      m = i+(dispmode-a0);  v = 0
 3267    %finish
 3268    %if y # 0 %start
 3269      %if m&63 = pcmode %start
 3270        i = free areg(undef);  plant(lea,temp(m,v+q),i)
 3271        m = i+(dispmode-a0);  v = 0;  q = 0
 3272      %finish %else %unless is mite(v+q)=TRUE %start;  !indexmode out
 3273        %unless is mite(q)=TRUE %start; !& out even if V absorbed
 3274          i = freeish areg(undef)
 3275          %if is short(v+q)=TRUE %start
 3276            plant(lea,temp(m,v+q),i)
 3277          %else
 3278            plant(lea,x,i);  addimm(q,i)
 3279          %finish
 3280          q = 0
 3281        %else
 3282          i = freeish areg(x+ad)
 3283          plant(lea,x,i)
 3284        %finish
 3285        m = i+(dispmode-a0);  v = 0
 3286      %finish
 3287    %finish
 3288    v = v+q
 3289    %if y # 0 %start
 3290      m = m+(indexmode-dispmode)
 3291      v = (y-d0)<<12+16_0800+v&255
 3292    %finish
 3293  %end
 3294  
 3295  do(index):
 3296  !  P      => {index,ARRAY,SUBSCRIPT}
 3297  !  ARRAY  => ARRID
 3298  !         or {index,ARRAY,SUBSCRIPT}
 3299  !         or {recref,RECORD,ARRAY}
 3300  !  TYPE INFO : TYPE = ELTYPE, XTYPE = INDEX-TYPE
 3301  !              MODE,VAL = DOPE ADDRESS
 3302    dx == dict(x)
 3303    i = dx_type;                   !array type cell
 3304    tx == dict(i)
 3305    get bounds(tx_xtype,sx,sy)
 3306   !establish multiplier (element size)
 3307    m = imod(nsize(tx))
 3308   !ARRFLAG is set for either ABC requested or dynamic
 3309    %if dx_flags&arrflag # 0 %and (y > 0 %or sx = minint %or m = 0) %start
 3310      commandeer(d0b+d1b+a0b);  ![D1 ??]
 3311     ! subscript
 3312      eval(y,d0b)
 3313     ! dope vector
 3314      j = 0
 3315      j = j+12 %and i = i+1 %and tx == dict(i) %while tx_mode = 0
 3316      %if tx_flags&indirect # 0 %start
 3317        plant(move,i,a0)
 3318        addimm(j,a0) %if j # 0
 3319      %else
 3320        %if tx_val = 0 %and tx_mode = constmode %start
 3321        ! dope info not yet created
 3322          fill code(1) %if cad&1 # 0
 3323          tx_val = cad
 3324          set code longword(sy)
 3325          set code longword(sx)
 3326          set code longword(m)
 3327        %finish
 3328        plant(lea,i,a0)
 3329      %finish
 3330      srcall(index)
 3331      forget(d0);  forget(a0)
 3332      restore(freed&(\d0b))
 3333      free = oldfree&(\d0b)
 3334      freed = freed&d0b
 3335      i = x;  eval(i,anyareg&free+asad)
 3336      plant(add,d0,i)
 3337      %if dp_flags < 0 %then forget(i) {ad of ad of P} %c
 3338+     %else c_reg_content(i) = p+ad
 3339      free = free!d0b %if freed = 0
 3340      restore(freed)
 3341      m = i+(dispmode-a0);  v = 0
 3342      -> setflags
 3343    %finish
 3344  index1:
 3345    !deal with subscript
 3346    j = 0
 3347    %if y <= 0 %start;  !literal subscript
 3348      j = litval(y);  y = 0
 3349    %finish
 3350    %if y >= np0 %and dict(y)_act = add %c
 3351+    %and dict(y)_y <= 0 %start;  !Y => {add,exp,lit}
 3352      j = litval(dict(y)_y);  y = dict(y)_x
 3353    %finish
 3354    %if m > 1 %start
 3355      %if y # 0 %start
 3356        %if m&(m-1) # 0 %and m <= 32767 %and sy <= 32767 %and sx >= -32768 %start
 3357          putexp(muls,y,litref(m),inttype)
 3358        %else
 3359          putexp(imul,y,litref(m),inttype)
 3360        %finish
 3361        y = item
 3362      %finish
 3363    %finish
 3364    %if dx_flags&(name+ext+arrflag+indirect) = indirect %and sx # 0 %start
 3365      dx_val = dx_val+4;  !0-based
 3366      adeval(x,y,j*m)
 3367      dx_val = dx_val-4
 3368    %else
 3369      j = j-sx;  j = j*m %if m > 1
 3370      adeval(x,y,j);  !array,index,displacement
 3371    %finish
 3372  setflags:
 3373    dx_flags = dx_flags!(mflag+wflag+rflag);  !don't know
 3374  setmode:
 3375  ![what about FRAMEMODE?]
 3376    %if dispmode <= m < indexmode %start
 3377      %unless is short(v)=TRUE %start
 3378        ok areg(m+(a0-dispmode),oldfree&anyareg)
 3379        addimm(v,r);  forget(r)
 3380        m = r-(a0-dispmode);  v = 0
 3381      %finish
 3382      %if pp >= explim %and v = 0 %and rset # ref %and dp_flags >= 0 %start
 3383      !address wanted, disp zero, as value, not name
 3384      ! so the address is simply in the register
 3385        ok reg(m+(a0-dispmode))
 3386        free = oldfree
 3387        -> endload
 3388      %finish
 3389    %finish
 3390    dp_mode = m;  dp_val = v
 3391    ->load
 3392  
 3393  do(recref):
 3394  !  P => {recref,RECORD,SUBEL}
 3395    dx == dict(x)
 3396    adeval(x,0,dict(y)_val);  !record,subscript,displacement
 3397    ->setflags
 3398  
 3399  do(storemap):
 3400    v = 0
 3401    %if y >= explim %start
 3402      y = y-ad;  eval(y,ref)
 3403      m = dict(y)_mode;  v = dict(y)_val
 3404    %else
 3405      %if y >= np0 %start
 3406        %if dict(y)_act = add %start
 3407          m = dict(y)_y
 3408          y = dict(y)_x %and v = litval(m) %if m <= 0
 3409  !       eval(y,val) %if y >= dictlim
 3410        %finish;! %else eval(y,val)
 3411      %finish
 3412      eval(y,anyareg)
 3413      check address(y) %if control&assbit # 0  %and pp < explim
 3414      m = y+(dispmode-a0)
 3415    %finish
 3416    -> setmode
 3417  
 3418  do(lenref):
 3419  do(sindex):
 3420    x = x-ad %if x >= explim
 3421    dx == dict(x)
 3422    %if y <= 0 %then adeval(x,0,litval(y)) %c
 3423+   %else eval(y,anydreg) %and adeval(x,y,0)
 3424    -> setflags
 3425  
 3426  do(dnew):
 3427    commandeer(c_free)
 3428    plant(move,y,d0)
 3429    srcall(act)
 3430    forget regs
 3431    c_reg_line = line
 3432    -> endmap
 3433  
 3434  do(dtostring):
 3435  proccall:
 3436    dx == dict(act)
 3437    -> rcall %if p < np
 3438    -> funcall %if dx_flags&writable = 0
 3439  !mapcall
 3440    commandeer(c_free)
 3441    call
 3442  endmap:
 3443    free = oldfree
 3444    r = a0
 3445    ok areg(a0,\freed&anyareg) %if rset # ref
 3446    restore(freed)
 3447    free = free&(\(a0b<<(r-a0)))
 3448    c_reg_content(r) = p+ad
 3449    m = r+(dispmode-a0);  v = 0;  !0(A?)
 3450    ->setmode
 3451  
 3452  funcall:
 3453    commandeer(c_free)
 3454    call
 3455    r = typecell(dx_type)_reg&15+d0
 3456    c_reg_ccx = pp %and c_reg_ccy = 0 %if dx_flags&okflag # 0
 3457  endloadr:
 3458    free = oldfree
 3459    %if rset # ref %then ok reg(r)
 3460    restore(freed)
 3461    ->endload
 3462  
 3463  rcall:
 3464    flush %if pendcond # 0
 3465    update sp
 3466  !<<IMP
 3467    %while act = dprintstr %and x >= np0 %and dict(x)_act = concat %cycle
 3468      dp_x = dict(x)_x;  !first of pair
 3469      call;  free = c_free
 3470      x = dict(x)_y;  dp_x = x
 3471    %repeat
 3472  !<<BOTH
 3473    call
 3474    c_access = 0 %if dx_flags&noret # 0
 3475    forget triples %if pp+1 = np %and curlab = c_lab1 %c
 3476+                  %and dict(curlab)_val >= 0 %and dict(curlab+1)_val >= 0
 3477    %return
 3478  
 3479  !!!!!!!!!!!!!!!!!!!!!!!!!   Operators   !!!!!!!!!!!!!!!!!!!!!!!!!!!
 3480  
 3481  %routine EVALXY
 3482    rset = rset&(\bregb)
 3483    commandeer(d0b+d1b)
 3484    %if 999 > weight(x) < weight(y) %start
 3485      eval(y,d1b);  eval(x,d0b)
 3486    %else
 3487      eval(x,d0b);  eval(y,d1b)
 3488    %finish
 3489  %end
 3490  
 3491  %routine STACKOP(%integer s)
 3492    stsiz = s
 3493    sp = c_sp
 3494    eval(x,tostack);  free = free!a0b
 3495    eval(y,a0b+asad)
 3496    plant(move,a7,a1);      !dest (stack)
 3497    structcall(act,s)
 3498    forget(a0);  forget(a1);  forget(a0+2)
 3499  %end
 3500  
 3501  !<<IMP
 3502  do(prel):
 3503  !  P => {prel,BASENAME,INDEX}
 3504    dx == dict(x)
 3505    m = imod(size(dx_type))
 3506    sx = 0;  sy = 999999
 3507    -> index1
 3508  
 3509  !<<BOTH
 3510  
 3511  do(check):        !CHECK rangetype,value
 3512    commandeer(d0b)
 3513    eval(y,d0b)
 3514    srcall(x)
 3515    r = d0
 3516    -> endloadr
 3517  
 3518  ![Note that all literal subtraction comes through as ADD]
 3519  do(add):
 3520    %if control&overbit # 0 %start
 3521      -> dataload %if rset&(\anyareg) = 0
 3522      rset = rset&(\anyareg)
 3523    %finish
 3524    -> dataload %if rset&(\bregb) = 0
 3525    rset = rset&(\bregb)
 3526    %if y < 0 %start
 3527      %if y >= litquick %start;  !(ADDQ,SUBQ)
 3528        y = y-1 %and act = sub %if y&1 # 0;  !'negate' if 'negative'
 3529        eval(x,rset&free)
 3530        ->fin1
 3531      %finish
 3532      %if y = -(128<<1) %start;  !+128
 3533        act = sub;  y = y+1;  !- -128 (MOVEQ)
 3534        -> op2
 3535      %finish
 3536    %finish
 3537    -> op1
 3538  do(eor):
 3539    -> dataload %if rset&(\bregb) = 0
 3540    rset = rset&(\bregb)
 3541  do(or):
 3542  do(and):
 3543    -> dataload %if rset&(\anyareg) = 0
 3544    rset = rset&(\anyareg)
 3545  op1:
 3546    wx = weight(x)
 3547    %if wx <= 1 %and y <= 0 %and y >= litmite %and rset&(\anyareg) # 0 %start
 3548      rset = rset&(\anyareg)
 3549      i = x;  x = y;  y = i
 3550    %finish %else %if 999 > wx < weight(y) %start
 3551      i = x;  x = y;  y = i
 3552    %finish
 3553    -> op2
 3554  do(sub):
 3555    %if control&overbit # 0 %start
 3556      -> dataload %if rset&(\anyareg) = 0
 3557      rset = rset&(\anyareg)
 3558    %finish
 3559    rset = rset&(\bregb)
 3560  op2:
 3561    eval(x,rset&free)
 3562  op3:
 3563    oldfree = free
 3564    %if y <= 0 %and y >= litmite %and free&(anydreg!bregb) # 0 %start
 3565      eval(y,anydreg!bregb);           !bring Y to reg
 3566    %finish %else %if act = eor %and y > 0 %start
 3567      eval(y,anydreg)
 3568    %finish %else %if act > sub %start
 3569      %if x = breg %and y > 0 %start
 3570        sy = tsize(y)
 3571        %if sy = 1 %or (sy = 2 %and act = and) %start
 3572          eval(y,val&(\anyareg)+sy<<sizeshift)
 3573          act = act+sy<<8 %if y > d7
 3574        %finish %else eval(y,val&(\anyareg))
 3575      %finish %else eval(y,val&(\anyareg))
 3576    %else
 3577      eval(y,val)
 3578    %finish
 3579    free = oldfree
 3580  fin1:
 3581    plant(act,y,x)
 3582    -> fin3 %if act > sub
 3583  fin2:
 3584    plant(trapv,0,0) %if control&overbit # 0
 3585  fin3:
 3586    pp = x;  c_reg_content(x) = p
 3587    %if act <= opmax %then c_reg_ccx = p %and c_reg_ccy = 0 %c
 3588+   %else forget cc
 3589    %return
 3590  
 3591  do(muls): do(mulu):
 3592    -> dataload %if rset&(\(anyareg!bregb)) = 0
 3593    rset = rset&(\(anyareg!bregb))
 3594    eval(x,rset&free)
 3595    oldfree = free
 3596    eval(y,anydreg) %if y > 0;  ![could do better for short]
 3597    free = oldfree
 3598    plant(act,y,x)
 3599    -> fin2
 3600  
 3601  do(lsl): do(lsr):
 3602    -> dataload %if rset&(\(anyareg!bregb)) = 0
 3603    rset = rset&(\(anyareg!bregb))
 3604    eval(x,rset&free)
 3605    %if y < 0 %and y >= litquick %start
 3606      act = act!!(lsl!!lsr) %and y = y-1 %if y&1 # 0;  !negate if neg
 3607    %else
 3608      oldfree = free;  eval(y,anydreg);  free = oldfree
 3609    %finish
 3610    ->fin1
 3611  do(neg):
 3612    %if y # 0 %start
 3613     r = y;  y = x;  x = r
 3614     act = sub
 3615     -> do(sub)
 3616    %finish
 3617  do(not):
 3618    -> dataload %if rset&(\(anyareg!bregb)) = 0
 3619    rset = rset&(\(anyareg!bregb))
 3620    eval(x,rset&free)
 3621    plant(act,0,x)
 3622    -> fin3
 3623  do(iabs):
 3624    -> dataload %if rset&(\(anyareg!bregb)) = 0
 3625    rset = rset&(\(anyareg!bregb))
 3626    x = y
 3627    eval(x,rset&free)
 3628    plant(move,x,x) %if c_reg_ccx # y %or c_reg_ccy # 0
 3629    plantlit2(bge,0,2)
 3630    plant(neg,0,x)
 3631    ->fin2
 3632  do(fabs):
 3633    -> dataload %if rset&(\(anyareg!bregb)) = 0
 3634    rset = rset&(\(anyareg!bregb))
 3635    x = y
 3636    eval(x,rset&free)
 3637    plantlit(and,16_7FFFFFFF,x)
 3638    ->fin3
 3639  
 3640  %routine DO SHIFT
 3641  %integer i;
 3642    i=0
 3643    i = i+1 %and j = j>>1 %until j&1 # 0
 3644    %if i = 1 %then plant(add,x,x) %else %start
 3645      i = litref(i)
 3646      %if i < litquick %start
 3647        oldfree = free;  eval(i,anydreg);  free = oldfree
 3648      %finish
 3649      plant(asl,i,x)
 3650    %finish
 3651  %end
 3652  
 3653  do(imul):
 3654    -> dataload %if rset&(\(anyareg!bregb)) = 0
 3655    rset = rset&(\(anyareg!bregb))
 3656   !Test for power of 2 or pair of powers of 2
 3657    %if y < 0 %start
 3658      j = litval(y)
 3659      i = j&(j-1)
 3660      %if i = 0 %or i&(i-1) = 0 %start
 3661        eval(x,rset&free)
 3662        do shift %if j&1 = 0
 3663        %if j # 1 %start
 3664          plant(move,x,prea7)
 3665          do shift
 3666          plant(add,posta7,x)
 3667        %finish
 3668        ->fin2
 3669      %finish
 3670    %finish
 3671  do(fsub): do(fdiv):
 3672  do(ipow): do(fpow):
 3673  do(fadd): do(fmul):
 3674    evalxy
 3675    srcall(act)
 3676    plant(trapv,0,0) %if act = imul %and control&overbit # 0
 3677    forget(d1);  r = d0
 3678    forget cc
 3679    -> endloadr
 3680  
 3681  do(idiv): do(drem):
 3682    %if control&halfbit # 0 %start
 3683      act = divs %if act = idiv
 3684  do(divs): do(divu):
 3685      -> dataload %if rset&(\(anyareg!bregb)) = 0
 3686      rset = rset&(\(anyareg!bregb))
 3687      eval(x,rset&free)
 3688      oldfree = free
 3689      eval(y,anydreg)
 3690      free = oldfree
 3691      %if act = drem %then plant(divs,y,x) %and plant(swap,0,x) %c
 3692+     %else plant(act,y,x)
 3693      plant(extl,0,x)
 3694      -> fin3
 3695    %finish
 3696    evalxy
 3697    srcall(idiv)
 3698    putexp(act!!(idiv!!drem),xx,yy,inttype)
 3699    %if act = idiv %start
 3700      c_reg_content(d1) = item;  r = d0
 3701    %else
 3702      c_reg_content(d0) = item;  r = d1
 3703    %finish
 3704    forget cc
 3705    ->endloadr
 3706  
 3707  do(float):
 3708  do(fneg):
 3709    commandeer(d0b)
 3710    eval(x,d0b)
 3711    srcall(act)
 3712    forget cc
 3713    r = d0
 3714    ->endloadr
 3715  
 3716  do(concat):      !not special case
 3717  ![they have to be free]  commandeer(d0b+bregb+a0b+a1b+a2b)
 3718    fault(plexerr) %if free&(a0b+a1b+a2b+d0b+bregb) # a0b+a1b+a2b+d0b+bregb
 3719    stackop(-256)
 3720  endconc:
 3721    %if rset&tostack = 0 %start
 3722      %if c_sp # sp %start
 3723        addimm(sp-c_sp,a7);  c_sp = sp
 3724      %finish
 3725    %finish %else rset = a0b
 3726    r = a0
 3727    ->endloadr
 3728  
 3729  !!!!!!!!!!!!!!!!!!!!!   Conditions   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 3730  
 3731  %routine CONDSWOP
 3732  !Swop condition operands, adjusting operator accordingly
 3733  %integer temp
 3734    temp = x;  x = y;  y = temp
 3735    temp = xx;  xx = yy;  yy = temp
 3736    temp = sx;  sx = sy;  sy = temp
 3737    temp = wx;  wx = wy;  wy = temp
 3738    case = case!!3 %if case&8 # 0;  !no change for '=','#'
 3739  %end
 3740  
 3741  %routine UNSIGNED
 3742    %if case&8 # 0 %start;  !no change for '=','#'
 3743      case = case!!8
 3744      case = case!!4 %if case&2 # 0
 3745    %finish
 3746  %end
 3747  
 3748  ![Some confusion here of which operand (weightier) to evaluate first
 3749  ![                   and which to bring to register
 3750  ![EVAL improvements make possible greater finesse:
 3751  ![               1. Decide which to evaluate first (weightier)
 3752  ![               2. EVAL both 'val'
 3753  ![               3. If either in register, OK
 3754  ![               4. Load one
 3755  ![*for IMP, conditions cannot be embedded in other expressions;
 3756  ![*for Pascal, they can.  This needs improvement to cover that.
 3757  do(compare):
 3758    flush %if pendcond # 0
 3759    update sp
 3760    sp = c_sp
 3761    pp = pp+1;  dp == dict(pp)
 3762    case = dp_act
 3763    %if x <= 0 %start;  ![1st literal: only for true,false]
 3764      case = case!!1 %if x = 0;  !invert for false
 3765      pendcond = case&1+bra
 3766      -> endcomp
 3767    %finish
 3768    %if x >= explim %start;        !address
 3769      dx == dict(x-ad);  sx = 4
 3770    %else
 3771      dx == dict(x)
 3772      tx == dict(dx_type);  sx = size(dx_type)
 3773    %finish
 3774    dx_flags = dx_flags!rflag
 3775    %if y >= explim %or y <= 0 %then sy = 4 %else sy = tsize(y)
 3776    wx = 0 %and wy = 0 %and condswop %if c_reg_ccx = y %and c_reg_ccy = x
 3777    %if c_reg_ccx # x %or c_reg_ccy # y %start;  ![???unsigned???]
 3778      %if y # 0 %start;  !not comparison with zero
 3779        wx = weight(x);  wy = weight(y)
 3780        condswop %if wx < 999 %and wy > wx+1
 3781        %if x >= explim %or y >= explim %start;  !one or other is address
 3782          !swop if Y is not name (to use LEA)
 3783          condswop %if 0 <= y-ad < dictlim %and dict(y-ad)_flags >= 0
 3784          eval(x,anyareg)
 3785          eval(y,sign+anyareg)
 3786          plant(cmp,y,x)
 3787          c_reg_ccx = xx;  c_reg_ccy = yy
 3788        %finish %else %if sx > 0 %start;  !simple operand
 3789          %if tx_flags&cat = realy %start
 3790            eval(x,d0b);  eval(y,d1b)
 3791            srcall(fsub)
 3792            forget(x)
 3793            c_reg_ccx = xx;  c_reg_ccy = yy
 3794          %finish %else %if y < 0 %start;         !comparison with literal
 3795            %if y >= litmite %start
 3796              eval(x,val+sx<<sizeshift)
 3797              %if (sx = 4 %and free&anydreg # 0) %c
 3798+             %or (x > a7 %and dict(x)_mode&63 = pcmode) %start
 3799                eval(y,anydreg)
 3800                condswop %and sx = sy %unless x <= d7
 3801              %finish
 3802            %else
 3803              sx = 0 %if sx = 1;   ![to ensure comparison fails?]
 3804              eval(x,val+sx<<sizeshift)
 3805              sx = 2 %if a0 <= x <= a7 %and is short(litval(y))=TRUE
 3806            %finish
 3807            plant(cmp+sx<<8,y,x)
 3808            unsigned %if sx = 1
 3809            c_reg_ccx = xx;  c_reg_ccy = yy
 3810          %else;  !Y not literal
 3811            condswop %if sy < sx
 3812            eval(x,anyreg)
 3813            %if sy <= 2 %and sy = sx %and (sy=1 %or x < a0) %start
 3814              eval(y,val+sy<<sizeshift)
 3815              plant(cmp+sy<<8,y,x)
 3816              unsigned %if sy = 1
 3817              forget cc
 3818            %else
 3819              eval(y,val)
 3820              plant(cmp,y,x)
 3821              c_reg_ccx = xx;  c_reg_ccy = yy
 3822            %finish
 3823          %finish
 3824        %else;            !structure
 3825          stsiz = sx;  stsiz = -stsiz %if tx_flags&cat # stringy
 3826          %if (case&8 = 0 %and control&strassbit = 0) %C
 3827+         %or stringy # tx_flags&cat # sety %start
 3828            !equals,notequals or rec,array
 3829            ! [No routine call required to implement]
 3830            %if wy >= 999 %start;  !both complex
 3831              eval(x,tostack);  free = free!a0b
 3832              eval(y,anyareg&free+asad)
 3833              x = freeareg(undef)
 3834              plant(move,a7,x)
 3835            %else
 3836              eval(x,anyareg&free+asad)
 3837              forget(x)
 3838              eval(y,anyareg&free+asad)
 3839            %finish
 3840            i = free dreg
 3841            %if tx_flags&cat = stringy %start;  !string comparison
 3842              plant(clr,0,i)
 3843              plant(moveb,x+indir,i)
 3844            %else
 3845              plantlit(move,-sx-1,i)
 3846            %finish
 3847            plant(cmpmb,x+post,y+post)
 3848            plantlit2(dbne,i,-4)
 3849            forget(i);  forget(y)
 3850          %else
 3851           ! [Routine call required: must bring complex to stack]
 3852            %if wx >= 999 %start
 3853              eval(x,tostack);  free = free!a0b
 3854              %if wy >= 999 %start
 3855                stsiz = sy;  stsiz = -stsiz %if tx_flags&cat # stringy
 3856                eval(y,tostack)
 3857                y = a1;  plant(move,a7,y)
 3858                sy = (imod(sy)+1)&(\1);  sy = 256 %if sy = 0
 3859                x = a0;  plant(lea,tempd(a7,sy),x)
 3860              %else
 3861                eval(y,a1b+asad)
 3862                x = a0;  plant(move,a7,x)
 3863              %finish
 3864            %else
 3865              eval(x,a0b+asad);  eval(y,a1b+asad)
 3866            %finish
 3867  !<<IMP
 3868            srcall(scomp)
 3869            unsigned
 3870  !<<BOTH
 3871          %finish
 3872          forget cc
 3873        %finish
 3874      %else;  !comparison with zero
 3875        %if sx <= 0 %or (sx = 1 %and dx_mode >= dispmode) %start
 3876          %if tx_flags&cat = stringy %or sx = 1 %start
 3877            eval(x,ref)
 3878            plant(tst+1<<8,0,x)
 3879            forget cc;  !*for now*
 3880            unsigned
 3881          %else
 3882            eval(x,anyareg&free+asad)
 3883            i = free dreg
 3884            plantlit(move,-sx-1,i)
 3885            plant(tst+1<<8,0,x+post)
 3886            plantlit2(dbne,i,-4)
 3887            forget(i);  forget(x)
 3888          %finish
 3889        %else
 3890          eval(x,anydreg)
 3891          %if c_reg_ccx # xx %or c_reg_ccy # 0 %start
 3892            plant(move,x,x);  c_reg_ccx = xx;  c_reg_ccy = 0
 3893          %finish
 3894        %finish
 3895      %finish
 3896    %finish
 3897    pendcond = case
 3898  endcomp:
 3899    pendin = dp_x;  pendout = dp_y
 3900  checksp:
 3901    %if c_sp # sp %start
 3902      addimm(sp-c_sp,a7);  c_sp = sp
 3903    %finish
 3904  !<<IMP
 3905    %return
 3906  
 3907  do(resolves):
 3908    flush %if pendcond # 0
 3909    update sp
 3910    sp = c_sp
 3911  !  push(mb)
 3912  !  eval(x,a0b+asad);  !string to be resolved
 3913  !  act = dict(y)_act;  x = dict(y)_x;  y = dict(y)_y
 3914  !  eval(x,a1b);  eval(act,a0b<<2);  eval(y,a0b<<3);  !match, fore, aft
 3915  !  srcall(resolves)
 3916  !  pop(mb)
 3917  !  forget regs
 3918    dx == dict(act)
 3919    call
 3920    pp = pp+2;  dp == dict(pp)
 3921    pendcond = dp_act
 3922    -> endcomp
 3923  
 3924  !<<BOTH
 3925  !!!!!!!!!!!!!!!!!!!!!!!!   Assignment   !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 3926  !
 3927  %integerfn EASY(%integer y)
 3928  ! Determine if structure assignment (string, set)
 3929  !  can be done by store-to-store op(s) and if so, do it.
 3930  %integer r1,f
 3931  %record(identinfo)%name dy
 3932  %owninteger s=0
 3933    %result = FALSE %if y < np0
 3934    dy == dict(y)
 3935    %result = FALSE %if dy_act > concat %or dy_act = prel
 3936    f = free
 3937    %if dy_x = x %start;  !recursion ends, successfully
 3938      s = tsize(x);  s = -s %if dy_act # concat;  !+ve unless string
 3939      eval(x,a1b+asad)
 3940    %else
 3941      %result = FALSE %if dy_y >= np0 %or dy_y = x %c
 3942+     %or %not easy(dy_x)=TRUE
 3943    %finish
 3944    y = dy_y
 3945    %if y >= np0 %and dict(y)_act = dtostring %start
 3946      y = dict(y)_x;  eval(y,tobyte+val);  !character value
 3947      r1 = clean reg
 3948      plant(addb,one,x+indir);              !inc length(dest)
 3949      plant(moveb,x+indir,r1)
 3950      plant(moveb,y,tempx(x,r1));          !append char
 3951      forget(r1)
 3952    %else
 3953      eval(y,a0b+asad)
 3954      structcall(dy_act,s)
 3955      forget(a0);  forget(a1)
 3956      forget(d1);  forget(d2)
 3957    %finish
 3958    free = f&(\a1b)
 3959    %result = TRUE
 3960  %end
 3961  
 3962  %routine BEWARE(%integer dest)
 3963  ![not foolproof: ?too expensive to do properly
 3964  !                 too inefficient to fail safe]
 3965  %integer r,d
 3966  %integerfn UNSAFE(%integer p)
 3967  ![a bit cavalier]
 3968    %cycle
 3969      %result = FALSE %if p <= undef;        !literal, basereg or undef
 3970      %result = TRUE %if p = dest %or p = d {%or d >= np0
 3971      p = p-ad %if p >= explim
 3972      %result = FALSE %if p < np0
 3973      %result = TRUE %if dict(p)_act > opmax;  !funcall,mapcall
 3974      %result = TRUE %unless dest # dict(p)_y < np0
 3975      p = dict(p)_x
 3976    %repeat
 3977  %end
 3978    forget(dest) %and %return %if dest <= a7
 3979    d = dest;  d = d-ad %if d >= explim
 3980    %for r = d0,1,maxareg %cycle
 3981      forget(r) %if unsafe(c_reg_content(r))=TRUE
 3982    %repeat
 3983    forget cc %if unsafe(c_reg_ccx)=TRUE %or unsafe(c_reg_ccy)=TRUE
 3984  %end
 3985  
 3986  %integerfn XFREE(%integer v,strong)
 3987  %record(identinfo)%name dp
 3988    %cycle
 3989      v = v-ad %if v >= explim
 3990      %exit %if v < dictlim
 3991      dp == dict(v)
 3992      %result = FALSE %unless xfree(dp_y,1)=TRUE
 3993      strong = 1 %if dp_y >= dictlim
 3994      v = dp_x
 3995    %repeat
 3996    %result = TRUE %if v # x %or strong = 0
 3997    %result = FALSE
 3998  %end
 3999  
 4000  !<<IMP
 4001  do(forass):  !FORASS:loopvar:start'
 4002               ! --   :inc    :end
 4003    eval(y,d0b)
 4004    pp = pp+1;  dp == dict(pp)
 4005    i = dp_x;  eval(i,d1b);  i = dp_y;  eval(i,d2b)
 4006    srcall(forok)
 4007  !<<BOTH
 4008  do(jamass):
 4009  do(assign):
 4010  do(okass):
 4011    flush %if pendcond # 0
 4012    %if xx >= explim %start;  !ad of ...
 4013      wx = weight(xx-ad)
 4014      dx == dict(xx-ad)
 4015      sx = 4
 4016    %else
 4017      wx = weight(xx)
 4018      dx == dict(xx)
 4019      sx = size(dx_type)
 4020    %finish
 4021    tx == dict(dx_type)
 4022    sp = c_sp-c_val
 4023    %if sx <= 0 %start;  !structure assignment
 4024      !Structure
 4025      ![for rec/string assignment beware corruption of stacked
 4026      ! structure in computing DEST]
 4027      update sp
 4028      %if tx_flags&cat = stringy %start
 4029        sx = -256 %if sx = 0;   !string(*)
 4030        op = -1;  op = dict(y)_act %if y >= np0
 4031        %if y = 0 %start;  !""
 4032          eval(x,ref)
 4033          plant(clr+1<<8,0,x)
 4034        %finish %else %if op = dtostring %start
 4035          y = dict(y)_x
 4036          eval(y,tobyte+val);  !character value
 4037          eval(x,anyareg&free+asad)
 4038          plant(moveb,one,x+post)
 4039          plant(moveb,y,x+indir)
 4040          forget(x)
 4041          forget cc
 4042        %finish %else %if act = jamass %or %not easy(y)=TRUE %start
 4043          %if op >= concat %and wx > 1 %start
 4044          ! Danger of corruption of RHS
 4045            stsiz = sx
 4046            eval(y,tostack);  free = free!a0b
 4047            eval(x,a1b+asad)
 4048            plant(move,a7,a0);  y = a0
 4049            structcall(strcopy,sx)
 4050          %finish %else %if act # assign %or sx = -256 %or control&capbit = 0 %start
 4051          ! No check needed
 4052            %if wx > 1 %then eval(x,anyareg&free+asad) %and eval(y,anyareg&free+asad) %c
 4053+           %else eval(y,anyareg&free+asad) %and eval(x,anyareg&free+asad)
 4054  !not worth %if act # jamass %and sx >= -4 %start
 4055  !            %cycle
 4056  !              plant(moveb,y+post,x+post)
 4057  !              sx = sx+1
 4058  !            %repeat %until sx >= 0
 4059  !          %else
 4060              i = free reg(anydreg!bregb)
 4061              %if act = jamass %start
 4062                plantlit(move,mite(-sx-1),i)
 4063                plant(moveb,i,x+post)
 4064                plant(cmpb,y+post,i)
 4065                plantlit2(bcs,0,6);     ! 3 2-byte instructions **
 4066                plant(sub,one,x)
 4067                plant(moveb,y+pre,i)
 4068              %else
 4069                plant(moveb,y+indir,i);   !length (dirty OK)
 4070              %finish
 4071              plant(moveb,y+post,x+post)
 4072              plant(subb,one,i)
 4073              plantlit2(bcc,0,-6)
 4074              forget(i)
 4075  !          %finish
 4076          %else
 4077            %if wx > 1 %then eval(x,a1b+asad) %and eval(y,a0b+asad) %c
 4078+           %else eval(y,a0b+asad) %and eval(x,a1b+asad)
 4079            structcall(strcopy,sx)
 4080          %finish
 4081          forget(x);  forget(y)
 4082          forget cc
 4083        %finish
 4084      %finish %else %unless easy(y)=TRUE %start
 4085        eval(x,anyareg&free+asad) %if y = 0 %or wx > 1
 4086        %if y # 0 %start
 4087          sx = tsize(y) %if sx = 0
 4088          eval(y,anyareg&free+asad)
 4089          forget(y)
 4090          y = y+post
 4091          eval(x,anyareg&free+asad) %if wx <= 1
 4092        %finish
 4093        forget(x)
 4094        %if sx = 0 %then fault(sizerr) %else move block(y,x+post,-sx)
 4095      %finish
 4096      beware(xx)
 4097      -> checksp
 4098    %finish
 4099  !Simple operand
 4100    %if c_val # 0 %start
 4101      %if dx_val = sp %and dx_mode = c_mode %start
 4102        %if sx = 4 %or x >= explim %then c_val = c_val-4 %c
 4103+       %else c_val = c_val-2
 4104      %finish
 4105      update sp
 4106    %finish
 4107    op = move
 4108    case = val;  case = case+sx<<sizeshift %if sx # 4
 4109    %if x <= a7 %start;  !explicit assignment to reg
 4110      %if xfree(y,0)=TRUE %start
 4111        case = 1<<(x-d0);  free = free!case
 4112      %else
 4113        free = free&(\(1<<(x-d0)))
 4114      %finish
 4115    %finish
 4116    %if sx # 4 %and act = assign %and control&capbit # 0 %start
 4117      eval(y,d0b)
 4118      srcall(dx_type);  !range check
 4119    %finish
 4120    i = y;  i = i-ad %if i >= explim
 4121    %if i >= np0 %start;                        !SOURCE complex
 4122      %if dx_flags&okflag # 0 %or control&bassbit>>1<<sx = 0 %start
 4123        dy == dict(i)
 4124        %if y >= explim %start
 4125          %if dy_act = prel %and dy_x = x-ad %c
 4126+         %and (dy_y < 0 %or dy_type = bytetype) %start
 4127            y = dy_y
 4128            y = litref(litval(y)*imod(size(dy_type))) %if dy_type # bytetype
 4129            act = add
 4130            -> tostore
 4131          %finish
 4132        %else
 4133          %if dy_x = x %c
 4134+         %and (dy_act < neg %or (dy_act = neg %and dy_y = 0)) %start
 4135            act = dy_act;  y = dy_y
 4136            -> tostore
 4137          %finish
 4138        %finish
 4139      %finish
 4140      %if wx < 999 %then eval(y,case) %and eval(x,ref) %c
 4141+     %else eval(x,ref) %and eval(y,case)
 4142    %else
 4143      eval(x,ref)
 4144      %if y <= 0 %start
 4145        %if y = 0 %and dx_flags&readable # 0 %then op = clr %c
 4146+       %else %if y >= litmite %and sx = 4 %then eval(y,anydreg)
 4147      %else
 4148        eval(y,case) %unless y <= a7
 4149      %finish
 4150    %finish
 4151    %if y # x %start
 4152      %if 0 < y <= maxareg %and 0 < yy = c_reg_content(y) %start
 4153        beware(xx)
 4154        c_reg_content(y) = xx
 4155      %finish %else beware(xx)
 4156      plant(op+(sx&3)<<8,y,x)
 4157      c_reg_ccx = xx;  c_reg_ccy = 0
 4158    %finish %else beware(xx)
 4159  endass:
 4160    dx_flags = dx_flags!okflag %if c_localdpos <= xx < dictlim %c
 4161+            %and c_forward = 0
 4162    %return
 4163  
 4164  do(incass):  !(for %for loop)
 4165    flush %if pendcond # 0
 4166    dx == dict(xx)
 4167    sx = size(dx_type)
 4168    wx = weight(x)
 4169    act = add
 4170  tostore:
 4171    %if y = 0 %start;  ![only for NOT,NEG]
 4172      eval(x,ref)
 4173    %finish %else %if y < 0 %start
 4174      %if act = add %start;  ![+- literal]
 4175        %if y >= litquick %start;  !-8:-1 or 1:8
 4176          act = sub %and y = y-1 %if y&1 # 0;  !negate if neg
 4177          eval(x,ref)
 4178          -> past
 4179        %finish
 4180        act = sub %and y = y+1 %if y = -(128<<1);  !128=>-128
 4181      %finish
 4182      eval(x,ref)
 4183      eval(y,anydreg) %if y >= litmite %and anydreg&free # 0
 4184    %finish %else %if x <= a7 %start
 4185      eval(y,val)
 4186    %else
 4187      %if 999 > wx < weight(y) %then eval(y,anydreg) %and eval(x,ref) %c
 4188+     %else eval(x,ref) %and eval(y,anydreg)
 4189    %finish
 4190  past:
 4191    plant(act+sx<<8,y,x)
 4192    plant(trapv,0,0) %if control&overbit # 0 %and act <= sub
 4193    beware(xx)
 4194    c_reg_ccx = xx;  c_reg_ccy = 0
 4195    ->endass
 4196  
 4197  
 4198  !!!!!!!!!!!!!!!!!!!!!!   Returns and jumps   !!!!!!!!!!!!!!!!!!!!!!!!
 4199  !
 4200  do(return):                 !terminate procedure
 4201    update sp
 4202    %if c_type # 0 %start;       !function,map
 4203      r = typecell(c_dpid_type)_reg&15
 4204      %if c_type > 0 %and size(c_type) > 0 %start;  !simple fn
 4205        flush %if pendcond # 0 %and pendin # 0
 4206        i = y
 4207        %if c_reg_content(r+d0) # y %start
 4208          flush %if pendcond # 0
 4209          eval(y,d0b<<r)
 4210        %finish
 4211        c_status = c_status!wrongcc %unless c_reg_ccx = i %and c_reg_ccy = 0
 4212      %else;   !struct fn or map
 4213        c_status = c_status!wrongcc
 4214        flush %if pendcond # 0
 4215        y = y+ad %if c_type > 0;  !ie struct fn
 4216        sp = c_sp
 4217        eval(y,d0b<<r)
 4218        %if c_sp # sp %start
 4219          addimm(sp-c_sp,a7);  c_sp = sp
 4220        %finish
 4221      %finish
 4222    %finish
 4223    %if c_temps # 0 %start
 4224      flush %if pendcond # 0
 4225      addimm(c_temps,a7)
 4226    %finish
 4227    dict(dictlim)_val = c_return
 4228    compile uncond branch(dictlim)
 4229    c_return = -(pc-1)
 4230    %return
 4231  
 4232  do(jumpout):
 4233    update sp
 4234    flush %if pendcond > 0 %and pendin # 0
 4235    save context(y) %if y # x;  !exit not continue
 4236    compile uncond branch(y)
 4237    %return
 4238  
 4239  do(repeat):
 4240    update sp
 4241    compile uncond branch(x)
 4242    define label(x+1) %if dict(x+1)_val < 0
 4243    %if y < 0 %start;  !temp(s) declared
 4244      c_val = y;  c_temps = c_temps+y;  !decrement temps
 4245      update sp
 4246    %finish
 4247    %return
 4248  
 4249  do(else):
 4250    %if c_access # 0 %and c_access # -2 %start
 4251      save context(y)
 4252      compile uncond branch(y);  !outward branch for %else
 4253    %finish
 4254    define label(x) %if x # 0 %and dict(x)_val < 0;  !inward from false cond
 4255    %return
 4256  
 4257  do(goto):                        !user jump
 4258    update sp
 4259    c_forward = c_forward+1 %if dict(y)_val = 0
 4260    addimm(c_temps,a7) %if c_temps # 0
 4261    i = pendcond
 4262    compile uncond branch(y)
 4263    addimm(-c_temps,a7) %if i # 0 %and c_temps # 0
 4264    %return
 4265  
 4266  do(label):
 4267    update sp
 4268    define label(x)
 4269    %return
 4270  
 4271  do(stop):
 4272    update sp
 4273    flush %if pendcond # 0
 4274    plant(clr,0,d0)
 4275    srcall(signal)
 4276    c_access = 0
 4277    %return
 4278  
 4279  do(signal):
 4280    update sp
 4281    flush %if pendcond # 0
 4282    sp = c_sp
 4283    pp = pp+1;  dp == dict(pp)
 4284    xx = dp_x;  yy = dp_y
 4285    x = litval(x)
 4286    %if yy # undef %start
 4287      eval(yy,a0b+asad);  x = x+64
 4288    %finish
 4289    %if xx # undef %start
 4290      eval(xx,d2b);  x = x+32
 4291    %finish
 4292    %if y # undef %start
 4293      eval(y,d1b);  x = x+16
 4294    %finish
 4295    x = litref(x)
 4296    eval(x,d0b)
 4297    %if control&sysbit # 0 %then plant(jmp,0,signal) %else plant(jsr,0,signal)
 4298    %if c_sp # sp %start;  ![earlier?]
 4299      addimm(sp-c_sp,a7);  c_sp = sp
 4300    %finish
 4301    c_access = 0
 4302    %return
 4303  
 4304  do(settrap):
 4305    update sp
 4306    push(d0+6);                     ![historical]
 4307    push(mb)
 4308    plant(pea,0,temp(pcmode,10));  !address of mask [2+2+2+4]
 4309    c_sp = c_sp-4
 4310    push(gb+indir);                ![2 bytes]
 4311    plant(move,a7,gb+indir);       ![2 bytes]
 4312    c_eventsp = c_sp
 4313    c_forward = c_forward+1
 4314    lreg(c_lab1-dictlim) = c_reg
 4315    plant(bra,0,c_lab1);           ![4 bytes]
 4316    pflag(pc-1) = longjump;  !**not to be shortened
 4317    forget regs
 4318    plant(dc,0,temp(absmode,litval(y)));  !event mask
 4319  !  store(litval(y),0);  !event mask
 4320    %return
 4321  
 4322  do(swgoto):                     !switch jump
 4323    flush %if pendcond # 0
 4324    update sp
 4325    dx == dict(x)
 4326    dx_flags = dx_flags!rflag
 4327    i = dx_val;  !start of table
 4328    dy == typecell(dx_type)
 4329    get bounds(dy_xtype,sx,sy)
 4330    %if y <= 0 %start;  !literal subscript
 4331      y = litval(y)
 4332      i = i+y-sx
 4333      addimm(c_temps,a7) %if c_temps # 0
 4334      plant(bra,0,temp(labmode,prog(i)))
 4335      prog(i) = dtemp_val;               !updated by PCREL
 4336    %else
 4337      eval(y,d0b)
 4338      %if i > pc %start;                  !first jump (I >= SWPC)
 4339        c_forward = c_forward+(sy-sx+1)
 4340        %if dx_flags&arrflag = 0 %start;  !no check
 4341          addimm(c_temps,a7) %if c_temps # 0
 4342          plant(lea,temp(pcmode,10-sx-sx),a0); !LEA ?(PC),A0
 4343          plant(add,d0,d0);                 !ADD D0,D0
 4344        %else
 4345          wx = 12
 4346          %if c_temps # 0 %start
 4347            wx = wx+2;  wx = wx+2 %if c_temps > 8
 4348          %finish
 4349          plant(lea,temp(pcmode,wx),a0)
 4350          srcall(index)
 4351          addimm(c_temps,a7) %if c_temps # 0
 4352        %finish
 4353        plant(add+2<<8,tempx(a0,d0),a0); !ADD.W 0(A0,D0),A0
 4354        plant(jmp,0,a0+indir);         !JUMP (A0)
 4355        %if dx_flags&arrflag # 0 %start
 4356          store(sy>>16,0);  store(sy,0)
 4357          store(sx>>16,0);  store(sx,0)
 4358          store(0,0);  store(2,0)
 4359        %finish
 4360        dx_val = pc
 4361        %cycle
 4362          store(prog(i),0)
 4363          swpc = swpc+1 %if i = swpc;  i = i+1
 4364          sx = sx+1
 4365        %repeat %until sx > sy
 4366      %else;  !just branch to earlier sequence
 4367              ![gives wrong line number for error]
 4368              ![wrong if temps]
 4369        i = i-7 %if dx_flags&arrflag # 0
 4370        plant(bra,0,temp(labmode,i-6))
 4371      %finish
 4372    %finish
 4373    c_access = 0
 4374    %return
 4375  
 4376  do(asize):
 4377    %if y # 0 %start;  !first: prime D0
 4378      update sp
 4379      eval(y,d0b);  !basic itemsize
 4380    %else
 4381      srcall(asize)
 4382    %finish
 4383    pp = pp+1;  dp == dict(pp)
 4384    xx = dp_x;  yy = dp_y
 4385    free = c_free-d0b;  !not d0
 4386    eval(xx,d1b);  !lower
 4387    eval(yy,d2b);  !upper
 4388    push(d0);  !size
 4389    push(d1);  push(d2)
 4390    forget regs
 4391    free = free!(d1b+d2b)
 4392    dict(x)_val = c_sp
 4393    %return
 4394  !
 4395  do(adok):  ![spare code]
 4396  !Push size of dynamic array (& 0-base value) for AGET
 4397    update sp
 4398    %if x # 0 %start
 4399      %if x # d0 %then eval(x,d0b) %else srcall(asize)
 4400    %finish
 4401    push(y) %if y # 0
 4402    push(d0)
 4403    %return
 4404  
 4405  do(aget):
 4406    plant(move,x,d0)
 4407    srcall(aget)
 4408    plant(move,a7,x)
 4409    %if y # 0 %start
 4410      dx == dict(x)
 4411      dx_val = dx_val+4
 4412      plant(move,a7,d0)
 4413      plant(add,d0,x)
 4414      dx_val = dx_val-4
 4415    %finish
 4416    forget(d0);  forget(a0)
 4417    %return
 4418  
 4419  %routine COMPILE ENTRY(%integer linked,arg)
 4420  !Entry sequence generated at end
 4421  %integer i,r,vsp,lastvsp,holdsp
 4422  %record(identinfo)%name darg,tp
 4423    holdsp = c_sp
 4424    c_sp = 0;  lastvsp = 0
 4425    c_stack = c_stack-4 %if linked > 0;  !allow for link
 4426    %if linked = 0 %and c_status&onstack # 0 %start
 4427      !justify addressing assumed for onstack parameters
 4428      c_sp = 4;  holdsp = holdsp-4;  c_stack = c_stack-4
 4429    %finish
 4430    c_stack = c_stack-4;              !and return address
 4431    c_totstack = c_stack %if c_stack < c_totstack
 4432    %if control&stackbit # 0 %c
 4433+   %and (c_status&unknown # 0 %or c_totstack < -128) %start
 4434      plantlit(move,c_stack,breg);  !*ok - gets cleared*
 4435      srcall(stackok)
 4436    %finish
 4437    %if level > outerlevel %and linked > 0 %start;  !link required
 4438      %if level > 1 %start
 4439        plant(move,tempd(gb,level<<2),prea7);  !MOVE ?(GB),-(SP)
 4440        plant(move,a7,tempd(gb,level<<2));  !MOVE SP,?(GB)
 4441      %else
 4442        plant(link,0,f1);       !LINK #0,Ax
 4443      %finish
 4444    %finish
 4445    darg == dict(arg)
 4446    %cycle
 4447      arg = darg_link
 4448      %exit %if arg = 0
 4449      darg == dict(arg)
 4450      %if darg_val <= 0 %start;  !passed in reg, not on stack
 4451        vsp = darg_val
 4452        r = darg_reg&15+d0
 4453        %if darg_flags&mflag # 0 %or linked > 0 %start
 4454          addimm(lastvsp-c_sp,a7);  c_sp = lastvsp
 4455          i = nsize(darg)
 4456          %if i > 0 %start
 4457            ! name or simple operand by value
 4458           !NB MOVE.B transfers to hi byte
 4459            plant(move+i<<8,r,prea7)
 4460          %finish %else %if darg_flags&proc # 0 %start;  !proc as param
 4461            plant(move,r,prea7)
 4462            plantlit(movew,16_4EF9,prea7)
 4463          %else;                          !structure by value
 4464            tp == typecell(darg_type)
 4465            %if tp_flags&cat = stringy %start
 4466              %if control&capbit # 0 %and tp_size > -256 %start
 4467                plantlit(cmp+1<<8,-tp_size,r+indir)
 4468                plantlit2(bcs,0,4)
 4469                srcall(check)
 4470              %finish
 4471              i = c_sp-vsp
 4472              addimm(-i,a7);            !SP = SP-bytes
 4473              extend stack(i)
 4474             !MOVE.B length,Dx
 4475              plant(moveb,r+indir,breg)
 4476             !MOVE.B 0(Ay,Dx),0(SP,Dx)
 4477              plant(moveb,tempx(r,breg),tempx2(a7,breg))
 4478              plant(subb,one,breg)
 4479              plantlit2(bcc,0,-10)
 4480            %else;  !fixed length structure
 4481              free = bregb
 4482              push block(r,c_sp-vsp)
 4483            %finish
 4484          %finish
 4485          c_sp = vsp
 4486        %finish
 4487        lastvsp = vsp
 4488      %finish
 4489    %repeat
 4490    %if c_sp # 0 %start;  !there are accesses to params
 4491      addimm(lastvsp-c_sp,a7)
 4492      c_sp = holdsp
 4493    %finish %else c_sp = holdsp-lastvsp;  !reduce
 4494  %end
 4495  
 4496  do(end):
 4497    compile entry(c_status&globbed,c_dpid_type)
 4498    %return
 4499  
 4500  do(*): intern(8)
 4501  do(0):  !null action
 4502  %end;
?ENDCONC unused
?OP3 unused
?MORE unused
?TOSHORT unused
?ADDW unused
 4503       ;  !eval
 4503  
 4504  %routine COMPILE(%integer startp)
 4505  %integer p
 4506  {?}  show exp(startp) %if control&explist # 0 %and control&list # 0
 4507    np = np0 %and %return %if faultnum > 0
 4508    pendcond = 0
 4509    p = startp-1
 4510    %cycle
 4511      free = c_free
 4512      p = p+1
 4513      %if p >= np %start
 4514        %if startp = np0 %start
 4515          np = np0
 4516          flush %if pendcond > 0
 4517          %return
 4518        %finish
 4519        np = startp;  startp = np0;  p = startp
 4520      %finish
 4521      %if c_reg_line # line %and control&(tracebit!diagbit!linebit) # 0 %start
 4522        flush %if pendcond > 0
 4523        pendcond = -1
 4524      %finish
 4525      eval(p,inst)
 4526    %repeat
 4527  %end;  !compile
 4528  
 4529  %routine SET FIRST ENTRY
 4530  %integer j,k,p
 4531  %record(identinfo)%name dp
 4532    firstpos = dictlim;  firstentry = finalbound
 4533    p = 0
 4534    %cycle
 4535      p = p+1
 4536      %exit %if p >= dlim
 4537      dp == dict(p)
 4538      %continue %if dp_mode # procmode
 4539      %continue %if dp_val >= firstentry
 4540      j = dp_val
 4541      %if j <= 0 %start
 4542        %continue %if j = 0
 4543        k = -j
 4544        %cycle
 4545          j = k<<1
 4546          k = code word(j)&16_FFFF
 4547        %repeat %until k = 0
 4548        %continue %if j >= firstentry
 4549      %finish
 4550      firstentry = j;  firstpos = p
 4551    %repeat
 4552  %end
 4553  
 4554  %routine DEFINE ENTRY(%integer chain,entry,pid)
 4555  %integer j
 4556    %cycle
 4557      chain = chain<<1
 4558      report(reacherr,pid,0) %unless is short(entry-chain)=TRUE
 4559      j = code word(chain)&16_FFFF
 4560  !$IF VAX
 4561  {  final(chain) <- (entry-chain)>>8;  final(chain+1) <- entry-chain
 4562  !$IF APM
 4563    shortinteger(final0+chain) <- entry-chain
 4564  !$FINISH
 4565      chain = j
 4566    %repeat %until chain = 0
 4567  %end
 4568  
 4569  %routine CHECK REACH(%integer blocksize)
 4570  !Add stepping stones if necessary
 4571  %integer i
 4572    %cycle
 4573      i = blocksize+cad
 4574      croak("Program too big") %if i >= ownbase
 4575      %return %if i-firstentry < 31000;  !enough leeway
 4576      %return %if blocksize >= 32000 %or cad-firstentry >= 32760;  !hopeless
 4577      %if dict(firstpos)_val < 0 %start
 4578        define entry(-dict(firstpos)_val,cad,firstpos)
 4579        set code word(16_6000);  !BRA
 4580        dict(firstpos)_val = -cad>>1
 4581        set code word(0)
 4582      %else
 4583        dict(firstpos)_val = cad
 4584        set code word(16_6000);  !BRA
 4585        set code word(firstentry-cad)
 4586      %finish
 4587      steps = steps+2
 4588      set first entry
 4589    %repeat
 4590  %end
 4591  
 4592  %routine PUT WORD(%integer v)
 4593      printsymbol(v>>8&255);  printsymbol(v&255)
 4594  %end
 4595  
 4596  %routine DO EXTERNALS(%integer chain,specs)
 4597  %integer k,a,b
 4598  %record(identinfo)%name dp,tp
 4599  
 4600    byteinteger(charlim) = 0;  ![see test for %alias]
 4601    value = 2
 4602    %cycle
 4603      dp == dict(chain)
 4604      a = dp_text+char0;  b = byteinteger(a)
 4605      %if byteinteger(a+b+1)&128 # 0 %start;  !aliased
 4606        a = a+b+1;  b = byteinteger(a)-128
 4607      %finish
 4608      value = value+(b+14)&(\1)
 4609      %if specs >= 0  %start;  !for real
 4610        put word(dp_flags&(ext+proc)!sign16)
 4611        put word(dp_mode)
 4612        k = 0
 4613        %if dp_flags&proc # 0 %start
 4614         !create type word
 4615          tp == dict(dp_type)
 4616          k = 4;  k = 6 %if tp_type # 0;  !100:R 11x:F,M
 4617          %cycle
 4618            k = k+1 %if tp_reg&8 # 0;    !0:dreg, 1:areg
 4619            %exit %if tp_link <= 0
 4620            tp == dict(tp_link);  k = k<<1
 4621          %repeat
 4622          !special code (11) for %routine ...(%string(255) parm)
 4623          k = k+2 %if k = 9 %and tp_type = stringtype %and tp_flags >= 0
 4624        %finish
 4625        put word(k>>16);  put word(k)
 4626        put word(dp_val>>16);  put word(dp_val)
 4627        put word(b<<8+byteinteger(a+1))
 4628        %cycle
 4629          a = a+2;  b = b-2
 4630          %exit %if b < 0
 4631          k = byteinteger(a)<<8
 4632          k = k+byteinteger(a+1) %if b > 0
 4633          put word(k)
 4634        %repeat
 4635      %finish
 4636      chain = dp_link
 4637    %repeat %until chain = 0
 4638    %if specs >= 0 %start
 4639      put word(0)
 4640      put word(0) %if value&3 # 0
 4641    %finish
 4642    value = (value+3)&(\3)
 4643  %end
 4644  !
 4645  %routine PUTACT(%integer act,x,y)
 4646    dict(np)_act = act;  dict(np)_x = x;  dict(np)_y = y
 4647    np = np+1
 4648  %end
 4649  
 4650  %routine COMPILE END
 4651  %integer i,j,x,y,entry,lim
 4652    %if c_reg_line # line %and control&(diagbit!linebit!tracebit) # 0 %c
 4653+   %and level > outerlevel %and c_access # 0 %start
 4654      pendcond = -1
 4655      flush
 4656    %finish
 4657    !Pop event block
 4658    %if c_eventsp # 0 %start
 4659      plant(move,temp(c_mode,c_eventsp),gb+indir)
 4660      forget cc
 4661    %finish
 4662  !Put pre-amble
 4663    codeflag = '^';  x = pc;  !preserve
 4664    putact(end,0,0)
 4665    compile(np0)
 4666    fill code(1) %if cad&1 # 0
 4667    check reach((pc-c_localpc)<<1)
 4668    entry = cad
 4669    y = x
 4670    %while y < pc %cycle
 4671      %if pflag(y) = indglobal %then set code word(dict(prog(y))_val-cad) %c
 4672+     %else set code word(prog(y))
 4673      y = y+1
 4674    %repeat
 4675    codeflag = ' ';  pc = x;  !restore
 4676  !Generate final sequence
 4677    %if c_access # 0 %start
 4678      %if level > outerlevel %and c_status&globbed # 0 %start
 4679        %if level > 1 %start;  !display in store
 4680          plant(move,tempd(gb,level<<2),a7);     !MOVE ?(GB),SP
 4681          plant(move,posta7,tempd(gb,level<<2)); !MOVE (SP)+,?(GB)
 4682          forget cc
 4683        %else
 4684          plant(unlk,0,f1)
 4685        %finish
 4686      %finish %else %if c_sp < 0 %start;  !some stack extension
 4687        addimm(-c_sp,a7)
 4688      %finish
 4689      %if level > outerlevel %start
 4690        c_dpid_flags = c_dpid_flags!okflag %if c_type > 0 %c
 4691+           %and c_status&wrongcc!c_reg_ccx!c_reg_ccy = 0
 4692        plant(rts,0,0)
 4693      %else
 4694        plant(move,0,d0);  srcall(signal);  !%stop
 4695      %finish
 4696    %else;  !no return from procedure
 4697      c_dpid_flags = c_dpid_flags!noret
 4698    %finish
 4699  !Set start address
 4700    x = c_dpid_val
 4701    define entry(-x,entry,c_pid) %if x < 0;  !forward refs in FINAL
 4702    c_dpid_val = entry
 4703  !
 4704    lim = cad+(pc-c_localpc-c_shorts+zeroshorts)<<1
 4705    x = c_localpc;  c_shorts = zeroshorts;  !reset
 4706    %while x < pc %cycle
 4707      y = prog(x);  j = pflag(x)
 4708      %if j # 0 %start
 4709        %if j < zeroshorts %start
 4710          %if j <= longjump %start;  !shortjump/jump/longjump
 4711            jumps = jumps+1
 4712            y = (y-pflag(y)-x+c_shorts)<<1
 4713            %if j = shortjump %start
 4714              cad = cad-2
 4715              y = prog(x-1)+y&255
 4716              c_shorts = c_shorts+1
 4717            %finish
 4718          %finish %else %if j = indglobal %start;  !procedure
 4719            i = dict(y)_val
 4720            %if i <= 0 %start;  !not yet encountered
 4721              dict(y)_val = -(cad>>1);  y = -i
 4722            %else
 4723              i = i-cad
 4724              report(reacherr,y,0) %unless is short(i)=TRUE
 4725              y = i
 4726            %finish
 4727          %else {global,negglobal,bigglobal}
 4728            %if j # global+1 %start
 4729              y = y&16_FFFF
 4730              y = y+65536 %if j # global;  !bigglobal
 4731            %finish
 4732            y = y-cad
 4733            %unless is short(y)=TRUE %start
 4734              %if prog(x-1)&16_F1FF # 16_41FA %start;  !LEA (PC),Ax
 4735                report(creacherr,0,cad)
 4736              %else
 4737                i = cad;  cad = lim
 4738                set code word(prog(x-1)!!(16_41FA!!16_207C)); !MOVEI #,Ax
 4739                set code longword(y-2)
 4740                set code word(prog(x-1)!!(16_41FA!!16_D1D7)); !ADD (SP),Ax
 4741                set code word(16_4E75);                       !RTS
 4742                lim = cad;  cad = i-2
 4743                set code word(16_6100);  !BSR
 4744                y = lim-10-cad
 4745                steps = steps+5
 4746              %finish
 4747            %finish
 4748          %finish
 4749        %finish
 4750      %finish
 4751  !$IF VAX
 4752  {    final(cad) <- y>>8;  final(cad+1) <- y
 4753  !$IF APM
 4754      shortinteger(final0+cad) <- y
 4755  !$FINISH
 4756      cad = cad+2
 4757      x = x+1
 4758    %repeat
 4759    cad = lim
 4760    forget all
 4761  %end;  !compile end
 4762  
 4763  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 4764  !!!!!!!!!!!!!!!  end of Code Generation  !!!!!!!!!!!!!!!!!!!!!!!
 4765  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 4766  !
 4767  !<<IMP
 4768  %routine TOPRED
 4769    item = litref(value) %if item = 0
 4770    putact(compare,item,0)
 4771    condop = bne!!polarity
 4772    item = np-1
 4773  %end
 4774  !<<BOTH
 4775  !
 4776  %routine RESET CONTEXT(%integer pid,free)
 4777    starts = 0;  cycles = 0
 4778    c = 0
 4779    forget all
 4780    c_localdpos = dlim;  c_parlim = dlim;  c_localtext = charlim
 4781    c_localpc = pc;  c_localswpc = swpc;  c_lab1 = curlab
 4782    c_shorts = zeroshorts;  c_free = free
 4783    c_mode = framemode+level;  c_vintage = vintage
 4784    c_pid = pid;  c_dpid == dict(c_pid)
 4785  %end
 4786  
 4787  %routine OPEN BLOCK(%integer pid)
 4788    forget regs;  !a bit extreme, but don't want to let LIT/EXP
 4789                   ! get out of hand so RESET CONTEXT forgets triples
 4790    croak("Too many levels") %if level = maxlevel
 4791    c_oldcontrol = control
 4792    hold(level) = c;  level = level+1;  vintage = vintage+1
 4793    reset context(pid,c_free)
 4794    c_access = 1;  c_localad = cad-accounted
 4795  %end;  !OPEN BLOCK
 4796  
 4797  %integerfn PARMATCH(%integer apos,bpos)
 4798  %record(identinfo)%name ap,bp,atp,btp
 4799    %cycle
 4800      ap == dict(apos);  bp == dict(bpos)
 4801      %result = FALSE %if ap_flags!!bp_flags < 0
 4802      {%result = FALSE %if ap_mode # bp_mode}
 4803      %if ap_type # bp_type %start
 4804        ![for now -- nominal]
 4805        atp == typecell(ap_type);  btp == typecell(bp_type)
 4806        %result = FALSE %unless atp_flags&cat = arry = btp_flags&cat
 4807      %finish
 4808      apos = ap_link;  bpos = bp_link
 4809      %if apos = 0 %start
 4810        %result = FALSE %if bpos # 0
 4811        %result = TRUE
 4812      %finish %else %if bpos = 0 %start
 4813        %result = FALSE
 4814      %finish
 4815    %repeat
 4816  %end
 4817  
 4818  %integer%fn CRUNCHED(%integer p)
 4819  %record(identinfo)%name dq,dp
 4820  %owninteger q=0,l=0
 4821    dp==dict(p)
 4822    dp_text = 0;  q = 0
 4823    l = dp_link
 4824    %if l # 0 %start
 4825      l = crunched(l) %if dp_type < p
 4826      %result = p %if p <= l
 4827      dp_link = l
 4828      q = l-1
 4829    %finish
 4830    dq == dict(q)
 4831    %while q < p %cycle
 4832      %if dq_type = dp_type %c
 4833+     %and dq_link = l %and dq_reg = dp_reg %and dq_val = dp_val %start
 4834        dlim = p
 4835        %result = q
 4836      %finish
 4837      q = q+1;  dq == dict(q)
 4838    %repeat
 4839    %result = p
 4840  %end
 4841  
 4842  %routine POP CONTEXT
 4843    pc = c_localpc;  swpc = c_localswpc;  curlab = c_lab1
 4844    dlim = c_parlim
 4845  !  %for i = 0,1,255 %cycle
 4846  !    hashindex(i) = dict(hashindex(i))_hlink %while hashindex(i) >= c_localdpos
 4847  !  %repeat
 4848    %if level > outerlevel %start
 4849      charlim = c_localtext
 4850      ranges = dict(ranges)_hlink %while ranges >= c_parlim
 4851      c_dpid_type = crunched(c_dpid_type)
 4852      level = level-1;  c = hold(level)
 4853      control = control&editbit ! c_oldcontrol&(\editbit)
 4854    %finish
 4855    dictshown = dlim %if dictshown > dlim
 4856    starts = 0;  cycles = 0
 4857  %end
 4858  
 4859  %routine FIXUP SWITCH VECTOR(%integer pos,%record(identinfo)%name dp)
 4860  %integer x,y,j,default,temp,lo,hi
 4861  %record(identinfo)%name tp
 4862    tp==typecell(dp_type)
 4863    x = dp_val
 4864    default = dp_link;  default = pc %if default = 0
 4865    get bounds(tp_xtype,lo,hi)
 4866    %if dp_flags&arrflag = 0 %then j = pflag(x-1)+lo %c
 4867+   %else j = pflag(x-7);  !allow for dope info
 4868    j = x-j;  !base position
 4869    %while lo <= hi %cycle;  !For each element
 4870      y = prog(x)
 4871      %if y <= 0 %start;  !not set
 4872        %if dp_link = 0 %start;  !no default
 4873          report(slabmissing+warn,pos,lo)
 4874          c_access = 1
 4875        %finish
 4876        %if y < 0 %start;  !explicit jump(s) to this one
 4877          y = -y
 4878          %cycle;  !define jumps to default
 4879            temp = y;  y = prog(temp);  prog(temp) = default
 4880          %repeat %until y = 0
 4881        %finish
 4882        y = default
 4883      %finish
 4884      prog(x) = (y-pflag(y)-j)<<1
 4885      x = x+1;  lo = lo+1
 4886    %repeat
 4887  %end
 4888  
 4889  %routine CLOSE BLOCK
 4890  %integer miss,under,pos,base
 4891  %record(identinfo)%name dp
 4892   ! WRONGCC is clear if all %result statements leave correct CC
 4893    %if c_type > 0 %and c_status&wrongcc = 0 %start
 4894     ! set special values and see if they survive exit sequence
 4895      c_reg_ccx = 0;  c_reg_ccy = 0
 4896    %finish
 4897    %if c_return # 0 %start
 4898      %if c_return = -(pc-1) %and c_access = 0 %start
 4899        c_return = -prog(pc-1);  pc = pc-2 
 4900      %finish
 4901      define jumps(c_return);  !must precede switch fixup
 4902      c_access = -1
 4903    %finish
 4904    pflag(pc) = c_shorts;      !in case of terminal switch labels
 4905    %if c_status&hadswitch # 0 %start
 4906      pos = c_localdpos
 4907      %while pos < dlim %cycle
 4908        dp == dict(pos)
 4909        fixup switch vector(pos,dp) %if dp_mode = labmode %and dp_type # 0
 4910        pos = pos+1
 4911      %repeat
 4912    %finish
 4913    compile end
 4914    c_totstack = c_totstack-c_extra
 4915    c_totstack = -c_totstack %if c_status&unknown = 0;  !positive if firm
 4916    typecell(c_dpid_type)_val = c_totstack
 4917  {?}  %if control&maplist # 0 %start
 4918  {?}    put ident(c_pid,0)
 4919  {?}    mark at(20)
 4920  {?}    put string(" code:")
 4921  {?}    put num(cad-c_localad-accounted)
 4922  {?}    put string("  entry:")
 4923  {?}    put num(c_dpid_val-c_localad-accounted)
 4924  {?}    put string("  stack:");  put num(-c_stack)
 4925  {?}    putsym('/');  put num(imod(c_totstack))
 4926  {?}    put sym('+') %if c_totstack < 0
 4927  {?}    accounted = cad-c_localad
 4928  {?}    print line
 4929  {?}  %finish
 4930    !Check identifier usage
 4931    miss = 0;  under = 0
 4932    base = c_localdpos;  base = 0 %if level = outerlevel
 4933    pos = dlim;  dp == dict(pos)
 4934    %while pos > base %cycle
 4935      pos = pos-1;  dp == dict(pos)
 4936      %if dp_flags&ext = 0 %start
 4937  !<<IMP
 4938  !<<BOTH
 4939        %if dp_text > 0 %start;               !user id
 4940          set hashhead(string(dp_text+char0))
 4941          %if head = pos %start;              !still active
 4942            head = dp_hlink;                  !remove from hash list
 4943  check:    %if dp_flags&spec # 0 %start
 4944              dp_hlink = miss;  miss = pos
 4945            %finish %else %if ((dp_flags&(readable+rflag) = readable %and dp_mode # litmode) %c
 4946+             %or (dp_flags&(writable+okflag+wflag+spec) = writable)) %c
 4947+             %and pos >= c_localdpos %and dp_mode # 0 %and dp_flags&typeid = 0 %c
 4948+             %and control&(list!maplist) # 0 %start
 4949              dp_hlink = under;  under = pos
 4950            %finish
 4951          %finish
 4952        %finish
 4953      %finish %else %if level = outerlevel %start;  !external, external spec
 4954        %if dp_flags&spec = 0 %start;  !external object
 4955          dp_link = externs;  externs = pos
 4956        %finish %else %if dp_flags&(rflag+wflag) # 0 %start
 4957         !external spec (used)
 4958          dp_link = extspecs;  extspecs = pos
 4959        %finish
 4960      %finish
 4961    %repeat
 4962    report(idmissing,miss,0) %if miss # 0
 4963    %if under # 0 %and c_faults = 0 %start
 4964      put ident(under,1)
 4965      put string(" underused")
 4966      print line
 4967    %finish
 4968    pop context
 4969    set first entry %if firstpos >= dlim
 4970  %end;
?CHECK unused
 4971       ;  !CLOSE BLOCK
 4971  
 4972  %routine ERROR(%integer case)
 4973    faultp = atomp
 4974    report(case,0,0)
 4975    %signal fail
 4976  %end
 4977  
 4978  %constinteger DUD=63
 4979  %routine SYNTAX ERROR
 4980    %if atom = dud %then error(atomerr+point) %else error(formerr+point)
 4981  %end
 4982  
 4983  %routine EXPFAULT(%integer case)
 4984    %if faultnum = 0 %or expp < faultp %start
 4985      faultnum = case!point;  faultp = expp
 4986    %finish
 4987  %end
 4988  
 4989  %routine NONSTANDARD(%integer case)
 4990  %integer b
 4991  %owninteger hadit=0
 4992    b = 1<<case
 4993    %if b&hadit = 0 %and control&nonsbit = 0 %and faultnum = 0 %start
 4994      hadit = hadit+b;  faultp = atomp
 4995      %if control&strictbit # 0 %then report(nonstand+point,0,case) %c
 4996+     %else report(nonstand+point+warn,0,case)
 4997    %finish
 4998  %end
 4999  
 5000  %routine NAME ERROR
 5001  !check if the culprit has occurred before
 5002  !and, if not, add it to the pool of unknowns stored at the
 5003  !far end of the dictionary.
 5004    %if item >= 0 %start;  !first time
 5005      fault(namerr+point+now)
 5006      %if charmin-newlen-80 >= charlim %start
 5007        dmin = dmin-1;  dmin0 = dmin
 5008        charmin = charmin-newlen-1
 5009        string(charmin) = string(charlim)
 5010        dict(dmin)_text = charmin-char0
 5011        head == dict(head)_hlink %while head > 0;  !find last link
 5012        dict(dmin)_hlink = head;  head = -dmin
 5013      %finish
 5014    %finish %else others = others+1
 5015    %signal fail
 5016  %end
 5017  
 5018  %routine FIND OP(%integer mnemonic,%integername op,types)
 5019  %integer i
 5020    i = 0
 5021    %cycle
 5022      i = i+2
 5023      error(namerr) %if i > defmax+defmax
 5024    %repeat %until def(i) = mnemonic 
 5025    types = def(i-1);  op = i>>1
 5026  %end
 5027  
 5028  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5029  !!!!!!!!!!!!!!!!!!!!  Source input  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5030  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5031  
 5032  %routine READ LINE(%integer flag)
 5033  ! Read (or otherwise make available) the next source line
 5034  !     Output any pending error report;                 *NB*
 5035  !     Skip remnant of previous line if SYM # NL        *NB*
 5036  !     Set LINESTART to point to start of new line
 5037  !     Print new line on list output stream if listing requested
 5038  !       (Direct output routines CF diagnostics)
 5039    report(faultnum,0,0) %if faultnum # 0
 5040    %while sym > nl %cycle;               !Skip remnant
 5041      sym = byteintegeR(fp);  fp = fp+1
 5042    %repeat
 5043    line = line+1
 5044    %while fp = curlim %cycle
 5045      %if curlim # cur_lim2 %start;  !in part1 of file
 5046        fp = cur_start2
 5047      %finish %else %if curfile = main %start;      !on main
 5048        %signal done
 5049      %else
 5050        cur_flag = -1
 5051  !!      disconnect edfile(cur)
 5052        curfile = curfile-1
 5053        cur == file(curfile)
 5054        fp = cur_fp;  line = cur_line
 5055        control = fcontrol(curfile)
 5056        inclim = dlim %if level = outerlevel %and c_status < hadon
 5057      %finish
 5058      curstart = cur_start2;  curlim = cur_lim2
 5059      %if fp < curstart %or fp > curlim %start
 5060        curstart = cur_start1;  curlim = cur_lim1
 5061      %finish
 5062    %repeat
 5063    linestart = fp
 5064    %if flag = 0 %start
 5065      flag = ' ';  flag = '&' %if curfile # main
 5066    %finish
 5067    listflag = flag
 5068    %if control&list # 0 %start
 5069      time1 = time1-cputime
 5070      print line %if rep # ""
 5071      show dict(dictshown) %if control&dictlist # 0
 5072      dictshown = dlim
 5073      write(line,4);  print symbol(listflag)
 5074      print symbol(' ')
 5075      %cycle
 5076        sym = byteintegeR(fp);  fp = fp+1
 5077        print symbol(sym)
 5078      %repeat %until sym <= nl
 5079      fp = linestart
 5080      time1 = time1+cputime
 5081    %finish
 5082    sym = 0
 5083  %end;  !READ LINE
 5084  
 5085  !<<IMP
 5086  
 5087  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5088  !!!!!!!!!!!!!!!!!!!!  Lexical processing  !!!!!!!!!!!!!!!!!!!!!!
 5089  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5090  
 5091  %constinteger CASEBIT=32
 5092  %owninteger PERCENT=0, SUBATOM=0
 5093  !
 5094  !~!!!!!!!  Keyword codes -- used by KEYGEN to produce tables  !!
 5095  %constinteger %c
 5096+   KEYEND=1 {end},
 5097+   KEYREPEAT=2   {repeat},
 5098+   KEYFINISH=3   {finish},
 5099+   KEYELSE=4     {else},
 5100+   KEYBEGIN=5    {begin},
 5101+   EXIT=6        {exit_1,continue_0}
 5102  %constinteger %c
 5103+   KEYRETURN=7   {return},
 5104+   TF=8          {true_1,false_0},
 5105+   KEYRESULT=9   {result},
 5106+   KEYSTOP=10    {stop},
 5107+   KEYGOTO=11    {goto},
 5108+   KEYSIGNAL=12  {signal}
 5109  %constinteger %c
 5110+   KEYMONITOR=13 {monitor},
 5111+   KEYON=14      {on},
 5112+   IU=15         {if_0,unless_1},
 5113+   KEYWHILE=16   {while},
 5114+   KEYUNTIL=17   {until_1},
 5115+   KEYFOR=18     {for},
 5116+   KEYTHEN=19    {then}
 5117  %constinteger %c
 5118+   KEYSTART=20   {start},
 5119+   KEYCYCLE=21   {cycle},
 5120+   KEYLABEL=22   {label},
 5121+   KEYCONST=23   {const,constant},
 5122+   KEYOWN=24     {own},
 5123+   KEYEXT=25     {external_6,system_5,dynamic_7}
 5124  %constinteger %c
 5125+   KATTRIB=26    {readonly_0,writeonly_1,volatile_2},
 5126+   KTYPE=27      {short_3,half_6,byte_9,mite_12,boolean_15,char_18,text_25},
 5127+   KEYINTEGER=28 {integer},
 5128+   KEYLONG=29    {long},
 5129+   KEYREAL=30    {real},
 5130+   KEYSTRING=31  {string_0,cstring_1}
 5131  %constinteger %c
 5132+   KEYRECORD=32  {record},
 5133+   KEYNAME=33    {name},
 5134+   KEYFORMAT=34  {format},
 5135+   FNMAP=35      {fn_0,function_0,map_1},
 5136+   RPRED=36      {routine_0,predicate_1},
 5137+   KEYSPEC=37    {spec}
 5138  %constinteger %c
 5139+   KEYARRAY=38   {array},
 5140+   KEYSWITCH=39  {switch},
 5141+   KEYOF=40      {of},
 5142+   KEYFILE=41    {file},
 5143+   KEYPROGRAM=42 {program},
 5144+   KEYLIST=43    {list}
 5145  %constinteger %c
 5146+   KEYCONTROL=44 {control},
 5147+   KEYCOMMENT=45 {comment},
 5148+   KEYEVENT=46   {event},
 5149+   KEYINCLUDE=47 {include},
 5150+   KEYOPTION=48  {option},
 5151+   KEYALIAS=49   {alias}
 5152  %constinteger %c
 5153+   KEYNOT=50     {not},
 5154+   KEYAND=72     {and},
 5155+   KEYOR=73      {or}
 5156  !!  end of keyword codes
 5157  !
 5158  !Symbol lexical codes other than operators:
 5159  %constinteger TERMINATOR=51, CONST=52, IDENT=53, MODSIGN=54,
 5160+               COLON=59, COMMA=60, RIGHT=61, RIGHTB=62
 5161  {DUD=63}
 5162  %constinteger LEFT=55, LEFTB=56, ATSIGN=57, UNDERLINE=58
 5163  
 5164  %constinteger ARROW=74, EQEQ=75, NOTEQEQ=76,
 5165+               EQUALS=77, NOTEQ=78, LESSEQ=79,
 5166+               LESS=80, GREATEQ=81, GREATER=82
 5167  %constinteger PLUS=83, MINUS=84, EXCLAM=85, EXCLAM2=86, DOT=87
 5168  %constinteger STAR=88, SLASH2=89, SLASH=90, AMPERSAND=91
 5169  %constinteger STAR2=92, BACKSLASH=93, UPARROW=94,
 5170+               BACKSLASH2=95, UPARROW2=96,
 5171+               TILDE=97,
 5172+               LSHIFT=98, RSHIFT=99
 5173  %constinteger ATOMMAX=99
 5174  %constinteger ALEFT=left, ARIGHT=right, RECSUB=underline,
 5175+               OVER=slash2, SCONC=dot
 5176  
 5177  %constinteger SIMPLE=atommax+1, VSIMPLE=simple+1,
 5178+               MAJOR=plus, SCOND=arrow, COND=keyand, CONDQ=71
 5179  !
 5180  %integer%fn NEXT ATOM
 5181  !Encode next atom from source file
 5182  ![Time-critical]
 5183  %switch s(0:255)
 5184  %constinteger TAB=9,
 5185+               MAX10=maxint//10, MAXDIG=maxint-max10*10
 5186  %integer i,j,p,radix,hash
 5187  %real rval
 5188  %constbytearray map(0:127) =
 5189+   0 ('0'),
 5190+   '0','1','2','3','4','5','6','7','8','9',
 5191+   0, 0, 0, 0, 0, 0, 0,
 5192+   'a','b','c','d','e','f','g','h','i','j','k','l','m',
 5193+   'n','o','p','q','r','s','t','u','v','w','x','y','z',
 5194+   0, 0, 0, 0, 0, 0,
 5195+   'a','b','c','d','e','f','g','h','i','j','k','l','m',
 5196+   'n','o','p','q','r','s','t','u','v','w','x','y','z',
 5197+   0, 0, 0, 0, 0
 5198  
 5199  !~!!!!!!!!!!!!!!!  Ex KEYGEN  !!!!!!!!!!!!!!!!!!!!
 5200  %CONSTSHORTINTEGERARRAY SYMINIT(97:122) =  %C
 5201+ 2,15,31,72,79,102,133,137,141,1,1,156,169,183,190,205,
 5202+ 1,220,257,297,309,319,327,1,1,1
 5203  
 5204  %CONSTBYTEINTEGERARRAY SYMBOL(1:340) =  %C
 5205+ 128,114,114,97,121,166,108,105,97,115,177,110,100,200,101,103,
 5206+ 105,110,133,121,116,101,155,111,111,108,101,97,110,155,111,110,
 5207+ 116,105,110,117,101,134,121,99,108,101,149,104,97,114,155,115,
 5208+ 116,114,105,110,103,159,109,109,101,110,116,173,115,116,97,110,
 5209+ 116,151,151,114,111,108,172,121,110,97,109,105,99,153,110,100,
 5210+ 129,108,115,101,132,120,105,116,134,118,101,110,116,174,116,101,
 5211+ 114,110,97,108,153,105,110,105,115,104,131,97,108,115,101,136,
 5212+ 111,114,109,97,116,162,110,163,117,110,99,116,105,111,110,163,
 5213+ 146,108,101,169,111,116,111,139,97,108,102,155,102,143,110,116,
 5214+ 101,103,101,114,156,99,108,117,100,101,175,97,98,101,108,150,
 5215+ 111,110,103,157,105,115,116,171,111,110,105,116,111,114,141,105,
 5216+ 116,101,155,97,112,163,97,109,101,161,111,116,178,110,142,119,
 5217+ 110,152,102,168,112,116,105,111,110,176,114,201,114,101,100,105,
 5218+ 99,97,116,101,164,111,103,114,97,109,170,101,112,101,97,116,
 5219+ 130,111,117,116,105,110,101,164,116,117,114,110,135,115,117,108,
 5220+ 116,137,97,100,111,110,108,121,154,99,111,114,100,160,108,158,
 5221+ 116,111,112,138,105,103,110,97,108,140,121,115,116,101,109,153,
 5222+ 104,111,114,116,155,112,101,99,165,119,105,116,99,104,167,97,
 5223+ 114,116,148,114,105,110,103,159,114,117,101,136,104,101,110,147,
 5224+ 101,120,116,155,110,108,101,115,115,143,116,105,108,145,111,108,
 5225+ 97,116,105,108,101,154,104,105,108,101,144,114,105,116,101,111,
 5226+ 110,108,121,154
 5227  
 5228  %CONSTBYTEINTEGERARRAY ALTDISP(1:340) =  %C
 5229+ 0,5,0,0,0,0,5,0,0,0,0,0,0,0,5,0,
 5230+ 0,0,0,4,0,0,9,0,0,0,0,0,0,15,8,23,
 5231+ 28,34,0,0,0,0,5,0,0,0,0,4,0,0,18,0,
 5232+ 0,0,0,0,0,1,0,0,0,0,0,0,0,0,4,0,
 5233+ 0,0,0,0,0,0,0,0,0,0,0,0,0,7,3,0,
 5234+ 0,4,0,0,0,4,8,0,1,0,0,0,0,0,0,0,
 5235+ 0,0,0,0,6,6,27,0,0,0,0,5,0,0,0,0,
 5236+ 6,0,14,0,0,0,2,0,0,0,0,0,0,0,0,0,
 5237+ 0,0,0,0,0,0,0,0,0,0,0,6,2,0,0,6,
 5238+ 0,0,0,0,0,0,0,0,0,0,0,5,0,0,0,0,
 5239+ 4,0,0,0,0,0,0,0,7,0,0,0,0,0,0,4,
 5240+ 0,0,12,0,0,1,4,0,0,0,0,0,0,2,0,3,
 5241+ 0,0,2,0,6,0,0,0,0,0,0,0,0,8,0,0,
 5242+ 0,0,0,0,1,0,0,0,0,0,0,6,12,0,0,0,
 5243+ 0,0,0,0,0,0,0,0,5,0,0,0,0,5,0,0,
 5244+ 0,0,7,11,0,0,0,0,0,0,0,0,0,0,0,0,
 5245+ 4,30,0,0,6,0,0,0,0,0,6,0,0,0,0,5,
 5246+ 5,0,0,0,3,4,0,0,0,0,0,0,0,0,0,4,
 5247+ 0,0,0,0,0,0,0,0,4,0,0,1,4,0,0,0,
 5248+ 0,0,0,25,0,5,0,0,0,1,0,0,0,1,0,0,
 5249+ 0,0,0,0,0,2,5,0,0,0,0,0,0,0,0,0,
 5250+ 0,0,0,1
 5251  
 5252  
 5253  !! end of generated tables
 5254  
 5255  %routine GET SYM
 5256    %cycle
 5257      sym = byteintegeR(fp);  fp = fp+1
 5258    %repeat %until sym # ' '
 5259    i = sym-'0'
 5260    %if i >= 10 %start
 5261      i = sym!casebit-'a';  i = i+10 %if i >= 0
 5262    %finish
 5263  %end
 5264  
 5265    matched = 0
 5266  again: s(tab):
 5267    read line(0) %if sym = nl
 5268  again1:
 5269    %cycle
 5270      sym = byteintegeR(fp);  fp = fp+1
 5271    %repeat %until sym # ' '
 5272    atomp = fp;     !(actually one after)
 5273    atoms = atoms+1
 5274    -> s(sym)
 5275  linebreak: s(nl):
 5276    %result = terminator %if atom # comma
 5277  continuation:
 5278    read line('+')
 5279    -> again1
 5280  
 5281  s('{'):
 5282    comments = comments+1
 5283    %cycle
 5284      sym = byteintegeR(fp);  fp = fp+1
 5285      -> linebreak %if sym = nl
 5286    %repeat %until sym = '}'
 5287    -> again
 5288  
 5289  s('+'): %result = plus
 5290  s('-'): fp = fp+1 %and %result = arrow %if byteintegeR(fp) = '>'
 5291          -> continuation %if byteintegeR(fp) = nl
 5292          %result = minus
 5293  s('*'): %result = star
 5294  s('/'): fp = fp+1 %and %result = slash2 %if byteintegeR(fp) = '/'
 5295          %result = slash
 5296  s('\'): fp = fp+1 %and %result = backslash2 %if byteintegeR(fp) = '\'
 5297          fp = fp+1 %and %result = noteq %if byteinteger(fp) = '='
 5298          %result = backslash
 5299  s('^'): fp = fp+1 %and %result = uparrow2 %if byteintegeR(fp) = '^'
 5300          %result = uparrow
 5301  s('~'): %result = tilde
 5302  s('!'): fp = fp+1 %and %result = exclam2 %if byteintegeR(fp) = '!'
 5303          %result = exclam
 5304  s('&'): %result = ampersand
 5305  s('.'): rval = 0 %and -> fraction %if '0' <= byteinteger(fp) <= '9'
 5306          %result = dot
 5307  s('='): fp = fp+1 %and %result = eqeq %if byteintegeR(fp) = '='
 5308          %result = equals
 5309  s('#'): fp = fp+1 %and %result = noteqeq %if byteintegeR(fp) = '#'
 5310          %result = noteq
 5311  s('<'): fp = fp+1 %and %result = lesseq %if byteintegeR(fp) = '='
 5312          fp = fp+1 %and %result = noteq %if byteintegeR(fp) = '>'
 5313          fp = fp+1 %and %result = lshift %if byteintegeR(fp) = '<'
 5314          %result = less
 5315  s('>'): fp = fp+1 %and %result = greateq %if byteintegeR(fp) = '='
 5316          fp = fp+1 %and %result = rshift %if byteintegeR(fp) = '>'
 5317          %result = greater
 5318  s('_'): %result = underline
 5319  s(':'): %result = colon
 5320  s(','): %result = comma
 5321  s(';'): %result = terminator
 5322  s('('): %result = left
 5323  s('['): %result = leftb
 5324  s(')'): %result = right
 5325  s(']'): %result = rightb
 5326  s('|'): %result = modsign
 5327  s('@'): %result = atsign
 5328  
 5329  s('M'): s('m'):
 5330    fp = fp+1 %and -> charconst %if byteintegeR(fp) = ''''
 5331  s('A'):s('B'):s('C'):s('D'):s('E'):s('F'):s('G'):s('H'):
 5332  s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'):
 5333  s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'):
 5334  s('Y'):s('Z'):s('a'):s('b'):s('c'):s('d'):s('e'):s('f'):
 5335  s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'):
 5336  s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'):
 5337  s('w'):s('x'):s('y'):s('z'):
 5338    -> keyword %if percent # 0
 5339    newlen = charlim+1;  hash = sym!casebit;  !lower-case (if letter)
 5340    byteinteger(newlen) = hash
 5341    %cycle
 5342      sym = byteintegeR(fp);  fp = fp+1
 5343    %repeat %until sym # ' '
 5344    %if sym = '''' %start;  !damned IBM-style literals
 5345      radix = 16 %and ->ibm %if hash = 'x'
 5346      radix = 8 %and ->ibm %if hash = 'k'
 5347      radix = 2 %and ->ibm %if hash = 'b'
 5348    %finish
 5349    sym = map(sym)
 5350    %if sym # 0 %start
 5351      %cycle
 5352        newlen = newlen+1;  byteinteger(newlen) = sym
 5353        hash = hash<<1!!sym
 5354        %cycle
 5355          sym = byteintegeR(fp);  fp = fp+1
 5356        %repeat %until sym # ' '
 5357        sym = map(sym)
 5358      %repeat %until sym = 0
 5359    %finish
 5360    fp = fp-1
 5361    newlen = newlen-charlim;  byteinteger(charlim) = newlen
 5362    %if subbed # 0 %then head == dformat_link %c
 5363+   %else head == hashindex(hash&255)
 5364    item = head
 5365    %if item # 0 %start
 5366      %cycle
 5367        ditem == dict(imod(item))
 5368        %exit %if string(ditem_text+char0) = string(charlim) %c
 5369+             %and (item > a7 %or item < 0 %or control&lowbit # 0)
 5370        item = ditem_hlink
 5371      %repeat %until item = 0
 5372    %finish
 5373    identatoms = identatoms+1
 5374    %result = ident
 5375  
 5376  s('%'):
 5377    sym = byteintegeR(fp)
 5378    -> again %unless 'a' <= sym!casebit <= 'z'
 5379    fp = fp+1
 5380  keyword:
 5381    percent = 0
 5382    p = syminit(sym!casebit)
 5383    %cycle
 5384  !     %cycle
 5385  !       sym = byteintegeR(fp)!casebit
 5386  !       %exit %if symbol(p) # sym
 5387      %while symbol(p) = byteintegeR(fp)!casebit %cycle
 5388        p = p+1;  fp = fp+1
 5389      %repeat
 5390      %exit %if symbol(p) > 127
 5391      atom = altdisp(p)
 5392      %if atom = 0 %start
 5393        %result = dud %unless sym!casebit = 'c' %and byteintegeR(fp) = nl
 5394        ->continuation
 5395      %finish
 5396      p = p+atom
 5397    %repeat
 5398    percent = 1 %if 'a' <= byteintegeR(fp)!casebit <= 'z'
 5399    subatom = altdisp(p)
 5400    atom = symbol(p)-128
 5401    %result = dud %if atom = 0
 5402    %result = atom
 5403  
 5404  ibm:
 5405    nonstandard(20)
 5406    item = -1;  value = 0
 5407    -> ibm1
 5408  s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'):
 5409    item = 0;  type = inttype
 5410    radix = 10;  value = sym-'0'
 5411  ibm1:
 5412    %cycle
 5413      %cycle
 5414        %cycle
 5415          sym = byteintegeR(fp);  fp = fp+1
 5416        %repeat %until sym # ' '
 5417        i = sym-'0'
 5418        %if radix = 10 %start
 5419          %exit %if i < 0 %or i >= 10
 5420          fault(rangerr+point+warn) %if value > max10 %or (value=max10 %and i > maxdig)
 5421          value = (value<<2+value)<<1+i
 5422        %else
 5423          i = sym!casebit-'a'+10 %if i >= 10
 5424          %exit %if i < 0 %or i >= radix
 5425          j = radix
 5426          %cycle
 5427            i = i+value %if j&1 # 0
 5428            value = value<<1;  j = j>>1
 5429          %repeat %until j = 0
 5430          value = i
 5431        %finish
 5432      %repeat
 5433      %exit %unless sym = '_'
 5434      radix = value
 5435      %result = dud %if radix = 0
 5436      value = 0
 5437    %repeat
 5438    %if item < 0 %start;  !IBM-style
 5439      %result = dud %if sym # ''''
 5440      item = 0
 5441    %else
 5442      j = 0
 5443      %if sym = '.' %start
 5444        rval = value %if type = inttype
 5445  fraction:
 5446        j = 0
 5447        type = realtype
 5448        %cycle
 5449          get sym
 5450          %exit %unless 0 <= i < radix
 5451          rval = rval*radix+i;  j = j-1
 5452        %repeat
 5453        %result = dud %if j = 0
 5454      %finish
 5455      %if sym = '@' %start
 5456        type = realtype %and rval = value %if type = inttype
 5457        get sym
 5458        value = 0
 5459        %if sym = '+' %then get sym %c
 5460+       %else %if sym = '-' %then value = 1 %and get sym
 5461        %result = dud %unless 0 <= i < radix
 5462        p = 0
 5463        %cycle
 5464          p = p*radix+i
 5465          get sym
 5466        %repeat %until %not 0 <= i < radix
 5467        p = -p %if value # 0
 5468        j = j+p
 5469      %finish
 5470      %if type = realtype %start
 5471        rval = rval*radix^^j %if j # 0
 5472        value = integer(addr(rval)) %if type = realtype
 5473      %finish
 5474      fp = fp-1;  sym = 0
 5475    %finish
 5476    litatoms = litatoms+1
 5477    %result = const
 5478  
 5479  s(''''):
 5480  charconst:
 5481    item = 0;  type = inttype
 5482    value = 0
 5483    %cycle
 5484      sym = byteintegeR(fp);  fp = fp+1
 5485      %result = dud %if sym = nl;  !?allow
 5486      %if sym = '''' %start
 5487        %exit %unless byteintegeR(fp) = ''''
 5488        fp = fp+1
 5489      %finish
 5490      value = value<<8+sym
 5491    %repeat
 5492    %result = const %if value # 0
 5493    %result = dud
 5494  
 5495  s('"'):
 5496    item = 0
 5497    value = cad;  type = stringtype
 5498    i = line;  j = linestart;  p = 0
 5499    %cycle
 5500      sym = byteintegeR(fp);  fp = fp+1
 5501      %if sym = '"' %start
 5502        %exit %if byteintegeR(fp) # '"'
 5503        fp = fp+1
 5504      %finish
 5505      p = p+1
 5506      %if p > 255 %start
 5507        sym = 0
 5508        fp = atomp;  linestart = j
 5509        %result = dud
 5510      %finish
 5511      final(value+p) = sym
 5512      read line('"') %if sym = nl
 5513    %repeat
 5514    %if p # 0 %start;  !not empty string
 5515      final(value) = p
 5516      cad = cad+(p+1)
 5517    %finish %else value = 0
 5518    litatoms = litatoms+1
 5519    %result = const
 5520  
 5521  s(*):
 5522    %result = dud
 5523  %end;  !NEXT ATOM
 5524  
 5525  !<<BOTH
 5526  
 5527  %integerfn A (%integer k)
 5528  !Basic atom-testing predicate
 5529    atom = next atom %if matched # 0
 5530    %result = FALSE %if k # atom
 5531    matched = 1
 5532    %result = TRUE
 5533  %end
 5534  
 5535  %routine GET(%integer k)
 5536    atom = next atom %if matched # 0
 5537    matched = 1
 5538    %return %if atom = k
 5539    syntax error { %if atom = dud
 5540  !  faultp = atomp
 5541  !  report(formerr+point,-k,0)
 5542  !  %signal fail
 5543  %end
 5544  
 5545  !<<IMP
 5546  
 5547  %routine ALLOW(%integer k)
 5548    %if a(k)=TRUE %start
 5549    %finish
 5550  %end
 5551  
 5552  %routine GET LITSTRING
 5553  %integer holditem
 5554  !Must be quoted string (for %alias and %include)
 5555    holditem = item;  !preserve
 5556    get(const)
 5557    error(typerr+point) %unless type = stringtype
 5558    cad = value;  !reset
 5559    item = holditem;  !restore
 5560  %end
 5561  
 5562  !<<BOTH
 5563  
 5564  %integer%fn IDTEXT(%integer f)
 5565  %integer k
 5566    %result = ditem_text %if item > 0 %and f&ext = 0;  !already exists
 5567    charlim = charlim+newlen+1
 5568    croak("Identifier space exhausted") %if charlim+80 >= charmin
 5569    k = charlim-newlen-1-char0
 5570    %if f&ext # 0 %and a(keyalias)=TRUE %start
 5571      get LITSTRING
 5572      string(charlim) = string(final0+value)
 5573      byteinteger(charlim) = byteinteger(charlim)+128
 5574      charlim = charlim+byteinteger(charlim)-127
 5575    %finish
 5576    %result = k
 5577  %end
 5578  
 5579  %record(objinfo)%map DETAILS(%integer f,t,m,v)
 5580  %ownrecord(objinfo) D=0
 5581    d_flags = f;  d_type = t
 5582    d_mode = m;  d_val = v
 5583    %result == d
 5584  %end
 5585  
 5586  %routine DECLARE(%record(objinfo)%name d)
 5587  %integer i
 5588  %record(identinfo)%name dp
 5589    dp == dict(dlim)
 5590    %if speccing = 0 %start;  !not within spec params
 5591      %if item >= c_localdpos %start;  !there already
 5592        %if d_flags&spec = 0 %and ditem_flags&spec # 0 %start
 5593          !body after spec (proc,label,typeid)
 5594          %if d_flags&(ext+proc+typeid) = ditem_flags&(ext+proc+typeid) %start
 5595            i = item
 5596            %if d_flags&ext # 0 %start
 5597              ![can't allow %ext%spec, then use, then %ext object]
 5598              ->ok %if ditem_flags&rflag # 0;  ![so create new entry]
 5599              ditem_mode = d_mode;  ditem_val = d_val
 5600              %if a(keyalias)=TRUE %start
 5601                get LITSTRING;  !ignore [should be identical]
 5602                item = i
 5603              %finish
 5604            %finish
 5605            %if d_flags&proc = 0 %start
 5606              ditem_flags = ditem_flags&(\(spec+indirect))
 5607            %finish
 5608            %return
 5609          %finish
 5610          %if ditem_flags&(ext+proc) = proc1 %and d_flags&ext # 0 %c
 5611+             %and d_flags&proc # 0 %start;  !(internal) %spec then %ext
 5612            ditem_flags = ditem_flags-proc1+(d_flags&(ext+proc))
 5613            ditem_text = idtext(ext);  !in case alias
 5614            %return
 5615          %finish
 5616        %finish
 5617  !<<IMP
 5618        %if item < inclim %and ditem_flags&(rflag+wflag) = 0 %c
 5619+       %then fault(duperr+warn+point) %else fault(duperr+point)
 5620  !<<BOTH
 5621      %finish
 5622  ok: dp_hlink = head;  head = dlim;  !insert in list
 5623      dp_text = idtext(d_flags)
 5624    %finish %else dp_hlink = 0 %and dp_text = 0
 5625    item = dlim;  ditem == dp
 5626    ditem_details = d
 5627    dlim = dlim+1
 5628    %if dlim >= dmin %start
 5629  {?}    show dict(0) %if control&logbit # 0
 5630      croak("Too many identifiers")
 5631    %finish
 5632  %end;  !DECLARE
 5633  
 5634  %routine DECLARE ANON(%record(objinfo)%name d)
 5635    speccing = speccing+1
 5636    item = 0
 5637    declare(d)
 5638    speccing = speccing-1
 5639  %end
 5640  !
 5641  %routine DECLARE TEMP(%integer t)
 5642    c_val = c_val+4;  c_temps = c_temps+4
 5643    declare anon(details(okflag+writable+readable,t,c_mode,c_sp-c_val))
 5644  %end
 5645  !
 5646  %routine DECLARE RANGE(%integer type,lower,upper)
 5647  !Type ident just declared
 5648  %integer s
 5649  %integerfn OK(%integer l,u)
 5650    %result = TRUE %if (l <= lower %and upper <= u) {signed} %c
 5651+         %or (0 <= lower %and upper <= u-l) {unsigned}
 5652    %result = FALSE
 5653  %end
 5654    s = 4
 5655    %if ok(-32768,32767)=TRUE %start
 5656      s = 2;  s = 1 %if ok(-128,127)=TRUE
 5657    %finish
 5658    ditem_details = details(typeid,type,absmode,sign)
 5659    ditem_size = s
 5660    declare anon(details(okflag,type,litmode,lower))
 5661    declare anon(details(okflag,type,litmode,upper))
 5662    ditem_hlink = ranges;  ranges = item
 5663    item = item-2
 5664  %end
 5665  
 5666  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5667  !!!!!!!!!!!!!!!!!!!!  Expressions  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5668  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5669  
 5670  %owninteger LITERAL=0, JAMMY=0
 5671  
 5672  %routine%spec GET EXPRESSION(%integer rank,etype)
 5673  !
 5674  %integerfn VALOK(%integer wanted,t)
 5675  %integer lo,hi,l,h,wc,tc
 5676  %record(identinfo)%name wp,tp
 5677    %result = TRUE %if wanted = t # recstar
 5678    wp == typecell(wanted);  tp == typecell(t)
 5679    wc = wp_flags&(packed+cat);  tc = tp_flags&(packed+cat)
 5680    %if wc = tc %start;  !same class
 5681      %if wc&nonord = 0 %start;  !ordinal wanted
 5682        %if wp_type = tp_type %start;  !same base-type
 5683          %result = TRUE %if wp_type = wanted;  !base-type (rather than subrange)
 5684          %if dict(wanted+1)_mode # litmode %then get bounds(dict(wanted+1)_type,lo,hi) %c
 5685+         %else lo = dict(wanted+1)_val
 5686          %if dict(wanted+2)_mode # litmode %then get bounds(dict(wanted+2)_type,hi,hi) %c
 5687+         %else hi = dict(wanted+2)_val
 5688          %if item = 0 %start;  !literal
 5689            %result = TRUE %if lo <= value <= hi
 5690            jammy = jammy!!1
 5691          %else
 5692            jammy = jammy!!1 %and %result = TRUE %if tp_type = t
 5693            %if dict(t+1)_mode # litmode %then get bounds(dict(t+1)_type,l,h) %c
 5694+           %else l = dict(t+1)_val
 5695            %if dict(t+2)_mode # litmode %then get bounds(dict(t+2)_type,h,h) %c
 5696+           %else h = dict(t+2)_val
 5697            %if l >= lo %start
 5698              %result = TRUE %if h <= hi
 5699              jammy = jammy!!1
 5700              %result = TRUE %if l <= hi
 5701            %else
 5702              jammy = jammy!!1
 5703              %result = TRUE %if h >= lo
 5704            %finish
 5705          %finish
 5706          expfault(rangerr) %if jammy # 0
 5707          %result = TRUE
 5708        %finish
 5709      %finish %else %if wc = realy %start
 5710        %result = TRUE
 5711      %finish %else %if wc = stringy %start;  !string wanted
 5712        %result = TRUE %if wanted = stringstar
 5713        %if item = 0 %start
 5714          %result = TRUE %if value = 0;  !empty string
 5715          l = final(value)+1
 5716        %else
 5717          l = imod(tp_size)
 5718          l = 256 %if l = 0
 5719        %finish
 5720        %if l > imod(wp_size) # 0 %start
 5721          jammy = jammy!!1
 5722          expfault(rangerr) %if item = 0 %and jammy # 0
 5723        %finish
 5724        %result = TRUE
 5725  !<<IMP
 5726      %finish %else %if wc&cat = arry %start
 5727        %result = TRUE %if wp_type = tp_type %and valok(wp_xtype,tp_xtype)=TRUE
 5728  !<<BOTH
 5729      %else;                          !record etc
 5730        %if wanted = recstar %start
 5731          %result = TRUE %if t # recstar
 5732        %else
 5733          %result = TRUE %if t = recstar %or item!value = 0
 5734        %finish
 5735      %finish
 5736    %else;                            !category difference
 5737      %if tc = inty %start
 5738        %result = TRUE %if wc = recy %and item!value = 0;  !RECORD = 0
 5739        toreal %and %result = TRUE %if wc = realy;         !REAL   = INT
 5740      %finish %else %if wc = stringy %and t = chartype %start;   !STRING = CHAR
 5741        %if item = 0 %start;           !null string
 5742          final(cad) = 1;  final(cad+1) = value
 5743          value = cad;  cad = cad+2
 5744          type = stringtype
 5745        %finish %else putexp(dtostring,normitem,0,string1)
 5746        %result = TRUE
 5747  !<<IMP
 5748  ! sets again
 5749  !<<BOTH
 5750      %finish
 5751    %finish
 5752    %result = FALSE
 5753  %end
 5754  !
 5755  %routine GET VALUE(%integer valtype)
 5756    get EXPRESSION(major,valtype)
 5757  %end;  !GET VALUE
 5758  !
 5759  %routine GET LITERAL(%integer t)
 5760    literal = literal+1
 5761    get EXPRESSION(major,t)
 5762    literal = literal-1
 5763  %end
 5764  !
 5765  !!!!!!!!!!!!!!!!!!!!!!  Machine-code  !!!!!!!!!!!!!!!!!!!!!!!!!!
 5766  !
 5767  %routine GET MIDENT(%integer min,max)
 5768    get(ident)
 5769    %if item <= 0 %start
 5770      name error %if string(charlim) # "sp"
 5771      item = a7
 5772      ditem == dict(item)
 5773    %finish
 5774    %if ditem_mode = litmode %start
 5775      value = ditem_val;  item = 0
 5776    %finish
 5777    syntax error %unless min <= item <= max
 5778  %end
 5779  
 5780  %routine GET REGSET
 5781  %integer hold,set
 5782    set=0
 5783    %cycle
 5784      get mident(d0,a7)
 5785      hold = item
 5786      get mident(hold,a7) %if a(minus)=TRUE
 5787      %cycle
 5788        set = set!1<<(hold-d0)
 5789        hold = hold+1
 5790      %repeat %until hold > item
 5791    %repeat %until %not a(slash)=TRUE
 5792    item = 0;  value = set
 5793  %end
 5794  
 5795  %routine get MCODE
 5796  %integer op,x,y,types
 5797  
 5798  %integer%fn OPSIZE(%integer okbyte)
 5799    %result = 0 %unless a(dot)=TRUE
 5800    sym = byteinteger(fp)&(\casebit);  fp = fp+1
 5801    %result = 4 %if sym = 'L'
 5802    %result = 2 %if sym = 'W'
 5803    %result = 1 %if sym = okbyte
 5804    syntax error
 5805  %end
 5806  
 5807  %routine get MOP(%integer t,dummy,%record(identinfo)%name dp)
 5808  !Get Mcode operand
 5809  %constinteger HASHSIGN=noteq
 5810  %integer sign,hold,holdval,m
 5811    %if a(hashsign)=TRUE %start
 5812      get LITERAL(inttype)
 5813      %return
 5814    %finish
 5815    sign = 0;  hold = -1;  holdval = 0
 5816    sign = 1 %if a(minus)=TRUE
 5817    %if a(ident)=TRUE %start
 5818      matched = 0
 5819      get mident(0,dlim)
 5820      hold = item
 5821      %if hold # 0 %start
 5822        syntax error %if sign # 0
 5823        %if item > a7 %start
 5824          dp_flags = ditem_flags
 5825          dp_mode = ditem_mode;  dp_val = ditem_val
 5826          %while a(recsub)=TRUE %cycle
 5827            dformat == typecell(ditem_type)
 5828            syntax error %unless dformat_flags&cat = recy %c
 5829+                        %and ditem_flags&(name+indirect) = 0
 5830            subbed = 1;  get(ident);  subbed = 0
 5831            error(namerr+point) %if item <= 0
 5832            dp_flags = ditem_flags;  dp_type = ditem_type
 5833            dp_val = dp_val+ditem_val
 5834            item = dummy;  ditem == dp
 5835          %repeat
 5836          %return
 5837        %finish
 5838        %if op&255 = movem %and item > 0 %start
 5839          matched = 0
 5840          get regset
 5841        %finish
 5842        %return
 5843      %finish
 5844      holdval = value
 5845    %finish %else %if a(const)=TRUE %start
 5846      hold = 0;  holdval = value
 5847    %finish
 5848    holdval = -holdval %if sign # 0
 5849    %if a(left)=TRUE %start
 5850      get mident(a0,a7)
 5851      %if hold < 0 %start
 5852        get(right)
 5853        %if sign # 0 %then item = item+pre %c
 5854+       %else %unless a(plus)=TRUE %then item = item+indir %c
 5855+       %else item = item+post
 5856        %return
 5857      %finish
 5858      m = item+(dispmode-a0)
 5859      %if a(comma)=TRUE %start
 5860        get mident(d0,a7)
 5861        fault(rangerr) %unless is mite(holdval)=TRUE
 5862        m = m+(indexmode-dispmode)
 5863        holdval = (item-d0)<<12+holdval&255
 5864        holdval = holdval+16_0800 %if opsize(0) # 2
 5865      %finish
 5866      get(right)
 5867    %else
 5868      syntax error %if hold < 0
 5869      m = absmode
 5870    %finish
 5871    dp_mode = m;  dp_val = holdval
 5872    item = dummy
 5873  %end
?T unused
 5874  
 5875  %constinteger temp=((('t'&31)<<5+('e'&31))<<5+('m'&31))<<5+('p'&31)
 5876    update sp
 5877  !Pack mnemonic
 5878    atomp = fp+1
 5879    x = 0
 5880    %cycle
 5881      sym = byteinteger(fp);  fp = fp+1
 5882      %exit %unless 'A' <= sym&(\casebit) <= 'Z'
 5883      sym = sym&31
 5884      x = x<<5+sym
 5885    %repeat
 5886    fp = fp-1;  sym = 0
 5887    syntax error %if x = 0
 5888    %if x = temp %start;       !*TEMP ...
 5889      value = 0
 5890      matched = 0 %and get regset %if a(ident)=TRUE
 5891      c_free = value
 5892      %return
 5893    %finish
 5894    x = x<<5 %until x&(31<<25) # 0
 5895    x = x!16_C0000000
 5896    find op(x,op,types)
 5897    op = op+opsize('B')<<8 %if types&(sized!asized) # 0
 5898    x = 0;  y = 0
 5899    %if types>>6&63 # 0 %start
 5900      get MOP(types>>6&63,lablim,dtemp)
 5901      x = normitem
 5902      get(comma) %if types&63 # 0
 5903    %finish
 5904    %if types&63 # 0 %start
 5905      get MOP(types&63,lablim+1,dtemp2)
 5906      y = normitem
 5907    %finish
 5908    plant(op,x,y)
 5909    forget regs;  c_access = -1
 5910  %end;  !get MCODE
 5911  
 5912  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 5913  
 5914  %integerfn REFOK(%integer wanted,t)
 5915  %record(identinfo)%name wp,tp
 5916    %result = TRUE %if t = wanted %or wanted = 0 %or t = 0 %or item!value = 0
 5917    wp == typecell(wanted);  tp == typecell(t)
 5918    %if (wp_flags!!tp_flags)&(name+packed+cat) = 0 %start
 5919      %if wp_flags&cat = arry %start
 5920        !**check index compatible
 5921        %result = TRUE %if refok(wp_type,tp_type)=TRUE
 5922      %finish %else %if wp_flags&cat = stringy %start
 5923        %result = TRUE %if tp_size = 0 %or wp_size = 0
 5924  !<<IMP
 5925  !<<BOTH
 5926      %else
 5927        %result = TRUE %if t = recstar %or wanted = recstar
 5928      %finish
 5929    %finish
 5930    %result = FALSE
 5931  %end
 5932  
 5933  %routine TOREF
 5934    atomp=expp %and error(nonref+point) %if item <= 0 %or ditem_mode < dispmode
 5935    %if item >= dictlim %start
 5936  !    %if ditem_act = prel %and (ditem_y < 0 %or ditem_type = bytetype) %start
 5937  !      value = ditem_y
 5938  !      value = litref(litval(value)*imod(size(ditem_type))) %if ditem_type # bytetype
 5939  !      putexp(add,ditem_x+ad,value,ditem_type)
 5940  !      %return
 5941  !    %finish
 5942    %else
 5943      %if ditem_mode = absmode %and ditem_flags >= 0 %start
 5944        item = 0;  value = ditem_val
 5945        %return
 5946      %finish
 5947    %finish
 5948    item = item+ad
 5949  %end
 5950  !
 5951  %routine COPY DOWN(%integer np1)
 5952    %while np > np1 %cycle
 5953      np = np-1;  explo = explo-1
 5954      dict(explo) = dict(np)
 5955    %repeat
 5956  %end
 5957  
 5958  %routine GET REFERENCE(%integer reftype)
 5959    get EXPRESSION(simple,reftype!sign16)
 5960  %end
 5961  !
 5962  %routine GET PARLIST(%integer special)
 5963  %integer procnp,pact,hold,count,headitem,arg,p,q,restype
 5964  %record(identinfo)%name hp,tp
 5965  %record(identinfo)%name darg
 5966  
 5967  %routine PUT ACTUAL
 5968    item = litref(value) %if item = 0
 5969    %if count&1 = 0 %then hold = item %c
 5970+   %else putact(pact,hold,item) %and pact = 0
 5971    count = count+1
 5972  %end
 5973  
 5974  %integerfn NO ALT
 5975    %if hp_flags&alt = 0 %start;  !no alternative
 5976      expfault(typerr)
 5977      %result = TRUE
 5978    %finish
 5979    item = hp_hlink
 5980    %cycle
 5981      report(internerr,0,6) %and %signal fail %if item <= 0
 5982      ditem == dict(item)
 5983      %exit %if string(ditem_text+char0) = string(hp_text+char0)
 5984      item = ditem_hlink
 5985    %repeat
 5986    headitem = item;  pact = headitem;  hp == ditem
 5987    arg = hp_type;  darg == dict(arg);  restype = darg_type
 5988    %result = FALSE
 5989  %end
 5990  
 5991  %routine PUT BOUNDS(%integer ft,at)
 5992  ! FT is TYPE of formal, AT of actual array
 5993  %integer maxarg
 5994  %record(identinfo)%name ftp,atp,fxp,axp
 5995  maxarg=arg
 5996  %cycle
 5997    ftp == typecell(ft);  atp == typecell(at)
 5998  !  %if ftp_flags&indirect # 0 %start;           !complete dope vector
 5999  !    ![now only for %string(*)%array%name]
 6000  !    intern(11) %unless ftp_type = stringstar
 6001  !    item = at
 6002  !    put actual
 6003  !    maxarg = ft %if ft > maxarg
 6004  !    %exit
 6005  !  %finish
 6006    %if ftp_flags&cat = stringy %start
 6007      %exit %if ftp_size # 0
 6008      %if atp_size # 0 %then item = litref(imod(atp_size)) %C
 6009+     %else item = at-1
 6010      put actual
 6011      maxarg = ft-1 %if ft-1 > maxarg
 6012      %exit
 6013    %finish
 6014    %if ftp_xtype >= arg %start;    !index type
 6015      fxp == typecell(ftp_xtype);  axp == typecell(atp_xtype)
 6016      %if dict(ftp_xtype+1)_mode # litmode %start;  !non-literal lower
 6017        item = atp_xtype+1
 6018        item = 0 %and value = dict(atp_xtype+1)_val %if dict(atp_xtype+1)_mode = litmode
 6019        put actual
 6020        maxarg = ftp_xtype+1 %if ftp_xtype >= maxarg
 6021      %finish
 6022      %if dict(ftp_xtype+2)_mode # litmode %start;  !non-literal upper
 6023        item = atp_xtype+2
 6024        item = 0 %and value = dict(atp_xtype+2)_val %if dict(atp_xtype+2)_mode = litmode
 6025        put actual
 6026        maxarg = ftp_xtype+2 %if ftp_xtype+1 >= maxarg
 6027      %finish
 6028    %finish
 6029    ft = ftp_type;  at = atp_type;        !element types
 6030  %repeat %until ft <= arg
 6031  arg = maxarg;  darg == dict(arg)
 6032  %end
 6033  
 6034    count = 0;  hold = 0
 6035    procnp = np
 6036    headitem = item;  pact = headitem;  hp == ditem
 6037    arg = hp_type;  darg == dict(arg);  restype = darg_type
 6038    %if a(left)=TRUE %start
 6039      %cycle
 6040        arg = darg_link
 6041        %if arg = 0 %start
 6042          error(toomany+point) %if special = 0
 6043          get REFERENCE(0)
 6044          value = item-ad;  !save extra item
 6045          %cycle
 6046            %if type = realtype %start
 6047              %exit %if restype = realtype;  !no coercion
 6048            %else
 6049              %exit %if valok(type,restype)=TRUE
 6050            %finish
 6051          %repeat %until no alt=TRUE
 6052          special = 0
 6053        %else
 6054          darg == dict(arg)
 6055          %if darg_flags&proc # 0 %start
 6056            get(ident)
 6057            name error %if item <= 0
 6058            fault(typerr+point) %if ditem_flags&proc = 0 %c
 6059+                               %or %not parmatch(darg_type,ditem_type)=TRUE
 6060            fault(classerr+point) %if item > headitem %C
 6061+                                 %and ditem_mode = procmode {OK if param?}
 6062            item = item+ad
 6063            put actual
 6064          %finish %else %if darg_flags >= 0 %start
 6065            jammy = 0
 6066            get EXPRESSION(major,0)
 6067            %cycle
 6068              %exit %if valok(darg_type,type)=TRUE
 6069            %repeat %until no alt=TRUE
 6070            putexp(check,darg_type,item,darg_type) %if jammy # 0 %c
 6071+                                         %and control&capbit # 0 %c
 6072+                                         %and category(darg_type) < realy
 6073            put actual
 6074          %else;  !name
 6075            get REFERENCE(0)
 6076            %cycle
 6077              %exit %if refok(darg_type,type)=TRUE
 6078            %repeat %until no alt=TRUE
 6079            put actual
 6080            tp == typecell(darg_type)
 6081            %if tp_flags&cat = arry %c
 6082+           %and dict(arg+1)_type # darg_type %c
 6083+           %and tp_mode >= framemode %start
 6084              !array name (last in group) with non-literal dope vector
 6085              put bounds(darg_type,type)
 6086            %finish
 6087          %finish
 6088        %finish
 6089      %repeat %until %not a(comma)=TRUE
 6090      error(toofew+point) %if darg_link # 0 %or special # 0
 6091      get(right)
 6092    %else;                              !no LEFT
 6093      error(toofew+point) %if darg_link # 0
 6094    %finish
 6095    put act(pact,hold,0) %if count&1 # 0 %or count = 0
 6096    type = restype
 6097    %if type # 0 %start;  !not routine
 6098      %if hp_flags&volatile = 0 %start
 6099        p = explo
 6100        %while p < explim %cycle
 6101          %if dict(p)_act = headitem %start;  ![enough?]
 6102            item = p;  q = procnp
 6103            %cycle
 6104              %exit %if dict(p)_x # dict(q)_x %or dict(p)_y # dict(q)_y
 6105              p = p+1;  q = q+1
 6106              ->okf %if q >= np
 6107            %repeat
 6108          %finish
 6109          p = p+1
 6110        %repeat
 6111      %finish
 6112      copy down(procnp)
 6113      item = explo
 6114  okf:ditem == dict(item)
 6115      ditem_flags = hp_flags&heritable
 6116      ditem_mode = 0
 6117      %if hp_flags&writable # 0 %start;  !map
 6118        ditem_mode = dispmode
 6119      %finish
 6120      ditem_type = type
 6121      np = procnp
 6122    %finish
 6123  %end;  !get PARLIST
 6124  
 6125  !<<IMP
 6126  
 6127  %routine get RESOLUTION(%integer t,item1)
 6128  %integer fore,ftype,s
 6129  !  type check needed
 6130    s = size(t)
 6131    s = -256 %if s = 0
 6132    fore = 0
 6133    %unless a(left)=TRUE %start
 6134      get REFERENCE(stringstar)
 6135      fore = item;  ftype = type
 6136      get(dot);  get(left)
 6137    %finish
 6138    get VALUE(stringtype);  get(right)
 6139    %if item = 0 %start
 6140      item = litref(value);  s = s+final(value)
 6141    %finish
 6142    fault(rangerr+warn) %if fore # 0 %and s < size(ftype) # 0
 6143    putact(resolves,item1+ad,item+ad)
 6144    item = 0
 6145    %if a(dot)=TRUE %start
 6146      get REFERENCE(stringstar)
 6147      fault(rangerr+warn) %if s < size(type) # 0
 6148    %finish
 6149    putact(0,fore,item)
 6150    putact(0,0,0);       !preserve 'parity'
 6151  %end
 6152  
 6153  %integer%fn ANON(%record(objinfo)%name d)
 6154    dict(lablim+3)_details = d
 6155    %result = lablim+3
 6156  %end
 6157  
 6158  %integerfn A ASSOP(%integer t)
 6159    %if t <= 0 %start
 6160      %result = FALSE %unless a(eqeq)=TRUE
 6161    %else
 6162      atom = next atom %if matched # 0
 6163      %if atom # equals %start
 6164        %result = FALSE %unless atom = less %and byteintegeR(fp) = '-'
 6165        jammy = 1;  fp = fp+1
 6166      %finish %else jammy = 0
 6167      matched = 1
 6168    %finish
 6169    %result = TRUE
 6170  %end
 6171  
 6172  !<<BOTH
 6173  
 6174  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 6175  !
 6176  %routine GET EXPRESSION(%integer rank,etype)
 6177  !Main expression recognition routine
 6178  !To bring together the treatment of all binary operators
 6179  ! and ensure fast recognition of simple expressions,
 6180  ! expressions of different levels are handled by
 6181  ! precedence techniques rather than syntactically
 6182  %integer atomp0,item1,type1,cat1,val1,double,op
 6183  %record(identinfo)%name ditem1,tp
 6184  %constinteger nop=0;  !to distinguish from numeric zero in OPVAL
 6185  
 6186  %routine GET RECORD
 6187  ![literal only at this stage]
 6188  %integer fid,ad,arg,hold,count,max,s
 6189  %record(identinfo)%name darg,fidp
 6190    literal = literal+1
 6191    fill code(1) %if cad&1 # 0
 6192    ad = cad
 6193    fid = item;  fidp == ditem
 6194    arg = fidp_link
 6195    count = 0;  max = -1
 6196    get(left)
 6197    %cycle
 6198      ![*beware premature lexical coding: may alter CAD*]
 6199      %cycle
 6200        error(toomany+point) %if arg <= 0
 6201        darg == dict(arg)
 6202        %exit %if ad+darg_val-cad >= 0
 6203        arg = darg_hlink
 6204      %repeat
 6205      fill code(ad+darg_val-cad)
 6206     ! [*now OK to code atom*]
 6207      %if a(recsub)=TRUE %start
 6208        subbed = 1;  dformat == fidp
 6209        get(ident)
 6210        subbed = 0
 6211        name error %if item < arg
 6212        fill code(ditem_val-darg_val)
 6213        arg = item;  darg == ditem
 6214        syntax error %unless a assop(darg_flags&name+darg_type)=TRUE
 6215      %finish
 6216      s = nsize(darg)
 6217      %unless a(comma)=TRUE %start
 6218        get VALUE(darg_flags&name+darg_type)
 6219        %if s > 0 %start
 6220          %if s = 4 %start
 6221  !$IF VAX
 6222  {          value = ieee(value) %if darg_type = realtype %and darg_flags >= 0
 6223  !$FINISH
 6224            set code longword(value)
 6225          %finish %else %if s = 2 %start
 6226           set code word(value)
 6227          %else
 6228            final(cad) <- value;  cad = cad+1
 6229          %finish
 6230        %finish
 6231        %exit %if a(right)=TRUE
 6232        get(comma)
 6233      %finish %else %if s > 0 %start
 6234        fill code(s)
 6235      %finish
 6236      arg = darg_hlink
 6237    %repeat
 6238    fill code(ad+imod(fidp_val)-cad)
 6239    item = 0;  value = ad
 6240    literal = literal-1
 6241  %end
?HOLD unused
 6242  
 6243  %routine SWOP
 6244  %integer temp
 6245    temp = item1;  item1 = item;  item = temp
 6246    temp = val1;  val1 = value;  value = temp
 6247    temp = type1;  type1 = type;  type = temp
 6248  %end
 6249  
 6250  %constinteger INTOK=1<<inty, CHAROK=1<<chary,
 6251+               BOOLOK=1<<booly, ENUMOK=1<<enumy,
 6252+               REALOK=1<<realy, STRINGOK=1<<stringy,
 6253+               ARROK=1<<arry, SETOK=1<<sety,
 6254+               RECOK=1<<recy, POINTOK=1<<pointy,
 6255+               NUMOK=intok!realok,
 6256+               ORDOK=intok!charok!boolok!enumok,
 6257+               RELOK=ordok!realok!stringok
 6258  %routine CHECK1(%integer ok)
 6259    cat1 = category(type)
 6260    %if ok>>(cat1&cat)&1 = 0 %start
 6261      %if cat1 = inty %and ok&realok # 0 %start
 6262        toreal;  cat1 = realy
 6263      %finish %else %if ok&stringok # 0 %and valok(stringtype,type)=TRUE %start
 6264        cat1 = stringy
 6265      %else
 6266        fault(typerr+point)
 6267      %finish
 6268    %finish
 6269    type1 = type;  item1 = item;  val1 = value
 6270  %end
 6271  
 6272  %integer%fn FROZEN LIT(%integer t,v)
 6273  ! Used when the type of a literal will not be recoverable from context
 6274  %integer hold,res
 6275    hold = item
 6276    putexp(move,0,litref(v),t);  !NO-OP (distinctive Y)
 6277    ditem_flags = okflag+wflag
 6278    ditem_mode = constmode;  ditem_val = v
 6279    res = item;  item = hold
 6280    %result = res
 6281  %end
 6282  
 6283  %routine COERCE(%integer c)
 6284    %if c = inty %and cat1 = realy %start
 6285      toreal
 6286    %finish %else %if cat1 = inty %and c = realy %start
 6287      ![rather sloppy]
 6288      %if item1 # 0 %start
 6289        val1 = item;  item = item1
 6290        toreal
 6291        item1 = item;  item = val1
 6292      %finish %else real(addr(val1)) = val1
 6293      type1 = realtype;  cat1 = realy
 6294    %else
 6295      expfault(typerr)
 6296    %finish
 6297  %end
 6298  
 6299  %routine GET ARITH(%integer rank)
 6300    get EXPRESSION(rank,0)
 6301    rank = category(type)
 6302    coerce(rank) %if rank # cat1
 6303  %end
 6304  
 6305  %integer%fn RCOND(%integer op)
 6306  %constinteger EQUAL=2_1001000010,
 6307+               LESS =2_1010000001,
 6308+             GREATER=2_0101000001
 6309  %integer which,c
 6310  !<<IMP
 6311    check1(relok)
 6312    get EXPRESSION(major,0)
 6313    c = category(type)
 6314    coerce(c) %if c # cat1
 6315    %if equals <= atom <= greater %start;  ![ATOM always primed]
 6316      syntax error %if double >= 0
 6317      double = item
 6318    %finish %else %if double < 0 %start
 6319      double = -2
 6320    %finish
 6321  !<<BOTH
 6322    %if item1 = 0 %start
 6323      %if item = 0 %start
 6324        %if size(type1) > 0 %or item1!val1 = 0 %or item!value = 0 %start
 6325          !non-structure (compile-time)
 6326          ![integer tests ok for real?]
 6327          %if val1 < value %then which = less %c
 6328+         %else %if val1 = value %then which = equal %c
 6329+         %else which = greater
 6330          %result = which>>(op-bne)&1
 6331        %finish
 6332        item1 = frozen lit(type1,val1)
 6333      %else
 6334        swop
 6335        op = op!!3 %if op&8 # 0;  !no change for '=','#'
 6336      %finish
 6337    %finish
 6338    %result = op
 6339  %end;  !RCOND
 6340  !<<IMP
 6341  
 6342  %integer%fn OPVAL
 6343  ! Returns result value for literal (ITEM=ITEM1=0)
 6344  !         0 for no-op (result is ITEM1,TYPE1)
 6345  !         operator otherwise (result type is TYPE)
 6346  ! NB literal INTY type is always INTTYPE (not subrange)
 6347  %switch op(keyand:rshift)
 6348    -> op(atom)
 6349  op(plus):
 6350    check1(numok+setok)
 6351    get ARITH(star)
 6352    %if cat1 = inty %start
 6353      %if item1 = 0 %start
 6354        %result = val1+value %if item = 0
 6355        swop
 6356      %finish
 6357      %result = nop %if item!value = 0
 6358      type = inttype
 6359      %result = add
 6360    %else
 6361      %if item1 = 0 %start
 6362        %if item = 0 %start
 6363          real(addr(val1)) = real(addr(val1))+real(addr(value))
 6364          %result = val1
 6365        %finish
 6366        swop
 6367      %finish
 6368      %result = nop %if item!value = 0
 6369      %result = fadd
 6370    %finish
 6371  op(minus):
 6372    check1(numok+setok)
 6373    get ARITH(star)
 6374    %if cat1 = inty %start
 6375      %if item1 = 0 %start
 6376        %result = val1-value %if item = 0
 6377        swop %and %result = neg %if val1 = 0
 6378      %finish
 6379      type = inttype
 6380      %if item = 0 %start
 6381        %result = nop %if value = 0
 6382        value = -value %if value # minint
 6383        %result = add
 6384      %finish
 6385      %result = sub
 6386    %else
 6387      %if item = 0 %start
 6388        %if item1 = 0 %start
 6389          real(addr(val1)) = real(addr(val1))-real(addr(value))
 6390          %result = val1
 6391        %finish
 6392        %result = nop %if value = 0
 6393      %finish
 6394      %result = fsub
 6395    %finish
 6396  op(exclam):
 6397    check1(intok);  get EXPRESSION(star,inttype)
 6398    %if item1 = 0 %start
 6399      %result = val1!value %if item = 0
 6400      swop
 6401    %finish
 6402    %result = nop %if item!value = 0
 6403    type = inttype
 6404    %result = or
 6405  op(exclam2):
 6406    check1(intok);  get EXPRESSION(star,inttype)
 6407    %if item1 = 0 %start
 6408      %result = val1!!value %if item = 0
 6409      swop
 6410    %finish
 6411    %result = nop %if item!value = 0
 6412    type = inttype
 6413    %result = eor
 6414  op(ampersand):
 6415    check1(intok);  get EXPRESSION(star2,inttype)
 6416    %if item1 = 0 %start
 6417      %result = val1&value %if item = 0
 6418      swop
 6419    %finish
 6420    item1 = 0 %and %result = 0 %if item!value = 0
 6421    type = inttype
 6422    %result = and
 6423  op(star):
 6424    check1(numok+setok)
 6425    get ARITH(star2)
 6426    item1 = 0 %and %result = 0 %if item!value = 0
 6427    %if cat1 = inty %start
 6428      %if item1 = 0 %start
 6429        %result = val1*value %if item = 0
 6430        swop
 6431      %finish
 6432      type = inttype
 6433      %result = imul %if control&halfbit = 0
 6434      %result = muls
 6435    %else
 6436      %if item1 = 0 %start
 6437        %if item = 0 %start
 6438          real(addr(val1)) = real(addr(val1))*real(addr(value))
 6439          %result = val1
 6440        %finish
 6441        swop
 6442      %finish
 6443      %result = fmul
 6444    %finish
 6445  op(over):
 6446    check1(intok);  get EXPRESSION(star2,inttype)
 6447    %if item = 0 %start
 6448      fault(rangerr) %and %result = nop %if value = 0
 6449      %result = val1//value %if item1 = 0
 6450    %finish
 6451    type = inttype
 6452    %result = idiv
 6453  op(slash):
 6454    check1(realok)
 6455    get EXPRESSION(star2,realtype)
 6456    %if item = 0 %start
 6457      fault(rangerr) %and %result = nop %if value = 0
 6458      %if item1 = 0 %start
 6459        real(addr(val1)) = real(addr(val1))/real(addr(value))
 6460        %result = val1
 6461      %finish
 6462    %finish
 6463    %result = fdiv
 6464  op(backslash2): op(uparrow2):
 6465    check1(intok);  get EXPRESSION(simple,inttype)
 6466    %if item = 0 %start
 6467      %result = val1\\value %if item1 = 0
 6468      item1 = 0 %and %result = 1 %if value = 0
 6469      %result = nop %if value = 1
 6470      item = item1 %and %result = imul %if value = 2
 6471    %finish
 6472    type = inttype
 6473    %result = ipow
 6474  op(backslash): op(uparrow): op(star2):
 6475    check1(realok)
 6476    get EXPRESSION(simple,inttype)
 6477    type = realtype
 6478    %if item!item1 = 0 %start
 6479      real(addr(val1)) = real(addr(val1))\value
 6480      %result = val1
 6481    %finish
 6482    %result = fpow
 6483  op(lshift):
 6484    check1(intok);  get EXPRESSION(simple,inttype)
 6485    %if item = 0 %start
 6486      %result = val1<<value %if item1 = 0
 6487      %result = nop %if value = 0
 6488    %finish
 6489    type = inttype
 6490    %result = lsl
 6491  op(rshift):
 6492    check1(intok);  get EXPRESSION(simple,inttype)
 6493    %if item = 0 %start
 6494      %result = val1>>value %if item1 = 0
 6495      %result = nop %if value = 0
 6496    %finish
 6497    type = inttype
 6498    %result = lsr
 6499  op(tilde):
 6500    check1(intok)
 6501    get EXPRESSION(simple,inttype)
 6502    %result = \value %if item = 0
 6503    swop
 6504    type = inttype
 6505    %result = not
 6506  op(sconc):
 6507    check1(stringok);  get EXPRESSION(dot+1,stringtype)
 6508    %if item = 0 %start
 6509      %if item1 = 0 %start
 6510        %result = val1 %if value = 0
 6511        %result = value %if val1 = 0
 6512        %if final(val1)+final(value) <= 255 %start
 6513          string(final0+val1) = string(final0+val1) %c
 6514+                                  . string(final0+value)
 6515          cad = cad-1
 6516        %finish %else fault(rangerr)
 6517        %result = val1
 6518      %finish
 6519      %result = nop %if value = 0
 6520    %finish %else %if item1!val1 = 0 %start
 6521      item1 = item;  val1 = value;  type1 = type
 6522      %result = nop
 6523    %finish
 6524    type = stringtype
 6525    %result = concat
 6526  op(equals):
 6527    %result = RCOND(beq)
 6528  op(noteq):
 6529    %result = RCOND(bne)
 6530  op(lesseq):
 6531    %result = RCOND(ble)
 6532  op(less):
 6533    %result = RCOND(blt)
 6534  op(greateq):
 6535    %result = RCOND(bge)
 6536  op(greater):
 6537    %result = RCOND(bgt)
 6538  %integer%fn RACOND(%integer op)
 6539    toref
 6540    item1 = normitem;  type1 = type
 6541    get REFERENCE(type1)
 6542    val1 = 0 %and swop %if item1 = 0
 6543    syntax error %if arrow <= atom <= greater;  ![ATOM always primed]
 6544    double = -2
 6545    %result = op
 6546  %end
 6547  op(eqeq):
 6548    %result = RACOND(beq)
 6549  op(noteqeq):
 6550    %result = RACOND(bne)
 6551  op(arrow):
 6552    check1(stringok)
 6553    item1 = litref(val1) %if item1 = 0
 6554    get RESOLUTION(type,item1)
 6555    item1 = np-3
 6556    condop = bne!!polarity
 6557    type1 = booltype
 6558    %result = nop
 6559  op(keyand):
 6560    topred %if condop = 0
 6561    item1 = np;  type1 = booltype
 6562    putact(condop!!polarity!!1+polarity<<7,item,0)
 6563    condop = 0
 6564    get EXPRESSION(scond,booltype)
 6565    dict(item1)_y = item
 6566    syntax error %if a(keyor)=TRUE
 6567    %result = nop
 6568  op(keyor):
 6569    topred %if condop = 0
 6570    item1 = np;  type1 = booltype
 6571    putact(condop!!polarity+(polarity!!1)<<7,item,0)
 6572    condop = 0
 6573    get EXPRESSION(scond,booltype)
 6574    dict(item1)_y = item
 6575    syntax error %if a(keyand)=TRUE
 6576    %result = nop
 6577  %end
 6578  
 6579  !Get leading operand
 6580    atom = next atom %if matched # 0
 6581    atomp0 = atomp;  jammy = jammy<<1;  !preserve
 6582    %if atom = ident %start
 6583      matched = 1
 6584      name error %if item <= 0 %or (ditem_mode = labmode %and item < c_localdpos)
 6585      fault(namerr+point) %if item >= dlim0
 6586      type = ditem_type
 6587      %if ditem_flags&typeid # 0 %start
 6588        %if ditem_flags&cat = recy %and item > dnil %start
 6589          get RECORD
 6590          %return
 6591        %else
 6592          item1 = item;  ditem1 == ditem
 6593          %if a(less)=TRUE %start;  !type coercion
 6594            get VALUE(0);  get(greater)
 6595            type = item1
 6596          %else
 6597            get(left);          !store mapping
 6598            get VALUE(inttype)
 6599            get(right)
 6600            putexp2(storemap,item1,item1)
 6601            ditem_flags = writable!readable
 6602            ditem_mode = dispmode
 6603          %finish
 6604        %finish
 6605      %finish %else %if ditem_mode = litmode %start
 6606        item = 0;  value = ditem_val
 6607      %else;                                    !non-literal ident
 6608        %cycle
 6609          %if ditem_flags&proc # 0 %start
 6610            %if item = daddr %or item = dsizeof %or item = dnew %start
 6611              get(left)
 6612              %if item = daddr %start
 6613                get REFERENCE(0)
 6614                type = inttype
 6615              %else
 6616                item1 = item
 6617                get REFERENCE(0)
 6618                value = imod(size(type))
 6619                expfault(sizerr) %if value = 0
 6620                %if item1 = dsizeof %start
 6621                  item = 0;  type = inttype
 6622                %else
 6623                  putexp(dnew,0,litref(value),0)
 6624                  ditem_mode = dispmode
 6625                %finish
 6626              %finish
 6627              get(right)
 6628  !          %finish %else %if item = dsnl %start
 6629  !            putexp(dtostring,nl,0,string1)
 6630            %else
 6631              get PARLIST(0)
 6632              atomp=atomp0 %and error(classerr+point) %if type = 0;  !routine
 6633            %finish
 6634          %else;                                   !not procedure
 6635            atom = next atom %if matched # 0
 6636            %exit %unless aleft <= atom <= recsub %and rank <= simple
 6637            %if atom = aleft %start;  !array subscript
 6638              %cycle
 6639                item1 = item;  ditem1 == ditem
 6640                tp == typecell(type)
 6641                %if tp_flags&cat = stringy %start
 6642                  matched = 1
 6643                  nonstandard(2)
 6644                  get VALUE(bytetype)
 6645                  putexp2(sindex,item1,chartype)
 6646                %else
 6647                  -> out %unless tp_flags&cat = arry
 6648                  matched = 1
 6649                  get VALUE(tp_xtype);  !get index
 6650                  putexp2(index,item1,tp_type)
 6651                %finish
 6652                ditem_flags = ditem1_flags&heritable
 6653                ditem_mode = ditem1_mode
 6654              %repeat %until %not a(comma)=TRUE
 6655              ditem_flags = ditem_flags+(tp_flags&name)
 6656              get(right)
 6657            %finish %else %if atom = recsub %start;  !record subfield
 6658              item1 = item;  ditem1 == ditem
 6659              dformat == typecell(ditem_type)
 6660              syntax error %unless dformat_flags&cat = recy
 6661              matched = 1
 6662              subbed = 1;  get(ident);  subbed = 0
 6663              error(namerr+point) %if item <= 0
 6664              val1 = ditem1_flags&heritable!ditem_flags
 6665              putexp2(recref,item1,ditem_type)
 6666              ditem_flags = val1
 6667              ditem_mode = ditem1_mode
 6668            %finish %else %if atom = atsign %start
 6669              nonstandard(4)
 6670              syntax error %if ditem_flags&typeid = 0
 6671              matched = 1
 6672              ditem1 == ditem;  item1 = item
 6673              get EXPRESSION(vsimple,inttype)
 6674              putexp2(storemap,item1,item1)
 6675              ditem_flags = writable!readable
 6676              ditem_mode = dispmode
 6677            %else;  !pointer relative
 6678              error(nonref+point) %if ditem_mode < dispmode
 6679              fault(sizerr) %if size(ditem_type) = 0
 6680              matched = 1
 6681              ditem1 == ditem;  item1 = item
 6682              get VALUE(inttype);  get(rightb)
 6683              putexp2(prel,item1,ditem1_type)
 6684              ditem_flags = writable!readable
 6685              ditem_mode = ditem1_mode
 6686            %finish
 6687          %finish
 6688        %repeat
 6689      %finish
 6690    %else
 6691      %if atom = const %start
 6692        matched = 1
 6693      %finish %else %if atom = minus %start;  !leave unmatched
 6694        item = 0;  value = 0;  type = inttype
 6695      %finish %else %if atom = left %start
 6696        matched = 1
 6697        %if rank < major %start;  !condition
 6698          get EXPRESSION(condq,0)
 6699        %else
 6700          get EXPRESSION(major,0)
 6701        %finish
 6702        get(right)
 6703      %finish %else %if a(keynot)=TRUE %start
 6704        syntax error %if rank >= major
 6705        polarity = polarity!!1
 6706        get EXPRESSION(scond,booltype)
 6707        %if item = 0 %then value = value!!1
 6708        polarity = polarity!!1
 6709      %finish %else %if atom = backslash %start
 6710        item = 0;  value = 0;  type = inttype
 6711        atom = tilde
 6712      %finish %else %if a(modsign)=TRUE %start
 6713        get EXPRESSION(major,0)
 6714        %if valok(inttype,type)=TRUE %start
 6715          %if item = 0 %start
 6716            %if value < 0 %start
 6717              %if value # minint %then value = -value %else expfault(rangerr)
 6718            %finish
 6719          %else
 6720            putexp2(iabs,0,inttype)
 6721          %finish
 6722        %finish %else %if valok(realtype,type)=TRUE %start
 6723          putexp2(fabs,0,realtype)
 6724        %else
 6725          error(typerr+point)
 6726        %finish
 6727        get(modsign)
 6728      %else
 6729        syntax error
 6730      %finish
 6731    %finish
 6732  out:
 6733    atom = next atom %if matched # 0;  ![always primed on return]
 6734  
 6735    %if etype < 0 %start;  !reference required
 6736      expp = atomp0;  jammy = jammy>>1;  !restore
 6737  %unless item!value = 0 %start;  !*temp*
 6738      toref
 6739      expfault(typerr) %unless refok(etype-sign16,type)=TRUE
 6740  %finish %else atomp = atomp0 %and nonstandard(21)
 6741    %else
 6742      %while atom >= rank %cycle
 6743        matched = 1
 6744        double = -1
 6745        op = opval
 6746        %if item1!item = 0 %start;  !both literal
 6747          %if double # -1 %start
 6748            %if double >= 0 %start
 6749              literal = literal+1;  !enforce all literal
 6750              op = op&opval
 6751              literal = literal-1
 6752            %finish
 6753            type = booltype
 6754          %finish
 6755          value = op
 6756        %finish %else %if double = -1 %start;         !not relop
 6757          %if op # 0 %start
 6758            item1 = litref(val1) %if item1 = 0
 6759            putexp(op,item1,normitem,type)
 6760          %else;         !nop
 6761            item = item1;  type = type1
 6762          %finish
 6763        %else;                      !conditional operation
 6764          condop = op!!polarity
 6765          putact(compare,item1,normitem)
 6766          item = np-1
 6767          %if double >= 0 %start
 6768            putact(condop!!polarity!!1+polarity<<7,np-1,np+1);  !implicit %and
 6769            item = double;  ![TYPE,VALUE unchanged]
 6770            matched = 1
 6771            op = opval
 6772            error(nonliteral) %if item1!item = 0;  !mixed non-lit, lit
 6773            condop = op!!polarity
 6774            putact(compare,item1,normitem)
 6775            item = np-2
 6776          %finish
 6777          type = booltype
 6778        %finish
 6779      %repeat
 6780      expp = atomp0;  jammy = jammy>>1
 6781      %if etype # 0 %start
 6782        %if type = booltype %start
 6783          topred %if (rank = cond %or rank = scond) %and condop = 0
 6784        %finish
 6785        expfault(typerr) %unless valok(etype,type)=TRUE
 6786      %finish
 6787    %finish
 6788    atomp=expp %and error(nonliteral+point) %if literal # 0 %and item # 0
 6789  %end;
?POINTOK unused
?RECOK unused
?ARROK unused
 6790       ;  !get EXPRESSION
 6790    
 6791  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 6792  !!!!!!!!!!!!!!!!!!!!  Conditions and loops  !!!!!!!!!!!!!!!!!!!!
 6793  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 6794  !
 6795  %routine GET CONDITION
 6796  %integer maxlab,condnp
 6797  
 6798  %routine ASSIGN LABELS(%integer p,lab,pol)
 6799  %integer base
 6800  %record(identinfo)%name dp
 6801    base=maxlab
 6802    %while (p-condnp)&1 # 0 %cycle;  !compound
 6803      dp == dict(p);  p = dp_y
 6804      %if dp_act&1<<7 = pol %then assign labels(dp_x,lab,pol) %c
 6805+     %else maxlab = base+1 %and assign labels(dp_x,maxlab,pol!!1<<7)
 6806    %repeat
 6807    dp == dict(p+1);  dp == dict(p+3) %if dp_act = 0;  !resolution
 6808    %if maxlab > base %then dp_x = maxlab %and maxlab = base %c
 6809+   %else dp_x = 0
 6810    dp_y = lab
 6811    dp_act = dp_act&127
 6812  %end
 6813  
 6814    condnp = np
 6815    polarity = subatom;  condop = 0
 6816    get EXPRESSION(cond,booltype)
 6817    putact(condop!!1,item,0)
 6818    %return %if faultnum > 0
 6819    maxlab = curlab+1
 6820    assign labels(item,maxlab,0)
 6821  %end;  !get CONDITION
 6822  
 6823  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 6824  
 6825  %routine DO DYNAMIC ARRAYS
 6826    update sp
 6827    c_mode = c_mode!2_01000000;   !bar to SP rel addressing
 6828    c_status = c_status!globbed;  !needs link
 6829    %while c_dynarray # 0 %cycle
 6830      %if c_dynarray < 0 %then putact(aget,-c_dynarray,one) %c
 6831+     %else putact(aget,c_dynarray,0)
 6832      c_dynarray = dict(imod(c_dynarray))_link
 6833    %repeat
 6834    compile(np0)
 6835  %end
 6836  
 6837  %routine GET STATEMENTS(%integer stopper)
 6838  ! STOPPER = 0          -- initial call
 6839  !           1 (END)    -- for procedure or block body
 6840  !           2 (REPEAT) -- for loop body
 6841  !           3 (FINISH) -- for condition body (ELSE not valid)
 6842  !           4 (ELSE)   --         "          (ELSE valid)
 6843  %switch initial(0:atommax)
 6844  %integer forinf,endval,loopstart
 6845  
 6846  %routine THIS IS INST
 6847    %if c_status < hadinst %start;  !first in block
 6848      c_status = c_status+hadinst
 6849      fault(ordererr) %if stopper = 0
 6850    %finish
 6851    fault(accesserr+warn) %if c_access = 0 %and np = np0
 6852    do dynamic arrays %if c_dynarray # 0
 6853  %end
 6854  
 6855  %routine PUTACT2(%integer act,item1)
 6856    putact(act,item1,normitem)
 6857  %end
 6858  
 6859  %routine GET RESULT
 6860    get VALUE(c_type)
 6861  !  fault(rangerr+warn) %if c_type > 0 %and item # 0 %c
 6862  !                      %and imod(size(type)) > imod(size(c_type))
 6863  %end
 6864  
 6865  %routine GET INSTRUCTION
 6866  %integer item1
 6867  %record(identinfo)%name tp
 6868    this is inst
 6869    %cycle
 6870      %if a(ident)=TRUE %start
 6871        name error %if item <= 0
 6872        %if ditem_flags&(writable!typeid) # 0 %start
 6873          matched = 0
 6874          get EXPRESSION(simple,0)
 6875          item1 = item
 6876          %if a(equals)=TRUE %start
 6877            jammy = 0
 6878            get VALUE(type)
 6879            putact2(okass+jammy,item1);  !okass,assign
 6880          %finish %else %if a(eqeq)=TRUE %start
 6881            syntax error %if ditem_flags >= 0
 6882            get REFERENCE(type)
 6883            putact2(assign,item1+ad)
 6884          %finish %else %if atom = less %and byteintegeR(fp) = '-' %start
 6885            fp = fp+1;  matched = 1
 6886            jammy = 1
 6887            get VALUE(type)
 6888            putact2(jamass+jammy,item1);  !jamass,okass
 6889          %else
 6890            syntax error %unless a(arrow)=TRUE
 6891            get RESOLUTION(type,item1)
 6892            putact(bne,0,curlab)
 6893            putact(signal,litref(7),undef)
 6894            putact(0,undef,undef)
 6895          %finish
 6896        %else
 6897          error(classerr+point) %if ditem_flags&proc = 0
 6898          tp == typecell(ditem_type)
 6899          %if tp_type # 0 %start;  !function as routine
 6900            get PARLIST(tp_type)
 6901            putact2(assign,value)
 6902          %else
 6903            get PARLIST(0)
 6904          %finish
 6905        %finish
 6906      %else
 6907        c_access = 0 %if np = np0;  !unconditional
 6908        %if a(keymonitor)=TRUE %start
 6909          c_access = 1
 6910  !        fault(monitor<<8)
 6911       %finish %else %if a(exit)=TRUE %start;  !%exit, %continue
 6912          %if c_looplab = 0 %then fault(notinloop+point) %c
 6913+         %else putact(jumpout,c_looplab,c_looplab+subatom)
 6914          %exit
 6915       %finish %else %if a(keyreturn)=TRUE %start
 6916          item = 0;  value = 0
 6917          get RESULT %if c_type # 0
 6918          putact2(return,0)
 6919          %exit
 6920       %finish %else %if a(keyresult)=TRUE %start
 6921          error(notinfun+point) %if c_type = 0
 6922          syntax error %unless a assop(c_type)=TRUE
 6923          get RESULT
 6924          putact2(return,0)
 6925          %exit
 6926       %finish %else %if a(tf)=TRUE %start;  !%true, %false
 6927          %if c_type # booltype %then fault(notinpred+point) %c
 6928+         %else putact(return,0,litref(subatom))
 6929          %exit
 6930       %finish %else %if a(arrow)=TRUE %or a(keygoto)=TRUE %start
 6931          nonstandard(5) %if atom = keygoto
 6932          get(ident)
 6933          %if byteinteger(fp) # '(' %start
 6934            declare(forwardlabel) %if item < c_localdpos {new} %c
 6935+                                 %or ditem_type # 0 {error}
 6936            putact2(goto,0)
 6937          %else
 6938            name error %if item < c_localdpos
 6939            error(classerr+point) %unless ditem_mode = labmode %c
 6940+                                 %and ditem_type # 0
 6941            item1 = item
 6942            get(left)
 6943            get VALUE(typecell(ditem_type)_xtype);  !index
 6944            get(right)
 6945            putact2(swgoto,item1)
 6946          %finish
 6947          %exit
 6948       %finish %else %if a(keystop)=TRUE %start
 6949          putact(stop,0,0)
 6950          %exit
 6951       %finish %else %if a(keysignal)=TRUE %start
 6952          c_access = 1
 6953          allow(keyevent)
 6954          get LITERAL(inttype)
 6955          expfault(rangerr) %unless 0 <= value <= 15
 6956          item1 = litref(value);  item = undef
 6957          %if a(comma)=TRUE %start
 6958  l1:       %if a(comma)=TRUE %then matched = 0 %else get VALUE(bytetype)
 6959          %finish
 6960          putact2(signal,item1)
 6961          item = undef
 6962          %if a(comma)=TRUE %start
 6963  l2:       %if a(comma)=TRUE %then matched = 0 %else get VALUE(inttype)
 6964          %finish
 6965          item1 = normitem;  item = undef
 6966          get VALUE(stringtype) %if a(comma)=TRUE
 6967          putact2(0,item1)
 6968          %exit
 6969        %else
 6970          syntax error
 6971        %finish
 6972      %finish
 6973    %repeat %until %not a(keyand)=TRUE
 6974  %end;
?L2 unused
?L1 unused
 6975       ;  !GET INSTRUCTION
 6975  
 6976  %routine GET FOR CLAUSE
 6977  !Global: FORINF,ENDVAL
 6978  %integer loopvar,lvtype,k,s,start,sval,i,inc,ival,e,n
 6979  %integer end
 6980  %record(identinfo)%name tp
 6981    forinf = 0
 6982    get(ident)
 6983    name error %if item <= 0
 6984    lvtype = ditem_type;  tp == typecell(lvtype)
 6985    fault(typerr+point) %if tp_flags&nonord # 0
 6986    loopvar = item
 6987    get(equals)
 6988    get VALUE(lvtype)
 6989    start = item;  sval = value
 6990    get(comma)
 6991    get VALUE(lvtype)
 6992    inc = item;  ival = value
 6993    expfault(rangerr) %and ival = 1 %if inc = 0 = ival
 6994  !Deal with INC and replace START by START-INC
 6995    k = undef
 6996    k = dict(start)_y %if start >= np0 %and dict(start)_act = add
 6997    %if inc = 0 %start;  !literal increment
 6998      i = litref(ival)
 6999      %if start = 0 %start;  !START and INC both literal
 7000        sval = sval-ival;  item = litref(sval)
 7001      %finish %else %if k <= 0 %start;  !START is x+lit
 7002        k = litval(k)-ival
 7003        item = dict(start)_x
 7004        putexp(add,item,litref(k),inttype) %if k # 0
 7005      %else
 7006        putexp(add,start,litref(-ival),inttype)
 7007      %finish
 7008    %else;  !variable
 7009      i = inc
 7010      %if control&volbit # 0 %start
 7011        declare temp(inttype);  i = item
 7012        putact(assign,i,inc);  forinf = forinf-4
 7013      %finish
 7014      %if start = inc %start;  !identical
 7015        item = 0;  sval = 0
 7016      %finish %else %if k = inc %start;  !START is x+INC
 7017        item = dict(start)_x
 7018      %else
 7019        item = start;  item = litref(sval) %if item = 0
 7020        putexp(sub,item,i,inttype)
 7021      %finish
 7022    %finish
 7023    s = item
 7024  !Get end-value
 7025    get(comma)
 7026    get VALUE(lvtype)
 7027    end = item
 7028    %if end = 0 %start;  !literal end-value
 7029      e = litref(value);  endval = value
 7030    %else
 7031      e = item
 7032      %if control&volbit # 0 %start
 7033        declare temp(inttype);  e = item
 7034        putact(assign,e,end);  forinf = forinf-4
 7035      %finish
 7036    %finish
 7037    %if start!inc!end # 0 %and control&loopbit # 0 %start
 7038      putact(forass,loopvar,s)
 7039      putact(forass,i,e)
 7040    %else
 7041      putact(assign,loopvar,s)
 7042    %finish
 7043    putact(label,curlab,0)
 7044    %if start!inc!end = 0 %start;  !all literal
 7045      k = endval-sval;  n = k//ival
 7046      %if n = 0 %start
 7047        fault(dubious+warn)
 7048        putact(else,0,curlab+1);  !ie unconditional branch
 7049        %return
 7050      %finish
 7051      fault(boundserr) %if n < 0
 7052      fault(unending) %if n*ival # k
 7053      forinf = loopvar
 7054    %else
 7055      putact(compare,loopvar,e)
 7056      putact(beq,0,curlab+1)
 7057    %finish
 7058    putact(incass,loopvar,i)
 7059  %end;  !get FORCLAUSE
 7060  
 7061  %routine GET LOOP BODY
 7062  %integer hold
 7063    hold=c_looplab
 7064    c_looplab = curlab;  curlab = curlab+2
 7065    get STATEMENTS(keyrepeat)
 7066    curlab = curlab-2;  c_looplab = hold
 7067  %end
 7068  
 7069  %routine GET SWITCH INDEX
 7070  %integer i,lo,hi
 7071  %record(identinfo)%name dp,tp
 7072  %routine SET LABEL(%shortname p)
 7073    value = p
 7074    expfault(duperr) %if value > 0
 7075    set user label(value)
 7076    p = value
 7077  %end
 7078    dp == ditem;  tp == typecell(ditem_type)
 7079    get(left)
 7080    %if a(star)=TRUE %start
 7081      set label(dp_link)
 7082    %else
 7083      get VALUE(tp_xtype)
 7084     !beware faulty declaration or index
 7085      %if tp_xtype > inttype %and faultnum = 0 %start
 7086        get bounds(tp_xtype,lo,hi)
 7087        i = value-lo+dp_val
 7088        c_forward = c_forward-1 %if i < pc;  !(had goto)
 7089        set label(prog(i))
 7090      %finish
 7091    %finish
 7092    get(right)
 7093  %end
 7094  
 7095  ![unsure of efficiency implications of trapping overflow lower down]
 7096  %on %event oflow,fail,done %start
 7097    %if event_event = 0 %start;  !failure in %option,%include or ^Y
 7098      %stop %if event_sub # 0
 7099      %signal abandon
 7100    %finish
 7101    %if event_event = done %start
 7102      croak("Premature end of input") %if stopper # 0
 7103      close block
 7104      c_dpid_val = 0;  !zero entry-point
 7105      %return
 7106    %finish
 7107    fault(rangerr+now) %if event_event = oflow
 7108    -> ignore
 7109  %finish
 7110  !!!!!!!!!!!!!!!!!!!  Start of new statement  !!!!!!!!!!!!!!!!!!!
 7111  next:
 7112    statements = statements+1
 7113    compile(startnp) %if np > np0
 7114    define label(curlab) %if dict(curlab)_val < 0
 7115    define label(curlab+1) %if dict(curlab+1)_val < 0
 7116  next1:
 7117    report(faultnum,0,0) %if faultnum # 0
 7118    dlim0 = dlim
 7119    speccing = 0;  subbed = 0
 7120    literal = 0;  jammy = 0;  condop = 0
 7121    dict(curlab)_val = 0;  dict(curlab+1)_val = 0
 7122    np = np0;  startnp = np0
 7123    maxcalldreg = maxdreg;  maxcallareg = maxareg
 7124    zaps = zaps+1 %and forget all %if explo < np0+50
 7125    zaps = zaps+1000 %and forget all %if litpos > litmax-40
 7126    value = 0
 7127  !
 7128  initial(terminator):
 7129    atom = next atom;  matched = 1
 7130    -> initial(atom)
 7131  
 7132  initial(keycomment): initial(exclam): initial(exclam2):
 7133    comments = comments+1
 7134    read line(0)
 7135    -> next1
 7136  term:
 7137    get(terminator)
 7138    -> next
 7139  
 7140  ignore:
 7141    c_access = -1
 7142    %if atom # terminator %start
 7143      %cycle
 7144        subatom = atom;  atom = next atom
 7145      %repeat %until atom = terminator
 7146      starts = starts+1 %if subatom = keystart
 7147      cycles = cycles+1 %if subatom = keycycle
 7148    %finish
 7149    -> next1
 7150  
 7151  initial(dud):
 7152    syntax error;  !ie atom error
 7153  
 7154  initial(*):
 7155    error(nonstarter+point)
 7156  
 7157  initial(ident):
 7158    %if byteintegeR(fp) = ':' %start;  !simple label
 7159      fp = fp+1
 7160      declare(definedlabel)
 7161      set user label(ditem_val)
 7162      ->next
 7163    %finish
 7164    name error %if item <= 0
 7165    %if ditem_mode = labmode %and ditem_type # 0 %start
 7166      literal = 1
 7167      get SWITCH INDEX
 7168      get(colon)
 7169      ->next
 7170    %finish
 7171  initial(keyreturn): initial(keyresult): initial(tf):
 7172  initial(keystop): initial(keysignal): initial(keymonitor):
 7173  initial(exit): initial(keygoto): initial(arrow):
 7174    matched = 0
 7175    get INSTRUCTION
 7176    -> next %if a(terminator)=TRUE
 7177    c_access = 1
 7178    %if a(iu)=TRUE %start
 7179      startnp = np
 7180      get CONDITION
 7181    %finish %else %if a(keywhile)=TRUE %start
 7182      putact(repeat,curlab,0);  !append repeat
 7183      startnp = np
 7184      define label(curlab)
 7185      get CONDITION
 7186   %finish %else %if a(keyfor)=TRUE %start
 7187      putact(0,0,0)
 7188      putact(0,0,0)
 7189      putact(repeat,curlab,0);  !append repeat
 7190      startnp = np
 7191      get FOR CLAUSE
 7192      value = np;  np = startnp-3
 7193      %if forinf > 0 %start
 7194        putact(compare,forinf,litref(endval))
 7195        putact(beq,0,curlab)
 7196      %finish %else np = np+2
 7197      putact(repeat,curlab,forinf)
 7198      np = value
 7199    %else
 7200      syntax error %unless a(keyuntil)=TRUE
 7201      get CONDITION
 7202      putact(repeat,curlab,0)
 7203      define label(curlab)
 7204    %finish
 7205    -> term
 7206  
 7207  initial(iu):  !%if, %unless
 7208    this is inst
 7209    %cycle
 7210      get CONDITION
 7211      %if a(keythen)=TRUE %and %not a(keystart)=TRUE %start
 7212        get INSTRUCTION
 7213      %else
 7214        matched = 0;   ![unsee %start]
 7215        get(keystart)
 7216        %cycle
 7217          get(terminator)
 7218          curlab = curlab+2
 7219          get STATEMENTS(keyelse)
 7220          curlab = curlab-2
 7221          %exit %if atom # keyelse;  !%finish ->
 7222          putact(else,curlab+1,curlab)
 7223          -> exit2 %unless a(iu)=TRUE
 7224          get CONDITION
 7225        %repeat
 7226        -> initial(keyend) %if atom = keyend
 7227      %finish
 7228      -> term %unless a(keyelse)=TRUE
 7229      putact(else,curlab+1,curlab)
 7230    %repeat %until %not a(iu)=TRUE
 7231    %unless a(keystart)=TRUE %start
 7232      get INSTRUCTION
 7233    %else
 7234  exit2:
 7235      get(terminator)
 7236      curlab = curlab+2
 7237      get STATEMENTS(keyfinish)
 7238      curlab = curlab-2
 7239      -> initial(keyend) %if atom = keyend
 7240    %finish
 7241    -> term
 7242  
 7243  initial(keycycle):
 7244    this is inst
 7245    %if a(terminator)=TRUE %start
 7246      define label(curlab)
 7247      get LOOP BODY
 7248      -> initial(keyend) %if atom = keyend
 7249      get CONDITION %if a(keyuntil)=TRUE
 7250      putact(repeat,curlab,0)
 7251      -> term
 7252    %finish
 7253    nonstandard(22)
 7254    get FOR CLAUSE
 7255    -> for1
 7256  initial(keywhile):
 7257    this is inst
 7258    define label(curlab)
 7259    get CONDITION
 7260    get(keycycle)
 7261    get(terminator)
 7262    compile(np0)
 7263    get LOOP BODY
 7264    -> initial(keyend) %if atom = keyend
 7265    nonstandard(6) %and get CONDITION %if a(keyuntil)=TRUE
 7266    putact(repeat,curlab,0)
 7267    ->term
 7268  initial(keyfor):
 7269    this is inst
 7270    get FOR CLAUSE
 7271    get(keycycle)
 7272  for1:
 7273    get(terminator)
 7274    compile(np0)
 7275    %if forinf > 0 %start;           !Literal for loop
 7276     !%continue must come to end for increment
 7277      loopstart = dict(curlab)_val;  !save start position
 7278      dict(curlab)_val = 0
 7279    %finish
 7280    get LOOP BODY
 7281    -> initial(keyend) %if atom = keyend
 7282    %if forinf > 0 %start;  !literal FOR loop
 7283      define label(curlab)
 7284      dict(curlab)_val = loopstart;  !restore
 7285      putact(compare,forinf,litref(endval))
 7286      putact(beq,0,curlab)
 7287    %finish
 7288    putact(repeat,curlab,forinf)
 7289    -> term
 7290  
 7291  initial(keyon):
 7292    fault(ordererr+point) %if c_status >= hadon %or stopper = 0
 7293    do dynamic arrays %if c_dynarray # 0
 7294    c_status = c_status!hadon
 7295    matched = 1
 7296    allow(keyevent)
 7297    dump = 0
 7298    %cycle
 7299      get LITERAL(inttype)
 7300      expfault(rangerr) %unless 0 <= value <= 15
 7301      dump = dump!1<<value
 7302    %repeat %until %not a(comma)=TRUE
 7303    get(keystart)
 7304    putact(settrap,0,litref(dump))
 7305    curlab = curlab+2
 7306    get STATEMENTS(keyfinish)
 7307    curlab = curlab-2
 7308    -> initial(keyend) %if atom = keyend
 7309    -> term
 7310  !
 7311  initial(keyelse):
 7312    -> ignore %if starts # 0
 7313    %return %if stopper = keyelse
 7314    error(noif) %if stopper = keyfinish
 7315  initial(keyfinish):
 7316    starts = starts-1 %and -> ignore %if starts # 0
 7317    %return %if stopper = keyfinish %or stopper = keyelse
 7318    error(nostart)
 7319  initial(keyrepeat):
 7320    cycles = cycles-1 %and -> ignore %if cycles # 0
 7321    %return %if stopper = keyrepeat
 7322    error(nocycle)
 7323  
 7324  initial(star):
 7325    fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0
 7326    matched = 1
 7327    %if byteinteger(fp) = '=' %start
 7328      fp = fp+1
 7329      get LITERAL(inttype)
 7330      plant(dc,0,temp(absmode,value))
 7331    %else
 7332      get MCODE
 7333    %finish
 7334    ->term
 7335  
 7336  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 7337  !!!!!!!!!!!!!!!!!!!!  Declarations  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 7338  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 7339  !
 7340  %routine DECLARE LIT RANGE(%integer basetype,lo,hi)
 7341  %own%record(objinfo) D=0
 7342    fault(boundserr) %and hi = lo %if lo > hi
 7343    item = ranges
 7344    %cycle
 7345      ditem == dict(item)
 7346      item = item-2 %and %return %if ditem_val = hi %and ditem_type = basetype %c
 7347+           %and dict(item-1)_val = lo
 7348      item = ditem_hlink
 7349    %repeat %until item = 0
 7350    declare anon(d);               !blank (for updating)
 7351    declare range(basetype,lo,hi)
 7352  %end
 7353  
 7354  %routine DECLARE STRING TYPE(%integer size)
 7355    item = stringtype %and %return %if size = -256
 7356    item = string1 %and %return %if size = -2
 7357    item = ranges
 7358    %cycle
 7359      ditem == dict(item)
 7360      %return %if ditem_size = size %and ditem_type = chartype
 7361      item = ditem_hlink
 7362    %repeat %until item = 0
 7363    declare anon(details(typeid+stringy,chartype,0,0))
 7364    ditem_size = size
 7365    ditem_hlink = ranges;  ranges = item
 7366  %end
 7367  
 7368  %routine GET LIT RANGE(%integer basetype)
 7369  %integer holdval
 7370    get LITERAL(basetype);  holdval = value
 7371    get(colon)
 7372    get LITERAL(basetype)
 7373    declare lit range(basetype,holdval,value)
 7374  %end
 7375  
 7376  %routine GET IDENTLIST(%record(objinfo)%name d)
 7377    dlim0 = dlim
 7378    get(ident) %and declare(d) %until %not a(comma)=TRUE
 7379  %end
 7380  
 7381  %routine RECALIGN(%integername val)
 7382    align(val,2)
 7383    val = -val %if val > 4
 7384  %end
 7385  
 7386  %routine GET DECLARATION(%integer FLAGS,MODE,%integer%name DISP,%integer DEPTH)
 7387  %record(objinfo) DECL
 7388  %record(identinfo)%name DFHOLD
 7389  %owninteger ITEMTYPE=0,ITEMSIZE=0,ADIM=0
 7390  %integer BASE,HOLD,MAX,STMAX,DREG,AREG
 7391  
 7392  %routine%spec GET VAR BOUND
 7393  
 7394  %routine GET DATA TYPE
 7395  %switch s(ktype:keyname)
 7396    atom = next atom %if matched # 0
 7397    syntax error %unless kattrib <= atom <= keyname
 7398    matched = 1
 7399    -> s(atom)
 7400  s(ktype):
 7401    itemtype = inttype+subatom
 7402    itemsize = size(itemtype)
 7403    nonstandard(7) %if itemtype >= mitetype
 7404    allow(keyinteger)
 7405    %return
 7406  s(keyinteger):                    !%integer
 7407    itemtype = inttype;  itemsize = 4
 7408    %if a(left)=TRUE %start
 7409      nonstandard(8)
 7410      get LIT RANGE(inttype)
 7411      get(right)
 7412      itemtype = item
 7413      itemsize = typecell(itemtype)_size
 7414    %finish
 7415    %return
 7416  s(keylong):                   !%long
 7417    itemtype = inttype;  itemsize = 4;  !**for now**
 7418    %if a(keyinteger)=TRUE %then fault(notin+point+warn) %c
 7419+   %else itemtype = realtype %and get(keyreal)
 7420    %return
 7421  s(keyreal):                   !%real
 7422    itemtype = realtype;  itemsize = 4
 7423    %return
 7424  s(keystring):                 !%string
 7425    itemsize = 0
 7426    %if a(left)=TRUE %start
 7427      atom = next atom
 7428  !    %if depth # 0 %and ktype <= atom <= keyinteger %start
 7429  !      get VAR BOUND
 7430  !      itemtype = stringstar
 7431  !    %finish %else %if a(star)=TRUE %start
 7432       %if a(star)=TRUE %start
 7433        itemtype = stringstar
 7434      %else
 7435        get LITERAL(bytetype)
 7436        itemsize = -(value+1)
 7437        declare string type(itemsize)
 7438        itemtype = item
 7439      %finish
 7440      get(right)
 7441    %else
 7442      syntax error %if mode # constmode
 7443      itemtype = stringtype
 7444    %finish
 7445    %return
 7446  s(keyrecord):                    !%record
 7447    get(left)
 7448    %unless a(star)=TRUE %start
 7449      %unless a(ident)=TRUE %start
 7450        declare anon(typeident)
 7451        hold = item;  dfhold == dformat
 7452        dformat == ditem
 7453        get DECLARATION(writable+readable,0,dformat_val,0)
 7454        recalign(dformat_val)
 7455        ditem == dformat
 7456        dformat == dfhold;  item = hold
 7457      %finish
 7458      name error %if item <= 0
 7459      error(classerr+point) %if ditem_flags&(\spec) # typeid+recy
 7460      itemtype = item;  itemsize = ditem_val
 7461    %else
 7462      itemtype = recstar;  itemsize = 0
 7463    %finish
 7464    get(right)
 7465    %return
 7466  s(keyname):    !untyped %name - leave unmatched
 7467    itemtype = 0;  matched = 0
 7468  %end
 7469  
 7470  %routine ASSIGN ADDRESS(%integer size)
 7471  
 7472  %routine ASSIGN STACK ADDRESS
 7473    align(stmax,2);  ditem_val = stmax
 7474    stmax = stmax+imod(size)
 7475    c_status = c_status!onstack %if depth = 1 %and speccing = 0
 7476  %end
 7477  
 7478    size = -4 %if ditem_flags&(name+indirect) # 0
 7479    %if depth # 0 %start
 7480      dlink_link = item;  dlink == ditem
 7481      %if size > 0 %start
 7482       !simple value
 7483        %if dreg > maxcalldreg %start
 7484          assign stack address
 7485          %return
 7486        %finish
 7487        c_reg_content(dreg) = item %if speccing = 0
 7488        ditem_reg = dreg-d0;  dreg = dreg+1
 7489      %else
 7490        %if areg > maxcallareg %start
 7491          assign stack address
 7492          ditem_reg = 8     {would have been in AREG}
 7493          %return
 7494        %finish
 7495        c_reg_content(areg) = item+ad %if speccing = 0 %and ditem_flags < 0
 7496        ditem_reg = areg-d0;  areg = areg+1
 7497      %finish
 7498    %finish
 7499    size = imod(size)
 7500    align(disp,size)
 7501    ditem_val = disp
 7502    %if constmode # ditem_mode # ownmode %start
 7503      disp = disp+size
 7504      %if ditem_mode >= framemode %start
 7505        align(disp,2)
 7506        ditem_val = c_sp-disp;  !neg stack disp.
 7507      %finish
 7508    %finish
 7509  %end
 7510  !
 7511  %routine GET QIDENT
 7512    get(ident)
 7513    %if mode = 0 %start;  !within record format
 7514      head == dformat_link;  item = head
 7515      %if item > 0 %start
 7516        %cycle
 7517          ditem == dict(item)
 7518          fault(duperr+point) %if string(ditem_text+char0) = string(charlim)
 7519          head == ditem_hlink;  item = head
 7520        %repeat %until item <= 0
 7521      %finish
 7522    %finish
 7523    declare(decl)
 7524  %end
 7525  
 7526  !<<BOTH
 7527  %routine DUMP CONST(%integer v,n)
 7528  ! Plant N replications of value V (of type ITEMTYPE and size ITEMSIZE)
 7529  ! For simple operand V is value, otherwise V is address in FINAL
 7530  ! Alignment requirement has been enforced (since it depends on context)
 7531  %integer i,j,k,kk,vv
 7532    k = itemsize
 7533    %if k <= 0 %start;  !structure
 7534      k = -k
 7535      k = final(v)+1 %if k = 0;  ![string]
 7536      cad = v %if v # 0;  !reset cad
 7537    %finish
 7538    kk = k
 7539    %return %if n < 1
 7540    kk = kk*n %if n > 1
 7541    %if mode = constmode %start
 7542      i = cad;  cad = cad+kk
 7543      croak("Program too big") %if cad >= ownbase
 7544    %else
 7545      %if ownbase+ownad+kk-finalbound > 0 %start
 7546        make room(ownbase+ownad+kk-finalbound)
 7547      %finish
 7548      i = ownbase+ownad;  ownad = ownad+kk
 7549    %finish
 7550    %if itemsize <= 0 %start
 7551      %while n > 0 %cycle
 7552        n = n-1;  j = i+k
 7553        %if v # 0 %start
 7554          vv = v
 7555          %cycle
 7556            final(i) = final(vv)
 7557            i = i+1;  vv = vv+1
 7558          %repeat %until i =j
 7559        %else
 7560          final(i) = 0 %and i = i+1 %while i < j
 7561        %finish
 7562      %repeat
 7563    %else
 7564  !$IF VAX
 7565  {    v = ieee(v) %if itemtype = realtype;  !vax->ieee
 7566  !$FINISH
 7567      %while n > 0 %cycle
 7568        n = n-1
 7569        %if itemsize >= 2 %start
 7570          %if itemsize > 2 %start;  !longword
 7571            final(i) <- v>>24
 7572            final(i+1) <- v>>16
 7573            i = i+2
 7574          %finish
 7575          final(i) <- v>>8
 7576          i = i+1
 7577        %finish
 7578        final(i) <- v
 7579        i = i+1
 7580      %repeat
 7581    %finish
 7582  %end;  !dump const
 7583  !<<IMP
 7584  
 7585  %routine GET VAR BOUND
 7586  %integer f
 7587    f = decl_flags
 7588    get DATA TYPE
 7589    decl_flags = okflag+mflag;  decl_type = itemtype
 7590    get(ident);  declare(decl)
 7591    decl_flags = f
 7592    assign address(itemsize)
 7593  %end
 7594  
 7595  %routine DECLARE BOUND(%integer mode,val)
 7596    declare anon(details(okflag,inttype,mode,val))
 7597    %if depth # 0 %and mode >= framemode %start
 7598      ditem_flags = ditem_flags!mflag
 7599      assign address(4)
 7600    %finish
 7601  %end
 7602  
 7603  %routine GET ARRAY DECLARATION(%integer dim)
 7604  %integer pos,dlim1,holdval,holdz,jam,elements,tot,totsize,lo1,size1
 7605  %record(identinfo)%name dp
 7606  %ownrecord(objinfo) ATYPE=0
 7607  
 7608  %integer%fn XTYPE
 7609    declare anon(details(typeid,inttype,0,0))
 7610    %result = item
 7611  %end
 7612  
 7613  %routine STRING STAR ARRAY
 7614    fault(notin+point) %if depth = 0
 7615   ! VAR for size
 7616    declare anon(details(okflag+mflag+inty,inttype,mode,0))
 7617    tot = item
 7618    assign address(4)
 7619   ! TYPEID for string(*)
 7620    declare anon(details(typeid+stringy,inttype,0,0))
 7621    atype_type = item
 7622    elements = maxint
 7623  %end
 7624  
 7625  %routine GET REST
 7626  %integer e,r,lo,loval,hi,hival
 7627    r = 0
 7628    atom = next atom %if matched # 0
 7629    %if decl_flags < 0 %start;  !%array%name
 7630      %if depth > 0 %and ktype <= atom <= keyinteger %start;  !variable
 7631        r = xtype;  get VAR BOUND
 7632      %else
 7633        get LITERAL(inttype)
 7634      %finish
 7635    %else;                   !%array
 7636      get VALUE(inttype)
 7637    %finish
 7638    loval = value;  lo = item
 7639    loval = minint %if lo # 0
 7640    get(colon)
 7641    atom = next atom %if matched # 0
 7642    %if decl_flags < 0 %start
 7643      %if depth > 0 %and ktype <= atom <= keyinteger %start;  !variable
 7644        %if r = 0 %start
 7645          r = xtype;  declare bound(litmode,loval)
 7646        %finish
 7647        get VAR BOUND
 7648      %else
 7649        %if dim!r = 0 %and a(star)=TRUE %start
 7650          item = 0;  value = maxint
 7651        %else
 7652          get LITERAL(inttype)
 7653          declare bound(litmode,value) %if r # 0
 7654        %finish
 7655      %finish
 7656    %else
 7657      get VALUE(inttype)
 7658    %finish
 7659    hival = value;  hi = item
 7660    hival = maxint %if hi # 0
 7661    e = maxint
 7662    %if r = 0 %start;  !no range yet declared
 7663      %if lo!hi = 0 %start
 7664        e = hival-loval %if hival!!loval >= 0 %or minint+hival-loval < 0
 7665        e = e+1 %if e # maxint
 7666        e = 0 %if hival = maxint
 7667        declare lit range(inttype,loval,hival)
 7668      %else
 7669        declare anon(typeident);               !blank (for updating)
 7670        declare range(inttype,loval,hival)
 7671      %finish
 7672      r = item
 7673    %finish
 7674    elements = e
 7675    %if a(comma)=TRUE %start
 7676      dim = dim+1
 7677      get REST
 7678      %if elements # maxint %and e # maxint %start
 7679        elements = elements*e
 7680      %else
 7681        elements = maxint
 7682      %finish
 7683    %finish
 7684    atype_xtype = r
 7685    size1 = totsize;  lo1 = loval;       !for outer dimension
 7686    string star array %if atype_type = stringstar
 7687    %if elements = maxint %start;             !non-literal bounds
 7688      atype_mode = mode
 7689      declare anon(atype)
 7690      atype_type = item;          !save type id
 7691      %if decl_flags >= 0 %or (depth = 1 %and speccing = 0) %start
 7692        lo = litref(loval) %if lo = 0
 7693        hi = litref(hival) %if hi = 0
 7694        tot = litref(totsize) %if tot = 0
 7695        putact(asize,item,tot)
 7696        putact(0,lo,hi)
 7697        %if decl_flags >= 0  %start
 7698          compile(np0)
 7699          dict(r+1)_mode = c_mode %and dict(r+1)_val = c_sp+4 %if lo > 0
 7700          dict(r+2)_mode = c_mode %and dict(r+2)_val = c_sp %if hi > 0
 7701        %finish
 7702      %finish
 7703      tot = 0;  totsize = 0
 7704    %else;  !literal bounds
 7705      item = 0
 7706      %cycle
 7707        ditem == dict(item)
 7708        %exit %if ditem_type = atype_type %and ditem_xtype = atype_xtype %c
 7709+             %and ditem_flags = atype_flags
 7710        item = item+1
 7711        %if item = dlim %start
 7712          declare anon(atype)
 7713          %exit
 7714        %finish
 7715      %repeat
 7716      atype_type = item
 7717      totsize = totsize*e
 7718    %finish
 7719  %end;  !get REST
 7720  
 7721  %routine PUT BOUNDS
 7722  %integer i
 7723    i = xtype;                         !index type
 7724    declare bound(mode,0);             !lower
 7725    declare bound(mode,0);             !upper
 7726    dim = dim-1
 7727    put bounds %if dim > 0
 7728    string star array %if atype_type = stringstar
 7729    atype_xtype = i
 7730    declare anon(atype);                  !array type
 7731    %if speccing = 0 %start
 7732      tot = litref(totsize) %if tot = 0
 7733      putact(asize,item,tot)
 7734      putact(0,i+1,i+2)
 7735    %finish
 7736    tot = 0;  totsize = 0;  lo1 = minint
 7737    atype_type = item
 7738  %end
 7739  
 7740    pos = dlim0;  dlim1 = dlim;  dp == ditem
 7741    atype_flags = typeid+arry+okflag;  atype_type = itemtype
 7742    %if atype_type < 0 %start;  !element %name
 7743      atype_flags = atype_flags+name;  atype_type = atype_type-name
 7744    %finish
 7745    atype_mode = constmode;   !by default (literal bounds)
 7746    tot = 0;  totsize = imod(itemsize)
 7747    %if dim > 0 %start;  !%array(n)%name
 7748      atype_mode = mode
 7749      put bounds
 7750      elements = maxint
 7751    %else;  !left parenthesis recognised
 7752      get REST
 7753      get(right)
 7754    %finish
 7755    dp_type = atype_type
 7756    %if mode # constmode %and mode # ownmode %start
 7757      holdval = d0
 7758      %while pos # dlim1 %cycle
 7759        dp == dict(pos)
 7760        dp_type = atype_type
 7761        %if mode >= framemode %start
 7762          dp_flags = dp_flags!arrflag %if lo1 = minint %or size1 = 0
 7763          %if decl_flags >= 0 %start;  !%array not %array%name
 7764            %if totsize # 0 {all literal bounds} %c
 7765+           %and totsize<<1-c_sp+disp <= 32000 %start
 7766              !if array will occupy less than half remaining reach
 7767              !then allocate directly on stack
 7768              disp = disp+totsize
 7769              align(disp,2)
 7770            %else
 7771              fault(ordererr) %if c_mode&2_01000000 # 0; !hard order error
 7772              %if totsize # 0 %start;  !known bounds but too big
 7773                c_extra = c_extra+totsize
 7774                holdval = litref(totsize)
 7775              %finish
 7776              ![ADOK updates C_SP]
 7777              holdz = 0;  holdz = litref(-lo1*size1) %if dp_flags&arrflag = 0
 7778              putact(adok,holdval,holdz);  !compute & store space needed
 7779              compile(np0)
 7780              dp_flags = dp_flags+indirect
 7781              dp_link = c_dynarray
 7782              c_dynarray = pos;  c_dynarray = -c_dynarray %if holdz # 0
 7783              c_status = c_status!unknown
 7784              holdval = 0
 7785            %finish
 7786            dp_val = c_sp-disp
 7787          %finish
 7788        %else { %if decl_flags >= 0};  !record field or absolute
 7789                                    !** to be corrected **
 7790                                    !name already allocated
 7791  {        dp_val = disp;  disp = disp+totsize}
 7792          dp_val = disp
 7793          %if decl_flags < 0 %then disp = disp+4 %else disp = disp+totsize
 7794        %finish
 7795        pos = pos+1
 7796      %repeat
 7797    %else;                           !const,own
 7798      %if decl_flags&(name+indirect) # 0 %start
 7799        %if mode = constmode %then fill code(4) %else fill own(4)
 7800      %else
 7801        %if a assop(itemtype)=TRUE %start
 7802          jam = jammy
 7803          dp_flags = dp_flags!okflag;  ![hum]
 7804          allow(terminator)
 7805          %cycle
 7806            jammy = jam
 7807            get VALUE(itemtype)
 7808            faultnum = rangerr+point+warn %if faultnum = rangerr+point
 7809            holdval = value
 7810            value = 1
 7811            %if a(left)=TRUE %start
 7812              value = elements
 7813              get LITERAL(halftype) %unless a(star)=TRUE
 7814              get(right)
 7815            %finish
 7816            elements = elements-value
 7817            value = value+elements %if elements < 0
 7818            dump const(holdval,value)
 7819          %repeat %until %not a(comma)=TRUE
 7820          %if faultnum = 0 %and elements # 0 %start
 7821            %if elements < 0 %then report(counterr,pos,elements) %c
 7822+           %else report(counterr+warn,pos,elements)
 7823          %finish
 7824        %finish
 7825        dump const(0,elements) %if elements > 0
 7826      %finish
 7827    %finish
 7828  %end;  !get ARRAY DECLARATION
 7829  !
 7830  %routine GET PROCEDURE DECLARATION
 7831  %integer pos,dlim1,argmode,argad,restype,stack
 7832  %record(identinfo)%name headditem,dhold
 7833  
 7834  %integerfn DUPOK
 7835  !Check that the proc being declared can reasonably alias existing id
 7836  %record(identinfo)%name tp
 7837    %result = FALSE %if ditem_flags&proc = 0
 7838    tp == typecell(ditem_type)
 7839    %if restype = 0 %start;  !routine
 7840      %result = FALSE %if tp_type # 0 %or tp_link = 0; !not routine, or no pars
 7841    %else
 7842      %result = FALSE %if restype = tp_type;  !function of same type
 7843    %finish
 7844    %result = TRUE
 7845  %end
 7846  
 7847    restype = itemtype
 7848    stack = 0;  !unknown
 7849    decl_flags = decl_flags&(\okflag)
 7850    decl_type = procstar;             !by default
 7851    %if depth # 0 %start;             !procedure as param
 7852      decl_flags = decl_flags!proc2;  ![must push MB in case external]
 7853    %finish %else %if mode >= framemode %start
 7854      decl_mode = procmode;  decl_val = 0
 7855      decl_flags = decl_flags!proc1
 7856      decl_flags = decl_flags!spec %if a(keyspec)=TRUE
 7857    %finish %else %if mode = ownmode %start;               !external (not @)
 7858      decl_mode = procmode;  decl_val = 0
 7859      %if a(keyspec)=TRUE %start
 7860        decl_mode = ownmode;  decl_flags = decl_flags!spec
 7861      %finish
 7862    %else;   !@...
 7863      decl_flags = decl_flags!proc1
 7864      decl_val = disp
 7865      stack = 4
 7866    %finish
 7867    %if decl_flags&ext # 0 %and a(keyalias)=TRUE %start
 7868      nonstandard(9)
 7869      get(ident)
 7870      %if item <= 0 %start
 7871        fault(namerr+point)
 7872      %else
 7873        item = 0 %and decl_flags = decl_flags!alt %if dupok=TRUE
 7874      %finish
 7875    %else
 7876      get(ident)
 7877    %finish
 7878    declare(decl)
 7879    headditem == ditem
 7880    assign address(-6) %if depth # 0
 7881    argmode = c_mode&(\2_01000000)+1
 7882    %if decl_flags&spec # 0 %or decl_mode # procmode %start
 7883      speccing = speccing+1
 7884    %else
 7885      c_forward = c_forward-1 %if ditem_flags&rflag # 0
 7886      open block(item)
 7887      c_type = restype
 7888      c_type = c_type!sign16 %if decl_flags&writable # 0 {%map}
 7889    %finish
 7890    dlim1 = dlim
 7891    declare anon(details(0,restype,0,stack))
 7892   ! Result in A0 for %map or structure %fn
 7893    ditem_reg = 8 %if decl_flags&writable # 0 {%map} %C
 7894+                 %or size(restype) <= 0 {structure %fn}
 7895  !Declare parameters
 7896    argad = c_sp;     !ok for both spec and body
 7897    %if a(left)=TRUE %start
 7898      dhold == dlink;  dlink == ditem
 7899      get DECLARATION(okflag+writable+readable,argmode,argad,1)
 7900      dlink == dhold
 7901      get(right)
 7902    %finish
 7903    %if speccing # 0 %start
 7904      speccing = speccing-1
 7905      pos = crunched(dlim1)
 7906      %if pos < dlim1 %or speccing = 0 %start
 7907        headditem_type = pos
 7908      %else;                    !proc as param
 7909        fault(classerr);  dlim = dlim1
 7910      %finish
 7911    %else;                        !procedure body
 7912      %if c_dpid_flags&spec # 0 %start
 7913        c_dpid_flags = c_dpid_flags-spec
 7914        %unless parmatch(c_dpid_type,dlim1)=TRUE %start
 7915          %if c_pid = dlim1-2 %then fault(matcherr+warn) %c
 7916+         %else fault(matcherr)
 7917        %finish
 7918      %finish
 7919      headditem_type = dlim1
 7920      c_parlim = dlim
 7921      c_sp = -argad
 7922      compile(np0)
 7923      get(terminator)
 7924      get STATEMENTS(keyend)
 7925    %finish
 7926  %end;  !get procedure declaration
 7927  
 7928  %routine GET INITIAL VALUE(%record(identinfo)%name dp)
 7929  %integer present
 7930    present=0
 7931    jammy = 0
 7932    %if a assop(itemtype)=TRUE %start
 7933      get VALUE(itemtype)
 7934      dp_flags = dp_flags!okflag
 7935      present = 1
 7936    %finish
 7937    %if mode >= framemode %start;  !dynamic
 7938      %if present # 0 %start
 7939        atomp = expp %and nonstandard(1) %if item # 0
 7940        %if itemtype < 0 %start
 7941          putact(okass,dlim0+ad,normitem)
 7942        %else
 7943          putact(okass+jammy,dlim0,normitem)
 7944        %finish
 7945        compile(np0)
 7946      %finish
 7947    %finish %else %if mode = constmode %start
 7948      syntax error %if present = 0
 7949      %if itemtype < 0 %start;  !name
 7950        dp_flags = writable+readable
 7951        dp_mode = absmode;  dp_val = value
 7952      %else
 7953        faultnum = rangerr+point+warn %if faultnum = rangerr+point
 7954        %if itemsize <= 0 %then dump const(value,1) %c
 7955+       %else dp_mode = litmode %and dp_val = value
 7956      %finish
 7957    %else;  !own
 7958      %if present # 0 %start
 7959        faultnum = rangerr+point+warn %if faultnum = rangerr+point
 7960        dump const(value,1)
 7961      %else
 7962        %if itemtype < 0 %then fill own(4) %else fill own(imod(itemsize))
 7963      %finish
 7964    %finish
 7965  %end;  !get initial value
 7966  
 7967  dreg = d0;  areg = a0;  stmax = 8;  !allow for RETAD & LINK
 7968  max = 0;  base = disp
 7969  %cycle
 7970    disp = base
 7971    %cycle
 7972      decl = 0
 7973      decl_flags = flags;  decl_mode = mode
 7974      adim = -1
 7975      %while a(kattrib)=TRUE %cycle
 7976        decl_flags = decl_flags!!(1<<subatom)
 7977      %repeat
 7978      %if depth = 0 %and a(left)=TRUE %start;  !start of sub-group
 7979        align(disp,2)
 7980  !      ad_cat = ad_cat+1 %if mode = 0
 7981        get DECLARATION(flags,mode,disp,0);  get(right)
 7982  !      ad_cat = ad_cat-1 %if mode = 0
 7983      %finish %else %if a(rpred)=TRUE %start;  !%routine,(%predicate)
 7984        %if subatom # 0 %start;  !pred
 7985          decl_flags = decl_flags&(\(writable))
 7986          decl_flags = decl_flags!volatile %if control&volbit # 0
 7987          itemtype = booltype
 7988        %else
 7989          decl_flags = decl_flags&(\(writable+readable))
 7990          itemtype = 0
 7991        %finish
 7992        get PROCEDURE DECLARATION
 7993        %return %if depth = 0
 7994      %else
 7995        get DATA TYPE
 7996        !Appendages
 7997        %if a(fnmap)=TRUE %start;  !%fn, %map
 7998          decl_flags = decl_flags!volatile %if control&volbit # 0
 7999          %if subatom = 0 %start
 8000            decl_flags = decl_flags&(\writable)
 8001            fault(illstarred) %if itemsize = 0
 8002          %finish
 8003          get PROCEDURE DECLARATION
 8004          %return %if depth = 0
 8005        %else
 8006          decl_flags = decl_flags&(\proc)
 8007          decl_type = itemtype
 8008          %if a(keyname)=TRUE %start
 8009            decl_flags = decl_flags+name;  itemtype = itemtype+name
 8010            itemsize = 4
 8011          %finish
 8012          %if a(keyarray)=TRUE %start
 8013            fault(illstarred) %if itemtype = recstar;  !%record(*)%array
 8014            adim = 0
 8015           ! ITEMTYPE now reflects element type (+name)
 8016           ! DECL is for the array itself
 8017            decl_flags = decl_flags&(\name)
 8018            decl_type = arrstar
 8019            decl_flags = decl_flags!arrflag %if control&arrbit # 0
 8020            %if a(left)=TRUE %start
 8021              fault(notin+point) %if depth = 0
 8022              get LITERAL(inttype)
 8023              %if value&(\7) # 0 %then expfault(rangerr) %else adim = value
 8024              get(right)
 8025              get(keyname);  matched = 0
 8026            %finish
 8027           ! %array%name versus %array
 8028            decl_flags = decl_flags+name %if a(keyname)=TRUE
 8029          %finish
 8030         ! %record(*) or %string(*) needs %name (or @)
 8031         ! %string alone allowed only for %const%string
 8032          fault(illstarred) %if itemsize = 0 %c
 8033+                           %and decl_flags >= 0 %and disp ## jokerad %c
 8034+                           %and decl_type # stringtype {const}
 8035          %if disp == c_val %start;  !main declaration
 8036            fault(notinblock) %if stopper = 0
 8037            %if c_status >= hadon %start
 8038              %if c_forward!c_return # 0 %or curlab # c_lab1 %start
 8039                fault(ordererr)
 8040              %finish %else %if c_status&hadordererr = 0 %start
 8041                fault(ordererr+warn);  c_status = c_status+hadordererr
 8042              %finish
 8043            %finish
 8044          %finish %else %if decl_flags&ext # 0 %and a(keyspec)=TRUE %start
 8045            decl_flags = decl_flags!(spec+indirect)
 8046          %finish
 8047         !Read identifier list
 8048          %cycle
 8049            dlim0 = dlim
 8050            %unless decl_type = arrstar %start;  !not array
 8051              get QIDENT
 8052              assign address(itemsize)
 8053              %if mode >= ownmode %and depth = 0 %start
 8054                %if decl_flags&spec = 0 %then get INITIAL VALUE(ditem) %c
 8055+               %else set own word(0) %and set own word(0)
 8056              %finish
 8057            %else
 8058              %cycle
 8059                get QIDENT
 8060                assign address(0);  !(4 if name)
 8061                %exit %unless a(comma)=TRUE
 8062                atom = next atom
 8063                %if atom # ident %start;  !ie new type
 8064                  %if adim = 0 %start;    !treat %array%name as %array(1)%name
 8065                    syntax error %if decl_flags >= 0
 8066                    adim = 1
 8067                  %finish
 8068                  get ARRAY DECLARATION(adim)
 8069                  -> exit22
 8070                %finish
 8071              %repeat
 8072              %if adim # 0 %or %not a(left)=TRUE %start
 8073                 %if adim = 0 %start
 8074                   syntax error %if decl_flags >= 0
 8075                   adim = 1
 8076                 %finish
 8077                 get ARRAY DECLARATION(adim)
 8078                 -> exit2
 8079              %finish
 8080              get ARRAY DECLARATION(adim)
 8081            %finish
 8082            -> exit2 %unless a(comma)=TRUE
 8083            atom = next atom
 8084          %repeat %until atom # ident
 8085  exit22:
 8086          %continue
 8087        %finish
 8088      %finish
 8089      %exit %unless a(comma)=TRUE;  ![NB %continue above]
 8090    %repeat
 8091  exit2:
 8092    max = disp %if disp > max
 8093  %repeat %until %not a(keyor)=TRUE
 8094  disp = max
 8095  %end;  !get declaration
 8096  
 8097  initial(keyconst):
 8098    literal = 1
 8099    get DECLARATION(okflag+readable,constmode,cad,0)
 8100    -> term
 8101  
 8102  initial(atsign):
 8103    dump = 0
 8104  atted:
 8105    fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0
 8106    get LITERAL(inttype)
 8107    jokerad = value
 8108    %if a(left)=TRUE %start
 8109      get MIDENT(a0,a7)
 8110      get(right)
 8111      value = item+(dispmode-a0)
 8112    %finish %else value = absmode
 8113    literal = 1
 8114    get DECLARATION(dump!(okflag+writable+readable),value,jokerad,0)
 8115    -> term
 8116  
 8117  initial(keyown):
 8118    literal = 1
 8119    get DECLARATION(writable+readable,ownmode,ownad,0)
 8120    -> term
 8121  
 8122  initial(keyext):
 8123    fault(ordererr) %if level # outerlevel
 8124    literal = 1
 8125    dump = subatom<<12
 8126    -> atted %if a(atsign)=TRUE
 8127    %if a(left)=TRUE %start
 8128      get LITERAL(inttype);  get(right)
 8129      maxcalldreg = (d0-1)+value&15
 8130      maxcallareg = (a0-1)+value>>4&15
 8131      dump = dump!!(value&(\255))
 8132    %finish
 8133    get DECLARATION(dump!(writable+readable),ownmode,ownad,0)
 8134    -> term
 8135  
 8136  initial(keyrecord):
 8137    %unless a(left)=TRUE %start
 8138      get(keyformat)
 8139      %if a(keyspec)=TRUE %start
 8140        typeident_flags = typeid+spec+recy
 8141        get(ident);  declare(typeident)
 8142      %else
 8143        typeident_flags = typeid+recy
 8144        get(ident);  declare(typeident)
 8145        get(left)
 8146        dformat == ditem
 8147        get DECLARATION(writable+readable,0,dformat_val,0)
 8148        recalign(dformat_val)
 8149        get(right)
 8150      %finish
 8151      -> term
 8152    %finish
 8153    fp = fp-1;  atom = keyrecord;  !back-up
 8154  initial(ktype): initial(keylong):
 8155  initial(keyinteger): initial(keyreal):
 8156  initial(kattrib): initial(keystring):
 8157  initial(rpred):
 8158    matched = 0
 8159    get DECLARATION(writable+readable,c_mode,c_val,0)
 8160    -> term
 8161  
 8162  initial(keylabel):
 8163    get IDENTLIST(forwardlabel)
 8164    -> term
 8165  
 8166  %routine GET SWITCH DECLARATION
 8167  %integer i,lo,hi,dlim1
 8168  %ownrecord(objinfo) d=0
 8169    matched = 1
 8170    %cycle
 8171      d_type = arrstar;  !(in case of error)
 8172      d_flags = d_flags+arrflag %if control&arrbit # 0
 8173      d_mode = labmode
 8174      get IDENTLIST(d)
 8175      dlim1 = dlim
 8176      declare anon(details(typeid+arry,0,0,0))
 8177      get(left);  get LIT RANGE(inttype);  get(right)
 8178      dict(dlim1)_xtype = item
 8179      get bounds(item,lo,hi)
 8180      %cycle;  !For each ident in group
 8181        %for i = lo,1,hi %cycle
 8182          swpc = swpc-1;  prog(swpc) = 0
 8183          croak("Code space exhausted") %if swpc <= pc
 8184        %repeat
 8185        dict(dlim0)_val = swpc
 8186        dict(dlim0)_type = dlim1
 8187        dlim0 = dlim0+1
 8188      %repeat %until dlim0 = dlim1
 8189    %repeat %until %not a(comma)=TRUE
 8190  %end
 8191  initial(keyswitch):
 8192    literal = 1
 8193    get SWITCH DECLARATION
 8194    c_status = c_status!hadswitch
 8195    ->term
 8196  
 8197  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 8198  !!!!!!!!!!!!!!!  Control statements  !!!!!!!!!!!!!!!!!!!!!!!!!!!
 8199  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 8200  !
 8201  %routine OPT
 8202  %integer c
 8203    c=control
 8204    set options(string(final0+value))
 8205    select output(listout);  !**for now - PAM may alter**
 8206    control = control&(\list) %if initcon&list = 0
 8207    control = control!list %if control&(\c)&(ttlist+codelist+explist+dictlist) # 0
 8208  %end
 8209  
 8210  initial(keyoption):
 8211    get LITSTRING
 8212    get(terminator)
 8213    opt %if faultnum = 0
 8214    -> next
 8215  
 8216  initial(keyinclude):
 8217    get LITSTRING
 8218    get(terminator)
 8219    %if faultnum = 0 %start
 8220      croak("Too many nested includes") %if curfile = 3
 8221      line = line+1 %if sym = nl
 8222      cur_fp = fp;  cur_line = line
 8223      fcontrol(curfile) = control
 8224      control = control&(\list) %if control&(codelist+explist+dictlist) = 0
 8225      curfile = curfile+1
 8226      lastfile = -1 %if curfile = lastfile
 8227      cur == file(curfile);  cur = 0
 8228      time1 = time1-cputime
 8229  !!    define param("INC",cur_name,nodefault)
 8230      opt
 8231  !!    connect edfile(cur)
 8232      time1 = time1+cputime
 8233      %signal abandon %if cur_flag # 0
 8234      line = 0;  sym = nl
 8235      curstart = cur_start2;  curlim = cur_lim2
 8236      fp = cur_start2
 8237    %finish
 8238    ->next
 8239  
 8240  initial(keycontrol):
 8241    get LITERAL(inttype)
 8242    control = 0 %if value = 0
 8243    control = control!!value
 8244    show dict(0) %if control&dictlist # 0
 8245    ->term
 8246  
 8247  initial(keylist):
 8248    control = control!list
 8249    ->term
 8250  
 8251  initial(keybegin):
 8252    get(terminator)
 8253    %if stopper = 0 %start;  !first %begin
 8254      c_localdpos = dlim;  c_parlim = dlim
 8255      c_access = 1
 8256      get STATEMENTS(keyend)
 8257      %return
 8258    %finish
 8259    declare anon(beginblock)
 8260    open block(dlim0)
 8261    get STATEMENTS(keyend)
 8262    update sp
 8263    this is inst
 8264    srcall(dlim-1)
 8265    -> term
 8266  
 8267  initial(keyend):
 8268    %if stopper > keyend %start
 8269      %if stopper = keyrepeat %then fault(norepeat+now) %C
 8270+     %else fault(nofinish+now)
 8271    %else
 8272      %if a(keyof)=TRUE %start
 8273        %if a(keylist)=TRUE %start
 8274          control = control&(\list)
 8275          ->term
 8276        %finish
 8277        %if a(keyfile)=TRUE %start
 8278         fp = curlim;  sym = nl
 8279          ->next
 8280        %finish
 8281        get(keyprogram)
 8282        fault(noend+now) %if level # outerlevel
 8283      %finish
 8284      fault(nobegin+now) %if stopper = 0
 8285      %if c_access > 0 %start
 8286        fault(noresult+now) %if c_type # 0;  !fn/map/pred
 8287      %finish
 8288      close block
 8289    %finish
 8290  %end;  !GET STATEMENTS
 8291  
 8292  !<<BOTH
 8293  
 8294  %routine ANNOUNCE(%integer value,%string(255) message)
 8295    write(value,1);  space;  printstring(message)
 8296    printsymbol('s') %if value # 1
 8297  %end
 8298  
 8299  %routine OUTPUT OBJECT FILE
 8300  %constinteger OBJOUT=1
 8301  %constinteger INITSIZE=18
 8302  !%constinteger INITSIZE=30
 8303  %integer i,reset,totsize,ownsize
 8304  ! INIT SEQUENCE
 8305  !   code to copy own values from end of code area to data area
 8306  !
 8307  !    Program area                 Data area
 8308  !   ________________         __________________
 8309  !   |              |         |                |
 8310  !   |              |         |  STACK SPACE   |
 8311  !   |    CODE      |         |                |
 8312  !   |              |     SP->|~~~~~~~~~~~~~~~~|
 8313  !   |______________|         |                |
 8314  !   |    init      |         |                |
 8315  !   |~~~~~~~~~~~~~~|         |GLOBAL DYNAMICS |
 8316  !   |              |         |                |
 8317  !   |  OWN VALUES  |     MB->|~~~~~~~~~~~~~~~~|
 8318  !   |              |         |                |
 8319  !   |              |         |    OWNS        |
 8320  !   |______________|         |                |
 8321  !                        orig|                |
 8322  !                        SP->|~~~~~~~~~~~~~~~~|
 8323  !
 8324   
 8325    reset = 0;  totsize = cad
 8326    ownsize =  ownad
 8327    %if ownsize # 0 %start
 8328      fill own(4-ownad&3) %if ownad&3 # 0
 8329      ownsize = ownad
 8330      reset = cad;    !entry-point for RESET
 8331      totsize = totsize+(initsize+ownad);  !total code size
 8332    %finish
 8333    set extension(objfile,".mob")
 8334    time1 = time1-cputime
 8335    open output(objout,objfile)
 8336    select output(objout)
 8337    put word(16_FE02);  !object module flag, version
 8338    put word(control>>20<<4);  !checking options
 8339    value = 0
 8340    do externals(externs,-1) %if externs # 0;  !find size
 8341    put word(value);        !length of exports
 8342    value = 0
 8343    do externals(extspecs,-1) %if extspecs # 0;  !find size
 8344    put word(value);        !length of imports
 8345    put word(totsize>>16);  !length of code + init pattern
 8346    put word(totsize)
 8347    put word(reset>>1);     !reset entry-point
 8348    put word(c_dpid_val>>1);  !main entry-point
 8349    put word(ownsize>>16);       !static data requirement
 8350    put word(ownsize)
 8351    put word(c_totstack>>16);  !stack requirement
 8352    put word(c_totstack)
 8353    put word(0);            !spare for diag
 8354    put word(0)
 8355    put word(0)
 8356    put word(0)
 8357    do externals(externs,0) %if externs # 0
 8358    do externals(extspecs,1) %if extspecs # 0
 8359    final(0) = 16_4E;  final(1) =16_75;  !RTS (as null reset,main?)
 8360    i = 0
 8361    %cycle
 8362      print symbol(final(i));  i = i+1
 8363    %repeat %until i = cad
 8364    %if ownsize # 0 %start
 8365      put word(16_2248+mb-a0);       !   move.l mb,a1
 8366      put word(16_41FA);             !   lea initpatt,a0
 8367      put word(16_000E)
 8368      put word(16_303C);             !   move.w #????,d0
 8369      put word(ownad>>1-1);          ![individual owns in shortwords - 1]
 8370      put word(16_32D8);             !l1 move.w (a0)+,(a1)+
 8371      put word(16_51C8);             !   dbra d0,l1
 8372      put word(-4)
 8373      put word(16_4E75);             !   rts
 8374      i = 0
 8375      %cycle
 8376        print symbol(final(i+ownbase));  i = i+1
 8377      %repeat %until i = ownad
 8378    %finish
 8379    time1 = time1+cputime
 8380  %end
 8381  
 8382  %routine CLOSE EDIT
 8383  !_FLAG is negative if edit abandoned
 8384  !_CHANGE is untouched (inf) if no changes
 8385    %if file(main)_flag >= 0 %and 0 < file(main)_change # 16_7FFFFFFF %start
 8386      file(main)_name = mainfile;  ![in case modified by OPEN IN]
 8387      time1 = time1-cputime
 8388  !!    disconnect edfile(file(main))
 8389      printstring(file(main)_name."  updated");  newline
 8390      time1 = time1+cputime
 8391    %finish
 8392  %end
 8393  
 8394  %begin
 8395  %on %event redo,abandon %start
 8396    close edit %and %stop %if event_event = abandon
 8397  %finish
 8398    time2 = cputime-time1
 8399    statements = 1;  comments = 0;  atoms = 0
 8400    identatoms = 0;  litatoms = 0
 8401    faults = 0;  others = 0;  faultnum = 0
 8402    zaps = 0;  steps = 0;  jumps = 0;  shorts = 0
 8403    rep = ""
 8404    forget triples;  !reset LITPOS,EXPLO,OLDEXPLO
 8405    char0 = addr(char(0));  final0 = addr(final(0))
 8406    preset
 8407    dint == dict(inttype)
 8408    dtemp == dict(lablim);  dtemp2 == dict(lablim+1)
 8409    dtsprel == dict(lablim+2)                                     ;! GT: file corruption???? lablim turned into lablib since the last compile!  WTF???
 8410    dmin = dictlim;  dmin0 = dmin
 8411    inclim = 0
 8412    accounted = 0
 8413    firstentry = finalbound;  firstpos = dictlim
 8414    pc = 1;  swpc = progbound+1
 8415    cad = 2
 8416    final(0) = 0;  !for empty string (compile-time only)
 8417    ownbase = finalbound-4095;  ownad = 0
 8418    level = outerlevel;  vintage = 1
 8419    pendout = 0;  pendin = 0;  polarity = 0
 8420    curlab = dictlim+1
 8421    reset context(procstar,defaultfree)
 8422    c_sp = -4;   !allow for BSR
 8423  
 8424    control = initcon
 8425    lastfile = main
 8426    curfile = main;  cur == file(main)
 8427    curstart = file(main)_start1;  curlim = file(main)_lim1
 8428    fp = file(main)_start1
 8429    line = 0;  sym = nl
 8430    np = np0
 8431  !<<IMP
 8432    get STATEMENTS(0)
 8433  !<<BOTH
 8434  %end
 8435  
 8436    time2 = cputime-time2-time1
 8437    close edit
 8438    output object file %if faults = 0 %or control&forcebit # 0
 8439    %cycle
 8440      select output(listout)
 8441      printstring(file(main)_name)
 8442      %if faults = 0 %or control&forcebit # 0 %start
 8443        printstring(" compiled:")
 8444        announce(statements,"statement")
 8445        print string(" (+")
 8446        announce(comments,"comment")
 8447        printstring(") to")
 8448        announce(cad,"byte")
 8449        printstring(" (+");  write(ownad,1)
 8450        printsymbol(')')
 8451        newline
 8452      %finish
 8453      %if faults # 0 %start
 8454        printsymbol(':')
 8455        announce(faults,"fault")
 8456        printstring(" reported")
 8457        %if others # 0 %start
 8458          printstring(" (+");  announce(others,"other")
 8459          printsymbol(')')
 8460        %finish
 8461        newline
 8462      %finish
 8463      %if control&logbit # 0 %start
 8464        printstring(%c
 8465+ "  CODE  OWNS  JUMPS SHORT STEPS  ZAPS | ATOMS LITS IDS  TIME")
 8466        newline
 8467        write(cad,5)
 8468        write(ownad,5)
 8469        write(jumps,6);  write(shorts,5)
 8470        write(steps,5);  write(zaps,5)
 8471        print(atoms/statements,5,1)
 8472        print(litatoms/statements,2,1)
 8473        print(identatoms/statements,1,1)
 8474        print(time2/statements,2,3)
 8475        printsymbol('+')
 8476        print(time1/statements,0,3)
 8477        newline
 8478      %finish
 8479      %exit %if listout = 0
 8480      listout = 0
 8481    %repeat
 8482  !<<IMP
 8483  %endofprogram
?ANON unused
?ARIGHT unused
?NONVAR unused
?NOTINROUT unused
?HADSPEC unused
?LABGLOBBED unused
?BVS unused
?BVC unused
?DWRITE unused
?NULLSETTYPE unused
?SHORTTYPE unused
?NULL unused
?FILEY unused
?INDA7 unused
?A6 unused
?NEWBIT unused
?RUNBIT unused
?NODEFAULT unused
?NEWGROUP unused

 6839 Statements compiled
