Source:    imp22g.i
Object:    imp22g.o
Parms:     MAP,PPRO,NOTRACE,NOLINE,LIST,NOARRAY,NODIAG,NOCHECK,MAXDICT,MAXWORK



              ERCC. Portable Imp80 Compiler Release 4 Version 13 Aug 96


  4095 12285
     1        %begin
     2        
     3        %integerfn is short(%name v)
     4          %result = 0 /* 0 false 1 true */
     5        %end
     6        
     7        %integerfn is mite(%name v)
     8          %result = 0 /* 0 false 1 true */
     9        %end
    10        
    11        !!%external%string(255)%fn%spec cliparam
    12        !!%external%integer%fn%spec cputime
    13        
    14        %string(255)cliparam; cliparam = "adec"
    15        
    16        !$IF ECSVAX
    17        {%conststring(51) title = %c
    18        {"  EUCSD IMP Compiler for M68000.  VAX Version  2.2g"
    19        !$IF APM
    20        %conststring(51) title = %c
     C        "  EUCSD IMP Compiler for M68000.  APM Version  2.2g"
    22        !$FINISH
    23        !
    24        ! Hamish Dewar  Computer Science   Edinburgh University  1982/83/84
    25        !
    26        %constinteger WHICH=M'.imp'
    27        
    28        !<<BOTH [markers for parts common to Pascal]
    29        
    30        !General notes:
    31        !  The main data structure DICT is used for identifier, type, label
    32        !  and expression representation (with some aliasing).  The fixedsize
    33        !  cell has a number of advantages which outweigh the Procustean factor
    34        !  (and the 16-byte size is efficiently addressed)
    35        !
    36        !  Major routines (like EVAL) which have variables heavily used by
    37        !   nested routines are not placed below level 1 for efficiency of
    38        !   addressing.  (Making the compiler an external procedure rather
    39        !   than a main program would seriously impact this efficiency).
    40        !
    41        !!!!!!!!!!!!!!!!!!  File handling definitions  !!!!!!!!!!!!!!!!!!!!!
    42        !
    43        %constinteger MAXNAME=127
    44        %string(maxname) MAINFILE,OBJFILE
    45        
    46        ! Editor-compatible file-mapping record:
    47        %recordformat EDFILE(%integer start1,lim1, {part 1}
     C                                      start2,lim2, {part 2}
     C                                      lim, {VMLIM}
     C                                      lbeg,fp,change,flag,
     C                                      line  {line number of current pos},
     C                                      diff  {diff between LINE and ROW},
     C                               %byte  top  {top row of sub_window},
     C                                      win  {floating top},
     C                                      bot  {bottom row of sub_window},
     C                                      min  {minimum window size},
     C                                      row  {last row position},
     C                                      col  {last col position},
     C                     %string(maxname) name)
    60        !
    61        !!%external%routine%spec EDI(%record(edfile)%name main,sec,
     C        !!                         %string(255) message)
    63        {PAM: parameter acquisition module}
    64        %constinteger NEWGROUP=1, NODEFAULT=2
    65        !!%external%routine%spec DEFINE PARAM %alias "PAM_DEFSTRING" %c
     C        !!          (%string(255) name, %name variable, %integer flags)
    67        !!%external%routine%spec DEFINE INT PARAM %alias "PAM_DEFINT" %c
     C        !!          (%string(255) name, %name variable, %integer flags)
    69        !!%external%routine%spec DEFINE BOOLEAN PARAMS %alias "PAM_DEFBOOL" %c
     C        !!    (%string(255) name, %name variable, %integer flags)
    71        !!%external%routine%spec PROCESS PARAMETERS %alias "PAM_PROCESS"(%string(255)!! parm)
    72        !!%external%routine%spec CONNECT EDFILE(%record(edfile)%name f)
    73        !!%external%routine%spec DISCONNECT EDFILE(%record(edfile)%name f)
    74        !!%external%string(8)%fnspec DATE
    75        !!%external%string(5)%fnspec TIME
    76        
    77        %string(8) DATE; DATE = "02/02/02"
    78        %string(5) TIME; TIME = "02:02"
    79        %integer CPUTIME; CPUTIME = 123
    80        !
    81        %owninteger ITEM=0;                ![high-frequency]
    82        %owninteger LISTOUT=0 {set to 2 if listing to file}
    83        !!  Compiler control
    84        
    85        %constinteger ARRBIT=   16_80000000 {array bound check}
    86        %constinteger LOOPBIT=  16_40000000 {%for loop check}
    87        %constinteger CAPBIT=   16_20000000 {capacity check}
    88        %constinteger OVERBIT=  16_10000000 {overflow check}
    89        %constinteger ASSBIT=   16_08000000 {integer-unassigned check}
    90        %constinteger STRASSBIT=16_04000000 {string-unassigned check}
    91        %constinteger SASSBIT=  16_02000000 {short-unassigned check}
    92        %constinteger BASSBIT=  16_01000000 {byte-unassigned check}
    93        %constinteger ASSMASK=assbit!strassbit!sassbit!bassbit
    94        %constinteger LINEBIT=  16_00800000 {set line number}
    95        %constinteger DIAGBIT=  16_00400000
    96        %constinteger TRACEBIT= 16_00200000 {plant TRAP 15}
    97        %constinteger STACKBIT= 16_00100000 {stack over-run check}
    98        %constinteger CHECKBIT= 16_00080000 {for NOCHECK}
    99        %constinteger SYSBIT=   16_00040000 {special treatment of SIGNAL}
   100        %constinteger STRICTBIT=16_00020000
   101        %constinteger VOLBIT   =16_00010000
   102        %constinteger HALFBIT=  16_00008000 {halfword MULT/DIV}
   103        %constinteger LOWBIT  = 16_00004000 {low-level features permitted}
   104        %constinteger EDITBIT=  16_00002000
   105        %constinteger RUNBIT=   16_00001000
   106        %constinteger FORCEBIT= 16_00000800
   107        %constinteger LOGBIT=   16_00000400 {print log}
   108        %constinteger WARNBIT=  16_00000200 {print warnings}
   109        %constinteger NONSBIT=  16_00000100 {nonstandard features permitted}
   110        %constinteger PERMBIT=  16_00000080 {for PRIM compilation}
   111        %constinteger NEWBIT=   16_00000040 {Pascal: new treatment of pointers}
   112        %constinteger CODELIST= 16_00000020 {list code}
   113        %constinteger DICTLIST= 16_00000010 {list dict entries}
   114        %constinteger EXPLIST=  16_00000008 {list EXP entries}
   115        %constinteger MAPLIST=  16_00000004 {print space map}
   116        %constinteger TTLIST=   16_00000002 {list to terminal}
   117        %constinteger LIST=     16_00000001 {do list}
   118        
   119               
   120        %constinteger LISTBITS=codelist+dictlist+explist+maplist+ttlist+list
   121        %owninteger CONTROL=warnbit+checkbit+linebit+diagbit+editbit+volbit %c
     C                           +strassbit+assbit+arrbit+loopbit+capbit+stackbit
   123        %integer INITCON,TIME1,TIME2
   124        !Events:-
   125        %constinteger OFLOW=1, FAIL=11, DONE=12, REDO=13, ABANDON=14
   126        !
   127        !
   128        %constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT
   129        %constinteger SIGN16=\16_7FFF, SIGN=\16_7FFFFFFF
   130        !
   131        !!!!!!!!!!!!!!!!   Operand Representation  !!!!!!!!!!!!!!!!!!!
   132        ! Operands (largely, Expressions) are denoted by integers in a
   133        ! contiguous range as follows:
   134        ! 
   135        ! <= 0  Literals (including 'addresses' within FINAL)
   136        !       [see LITREF and LITVAL for interpretation]
   137        !                                    Dictionary
   138        !                   __16___16____16____8____8____32____16___16__
   139        ! [dummy @ 0] ->    |flags|type| link| reg|mode|value|text|hlink|
   140        ! D0 [@1]  ->  R    |     |    | size|    |    |     |    |    |
   141        !                   |     |    |xtype|    |    |     |    |    |
   142        ! D7       ->       |     |    |     |    |    |     |    |    |
   143        ! A0       ->  E    |     |    |     |    |    |     |    |    |
   144        !                   |     |    |     |    |    |     |    |    |
   145        ! A7       ->  G    |     |    |     |    |    |     |    |    |
   146        ! INDA0    ->       |     |    |     |    |    |     |    |    |
   147        !              S    |     |    |     |    |    |     |    |    |
   148        ! PREA7    ->       |     |    |     |    |    |     |    |    |
   149        !              I    |     |    |     |    |    |     |    |    |
   150        !              D    |     |    |     |    |    |     |    |    |
   151        !              E    |     |    |     |    |    |     |    |    |
   152        !              N    |     |    |     |    |    |     |    |    |
   153        !              T    |     |    |     |    |    |     |    |    |
   154        !              S    |     |    |     |    |    |     |    |    |
   155        !                   |_____|____|_____|____|____|_____|____|____|
   156        ! DICTLIM  ->       | --  |--  |  -- | -- |mode|value| -- | -- |
   157        !              C L  |     |    |     |    |    |     |    |    |
   158        !              O A  |     |    |     |    |    |     |    |    |
   159        !              M B  |     |    |     |    |    |     |    |    |
   160        !              P S  |     |    |     |    |    |     |    |    |
   161        !                   |_____|____|_____|____|____|_____|____|____|
   162        ! LABLIM   ->       |flags|type| act |----|mode|value|arg1|arg2|
   163        !              C    |     |    |     |    |    |     |    |    |
   164        !              O    |     |    |     |    |    |     |    |    |
   165        !              M E  |     |    |     |    |    |     |    |    |
   166        !              P X  |     |    |     |    |    |     |    |    |
   167        !              L P  |     |    |     |    |    |     |    |    |
   168        !              E S  |     |    |     |    |    |     |    |    |
   169        !              X    |_____|____|_____|____|____|_____|____|____|
   170        ! EXPLIM   ->
   171        
   172        %constinteger SMALLMIN=-1024, SMALLMAX=1023,
     C                      LITMAX=smallmin-(smallmax+1), LITMIN=litmax-199,
     C                      LITMITE=-255, LITQUICK=-16, ONE=-(1<<1)
   175        %constinteger D0=1, D1=d0+1, D2=d0+2, D7=d0+7,
     C                      A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7,
     C                      INDA0=a0+8, INDA7=inda0+7,
     C                      POSTA0=inda0+8, POSTA7=posta0+7,
     C                      PREA0=posta0+8, PREA7=prea0+7,
     C                      UNDEF=a7
   181        %owninteger   DICTLIM=1000, FINALBOUND=64  {see Init for adjustment}
   182        %integer      LABLIM,NP0,EXPLIM {continuing from DICTLIM}
   183        %integer      CHARBOUND         {derived from DICTLIM}
   184        %constinteger LABELS=42 {enough for Pascal reserveds},
     C                      TRIPLES=200
   186        %constinteger AD=16384  {any item + AD >= EXPLIM}
   187        
   188        %constinteger BREG=D0+4, LINELOC=d0+5
   189        %constinteger F1=a0+6, GB=a0+5, MB=a0+4;  !level 1, global base, main base
   190        %constinteger MAXDREG=d0+3, MAXAREG=a0+3
   191        %constinteger D0B=1, D1B=2, D2B=4, BREGB=16,
     C                      A0B=16_100, A1B=16_200, A2B=16_400
   193        %constinteger ANYDREG=16_00FF-bregb, ANYAREG=16_FF00,
     C                      ANYREG=16_FFFF
   195        %constinteger DEFAULTFREE=2<<(maxdreg-d0)-1+(2<<(maxareg-a0)-1)<<8+bregb
   196        %integer MAXCALLDREG, MAXCALLAREG
   197        %integer FREE
   198        
   199        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   200        !!!!!!!!!!!!!!!!!!!!!!!   Big Literals  !!!!!!!!!!!!!!!!!!!!!!!
   201        %integer LITPOS
   202        %integerarray LITSTORE(litmin:litmax)
   203        !
   204        !!!!!!!!!  Registers, Identifiers, Labels, Expressions  !!!!!!!!!
   205        !
   206        !   Operand attributes:
   207        %recordformat OBJINFO %C
     C          (%short FLAGS,TYPE,
     C           (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT),
     C           %byte REG,MODE,
     C           %integer VAL)
   212        %recordformat IDENTINFO %C
     C          ((%short FLAGS,TYPE,
     C           (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT),
     C            %byte REG,MODE,
     C            %integer VAL %or %record(objinfo) DETAILS),
     C           (%short   TEXT,HLINK %or %short X,Y))
   218        !
   219        !Machine addressing modes:
   220        %constinteger AREGMODE=2_001000,
     C                      DISPMODE=2_101000, INDEXMODE=2_110000, ABSMODE=2_111000,
     C                      PCMODE=2_111010, LITMODE=2_111100
   223        !Conversion factors for address register modes (from AREGMODE)
   224        %constinteger INDIR=8, POST=16, PRE=24
   225        !Additional source-related modes:
   226        %constinteger LABMODE=2_10000000+pcmode,
     C                      PROCMODE=2_11000000+pcmode,
     C                      GLOBALMODE=dispmode+(gb-a0),
     C                      OWNMODE=2_01000000+dispmode+(mb-a0),
     C                      CONSTMODE=2_01000000+pcmode,
     C                      FRAMEMODE=2_10000000+dispmode
   232        !                      +  01000000 for dynamic array
   233        !
   234        ! MODE,VAL:
   235        !  %const simple       : LITMODE     the actual value
   236        !  %const structure    : CONSTMODE   address in code area
   237        !  variable etc        : mode        byte address/displacement
   238        !  undefined label     : LABMODE     reference chain
   239        !  undefined procedure : PROCMODE    reference chain
   240        !  record format       : 0           size of record in bytes
   241        !
   242        ! Significance of FLAGS:
   243        %constinteger CAT     =16_000F, {category: typeid only}
     C                      WRITABLE=16_0001,
     C                      READABLE=16_0002, {not write only}
     C                      VOLATILE=16_0004,
     C                      ARRFLAG =16_0008, {bound check needed}
     C                        ALT   =16_0008, {alternative proc}
     C                      WFLAG   =16_0010, {has been written to}
     C                      RFLAG   =16_0020, {has been read from}
     C                      OKFLAG  =16_0040, {no unassigned check needed, CC OK for fun}
     C                        NORET =16_0040, {routine does not return}
     C                      MFLAG   =16_0080, {has had mem access}
     C                      SPEC    =16_0100, {unbodied spec or forward label}
     C                      TYPEID  =16_0200, {type identifier}
     C                      PACKED  =16_0400,
     C                      INDIRECT=16_0800,
     C                      PROC    =16_3000, {procedure not data}
     C                        PROC1 =16_1000,
     C                        PROC2 =16_2000,
     C                      EXT     =16_4000, {external}
     C                      NAME    =sign16
   263        %constinteger HERITABLE=writable+readable+volatile %c
     C                               +wflag+rflag+okflag+arrflag
   265        !
   266        !CATegories (type identifiers only):
   267        %constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3,
     C                      POINTY=4, REALY=5,
     C                      STRINGY=8, ARRY=9, SETY=10,
     C                      RECY=12, FILEY=13,
     C                      NONORD=12
   272        
   273        %ownrecord(objinfo) DEFINEDLABEL=0,
     C                            FORWARDLABEL=0,
     C                            BEGINBLOCK=0,
     C                            TYPEIDENT=0
   277        !!!!!!!!!!!!!!!!!  File and control initialisation  !!!!!!!!!!!!!!!
   278        !
   279        %constinteger MAIN=1
   280        %record(edfile)%array FILE(1:3)
   281        %record(edfile)%name CUR
   282        %integerarray FCONTROL(1:3)
   283        %integer CURFILE,LASTFILE;      !current source file no (0:3)
   284        %integer CURSTART,CURLIM;        !current source file bounds
   285        
   286        %routine SET OPTIONS(%string(255) parm)
   287        %constinteger CHECKS=assmask+arrbit+loopbit+capbit+overbit
   288        !!  define boolean params( %c
     C        !!  "ARR,LOOP,CAP,OVER,ASS,STRASS,SASS,BASS,LINE,DIAG,TRACE,STACK,".%C
     C        !!  "CHECK,SYS,STRICT,VOL,HALF,LOW,EDIT,RUN,FORCE,LOG,WARN,NONS,PERM,NEW,".%C
     C        !!  "CODE,DICT,EXP,MAP,TT,LIST",control,0)
   292        !!  process parameters(parm)
   293         !NOCHECK => removal of checkbits
   294          control = control&(\checks) %if control&checkbit = 0
   295          control = control&(\editbit) %if control&listbits # 0
   296        %end
   297        
   298        %routine SET EXTENSION(%string(maxname)%name f,%string(4) ext)
   299        %integer strip
   300        %integer%fn last4(%string(*)%name s)
   301        %integer i,e
   302          i = 0;  e = 0
   303          %while i < length(s) %cycle
   304            i = i+1;  e = e<<8+charno(s,i)
   305          %repeat
   306          %result = e
   307        %end
   308          strip = last4(ext)
   309          f = mainfile %and strip = which %if f = ""
   310          length(f) = length(f)-4 %if last4(f)!16_202020 = strip
   311          f = f.ext
   312        %end
   313        
   314        
   315        %routine OPEN FILES
   316        %string(maxname) LISTFILE; LISTFILE=""
   317          objfile = ""
   318        !!  define param("SOURCE",mainfile,nodefault)
   319        !!  define param("OFILE",objfile,newgroup)
   320        !!  define param("LFILE",listfile,0)
   321        !!  define int param("IDents",dictlim,newgroup)
   322        !!  define int param("KBytes",finalbound,0)
   323          file(main) = 0
   324          set options(cliparam)
   325          control = control&(\linebit) %if control&diagbit = 0;  !*temp*
   326        !Main file
   327          file(main)_name = mainfile;  file(main)_flag = 32768
   328          time1 = time1-cputime
   329        !!  connect edfile(file(main))
   330          time1 = time1+cputime
   331          %stop %if file(main)_flag # 0
   332        
   333        !Listing file
   334          %if listfile # "" %or control&(list+ttlist) # 0 %start
   335            %if control&ttlist = 0 %start
   336              set extension(listfile,".lis")
   337              listout = 2
   338              open output(listout,listfile)
   339            %finish
   340            control = control&(\(editbit+ttlist))
   341            control = control!list %if control&listbits = 0
   342          %finish
   343          select output(listout)
   344          %if control&listbits # 0 %start
   345            control = control!list %if control&listbits # maplist
   346            newlines(2)
   347            printstring(title)
   348            newlines(2)
   349            printstring("   ");  printstring(file(main)_name)
   350            printstring("  compiled on ");  printstring(date)
   351            printstring("  at  ");  printstring(time)
   352            newlines(2)
   353          %finish
   354          initcon = control
   355        %end
   356        
   357          time1 = 0
   358          open files
   359          dictlim = dictlim+300;  !allow for presets
   360          charbound = dictlim*8
   361          finalbound = finalbound<<10+4095;  !kilobytes -> bytes + (min) owns
   362          lablim = dictlim+labels
   363          explim = lablim+triples
   364          np0 = lablim+4
   365          file(main)_change = 16_7FFFFFFF
   366          forwardlabel_flags = spec;  forwardlabel_mode = labmode
   367          definedlabel_mode = labmode
   368          beginblock_mode = procmode
   369          typeident_flags = typeid+recy
   370        !
   371        !!!!!!!!!!!!!!!!  end of file and control initialisation  !!!!!!!!
   372        !
   373        %record(identinfo)%array DICT(0:explim-1)
   374        !  indexing DICT:
   375        %integer DLIM;         !dict limit (up)
   376        %integer DLIM0
   377        %integer DMIN;       !dict upper limit (down)
   378        %integer DMIN0
   379        %integer DICTSHOWN
   380        %integer INCLIM
   381        %record(identinfo)%name DLINK,DFORMAT,DTEMP,DTEMP2,DTSPREL,DINT
   382        %integer SUBBED
   383        %integer RANGES
   384        
   385        ! The identifier dictionary grows as declarations are
   386        ! encountered, sequentially from 0 up, so that the
   387        ! identifiers within a declaration group and within any block
   388        ! are contiguous and may be processed thus (eg at block end).
   389        ! However, searching is always through the hash links, with a
   390        ! start-point given by the array HASHINDEX.  The final link
   391        ! value is zero.
   392        !  Identifiers are normally added at the start of the hash list
   393        ! (hence pushing down any global instance of the same name),
     C        ! but identifiers which have been reported as 'not declared'
   395        ! are added at the end of the list, using a negative link value.
   396        ! This tail section is used to avoid repeated reports for the
   397        ! same name (and is ultra-global, ie never removed).
   398        !
   399        ! For record formats, the format name is stored in the usual way
   400        ! and contains in LINK a pointer to the field-names which are linked
   401        ! through what is normally the hash link.  Searching for field-names
   402        ! proceeds along this chain, as if following hash links.
   403        !
   404        !  HLINK is the hash link (index to DICT)
   405        !
   406        !  TEXT is the pointer (index to CHAR) to the text of the identifier
   407        !       stored as a standard string
   408        
   409        !  Text of identifiers (indexed by _TEXT):
   410        %bytearray CHAR(0:charbound)
   411        %integer CHAR0,CHARLIM,CHARMIN;  !pointers
   412        %integer NEWLEN
   413        
   414        !  Hash index to DICT:
   415        %shortarray HASHINDEX(0:255)
   416        %shortname HEAD;                  !head of ident search list
   417        !
   418        !
   419        !<<IMP
   420        
   421        !* PRIMGEN marker 1
   422        %constinteger NULL=41
   423        %constinteger PROCSTAR=42
   424        %constinteger INTTYPE=43
   425        %constinteger SHORTTYPE=46
   426        %constinteger HALFTYPE=49
   427        %constinteger BYTETYPE=52
   428        %constinteger MITETYPE=55
   429        %constinteger BOOLTYPE=58
   430        %constinteger CHARTYPE=61
   431        %constinteger STRINGSTAR=62
   432        %constinteger STRING1=63
   433        %constinteger STRINGTYPE=64
   434        %constinteger ARRSTAR=65
   435        %constinteger NULLSETTYPE=66
   436        %constinteger RECSTAR=67
   437        %constinteger REALTYPE=69
   438        %constinteger SIGNAL=73
   439        %constinteger DADDR=74
   440        %constinteger DSIZEOF=77
   441        %constinteger INDEX=78
   442        %constinteger LENREF=79
   443        %constinteger SINDEX=82
   444        %constinteger IMUL=86
   445        %constinteger IDIV=87
   446        %constinteger IPOW=88
   447        %constinteger FNEG=89
   448        %constinteger FADD=90
   449        %constinteger FSUB=91
   450        %constinteger FMUL=92
   451        %constinteger FDIV=93
   452        %constinteger FPOW=94
   453        %constinteger FLOAT=95
   454        %constinteger DREM=98
   455        %constinteger UNASS=102
   456        %constinteger ADOK=103
   457        %constinteger STACKOK=104
   458        %constinteger ASIZE=105
   459        %constinteger CONCAT=106
   460        %constinteger DTOSTRING=107
   461        %constinteger AGET=109
   462        %constinteger FOROK=110
   463        %constinteger CHECK=111
   464        %constinteger SCOMP=112
   465        %constinteger STRCOPY=113
   466        %constinteger STRTOSTK=114
   467        %constinteger DNEW=115
   468        %constinteger RESOLVES=117
   469        %constinteger DEVENTF=128
   470        %constinteger DEVENT=134
   471        %constinteger DNIL=137
   472        %constinteger DPRINTSTR=155
   473        %constinteger DWRITE=183
   474        
   475        %constinteger OPMAX=resolves
   476        
   477        %routine SET HASHHEAD(%string(*)%name s)
   478        %integer h,i
   479          h = 0
   480          h = h<<1!!charno(s,i) %for i = 1,1,length(s)
   481          head == hashindex(h&255)
   482        %end
   483        
   484        %routine PRESET
   485        !* PRIMGEN marker 2
   486        %const%integer CMAX=775
   487        %OWN%byte%array CHARINIT(0:CMAX) = 
   488          0,
     C          2,'d','0',
     C          2,'d','1',
     C          2,'d','2',
     C          2,'d','3',
     C          2,'d','4',
     C          2,'d','5',
     C          2,'d','6',
     C          2,'d','7',
     C          2,'a','0',
     C          2,'a','1',
     C          2,'a','2',
     C          2,'a','3',
     C          2,'a','4',
     C          2,'a','5',
     C          2,'a','6',
     C          2,'a','7',
     C          7,'i','n','t','e','g','e','r',
     C          6,'M','A','X','I','N','T',
     C          12,'s','h','o','r','t','i','n','t','e','g','e','r',
     C          11,'h','a','l','f','i','n','t','e','g','e','r',
     C          11,'b','y','t','e','i','n','t','e','g','e','r',
     C          11,'m','i','t','e','i','n','t','e','g','e','r',
     C          7,'B','O','O','L','E','A','N',
     C          5,'F','A','L','S','E',
     C          4,'T','R','U','E',
     C          4,'c','h','a','r',
     C          6,'s','t','r','i','n','g',
     C          5,'a','r','r','a','y',
     C          6,'r','e','c','o','r','d',
     C          4,'T','E','X','T',
     C          4,'r','e','a','l',
     C          8,'l','o','n','g','r','e','a','l',
     C          6,'S','I','G','N','A','L',
     C          4,'a','d','d','r',
     C          6,'s','i','z','e','o','f',
     C          5,'I','N','D','E','X',
     C          6,'l','e','n','g','t','h',
     C          6,'c','h','a','r','n','o',
     C          4,'I','M','U','L',
     C          4,'I','D','I','V',
     C          4,'I','P','O','W',
     C          4,'F','N','E','G',
     C          4,'F','A','D','D',
     C          4,'F','S','U','B',
     C          4,'F','M','U','L',
     C          4,'F','D','I','V',
     C          4,'F','P','O','W',
     C          5,'f','l','o','a','t',
     C          3,'r','e','m',
     C          5,'U','N','A','S','S',
     C          4,'A','D','O','K',
     C          7,'S','T','A','C','K','O','K',
     C          5,'A','S','I','Z','E',
     C          6,'C','O','N','C','A','T',
     C          8,'t','o','s','t','r','i','n','g',
     C          4,'A','G','E','T',
     C          5,'F','O','R','O','K',
     C          5,'C','H','E','C','K',
     C          5,'S','C','O','M','P',
     C          7,'S','T','R','C','O','P','Y',
     C          8,'S','T','R','T','O','S','T','K',
     C          3,'n','e','w',
     C          8,'r','e','s','o','l','v','e','s',
     C          9,'s','u','b','s','t','r','i','n','g',
     C          7,'e','v','e','n','t','f','m',
     C          5,'e','v','e','n','t',
     C          3,'s','u','b',
     C          4,'l','i','n','e',
     C          5,'e','x','t','r','a',
     C          7,'m','e','s','s','a','g','e',
     C          5,'e','v','e','n','t',
     C          2,'n','l',
     C          3,'s','n','l',
     C          3,'n','i','l',
     C          7,'d','i','s','p','o','s','e',
     C          5,'r','o','u','n','d',
     C          5,'t','r','u','n','c',
     C          8,'f','r','a','c','t','i','o','n',
     C          3,'i','n','t',
     C          5,'i','n','t','p','t',
     C          6,'f','r','a','c','p','t',
     C          4,'s','q','r','t',
     C          10,'n','e','x','t','s','y','m','b','o','l',
     C          10,'r','e','a','d','s','y','m','b','o','l',
     C          10,'s','k','i','p','s','y','m','b','o','l',
     C          11,'p','r','i','n','t','s','y','m','b','o','l',
     C          11,'p','r','i','n','t','s','t','r','i','n','g',
     C          9,'o','p','e','n','i','n','p','u','t',
     C          10,'o','p','e','n','o','u','t','p','u','t',
     C          11,'s','e','l','e','c','t','i','n','p','u','t',
     C          12,'s','e','l','e','c','t','o','u','t','p','u','t',
     C          8,'s','e','t','i','n','p','u','t',
     C          9,'s','e','t','o','u','t','p','u','t',
     C          10,'r','e','s','e','t','i','n','p','u','t',
     C          11,'r','e','s','e','t','o','u','t','p','u','t',
     C          10,'c','l','o','s','e','i','n','p','u','t',
     C          11,'c','l','o','s','e','o','u','t','p','u','t',
     C          6,'p','r','o','m','p','t',
     C          7,'n','e','w','l','i','n','e',
     C          5,'s','p','a','c','e',
     C          6,'s','p','a','c','e','s',
     C          8,'n','e','w','l','i','n','e','s',
     C          4,'r','e','a','d', 138,'r','e','a','d','s','t','r','i','n','g',
     C          4,'r','e','a','d', 136,'r','e','a','d','r','e','a','l',
     C          4,'r','e','a','d',
     C          5,'w','r','i','t','e',
     C          7,'c','p','u','t','i','m','e',
     C          5,'p','r','i','n','t',
     C          7,'p','r','i','n','t','f','l',
     C          8,'i','n','s','t','r','e','a','m',
     C          9,'o','u','t','s','t','r','e','a','m',
     C          8,'c','l','i','p','a','r','a','m',
     C        0
   602        %constinteger PREMAX=196
   603        %own%short%array DICTINIT(41*6:PREMAX*6+5) = 
   604         516,-1,0,0,0,0,
     C         527,-1,0,0,0,4,
     C         512,43,4,56,-32768,0,
     C         0,-44,4,60,-32768,0,
     C         0,43,4,60,32767,-1,
     C         512,43,2,56,-32768,0,
     C         0,-44,2,60,-1,-32768,
     C         0,-44,2,60,0,32767,
     C         512,43,2,56,-32768,0,
     C         0,-44,2,60,0,0,
     C         0,-44,2,60,0,-1,
     C         512,43,1,56,-32768,0,
     C         0,-44,1,60,0,0,
     C         0,-44,1,60,0,255,
     C         512,43,1,56,-32768,0,
     C         0,-44,1,60,-1,-128,
     C         0,-44,1,60,0,127,
     C         514,58,1,0,0,0,
     C         0,58,1,60,0,0,
     C         0,58,1,60,0,1,
     C         513,61,255,0,0,0,
     C         520,61,0,0,0,0,
     C         520,-62,-2,0,0,0,
     C         520,-62,-256,0,0,0,
     C         521,0,0,0,0,0,
     C         522,-1,0,0,0,0,
     C         524,0,0,0,0,0,
     C         525,61,4,0,0,0,
     C         517,0,4,0,0,0,
     C         517,0,4,0,0,0,
     C         0,-1,0,0,0,0,
     C         0,-1,0,0,0,0,
     C         4256,42,0,56,0,16122,
     C         4098,75,0,56,0,0,
     C         0,-44,76,0,0,4,
     C         -32701,-1,0,6313,-1,-4,
     C         4098,75,0,56,0,0,
     C         4096,42,0,56,-32767,2861,
     C         4099,80,0,56,0,0,
     C         0,-53,81,6144,0,4,
     C         -32701,-63,0,6313,-1,-4,
     C         4099,83,0,56,0,0,
     C         0,-53,84,6144,0,4,
     C         -32701,-63,85,6313,-1,-4,
     C         67,-44,0,169,-1,-8,
     C         4256,42,0,56,0,16116,
     C         4256,42,0,56,0,16110,
     C         4096,42,0,56,0,16098,
     C         4096,42,0,56,0,16092,
     C         4096,42,0,56,0,16086,
     C         4096,42,0,56,0,16080,
     C         4096,42,0,56,0,16074,
     C         4096,42,0,56,0,16068,
     C         4096,42,0,56,0,16062,
     C         4098,96,0,56,0,16056,
     C         0,-70,97,0,0,4,
     C         67,-44,0,169,-1,-4,
     C         4098,99,0,56,0,0,
     C         0,-44,100,0,0,4,
     C         67,-44,101,169,-1,-4,
     C         67,-44,0,425,-1,-8,
     C         4096,42,0,56,-32722,2578,
     C         4096,42,0,56,-32704,2064,
     C         4096,42,0,56,-32688,2839,
     C         4096,42,0,56,-32665,3097,
     C         4096,42,0,56,-32640,2077,
     C         4098,108,0,56,-32611,6,
     C         0,-64,97,6144,0,4,
     C         4096,42,0,56,-32605,2597,
     C         4096,42,0,56,-32568,2334,
     C         4096,42,0,56,-32538,1806,
     C         4096,42,0,56,-32524,2626,
     C         4096,42,0,56,-32458,2070,
     C         4096,42,0,56,-32436,2090,
     C         4103,116,0,56,0,16008,
     C         0,-68,76,6144,0,4,
     C         22786,118,0,108,0,0,
     C         0,-59,119,0,0,0,
     C         -32701,-63,120,6313,-1,-4,
     C         67,-65,121,6569,-1,-260,
     C         -32701,-63,122,6825,-1,-264,
     C         -32701,-63,0,7081,-1,-268,
     C         4098,124,0,56,-32394,15,
     C         0,-65,125,6144,0,4,
     C         -32701,-63,126,6313,-1,-4,
     C         67,-44,127,169,-1,-8,
     C         67,-44,0,425,-1,-12,
     C         524,0,129,0,-1,-264,
     C         3,52,0,0,0,0,
     C         3,52,0,0,0,1,
     C         3,46,0,0,0,2,
     C         3,43,0,0,0,4,
     C         3,64,0,0,0,8,
     C         67,128,0,45,0,32,
     C         66,43,0,60,0,10,
     C         66,61,0,60,0,10,
     C         67,67,0,56,0,0,
     C         4096,139,0,56,0,16002,
     C         0,-1,76,0,0,4,
     C         4098,141,0,56,0,16050,
     C         0,-44,142,0,0,4,
     C         67,-70,0,169,-1,-4,
     C         4098,141,0,56,0,16044,
     C         4098,145,0,56,0,16038,
     C         0,-70,142,0,0,4,
     C         4098,141,0,56,0,16032,
     C         4098,141,0,56,0,16026,
     C         4098,145,0,56,0,16020,
     C         4098,145,0,56,0,16014,
     C         4098,132,0,56,0,15996,
     C         4098,132,0,56,0,15990,
     C         4096,42,0,56,0,15990,
     C         4256,154,0,56,0,15984,
     C         0,-1,97,0,0,4,
     C         4096,156,0,56,0,15978,
     C         0,-1,157,0,0,4,
     C         67,-65,0,6313,-1,-256,
     C         26880,159,0,108,0,0,
     C         0,-1,160,0,0,0,
     C         67,-44,161,169,-1,-4,
     C         67,-65,0,6313,-1,-260,
     C         26880,159,0,108,0,0,
     C         4096,154,0,56,0,15960,
     C         4096,154,0,56,0,15954,
     C         26880,166,0,108,0,0,
     C         0,-1,97,0,0,0,
     C         26880,166,0,108,0,0,
     C         26880,0,0,108,0,0,
     C         26880,0,0,108,0,0,
     C         4096,42,0,56,0,15936,
     C         4096,42,0,56,0,15930,
     C         26880,173,0,108,0,0,
     C         0,-1,157,0,0,0,
     C         4096,42,0,56,-32379,4,
     C         4096,42,0,56,-32375,4,
     C         22784,166,0,108,0,0,
     C         22784,166,0,108,0,0,
     C         22790,179,0,108,0,0,
     C         0,-65,0,6144,0,0,
     C         22798,181,0,108,0,0,
     C         0,-70,0,0,0,0,
     C         22798,1,0,108,0,0,
     C         22784,184,0,108,0,0,
     C         0,-1,100,0,0,0,
     C         26886,1,0,108,0,0,
     C         22784,187,0,108,0,0,
     C         0,-1,188,0,0,0,
     C         67,-70,189,169,-1,-4,
     C         67,-44,190,425,-1,-8,
     C         67,-44,0,681,-1,-12,
     C         22784,192,0,108,0,0,
     C         0,-1,193,0,0,0,
     C         67,-70,101,169,-1,-4,
     C         67,43,0,45,0,392,
     C         67,43,0,45,0,396,
     C         67,64,0,45,0,464
   760        
   761        %integer i,ci,anons
   762        %record(identinfo)%name dp
   763        
   764        %routine PUT CHAR
   765          byteinteger(charlim) = charinit(ci)
   766          charlim = charlim+1;  ci = ci+1
   767        %end
   768        
   769        %routine TEXTSET(%record(identinfo)%name dp)
   770        %integer len
   771          dp_hlink = 0
   772          %if dp_type < 0 %start;     !convention for *anon*
   773            dp_type = \dp_type
   774            dp_text = 0
   775            anons = anons-1
   776            dp_hlink = ranges %and ranges = dlim %if anons = 0 %and dlim <= mitetype+2
   777          %else
   778            dp_text = ci
   779            %if charinit(ci+1)&32 # 0 %start;  !not upper-case
   780              %if deventf < dlim < devent %start
   781                head = dlim;  head == dp_hlink
   782              %else
   783                set hashhead(string(addr(charinit(ci))))
   784                dp_hlink = head;  head = dlim
   785                head == dp_link %if dlim = deventf
   786              %finish
   787            %finish
   788            len = charinit(ci)
   789            put char %and len = len-1 %until len < 0
   790            len = charinit(ci)-128
   791            put char %and len = len-1 %while len >= 0
   792            anons = 2
   793          %finish
   794        %end
   795        
   796          hashindex(i) = 0 %for i = 0,1,255;  !hash table empty
   797          byteinteger(char0) = 0;  !for anon ident
   798          charlim = char0+1
   799          charmin = charlim+charbound;  !(1 over top)
   800          ranges = 0
   801        
   802          ci = 1
   803          anons = 100
   804          dict(0) = 0
   805          dlim = d0
   806          %cycle
   807            dp == dict(dlim)
   808            %if dlim <= prea7 %start
   809              dp = 0
   810              dp_flags = okflag+writable+readable;  dp_mode = dlim-d0
   811              dp_type = inttype
   812              textset(dp) %if dlim <= a7
   813            %else
   814              dp_details = record(addr(dictinit(dlim*6)))
   815              textset(dp)
   816            %finish
   817            dlim = dlim+1
   818            %exit %if control&permbit # 0 %and dlim >= signal
   819          %repeat %until dlim > premax
   820          dictshown = dlim
   821          i = dictlim
   822          %cycle
   823            dp == dict(i)
   824            dp = 0
   825            dp_mode = labmode
   826            i = i+1
   827          %repeat %until i = np0
   828        %end;  !preset
   829        
   830        !<<BOTH
   831        
   832        !  The last part of DICT (from LABLIM to EXPLIM) is used for
   833        ! the intermediate representation of the components of source
   834        ! statements between the recognition stage and the code generation
   835        ! stage.
   836        !  The part from LABLIM+4 (NP0) up is used as a temporary pipeline
   837        ! for non-expression cells (instructions, conditions, etc)
   838        ! and the part down from EXPLIM for the canonical and
   839        ! persistent representation of expressions (including name
   840        ! expressions).
   841        ! In this part of the array the ident components PLIST (etc), TEXT
   842        !  and HLINK are replaced by ACT, X and Y representing an operation
   843        !  and (up to) two operands.
   844        %integer EXPLO,OLDEXPLO
   845        %integer NP,STARTNP
   846        
   847        !Operator codes:
   848        ! Machine operator index values 1-31:
   849        %constinteger MOVE=1, ADD=2, SUB=3
   850        %constinteger CMP=4, AND=5, OR=6, EOR=7
   851        %constinteger NOT=8, NEG=9, LSL=10, LSR=11
   852        %constinteger MULS=12, DIVS=13, MULU=14, DIVU=15
   853        %constinteger BRA=16, BSR=17
   854        %constinteger BCC=20, BCS=21, BNE=22, BEQ=23
   855        %constinteger BVC=24, BVS=25
   856        %constinteger BGE=28, BLT=29, BGT=30, BLE=31
   857        %constinteger COMPARE=cmp, GOTO=bra
   858        ! Other built-in operators
   859        %constinteger JAMASS=32, OKASS=33, ASSIGN=34, INCASS=35
   860        %constinteger FORASS=36, STOP=37, RETURN=38, REPEAT=39
   861        %constinteger ELSE=40, JUMPOUT=41, SETTRAP=42, SWGOTO=43
   862        %constinteger LABEL=44, RECREF=45, PREL=46, STOREMAP=47
   863        %constinteger IABS=48, FABS=49, END=50
   864        ! PLUS OPERATORS DEFINED IN DICTIONARY > BOPMAX <= OPMAX
   865        !
   866        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   867        
   868        %integer STARTS, CYCLES
   869        %integer CURLAB
   870        %integer PENDOUT, PENDCOND, PENDIN, POLARITY, CONDOP
   871        %ownshortinteger EXTSPECS=0, EXTERNS=0
   872        !
   873        %recordformat CONTENTINFO(%short ccx,ccy,line,
     C                                  %shortarray content(d0:a7))
   875        %recordformat BLOCKINF(%integer sp, stack, extra, totstack, free, status,
     C                        type, localdpos, parlim, localtext, localad, vintage,
     C                        localpc, localswpc, pid, access, forward, lab1, looplab,
     C                        eventsp, faults, return, shorts, temps,
     C                        dynarray, oldcontrol, mode,val,
     C                        %record(identinfo)%name dpid,
     C                        %record(contentinfo) reg)
   882        !STATUS flag bits
   883        %constinteger UNKNOWN    =16_0002,
     C                      WRONGCC    =16_0004,
     C                      ONSTACK    =16_0008,
     C                      GLOBBED    =16_0010,
     C                      LABGLOBBED =16_0020, {Pascal}
     C                      HADSPEC    =16_0040,
     C                      HADSWITCH  =16_0080,
     C                      HADON      =16_1000,
     C                      HADORDERERR=16_2000,
     C                      HADINST    =16_4000  {max flag}
   893        
   894        %constinteger OUTERLEVEL=0, MAXLEVEL=7
   895        %integer LEVEL;           !current block level
   896        %integer VINTAGE;         !current block number
   897        %record(blockinf) C;      !info for current block
   898        %record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks
   899        %record(contentinfo)%array LREG(0:labels)
   900        
   901        ! Code storage for currently open blocks
   902        %constinteger PROGBOUND=16383
   903        %shortarray PROG(0:progbound)
   904        %bytearray PFLAG(0:progbound)
   905        %constinteger SHORTJUMP=1, JUMP=2, LONGJUMP=3,
     C                      GLOBAL=4, {NEGGLOBAL=5, BIGGLOBAL=6,} INDGLOBAL=7,
     C                      ZEROSHORTS=8
   908        %integer PC,SWPC
   909        ! Final core image
   910        %bytearray FINAL(0:finalbound)
   911        ! Declaration records (to select relevant context)
   912        %integer CAD,OWNAD,JOKERAD,OWNBASE
   913        %integer FINAL0,ACCOUNTED
   914        !
   915        %integer FIRSTENTRY, FIRSTPOS
   916        
   917        !Memo variables for current statement:-
   918        %own%integer {ITEM,}TYPE=0,VALUE=0;      !current operand
   919        %record(identinfo)%name DITEM
   920        %integer SPECCING
   921        %integer DUMP
   922        
   923        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   924        
   925        !!  Source file input and listing
   926        %owninteger ATOM=0;       !current lexical atom
   927        %integer MATCHED;         !indic that atom has been matched
   928        %integer SYM;             !current input symbol
   929        %integer LINE;            !current line number
   930        %owninteger CODEFLAG=' '; !or ^
   931        %integer LISTFLAG;        !' ' or '&' or '+' or '"'
   932        !   Pointers to source file:
   933        %integer LINESTART
   934        %integer FP;              !(file pointer) current position
   935        %integer ATOMP;           !start of current atom
   936        %integer EXPP
   937        !
   938        !! Utility routines
   939        
   940        %integerfn IS SHORT(%integer v)
   941          %result = TRUE %if -32768 <= v <= 32767
   942          %result = FALSE
   943        %end
   944        
   945        %integerfn IS MITE(%integer v)
   946          %result = TRUE %if -128 <= v <= 127
   947          %result = FALSE
   948        %end
   949        
   950        %integer%fn MITE(%integer v)
   951          v = v&255;  v = v-256 %if v&128 # 0
   952          %result = v
   953        %end
   954        
   955        %record(identinfo)%map TYPECELL(%integer t)
   956          %result == dict(t)
   957        %end
   958        
   959        %integer%fn CATEGORY(%integer t)
   960          %result = dict(t)_flags&(packed+cat)
   961        %end
   962        
   963        %integer%fn LITVAL(%integer v)
   964          %result = v %if v = 0
   965          %if v > litmax %start;  !not stored literal
   966            %result = (-v)>>1 %if v&1 = 0
   967            %result = \((-v)>>1)
   968          %finish
   969          %result = litstore(v)
   970        %end
   971        !
   972        !!!!!!!!!!!!!! Listing, diagnostic and report routines  !!!!!!!!!!!!!!
   973        !
   974        %integer FAULTS, OTHERS, FAULTNUM, FAULTP
   975        !
   976        !!  Program statistics
   977        %integer STATEMENTS;           !statement count
   978        %integer COMMENTS;             !comment count
   979        %integer ATOMS;                !atom count
   980        %integer IDENTATOMS;           !identifier count
   981        %integer LITATOMS;             !numeric atom count
   982        %integer ZAPS;                 !enforced cleardown of lits/exps
   983        %integer STEPS;                !stepping stones inserted
   984        !%integer MAXIDENTS, MAXCHARS, MAXLITS
   985        %integer JUMPS,SHORTS
   986        !
   987        %string(255) REP
   988        !
   989        %routine PRINT LINE
   990          print string(rep);  print symbol(nl)
   991          rep = ""
   992        %end
   993        !
   994        %routine PUT SYM(%integer k)
   995          rep = rep.tostring(k)
   996        %end
   997        !
   998        %routine PUT STRING(%string(255) s)
   999          rep = rep.s
  1000        %end
  1001        !
  1002        !
  1003        %routine PUT NUM(%integer val)
  1004        %routine PD(%integer v)
  1005          pd(v//10) %and v = v-v//10*10 %if v <= -10
  1006          put sym('0'-v)
  1007        %end
  1008          %if val < 0 %then put sym('-') %and pd(val) %c
     C          %else pd(-val)
  1010        %end
  1011        !
  1012        %routine PUT IDENT(%integer p,mode)
  1013        %record(identinfo)%name dp
  1014          %cycle
  1015            print line %if length(rep) > 50
  1016            spaces(6) %if rep = ""
  1017            dp == dict(p)
  1018            put sym(' ') %and put sym('"') %if mode # 0
  1019            %if dp_text > 0 %start
  1020                put string(string(char0+dp_text))
  1021            %finish %else %if dp_text < 0 %start
  1022                put num(\dp_text)
  1023            %else
  1024                put num(p)
  1025            %finish
  1026            put sym('"') %if mode # 0
  1027            %return %if mode <= 0
  1028            p = dp_hlink
  1029          %repeat %until p = 0
  1030        %end
  1031        !
  1032        {?}%routine SPACES(%integer n)
  1033        {?}  %while n > 0 %cycle
  1034        {?}    put sym(' ');  n = n-1
  1035        {?}  %repeat
  1036        {?}%end
  1037        {?}!
  1038        {?}%routine PUT SPNUM(%integer val)
  1039        {?}  put sym(' ') %if val >= 0
  1040        {?}  put num(val)
  1041        {?}%end
  1042        {?}
  1043        {?}%constbytearray hexsym(0:15) =
  1044        {?}'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
  1045        {?}
  1046        {?}%routine PUT HEX(%integer val)
  1047        {?}%integer i
  1048        {?}  put sym(hexsym(val>>i&15)) %for i = 12,-4,0
  1049        {?}%end
  1050        {?}!
  1051        {?}%routine PUT OPERAND(%integer v)
  1052        {?}%integer i
  1053        {?}%routine INTERPRET(%integer mode)
  1054        {?}%switch s(0:7)
  1055        {?}  ->s(mode>>3&7)
  1056        {?}s(0):                 !DREG
  1057        {?}  put sym('D')
  1058        {?}putrno:
  1059        {?}  put sym(mode&7+'0')
  1060        {?}  %return
  1061        {?}s(1):                 !AREG
  1062        {?}  %if mode >= framemode-dispmode %then put sym('F') %else put sym('A')
  1063        {?}  -> putrno
  1064        {?}s(4):                 !PRE
  1065        {?}  put sym('-')
  1066        {?}s(2):                 !INDIRECT
  1067        {?}ind:
  1068        {?}  put sym('(')
  1069        {?}  interpret(mode&2_11000111+aregmode)
  1070        {?}  put sym(')')
  1071        {?}  %return
  1072        {?}s(3):                 !POST
  1073        {?}  interpret(mode-8);  !ind
  1074        {?}  put sym('+')
  1075        {?}  %return
  1076        {?}s(5):                 !DISP
  1077        {?}  put num(i)
  1078        {?}  ->ind
  1079        {?}s(6):                 !INDEX
  1080        {?}  put num(mite(i))
  1081        {?}  put sym('(')
  1082        {?}  interpret(mode+(aregmode-indexmode))
  1083        {?}  put sym(',')
  1084        {?}  interpret(i>>12&15)
  1085        {?}  put sym('.')
  1086        {?}  %if i&16_800 = 0 %then put sym('W') %else put sym('L')
  1087        {?}  put sym(')')
  1088        {?}  %return
  1089        {?}s(7):                 !MISC
  1090        {?}  %if mode&63 = pcmode %start
  1091        {?}    put num(i) %if mode = pcmode;  !suppress if not explicit
  1092        {?}    put string("(PC)")
  1093        {?}    %return
  1094        {?}  %finish
  1095        {?}  %if mode <= absmode+1 %start
  1096        {?}    put sym('$')
  1097        {?}    put hex(i>>16) %if mode = absmode+1 %or %not 0 = is short(i)
  1098        {?}  %else
  1099        {?}    put sym(hexsym(mode>>4&3))
  1100        {?}    put sym(hexsym(mode&15))
  1101        {?}    put sym('_')
  1102        {?}  %finish
  1103        {?}  put hex(i)
  1104        {?}%end
  1105        {?}
  1106        {?}  %if v <= 0 %start;               !literal
  1107        {?}    v = litval(v)
  1108        {?}    put sym('#')
  1109        {?}    %if 0 = is mite(v) %then put num(v) %else %start
  1110        {?}      put sym('$')
  1111        {?}      put hex(v>>16) %if v>>16 # 0
  1112        {?}      put hex(v&16_FFFF)
  1113        {?}    %finish
  1114        {?}  %finish %else %if v <= prea7 %start;    !register
  1115        {?}    interpret(v-d0)
  1116        {?}  %finish %else %if v < dictlim %start;  !identifier
  1117        {?}    put ident(v,0)
  1118        {?}  %finish %else %if v < lablim %start;  !internal label
  1119        {?}    put sym('L')
  1120        {?}    put num(v-dictlim)
  1121        {?}  %else;                 !complex
  1122        {?}    i = dict(v)_val
  1123        {?}    interpret(dict(v)_mode)
  1124        {?}  %finish
  1125        {?}%end;  !put operand
  1126        {?}
  1127        {?}%routine MARK AT(%integer col)
  1128        {?}  put sym(' ') %while length(rep) < col;  put sym('|')
  1129        {?}%end
  1130        {?}!
  1131        {?}%routine SHOW DICT(%integer from)
  1132        {?}%integer i
  1133        {?}%record(identinfo) d
  1134        {?}%constbytearray flagsym(0:15) =
  1135        {?}  'W','R','V','A','w','r','o','m','S','T','K','?','P','p','E','*'
  1136        {?}%constbytearray catsym(0:15) =
  1137        {?}  'I', 'C', 'B', 'E', '@', 'X', '?', '?',
     C        {?}  'S', 'A', 'Z', '?', 'R', 'F', '?', '?'
  1139        {?}
  1140        {?}  %return %if from >= dlim
  1141        !<<IMP
  1142        {?}  print line %if rep # ""
  1143        {?}  byteinteger(charlim) = 0
  1144        {?}  spaces(6)
  1145        {?}  put string("___identifier____flags___type__link__par_mode___value____")
  1146        {?}  print line
  1147        {?}  %cycle
  1148        {?}    put spnum(from);  mark at(6)
  1149        {?}    d = dict(from)
  1150        {?}    put sym(' ');  put ident(from,0)
  1151        {?}    %if d_text > 0 %start
  1152        {?}      i = char0+d_text;  i = i+byteinteger(i)+1
  1153        {?}      %if byteinteger(i)&128 # 0 %start
  1154        {?}        byteinteger(i) = byteinteger(i)-128
  1155        {?}        put sym(':');  put string(string(i))
  1156        {?}        byteinteger(i) = byteinteger(i)+128
  1157        {?}      %finish
  1158        {?}    %finish
  1159        {?}    mark at(22)
  1160        {?}    %if d_flags&typeid # 0 %then put sym(catsym(d_flags&cat)) %and i = 4 %c
     C        {?}    %else put sym(' ') %and i = 0
  1162        {?}    %cycle
  1163        {?}      put sym(flagsym(i)) %if d_flags>>i&1 # 0
  1164        {?}      i = i+1
  1165        {?}    %repeat %until i > 15
  1166        {?}    mark at(30)
  1167        {?}    put spnum(d_type);  mark at(35)
  1168        {?}    put spnum(d_link);  mark at(42)
  1169        {?}    put spnum(d_reg);  mark at(46)
  1170        {?}    put spnum(d_mode);  mark at(51)
  1171        {?}    put spnum(d_val);  mark at(63)
  1172        {?}    print line
  1173        {?}    from = from+1
  1174        {?}  %repeat %until from = dlim
  1175        {?}  spaces(6)
  1176        {?}  put string("+-------------------------------------------------------+")
  1177        {?}  print line
  1178        !<<BOTH
  1179        {?}%end
  1180        {?}%routine PUT MNEMONIC(%integer m)
  1181        {?}  m = m<<2
  1182        {?}  %cycle
  1183        {?}    put sym(m>>27+'A'-1)
  1184        {?}    m = m<<5
  1185        {?}  %repeat %until m = 0
  1186        {?}%end
  1187        {?}%routine%spec PUT OPCODE(%integer op)
  1188        {?}%routine SHOW EXP(%integer startp)
  1189        {?}%integer p,q
  1190        {?}%record(identinfo)%name dp
  1191        {?}
  1192        %constinteger bopmax=51
  1193        %constintegerarray EXTRA(32:bopmax) =
  1194        'j'<<25+('a'&31)<<20+('m'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
     C        'o'<<25+('k'&31)<<20+('a'&31)<<15+('s'&31)<<10+('s'&31)<<5,
     C        'a'<<25+('s'&31)<<20+('s'&31)<<15+('i'&31)<<10+('g'&31)<<5+('n'&31),
     C        'i'<<25+('n'&31)<<20+('c'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
     C        'f'<<25+('o'&31)<<20+('r'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
     C        's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
     C        'r'<<25+('e'&31)<<20+('t'&31)<<15+('u'&31)<<10+('r'&31)<<5+('n'&31),
     C        'r'<<25+('e'&31)<<20+('p'&31)<<15+('e'&31)<<10+('a'&31)<<5+('t'&31),
     C        'e'<<25+('l'&31)<<20+('s'&31)<<15+('e'&31)<<10,
     C        'e'<<25+('x'&31)<<20+('i'&31)<<15+('t'&31)<<10,
     C        't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
     C        's'<<25+('w'&31)<<20+('g'&31)<<15+('o'&31)<<10+('t'&31)<<5+('o'&31),
     C        'l'<<25+('a'&31)<<20+('b'&31)<<15+('e'&31)<<10+('l'&31)<<5,
     C        'r'<<25+('e'&31)<<20+('c'&31)<<15+('r'&31)<<10+('e'&31)<<5+('f'&31),
     C        'p'<<25+('r'&31)<<20+('e'&31)<<15+('l'&31)<<10,
     C        's'<<25+('t'&31)<<20+('r'&31)<<15+('m'&31)<<10+('a'&31)<<5+('p'&31),
     C        'i'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
     C        'f'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
     C        'e'<<25+('n'&31)<<20+('d'&31)<<15,
     C        'l'<<25+('o'&31)<<20+('g'&31)<<15+('s'&31)<<10+('u'&31)<<5+('b'&31)
  1214        
  1215        {?}%routine PUT OPRAND(%integer v)
  1216        {?}  put sym('#') %and v = v-ad %if v >= explim
  1217        {?}  %if v < np0 %then put operand(v) %else put num(v)
  1218        {?}%end
  1219        {?}  print line %if rep # ""
  1220        {?}  %return %unless np > np0
  1221        {?}  put string("      ______action_______first_______second____")
  1222        {?}  print line
  1223        {?}  p = np0
  1224        {?}  %cycle
  1225        {?}    %if p = np %start
  1226        {?}      p = explo
  1227        {?}      %exit %if p >= oldexplo
  1228        {?}      put string("      |---------------------------------------|")
  1229        {?}      print line
  1230        {?}    %finish
  1231        {?}    %if p = startp %then put sym('>') %else put sym(' ')
  1232        {?}    put num(p);  mark at(6)
  1233        {?}    dp == dict(p)
  1234        {?}    put sym(' ')
  1235        {?}    q = dp_act
  1236        {?}    %if q <= 31 %start
  1237        {?}         put opcode(q)
  1238        {?}    %finish %else %if q <= bopmax %start
  1239        {?}       put mnemonic(extra(q))
  1240        {?}    %else
  1241        {?}        put ident(q,0)
  1242        {?}    %finish
  1243        {?}    mark at(22)
  1244        {?}    put sym(' ');  put oprand(dp_x);  mark at(34)
  1245        {?}    put sym(' ');  put oprand(dp_y);  mark at(46)
  1246        {?}    %if p >= explo %start
  1247        {?}      put spnum(dp_type)
  1248        {?}      put sym('*') %if dp_flags < 0
  1249        {?}    %finish
  1250        {?}    print line
  1251        {?}    p = p+1
  1252        {?}  %repeat %until p >= oldexplo
  1253        {?}  oldexplo = explo
  1254        {?}  put string("      +---------------------------------------+")
  1255        {?}  print line
  1256        {?}%end
  1257        {?}!
  1258        !
  1259        !!!!!!!!!!!!!!!!!!!!!!!!!!!! Fault reporting  !!!!!!!!!!!!!!!!!!!!!!!!!!!
  1260        !
  1261        %routine CROAK(%string(255) s)
  1262          select output(0)
  1263          put string("** ");  put string(s)
  1264          put string(".  Compilation abandoned at line ");  put num(line)
  1265          print line
  1266          %signal abandon
  1267        %end
  1268        
  1269        !<<IMP
  1270        
  1271        !!  Fault numbers
  1272        %constinteger INTERNERR=1, PLEXERR=2, CREACHERR=3, REACHERR=4
  1273        %constinteger NORESULT=5, DREACHERR=6
  1274        %constinteger FORMERR=7, ATOMERR=8, NAMERR=9, CLASSERR=10
  1275        %constinteger SIZERR=11, TYPERR=12, BOUNDSERR=13, UNENDING=14
  1276        %constinteger LOWLEVEL=15, ACCESSERR=16, NOTINLOOP=17, NOTINROUT=18
  1277        %constinteger NOTINFUN=19, NOTINPRED=20, DUPERR=21
  1278        %constinteger ORDERERR=22, MATCHERR=23, RANGERR=24, NONLITERAL=25
  1279        %constinteger MOPERR=26, NOCYCLE=27
  1280        %constinteger NOSTART=28, NOIF=29, ILLSTARRED=30, NONSTARTER=31
  1281        %constinteger NONVAR=32, NONREF=33, TOOFEW=34, TOOMANY=35
  1282        %constinteger NOBEGIN=36, DUBIOUS=37, NOTINBLOCK=38
  1283        %constinteger NONSTAND=39, NOTIN=40, ASSERR=41
  1284        %constinteger NOEND=42, NOFINISH=43, NOREPEAT=44
  1285        %constinteger COUNTERR=45, SLABMISSING=46, IDMISSING=47
  1286        %constinteger POINT=64, WARN=-128, NOW=128
  1287        !
  1288        %routine REPORT(%integer n,id,num)
  1289        %owninteger lastchange=0
  1290        %integer mark,start,errline
  1291        
  1292        %routine PRINT TEXT(%integer stream)
  1293        %constinteger esc=27
  1294        %integer k,p
  1295        
  1296        %conststring(15)%array MESSAGE(1:44) =
  1297          "Internal error ", "Reg not free",
     C          "Out of reach ",  " out of reach!",
     C          "RESULT missing", "Out of reach",
     C          "Faulty form", "Unknown atom",
     C          "Unknown name", "Wrong class",
     C          "Wrong size", "Wrong type",
     C          "Inside out", "Endless loop",
     C          "Low level", "Not accessible",
     C          "Not in loop", "Not in routine",
     C          "Not in fn/map", "Not in pred",
     C          "Duplicate",
     C          "Out of order", "Mismatch",
     C          "Out of range", "Not literal",
     C          "Faulty operand", "%CYCLE missing",
     C          "%START missing", "Extra %ELSE",
     C          "Ill-starred", "Non-starter",
     C          "Not variable", "Not reference",
     C          "Too few args", "Too many args",
     C          "%BEGIN missing",
     C          "Dubious usage", "Not in block",
     C          "Nonstandard ", "Not supported",
     C          " void",
     C          "%END missing",
     C          "%FINISH missing", "%REPEAT missing"
  1321        
  1322        !<<BOTH
  1323        
  1324          put sym(mark)
  1325          put sym(' ') %if errline < 1000
  1326          put sym(' ') %if errline < 100
  1327          put sym(' ') %if errline < 10
  1328          put num(errline)
  1329          put sym(listflag);  put sym(' ')
  1330          k = n&63
  1331          %if k >= counterr %start
  1332            %if k = counterr %start
  1333              %if num < 0 %start
  1334                put num(-num);  put string(" extra")
  1335              %else
  1336                put num(num) %if num # 0;  put string(" missing")
  1337              %finish
  1338              put string(" value(s) for ")
  1339              put ident(id,0)
  1340              %return
  1341            %finish
  1342            %if k # slabmissing %start
  1343              put ident(id,1)
  1344            %else
  1345              put ident(id,0)
  1346              put sym('(');  put num(num);  put sym(')')
  1347            %finish
  1348            put string(" missing")
  1349        mend:
  1350            %if c_dpid_text # 0 %start
  1351              put string(" in ")
  1352              put ident(c_pid,-1)
  1353            %finish
  1354            %return
  1355          %finish
  1356          put ident(id,0) %if id > 0
  1357          put string(message(k))
  1358          put num(num) %if num > 0
  1359          -> mend %if creacherr <= k <= noresult
  1360          spaces(22-length(rep))
  1361          p = start
  1362          p = p+1 %while byteinteger(p) = ' '
  1363          %if p < faultp-50 %then p = faultp-47 %and put string("...") %c
     C          %else put sym(' ')
  1365          %cycle
  1366            k = byteintegeR(p);  p = p+1
  1367            %if p = faultp %start
  1368        !      %if stream # 0 %then put sym('|') %else %start
  1369        !       !**V200**
  1370        !        put sym(esc);  put sym('F');  !graphics
  1371        !        put sym('~')
  1372        !        put sym(esc);  put sym('G');  !normal
  1373        !      %finish
  1374              put sym('|')
  1375            %finish
  1376            %exit %if k = nl
  1377            put sym(k)
  1378        !    %if ' ' <= k <= '~' %then put sym(k) %c
     C        !    %else put sym('[') %and put num(k) %and put sym(']')
  1380          %repeat
  1381          %return
  1382        %end
  1383        
  1384        !Warning or error
  1385          mark = '?'
  1386          %if n > 0 %start
  1387            mark = '*'
  1388            c_faults = c_faults+1;  faults = faults+1
  1389          %finish
  1390          faultnum = 0;  c_access = -1
  1391        !Ignore uncorrected earlier error
  1392          %return %if file(main)_start1 <= fp < lastchange
  1393        !Establish what to print
  1394          start = linestart;  errline = line
  1395          %if n&point = 0 %start
  1396            faultp = 0;  !no pointing
  1397          %else
  1398            %while start >= faultp %cycle;  !before current line
  1399              start = start-1
  1400              errline = errline-1 %if byteintegeR(start) = nl
  1401            %repeat
  1402            start = start-1 %while start # curstart %and byteintegeR(start-1) # nl
  1403          %finish
  1404          time1 = time1-cputime
  1405          %if listout # 0 %start;  !listing file
  1406            print text(listout);  print line
  1407          %finish
  1408          select output(0)
  1409          %if curfile # lastfile %start
  1410            lastfile = curfile;  put string(cur_name);  print line
  1411          %finish
  1412          print text(0)
  1413          %if n > reacherr %and curfile = main %and control&editbit # 0 %start
  1414            start = faultp-1 %if faultp > start
  1415            cur_fp = start;  cur_line = line
  1416            cur_change = 16_7FFFFFFE %if lastchange # 0
  1417            select input(0)
  1418            file(main+1) = 0
  1419        !!    edi(file(main),file(main+1),rep);  !main+1 to keep editor happy
  1420            rep = ""
  1421            select output(listout)
  1422            time1 = time1+cputime
  1423            %signal abandon %if cur_flag < 0 {abandoned}
  1424            control = control&(\editbit) %if cur_flag = 'I'
  1425            lastchange = cur_change %and %signal redo %if cur_change < 16_7FFFFFFE
  1426          %else
  1427            print line
  1428            select output(listout)
  1429            time1 = time1+cputime
  1430          %finish
  1431        %end;  !report
  1432        
  1433        %routine FAULT(%integer n)
  1434        !Note fault number and position of (earliest) fault
  1435        ! for subsequent reporting (warnings and weak errors)
  1436          %if faultnum = 0 %or (n > 0 %and faultnum < 0) %start
  1437            faultnum = n;  faultp = atomp
  1438            report(faultnum&127,0,0) %if faultnum >= now
  1439          %finish
  1440        %end
  1441        
  1442        %routine INTERN(%integer n)
  1443          report(internerr,0,n)
  1444        %end
  1445        
  1446        !!!!!!!!!!!!!!!!!!!!   CELL  CONSTRUCTORS  !!!!!!!!!!!!!!!!!!!
  1447        !
  1448        %integer%fn LITREF(%integer v)
  1449        %integer i
  1450          %result = v %if v = 0
  1451          %if v > 0 %start
  1452            %result = -(v<<1) %if v <= smallmax
  1453          %else
  1454            %result = v<<1+1 %if v >= smallmin
  1455          %finish
  1456          litstore(litpos) = v
  1457          i = litmin-1
  1458          i = i+1 %until litstore(i) = v
  1459          %if i = litpos %start
  1460            litpos = litpos+1
  1461            croak("Too many literals") %if litpos >= litmax
  1462          %finish
  1463          %result = i
  1464        %end
  1465        !
  1466        %routine PUTEXP(%integer act,x,y,t)
  1467          type = t
  1468          item = explim
  1469          item = x %if explo <= x < item
  1470          item = y %if explo <= y < item
  1471          %cycle
  1472            item = item-1
  1473            ditem == dict(item)
  1474            %if item < explo %start
  1475              explo = item
  1476              ditem_act = act;  ditem_x = x;  ditem_y = y
  1477              ditem_flags = 0;  ditem_type = t;  ditem_mode = 0
  1478              %exit
  1479            %finish
  1480          %repeat %until ditem_act = act %and ditem_x = x %and ditem_y = y
  1481        %end
  1482        
  1483        !$IF VAX
  1484        {%integer%fn IEEE(%integer v)
  1485        {  %result = 0 %if v = 0
  1486        {  %result = v<<16+v>>16-16_01000000
  1487        {%end
  1488        !$FINISH
  1489        
  1490        %routine PUTEXP2(%integer op,first,t)
  1491          %if item = 0 %start
  1492        !$IF VAX
  1493        {  value = ieee(value) %if type = realtype;  !vax->ieee
  1494        !$FINISH
  1495            item = litref(value)
  1496          %finish
  1497          putexp(op,first,item,t)
  1498        %end
  1499        
  1500        %integer%fn NORMITEM
  1501          %result = item %if item # 0
  1502        !$IF VAX
  1503        {  value = ieee(value) %if type = realtype;  !vax->ieee
  1504        !$FINISH
  1505          %result = litref(value)
  1506        %end
  1507        
  1508        %routine TOREAL
  1509          %if item # 0 %then putexp(float,item,0,realtype) %c
     C          %else real(addr(value)) = value %and type = realtype
  1511        %end
  1512        
  1513        %integer%fn TEMP(%integer m,v)
  1514          dtemp_mode = m;  dtemp_val = v
  1515          %result = lablim
  1516        %end
  1517        %integer%fn TEMPX(%integer r1,r2)
  1518          dtemp_mode = r1+(indexmode-a0);  dtemp_val = (r2-d0)<<12+16_0800
  1519          %result = lablim
  1520        %end
  1521        %integer%fn TEMPD(%integer a,disp)
  1522          dtemp_mode = a+(dispmode-a0);  dtemp_val = disp
  1523          %result = lablim
  1524        %end
  1525        %integer%fn TEMPX2(%integer r1,r2)
  1526          dtemp2_mode = r1+(indexmode-a0);  dtemp2_val = (r2-d0)<<12+16_0800
  1527          %result = lablim+1
  1528        %end
  1529        
  1530        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1531        !!!!!!!!!!!!!!!!!    CODE  GENERATION   !!!!!!!!!!!!!!!!!!!!!!!!
  1532        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1533        !
  1534        !  The array DEF contains packed mnemonics for M68000 machine
  1535        ! instructions and, for each mnemonic, the basic opcode and
  1536        ! a type indicator.
  1537        !  The type indicator contains flag bits for various special cases
  1538        ! and two 6-bit fields defining the operand types
  1539        ! [should be const record array]
  1540        !  The mnemonics and variant distinctions broadly follow the
  1541        !  manufacturer's Assembly Language conventions
  1542        !
  1543        ! Opcode index values needed globally:-
  1544        %constinteger LEA=78, PEA=55, CLR=52, DBRA=81, JSR=56,
     C                      LINK=72, UNLK=73, RTS=68,
     C                      MOVEM=100, TRAPI=101, DC=102
  1547        
  1548        !Machine-code operand types
  1549        ![EA needs to be further distinguished]
  1550        %constinteger SHIFT=32
  1551        %constinteger REG=1, AREG=2, IREG=3, QUICK=4, MQUICK=5
  1552        %constinteger EA=6, RWEA=7, WEA=8
  1553        %constinteger IMM=9, TQUICK=10, REL=11, LONGREL=12
  1554        %constinteger QREG=13, POSTAREG=14, QEA=15
  1555        %constinteger REVEA=16, XIMM=17, DATA=18, PREAREG=19, QPRE=20
  1556        %constinteger EXREG=21+shift
  1557        %constinteger REG9=reg+shift, QREG9=qreg+shift, IREG9=ireg+shift,
     C                      POSTAREG9=postareg+shift,
     C                      QUICK9=quick+shift, AREG9=areg+shift
  1560        %constinteger SIZED=1<<15, ASIZED=1<<14;  !2 spare bits
  1561        %constinteger REVERSIBLE=revea<<6+reg9+sized, MULTIPLE=ximm<<6+ea+asized
  1562        %constinteger DEFMAX=129
  1563        %constintegerarray DEF(0:defmax+defmax) =
  1564          0,
     C         {MOVE} 16_0000<<16+ ea<<6+wea+shift +sized,
     C          'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10,
     C         {ADD} 16_D000<<16+ reversible,
     C          'a'<<25+('d'&31)<<20+('d'&31)<<15,
     C         {SUB} 16_9000<<16+ reversible,
     C          's'<<25+('u'&31)<<20+('b'&31)<<15,
     C         {CMP} 16_B000<<16+ ea<<6+reg9 +sized,
     C          'c'<<25+('m'&31)<<20+('p'&31)<<15,
     C         {AND} 16_C000<<16+ reversible,
     C          'a'<<25+('n'&31)<<20+('d'&31)<<15,
     C         {OR} 16_8000<<16+ reversible,
     C          'o'<<25+('r'&31)<<20,
     C         {EOR} 16_B100<<16+ reg9<<6+rwea +sized,
     C          'e'<<25+('o'&31)<<20+('r'&31)<<15,
     C         {NOT} 16_4600<<16+ rwea +sized,
     C          'n'<<25+('o'&31)<<20+('t'&31)<<15,
     C         {NEG} 16_4400<<16+ rwea +sized,
     C          'n'<<25+('e'&31)<<20+('g'&31)<<15,
     C         {LSL} 16_E108<<16+ qreg9<<6+reg +sized,
     C          'l'<<25+('s'&31)<<20+('l'&31)<<15,
     C         {LSR} 16_E008<<16+ qreg9<<6+reg +sized,
     C          'l'<<25+('s'&31)<<20+('r'&31)<<15,
     C         {MULS} 16_C1C0<<16+ ea<<6+reg9,
     C          'm'<<25+('u'&31)<<20+('l'&31)<<15+('s'&31)<<10,
     C         {DIVS} 16_81C0<<16+ ea<<6+reg9,
     C          'd'<<25+('i'&31)<<20+('v'&31)<<15+('s'&31)<<10,
     C         {MULU} 16_C0C0<<16+ ea<<6+reg9,
     C          'm'<<25+('u'&31)<<20+('l'&31)<<15+('u'&31)<<10,
     C         {DIVU} 16_80C0<<16+ ea<<6+reg9,
     C          'd'<<25+('i'&31)<<20+('v'&31)<<15+('u'&31)<<10,
     C         {BRA} 16_6000<<16+ rel,
     C          'b'<<25+('r'&31)<<20+('a'&31)<<15,
     C         {BSR} 16_6100<<16+ rel,
     C          'b'<<25+('s'&31)<<20+('r'&31)<<15,
     C         {BHI} 16_6200<<16+ rel,
     C          'b'<<25+('h'&31)<<20+('i'&31)<<15,
     C         {BLS} 16_6300<<16+ rel,
     C          'b'<<25+('l'&31)<<20+('s'&31)<<15,
     C         {BCC} 16_6400<<16+ rel,
     C          'b'<<25+('c'&31)<<20+('c'&31)<<15,
     C         {BCS} 16_6500<<16+ rel,
     C          'b'<<25+('c'&31)<<20+('s'&31)<<15,
     C         {BNE} 16_6600<<16+ rel,
     C          'b'<<25+('n'&31)<<20+('e'&31)<<15,
     C         {BEQ} 16_6700<<16+ rel,
     C          'b'<<25+('e'&31)<<20+('q'&31)<<15,
     C         {BVC} 16_6800<<16+ rel,
     C          'b'<<25+('v'&31)<<20+('c'&31)<<15,
     C         {BVS} 16_6900<<16+ rel,
     C          'b'<<25+('v'&31)<<20+('s'&31)<<15,
     C         {BPL} 16_6A00<<16+ rel,
     C          'b'<<25+('p'&31)<<20+('l'&31)<<15,
     C         {BMI} 16_6B00<<16+ rel,
     C          'b'<<25+('m'&31)<<20+('i'&31)<<15,
     C         {BGE} 16_6C00<<16+ rel,
     C          'b'<<25+('g'&31)<<20+('e'&31)<<15,
     C         {BLT} 16_6D00<<16+ rel,
     C          'b'<<25+('l'&31)<<20+('t'&31)<<15,
     C         {BGT} 16_6E00<<16+ rel,
     C          'b'<<25+('g'&31)<<20+('t'&31)<<15,
     C         {BLE} 16_6F00<<16+ rel,
     C          'b'<<25+('l'&31)<<20+('e'&31)<<15,
     C         {ASL} 16_E100<<16+ qreg9<<6+reg +sized,
     C          'a'<<25+('s'&31)<<20+('l'&31)<<15,
     C         {ASR} 16_E000<<16+ qreg9<<6+reg +sized,
     C          'a'<<25+('s'&31)<<20+('r'&31)<<15,
     C         {ROL} 16_E118<<16+ qreg9<<6+reg +sized,
     C          'r'<<25+('o'&31)<<20+('l'&31)<<15,
     C         {ROR} 16_E018<<16+ qreg9<<6+reg +sized,
     C          'r'<<25+('o'&31)<<20+('r'&31)<<15,
     C         {MOVEQ} 16_7000<<16+ mquick<<6+reg9,
     C          'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('q'&31)<<5,
     C         {ADDQ} 16_5000<<16+ quick9<<6+rwea +sized,
     C          'a'<<25+('d'&31)<<20+('d'&31)<<15+('q'&31)<<10,
     C         {SUBQ} 16_5100<<16+ quick9<<6+rwea +sized,
     C          's'<<25+('u'&31)<<20+('b'&31)<<15+('q'&31)<<10,
     C         {MOVEA} 16_3040<<16+ ea<<6+areg9 +asized,
     C          'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('a'&31)<<5,
     C         {ADDA} 16_D0C0<<16+ ea<<6+areg9 +asized,
     C          'a'<<25+('d'&31)<<20+('d'&31)<<15+('a'&31)<<10,
     C         {SUBA} 16_90C0<<16+ ea<<6+areg9 +asized,
     C          's'<<25+('u'&31)<<20+('b'&31)<<15+('a'&31)<<10,
     C         {CMPA} 16_B0C0<<16+ ea<<6+areg9 +asized,
     C          'c'<<25+('m'&31)<<20+('p'&31)<<15+('a'&31)<<10,
     C         {CMPM} 16_B108<<16+ postareg<<6+postareg9,
     C          'c'<<25+('m'&31)<<20+('p'&31)<<15+('m'&31)<<10,
     C         {ADDI} 16_0600<<16+ imm<<6+rwea +sized,
     C          'a'<<25+('d'&31)<<20+('d'&31)<<15+('i'&31)<<10,
     C         {SUBI} 16_0400<<16+ imm<<6+rwea +sized,
     C          's'<<25+('u'&31)<<20+('b'&31)<<15+('i'&31)<<10,
     C         {CMPI} 16_0C00<<16+ imm<<6+ea +sized,
     C          'c'<<25+('m'&31)<<20+('p'&31)<<15+('i'&31)<<10,
     C         {ANDI} 16_0200<<16+ imm<<6+rwea +sized,
     C          'a'<<25+('n'&31)<<20+('d'&31)<<15+('i'&31)<<10,
     C         {ORI} 16_0000<<16+ imm<<6+rwea +sized,
     C          'o'<<25+('r'&31)<<20+('i'&31)<<15,
     C         {EORI} 16_0A00<<16+ imm<<6+rwea +sized,
     C          'e'<<25+('o'&31)<<20+('r'&31)<<15+('i'&31)<<10,
     C         {ROXL} 16_E110<<16+ qreg9<<6+reg +sized,
     C          'r'<<25+('o'&31)<<20+('x'&31)<<15+('l'&31)<<10,
     C         {ROXR} 16_E010<<16+ qreg9<<6+reg +sized,
     C          'r'<<25+('o'&31)<<20+('x'&31)<<15+('r'&31)<<10,
     C         {CLR} 16_4200<<16+ wea +sized,
     C          'c'<<25+('l'&31)<<20+('r'&31)<<15,
     C         {NEGX} 16_4000<<16+ rwea +sized,
     C          'n'<<25+('e'&31)<<20+('g'&31)<<15+('x'&31)<<10,
     C         {NBCD} 16_4800<<16+ rwea,
     C          'n'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
     C         {PEA} 16_4840<<16+ ea,
     C          'p'<<25+('e'&31)<<20+('a'&31)<<15,
     C         {JSR} 16_4E80<<16+ ea,
     C          'j'<<25+('s'&31)<<20+('r'&31)<<15,
     C         {JMP} 16_4EC0<<16+ ea,
     C          'j'<<25+('m'&31)<<20+('p'&31)<<15,
     C         {TAS} 16_4AC0<<16+ rwea,
     C          't'<<25+('a'&31)<<20+('s'&31)<<15,
     C         {TST} 16_4A00<<16+ ea +sized,
     C          't'<<25+('s'&31)<<20+('t'&31)<<15,
     C         {ABCD} 16_C100<<16+ qpre<<6+reg9,
     C          'a'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
     C         {SBCD} 16_8100<<16+ qpre<<6+reg9,
     C          's'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
     C         {ADDX} 16_D100<<16+ qpre<<6+reg9 +sized,
     C          'a'<<25+('d'&31)<<20+('d'&31)<<15+('x'&31)<<10,
     C         {SUBX} 16_9100<<16+ qpre<<6+reg9 +sized,
     C          's'<<25+('u'&31)<<20+('b'&31)<<15+('x'&31)<<10,
     C         {NOP} 16_4E71<<16,
     C          'n'<<25+('o'&31)<<20+('p'&31)<<15,
     C         {RESET} 16_4E70<<16,
     C          'r'<<25+('e'&31)<<20+('s'&31)<<15+('e'&31)<<10+('t'&31)<<5,
     C         {RTE} 16_4E73<<16,
     C          'r'<<25+('t'&31)<<20+('e'&31)<<15,
     C         {RTR} 16_4E77<<16,
     C          'r'<<25+('t'&31)<<20+('r'&31)<<15,
     C         {RTS} 16_4E75<<16,
     C          'r'<<25+('t'&31)<<20+('s'&31)<<15,
     C         {STOP} 16_4E72<<16 +imm,
     C          's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
     C         {TRAPV} 16_4E76<<16,
     C          't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('v'&31)<<5,
     C         {TRAP} 16_4E40<<16+ tquick,
     C          't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
     C         {LINK} 16_4E50<<16+ imm<<6+areg,
     C          'l'<<25+('i'&31)<<20+('n'&31)<<15+('k'&31)<<10,
     C         {UNLK} 16_4E58<<16+ areg,
     C          'u'<<25+('n'&31)<<20+('l'&31)<<15+('k'&31)<<10,
     C         {SWAP} 16_4840<<16+ reg,
     C          's'<<25+('w'&31)<<20+('a'&31)<<15+('p'&31)<<10,
     C         {EXTW} 16_4880<<16+ reg,
     C          'e'<<25+('x'&31)<<20+('t'&31)<<15+('w'&31)<<10,
     C         {EXTL} 16_48C0<<16+ reg,
     C          'e'<<25+('x'&31)<<20+('t'&31)<<15+('l'&31)<<10,
     C         {EXG} 16_C140<<16+ exreg<<6+reg,
     C          'e'<<25+('x'&31)<<20+('g'&31)<<15,
     C         {LEA} 16_41C0<<16+ qea<<6+areg9,
     C          'l'<<25+('e'&31)<<20+('a'&31)<<15,
     C         {CHK} 16_4180<<16+ ea<<6+reg9,
     C          'c'<<25+('h'&31)<<20+('k'&31)<<15,
     C         {DBXX} 16_50C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('x'&31)<<15+('x'&31)<<10,
     C         {DBRA} 16_51C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('r'&31)<<15+('a'&31)<<10,
     C         {DBHI} 16_52C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('h'&31)<<15+('i'&31)<<10,
     C         {DBLS} 16_53C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('l'&31)<<15+('s'&31)<<10,
     C         {DBCC} 16_54C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('c'&31)<<15+('c'&31)<<10,
     C         {DBCS} 16_55C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('c'&31)<<15+('s'&31)<<10,
     C         {DBNE} 16_56C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('n'&31)<<15+('e'&31)<<10,
     C         {DBEQ} 16_57C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('e'&31)<<15+('q'&31)<<10,
     C         {DBVC} 16_58C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('v'&31)<<15+('c'&31)<<10,
     C         {DBVS} 16_59C8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('v'&31)<<15+('s'&31)<<10,
     C         {DBPL} 16_5AC8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('p'&31)<<15+('l'&31)<<10,
     C         {DBMI} 16_5BC8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('m'&31)<<15+('i'&31)<<10,
     C         {DBGE} 16_5CC8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('g'&31)<<15+('e'&31)<<10,
     C         {DBLT} 16_5DC8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('l'&31)<<15+('t'&31)<<10,
     C         {DBGT} 16_5EC8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('g'&31)<<15+('t'&31)<<10,
     C         {DBLE} 16_5FC8<<16+ reg<<6+longrel,
     C          'd'<<25+('b'&31)<<20+('l'&31)<<15+('e'&31)<<10,
     C         {BCHG} 16_0140<<16+ ireg9<<6+rwea,
     C          'b'<<25+('c'&31)<<20+('h'&31)<<15+('g'&31)<<10,
     C         {BCLR} 16_0180<<16+ ireg9<<6+wea,
     C          'b'<<25+('c'&31)<<20+('l'&31)<<15+('r'&31)<<10,
     C         {BSET} 16_01C0<<16+ ireg9<<6+wea,
     C          'b'<<25+('s'&31)<<20+('e'&31)<<15+('t'&31)<<10,
     C         {BTST} 16_0100<<16+ ireg9<<6+ea,
     C          'b'<<25+('t'&31)<<20+('s'&31)<<15+('t'&31)<<10,
     C         {MOVEM} 16_4880<<16+ multiple,
     C          'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('m'&31)<<5,
     C         {TRAPI} 16_4E40<<16+ imm<<6+tquick,
     C          't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('i'&31)<<5,
     C         {DC}         data,
     C             'd'<<25+('c'&31)<<20,
     C         {ST} 16_50C0<<16+ wea,
     C          's'<<25+('t'&31)<<20,
     C         {SF} 16_51C0<<16+ wea,
     C          's'<<25+('f'&31)<<20,
     C         {SHI} 16_52C0<<16+ wea,
     C          's'<<25+('h'&31)<<20+('i'&31)<<15,
     C         {SLS} 16_53C0<<16+ wea,
     C          's'<<25+('l'&31)<<20+('s'&31)<<15,
     C         {SCC} 16_54C0<<16+ wea,
     C          's'<<25+('c'&31)<<20+('c'&31)<<15,
     C         {SCS} 16_55C0<<16+ wea,
     C          's'<<25+('c'&31)<<20+('s'&31)<<15,
     C         {SNE} 16_56C0<<16+ wea,
     C          's'<<25+('n'&31)<<20+('e'&31)<<15,
     C         {SEQ} 16_57C0<<16+ wea,
     C          's'<<25+('e'&31)<<20+('q'&31)<<15,
     C         {SVC} 16_58C0<<16+ wea,
     C          's'<<25+('v'&31)<<20+('c'&31)<<15,
     C         {SVS} 16_59C0<<16+ wea,
     C          's'<<25+('v'&31)<<20+('s'&31)<<15,
     C         {SPL} 16_5AC0<<16+ wea,
     C          's'<<25+('p'&31)<<20+('l'&31)<<15,
     C         {SMI} 16_5BC0<<16+ wea,
     C          's'<<25+('m'&31)<<20+('i'&31)<<15,
     C         {SGE} 16_5CC0<<16+ wea,
     C          's'<<25+('g'&31)<<20+('e'&31)<<15,
     C         {SLT} 16_5DC0<<16+ wea,
     C          's'<<25+('l'&31)<<20+('t'&31)<<15,
     C         {SGT} 16_5EC0<<16+ wea,
     C          's'<<25+('g'&31)<<20+('t'&31)<<15,
     C         {SLE} 16_5FC0<<16+ wea,
     C          's'<<25+('l'&31)<<20+('e'&31)<<15,
     C         {MTCCR} 16_44C0<<16+ ea<<6,
     C          'm'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
     C         {MTSR} 16_46C0<<16+ ea<<6,
     C          'm'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
     C         {MFSR} 16_40C0<<16+ wea,
     C          'm'<<25+('f'&31)<<20+('s'&31)<<15+('r'&31)<<10,
     C         {MTUSP} 16_4E60<<16+ areg,
     C          'm'<<25+('t'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
     C         {MFUSP} 16_4E68<<16+ areg,
     C          'm'<<25+('f'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
     C         {ATCCR} 16_023C<<16+ imm,
     C          'a'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
     C         {ATSR} 16_027C<<16+ imm,
     C          'a'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
     C         {ETCCR} 16_0A3C<<16+ imm,
     C          'e'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
     C         {ETSR} 16_0A7C<<16+ imm,
     C          'e'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
     C         {OTCCR} 16_003C<<16+ imm,
     C          'o'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
     C         {OTSR} 16_007C<<16+ imm,
     C          'o'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10
  1823        
  1824        {?}%routine PUT OPCODE(%integer op)
  1825        {?}  put mnemonic(def(op+op))
  1826        {?}%end
  1827        
  1828        %routine STORE(%integer v,f)
  1829        !$IF VAX
  1830        {  v = v&16_FFFF;  v = v!sign16 %if v&sign16 # 0
  1831        !$FINISH
  1832          prog(pc) <- v;  pflag(pc) = f;  pc = pc+1
  1833        %end
  1834        
  1835        %routine MAKE ROOM(%integer size)
  1836        %integer newbase,newlim
  1837          size = (size+127)&(\127)
  1838          ownbase = ownbase-size
  1839          croak("Program too big") %if ownbase <= cad
  1840          newbase = ownbase;  newlim = newbase+ownad
  1841          %cycle
  1842            final(newbase) = final(newbase+size)
  1843            newbase = newbase+1
  1844          %repeat %until newbase >= newlim
  1845        %end
  1846        
  1847        %routine FILL CODE(%integer n)
  1848        %integer i
  1849          i = cad;  cad = cad+n
  1850          %while n > 0 %cycle
  1851            final(i) = 16_80;  i = i+1;  n = n-1
  1852          %repeat
  1853        %end
  1854        %routine FILL OWN(%integer n)
  1855        %integer i
  1856          make room(n)
  1857          i = ownbase+ownad;  ownad = ownad+n
  1858          %while n > 0 %cycle
  1859            final(i) = 16_80;  i = i+1;  n = n-1
  1860          %repeat
  1861        %end
  1862        
  1863        %routine SET CODE WORD(%integer v)
  1864        !$IF VAX (works irrespective of host byte sex)
  1865        {  final(cad) <- v>>8;  final(cad+1) <- v
  1866        !$IF APM (for efficiency)
  1867          shortinteger(final0+cad) <- v
  1868        !$FINISH
  1869          cad = cad+2
  1870        %end
  1871        
  1872        %integer%fn CODE WORD(%integer cad)
  1873        !$IF VAX (works irrespective of host byte sex)
  1874        {  %result = final(cad)<<8+final(cad+1)
  1875        !$IF APM (for efficiency)
  1876          %result = shortinteger(final0+cad)
  1877        !$FINISH
  1878        %end
  1879        
  1880        %routine SET CODE LONGWORD(%integer v)
  1881          set code word(v>>16);  set code word(v)
  1882        %end
  1883        
  1884        %routine SET OWN WORD(%integer v)
  1885          make room(2) %if ownbase+ownad > finalbound
  1886        !$IF VAX
  1887        {  final(ownbase+ownad) <- v>>8;  final(ownbase+ownad+1) <- v
  1888        !$IF APM
  1889          shortinteger(final0+ownbase+ownad) <- v
  1890        !$FINISH
  1891          ownad = ownad+2
  1892        %end
  1893        
  1894        %routine EXTEND STACK(%integer delta)
  1895          c_sp = c_sp-delta
  1896          %if c_sp < c_stack %start
  1897            c_stack = c_sp
  1898            c_totstack = c_stack %if c_stack < c_totstack
  1899          %finish
  1900        %end
  1901        
  1902        %routine PLANT(%integer op,y,x)
  1903        !Basic code planting procedure
  1904        ! OP is an index to the array defining op-codes
  1905        !  (it can be flagged to force SIZE)
  1906        ! For unary operations the operand is given by X (Y zero)
  1907        ! For binary operations the operands are Y (source) and X (dest)
  1908        %integer OPCODE,PC1,I,F,EXTWORD,INFO,KIND,MODE,MODEX,SIZE
  1909        %record(identinfo)%name DX,DY
  1910        %switch S(0:21)
  1911        %constbytearray SIZESYM(0:3) = 'L','B','W','?'
  1912        
  1913        %integer%fn NONLOCAL(%integer l)
  1914        %integer r
  1915          %result = mb %if l = outerlevel
  1916          hold(l)_status = hold(l)_status!globbed %if l # level
  1917          %result = f1 %if l = outerlevel+1
  1918          r = maxareg
  1919          %cycle
  1920            %result = r %if c_reg_content(r) = d7+l;  ![unique]
  1921            r = r-1
  1922          %repeat %until r < a0
  1923        ![not good enough: 1. may need two
  1924        !                  2. FREE updated elsewhere without regard to this]
  1925          r = maxareg
  1926          %while a0b<<(r-a0)&free = 0 %cycle
  1927            fault(plexerr) %and %exit %if r = a0
  1928            r = r-1
  1929          %repeat
  1930          c_reg_content(r) = d7+l
  1931          dtsprel_mode = globalmode;  dtsprel_val = l<<2
  1932          plant(move,lablim+2,r)
  1933          %result = r
  1934        %end
  1935        
  1936        %constinteger MOVEQ=36, ADDQ=37, MOVEA=39,
     C                      ADDA=40, ADDI=44
  1938        
  1939          %if x > 0 %start
  1940            intern(1) %and %return %if x >= explim
  1941            dx == dict(x)
  1942            modex = dx_mode
  1943            %if modex >= framemode %and modex # c_mode %c
     C            %and modex&2_111000 # 2_111000 %start
  1945              modex = nonlocal(modex&7)-a0+(modex&(7<<3))
  1946            %finish
  1947          %finish %else modex = litmode %and dx == dint
  1948          %if y > 0 %start
  1949            intern(1) %and %return %if y >= explim
  1950            dy == dict(y)
  1951            mode = dy_mode
  1952            %if mode >= framemode %and mode # c_mode %c
     C            %and mode&2_111000 # 2_111000 %start
  1954              mode = nonlocal(mode&7)-a0+(mode&(7<<3))
  1955            %finish
  1956          %finish %else mode = litmode %and dy == dint
  1957          size = op>>8;  op = op&255
  1958          %if op = move %start
  1959            %if modex&2_111000 = 0 %start;  !D
  1960              op = moveq %if y <= 0 %and y >= litmite %and size&3 = 0
  1961            %finish %else %if modex&2_110000 = 0 %start;   !A
  1962              op = movea
  1963            %finish
  1964          %finish %else %if op <= cmp %start
  1965            %if op < cmp %and y < 0 %and y >= litquick %and y&1 = 0 %c
     C            %then op=op+(addq-add) {ADDQ,SUBQ} %c
     C            %else %if modex&2_111000 = aregmode %c
     C            %then op=op+(adda-add) {ADDA,SUBA,CMPA} %c
     C            %else %if y <= 0 %c
     C            %then op=op+(addi-add) {ADDI,SUBI,CMPI}
  1971          %finish %else %if op <= eor %start
  1972            op = op+(addi-add) %if y <= 0 {ANDI,ORI,EORI}
  1973          %finish
  1974          info = def(op+op-1)
  1975          opcode = info>>16
  1976          %if info&sized # 0 %start;  !data size required
  1977            size = 4 %if size = 0
  1978            %if op = move %start
  1979              %if size = 4 %start
  1980                opcode = opcode+16_2000
  1981              %finish %else %if size = 2 %start
  1982                opcode = opcode+16_3000
  1983              %else
  1984                opcode = opcode+16_1000
  1985              %finish
  1986            %else
  1987              %if size = 4 %start
  1988                opcode = opcode+16_80
  1989              %finish %else %if size = 2 %start
  1990                opcode = opcode+16_40
  1991              %finish
  1992            %finish
  1993          %finish %else %if info&asized # 0 %start;  !areg size required
  1994            fault(sizerr) %if size = 1
  1995            %if op # movem %start
  1996              %if size = 0 %start
  1997                size = 4 %unless y <= 0 %and 0 = is short(litval(y))
  1998              %finish
  1999              %if size = 4 %start
  2000                %if op = movea %then opcode = opcode!!16_1000 %c
     C                %else opcode = opcode+16_0100
  2002              %finish
  2003            %else;  !MOVEM
  2004              size = 4 %if size = 0
  2005              opcode = opcode+16_0040 %if size = 4
  2006            %finish
  2007          %finish
  2008        {?}  %if control&codelist # 0 %and control&list # 0 %start
  2009        {?}    print line %if length(rep) >= 4
  2010        {?}    put sym(codeflag);  spaces(4-length(rep))
  2011        {?}    put opcode(op)
  2012        {?}    %if size # 0 %start
  2013        {?}      put sym('.')
  2014        {?}      put sym(sizesym(size&3))
  2015        {?}    %finish
  2016        {?}    spaces(12-length(rep))
  2017        {?}    %if info&(63<<6) # 0 %start
  2018        {?}      put operand(y)
  2019        {?}      put sym(',') %if info&63 # 0
  2020        {?}    %finish
  2021        {?}    put operand(x) %if info&63 # 0
  2022        {?}    spaces(33-length(rep));  put sym(':')
  2023        {?}  %finish
  2024        
  2025          pc1 = pc;  pflag(pc1) = c_shorts;  !op-code word
  2026          pc = pc+1
  2027          croak("Code space exhausted") %if pc >= swpc-8
  2028          kind = info>>6
  2029        again:
  2030          ->s(kind&31)
  2031        s(0):
  2032        next:
  2033          kind = info
  2034          %if kind # 0 %start
  2035            dy == dx;  y = x;  mode = modex
  2036            info = 0
  2037            ->again
  2038          %finish
  2039        !
  2040        !$IF VAX
  2041        {  opcode = opcode!sign16 %if opcode&sign16 # 0
  2042        !$FINISH
  2043          prog(pc1) <- opcode
  2044        {?}  %if control&codelist # 0 %and control&list # 0 %start
  2045        {?}    %cycle
  2046        {?}      put sym(' ')
  2047        {?}      put hex(prog(pc1))
  2048        {?}      pc1 = pc1+1
  2049        {?}    %repeat %until pc1 >= pc
  2050        {?}    print line
  2051        {?}  %finish
  2052          %return
  2053        
  2054        !Set flag value for PC-relative reference
  2055        ! distinguishing GLOBAL (const access), INDIRECT GLOBAL (procedure),
     C        ! and LOCAL (label) -- the last further distinguished according to
  2057        ! whether the instruction permits shortening
  2058        %routine PCREL(%integer shorten)
  2059          %if dy_mode = labmode %start
  2060            f = jump;  f = longjump %if shorten = 0
  2061            %if extword > 0 %start;  !label defined
  2062              %if shorten # 0 %and (extword-pflag(extword)-pc+c_shorts)<<1 >= -128 %start
  2063                %if c_shorts = 255 %start
  2064                  zaps = zaps+100
  2065                %else
  2066                  shorts = shorts+1;  c_shorts = c_shorts+1
  2067                  f = shortjump
  2068                %finish
  2069              %finish
  2070            %else
  2071              extword = -extword
  2072              dy_val = -pc
  2073            %finish
  2074          %finish %else %if dy_mode = procmode %start;  !procedure
  2075            f = indglobal;  extword = y;  !rather than DY_VAL
  2076          %finish %else %if dy_mode = constmode %start;  !constant data ref
  2077            f = global
  2078            f = f+1 %if extword < 0
  2079            f = f+2 %if extword > 65535
  2080          %finish %else %if dy_mode # pcmode %start
  2081            fault(moperr)
  2082          %finish
  2083        %end
  2084        
  2085        s(qea):  !LEA
  2086          -> ea0 %unless mode&63 = x-(a0-indexmode) %and dy_val&255 = 0
  2087          !  LEA 0(Ax,Dy)  =>  ADDA Dy,Ax
  2088          opcode = 16_D1C0+dy_val>>12&15
  2089          -> next
  2090        
  2091        s(wea):
  2092          dy_flags = dy_flags!(mflag!wflag)
  2093          -> wea1
  2094        s(rwea):  ![for our purposes, read&write counts as neither]
  2095          dy_flags = dy_flags!mflag
  2096        wea1:
  2097          -> err %if y <= 0 %or mode&63 >= pcmode
  2098          -> ea1
  2099        s(revea):  !reversible cases (EA,REG or REG,EA)
  2100          %if modex&2_111000 # 0 %start;  !dest not D
  2101            kind = shift;  info = rwea
  2102            opcode = opcode!!16_0100
  2103            ->sreg
  2104          %finish
  2105        s(ea): ea0:
  2106          %if y <= 0 %start
  2107            opcode = opcode+litmode;  !immediate
  2108            ->simm
  2109          %finish
  2110          %if dy_flags&(ext+spec+rflag+wflag) = ext+spec %c
     C          %and dy_flags&proc # 0 %start
  2112            ! Create transfer vector for external procedure
  2113            fill own(1) %if ownad&1 # 0
  2114            dy_val = ownad
  2115            set own word(16_207C+(mb-a0)<<9);  !MOVE.L #xxxxxxxx,MB
  2116            set own word(0);  set own word(0)
  2117            set own word(16_4EF9);  !JMP xxxxxxxx
  2118            set own word(0);  set own word(0)
  2119          %finish
  2120          %if (op = lea %or op = pea) %and mode&63 # pcmode %start
  2121            !taking address: might read or write
  2122            dy_flags = dy_flags!(mflag+rflag+wflag)
  2123            ->err %if mode&2_111000 < aregmode+indir
  2124          %else
  2125            dy_flags = dy_flags!(mflag+rflag)
  2126          %finish
  2127        ea1:
  2128          extword = dy_val
  2129          %if mode = c_mode %start;  !local
  2130            mode = dispmode+7;  extword = extword-c_sp;  !convert to use SP
  2131            %if extword < 0 %start
  2132              intern(4) %if extword < -4
  2133              mode = aregmode+pre+7
  2134              extend stack(-extword)
  2135              extword = 0
  2136            %finish
  2137          %finish
  2138          mode = mode&63;   !strip extra flags
  2139          %if mode >= dispmode %start;  !+extra
  2140            f = 0
  2141            %if mode = pcmode %start
  2142              pcrel(0)
  2143            %finish
  2144            %if mode <= dispmode+7 %start
  2145              %if extword = 0 %start
  2146                ! Premode (just created) or Dispmode (=>Indmode)
  2147                mode = mode+(aregmode+indir-dispmode) %if mode >= dispmode
  2148              %else
  2149                fault(dreacherr) %unless -32768 <= extword <= 32767
  2150                store(extword,f)
  2151              %finish
  2152            %else
  2153              mode = absmode+1 %if mode = absmode %and %not 0 = is short(extword)
  2154              store(extword>>16,0) %if mode = absmode+1
  2155              store(extword,f)
  2156            %finish
  2157          %finish
  2158          mode = ((mode&7)<<3 + mode>>3)<<6 %if kind&shift # 0
  2159          opcode = opcode+mode
  2160          ->next
  2161        
  2162        s(exreg&31):  !EXG (D,D / A,A / D,A)
  2163          %if mode&2_111000 = 0 %start;  !D
  2164            %if modex&2_111000 # 0 %start;  !not D
  2165              opcode = opcode!!16_C8;  info = areg
  2166            %finish
  2167            -> sreg
  2168          %finish
  2169          opcode = opcode+8;  info = areg
  2170          -> sareg
  2171        s(qpre):
  2172          -> sreg %if mode&2_111000 = 0;  !D
  2173          opcode = opcode+8;  info = preareg+shift
  2174        s(preareg):
  2175          mode = mode+(post-pre)
  2176        s(postareg):
  2177          mode = mode-post
  2178        s(areg): sareg:
  2179          mode = mode-8
  2180        s(reg): sreg:
  2181          -> err %unless mode&2_111000 = 0
  2182          mode = mode&7
  2183          mode = mode<<9 %if kind&shift # 0
  2184          opcode = opcode+mode
  2185          ->next
  2186        
  2187        s(qreg):  !Shift formats -- quick,Dx / Dy,Dx / 1,<ea> (W)
  2188          opcode = opcode+16_20 %and ->sreg %if y > 0
  2189          %if y = one %and size = 2 %and modex&2_111000 # 0 %start
  2190            opcode = opcode!!16_290
  2191            ->next
  2192             %finish
  2193        s(quick):
  2194          -> err %if y >= 0
  2195          y = litval(y)
  2196          ->err %unless y <= 8
  2197          opcode = opcode+(y&7)<<9;  !(always aligned to bit9)
  2198          ->next
  2199        
  2200        s(tquick):  !(TRAP)
  2201          -> err %unless -30 <= y %and y&1 = 0;  !{0<=}litval(y)<=15
  2202        s(mquick):
  2203          ->err %unless y <= 0 %and y >= litmite
  2204          y = litval(y)
  2205          opcode = opcode+y&255
  2206          ->next
  2207        s(rel):
  2208          ->s(mquick) %if y <= 0 %and y >= litmite
  2209        s(longrel):
  2210          ->simm %if y <= 0
  2211          dy_flags = dy_flags!rflag
  2212          extword = dy_val
  2213          f = 0
  2214          pcrel(longrel-kind&31)
  2215          store(extword,f)
  2216          ->next
  2217        
  2218        s(ireg):  !immediate or reg
  2219          ->sreg %if y > 0
  2220          opcode = opcode!!16_900
  2221        s(imm):
  2222          ->err %if y > 0
  2223        simm:
  2224          y = litval(y)
  2225          store(y>>16,0) %if size = 4
  2226        put:
  2227          store(y,0)
  2228          ->next
  2229        s(ximm):  !MOVEM (IMM,EA or EA,IMM)
  2230          %if y > 0 %start;  !EA,IMM
  2231            opcode = opcode!!16_0400
  2232            i = x;  x = y;  y = i
  2233            dx == dy;  modex = mode
  2234          %finish
  2235          y = litval(y)
  2236          %if prea0 <= x <= prea7 %start;  !-(SP)
  2237            i = 0;  !Reverse bits
  2238            i = i<<1+y&1 %and y = y>>1 %for extword = 1,1,16
  2239            y = i
  2240          %finish
  2241          ->put
  2242        s(data):
  2243          -> err %if y <= 0
  2244          -> err %if mode # absmode
  2245          opcode = dy_val
  2246          ->next
  2247        err:
  2248          fault(moperr)
  2249          ->next
  2250        %end;  !plant
  2251        
  2252        %routine PLANTLIT(%integer op,v,x)
  2253          %if v >= 0 %start
  2254            %if v > smallmax %then litstore(litmax) = v %and v = litmax %c
     C            %else v = -(v<<1)
  2256          %else
  2257            %if v < smallmin %then litstore(litmax) = v %and v = litmax %c
     C            %else v = v<<1+1
  2259          %finish
  2260          plant(op,v,x)
  2261        %end
  2262        
  2263        %routine PLANTLIT2(%integer op,y,v)
  2264          %if v >= 0 %start
  2265            %if v > smallmax %then litstore(litmax) = v %and v = litmax %c
     C            %else v = -(v<<1)
  2267          %else
  2268            %if v < smallmin %then litstore(litmax) = v %and v = litmax %c
     C            %else v = v<<1+1
  2270          %finish
  2271          plant(op,y,v)
  2272        %end
  2273        
  2274        %routine ALIGN(%integername AD, %integer size)
  2275        !Impose alignment requirements on address AD for
  2276        ! operand of length SIZE
  2277        !provisional basis for bit addressing
  2278        ! -- multiples of 16 on Word boundary
  2279        ! -- multiples of 8 on Byte boundary
  2280        ! -- other < 32 within one Longword
  2281        !%constinteger BITMASK=16_E0000000
  2282        !  %if size&7 = 0 %start
  2283        !    ad = (ad&(\bitmask))+1 %if ad&bitmask # 0;  !ensure on byte boundary
  2284        !    %return %if size&8 # 0
  2285        !  %else
  2286        !    %return %if size < 16
  2287        !    %return %if ad>>29+(ad&1)<<3+size <= 32
  2288        !    ad = (ad&(\bitmask))+1 %if ad&bitmask # 0
  2289        !  %finish
  2290          ad = ad+1 %if size # 1 %and ad&1 # 0
  2291        %end
  2292        
  2293        %routine ADDIMM(%integer bytes,dest)
  2294          %if bytes <= 0 %start
  2295            %return %if bytes = 0
  2296            %if bytes >= -8 %start
  2297              plantlit(sub,-bytes,dest)
  2298              %return
  2299            %finish
  2300          %finish %else %if bytes <= 8 %start
  2301            plantlit(add,bytes,dest)
  2302            %return
  2303          %finish
  2304          %if a0 <= dest <= a7 %and 0 = is short(bytes) %start
  2305            plant(lea,tempd(dest,bytes),dest)
  2306            %return
  2307          %finish
  2308          plantlit(add,bytes,dest)
  2309        %end
  2310        
  2311        %integer%fn FREE REG(%integer rset)
  2312        %integer r,r1
  2313          r = d0;  rset = rset&free
  2314          %if rset = 0 %then fault(plexerr) %else %start
  2315            r = r+1 %and rset = rset>>1 %while rset&1 = 0
  2316            r1 = r
  2317            %while c_reg_content(r) # undef %cycle
  2318              r = r+1;  rset = rset>>1
  2319              r = r1 %and %exit %if rset = 0
  2320              r = r+1 %and rset = rset>>1 %while rset&1 = 0
  2321            %repeat
  2322            free = free-d0b<<(r-d0)
  2323          %finish
  2324          %result = r
  2325        %end
  2326        
  2327        %routine MOVE BLOCK(%integer source,dest,bytes)
  2328        !Generate code to move a fixed number of bytes
  2329        ! from SOURCE (0,reg,pre,post) to DEST (pre,post)
  2330        ! -- source & dest addresses both even if BYTES even
  2331        %integer op,f,r,pc1
  2332          op = move;  op = clr %if source = 0
  2333          %if bytes <= 16 %and bytes&1 = 0 %start
  2334            plant(op,source,dest) %and bytes = bytes-4 %while bytes >= 4
  2335            plant(op+2<<8,source,dest) %if bytes >= 2
  2336          %else;  !use loop
  2337            op = op+1<<8
  2338            %if bytes&1 = 0 %start
  2339              bytes = bytes>>1;  op = op+1<<8;  !.B -> .W
  2340              %if bytes&1 = 0 %start
  2341                bytes = bytes>>1;  op = op+2<<8;  !.W -> .L
  2342              %finish
  2343            %finish
  2344            f = free
  2345            %if bytes <= 32768 %and free&anydreg # 0 %start
  2346              r = free reg(anydreg)
  2347              plantlit(move,bytes-1,r)
  2348              pc1 = pc
  2349              plant(op,source,dest)
  2350              plantlit2(dbra,r,(pc1-pc-1)<<1)
  2351              bytes = undef
  2352            %else
  2353              r = free reg(anydreg!bregb)
  2354              plantlit(move,bytes,r)
  2355              pc1 = pc
  2356              plant(op,source,dest)
  2357              plant(sub,one,r)
  2358              plantlit2(bne,0,(pc1-pc-1)<<1)
  2359              bytes = 0
  2360            %finish
  2361            c_reg_content(r) = bytes;  free = f
  2362          %finish
  2363        %end
  2364        
  2365        %routine UPDATE SP
  2366          %return %if c_val = 0
  2367          %if c_val < 0 %start
  2368            addimm(-c_val,a7);  c_sp = c_sp-c_val
  2369          %else
  2370            %if control&assmask = 0 %then addimm(-c_val,a7) {no unass check} %c
     C            %else move block(d7,prea7,c_val)
  2372            extend stack(c_val)
  2373          %finish
  2374          c_val = 0
  2375        %end
  2376        
  2377        %routine GET BOUNDS(%integer t,%integername lo,hi)
  2378        ![Note: sets HI after LO -- see dummy params in VALOK] 
  2379          %if dict(t)_type = t # inttype %start;  !basetype
  2380            lo = 0;  hi = dict(t)_size
  2381          %else
  2382            %if dict(t+1)_mode # litmode %then lo = minint %c
     C            %else lo = dict(t+1)_val
  2384            %if dict(t+2)_mode # litmode %then hi = maxint %c
     C            %else hi = dict(t+2)_val
  2386          %finish
  2387        %end
  2388        
  2389        %integer%fn SIZE(%integer t)
  2390        !Storage size for given object type in bytes
  2391        ! > 0 for operand passable in register
  2392        ! < 0 otherwise
  2393        %integer s,ss,lo,hi
  2394        %record(identinfo)%name tp
  2395          tp == dict(t)
  2396          %if tp_flags&nonord = 0 %start
  2397            %result = tp_size %if tp_type # t;  !subrange
  2398            %result = 4 %if tp_type = inttype
  2399            %result = 1 %if tp_size <= 255
  2400            %result = 2
  2401          %finish
  2402          %result = tp_val %if tp_flags&cat = recy
  2403          %result = tp_size %if tp_flags&cat # arry
  2404          %result = 0 %if tp_mode >= framemode;  !dynamic bounds
  2405          s = 4;  s = size(tp_type) %if tp_flags >= 0
  2406          get bounds(tp_xtype,lo,hi)
  2407          %result = 0 %if lo = minint %or hi = maxint
  2408          ss = (hi-lo+1)*s
  2409          %result = ss %if ss <= 0
  2410          %if s = 1 %start;  !byte element size (not nec aligned)
  2411            %result = ss %if ss = 1
  2412          %else;  !word,long element size (aligned)
  2413            %result = ss %if ss <= 4
  2414          %finish
  2415          %result = -ss
  2416        %end
  2417        
  2418        %integer%fn NSIZE(%record(identinfo)%name dp)
  2419          %result = 4 %if dp_flags&(name+indirect) # 0
  2420          %result = 0 %if dp_flags&proc # 0;       ![??]
  2421          %result = size(dp_type)
  2422        %end
  2423        
  2424        %integer%fn TSIZE(%integer t)
  2425          %result = size(dict(t)_type)
  2426        %end
  2427        
  2428        %routine FORGET(%integer r)
  2429          c_reg_content(r) = undef
  2430        %end
  2431        %routine FORGET CC
  2432          c_reg_ccy = undef
  2433        %end
  2434        %routine FORGET REGS
  2435        %shortname cc
  2436          cc==c_reg_content(maxareg)
  2437          %cycle
  2438            cc = undef
  2439            %exit %if cc == c_reg_content(d0)
  2440            {cc == cc[-1]}%exit   {GT: Need to rewrite in standard imp}
  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,
     C        16_6365,16_6564,16_6564,16_B098,16_6E06,16_9098,16_6C10,16_D0A0,
     C        16_41FA,16_FFDE,16_2400,16_7202,16_7076,16_4EF8,16_3EFA,16_4A58,
     C        16_660C,16_4840,16_4A40,16_6610,16_4840,16_C0D8,16_4E75,
     C        16_2F01,16_2200,16_C2E8,16_FFFE,16_6008,16_2F01,16_2200,16_4840,
     C        16_C2D0,16_4841,16_C0D8,16_D081,16_221F,16_4E75,
     C        16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
     C        16_6162,16_6C65,16_660C,16_41FA,16_FFE8,16_7201,16_7058,16_4EF8,
     C        16_3EFA,16_4E75,
     C        16_0F49,16_6E76,16_616C,16_6964,16_2061,16_6464,16_7265,16_7373,
     C        16_6E0C,16_41FA,16_FFEC,16_7201,16_7058,16_4EF8,16_3EFA,16_4E75,
     C        16_1553,16_7461,16_636B,16_2073,16_7061,16_6365,16_2065,16_7868,
     C        16_6175,16_7374,16_6564,16_D88F,16_B886,16_6C0E,16_4284,16_41FA,
     C        16_FFE0,16_7203,16_7055,16_4EF8,16_3EFA,16_4284,16_4E75,
     C        16_1741,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_696E,
     C        16_7369,16_6465,16_206F,16_7574,16_9282,16_6F0C,16_41FA,16_FFE2,
     C        16_7203,16_7055,16_4EF8,16_3EFA,16_4481,16_5281,16_4EF8,16_3EF4,
     C        16_4E75,
     C        16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
     C        16_1811,16_9004,16_6504,16_9010,16_640C,16_41FA,16_FFE4,16_7203,
     C        16_7051,16_4EF8,16_3EFA,16_1018,16_670C,16_D111,16_1398,16_4801,
     C        16_5204,16_5300,16_66F6,16_2049,16_4E75,
     C        16_3F00,16_7001,16_1E80,16_204F,16_548F,16_4E75,
     C        16_124E,16_6F20,16_7370,16_6163,16_6520,16_666F,16_7220,16_6172,
     C        16_7261,16_7980,16_5680,16_E480,16_E588,16_6D08,16_204F,16_91C0,
     C        16_B1C6,16_6C0E,16_2400,16_41FA,16_FFD8,16_7201,16_7072,16_4EF8,
     C        16_3EFA,16_205F,16_E488,16_6004,16_4840,16_2F07,16_51C8,16_FFFC,
     C        16_4840,16_51C8,16_FFF4,16_4ED0,16_4E75,
     C        16_1149,16_6E76,16_616C,16_6964,16_2025,16_666F,16_7220,16_6C6F,
     C        16_6F70,16_2F00,16_9082,16_6720,16_2F01,16_6708,16_4EB8,16_3EEE,
     C        16_4A80,16_6D0E,16_508F,16_41FA,16_FFD8,16_7201,16_7055,16_4EF8,
     C        16_3EFA,16_4A81,16_66EE,16_221F,16_201F,16_4E75,
     C        16_0C4F,16_7574,16_206F,16_6620,16_7261,16_6E67,16_6580,16_41FA,
     C        16_FFF0,16_7201,16_7056,16_4EF8,16_3EFA,16_4E75,
     C        16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
     C        16_6162,16_6C65,16_B0FC,16_0000,16_6F1A,16_B2FC,16_0000,16_6F14,
     C        16_BE10,16_6606,16_BE28,16_0001,16_670A,16_BE11,16_6612,16_BE29,
     C        16_0001,16_660C,16_41FA,16_FFCA,16_7202,16_7054,16_4EF8,16_3EFA,
     C        16_48E7,16_C0C0,16_4240,16_1018,16_6730,16_4241,16_1219,16_6722,
     C        16_5380,16_5381,16_B041,16_6E12,16_9240,16_B109,16_56C8,16_FFFC,
     C        16_6602,16_4441,16_4CDF,16_0303,16_4E75,
     C        16_B109,16_56C9,16_FFFC,16_66F2,16_7201,16_4CDF,16_0303,16_4E75,
     C        16_1011,16_4440,16_4CDF,16_0303,16_4E75,
     C        16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
     C        16_B010,16_640C,16_41FA,16_FFEA,16_7203,16_7051,16_4EF8,16_3EFA,
     C        16_4280,16_1010,16_12D8,16_51C8,16_FFFC,16_4E75,
     C        16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
     C        16_B010,16_640C,16_41FA,16_FFEA,16_7201,16_7056,16_4EF8,16_3EFA,
     C        16_0240,16_00FE,16_245F,16_9EC0,16_558F,16_224F,16_BFC8,16_6E0E,
     C        16_1010,16_12D8,16_51C8,16_FFFC,16_204F,16_224F,16_4ED2,16_1018,
     C        16_5289,16_D0C0,16_D2C0,16_1320,16_51C8,16_FFFC,16_204F,16_224F,
     C        16_4ED2,16_4E75,
     C        16_43EF,16_FF00,16_2448,16_D5C0,16_2049,16_9280,16_6C04,16_4211,
     C        16_4E75,
     C        16_1281,16_5219,16_12DA,16_51C9,16_FFFC,16_4E75,
     C        16_700A,16_4EF8,16_3E70,16_4E75,
     C        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
     C            %else %if line-c_reg_line > 8 %then plant(move+2<<8,litpos,lineloc) %c
     C            %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,
     C                      CMPM=43,
     C                      TRAPV=70,
     C                      SWAP=74, EXTL=76,
     C                      JMP=57, TST=59, DBNE=86
  2695                      
  2696        %constinteger MOVEW=move+2<<8, ADDW=add+2<<8,
     C                      MOVEB=move+1<<8, ADDB=add+1<<8,
     C                      SUBB=sub+1<<8, CMPB=cmp+1<<8,
     C                      CMPMB=cmpm+1<<8
  2700        
  2701        %constinteger VAL=sign+anyreg, REF=sign,
     C                      SIZESHIFT=16,
     C                      TOBYTE=1<<16, TOSHORT=1<<17, {1<<18 not sig}
     C                      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
     C          %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
     C                %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
     C                   %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
     C              %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
     C                                %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 0 = is mite(i) %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 0 = is mite(v+q) %start;  !indexmode out
  3273              %unless 0 = is mite(q) %start; !& out even if V absorbed
  3274                i = freeish areg(undef)
  3275                %if 0 = is short(v+q) %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
     C            %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
     C           %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 0 = is short(v) %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
     C          %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
     C                         %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
     C          %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
     C            %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 == dp[1]

*    Failed to analyse line  3761
     DP==DP[1]
           !

*    Failed to analyse line  3761
     DP==DP[1]
           !
  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
     C                    %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 0 = is short(litval(y))
  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
     C                %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
     C            %or %not easy(dy_x)

*    Failed to analyse line  3942
      %RESULT =FALSE %IF DY_Y>=NP0 %OR DY_Y=X %ORNOT EASY(DY_X)
                                                              !

*    Failed to analyse line  3942
      %RESULT =FALSE %IF DY_Y>=NP0 %OR DY_Y=X %ORNOT EASY(DY_X)
                                                              !
  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))

*    Failed to analyse line  3981
     FORGET(R) %IF UNSAFE(C_REG_CONTENT(R))
                                          !

*    Failed to analyse line  3981
     FORGET(R) %IF UNSAFE(C_REG_CONTENT(R))
                                          !
  3982          %repeat
  3983          forget cc %if unsafe(c_reg_ccx) %or unsafe(c_reg_ccy)

*    Failed to analyse line  3983
     FORGETCC %IF UNSAFE(C_REG_CCX) %OR UNSAFE(C_REG_CCY)
                                     !

*    Failed to analyse line  3983
     FORGETCC %IF UNSAFE(C_REG_CCX) %OR UNSAFE(C_REG_CCY)
                                     !
  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)

*    Failed to analyse line  3992
      %RESULT =FALSE %UNLESS XFREE(DP_Y,1)
                                         !

*    Failed to analyse line  3992
      %RESULT =FALSE %UNLESS XFREE(DP_Y,1)
                                         !
  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 == dp[1]

*    Failed to analyse line  4004
     DP==DP[1]
           !

*    Failed to analyse line  4004
     DP==DP[1]
           !
  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) %start

*    Failed to analyse line  4042
      %FINISHELSEIF ACT=JAMASS %ORNOT EASY(Y) %START
                                               !

*    Failed to analyse line  4042
      %FINISHELSEIF ACT=JAMASS %ORNOT EASY(Y) %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
     C                  %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
     C                  %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) %start

*    Failed to analyse line  4084
      %FINISHELSEUNLESS EASY(Y) %START
                                 !

*    Failed to analyse line  4084
      %FINISHELSEUNLESS EASY(Y) %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

* 4095   FAULT 51 %FINISH is not required

* 4095   FAULT 51 %FINISH is not required
  4096            beware(xx)
  4097            -> checksp
  4098          %finish

* 4098   FAULT 51 %FINISH is not required

* 4098   FAULT 51 %FINISH is not required
  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
     C              %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) %start

*    Failed to analyse line  4110
      %IF XFREE(Y,0) %START
                      !

*    Failed to analyse line  4110
      %IF XFREE(Y,0) %START
                      !
  4111              case = 1<<(x-d0);  free = free!case
  4112            %else
  4113              free = free&(\(1<<(x-d0)))
  4114            %finish
  4115          %finish

* 4115   FAULT 51 %FINISH is not required

* 4115   FAULT 51 %FINISH is not required
  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
     C                %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
     C                %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
     C            %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
     C              %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
     C                   %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
     C            %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 == dp[1]

*    Failed to analyse line  4283
     DP==DP[1]
           !

*    Failed to analyse line  4283
     DP==DP[1]
           !
  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 == dp[1]

*    Failed to analyse line  4383
     DP==DP[1]
           !

*    Failed to analyse line  4383
     DP==DP[1]
           !
  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
     C          %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;  !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 0 = is short(entry-chain)
  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
     C          %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
     C            %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
     C                  %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 0 = is short(i)
  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 0 = is short(y) %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==dict(p)

*    Failed to analyse line  4819
      %RECORD (IDENTINFO) %NAME DQ,DP==DICT(P)
                                     !

*    Failed to analyse line  4819
      %RECORD (IDENTINFO) %NAME DQ,DP==DICT(P)
                                     !
  4820        %owninteger q=0,l=0
  4821          dp_text = 0;  q = 0
  4822          l = dp_link
  4823          %if l # 0 %start
  4824            l = crunched(l) %if dp_type < p
  4825            %result = p %if p <= l
  4826            dp_link = l
  4827            q = l-1
  4828          %finish
  4829          dq == dict(q)
  4830          %while q < p %cycle
  4831            %if dq_type = dp_type %c
     C            %and dq_link = l %and dq_reg = dp_reg %and dq_val = dp_val %start
  4833              dlim = p
  4834              %result = q
  4835            %finish
  4836            q = q+1;  dq == dq[1]

*    Failed to analyse line  4836
     DQ==DQ[1]
           !

*    Failed to analyse line  4836
     DQ==DQ[1]
           !
  4837          %repeat
  4838          %result = p
  4839        %end
  4840        
  4841        %routine POP CONTEXT
  4842          pc = c_localpc;  swpc = c_localswpc;  curlab = c_lab1
  4843          dlim = c_parlim
  4844        !  %for i = 0,1,255 %cycle
  4845        !    hashindex(i) = dict(hashindex(i))_hlink %while hashindex(i) >= c_localdpos
  4846        !  %repeat
  4847          %if level > outerlevel %start
  4848            charlim = c_localtext
  4849            ranges = dict(ranges)_hlink %while ranges >= c_parlim
  4850            c_dpid_type = crunched(c_dpid_type)
  4851            level = level-1;  c = hold(level)
  4852            control = control&editbit ! c_oldcontrol&(\editbit)
  4853          %finish
  4854          dictshown = dlim %if dictshown > dlim
  4855          starts = 0;  cycles = 0
  4856        %end
  4857        
  4858        %routine FIXUP SWITCH VECTOR(%integer pos,%record(identinfo)%name dp)
  4859        %integer x,y,j,default,temp,lo,hi
  4860        %record(identinfo)%name tp==typecell(dp_type)

*    Failed to analyse line  4860
      %RECORD (IDENTINFO) %NAME TP==TYPECELL(DP_TYPE)
                                  !

*    Failed to analyse line  4860
      %RECORD (IDENTINFO) %NAME TP==TYPECELL(DP_TYPE)
                                  !
  4861          x = dp_val
  4862          default = dp_link;  default = pc %if default = 0
  4863          get bounds(tp_xtype,lo,hi)
  4864          %if dp_flags&arrflag = 0 %then j = pflag(x-1)+lo %c
     C          %else j = pflag(x-7);  !allow for dope info
  4866          j = x-j;  !base position
  4867          %while lo <= hi %cycle;  !For each element
  4868            y = prog(x)
  4869            %if y <= 0 %start;  !not set
  4870              %if dp_link = 0 %start;  !no default
  4871                report(slabmissing+warn,pos,lo)
  4872                c_access = 1
  4873              %finish
  4874              %if y < 0 %start;  !explicit jump(s) to this one
  4875                y = -y
  4876                %cycle;  !define jumps to default
  4877                  temp = y;  y = prog(temp);  prog(temp) = default
  4878                %repeat %until y = 0
  4879              %finish
  4880              y = default
  4881            %finish
  4882            prog(x) = (y-pflag(y)-j)<<1
  4883            x = x+1;  lo = lo+1
  4884          %repeat
  4885        %end
  4886        
  4887        %routine CLOSE BLOCK
  4888        %integer miss,under,pos,base
  4889        %record(identinfo)%name dp
  4890         ! WRONGCC is clear if all %result statements leave correct CC
  4891          %if c_type > 0 %and c_status&wrongcc = 0 %start
  4892           ! set special values and see if they survive exit sequence
  4893            c_reg_ccx = 0;  c_reg_ccy = 0
  4894          %finish
  4895          %if c_return # 0 %start
  4896            %if c_return = -(pc-1) %and c_access = 0 %start
  4897              c_return = -prog(pc-1);  pc = pc-2 
  4898            %finish
  4899            define jumps(c_return);  !must precede switch fixup
  4900            c_access = -1
  4901          %finish
  4902          pflag(pc) = c_shorts;      !in case of terminal switch labels
  4903          %if c_status&hadswitch # 0 %start
  4904            pos = c_localdpos
  4905            %while pos < dlim %cycle
  4906              dp == dict(pos)
  4907              fixup switch vector(pos,dp) %if dp_mode = labmode %and dp_type # 0
  4908              pos = pos+1
  4909            %repeat
  4910          %finish
  4911          compile end
  4912          c_totstack = c_totstack-c_extra
  4913          c_totstack = -c_totstack %if c_status&unknown = 0;  !positive if firm
  4914          typecell(c_dpid_type)_val = c_totstack
  4915        {?}  %if control&maplist # 0 %start
  4916        {?}    put ident(c_pid,0)
  4917        {?}    mark at(20)
  4918        {?}    put string(" code:")
  4919        {?}    put num(cad-c_localad-accounted)
  4920        {?}    put string("  entry:")
  4921        {?}    put num(c_dpid_val-c_localad-accounted)
  4922        {?}    put string("  stack:");  put num(-c_stack)
  4923        {?}    putsym('/');  put num(imod(c_totstack))
  4924        {?}    put sym('+') %if c_totstack < 0
  4925        {?}    accounted = cad-c_localad
  4926        {?}    print line
  4927        {?}  %finish
  4928          !Check identifier usage
  4929          miss = 0;  under = 0
  4930          base = c_localdpos;  base = 0 %if level = outerlevel
  4931          pos = dlim;  dp == dict(pos)
  4932          %while pos > base %cycle
  4933            pos = pos-1;  dp == dp[-1]

*    Failed to analyse line  4933
     DP==DP[-1]
           !

*    Failed to analyse line  4933
     DP==DP[-1]
           !
  4934            %if dp_flags&ext = 0 %start
  4935        !<<IMP
  4936        !<<BOTH
  4937              %if dp_text > 0 %start;               !user id
  4938                set hashhead(string(dp_text+char0))
  4939                %if head = pos %start;              !still active
  4940                  head = dp_hlink;                  !remove from hash list
  4941        check:    %if dp_flags&spec # 0 %start
  4942                    dp_hlink = miss;  miss = pos
  4943                  %finish %else %if ((dp_flags&(readable+rflag) = readable %and dp_mode # litmode) %c
     C                    %or (dp_flags&(writable+okflag+wflag+spec) = writable)) %c
     C                    %and pos >= c_localdpos %and dp_mode # 0 %and dp_flags&typeid = 0 %c
     C                    %and control&(list!maplist) # 0 %start
  4947                    dp_hlink = under;  under = pos
  4948                  %finish
  4949                %finish
  4950              %finish
  4951            %finish %else %if level = outerlevel %start;  !external, external spec
  4952              %if dp_flags&spec = 0 %start;  !external object
  4953                dp_link = externs;  externs = pos
  4954              %finish %else %if dp_flags&(rflag+wflag) # 0 %start
  4955               !external spec (used)
  4956                dp_link = extspecs;  extspecs = pos
  4957              %finish
  4958            %finish
  4959          %repeat
  4960          report(idmissing,miss,0) %if miss # 0
  4961          %if under # 0 %and c_faults = 0 %start
  4962            put ident(under,1)
  4963            put string(" underused")
  4964            print line
  4965          %finish
  4966          pop context
  4967          set first entry %if firstpos >= dlim
  4968        %end;  !CLOSE BLOCK
  4969        
  4970        %routine ERROR(%integer case)
  4971          faultp = atomp
  4972          report(case,0,0)
  4973          %signal fail
  4974        %end
  4975        
  4976        %constinteger DUD=63
  4977        %routine SYNTAX ERROR
  4978          %if atom = dud %then error(atomerr+point) %else error(formerr+point)
  4979        %end
  4980        
  4981        %routine EXPFAULT(%integer case)
  4982          %if faultnum = 0 %or expp < faultp %start
  4983            faultnum = case!point;  faultp = expp
  4984          %finish
  4985        %end
  4986        
  4987        %routine NONSTANDARD(%integer case)
  4988        %integer b
  4989        %owninteger hadit=0
  4990          b = 1<<case
  4991          %if b&hadit = 0 %and control&nonsbit = 0 %and faultnum = 0 %start
  4992            hadit = hadit+b;  faultp = atomp
  4993            %if control&strictbit # 0 %then report(nonstand+point,0,case) %c
     C            %else report(nonstand+point+warn,0,case)
  4995          %finish
  4996        %end
  4997        
  4998        %routine NAME ERROR
  4999        !check if the culprit has occurred before
  5000        !and, if not, add it to the pool of unknowns stored at the
  5001        !far end of the dictionary.
  5002          %if item >= 0 %start;  !first time
  5003            fault(namerr+point+now)
  5004            %if charmin-newlen-80 >= charlim %start
  5005              dmin = dmin-1;  dmin0 = dmin
  5006              charmin = charmin-newlen-1
  5007              string(charmin) = string(charlim)
  5008              dict(dmin)_text = charmin-char0
  5009              head == dict(head)_hlink %while head > 0;  !find last link
  5010              dict(dmin)_hlink = head;  head = -dmin
  5011            %finish
  5012          %finish %else others = others+1
  5013          %signal fail
  5014        %end
  5015        
  5016        %routine FIND OP(%integer mnemonic,%integername op,types)
  5017        %integer i
  5018          i = 0
  5019          %cycle
  5020            i = i+2
  5021            error(namerr) %if i > defmax+defmax
  5022          %repeat %until def(i) = mnemonic 
  5023          types = def(i-1);  op = i>>1
  5024        %end
  5025        
  5026        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5027        !!!!!!!!!!!!!!!!!!!!  Source input  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5028        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5029        
  5030        %routine READ LINE(%integer flag)
  5031        ! Read (or otherwise make available) the next source line
  5032        !     Output any pending error report;                 *NB*
  5033        !     Skip remnant of previous line if SYM # NL        *NB*
  5034        !     Set LINESTART to point to start of new line
  5035        !     Print new line on list output stream if listing requested
  5036        !       (Direct output routines CF diagnostics)
  5037          report(faultnum,0,0) %if faultnum # 0
  5038          %while sym > nl %cycle;               !Skip remnant
  5039            sym = byteintegeR(fp);  fp = fp+1
  5040          %repeat
  5041          line = line+1
  5042          %while fp = curlim %cycle
  5043            %if curlim # cur_lim2 %start;  !in part1 of file
  5044              fp = cur_start2
  5045            %finish %else %if curfile = main %start;      !on main
  5046              %signal done
  5047            %else
  5048              cur_flag = -1
  5049        !!      disconnect edfile(cur)
  5050              curfile = curfile-1
  5051              cur == file(curfile)
  5052              fp = cur_fp;  line = cur_line
  5053              control = fcontrol(curfile)
  5054              inclim = dlim %if level = outerlevel %and c_status < hadon
  5055            %finish
  5056            curstart = cur_start2;  curlim = cur_lim2
  5057            %if fp < curstart %or fp > curlim %start
  5058              curstart = cur_start1;  curlim = cur_lim1
  5059            %finish
  5060          %repeat
  5061          linestart = fp
  5062          %if flag = 0 %start
  5063            flag = ' ';  flag = '&' %if curfile # main
  5064          %finish
  5065          listflag = flag
  5066          %if control&list # 0 %start
  5067            time1 = time1-cputime
  5068            print line %if rep # ""
  5069            show dict(dictshown) %if control&dictlist # 0
  5070            dictshown = dlim
  5071            write(line,4);  print symbol(listflag)
  5072            print symbol(' ')
  5073            %cycle
  5074              sym = byteintegeR(fp);  fp = fp+1
  5075              print symbol(sym)
  5076            %repeat %until sym <= nl
  5077            fp = linestart
  5078            time1 = time1+cputime
  5079          %finish
  5080          sym = 0
  5081        %end;  !READ LINE
  5082        
  5083        !<<IMP
  5084        
  5085        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5086        !!!!!!!!!!!!!!!!!!!!  Lexical processing  !!!!!!!!!!!!!!!!!!!!!!
  5087        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5088        
  5089        %constinteger CASEBIT=32
  5090        %owninteger PERCENT=0, SUBATOM=0
  5091        !
  5092        !~!!!!!!!  Keyword codes -- used by KEYGEN to produce tables  !!
  5093        %constinteger %c
     C          KEYEND=1 {end},
     C          KEYREPEAT=2   {repeat},
     C          KEYFINISH=3   {finish},
     C          KEYELSE=4     {else},
     C          KEYBEGIN=5    {begin},
     C          EXIT=6        {exit_1,continue_0}
  5100        %constinteger %c
     C          KEYRETURN=7   {return},
     C          TF=8          {true_1,false_0},
     C          KEYRESULT=9   {result},
     C          KEYSTOP=10    {stop},
     C          KEYGOTO=11    {goto},
     C          KEYSIGNAL=12  {signal}
  5107        %constinteger %c
     C          KEYMONITOR=13 {monitor},
     C          KEYON=14      {on},
     C          IU=15         {if_0,unless_1},
     C          KEYWHILE=16   {while},
     C          KEYUNTIL=17   {until_1},
     C          KEYFOR=18     {for},
     C          KEYTHEN=19    {then}
  5115        %constinteger %c
     C          KEYSTART=20   {start},
     C          KEYCYCLE=21   {cycle},
     C          KEYLABEL=22   {label},
     C          KEYCONST=23   {const,constant},
     C          KEYOWN=24     {own},
     C          KEYEXT=25     {external_6,system_5,dynamic_7}
  5122        %constinteger %c
     C          KATTRIB=26    {readonly_0,writeonly_1,volatile_2},
     C          KTYPE=27      {short_3,half_6,byte_9,mite_12,boolean_15,char_18,text_25},
     C          KEYINTEGER=28 {integer},
     C          KEYLONG=29    {long},
     C          KEYREAL=30    {real},
     C          KEYSTRING=31  {string_0,cstring_1}
  5129        %constinteger %c
     C          KEYRECORD=32  {record},
     C          KEYNAME=33    {name},
     C          KEYFORMAT=34  {format},
     C          FNMAP=35      {fn_0,function_0,map_1},
     C          RPRED=36      {routine_0,predicate_1},
     C          KEYSPEC=37    {spec}
  5136        %constinteger %c
     C          KEYARRAY=38   {array},
     C          KEYSWITCH=39  {switch},
     C          KEYOF=40      {of},
     C          KEYFILE=41    {file},
     C          KEYPROGRAM=42 {program},
     C          KEYLIST=43    {list}
  5143        %constinteger %c
     C          KEYCONTROL=44 {control},
     C          KEYCOMMENT=45 {comment},
     C          KEYEVENT=46   {event},
     C          KEYINCLUDE=47 {include},
     C          KEYOPTION=48  {option},
     C          KEYALIAS=49   {alias}
  5150        %constinteger %c
     C          KEYNOT=50     {not},
     C          KEYAND=72     {and},
     C          KEYOR=73      {or}
  5154        !!  end of keyword codes
  5155        !
  5156        !Symbol lexical codes other than operators:
  5157        %constinteger TERMINATOR=51, CONST=52, IDENT=53, MODSIGN=54,
     C                      COLON=59, COMMA=60, RIGHT=61, RIGHTB=62
  5159        {DUD=63}
  5160        %constinteger LEFT=55, LEFTB=56, ATSIGN=57, UNDERLINE=58
  5161        
  5162        %constinteger ARROW=74, EQEQ=75, NOTEQEQ=76,
     C                      EQUALS=77, NOTEQ=78, LESSEQ=79,
     C                      LESS=80, GREATEQ=81, GREATER=82
  5165        %constinteger PLUS=83, MINUS=84, EXCLAM=85, EXCLAM2=86, DOT=87
  5166        %constinteger STAR=88, SLASH2=89, SLASH=90, AMPERSAND=91
  5167        %constinteger STAR2=92, BACKSLASH=93, UPARROW=94,
     C                      BACKSLASH2=95, UPARROW2=96,
     C                      TILDE=97,
     C                      LSHIFT=98, RSHIFT=99
  5171        %constinteger ATOMMAX=99
  5172        %constinteger ALEFT=left, ARIGHT=right, RECSUB=underline,
     C                      OVER=slash2, SCONC=dot
  5174        
  5175        %constinteger SIMPLE=atommax+1, VSIMPLE=simple+1,
     C                      MAJOR=plus, SCOND=arrow, COND=keyand, CONDQ=71
  5177        !
  5178        %integer%fn NEXT ATOM
  5179        !Encode next atom from source file
  5180        ![Time-critical]
  5181        %switch s(0:255)
  5182        %constinteger TAB=9,
     C                      MAX10=maxint//10, MAXDIG=maxint-max10*10
  5184        %integer i,j,p,radix,hash
  5185        %real rval
  5186        %constbytearray map(0:127) =
  5187          0 ('0'),
     C          '0','1','2','3','4','5','6','7','8','9',
     C          0, 0, 0, 0, 0, 0, 0,
     C          'a','b','c','d','e','f','g','h','i','j','k','l','m',
     C          'n','o','p','q','r','s','t','u','v','w','x','y','z',
     C          0, 0, 0, 0, 0, 0,
     C          'a','b','c','d','e','f','g','h','i','j','k','l','m',
     C          'n','o','p','q','r','s','t','u','v','w','x','y','z',
     C          0, 0, 0, 0, 0
  5196        
  5197        !~!!!!!!!!!!!!!!!  Ex KEYGEN  !!!!!!!!!!!!!!!!!!!!
  5198        %CONSTSHORTINTEGERARRAY SYMINIT(97:122) =  %C
     C        2,15,31,72,79,102,133,137,141,1,1,156,169,183,190,205,
     C        1,220,257,297,309,319,327,1,1,1
  5201        
  5202        %CONSTBYTEINTEGERARRAY SYMBOL(1:340) =  %C
     C        128,114,114,97,121,166,108,105,97,115,177,110,100,200,101,103,
     C        105,110,133,121,116,101,155,111,111,108,101,97,110,155,111,110,
     C        116,105,110,117,101,134,121,99,108,101,149,104,97,114,155,115,
     C        116,114,105,110,103,159,109,109,101,110,116,173,115,116,97,110,
     C        116,151,151,114,111,108,172,121,110,97,109,105,99,153,110,100,
     C        129,108,115,101,132,120,105,116,134,118,101,110,116,174,116,101,
     C        114,110,97,108,153,105,110,105,115,104,131,97,108,115,101,136,
     C        111,114,109,97,116,162,110,163,117,110,99,116,105,111,110,163,
     C        146,108,101,169,111,116,111,139,97,108,102,155,102,143,110,116,
     C        101,103,101,114,156,99,108,117,100,101,175,97,98,101,108,150,
     C        111,110,103,157,105,115,116,171,111,110,105,116,111,114,141,105,
     C        116,101,155,97,112,163,97,109,101,161,111,116,178,110,142,119,
     C        110,152,102,168,112,116,105,111,110,176,114,201,114,101,100,105,
     C        99,97,116,101,164,111,103,114,97,109,170,101,112,101,97,116,
     C        130,111,117,116,105,110,101,164,116,117,114,110,135,115,117,108,
     C        116,137,97,100,111,110,108,121,154,99,111,114,100,160,108,158,
     C        116,111,112,138,105,103,110,97,108,140,121,115,116,101,109,153,
     C        104,111,114,116,155,112,101,99,165,119,105,116,99,104,167,97,
     C        114,116,148,114,105,110,103,159,114,117,101,136,104,101,110,147,
     C        101,120,116,155,110,108,101,115,115,143,116,105,108,145,111,108,
     C        97,116,105,108,101,154,104,105,108,101,144,114,105,116,101,111,
     C        110,108,121,154
  5225        
  5226        %CONSTBYTEINTEGERARRAY ALTDISP(1:340) =  %C
     C        0,5,0,0,0,0,5,0,0,0,0,0,0,0,5,0,
     C        0,0,0,4,0,0,9,0,0,0,0,0,0,15,8,23,
     C        28,34,0,0,0,0,5,0,0,0,0,4,0,0,18,0,
     C        0,0,0,0,0,1,0,0,0,0,0,0,0,0,4,0,
     C        0,0,0,0,0,0,0,0,0,0,0,0,0,7,3,0,
     C        0,4,0,0,0,4,8,0,1,0,0,0,0,0,0,0,
     C        0,0,0,0,6,6,27,0,0,0,0,5,0,0,0,0,
     C        6,0,14,0,0,0,2,0,0,0,0,0,0,0,0,0,
     C        0,0,0,0,0,0,0,0,0,0,0,6,2,0,0,6,
     C        0,0,0,0,0,0,0,0,0,0,0,5,0,0,0,0,
     C        4,0,0,0,0,0,0,0,7,0,0,0,0,0,0,4,
     C        0,0,12,0,0,1,4,0,0,0,0,0,0,2,0,3,
     C        0,0,2,0,6,0,0,0,0,0,0,0,0,8,0,0,
     C        0,0,0,0,1,0,0,0,0,0,0,6,12,0,0,0,
     C        0,0,0,0,0,0,0,0,5,0,0,0,0,5,0,0,
     C        0,0,7,11,0,0,0,0,0,0,0,0,0,0,0,0,
     C        4,30,0,0,6,0,0,0,0,0,6,0,0,0,0,5,
     C        5,0,0,0,3,4,0,0,0,0,0,0,0,0,0,4,
     C        0,0,0,0,0,0,0,0,4,0,0,1,4,0,0,0,
     C        0,0,0,25,0,5,0,0,0,1,0,0,0,1,0,0,
     C        0,0,0,0,0,2,5,0,0,0,0,0,0,0,0,0,
     C        0,0,0,1
  5249        
  5250        
  5251        !! end of generated tables
  5252        
  5253        %routine GET SYM
  5254          %cycle
  5255            sym = byteintegeR(fp);  fp = fp+1
  5256          %repeat %until sym # ' '
  5257          i = sym-'0'
  5258          %if i >= 10 %start
  5259            i = sym!casebit-'a';  i = i+10 %if i >= 0
  5260          %finish
  5261        %end
  5262        
  5263          matched = 0
  5264        again: s(tab):
  5265          read line(0) %if sym = nl
  5266        again1:
  5267          %cycle
  5268            sym = byteintegeR(fp);  fp = fp+1
  5269          %repeat %until sym # ' '
  5270          atomp = fp;     !(actually one after)
  5271          atoms = atoms+1
  5272          -> s(sym)
  5273        linebreak: s(nl):
  5274          %result = terminator %if atom # comma
  5275        continuation:
  5276          read line('+')
  5277          -> again1
  5278        
  5279        s('{'):
  5280          comments = comments+1
  5281          %cycle
  5282            sym = byteintegeR(fp);  fp = fp+1
  5283            -> linebreak %if sym = nl
  5284          %repeat %until sym = '}'
  5285          -> again
  5286        
  5287        s('+'): %result = plus
  5288        s('-'): fp = fp+1 %and %result = arrow %if byteintegeR(fp) = '>'
  5289                -> continuation %if byteintegeR(fp) = nl
  5290                %result = minus
  5291        s('*'): %result = star
  5292        s('/'): fp = fp+1 %and %result = slash2 %if byteintegeR(fp) = '/'
  5293                %result = slash
  5294        s('\'): fp = fp+1 %and %result = backslash2 %if byteintegeR(fp) = '\'
  5295                fp = fp+1 %and %result = noteq %if byteinteger(fp) = '='
  5296                %result = backslash
  5297        s('^'): fp = fp+1 %and %result = uparrow2 %if byteintegeR(fp) = '^'
  5298                %result = uparrow
  5299        s('~'): %result = tilde
  5300        s('!'): fp = fp+1 %and %result = exclam2 %if byteintegeR(fp) = '!'
  5301                %result = exclam
  5302        s('&'): %result = ampersand
  5303        s('.'): rval = 0 %and -> fraction %if '0' <= byteinteger(fp) <= '9'
  5304                %result = dot
  5305        s('='): fp = fp+1 %and %result = eqeq %if byteintegeR(fp) = '='
  5306                %result = equals
  5307        s('#'): fp = fp+1 %and %result = noteqeq %if byteintegeR(fp) = '#'
  5308                %result = noteq
  5309        s('<'): fp = fp+1 %and %result = lesseq %if byteintegeR(fp) = '='
  5310                fp = fp+1 %and %result = noteq %if byteintegeR(fp) = '>'
  5311                fp = fp+1 %and %result = lshift %if byteintegeR(fp) = '<'
  5312                %result = less
  5313        s('>'): fp = fp+1 %and %result = greateq %if byteintegeR(fp) = '='
  5314                fp = fp+1 %and %result = rshift %if byteintegeR(fp) = '>'
  5315                %result = greater
  5316        s('_'): %result = underline
  5317        s(':'): %result = colon
  5318        s(','): %result = comma
  5319        s(';'): %result = terminator
  5320        s('('): %result = left
  5321        s('['): %result = leftb
  5322        s(')'): %result = right
  5323        s(']'): %result = rightb
  5324        s('|'): %result = modsign
  5325        s('@'): %result = atsign
  5326        
  5327        s('M'): s('m'):
  5328          fp = fp+1 %and -> charconst %if byteintegeR(fp) = ''''
  5329        s('A'):s('B'):s('C'):s('D'):s('E'):s('F'):s('G'):s('H'):
  5330        s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'):
  5331        s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'):
  5332        s('Y'):s('Z'):s('a'):s('b'):s('c'):s('d'):s('e'):s('f'):
  5333        s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'):
  5334        s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'):
  5335        s('w'):s('x'):s('y'):s('z'):
  5336          -> keyword %if percent # 0
  5337          newlen = charlim+1;  hash = sym!casebit;  !lower-case (if letter)
  5338          byteinteger(newlen) = hash
  5339          %cycle
  5340            sym = byteintegeR(fp);  fp = fp+1
  5341          %repeat %until sym # ' '
  5342          %if sym = '''' %start;  !damned IBM-style literals
  5343            radix = 16 %and ->ibm %if hash = 'x'
  5344            radix = 8 %and ->ibm %if hash = 'k'
  5345            radix = 2 %and ->ibm %if hash = 'b'
  5346          %finish
  5347          sym = map(sym)
  5348          %if sym # 0 %start
  5349            %cycle
  5350              newlen = newlen+1;  byteinteger(newlen) = sym
  5351              hash = hash<<1!!sym
  5352              %cycle
  5353                sym = byteintegeR(fp);  fp = fp+1
  5354              %repeat %until sym # ' '
  5355              sym = map(sym)
  5356            %repeat %until sym = 0
  5357          %finish
  5358          fp = fp-1
  5359          newlen = newlen-charlim;  byteinteger(charlim) = newlen
  5360          %if subbed # 0 %then head == dformat_link %c
     C          %else head == hashindex(hash&255)
  5362          item = head
  5363          %if item # 0 %start
  5364            %cycle
  5365              ditem == dict(imod(item))
  5366              %exit %if string(ditem_text+char0) = string(charlim) %c
     C                    %and (item > a7 %or item < 0 %or control&lowbit # 0)
  5368              item = ditem_hlink
  5369            %repeat %until item = 0
  5370          %finish
  5371          identatoms = identatoms+1
  5372          %result = ident
  5373        
  5374        s('%'):
  5375          sym = byteintegeR(fp)
  5376          -> again %unless 'a' <= sym!casebit <= 'z'
  5377          fp = fp+1
  5378        keyword:
  5379          percent = 0
  5380          p = syminit(sym!casebit)
  5381          %cycle
  5382        !     %cycle
  5383        !       sym = byteintegeR(fp)!casebit
  5384        !       %exit %if symbol(p) # sym
  5385            %while symbol(p) = byteintegeR(fp)!casebit %cycle
  5386              p = p+1;  fp = fp+1
  5387            %repeat
  5388            %exit %if symbol(p) > 127
  5389            atom = altdisp(p)
  5390            %if atom = 0 %start
  5391              %result = dud %unless sym!casebit = 'c' %and byteintegeR(fp) = nl
  5392              ->continuation
  5393            %finish
  5394            p = p+atom
  5395          %repeat
  5396          percent = 1 %if 'a' <= byteintegeR(fp)!casebit <= 'z'
  5397          subatom = altdisp(p)
  5398          atom = symbol(p)-128
  5399          %result = dud %if atom = 0
  5400          %result = atom
  5401        
  5402        ibm:
  5403          nonstandard(20)
  5404          item = -1;  value = 0
  5405          -> ibm1
  5406        s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'):
  5407          item = 0;  type = inttype
  5408          radix = 10;  value = sym-'0'
  5409        ibm1:
  5410          %cycle
  5411            %cycle
  5412              %cycle
  5413                sym = byteintegeR(fp);  fp = fp+1
  5414              %repeat %until sym # ' '
  5415              i = sym-'0'
  5416              %if radix = 10 %start
  5417                %exit %if i < 0 %or i >= 10
  5418                fault(rangerr+point+warn) %if value > max10 %or (value=max10 %and i > maxdig)
  5419                value = (value<<2+value)<<1+i
  5420              %else
  5421                i = sym!casebit-'a'+10 %if i >= 10
  5422                %exit %if i < 0 %or i >= radix
  5423                j = radix
  5424                %cycle
  5425                  i = i+value %if j&1 # 0
  5426                  value = value<<1;  j = j>>1
  5427                %repeat %until j = 0
  5428                value = i
  5429              %finish
  5430            %repeat
  5431            %exit %unless sym = '_'
  5432            radix = value
  5433            %result = dud %if radix = 0
  5434            value = 0
  5435          %repeat
  5436          %if item < 0 %start;  !IBM-style
  5437            %result = dud %if sym # ''''
  5438            item = 0
  5439          %else
  5440            j = 0
  5441            %if sym = '.' %start
  5442              rval = value %if type = inttype
  5443        fraction:
  5444              j = 0
  5445              type = realtype
  5446              %cycle
  5447                get sym
  5448                %exit %unless 0 <= i < radix
  5449                rval = rval*radix+i;  j = j-1
  5450              %repeat
  5451              %result = dud %if j = 0
  5452            %finish
  5453            %if sym = '@' %start
  5454              type = realtype %and rval = value %if type = inttype
  5455              get sym
  5456              value = 0
  5457              %if sym = '+' %then get sym %c
     C              %else %if sym = '-' %then value = 1 %and get sym
  5459              %result = dud %unless 0 <= i < radix
  5460              p = 0
  5461              %cycle
  5462                p = p*radix+i
  5463                get sym
  5464              %repeat %until %not 0 <= i < radix
  5465              p = -p %if value # 0
  5466              j = j+p
  5467            %finish
  5468            %if type = realtype %start
  5469              rval = rval*radix^j %if j # 0

*    Failed to analyse line  5469
     RVAL=RVAL*RADIX^J %IF J#0
                     !

*    Failed to analyse line  5469
     RVAL=RVAL*RADIX^J %IF J#0
                     !
  5470              value = integer(addr(rval)) %if type = realtype
  5471            %finish
  5472            fp = fp-1;  sym = 0
  5473          %finish
  5474          litatoms = litatoms+1
  5475          %result = const
  5476        
  5477        s(''''):
  5478        charconst:
  5479          item = 0;  type = inttype
  5480          value = 0
  5481          %cycle
  5482            sym = byteintegeR(fp);  fp = fp+1
  5483            %result = dud %if sym = nl;  !?allow
  5484            %if sym = '''' %start
  5485              %exit %unless byteintegeR(fp) = ''''
  5486              fp = fp+1
  5487            %finish
  5488            value = value<<8+sym
  5489          %repeat
  5490          %result = const %if value # 0
  5491          %result = dud
  5492        
  5493        s('"'):
  5494          item = 0
  5495          value = cad;  type = stringtype
  5496          i = line;  j = linestart;  p = 0
  5497          %cycle
  5498            sym = byteintegeR(fp);  fp = fp+1
  5499            %if sym = '"' %start
  5500              %exit %if byteintegeR(fp) # '"'
  5501              fp = fp+1
  5502            %finish
  5503            p = p+1
  5504            %if p > 255 %start
  5505              sym = 0
  5506              fp = atomp;  linestart = j
  5507              %result = dud
  5508            %finish
  5509            final(value+p) = sym
  5510            read line('"') %if sym = nl
  5511          %repeat
  5512          %if p # 0 %start;  !not empty string
  5513            final(value) = p
  5514            cad = cad+(p+1)
  5515          %finish %else value = 0
  5516          litatoms = litatoms+1
  5517          %result = const
  5518        
  5519        s(*):
  5520          %result = dud
  5521        %end;  !NEXT ATOM
  5522        
  5523        !<<BOTH
  5524        
  5525        %integerfn A (%integer k)
  5526        !Basic atom-testing predicate
  5527          atom = next atom %if matched # 0
  5528          %result = FALSE %if k # atom
  5529          matched = 1
  5530          %result = TRUE
  5531        %end
  5532        
  5533        %routine GET(%integer k)
  5534          atom = next atom %if matched # 0
  5535          matched = 1
  5536          %return %if atom = k
  5537          syntax error { %if atom = dud
  5538        !  faultp = atomp
  5539        !  report(formerr+point,-k,0)
  5540        !  %signal fail
  5541        %end
  5542        
  5543        !<<IMP
  5544        
  5545        %routine ALLOW(%integer k)
  5546          %if a(k) %start

*    Failed to analyse line  5546
      %IF A(K) %START
                !

*    Failed to analyse line  5546
      %IF A(K) %START
                !
  5547          %finish

* 5547   FAULT 51 %FINISH is not required

* 5547   FAULT 51 %FINISH is not required
  5548        %end
  5549        
  5550        %routine GET LITSTRING
  5551        %integer holditem
  5552        !Must be quoted string (for %alias and %include)
  5553          holditem = item;  !preserve
  5554          get(const)
  5555          error(typerr+point) %unless type = stringtype
  5556          cad = value;  !reset
  5557          item = holditem;  !restore
  5558        %end
  5559        
  5560        !<<BOTH
  5561        
  5562        %integer%fn IDTEXT(%integer f)
  5563        %integer k
  5564          %result = ditem_text %if item > 0 %and f&ext = 0;  !already exists
  5565          charlim = charlim+newlen+1
  5566          croak("Identifier space exhausted") %if charlim+80 >= charmin
  5567          k = charlim-newlen-1-char0
  5568          %if f&ext # 0 %and a(keyalias) %start

*    Failed to analyse line  5568
      %IF F&EXT#0 %AND A(KEYALIAS) %START
                                    !

*    Failed to analyse line  5568
      %IF F&EXT#0 %AND A(KEYALIAS) %START
                                    !
  5569            get LITSTRING
  5570            string(charlim) = string(final0+value)
  5571            byteinteger(charlim) = byteinteger(charlim)+128
  5572            charlim = charlim+byteinteger(charlim)-127
  5573          %finish

* 5573   FAULT 51 %FINISH is not required

* 5573   FAULT 51 %FINISH is not required
  5574          %result = k
  5575        %end
  5576        
  5577        %record(objinfo)%map DETAILS(%integer f,t,m,v)
  5578        %ownrecord(objinfo) D=0
  5579          d_flags = f;  d_type = t
  5580          d_mode = m;  d_val = v
  5581          %result == d
  5582        %end
  5583        
  5584        %routine DECLARE(%record(objinfo)%name d)
  5585        %integer i
  5586        %record(identinfo)%name dp
  5587          dp == dict(dlim)
  5588          %if speccing = 0 %start;  !not within spec params
  5589            %if item >= c_localdpos %start;  !there already
  5590              %if d_flags&spec = 0 %and ditem_flags&spec # 0 %start
  5591                !body after spec (proc,label,typeid)
  5592                %if d_flags&(ext+proc+typeid) = ditem_flags&(ext+proc+typeid) %start
  5593                  i = item
  5594                  %if d_flags&ext # 0 %start
  5595                    ![can't allow %ext%spec, then use, then %ext object]
  5596                    ->ok %if ditem_flags&rflag # 0;  ![so create new entry]
  5597                    ditem_mode = d_mode;  ditem_val = d_val
  5598                    %if a(keyalias) %start

*    Failed to analyse line  5598
      %IF A(KEYALIAS) %START
                       !

*    Failed to analyse line  5598
      %IF A(KEYALIAS) %START
                       !
  5599                      get LITSTRING;  !ignore [should be identical]
  5600                      item = i
  5601                    %finish
  5602                  %finish
  5603                  %if d_flags&proc = 0 %start
  5604                    ditem_flags = ditem_flags&(\(spec+indirect))
  5605                  %finish
  5606                  %return
  5607                %finish
  5608                %if ditem_flags&(ext+proc) = proc1 %and d_flags&ext # 0 %c
     C                    %and d_flags&proc # 0 %start;  !(internal) %spec then %ext
  5610                  ditem_flags = ditem_flags-proc1+(d_flags&(ext+proc))
  5611                  ditem_text = idtext(ext);  !in case alias
  5612                  %return
  5613                %finish
  5614              %finish
  5615        !<<IMP
  5616              %if item < inclim %and ditem_flags&(rflag+wflag) = 0 %c
     C              %then fault(duperr+warn+point) %else fault(duperr+point)
  5618        !<<BOTH
  5619            %finish
  5620        ok: dp_hlink = head;  head = dlim;  !insert in list
  5621            dp_text = idtext(d_flags)
  5622          %finish %else dp_hlink = 0 %and dp_text = 0

* 5622   FAULT 51 %FINISH is not required

* 5622   FAULT 51 %FINISH is not required
  5623          item = dlim;  ditem == dp
  5624          ditem_details = d
  5625          dlim = dlim+1
  5626          %if dlim >= dmin %start
  5627        {?}    show dict(0) %if control&logbit # 0
  5628            croak("Too many identifiers")
  5629          %finish
  5630        %end;  !DECLARE
  5631        
  5632        %routine DECLARE ANON(%record(objinfo)%name d)
  5633          speccing = speccing+1
  5634          item = 0
  5635          declare(d)
  5636          speccing = speccing-1
  5637        %end
  5638        !
  5639        %routine DECLARE TEMP(%integer t)
  5640          c_val = c_val+4;  c_temps = c_temps+4
  5641          declare anon(details(okflag+writable+readable,t,c_mode,c_sp-c_val))
  5642        %end
  5643        !
  5644        %routine DECLARE RANGE(%integer type,lower,upper)
  5645        !Type ident just declared
  5646        %integer s
  5647        %integerfn OK(%integer l,u)
  5648          %result = TRUE %if (l <= lower %and upper <= u) {signed} %c
     C                %or (0 <= lower %and upper <= u-l) {unsigned}
  5650          %result = FALSE
  5651        %end
  5652          s = 4
  5653          %if ok(-32768,32767) %start

*    Failed to analyse line  5653
      %IF OK(-32768,32767) %START
                            !

*    Failed to analyse line  5653
      %IF OK(-32768,32767) %START
                            !
  5654            s = 2;  s = 1 %if ok(-128,127)

*    Failed to analyse line  5654
     S=1 %IF OK(-128,127)
                        !

*    Failed to analyse line  5654
     S=1 %IF OK(-128,127)
                        !
  5655          %finish

* 5655   FAULT 51 %FINISH is not required

* 5655   FAULT 51 %FINISH is not required
  5656          ditem_details = details(typeid,type,absmode,sign)
  5657          ditem_size = s
  5658          declare anon(details(okflag,type,litmode,lower))
  5659          declare anon(details(okflag,type,litmode,upper))
  5660          ditem_hlink = ranges;  ranges = item
  5661          item = item-2
  5662        %end
  5663        
  5664        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5665        !!!!!!!!!!!!!!!!!!!!  Expressions  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5666        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5667        
  5668        %owninteger LITERAL=0, JAMMY=0
  5669        
  5670        %routine%spec GET EXPRESSION(%integer rank,etype)
  5671        !
  5672        %integerfn VALOK(%integer wanted,t)
  5673        %integer lo,hi,l,h,wc,tc
  5674        %record(identinfo)%name wp,tp
  5675          %result = TRUE %if wanted = t # recstar
  5676          wp == typecell(wanted);  tp == typecell(t)
  5677          wc = wp_flags&(packed+cat);  tc = tp_flags&(packed+cat)
  5678          %if wc = tc %start;  !same class
  5679            %if wc&nonord = 0 %start;  !ordinal wanted
  5680              %if wp_type = tp_type %start;  !same base-type
  5681                %result = TRUE %if wp_type = wanted;  !base-type (rather than subrange)
  5682                %if dict(wanted+1)_mode # litmode %then get bounds(dict(wanted+1)_type,lo,hi) %c
     C                %else lo = dict(wanted+1)_val
  5684                %if dict(wanted+2)_mode # litmode %then get bounds(dict(wanted+2)_type,hi,hi) %c
     C                %else hi = dict(wanted+2)_val
  5686                %if item = 0 %start;  !literal
  5687                  %result = TRUE %if lo <= value <= hi
  5688                  jammy = jammy!!1
  5689                %else
  5690                  jammy = jammy!!1 %and %result = TRUE %if tp_type = t
  5691                  %if dict(t+1)_mode # litmode %then get bounds(dict(t+1)_type,l,h) %c
     C                  %else l = dict(t+1)_val
  5693                  %if dict(t+2)_mode # litmode %then get bounds(dict(t+2)_type,h,h) %c
     C                  %else h = dict(t+2)_val
  5695                  %if l >= lo %start
  5696                    %result = TRUE %if h <= hi
  5697                    jammy = jammy!!1
  5698                    %result = TRUE %if l <= hi
  5699                  %else
  5700                    jammy = jammy!!1
  5701                    %result = TRUE %if h >= lo
  5702                  %finish
  5703                %finish
  5704                expfault(rangerr) %if jammy # 0
  5705                %result = TRUE
  5706              %finish
  5707            %finish %else %if wc = realy %start
  5708              %result = TRUE
  5709            %finish %else %if wc = stringy %start;  !string wanted
  5710              %result = TRUE %if wanted = stringstar
  5711              %if item = 0 %start
  5712                %result = TRUE %if value = 0;  !empty string
  5713                l = final(value)+1
  5714              %else
  5715                l = imod(tp_size)
  5716                l = 256 %if l = 0
  5717              %finish
  5718              %if l > imod(wp_size) # 0 %start
  5719                jammy = jammy!!1
  5720                expfault(rangerr) %if item = 0 %and jammy # 0
  5721              %finish
  5722              %result = TRUE
  5723        !<<IMP
  5724            %finish %else %if wc&cat = arry %start
  5725              %result = TRUE %if wp_type = tp_type %and valok(wp_xtype,tp_xtype)

*    Failed to analyse line  5725
      %RESULT =TRUE %IF WP_TYPE=TP_TYPE %AND VALOK(WP_XTYPE,TP_XTYPE)
                                                              !

*    Failed to analyse line  5725
      %RESULT =TRUE %IF WP_TYPE=TP_TYPE %AND VALOK(WP_XTYPE,TP_XTYPE)
                                                              !
  5726        !<<BOTH
  5727            %else;                          !record etc
  5728              %if wanted = recstar %start
  5729                %result = TRUE %if t # recstar
  5730              %else
  5731                %result = TRUE %if t = recstar %or item!value = 0
  5732              %finish
  5733            %finish
  5734          %else;                            !category difference
  5735            %if tc = inty %start
  5736              %result = TRUE %if wc = recy %and item!value = 0;  !RECORD = 0
  5737              toreal %and %result = TRUE %if wc = realy;         !REAL   = INT
  5738            %finish %else %if wc = stringy %and t = chartype %start;   !STRING = CHAR
  5739              %if item = 0 %start;           !null string
  5740                final(cad) = 1;  final(cad+1) = value
  5741                value = cad;  cad = cad+2
  5742                type = stringtype
  5743              %finish %else putexp(dtostring,normitem,0,string1)
  5744              %result = TRUE
  5745        !<<IMP
  5746        ! sets again
  5747        !<<BOTH
  5748            %finish
  5749          %finish
  5750          %result = FALSE
  5751        %end
  5752        !
  5753        %routine GET VALUE(%integer valtype)
  5754          get EXPRESSION(major,valtype)
  5755        %end;  !GET VALUE
  5756        !
  5757        %routine GET LITERAL(%integer t)
  5758          literal = literal+1
  5759          get EXPRESSION(major,t)
  5760          literal = literal-1
  5761        %end
  5762        !
  5763        !!!!!!!!!!!!!!!!!!!!!!  Machine-code  !!!!!!!!!!!!!!!!!!!!!!!!!!
  5764        !
  5765        %routine GET MIDENT(%integer min,max)
  5766          get(ident)
  5767          %if item <= 0 %start
  5768            name error %if string(charlim) # "sp"
  5769            item = a7
  5770            ditem == dict(item)
  5771          %finish
  5772          %if ditem_mode = litmode %start
  5773            value = ditem_val;  item = 0
  5774          %finish
  5775          syntax error %unless min <= item <= max
  5776        %end
  5777        
  5778        %routine GET REGSET
  5779        %integer hold,set=0

*    Failed to analyse line  5779
      %INTEGER HOLD,SET=0
                       !

*    Failed to analyse line  5779
      %INTEGER HOLD,SET=0
                       !
  5780          %cycle
  5781            get mident(d0,a7)
  5782            hold = item
  5783            get mident(hold,a7) %if a(minus)

*    Failed to analyse line  5783
     GETMIDENT(HOLD,A7) %IF A(MINUS)
                                   !

*    Failed to analyse line  5783
     GETMIDENT(HOLD,A7) %IF A(MINUS)
                                   !
  5784            %cycle
  5785              set = set!1<<(hold-d0)
  5786              hold = hold+1
  5787            %repeat %until hold > item
  5788          %repeat %until %not a(slash)

*    Failed to analyse line  5788
      %REPEATUNTILNOT A(SLASH)
                             !

*    Failed to analyse line  5788
      %REPEATUNTILNOT A(SLASH)
                             !
  5789          item = 0;  value = set
  5790        %end
  5791        
  5792        %routine get MCODE
  5793        %integer op,x,y,types
  5794        
  5795        %integer%fn OPSIZE(%integer okbyte)
  5796          %result = 0 %unless a(dot)

*    Failed to analyse line  5796
      %RESULT =0 %UNLESS A(DOT)
                              !

*    Failed to analyse line  5796
      %RESULT =0 %UNLESS A(DOT)
                              !
  5797          sym = byteinteger(fp)&(\casebit);  fp = fp+1
  5798          %result = 4 %if sym = 'L'
  5799          %result = 2 %if sym = 'W'
  5800          %result = 1 %if sym = okbyte
  5801          syntax error
  5802        %end
  5803        
  5804        %routine get MOP(%integer t,dummy,%record(identinfo)%name dp)
  5805        !Get Mcode operand
  5806        %constinteger HASHSIGN=noteq
  5807        %integer sign,hold,holdval,m
  5808          %if a(hashsign) %start

*    Failed to analyse line  5808
      %IF A(HASHSIGN) %START
                       !

*    Failed to analyse line  5808
      %IF A(HASHSIGN) %START
                       !
  5809            get LITERAL(inttype)
  5810            %return
  5811          %finish

* 5811   FAULT 51 %FINISH is not required

* 5811   FAULT 51 %FINISH is not required
  5812          sign = 0;  hold = -1;  holdval = 0
  5813          sign = 1 %if a(minus)

*    Failed to analyse line  5813
     SIGN=1 %IF A(MINUS)
                       !

*    Failed to analyse line  5813
     SIGN=1 %IF A(MINUS)
                       !
  5814          %if a(ident) %start

*    Failed to analyse line  5814
      %IF A(IDENT) %START
                    !

*    Failed to analyse line  5814
      %IF A(IDENT) %START
                    !
  5815            matched = 0
  5816            get mident(0,dlim)
  5817            hold = item
  5818            %if hold # 0 %start
  5819              syntax error %if sign # 0
  5820              %if item > a7 %start
  5821                dp_flags = ditem_flags
  5822                dp_mode = ditem_mode;  dp_val = ditem_val
  5823                %while a(recsub) %cycle

*    Failed to analyse line  5823
      %WHILE A(RECSUB) %CYCLE
                        !

*    Failed to analyse line  5823
      %WHILE A(RECSUB) %CYCLE
                        !
  5824                  dformat == typecell(ditem_type)
  5825                  syntax error %unless dformat_flags&cat = recy %c
     C                               %and ditem_flags&(name+indirect) = 0
  5827                  subbed = 1;  get(ident);  subbed = 0
  5828                  error(namerr+point) %if item <= 0
  5829                  dp_flags = ditem_flags;  dp_type = ditem_type
  5830                  dp_val = dp_val+ditem_val
  5831                  item = dummy;  ditem == dp
  5832                %repeat

* 5832   FAULT 52 %REPEAT instead of %FINISH for %START at line  5820

* 5832   FAULT 52 %REPEAT instead of %FINISH for %START at line  5820
  5833                %return
  5834              %finish
  5835              %if op&255 = movem %and item > 0 %start
  5836                matched = 0
  5837                get regset
  5838              %finish
  5839              %return
  5840            %finish

* 5840   FAULT 51 %FINISH is not required

* 5840   FAULT 51 %FINISH is not required
  5841            holdval = value
  5842          %finish %else %if a(const) %start

* 5842   FAULT 51 %FINISH is not required

* 5842   FAULT 51 %FINISH is not required

*    Failed to analyse line  5842
      %FINISHELSEIF A(CONST) %START
                              !

*    Failed to analyse line  5842
      %FINISHELSEIF A(CONST) %START
                              !
  5843            hold = 0;  holdval = value
  5844          %finish

* 5844   FAULT 51 %FINISH is not required

* 5844   FAULT 51 %FINISH is not required
  5845          holdval = -holdval %if sign # 0
  5846          %if a(left) %start

*    Failed to analyse line  5846
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  5846
      %IF A(LEFT) %START
                   !
  5847            get mident(a0,a7)
  5848            %if hold < 0 %start
  5849              get(right)
  5850              %if sign # 0 %then item = item+pre %c
     C              %else %unless a(plus) %then item = item+indir %c
     C              %else item = item+post

*    Failed to analyse line  5852
      %IF SIGN#0 %THEN ITEM=ITEM+PRE %ELSEUNLESS A(PLUS) %THEN ITEM=ITEM+INDIR %ELSE ITEM=ITEM+POST
                                !

*    Failed to analyse line  5852
      %IF SIGN#0 %THEN ITEM=ITEM+PRE %ELSEUNLESS A(PLUS) %THEN ITEM=ITEM+INDIR %ELSE ITEM=ITEM+POST
                                !
  5853              %return
  5854            %finish
  5855            m = item+(dispmode-a0)
  5856            %if a(comma) %start

*    Failed to analyse line  5856
      %IF A(COMMA) %START
                    !

*    Failed to analyse line  5856
      %IF A(COMMA) %START
                    !
  5857              get mident(d0,a7)
  5858              fault(rangerr) %unless 0 = is mite(holdval)
  5859              m = m+(indexmode-dispmode)
  5860              holdval = (item-d0)<<12+holdval&255
  5861              holdval = holdval+16_0800 %if opsize(0) # 2
  5862            %finish

* 5862   FAULT 51 %FINISH is not required

* 5862   FAULT 51 %FINISH is not required
  5863            get(right)
  5864          %else

* 5864   FAULT 51 %FINISH is not required

* 5864   FAULT 51 %FINISH is not required
  5865            syntax error %if hold < 0
  5866            m = absmode
  5867          %finish
  5868          dp_mode = m;  dp_val = holdval
  5869          item = dummy
  5870        %end
  5871        
  5872        %constinteger temp=((('t'&31)<<5+('e'&31))<<5+('m'&31))<<5+('p'&31)
  5873          update sp
  5874        !Pack mnemonic
  5875          atomp = fp+1
  5876          x = 0
  5877          %cycle
  5878            sym = byteinteger(fp);  fp = fp+1
  5879            %exit %unless 'A' <= sym&(\casebit) <= 'Z'
  5880            sym = sym&31
  5881            x = x<<5+sym
  5882          %repeat
  5883          fp = fp-1;  sym = 0
  5884          syntax error %if x = 0
  5885          %if x = temp %start;       !*TEMP ...
  5886            value = 0
  5887            matched = 0 %and get regset %if a(ident)

*    Failed to analyse line  5887
     MATCHED=0 %AND GETREGSET %IF A(IDENT)
                                         !

*    Failed to analyse line  5887
     MATCHED=0 %AND GETREGSET %IF A(IDENT)
                                         !
  5888            c_free = value
  5889            %return
  5890          %finish
  5891          x = x<<5 %until x&(31<<25) # 0
  5892          x = x!16_C0000000
  5893          find op(x,op,types)
  5894          op = op+opsize('B')<<8 %if types&(sized!asized) # 0
  5895          x = 0;  y = 0
  5896          %if types>>6&63 # 0 %start
  5897            get MOP(types>>6&63,lablim,dtemp)
  5898            x = normitem
  5899            get(comma) %if types&63 # 0
  5900          %finish
  5901          %if types&63 # 0 %start
  5902            get MOP(types&63,lablim+1,dtemp2)
  5903            y = normitem
  5904          %finish
  5905          plant(op,x,y)
  5906          forget regs;  c_access = -1
  5907        %end;  !get MCODE
  5908        
  5909        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  5910        
  5911        %integerfn REFOK(%integer wanted,t)
  5912        %record(identinfo)%name wp,tp
  5913          %result = TRUE %if t = wanted %or wanted = 0 %or t = 0 %or item!value = 0
  5914          wp == typecell(wanted);  tp == typecell(t)
  5915          %if (wp_flags!!tp_flags)&(name+packed+cat) = 0 %start
  5916            %if wp_flags&cat = arry %start
  5917              !**check index compatible
  5918              %result = TRUE %if refok(wp_type,tp_type)

*    Failed to analyse line  5918
      %RESULT =TRUE %IF REFOK(WP_TYPE,TP_TYPE)
                                             !

*    Failed to analyse line  5918
      %RESULT =TRUE %IF REFOK(WP_TYPE,TP_TYPE)
                                             !
  5919            %finish %else %if wp_flags&cat = stringy %start
  5920              %result = TRUE %if tp_size = 0 %or wp_size = 0
  5921        !<<IMP
  5922        !<<BOTH
  5923            %else
  5924              %result = TRUE %if t = recstar %or wanted = recstar
  5925            %finish
  5926          %finish
  5927          %result = FALSE
  5928        %end
  5929        
  5930        %routine TOREF
  5931          atomp=expp %and error(nonref+point) %if item <= 0 %or ditem_mode < dispmode
  5932          %if item >= dictlim %start
  5933        !    %if ditem_act = prel %and (ditem_y < 0 %or ditem_type = bytetype) %start
  5934        !      value = ditem_y
  5935        !      value = litref(litval(value)*imod(size(ditem_type))) %if ditem_type # bytetype
  5936        !      putexp(add,ditem_x+ad,value,ditem_type)
  5937        !      %return
  5938        !    %finish
  5939          %else
  5940            %if ditem_mode = absmode %and ditem_flags >= 0 %start
  5941              item = 0;  value = ditem_val
  5942              %return
  5943            %finish
  5944          %finish
  5945          item = item+ad
  5946        %end
  5947        !
  5948        %routine COPY DOWN(%integer np1)
  5949          %while np > np1 %cycle
  5950            np = np-1;  explo = explo-1
  5951            dict(explo) = dict(np)
  5952          %repeat
  5953        %end
  5954        
  5955        %routine GET REFERENCE(%integer reftype)
  5956          get EXPRESSION(simple,reftype!sign16)
  5957        %end
  5958        !
  5959        %routine GET PARLIST(%integer special)
  5960        %integer procnp,pact,hold,count,headitem,arg,p,q,restype
  5961        %record(identinfo)%name hp,tp
  5962        %record(identinfo)%name darg
  5963        
  5964        %routine PUT ACTUAL
  5965          item = litref(value) %if item = 0
  5966          %if count&1 = 0 %then hold = item %c
     C          %else putact(pact,hold,item) %and pact = 0
  5968          count = count+1
  5969        %end
  5970        
  5971        %integerfn NO ALT
  5972          %if hp_flags&alt = 0 %start;  !no alternative
  5973            expfault(typerr)
  5974            %result = TRUE
  5975          %finish
  5976          item = hp_hlink
  5977          %cycle
  5978            report(internerr,0,6) %and %signal fail %if item <= 0
  5979            ditem == dict(item)
  5980            %exit %if string(ditem_text+char0) = string(hp_text+char0)
  5981            item = ditem_hlink
  5982          %repeat
  5983          headitem = item;  pact = headitem;  hp == ditem
  5984          arg = hp_type;  darg == dict(arg);  restype = darg_type
  5985          %result = FALSE
  5986        %end
  5987        
  5988        %routine PUT BOUNDS(%integer ft,at)
  5989        ! FT is TYPE of formal, AT of actual array
  5990        %integer maxarg=arg

*    Failed to analyse line  5990
      %INTEGER MAXARG=ARG
                     !

*    Failed to analyse line  5990
      %INTEGER MAXARG=ARG
                     !
  5991        %record(identinfo)%name ftp,atp,fxp,axp
  5992        %cycle
  5993          ftp == typecell(ft);  atp == typecell(at)
  5994        !  %if ftp_flags&indirect # 0 %start;           !complete dope vector
  5995        !    ![now only for %string(*)%array%name]
  5996        !    intern(11) %unless ftp_type = stringstar
  5997        !    item = at
  5998        !    put actual
  5999        !    maxarg = ft %if ft > maxarg
  6000        !    %exit
  6001        !  %finish
  6002          %if ftp_flags&cat = stringy %start
  6003            %exit %if ftp_size # 0
  6004            %if atp_size # 0 %then item = litref(imod(atp_size)) %C
     C            %else item = at-1
  6006            put actual
  6007            maxarg = ft-1 %if ft-1 > maxarg
  6008            %exit
  6009          %finish
  6010          %if ftp_xtype >= arg %start;    !index type
  6011            fxp == typecell(ftp_xtype);  axp == typecell(atp_xtype)
  6012            %if dict(ftp_xtype+1)_mode # litmode %start;  !non-literal lower
  6013              item = atp_xtype+1
  6014              item = 0 %and value = dict(atp_xtype+1)_val %if dict(atp_xtype+1)_mode = litmode
  6015              put actual
  6016              maxarg = ftp_xtype+1 %if ftp_xtype >= maxarg
  6017            %finish
  6018            %if dict(ftp_xtype+2)_mode # litmode %start;  !non-literal upper
  6019              item = atp_xtype+2
  6020              item = 0 %and value = dict(atp_xtype+2)_val %if dict(atp_xtype+2)_mode = litmode
  6021              put actual
  6022              maxarg = ftp_xtype+2 %if ftp_xtype+1 >= maxarg
  6023            %finish
  6024          %finish
  6025          ft = ftp_type;  at = atp_type;        !element types
  6026        %repeat %until ft <= arg
  6027        arg = maxarg;  darg == dict(arg)
  6028        %end
  6029        
  6030          count = 0;  hold = 0
  6031          procnp = np
  6032          headitem = item;  pact = headitem;  hp == ditem
  6033          arg = hp_type;  darg == dict(arg);  restype = darg_type
  6034          %if a(left) %start

*    Failed to analyse line  6034
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  6034
      %IF A(LEFT) %START
                   !
  6035            %cycle
  6036              arg = darg_link
  6037              %if arg = 0 %start
  6038                error(toomany+point) %if special = 0
  6039                get REFERENCE(0)
  6040                value = item-ad;  !save extra item
  6041                %cycle
  6042                  %if type = realtype %start
  6043                    %exit %if restype = realtype;  !no coercion
  6044                  %else
  6045                    %exit %if valok(type,restype)

*    Failed to analyse line  6045
      %EXITIF VALOK(TYPE,RESTYPE)
                                !

*    Failed to analyse line  6045
      %EXITIF VALOK(TYPE,RESTYPE)
                                !
  6046                  %finish
  6047                %repeat %until no alt

*    Failed to analyse line  6047
      %REPEATUNTIL NOALT
                       !

*    Failed to analyse line  6047
      %REPEATUNTIL NOALT
                       !
  6048                special = 0
  6049              %else
  6050                darg == dict(arg)
  6051                %if darg_flags&proc # 0 %start
  6052                  get(ident)
  6053                  name error %if item <= 0
  6054                  fault(typerr+point) %if ditem_flags&proc = 0 %c
     C                                      %or %not parmatch(darg_type,ditem_type)

*    Failed to analyse line  6055
     FAULT(TYPERR+POINT) %IF DITEM_FLAGS&PROC=0 %ORNOT PARMATCH(DARG_TYPE,DITEM_TYPE)
                                              !

*    Failed to analyse line  6055
     FAULT(TYPERR+POINT) %IF DITEM_FLAGS&PROC=0 %ORNOT PARMATCH(DARG_TYPE,DITEM_TYPE)
                                              !
  6056                  fault(classerr+point) %if item > headitem %C
     C                                        %and ditem_mode = procmode {OK if param?}
  6058                  item = item+ad
  6059                  put actual
  6060                %finish %else %if darg_flags >= 0 %start
  6061                  jammy = 0
  6062                  get EXPRESSION(major,0)
  6063                  %cycle
  6064                    %exit %if valok(darg_type,type)

*    Failed to analyse line  6064
      %EXITIF VALOK(DARG_TYPE,TYPE)
                                  !

*    Failed to analyse line  6064
      %EXITIF VALOK(DARG_TYPE,TYPE)
                                  !
  6065                  %repeat %until no alt

*    Failed to analyse line  6065
      %REPEATUNTIL NOALT
                       !

*    Failed to analyse line  6065
      %REPEATUNTIL NOALT
                       !
  6066                  putexp(check,darg_type,item,darg_type) %if jammy # 0 %c
     C                                                %and control&capbit # 0 %c
     C                                                %and category(darg_type) < realy
  6069                  put actual
  6070                %else;  !name
  6071                  get REFERENCE(0)
  6072                  %cycle
  6073                    %exit %if refok(darg_type,type)

*    Failed to analyse line  6073
      %EXITIF REFOK(DARG_TYPE,TYPE)
                                  !

*    Failed to analyse line  6073
      %EXITIF REFOK(DARG_TYPE,TYPE)
                                  !
  6074                  %repeat %until no alt

*    Failed to analyse line  6074
      %REPEATUNTIL NOALT
                       !

*    Failed to analyse line  6074
      %REPEATUNTIL NOALT
                       !
  6075                  put actual
  6076                  tp == typecell(darg_type)
  6077                  %if tp_flags&cat = arry %c
     C                  %and dict(arg+1)_type # darg_type %c
     C                  %and tp_mode >= framemode %start
  6080                    !array name (last in group) with non-literal dope vector
  6081                    put bounds(darg_type,type)
  6082                  %finish
  6083                %finish
  6084              %finish
  6085            %repeat %until %not a(comma)

*    Failed to analyse line  6085
      %REPEATUNTILNOT A(COMMA)
                             !

*    Failed to analyse line  6085
      %REPEATUNTILNOT A(COMMA)
                             !
  6086            error(toofew+point) %if darg_link # 0 %or special # 0
  6087            get(right)
  6088          %else;                              !no LEFT

* 6088   FAULT 51 %FINISH is not required

* 6088   FAULT 51 %FINISH is not required
  6089            error(toofew+point) %if darg_link # 0
  6090          %finish
  6091          put act(pact,hold,0) %if count&1 # 0 %or count = 0
  6092          type = restype
  6093          %if type # 0 %start;  !not routine
  6094            %if hp_flags&volatile = 0 %start
  6095              p = explo
  6096              %while p < explim %cycle
  6097                %if dict(p)_act = headitem %start;  ![enough?]
  6098                  item = p;  q = procnp
  6099                  %cycle
  6100                    %exit %if dict(p)_x # dict(q)_x %or dict(p)_y # dict(q)_y
  6101                    p = p+1;  q = q+1
  6102                    ->okf %if q >= np
  6103                  %repeat
  6104                %finish
  6105                p = p+1
  6106              %repeat
  6107            %finish
  6108            copy down(procnp)
  6109            item = explo
  6110        okf:ditem == dict(item)
  6111            ditem_flags = hp_flags&heritable
  6112            ditem_mode = 0
  6113            %if hp_flags&writable # 0 %start;  !map
  6114              ditem_mode = dispmode
  6115            %finish
  6116            ditem_type = type
  6117            np = procnp
  6118          %finish
  6119        %end;  !get PARLIST
  6120        
  6121        !<<IMP
  6122        
  6123        %routine get RESOLUTION(%integer t,item1)
  6124        %integer fore,ftype,s
  6125        !  type check needed
  6126          s = size(t)
  6127          s = -256 %if s = 0
  6128          fore = 0
  6129          %unless a(left) %start

*    Failed to analyse line  6129
      %UNLESS A(LEFT) %START
                       !

*    Failed to analyse line  6129
      %UNLESS A(LEFT) %START
                       !
  6130            get REFERENCE(stringstar)
  6131            fore = item;  ftype = type
  6132            get(dot);  get(left)
  6133          %finish

* 6133   FAULT 51 %FINISH is not required

* 6133   FAULT 51 %FINISH is not required
  6134          get VALUE(stringtype);  get(right)
  6135          %if item = 0 %start
  6136            item = litref(value);  s = s+final(value)
  6137          %finish
  6138          fault(rangerr+warn) %if fore # 0 %and s < size(ftype) # 0
  6139          putact(resolves,item1+ad,item+ad)
  6140          item = 0
  6141          %if a(dot) %start

*    Failed to analyse line  6141
      %IF A(DOT) %START
                  !

*    Failed to analyse line  6141
      %IF A(DOT) %START
                  !
  6142            get REFERENCE(stringstar)
  6143            fault(rangerr+warn) %if s < size(type) # 0
  6144          %finish

* 6144   FAULT 51 %FINISH is not required

* 6144   FAULT 51 %FINISH is not required
  6145          putact(0,fore,item)
  6146          putact(0,0,0);       !preserve 'parity'
  6147        %end
  6148        
  6149        %integer%fn ANON(%record(objinfo)%name d)
  6150          dict(lablim+3)_details = d
  6151          %result = lablim+3
  6152        %end
  6153        
  6154        %integerfn A ASSOP(%integer t)
  6155          %if t <= 0 %start
  6156            %result = FALSE %unless a(eqeq)

*    Failed to analyse line  6156
      %RESULT =FALSE %UNLESS A(EQEQ)
                                   !

*    Failed to analyse line  6156
      %RESULT =FALSE %UNLESS A(EQEQ)
                                   !
  6157          %else
  6158            atom = next atom %if matched # 0
  6159            %if atom # equals %start
  6160              %result = FALSE %unless atom = less %and byteintegeR(fp) = '-'
  6161              jammy = 1;  fp = fp+1
  6162            %finish %else jammy = 0
  6163            matched = 1
  6164          %finish
  6165          %result = TRUE
  6166        %end
  6167        
  6168        !<<BOTH
  6169        
  6170        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  6171        !
  6172        %routine GET EXPRESSION(%integer rank,etype)
  6173        !Main expression recognition routine
  6174        !To bring together the treatment of all binary operators
  6175        ! and ensure fast recognition of simple expressions,
     C        ! expressions of different levels are handled by
  6177        ! precedence techniques rather than syntactically
  6178        %integer atomp0,item1,type1,cat1,val1,double,op
  6179        %record(identinfo)%name ditem1,tp
  6180        %constinteger nop=0;  !to distinguish from numeric zero in OPVAL
  6181        
  6182        %routine GET RECORD
  6183        ![literal only at this stage]
  6184        %integer fid,ad,arg,hold,count,max,s
  6185        %record(identinfo)%name darg,fidp
  6186          literal = literal+1
  6187          fill code(1) %if cad&1 # 0
  6188          ad = cad
  6189          fid = item;  fidp == ditem
  6190          arg = fidp_link
  6191          count = 0;  max = -1
  6192          get(left)
  6193          %cycle
  6194            ![*beware premature lexical coding: may alter CAD*]
  6195            %cycle
  6196              error(toomany+point) %if arg <= 0
  6197              darg == dict(arg)
  6198              %exit %if ad+darg_val-cad >= 0
  6199              arg = darg_hlink
  6200            %repeat
  6201            fill code(ad+darg_val-cad)
  6202           ! [*now OK to code atom*]
  6203            %if a(recsub) %start

*    Failed to analyse line  6203
      %IF A(RECSUB) %START
                     !

*    Failed to analyse line  6203
      %IF A(RECSUB) %START
                     !
  6204              subbed = 1;  dformat == fidp
  6205              get(ident)
  6206              subbed = 0
  6207              name error %if item < arg
  6208              fill code(ditem_val-darg_val)
  6209              arg = item;  darg == ditem
  6210              syntax error %unless a assop(darg_flags&name+darg_type)

*    Failed to analyse line  6210
     SYNTAXERROR %UNLESS AASSOP(DARG_FLAGS&NAME+DARG_TYPE)
                                                         !

*    Failed to analyse line  6210
     SYNTAXERROR %UNLESS AASSOP(DARG_FLAGS&NAME+DARG_TYPE)
                                                         !
  6211            %finish

* 6211   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  6193

* 6211   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  6193
  6212            s = nsize(darg)
  6213            %unless a(comma) %start

*    Failed to analyse line  6213
      %UNLESS A(COMMA) %START
                        !

*    Failed to analyse line  6213
      %UNLESS A(COMMA) %START
                        !
  6214              get VALUE(darg_flags&name+darg_type)
  6215              %if s > 0 %start
  6216                %if s = 4 %start
  6217        !$IF VAX
  6218        {          value = ieee(value) %if darg_type = realtype %and darg_flags >= 0
  6219        !$FINISH
  6220                  set code longword(value)
  6221                %finish %else %if s = 2 %start
  6222                 set code word(value)
  6223                %else
  6224                  final(cad) <- value;  cad = cad+1
  6225                %finish
  6226              %finish
  6227              %exit %if a(right)

*    Failed to analyse line  6227
      %EXITIF A(RIGHT)
                     !

*    Failed to analyse line  6227
      %EXITIF A(RIGHT)
                     !
  6228              get(comma)
  6229            %finish %else %if s > 0 %start

* 6229   FAULT 51 %FINISH is not required

* 6229   FAULT 51 %FINISH is not required
  6230              fill code(s)
  6231            %finish
  6232            arg = darg_hlink
  6233          %repeat

* 6233   FAULT  1 %REPEAT is not required

* 6233   FAULT  1 %REPEAT is not required
  6234          fill code(ad+imod(fidp_val)-cad)
  6235          item = 0;  value = ad
  6236          literal = literal-1
  6237        %end
  6238        
  6239        %routine SWOP
  6240        %integer temp
  6241          temp = item1;  item1 = item;  item = temp
  6242          temp = val1;  val1 = value;  value = temp
  6243          temp = type1;  type1 = type;  type = temp
  6244        %end
  6245        
  6246        %constinteger INTOK=1<<inty, CHAROK=1<<chary,
     C                      BOOLOK=1<<booly, ENUMOK=1<<enumy,
     C                      REALOK=1<<realy, STRINGOK=1<<stringy,
     C                      ARROK=1<<arry, SETOK=1<<sety,
     C                      RECOK=1<<recy, POINTOK=1<<pointy,
     C                      NUMOK=intok!realok,
     C                      ORDOK=intok!charok!boolok!enumok,
     C                      RELOK=ordok!realok!stringok
  6254        %routine CHECK1(%integer ok)
  6255          cat1 = category(type)
  6256          %if ok>>(cat1&cat)&1 = 0 %start
  6257            %if cat1 = inty %and ok&realok # 0 %start
  6258              toreal;  cat1 = realy
  6259            %finish %else %if ok&stringok # 0 %and valok(stringtype,type) %start

*    Failed to analyse line  6259
      %FINISHELSEIF OK&STRINGOK#0 %AND VALOK(STRINGTYPE,TYPE) %START
                                                               !

*    Failed to analyse line  6259
      %FINISHELSEIF OK&STRINGOK#0 %AND VALOK(STRINGTYPE,TYPE) %START
                                                               !
  6260              cat1 = stringy
  6261            %else
  6262              fault(typerr+point)
  6263            %finish
  6264          %finish

* 6264   FAULT 51 %FINISH is not required

* 6264   FAULT 51 %FINISH is not required
  6265          type1 = type;  item1 = item;  val1 = value
  6266        %end
  6267        
  6268        %integer%fn FROZEN LIT(%integer t,v)
  6269        ! Used when the type of a literal will not be recoverable from context
  6270        %integer hold,res
  6271          hold = item
  6272          putexp(move,0,litref(v),t);  !NO-OP (distinctive Y)
  6273          ditem_flags = okflag+wflag
  6274          ditem_mode = constmode;  ditem_val = v
  6275          res = item;  item = hold
  6276          %result = res
  6277        %end
  6278        
  6279        %routine COERCE(%integer c)
  6280          %if c = inty %and cat1 = realy %start
  6281            toreal
  6282          %finish %else %if cat1 = inty %and c = realy %start
  6283            ![rather sloppy]
  6284            %if item1 # 0 %start
  6285              val1 = item;  item = item1
  6286              toreal
  6287              item1 = item;  item = val1
  6288            %finish %else real(addr(val1)) = val1
  6289            type1 = realtype;  cat1 = realy
  6290          %else
  6291            expfault(typerr)
  6292          %finish
  6293        %end
  6294        
  6295        %routine GET ARITH(%integer rank)
  6296          get EXPRESSION(rank,0)
  6297          rank = category(type)
  6298          coerce(rank) %if rank # cat1
  6299        %end
  6300        
  6301        %integer%fn RCOND(%integer op)
  6302        %constinteger EQUAL=2_1001000010,
     C                      LESS =2_1010000001,
     C                    GREATER=2_0101000001
  6305        %integer which,c
  6306        !<<IMP
  6307          check1(relok)
  6308          get EXPRESSION(major,0)
  6309          c = category(type)
  6310          coerce(c) %if c # cat1
  6311          %if equals <= atom <= greater %start;  ![ATOM always primed]
  6312            syntax error %if double >= 0
  6313            double = item
  6314          %finish %else %if double < 0 %start
  6315            double = -2
  6316          %finish
  6317        !<<BOTH
  6318          %if item1 = 0 %start
  6319            %if item = 0 %start
  6320              %if size(type1) > 0 %or item1!val1 = 0 %or item!value = 0 %start
  6321                !non-structure (compile-time)
  6322                ![integer tests ok for real?]
  6323                %if val1 < value %then which = less %c
     C                %else %if val1 = value %then which = equal %c
     C                %else which = greater
  6326                %result = which>>(op-bne)&1
  6327              %finish
  6328              item1 = frozen lit(type1,val1)
  6329            %else
  6330              swop
  6331              op = op!!3 %if op&8 # 0;  !no change for '=','#'
  6332            %finish
  6333          %finish
  6334          %result = op
  6335        %end;  !RCOND
  6336        !<<IMP
  6337        
  6338        %integer%fn OPVAL
  6339        ! Returns result value for literal (ITEM=ITEM1=0)
  6340        !         0 for no-op (result is ITEM1,TYPE1)
  6341        !         operator otherwise (result type is TYPE)
  6342        ! NB literal INTY type is always INTTYPE (not subrange)
  6343        %switch op(keyand:rshift)
  6344          -> op(atom)
  6345        op(plus):
  6346          check1(numok+setok)
  6347          get ARITH(star)
  6348          %if cat1 = inty %start
  6349            %if item1 = 0 %start
  6350              %result = val1+value %if item = 0
  6351              swop
  6352            %finish
  6353            %result = nop %if item!value = 0
  6354            type = inttype
  6355            %result = add
  6356          %else
  6357            %if item1 = 0 %start
  6358              %if item = 0 %start
  6359                real(addr(val1)) = real(addr(val1))+real(addr(value))
  6360                %result = val1
  6361              %finish
  6362              swop
  6363            %finish
  6364            %result = nop %if item!value = 0
  6365            %result = fadd
  6366          %finish
  6367        op(minus):
  6368          check1(numok+setok)
  6369          get ARITH(star)
  6370          %if cat1 = inty %start
  6371            %if item1 = 0 %start
  6372              %result = val1-value %if item = 0
  6373              swop %and %result = neg %if val1 = 0
  6374            %finish
  6375            type = inttype
  6376            %if item = 0 %start
  6377              %result = nop %if value = 0
  6378              value = -value %if value # minint
  6379              %result = add
  6380            %finish
  6381            %result = sub
  6382          %else
  6383            %if item = 0 %start
  6384              %if item1 = 0 %start
  6385                real(addr(val1)) = real(addr(val1))-real(addr(value))
  6386                %result = val1
  6387              %finish
  6388              %result = nop %if value = 0
  6389            %finish
  6390            %result = fsub
  6391          %finish
  6392        op(exclam):
  6393          check1(intok);  get EXPRESSION(star,inttype)
  6394          %if item1 = 0 %start
  6395            %result = val1!value %if item = 0
  6396            swop
  6397          %finish
  6398          %result = nop %if item!value = 0
  6399          type = inttype
  6400          %result = or
  6401        op(exclam2):
  6402          check1(intok);  get EXPRESSION(star,inttype)
  6403          %if item1 = 0 %start
  6404            %result = val1!!value %if item = 0
  6405            swop
  6406          %finish
  6407          %result = nop %if item!value = 0
  6408          type = inttype
  6409          %result = eor
  6410        op(ampersand):
  6411          check1(intok);  get EXPRESSION(star2,inttype)
  6412          %if item1 = 0 %start
  6413            %result = val1&value %if item = 0
  6414            swop
  6415          %finish
  6416          item1 = 0 %and %result = 0 %if item!value = 0
  6417          type = inttype
  6418          %result = and
  6419        op(star):
  6420          check1(numok+setok)
  6421          get ARITH(star2)
  6422          item1 = 0 %and %result = 0 %if item!value = 0
  6423          %if cat1 = inty %start
  6424            %if item1 = 0 %start
  6425              %result = val1*value %if item = 0
  6426              swop
  6427            %finish
  6428            type = inttype
  6429            %result = imul %if control&halfbit = 0
  6430            %result = muls
  6431          %else
  6432            %if item1 = 0 %start
  6433              %if item = 0 %start
  6434                real(addr(val1)) = real(addr(val1))*real(addr(value))
  6435                %result = val1
  6436              %finish
  6437              swop
  6438            %finish
  6439            %result = fmul
  6440          %finish
  6441        op(over):
  6442          check1(intok);  get EXPRESSION(star2,inttype)
  6443          %if item = 0 %start
  6444            fault(rangerr) %and %result = nop %if value = 0
  6445            %result = val1//value %if item1 = 0
  6446          %finish
  6447          type = inttype
  6448          %result = idiv
  6449        op(slash):
  6450          check1(realok)
  6451          get EXPRESSION(star2,realtype)
  6452          %if item = 0 %start
  6453            fault(rangerr) %and %result = nop %if value = 0
  6454            %if item1 = 0 %start
  6455              real(addr(val1)) = real(addr(val1))/real(addr(value))
  6456              %result = val1
  6457            %finish
  6458          %finish
  6459          %result = fdiv
  6460        op(backslash2): op(uparrow2):
  6461          check1(intok);  get EXPRESSION(simple,inttype)
  6462          %if item = 0 %start
  6463            %result = val1\\value %if item1 = 0
  6464            item1 = 0 %and %result = 1 %if value = 0
  6465            %result = nop %if value = 1
  6466            item = item1 %and %result = imul %if value = 2
  6467          %finish
  6468          type = inttype
  6469          %result = ipow
  6470        op(backslash): op(uparrow): op(star2):
  6471          check1(realok)
  6472          get EXPRESSION(simple,inttype)
  6473          type = realtype
  6474          %if item!item1 = 0 %start
  6475            real(addr(val1)) = real(addr(val1))\value
  6476            %result = val1
  6477          %finish
  6478          %result = fpow
  6479        op(lshift):
  6480          check1(intok);  get EXPRESSION(simple,inttype)
  6481          %if item = 0 %start
  6482            %result = val1<<value %if item1 = 0
  6483            %result = nop %if value = 0
  6484          %finish
  6485          type = inttype
  6486          %result = lsl
  6487        op(rshift):
  6488          check1(intok);  get EXPRESSION(simple,inttype)
  6489          %if item = 0 %start
  6490            %result = val1>>value %if item1 = 0
  6491            %result = nop %if value = 0
  6492          %finish
  6493          type = inttype
  6494          %result = lsr
  6495        op(tilde):
  6496          check1(intok)
  6497          get EXPRESSION(simple,inttype)
  6498          %result = \value %if item = 0
  6499          swop
  6500          type = inttype
  6501          %result = not
  6502        op(sconc):
  6503          check1(stringok);  get EXPRESSION(dot+1,stringtype)
  6504          %if item = 0 %start
  6505            %if item1 = 0 %start
  6506              %result = val1 %if value = 0
  6507              %result = value %if val1 = 0
  6508              %if final(val1)+final(value) <= 255 %start
  6509                string(final0+val1) = string(final0+val1) %c
     C                                         . string(final0+value)
  6511                cad = cad-1
  6512              %finish %else fault(rangerr)
  6513              %result = val1
  6514            %finish
  6515            %result = nop %if value = 0
  6516          %finish %else %if item1!val1 = 0 %start
  6517            item1 = item;  val1 = value;  type1 = type
  6518            %result = nop
  6519          %finish
  6520          type = stringtype
  6521          %result = concat
  6522        op(equals):
  6523          %result = RCOND(beq)
  6524        op(noteq):
  6525          %result = RCOND(bne)
  6526        op(lesseq):
  6527          %result = RCOND(ble)
  6528        op(less):
  6529          %result = RCOND(blt)
  6530        op(greateq):
  6531          %result = RCOND(bge)
  6532        op(greater):
  6533          %result = RCOND(bgt)
  6534        %integer%fn RACOND(%integer op)
  6535          toref
  6536          item1 = normitem;  type1 = type
  6537          get REFERENCE(type1)
  6538          val1 = 0 %and swop %if item1 = 0
  6539          syntax error %if arrow <= atom <= greater;  ![ATOM always primed]
  6540          double = -2
  6541          %result = op
  6542        %end
  6543        op(eqeq):
  6544          %result = RACOND(beq)
  6545        op(noteqeq):
  6546          %result = RACOND(bne)
  6547        op(arrow):
  6548          check1(stringok)
  6549          item1 = litref(val1) %if item1 = 0
  6550          get RESOLUTION(type,item1)
  6551          item1 = np-3
  6552          condop = bne!!polarity
  6553          type1 = booltype
  6554          %result = nop
  6555        op(keyand):
  6556          topred %if condop = 0
  6557          item1 = np;  type1 = booltype
  6558          putact(condop!!polarity!!1+polarity<<7,item,0)
  6559          condop = 0
  6560          get EXPRESSION(scond,booltype)
  6561          dict(item1)_y = item
  6562          syntax error %if a(keyor)

*    Failed to analyse line  6562
     SYNTAXERROR %IF A(KEYOR)
                            !

*    Failed to analyse line  6562
     SYNTAXERROR %IF A(KEYOR)
                            !
  6563          %result = nop
  6564        op(keyor):
  6565          topred %if condop = 0
  6566          item1 = np;  type1 = booltype
  6567          putact(condop!!polarity+(polarity!!1)<<7,item,0)
  6568          condop = 0
  6569          get EXPRESSION(scond,booltype)
  6570          dict(item1)_y = item
  6571          syntax error %if a(keyand)

*    Failed to analyse line  6571
     SYNTAXERROR %IF A(KEYAND)
                             !

*    Failed to analyse line  6571
     SYNTAXERROR %IF A(KEYAND)
                             !
  6572          %result = nop
  6573        %end
  6574        
  6575        !Get leading operand
  6576          atom = next atom %if matched # 0
  6577          atomp0 = atomp;  jammy = jammy<<1;  !preserve
  6578          %if atom = ident %start
  6579            matched = 1
  6580            name error %if item <= 0 %or (ditem_mode = labmode %and item < c_localdpos)
  6581            fault(namerr+point) %if item >= dlim0
  6582            type = ditem_type
  6583            %if ditem_flags&typeid # 0 %start
  6584              %if ditem_flags&cat = recy %and item > dnil %start
  6585                get RECORD
  6586                %return
  6587              %else
  6588                item1 = item;  ditem1 == ditem
  6589                %if a(less) %start;  !type coercion

*    Failed to analyse line  6589
      %IF A(LESS) %START ;
                   !

*    Failed to analyse line  6589
      %IF A(LESS) %START ;
                   !
  6590                  get VALUE(0);  get(greater)
  6591                  type = item1
  6592                %else
  6593                  get(left);          !store mapping
  6594                  get VALUE(inttype)
  6595                  get(right)
  6596                  putexp2(storemap,item1,item1)
  6597                  ditem_flags = writable!readable
  6598                  ditem_mode = dispmode
  6599                %finish
  6600              %finish
  6601            %finish %else %if ditem_mode = litmode %start
  6602              item = 0;  value = ditem_val
  6603            %else;                                    !non-literal ident
  6604              %cycle
  6605                %if ditem_flags&proc # 0 %start
  6606                  %if item = daddr %or item = dsizeof %or item = dnew %start
  6607                    get(left)
  6608                    %if item = daddr %start
  6609                      get REFERENCE(0)
  6610                      type = inttype
  6611                    %else
  6612                      item1 = item
  6613                      get REFERENCE(0)
  6614                      value = imod(size(type))
  6615                      expfault(sizerr) %if value = 0
  6616                      %if item1 = dsizeof %start
  6617                        item = 0;  type = inttype
  6618                      %else
  6619                        putexp(dnew,0,litref(value),0)
  6620                        ditem_mode = dispmode
  6621                      %finish
  6622                    %finish
  6623                    get(right)
  6624        !          %finish %else %if item = dsnl %start
  6625        !            putexp(dtostring,nl,0,string1)
  6626                  %else
  6627                    get PARLIST(0)
  6628                    atomp=atomp0 %and error(classerr+point) %if type = 0;  !routine
  6629                  %finish
  6630                %else;                                   !not procedure
  6631                  atom = next atom %if matched # 0
  6632                  %exit %unless aleft <= atom <= recsub %and rank <= simple
  6633                  %if atom = aleft %start;  !array subscript
  6634                    %cycle
  6635                      item1 = item;  ditem1 == ditem
  6636                      tp == typecell(type)
  6637                      %if tp_flags&cat = stringy %start
  6638                        matched = 1
  6639                        nonstandard(2)
  6640                        get VALUE(bytetype)
  6641                        putexp2(sindex,item1,chartype)
  6642                      %else
  6643                        -> out %unless tp_flags&cat = arry
  6644                        matched = 1
  6645                        get VALUE(tp_xtype);  !get index
  6646                        putexp2(index,item1,tp_type)
  6647                      %finish
  6648                      ditem_flags = ditem1_flags&heritable
  6649                      ditem_mode = ditem1_mode
  6650                    %repeat %until %not a(comma)

*    Failed to analyse line  6650
      %REPEATUNTILNOT A(COMMA)
                             !

*    Failed to analyse line  6650
      %REPEATUNTILNOT A(COMMA)
                             !
  6651                    ditem_flags = ditem_flags+(tp_flags&name)
  6652                    get(right)
  6653                  %finish %else %if atom = recsub %start;  !record subfield
  6654                    item1 = item;  ditem1 == ditem
  6655                    dformat == typecell(ditem_type)
  6656                    syntax error %unless dformat_flags&cat = recy
  6657                    matched = 1
  6658                    subbed = 1;  get(ident);  subbed = 0
  6659                    error(namerr+point) %if item <= 0
  6660                    val1 = ditem1_flags&heritable!ditem_flags
  6661                    putexp2(recref,item1,ditem_type)
  6662                    ditem_flags = val1
  6663                    ditem_mode = ditem1_mode
  6664                  %finish %else %if atom = atsign %start
  6665                    nonstandard(4)
  6666                    syntax error %if ditem_flags&typeid = 0
  6667                    matched = 1
  6668                    ditem1 == ditem;  item1 = item
  6669                    get EXPRESSION(vsimple,inttype)
  6670                    putexp2(storemap,item1,item1)
  6671                    ditem_flags = writable!readable
  6672                    ditem_mode = dispmode
  6673                  %else;  !pointer relative
  6674                    error(nonref+point) %if ditem_mode < dispmode
  6675                    fault(sizerr) %if size(ditem_type) = 0
  6676                    matched = 1
  6677                    ditem1 == ditem;  item1 = item
  6678                    get VALUE(inttype);  get(rightb)
  6679                    putexp2(prel,item1,ditem1_type)
  6680                    ditem_flags = writable!readable
  6681                    ditem_mode = ditem1_mode
  6682                  %finish
  6683                %finish
  6684              %repeat
  6685            %finish
  6686          %else

* 6686   FAULT 51 %FINISH is not required

* 6686   FAULT 51 %FINISH is not required
  6687            %if atom = const %start
  6688              matched = 1
  6689            %finish %else %if atom = minus %start;  !leave unmatched
  6690              item = 0;  value = 0;  type = inttype
  6691            %finish %else %if atom = left %start
  6692              matched = 1
  6693              %if rank < major %start;  !condition
  6694                get EXPRESSION(condq,0)
  6695              %else
  6696                get EXPRESSION(major,0)
  6697              %finish
  6698              get(right)
  6699            %finish %else %if a(keynot) %start

*    Failed to analyse line  6699
      %FINISHELSEIF A(KEYNOT) %START
                               !

*    Failed to analyse line  6699
      %FINISHELSEIF A(KEYNOT) %START
                               !
  6700              syntax error %if rank >= major
  6701              polarity = polarity!!1
  6702              get EXPRESSION(scond,booltype)
  6703              %if item = 0 %then value = value!!1
  6704              polarity = polarity!!1
  6705            %finish %else %if atom = backslash %start
  6706              item = 0;  value = 0;  type = inttype
  6707              atom = tilde
  6708            %finish %else %if a(modsign) %start

*    Failed to analyse line  6708
      %FINISHELSEIF A(MODSIGN) %START
                                !

*    Failed to analyse line  6708
      %FINISHELSEIF A(MODSIGN) %START
                                !
  6709              get EXPRESSION(major,0)
  6710              %if valok(inttype,type) %start

*    Failed to analyse line  6710
      %IF VALOK(INTTYPE,TYPE) %START
                               !

*    Failed to analyse line  6710
      %IF VALOK(INTTYPE,TYPE) %START
                               !
  6711                %if item = 0 %start
  6712                  %if value < 0 %start
  6713                    %if value # minint %then value = -value %else expfault(rangerr)
  6714                  %finish
  6715                %else
  6716                  putexp2(iabs,0,inttype)
  6717                %finish
  6718              %finish %else %if valok(realtype,type) %start

* 6718   FAULT 51 %FINISH is not required

* 6718   FAULT 51 %FINISH is not required

*    Failed to analyse line  6718
      %FINISHELSEIF VALOK(REALTYPE,TYPE) %START
                                          !

*    Failed to analyse line  6718
      %FINISHELSEIF VALOK(REALTYPE,TYPE) %START
                                          !
  6719                putexp2(fabs,0,realtype)
  6720              %else

* 6720   FAULT 51 %FINISH is not required

* 6720   FAULT 51 %FINISH is not required
  6721                error(typerr+point)
  6722              %finish
  6723              get(modsign)
  6724            %else

* 6724   FAULT 51 %FINISH is not required

* 6724   FAULT 51 %FINISH is not required
  6725              syntax error
  6726            %finish
  6727          %finish

* 6727   FAULT 51 %FINISH is not required

* 6727   FAULT 51 %FINISH is not required
  6728        out:
  6729          atom = next atom %if matched # 0;  ![always primed on return]
  6730        
  6731          %if etype < 0 %start;  !reference required
  6732            expp = atomp0;  jammy = jammy>>1;  !restore
  6733        %unless item!value = 0 %start;  !*temp*
  6734            toref
  6735            expfault(typerr) %unless refok(etype-sign16,type)

*    Failed to analyse line  6735
     EXPFAULT(TYPERR) %UNLESS REFOK(ETYPE-SIGN16,TYPE)
                                                     !

*    Failed to analyse line  6735
     EXPFAULT(TYPERR) %UNLESS REFOK(ETYPE-SIGN16,TYPE)
                                                     !
  6736        %finish %else atomp = atomp0 %and nonstandard(21)
  6737          %else
  6738            %while atom >= rank %cycle
  6739              matched = 1
  6740              double = -1
  6741              op = opval
  6742              %if item1!item = 0 %start;  !both literal
  6743                %if double # -1 %start
  6744                  %if double >= 0 %start
  6745                    literal = literal+1;  !enforce all literal
  6746                    op = op&opval
  6747                    literal = literal-1
  6748                  %finish
  6749                  type = booltype
  6750                %finish
  6751                value = op
  6752              %finish %else %if double = -1 %start;         !not relop
  6753                %if op # 0 %start
  6754                  item1 = litref(val1) %if item1 = 0
  6755                  putexp(op,item1,normitem,type)
  6756                %else;         !nop
  6757                  item = item1;  type = type1
  6758                %finish
  6759              %else;                      !conditional operation
  6760                condop = op!!polarity
  6761                putact(compare,item1,normitem)
  6762                item = np-1
  6763                %if double >= 0 %start
  6764                  putact(condop!!polarity!!1+polarity<<7,np-1,np+1);  !implicit %and
  6765                  item = double;  ![TYPE,VALUE unchanged]
  6766                  matched = 1
  6767                  op = opval
  6768                  error(nonliteral) %if item1!item = 0;  !mixed non-lit, lit
  6769                  condop = op!!polarity
  6770                  putact(compare,item1,normitem)
  6771                  item = np-2
  6772                %finish
  6773                type = booltype
  6774              %finish
  6775            %repeat
  6776            expp = atomp0;  jammy = jammy>>1
  6777            %if etype # 0 %start
  6778              %if type = booltype %start
  6779                topred %if (rank = cond %or rank = scond) %and condop = 0
  6780              %finish
  6781              expfault(typerr) %unless valok(etype,type)

*    Failed to analyse line  6781
     EXPFAULT(TYPERR) %UNLESS VALOK(ETYPE,TYPE)
                                              !

*    Failed to analyse line  6781
     EXPFAULT(TYPERR) %UNLESS VALOK(ETYPE,TYPE)
                                              !
  6782            %finish
  6783          %finish
  6784          atomp=expp %and error(nonliteral+point) %if literal # 0 %and item # 0
  6785        %end;  !get EXPRESSION
  6786          
  6787        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  6788        !!!!!!!!!!!!!!!!!!!!  Conditions and loops  !!!!!!!!!!!!!!!!!!!!
  6789        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  6790        !
  6791        %routine GET CONDITION
  6792        %integer maxlab,condnp
  6793        
  6794        %routine ASSIGN LABELS(%integer p,lab,pol)
  6795        %integer base=maxlab

*    Failed to analyse line  6795
      %INTEGER BASE=MAXLAB
                   !

*    Failed to analyse line  6795
      %INTEGER BASE=MAXLAB
                   !
  6796        %record(identinfo)%name dp
  6797          %while (p-condnp)&1 # 0 %cycle;  !compound
  6798            dp == dict(p);  p = dp_y
  6799            %if dp_act&1<<7 = pol %then assign labels(dp_x,lab,pol) %c
     C            %else maxlab = base+1 %and assign labels(dp_x,maxlab,pol!!1<<7)
  6801          %repeat
  6802          dp == dict(p+1);  dp == dp[2] %if dp_act = 0;  !resolution

*    Failed to analyse line  6802
     DP==DP[2] %IF DP_ACT=0;
           !

*    Failed to analyse line  6802
     DP==DP[2] %IF DP_ACT=0;
           !
  6803          %if maxlab > base %then dp_x = maxlab %and maxlab = base %c
     C          %else dp_x = 0
  6805          dp_y = lab
  6806          dp_act = dp_act&127
  6807        %end
  6808        
  6809          condnp = np
  6810          polarity = subatom;  condop = 0
  6811          get EXPRESSION(cond,booltype)
  6812          putact(condop!!1,item,0)
  6813          %return %if faultnum > 0
  6814          maxlab = curlab+1
  6815          assign labels(item,maxlab,0)
  6816        %end;  !get CONDITION
  6817        
  6818        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  6819        
  6820        %routine DO DYNAMIC ARRAYS
  6821          update sp
  6822          c_mode = c_mode!2_01000000;   !bar to SP rel addressing
  6823          c_status = c_status!globbed;  !needs link
  6824          %while c_dynarray # 0 %cycle
  6825            %if c_dynarray < 0 %then putact(aget,-c_dynarray,one) %c
     C            %else putact(aget,c_dynarray,0)
  6827            c_dynarray = dict(imod(c_dynarray))_link
  6828          %repeat
  6829          compile(np0)
  6830        %end
  6831        
  6832        %routine GET STATEMENTS(%integer stopper)
  6833        ! STOPPER = 0          -- initial call
  6834        !           1 (END)    -- for procedure or block body
  6835        !           2 (REPEAT) -- for loop body
  6836        !           3 (FINISH) -- for condition body (ELSE not valid)
  6837        !           4 (ELSE)   --         "          (ELSE valid)
  6838        %switch initial(0:atommax)
  6839        %integer forinf,endval,loopstart
  6840        
  6841        %routine THIS IS INST
  6842          %if c_status < hadinst %start;  !first in block
  6843            c_status = c_status+hadinst
  6844            fault(ordererr) %if stopper = 0
  6845          %finish
  6846          fault(accesserr+warn) %if c_access = 0 %and np = np0
  6847          do dynamic arrays %if c_dynarray # 0
  6848        %end
  6849        
  6850        %routine PUTACT2(%integer act,item1)
  6851          putact(act,item1,normitem)
  6852        %end
  6853        
  6854        %routine GET RESULT
  6855          get VALUE(c_type)
  6856        !  fault(rangerr+warn) %if c_type > 0 %and item # 0 %c
     C        !                      %and imod(size(type)) > imod(size(c_type))
  6858        %end
  6859        
  6860        %routine GET INSTRUCTION
  6861        %integer item1
  6862        %record(identinfo)%name tp
  6863          this is inst
  6864          %cycle
  6865            %if a(ident) %start

*    Failed to analyse line  6865
      %IF A(IDENT) %START
                    !

*    Failed to analyse line  6865
      %IF A(IDENT) %START
                    !
  6866              name error %if item <= 0
  6867              %if ditem_flags&(writable!typeid) # 0 %start
  6868                matched = 0
  6869                get EXPRESSION(simple,0)
  6870                item1 = item
  6871                %if a(equals) %start

*    Failed to analyse line  6871
      %IF A(EQUALS) %START
                     !

*    Failed to analyse line  6871
      %IF A(EQUALS) %START
                     !
  6872                  jammy = 0
  6873                  get VALUE(type)
  6874                  putact2(okass+jammy,item1);  !okass,assign
  6875                %finish %else %if a(eqeq) %start

*    Failed to analyse line  6875
      %FINISHELSEIF A(EQEQ) %START
                             !

*    Failed to analyse line  6875
      %FINISHELSEIF A(EQEQ) %START
                             !
  6876                  syntax error %if ditem_flags >= 0
  6877                  get REFERENCE(type)
  6878                  putact2(assign,item1+ad)
  6879                %finish %else %if atom = less %and byteintegeR(fp) = '-' %start

* 6879   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  6864

* 6879   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  6864
  6880                  fp = fp+1;  matched = 1
  6881                  jammy = 1
  6882                  get VALUE(type)
  6883                  putact2(jamass+jammy,item1);  !jamass,okass
  6884                %else
  6885                  syntax error %unless a(arrow)

*    Failed to analyse line  6885
     SYNTAXERROR %UNLESS A(ARROW)
                                !

*    Failed to analyse line  6885
     SYNTAXERROR %UNLESS A(ARROW)
                                !
  6886                  get RESOLUTION(type,item1)
  6887                  putact(bne,0,curlab)
  6888                  putact(signal,litref(7),undef)
  6889                  putact(0,undef,undef)
  6890                %finish
  6891              %else

* 6891   FAULT 51 %FINISH is not required

* 6891   FAULT 51 %FINISH is not required
  6892                error(classerr+point) %if ditem_flags&proc = 0
  6893                tp == typecell(ditem_type)
  6894                %if tp_type # 0 %start;  !function as routine
  6895                  get PARLIST(tp_type)
  6896                  putact2(assign,value)
  6897                %else
  6898                  get PARLIST(0)
  6899                %finish
  6900              %finish
  6901            %else

* 6901   FAULT 51 %FINISH is not required

* 6901   FAULT 51 %FINISH is not required
  6902              c_access = 0 %if np = np0;  !unconditional
  6903              %if a(keymonitor) %start

*    Failed to analyse line  6903
      %IF A(KEYMONITOR) %START
                         !

*    Failed to analyse line  6903
      %IF A(KEYMONITOR) %START
                         !
  6904                c_access = 1
  6905        !        fault(monitor<<8)
  6906             %finish %else %if a(exit) %start;  !%exit, %continue

*    Failed to analyse line  6906
      %FINISHELSEIF A(EXIT) %START ;
                             !

*    Failed to analyse line  6906
      %FINISHELSEIF A(EXIT) %START ;
                             !
  6907                %if c_looplab = 0 %then fault(notinloop+point) %c
     C                %else putact(jumpout,c_looplab,c_looplab+subatom)
  6909                %exit
  6910             %finish %else %if a(keyreturn) %start

* 6910   FAULT 51 %FINISH is not required

* 6910   FAULT 51 %FINISH is not required

*    Failed to analyse line  6910
      %FINISHELSEIF A(KEYRETURN) %START
                                  !

*    Failed to analyse line  6910
      %FINISHELSEIF A(KEYRETURN) %START
                                  !
  6911                item = 0;  value = 0
  6912                get RESULT %if c_type # 0
  6913                putact2(return,0)
  6914                %exit
  6915             %finish %else %if a(keyresult) %start

* 6915   FAULT 51 %FINISH is not required

* 6915   FAULT 51 %FINISH is not required

*    Failed to analyse line  6915
      %FINISHELSEIF A(KEYRESULT) %START
                                  !

*    Failed to analyse line  6915
      %FINISHELSEIF A(KEYRESULT) %START
                                  !
  6916                error(notinfun+point) %if c_type = 0
  6917                syntax error %unless a assop(c_type)

*    Failed to analyse line  6917
     SYNTAXERROR %UNLESS AASSOP(C_TYPE)
                                      !

*    Failed to analyse line  6917
     SYNTAXERROR %UNLESS AASSOP(C_TYPE)
                                      !
  6918                get RESULT
  6919                putact2(return,0)
  6920                %exit
  6921             %finish %else %if a(tf) %start;  !%true, %false

* 6921   FAULT 51 %FINISH is not required

* 6921   FAULT 51 %FINISH is not required

*    Failed to analyse line  6921
      %FINISHELSEIF A(TF) %START ;
                           !

*    Failed to analyse line  6921
      %FINISHELSEIF A(TF) %START ;
                           !
  6922                %if c_type # booltype %then fault(notinpred+point) %c
     C                %else putact(return,0,litref(subatom))
  6924                %exit
  6925             %finish %else %if a(arrow) %or a(keygoto) %start

* 6925   FAULT 51 %FINISH is not required

* 6925   FAULT 51 %FINISH is not required

*    Failed to analyse line  6925
      %FINISHELSEIF A(ARROW) %OR A(KEYGOTO) %START
                              !

*    Failed to analyse line  6925
      %FINISHELSEIF A(ARROW) %OR A(KEYGOTO) %START
                              !
  6926                nonstandard(5) %if atom = keygoto
  6927                get(ident)
  6928                %if byteinteger(fp) # '(' %start
  6929                  declare(forwardlabel) %if item < c_localdpos {new} %c
     C                                        %or ditem_type # 0 {error}
  6931                  putact2(goto,0)
  6932                %else
  6933                  name error %if item < c_localdpos
  6934                  error(classerr+point) %unless ditem_mode = labmode %c
     C                                        %and ditem_type # 0
  6936                  item1 = item
  6937                  get(left)
  6938                  get VALUE(typecell(ditem_type)_xtype);  !index
  6939                  get(right)
  6940                  putact2(swgoto,item1)
  6941                %finish
  6942                %exit
  6943             %finish %else %if a(keystop) %start

* 6943   FAULT 51 %FINISH is not required

* 6943   FAULT 51 %FINISH is not required

*    Failed to analyse line  6943
      %FINISHELSEIF A(KEYSTOP) %START
                                !

*    Failed to analyse line  6943
      %FINISHELSEIF A(KEYSTOP) %START
                                !
  6944                putact(stop,0,0)
  6945                %exit
  6946             %finish %else %if a(keysignal) %start

* 6946   FAULT 51 %FINISH is not required

* 6946   FAULT 51 %FINISH is not required

*    Failed to analyse line  6946
      %FINISHELSEIF A(KEYSIGNAL) %START
                                  !

*    Failed to analyse line  6946
      %FINISHELSEIF A(KEYSIGNAL) %START
                                  !
  6947                c_access = 1
  6948                allow(keyevent)
  6949                get LITERAL(inttype)
  6950                expfault(rangerr) %unless 0 <= value <= 15
  6951                item1 = litref(value);  item = undef
  6952                %if a(comma) %start

*    Failed to analyse line  6952
      %IF A(COMMA) %START
                    !

*    Failed to analyse line  6952
      %IF A(COMMA) %START
                    !
  6953        l1:       %if a(comma) %then matched = 0 %else get VALUE(bytetype)

*    Failed to analyse line  6953
      %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(BYTETYPE)
                    !

*    Failed to analyse line  6953
      %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(BYTETYPE)
                    !
  6954                %finish

* 6954   FAULT 51 %FINISH is not required

* 6954   FAULT 51 %FINISH is not required
  6955                putact2(signal,item1)
  6956                item = undef
  6957                %if a(comma) %start

*    Failed to analyse line  6957
      %IF A(COMMA) %START
                    !

*    Failed to analyse line  6957
      %IF A(COMMA) %START
                    !
  6958        l2:       %if a(comma) %then matched = 0 %else get VALUE(inttype)

*    Failed to analyse line  6958
      %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(INTTYPE)
                    !

*    Failed to analyse line  6958
      %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(INTTYPE)
                    !
  6959                %finish

* 6959   FAULT 51 %FINISH is not required

* 6959   FAULT 51 %FINISH is not required
  6960                item1 = normitem;  item = undef
  6961                get VALUE(stringtype) %if a(comma)

*    Failed to analyse line  6961
     GETVALUE(STRINGTYPE) %IF A(COMMA)
                                     !

*    Failed to analyse line  6961
     GETVALUE(STRINGTYPE) %IF A(COMMA)
                                     !
  6962                putact2(0,item1)
  6963                %exit
  6964              %else

* 6964   FAULT 51 %FINISH is not required

* 6964   FAULT 51 %FINISH is not required
  6965                syntax error
  6966              %finish
  6967            %finish

* 6967   FAULT 51 %FINISH is not required

* 6967   FAULT 51 %FINISH is not required
  6968          %repeat %until %not a(keyand)

* 6968   FAULT  1 %REPEAT is not required

* 6968   FAULT  1 %REPEAT is not required

*    Failed to analyse line  6968
      %REPEATUNTILNOT A(KEYAND)
                              !

*    Failed to analyse line  6968
      %REPEATUNTILNOT A(KEYAND)
                              !
  6969        %end;  !GET INSTRUCTION
  6970        
  6971        %routine GET FOR CLAUSE
  6972        !Global: FORINF,ENDVAL
  6973        %integer loopvar,lvtype,k,s,start,sval,i,inc,ival,e,n
  6974        %integer end
  6975        %record(identinfo)%name tp
  6976          forinf = 0
  6977          get(ident)
  6978          name error %if item <= 0
  6979          lvtype = ditem_type;  tp == typecell(lvtype)
  6980          fault(typerr+point) %if tp_flags&nonord # 0
  6981          loopvar = item
  6982          get(equals)
  6983          get VALUE(lvtype)
  6984          start = item;  sval = value
  6985          get(comma)
  6986          get VALUE(lvtype)
  6987          inc = item;  ival = value
  6988          expfault(rangerr) %and ival = 1 %if inc = 0 = ival
  6989        !Deal with INC and replace START by START-INC
  6990          k = undef
  6991          k = dict(start)_y %if start >= np0 %and dict(start)_act = add
  6992          %if inc = 0 %start;  !literal increment
  6993            i = litref(ival)
  6994            %if start = 0 %start;  !START and INC both literal
  6995              sval = sval-ival;  item = litref(sval)
  6996            %finish %else %if k <= 0 %start;  !START is x+lit
  6997              k = litval(k)-ival
  6998              item = dict(start)_x
  6999              putexp(add,item,litref(k),inttype) %if k # 0
  7000            %else
  7001              putexp(add,start,litref(-ival),inttype)
  7002            %finish
  7003          %else;  !variable
  7004            i = inc
  7005            %if control&volbit # 0 %start
  7006              declare temp(inttype);  i = item
  7007              putact(assign,i,inc);  forinf = forinf-4
  7008            %finish
  7009            %if start = inc %start;  !identical
  7010              item = 0;  sval = 0
  7011            %finish %else %if k = inc %start;  !START is x+INC
  7012              item = dict(start)_x
  7013            %else
  7014              item = start;  item = litref(sval) %if item = 0
  7015              putexp(sub,item,i,inttype)
  7016            %finish
  7017          %finish
  7018          s = item
  7019        !Get end-value
  7020          get(comma)
  7021          get VALUE(lvtype)
  7022          end = item
  7023          %if end = 0 %start;  !literal end-value
  7024            e = litref(value);  endval = value
  7025          %else
  7026            e = item
  7027            %if control&volbit # 0 %start
  7028              declare temp(inttype);  e = item
  7029              putact(assign,e,end);  forinf = forinf-4
  7030            %finish
  7031          %finish
  7032          %if start!inc!end # 0 %and control&loopbit # 0 %start
  7033            putact(forass,loopvar,s)
  7034            putact(forass,i,e)
  7035          %else
  7036            putact(assign,loopvar,s)
  7037          %finish
  7038          putact(label,curlab,0)
  7039          %if start!inc!end = 0 %start;  !all literal
  7040            k = endval-sval;  n = k//ival
  7041            %if n = 0 %start
  7042              fault(dubious+warn)
  7043              putact(else,0,curlab+1);  !ie unconditional branch
  7044              %return
  7045            %finish
  7046            fault(boundserr) %if n < 0
  7047            fault(unending) %if n*ival # k
  7048            forinf = loopvar
  7049          %else
  7050            putact(compare,loopvar,e)
  7051            putact(beq,0,curlab+1)
  7052          %finish
  7053          putact(incass,loopvar,i)
  7054        %end;  !get FORCLAUSE
  7055        
  7056        %routine GET LOOP BODY
  7057        %integer hold=c_looplab

*    Failed to analyse line  7057
      %INTEGER HOLD=C_LOOPLAB
                   !

*    Failed to analyse line  7057
      %INTEGER HOLD=C_LOOPLAB
                   !
  7058          c_looplab = curlab;  curlab = curlab+2
  7059          get STATEMENTS(keyrepeat)
  7060          curlab = curlab-2;  c_looplab = hold
  7061        %end
  7062        
  7063        %routine GET SWITCH INDEX
  7064        %integer i,lo,hi
  7065        %record(identinfo)%name dp,tp
  7066        %routine SET LABEL(%shortname p)
  7067          value = p
  7068          expfault(duperr) %if value > 0
  7069          set user label(value)
  7070          p = value
  7071        %end
  7072          dp == ditem;  tp == typecell(ditem_type)
  7073          get(left)
  7074          %if a(star) %start

*    Failed to analyse line  7074
      %IF A(STAR) %START
                   !

*    Failed to analyse line  7074
      %IF A(STAR) %START
                   !
  7075            set label(dp_link)
  7076          %else

* 7076   FAULT 51 %FINISH is not required

* 7076   FAULT 51 %FINISH is not required
  7077            get VALUE(tp_xtype)
  7078           !beware faulty declaration or index
  7079            %if tp_xtype > inttype %and faultnum = 0 %start
  7080              get bounds(tp_xtype,lo,hi)
  7081              i = value-lo+dp_val
  7082              c_forward = c_forward-1 %if i < pc;  !(had goto)
  7083              set label(prog(i))
  7084            %finish
  7085          %finish
  7086          get(right)
  7087        %end
  7088        
  7089        ![unsure of efficiency implications of trapping overflow lower down]
  7090        %on %event oflow,fail,done %start
  7091          %if event_event = 0 %start;  !failure in %option,%include or ^Y
  7092            %stop %if event_sub # 0
  7093            %signal abandon
  7094          %finish
  7095          %if event_event = done %start
  7096            croak("Premature end of input") %if stopper # 0
  7097            close block
  7098            c_dpid_val = 0;  !zero entry-point
  7099            %return
  7100          %finish
  7101          fault(rangerr+now) %if event_event = oflow
  7102          -> ignore
  7103        %finish
  7104        !!!!!!!!!!!!!!!!!!!  Start of new statement  !!!!!!!!!!!!!!!!!!!
  7105        next:
  7106          statements = statements+1
  7107          compile(startnp) %if np > np0
  7108          define label(curlab) %if dict(curlab)_val < 0
  7109          define label(curlab+1) %if dict(curlab+1)_val < 0
  7110        next1:
  7111          report(faultnum,0,0) %if faultnum # 0
  7112          dlim0 = dlim
  7113          speccing = 0;  subbed = 0
  7114          literal = 0;  jammy = 0;  condop = 0
  7115          dict(curlab)_val = 0;  dict(curlab+1)_val = 0
  7116          np = np0;  startnp = np0
  7117          maxcalldreg = maxdreg;  maxcallareg = maxareg
  7118          zaps = zaps+1 %and forget all %if explo < np0+50
  7119          zaps = zaps+1000 %and forget all %if litpos > litmax-40
  7120          value = 0
  7121        !
  7122        initial(terminator):
  7123          atom = next atom;  matched = 1
  7124          -> initial(atom)
  7125        
  7126        initial(keycomment): initial(exclam): initial(exclam2):
  7127          comments = comments+1
  7128          read line(0)
  7129          -> next1
  7130        term:
  7131          get(terminator)
  7132          -> next
  7133        
  7134        ignore:
  7135          c_access = -1
  7136          %if atom # terminator %start
  7137            %cycle
  7138              subatom = atom;  atom = next atom
  7139            %repeat %until atom = terminator
  7140            starts = starts+1 %if subatom = keystart
  7141            cycles = cycles+1 %if subatom = keycycle
  7142          %finish
  7143          -> next1
  7144        
  7145        initial(dud):
  7146          syntax error;  !ie atom error
  7147        
  7148        initial(*):
  7149          error(nonstarter+point)
  7150        
  7151        initial(ident):
  7152          %if byteintegeR(fp) = ':' %start;  !simple label
  7153            fp = fp+1
  7154            declare(definedlabel)
  7155            set user label(ditem_val)
  7156            ->next
  7157          %finish
  7158          name error %if item <= 0
  7159          %if ditem_mode = labmode %and ditem_type # 0 %start
  7160            literal = 1
  7161            get SWITCH INDEX
  7162            get(colon)
  7163            ->next
  7164          %finish
  7165        initial(keyreturn): initial(keyresult): initial(tf):
  7166        initial(keystop): initial(keysignal): initial(keymonitor):
  7167        initial(exit): initial(keygoto): initial(arrow):
  7168          matched = 0
  7169          get INSTRUCTION
  7170          -> next %if a(terminator)

*    Failed to analyse line  7170
     ->NEXT %IF A(TERMINATOR)
                            !

*    Failed to analyse line  7170
     ->NEXT %IF A(TERMINATOR)
                            !
  7171          c_access = 1
  7172          %if a(iu) %start

*    Failed to analyse line  7172
      %IF A(IU) %START
                 !

*    Failed to analyse line  7172
      %IF A(IU) %START
                 !
  7173            startnp = np
  7174            get CONDITION
  7175          %finish %else %if a(keywhile) %start

* 7175   FAULT 51 %FINISH is not required

* 7175   FAULT 51 %FINISH is not required

*    Failed to analyse line  7175
      %FINISHELSEIF A(KEYWHILE) %START
                                 !

*    Failed to analyse line  7175
      %FINISHELSEIF A(KEYWHILE) %START
                                 !
  7176        {GT: continue fixing else if's from here...}
  7177            putact(repeat,curlab,0);  !append repeat
  7178            startnp = np
  7179            define label(curlab)
  7180            get CONDITION
  7181         %else %if a(keyfor)

* 7181   FAULT 51 %FINISH is not required

* 7181   FAULT 51 %FINISH is not required

*    Failed to analyse line  7181
      %ELSEIF A(KEYFOR)
           !

*    Failed to analyse line  7181
      %ELSEIF A(KEYFOR)
           !
  7182            putact(0,0,0)
  7183            putact(0,0,0)
  7184            putact(repeat,curlab,0);  !append repeat
  7185            startnp = np
  7186            get FOR CLAUSE
  7187            value = np;  np = startnp-3
  7188            %if forinf > 0 %start
  7189              putact(compare,forinf,litref(endval))
  7190              putact(beq,0,curlab)
  7191            %finish %else np = np+2
  7192            putact(repeat,curlab,forinf)
  7193            np = value
  7194          %else
  7195            syntax error %unless a(keyuntil)

*    Failed to analyse line  7195
     SYNTAXERROR %UNLESS A(KEYUNTIL)
                                   !

*    Failed to analyse line  7195
     SYNTAXERROR %UNLESS A(KEYUNTIL)
                                   !
  7196            get CONDITION
  7197            putact(repeat,curlab,0)
  7198            define label(curlab)
  7199          %finish
  7200          -> term
  7201        
  7202        initial(iu):  !%if, %unless
  7203          this is inst
  7204          %cycle
  7205            get CONDITION
  7206            %if a(keythen) %and %not a(keystart) %start

*    Failed to analyse line  7206
      %IF A(KEYTHEN) %ANDNOT A(KEYSTART) %START
                      !

*    Failed to analyse line  7206
      %IF A(KEYTHEN) %ANDNOT A(KEYSTART) %START
                      !
  7207              get INSTRUCTION
  7208            %else

* 7208   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  7204

* 7208   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  7204
  7209              matched = 0;   ![unsee %start]
  7210              get(keystart)
  7211              %cycle
  7212                get(terminator)
  7213                curlab = curlab+2
  7214                get STATEMENTS(keyelse)
  7215                curlab = curlab-2
  7216                %exit %if atom # keyelse;  !%finish ->
  7217                putact(else,curlab+1,curlab)
  7218                -> exit2 %unless a(iu)

*    Failed to analyse line  7218
     ->EXIT2 %UNLESS A(IU)
                         !

*    Failed to analyse line  7218
     ->EXIT2 %UNLESS A(IU)
                         !
  7219                get CONDITION
  7220              %repeat
  7221              -> initial(keyend) %if atom = keyend
  7222            %finish
  7223            -> term %unless a(keyelse)

*    Failed to analyse line  7223
     ->TERM %UNLESS A(KEYELSE)
                             !

*    Failed to analyse line  7223
     ->TERM %UNLESS A(KEYELSE)
                             !
  7224            putact(else,curlab+1,curlab)
  7225          %repeat %until %not a(iu)

* 7225   FAULT  1 %REPEAT is not required

* 7225   FAULT  1 %REPEAT is not required

*    Failed to analyse line  7225
      %REPEATUNTILNOT A(IU)
                          !

*    Failed to analyse line  7225
      %REPEATUNTILNOT A(IU)
                          !
  7226          %unless a(keystart) %start

*    Failed to analyse line  7226
      %UNLESS A(KEYSTART) %START
                           !

*    Failed to analyse line  7226
      %UNLESS A(KEYSTART) %START
                           !
  7227            get INSTRUCTION
  7228          %else

* 7228   FAULT 51 %FINISH is not required

* 7228   FAULT 51 %FINISH is not required
  7229        exit2:
  7230            get(terminator)
  7231            curlab = curlab+2
  7232            get STATEMENTS(keyfinish)
  7233            curlab = curlab-2
  7234            -> initial(keyend) %if atom = keyend
  7235          %finish
  7236          -> term
  7237        
  7238        initial(keycycle):
  7239          this is inst
  7240          %if a(terminator) %start

*    Failed to analyse line  7240
      %IF A(TERMINATOR) %START
                         !

*    Failed to analyse line  7240
      %IF A(TERMINATOR) %START
                         !
  7241            define label(curlab)
  7242            get LOOP BODY
  7243            -> initial(keyend) %if atom = keyend
  7244            get CONDITION %if a(keyuntil)

*    Failed to analyse line  7244
     GETCONDITION %IF A(KEYUNTIL)
                                !

*    Failed to analyse line  7244
     GETCONDITION %IF A(KEYUNTIL)
                                !
  7245            putact(repeat,curlab,0)
  7246            -> term
  7247          %finish

* 7247   FAULT 51 %FINISH is not required

* 7247   FAULT 51 %FINISH is not required
  7248          nonstandard(22)
  7249          get FOR CLAUSE
  7250          -> for1
  7251        initial(keywhile):
  7252          this is inst
  7253          define label(curlab)
  7254          get CONDITION
  7255          get(keycycle)
  7256          get(terminator)
  7257          compile(np0)
  7258          get LOOP BODY
  7259          -> initial(keyend) %if atom = keyend
  7260          nonstandard(6) %and get CONDITION %if a(keyuntil)

*    Failed to analyse line  7260
     NONSTANDARD(6) %AND GETCONDITION %IF A(KEYUNTIL)
                                                    !

*    Failed to analyse line  7260
     NONSTANDARD(6) %AND GETCONDITION %IF A(KEYUNTIL)
                                                    !
  7261          putact(repeat,curlab,0)
  7262          ->term
  7263        initial(keyfor):
  7264          this is inst
  7265          get FOR CLAUSE
  7266          get(keycycle)
  7267        for1:
  7268          get(terminator)
  7269          compile(np0)
  7270          %if forinf > 0 %start;           !Literal for loop
  7271           !%continue must come to end for increment
  7272            loopstart = dict(curlab)_val;  !save start position
  7273            dict(curlab)_val = 0
  7274          %finish
  7275          get LOOP BODY
  7276          -> initial(keyend) %if atom = keyend
  7277          %if forinf > 0 %start;  !literal FOR loop
  7278            define label(curlab)
  7279            dict(curlab)_val = loopstart;  !restore
  7280            putact(compare,forinf,litref(endval))
  7281            putact(beq,0,curlab)
  7282          %finish
  7283          putact(repeat,curlab,forinf)
  7284          -> term
  7285        
  7286        initial(keyon):
  7287          fault(ordererr+point) %if c_status >= hadon %or stopper = 0
  7288          do dynamic arrays %if c_dynarray # 0
  7289          c_status = c_status!hadon
  7290          matched = 1
  7291          allow(keyevent)
  7292          dump = 0
  7293          %cycle
  7294            get LITERAL(inttype)
  7295            expfault(rangerr) %unless 0 <= value <= 15
  7296            dump = dump!1<<value
  7297          %repeat %until %not a(comma)

*    Failed to analyse line  7297
      %REPEATUNTILNOT A(COMMA)
                             !

*    Failed to analyse line  7297
      %REPEATUNTILNOT A(COMMA)
                             !
  7298          get(keystart)
  7299          putact(settrap,0,litref(dump))
  7300          curlab = curlab+2
  7301          get STATEMENTS(keyfinish)
  7302          curlab = curlab-2
  7303          -> initial(keyend) %if atom = keyend
  7304          -> term
  7305        !
  7306        initial(keyelse):
  7307          -> ignore %if starts # 0
  7308          %return %if stopper = keyelse
  7309          error(noif) %if stopper = keyfinish
  7310        initial(keyfinish):
  7311          starts = starts-1 %and -> ignore %if starts # 0
  7312          %return %if stopper = keyfinish %or stopper = keyelse
  7313          error(nostart)
  7314        initial(keyrepeat):
  7315          cycles = cycles-1 %and -> ignore %if cycles # 0
  7316          %return %if stopper = keyrepeat
  7317          error(nocycle)
  7318        
  7319        initial(star):
  7320          fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0
  7321          matched = 1
  7322          %if byteinteger(fp) = '=' %start
  7323            fp = fp+1
  7324            get LITERAL(inttype)
  7325            plant(dc,0,temp(absmode,value))
  7326          %else
  7327            get MCODE
  7328          %finish
  7329          ->term
  7330        
  7331        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  7332        !!!!!!!!!!!!!!!!!!!!  Declarations  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
  7333        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  7334        !
  7335        %routine DECLARE LIT RANGE(%integer basetype,lo,hi)
  7336        %own%record(objinfo) D=0
  7337          fault(boundserr) %and hi = lo %if lo > hi
  7338          item = ranges
  7339          %cycle
  7340            ditem == dict(item)
  7341            item = item-2 %and %return %if ditem_val = hi %and ditem_type = basetype %c
     C                  %and dict(item-1)_val = lo
  7343            item = ditem_hlink
  7344          %repeat %until item = 0
  7345          declare anon(d);               !blank (for updating)
  7346          declare range(basetype,lo,hi)
  7347        %end
  7348        
  7349        %routine DECLARE STRING TYPE(%integer size)
  7350          item = stringtype %and %return %if size = -256
  7351          item = string1 %and %return %if size = -2
  7352          item = ranges
  7353          %cycle
  7354            ditem == dict(item)
  7355            %return %if ditem_size = size %and ditem_type = chartype
  7356            item = ditem_hlink
  7357          %repeat %until item = 0
  7358          declare anon(details(typeid+stringy,chartype,0,0))
  7359          ditem_size = size
  7360          ditem_hlink = ranges;  ranges = item
  7361        %end
  7362        
  7363        %routine GET LIT RANGE(%integer basetype)
  7364        %integer holdval
  7365          get LITERAL(basetype);  holdval = value
  7366          get(colon)
  7367          get LITERAL(basetype)
  7368          declare lit range(basetype,holdval,value)
  7369        %end
  7370        
  7371        %routine GET IDENTLIST(%record(objinfo)%name d)
  7372          dlim0 = dlim
  7373          get(ident) %and declare(d) %until %not a(comma)

*    Failed to analyse line  7373
     GET(IDENT) %AND DECLARE(D) %UNTILNOT A(COMMA)
                                                 !

*    Failed to analyse line  7373
     GET(IDENT) %AND DECLARE(D) %UNTILNOT A(COMMA)
                                                 !
  7374        %end
  7375        
  7376        %routine RECALIGN(%integername val)
  7377          align(val,2)
  7378          val = -val %if val > 4
  7379        %end
  7380        
  7381        %routine GET DECLARATION(%integer FLAGS,MODE,%integer%name DISP,%integer DEPTH)
  7382        %record(objinfo) DECL
  7383        %record(identinfo)%name DFHOLD
  7384        %owninteger ITEMTYPE=0,ITEMSIZE=0,ADIM=0
  7385        %integer BASE,HOLD,MAX,STMAX,DREG,AREG
  7386        
  7387        %routine%spec GET VAR BOUND
  7388        
  7389        %routine GET DATA TYPE
  7390        %switch s(ktype:keyname)
  7391          atom = next atom %if matched # 0
  7392          syntax error %unless kattrib <= atom <= keyname
  7393          matched = 1
  7394          -> s(atom)
  7395        s(ktype):
  7396          itemtype = inttype+subatom
  7397          itemsize = size(itemtype)
  7398          nonstandard(7) %if itemtype >= mitetype
  7399          allow(keyinteger)
  7400          %return
  7401        s(keyinteger):                    !%integer
  7402          itemtype = inttype;  itemsize = 4
  7403          %if a(left) %start

*    Failed to analyse line  7403
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  7403
      %IF A(LEFT) %START
                   !
  7404            nonstandard(8)
  7405            get LIT RANGE(inttype)
  7406            get(right)
  7407            itemtype = item
  7408            itemsize = typecell(itemtype)_size
  7409          %finish

* 7409   FAULT 51 %FINISH is not required

* 7409   FAULT 51 %FINISH is not required
  7410          %return
  7411        s(keylong):                   !%long
  7412          itemtype = inttype;  itemsize = 4;  !**for now**
  7413          %if a(keyinteger) %then fault(notin+point+warn) %c
     C          %else itemtype = realtype %and get(keyreal)

*    Failed to analyse line  7414
      %IF A(KEYINTEGER) %THEN FAULT(NOTIN+POINT+WARN) %ELSE ITEMTYPE=REALTYPE %AND GET(KEYREAL)
                         !

*    Failed to analyse line  7414
      %IF A(KEYINTEGER) %THEN FAULT(NOTIN+POINT+WARN) %ELSE ITEMTYPE=REALTYPE %AND GET(KEYREAL)
                         !
  7415          %return
  7416        s(keyreal):                   !%real
  7417          itemtype = realtype;  itemsize = 4
  7418          %return
  7419        s(keystring):                 !%string
  7420          itemsize = 0
  7421          %if a(left) %start

*    Failed to analyse line  7421
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  7421
      %IF A(LEFT) %START
                   !
  7422            atom = next atom
  7423        !    %if depth # 0 %and ktype <= atom <= keyinteger %start
  7424        !      get VAR BOUND
  7425        !      itemtype = stringstar
  7426        !    %else %if a(star)
  7427             %if a(star) %start

*    Failed to analyse line  7427
      %IF A(STAR) %START
                   !

*    Failed to analyse line  7427
      %IF A(STAR) %START
                   !
  7428              itemtype = stringstar
  7429            %else

* 7429   FAULT 51 %FINISH is not required

* 7429   FAULT 51 %FINISH is not required
  7430              get LITERAL(bytetype)
  7431              itemsize = -(value+1)
  7432              declare string type(itemsize)
  7433              itemtype = item
  7434            %finish
  7435            get(right)
  7436          %else

* 7436   FAULT 51 %FINISH is not required

* 7436   FAULT 51 %FINISH is not required
  7437            syntax error %if mode # constmode
  7438            itemtype = stringtype
  7439          %finish
  7440          %return
  7441        s(keyrecord):                    !%record
  7442          get(left)
  7443          %unless a(star) %start

*    Failed to analyse line  7443
      %UNLESS A(STAR) %START
                       !

*    Failed to analyse line  7443
      %UNLESS A(STAR) %START
                       !
  7444            %unless a(ident) %start

*    Failed to analyse line  7444
      %UNLESS A(IDENT) %START
                        !

*    Failed to analyse line  7444
      %UNLESS A(IDENT) %START
                        !
  7445              declare anon(typeident)
  7446              hold = item;  dfhold == dformat
  7447              dformat == ditem
  7448              get DECLARATION(writable+readable,0,dformat_val,0)
  7449              recalign(dformat_val)
  7450              ditem == dformat
  7451              dformat == dfhold;  item = hold
  7452            %finish

* 7452   FAULT 51 %FINISH is not required

* 7452   FAULT 51 %FINISH is not required
  7453            name error %if item <= 0
  7454            error(classerr+point) %if ditem_flags&(\spec) # typeid+recy
  7455            itemtype = item;  itemsize = ditem_val
  7456          %else

* 7456   FAULT 51 %FINISH is not required

* 7456   FAULT 51 %FINISH is not required
  7457            itemtype = recstar;  itemsize = 0
  7458          %finish
  7459          get(right)
  7460          %return
  7461        s(keyname):    !untyped %name - leave unmatched
  7462          itemtype = 0;  matched = 0
  7463        %end
  7464        
  7465        %routine ASSIGN ADDRESS(%integer size)
  7466        
  7467        %routine ASSIGN STACK ADDRESS
  7468          align(stmax,2);  ditem_val = stmax
  7469          stmax = stmax+imod(size)
  7470          c_status = c_status!onstack %if depth = 1 %and speccing = 0
  7471        %end
  7472        
  7473          size = -4 %if ditem_flags&(name+indirect) # 0
  7474          %if depth # 0 %start
  7475            dlink_link = item;  dlink == ditem
  7476            %if size > 0 %start
  7477             !simple value
  7478              %if dreg > maxcalldreg %start
  7479                assign stack address
  7480                %return
  7481              %finish
  7482              c_reg_content(dreg) = item %if speccing = 0
  7483              ditem_reg = dreg-d0;  dreg = dreg+1
  7484            %else
  7485              %if areg > maxcallareg %start
  7486                assign stack address
  7487                ditem_reg = 8     {would have been in AREG}
  7488                %return
  7489              %finish
  7490              c_reg_content(areg) = item+ad %if speccing = 0 %and ditem_flags < 0
  7491              ditem_reg = areg-d0;  areg = areg+1
  7492            %finish
  7493          %finish
  7494          size = imod(size)
  7495          align(disp,size)
  7496          ditem_val = disp
  7497          %if constmode # ditem_mode # ownmode %start
  7498            disp = disp+size
  7499            %if ditem_mode >= framemode %start
  7500              align(disp,2)
  7501              ditem_val = c_sp-disp;  !neg stack disp.
  7502            %finish
  7503          %finish
  7504        %end
  7505        !
  7506        %routine GET QIDENT
  7507          get(ident)
  7508          %if mode = 0 %start;  !within record format
  7509            head == dformat_link;  item = head
  7510            %if item > 0 %start
  7511              %cycle
  7512                ditem == dict(item)
  7513                fault(duperr+point) %if string(ditem_text+char0) = string(charlim)
  7514                head == ditem_hlink;  item = head
  7515              %repeat %until item <= 0
  7516            %finish
  7517          %finish
  7518          declare(decl)
  7519        %end
  7520        
  7521        !<<BOTH
  7522        %routine DUMP CONST(%integer v,n)
  7523        ! Plant N replications of value V (of type ITEMTYPE and size ITEMSIZE)
  7524        ! For simple operand V is value, otherwise V is address in FINAL
  7525        ! Alignment requirement has been enforced (since it depends on context)
  7526        %integer i,j,k,kk,vv
  7527          k = itemsize
  7528          %if k <= 0 %start;  !structure
  7529            k = -k
  7530            k = final(v)+1 %if k = 0;  ![string]
  7531            cad = v %if v # 0;  !reset cad
  7532          %finish
  7533          kk = k
  7534          %return %if n < 1
  7535          kk = kk*n %if n > 1
  7536          %if mode = constmode %start
  7537            i = cad;  cad = cad+kk
  7538            croak("Program too big") %if cad >= ownbase
  7539          %else
  7540            %if ownbase+ownad+kk-finalbound > 0 %start
  7541              make room(ownbase+ownad+kk-finalbound)
  7542            %finish
  7543            i = ownbase+ownad;  ownad = ownad+kk
  7544          %finish
  7545          %if itemsize <= 0 %start
  7546            %while n > 0 %cycle
  7547              n = n-1;  j = i+k
  7548              %if v # 0 %start
  7549                vv = v
  7550                %cycle
  7551                  final(i) = final(vv)
  7552                  i = i+1;  vv = vv+1
  7553                %repeat %until i =j
  7554              %else
  7555                final(i) = 0 %and i = i+1 %while i < j
  7556              %finish
  7557            %repeat
  7558          %else
  7559        !$IF VAX
  7560        {    v = ieee(v) %if itemtype = realtype;  !vax->ieee
  7561        !$FINISH
  7562            %while n > 0 %cycle
  7563              n = n-1
  7564              %if itemsize >= 2 %start
  7565                %if itemsize > 2 %start;  !longword
  7566                  final(i) <- v>>24
  7567                  final(i+1) <- v>>16
  7568                  i = i+2
  7569                %finish
  7570                final(i) <- v>>8
  7571                i = i+1
  7572              %finish
  7573              final(i) <- v
  7574              i = i+1
  7575            %repeat
  7576          %finish
  7577        %end;  !dump const
  7578        !<<IMP
  7579        
  7580        %routine GET VAR BOUND
  7581        %integer f
  7582          f = decl_flags
  7583          get DATA TYPE
  7584          decl_flags = okflag+mflag;  decl_type = itemtype
  7585          get(ident);  declare(decl)
  7586          decl_flags = f
  7587          assign address(itemsize)
  7588        %end
  7589        
  7590        %routine DECLARE BOUND(%integer mode,val)
  7591          declare anon(details(okflag,inttype,mode,val))
  7592          %if depth # 0 %and mode >= framemode %start
  7593            ditem_flags = ditem_flags!mflag
  7594            assign address(4)
  7595          %finish
  7596        %end
  7597        
  7598        %routine GET ARRAY DECLARATION(%integer dim)
  7599        %integer pos,dlim1,holdval,holdz,jam,elements,tot,totsize,lo1,size1
  7600        %record(identinfo)%name dp
  7601        %ownrecord(objinfo) ATYPE=0
  7602        
  7603        %integer%fn XTYPE
  7604          declare anon(details(typeid,inttype,0,0))
  7605          %result = item
  7606        %end
  7607        
  7608        %routine STRING STAR ARRAY
  7609          fault(notin+point) %if depth = 0
  7610         ! VAR for size
  7611          declare anon(details(okflag+mflag+inty,inttype,mode,0))
  7612          tot = item
  7613          assign address(4)
  7614         ! TYPEID for string(*)
  7615          declare anon(details(typeid+stringy,inttype,0,0))
  7616          atype_type = item
  7617          elements = maxint
  7618        %end
  7619        
  7620        %routine GET REST
  7621        %integer e,r,lo,loval,hi,hival
  7622          r = 0
  7623          atom = next atom %if matched # 0
  7624          %if decl_flags < 0 %start;  !%array%name
  7625            %if depth > 0 %and ktype <= atom <= keyinteger %start;  !variable
  7626              r = xtype;  get VAR BOUND
  7627            %else
  7628              get LITERAL(inttype)
  7629            %finish
  7630          %else;                   !%array
  7631            get VALUE(inttype)
  7632          %finish
  7633          loval = value;  lo = item
  7634          loval = minint %if lo # 0
  7635          get(colon)
  7636          atom = next atom %if matched # 0
  7637          %if decl_flags < 0 %start
  7638            %if depth > 0 %and ktype <= atom <= keyinteger %start;  !variable
  7639              %if r = 0 %start
  7640                r = xtype;  declare bound(litmode,loval)
  7641              %finish
  7642              get VAR BOUND
  7643            %else
  7644              %if dim!r = 0 %and a(star) %start

*    Failed to analyse line  7644
      %IF DIM!R=0 %AND A(STAR) %START
                                !

*    Failed to analyse line  7644
      %IF DIM!R=0 %AND A(STAR) %START
                                !
  7645                item = 0;  value = maxint
  7646              %else
  7647                get LITERAL(inttype)
  7648                declare bound(litmode,value) %if r # 0
  7649              %finish
  7650            %finish
  7651          %else

* 7651   FAULT 51 %FINISH is not required

* 7651   FAULT 51 %FINISH is not required
  7652            get VALUE(inttype)
  7653          %finish
  7654          hival = value;  hi = item
  7655          hival = maxint %if hi # 0
  7656          e = maxint
  7657          %if r = 0 %start;  !no range yet declared
  7658            %if lo!hi = 0 %start
  7659              e = hival-loval %if hival!!loval >= 0 %or minint+hival-loval < 0
  7660              e = e+1 %if e # maxint
  7661              e = 0 %if hival = maxint
  7662              declare lit range(inttype,loval,hival)
  7663            %else
  7664              declare anon(typeident);               !blank (for updating)
  7665              declare range(inttype,loval,hival)
  7666            %finish
  7667            r = item
  7668          %finish
  7669          elements = e
  7670          %if a(comma) %start

*    Failed to analyse line  7670
      %IF A(COMMA) %START
                    !

*    Failed to analyse line  7670
      %IF A(COMMA) %START
                    !
  7671            dim = dim+1
  7672            get REST
  7673            %if elements # maxint %and e # maxint %start
  7674              elements = elements*e
  7675            %else
  7676              elements = maxint
  7677            %finish
  7678          %finish

* 7678   FAULT 51 %FINISH is not required

* 7678   FAULT 51 %FINISH is not required
  7679          atype_xtype = r
  7680          size1 = totsize;  lo1 = loval;       !for outer dimension
  7681          string star array %if atype_type = stringstar
  7682          %if elements = maxint %start;             !non-literal bounds
  7683            atype_mode = mode
  7684            declare anon(atype)
  7685            atype_type = item;          !save type id
  7686            %if decl_flags >= 0 %or (depth = 1 %and speccing = 0) %start
  7687              lo = litref(loval) %if lo = 0
  7688              hi = litref(hival) %if hi = 0
  7689              tot = litref(totsize) %if tot = 0
  7690              putact(asize,item,tot)
  7691              putact(0,lo,hi)
  7692              %if decl_flags >= 0  %start
  7693                compile(np0)
  7694                dict(r+1)_mode = c_mode %and dict(r+1)_val = c_sp+4 %if lo > 0
  7695                dict(r+2)_mode = c_mode %and dict(r+2)_val = c_sp %if hi > 0
  7696              %finish
  7697            %finish
  7698            tot = 0;  totsize = 0
  7699          %else;  !literal bounds
  7700            item = 0
  7701            %cycle
  7702              ditem == dict(item)
  7703              %exit %if ditem_type = atype_type %and ditem_xtype = atype_xtype %c
     C                    %and ditem_flags = atype_flags
  7705              item = item+1
  7706              %if item = dlim %start
  7707                declare anon(atype)
  7708                %exit
  7709              %finish
  7710            %repeat
  7711            atype_type = item
  7712            totsize = totsize*e
  7713          %finish
  7714        %end;  !get REST
  7715        
  7716        %routine PUT BOUNDS
  7717        %integer i
  7718          i = xtype;                         !index type
  7719          declare bound(mode,0);             !lower
  7720          declare bound(mode,0);             !upper
  7721          dim = dim-1
  7722          put bounds %if dim > 0
  7723          string star array %if atype_type = stringstar
  7724          atype_xtype = i
  7725          declare anon(atype);                  !array type
  7726          %if speccing = 0 %start
  7727            tot = litref(totsize) %if tot = 0
  7728            putact(asize,item,tot)
  7729            putact(0,i+1,i+2)
  7730          %finish
  7731          tot = 0;  totsize = 0;  lo1 = minint
  7732          atype_type = item
  7733        %end
  7734        
  7735          pos = dlim0;  dlim1 = dlim;  dp == ditem
  7736          atype_flags = typeid+arry+okflag;  atype_type = itemtype
  7737          %if atype_type < 0 %start;  !element %name
  7738            atype_flags = atype_flags+name;  atype_type = atype_type-name
  7739          %finish
  7740          atype_mode = constmode;   !by default (literal bounds)
  7741          tot = 0;  totsize = imod(itemsize)
  7742          %if dim > 0 %start;  !%array(n)%name
  7743            atype_mode = mode
  7744            put bounds
  7745            elements = maxint
  7746          %else;  !left parenthesis recognised
  7747            get REST
  7748            get(right)
  7749          %finish
  7750          dp_type = atype_type
  7751          %if mode # constmode %and mode # ownmode %start
  7752            holdval = d0
  7753            %while pos # dlim1 %cycle
  7754              dp == dict(pos)
  7755              dp_type = atype_type
  7756              %if mode >= framemode %start
  7757                dp_flags = dp_flags!arrflag %if lo1 = minint %or size1 = 0
  7758                %if decl_flags >= 0 %start;  !%array not %array%name
  7759                  %if totsize # 0 {all literal bounds} %c
     C                  %and totsize<<1-c_sp+disp <= 32000 %start
  7761                    !if array will occupy less than half remaining reach
  7762                    !then allocate directly on stack
  7763                    disp = disp+totsize
  7764                    align(disp,2)
  7765                  %else
  7766                    fault(ordererr) %if c_mode&2_01000000 # 0; !hard order error
  7767                    %if totsize # 0 %start;  !known bounds but too big
  7768                      c_extra = c_extra+totsize
  7769                      holdval = litref(totsize)
  7770                    %finish
  7771                    ![ADOK updates C_SP]
  7772                    holdz = 0;  holdz = litref(-lo1*size1) %if dp_flags&arrflag = 0
  7773                    putact(adok,holdval,holdz);  !compute & store space needed
  7774                    compile(np0)
  7775                    dp_flags = dp_flags+indirect
  7776                    dp_link = c_dynarray
  7777                    c_dynarray = pos;  c_dynarray = -c_dynarray %if holdz # 0
  7778                    c_status = c_status!unknown
  7779                    holdval = 0
  7780                  %finish
  7781                  dp_val = c_sp-disp
  7782                %finish
  7783              %else { %if decl_flags >= 0};  !record field or absolute
  7784                                          !** to be corrected **
  7785                                          !name already allocated
  7786        {        dp_val = disp;  disp = disp+totsize}
  7787                dp_val = disp
  7788                %if decl_flags < 0 %then disp = disp+4 %else disp = disp+totsize
  7789              %finish
  7790              pos = pos+1
  7791            %repeat
  7792          %else;                           !const,own
  7793            %if decl_flags&(name+indirect) # 0 %start
  7794              %if mode = constmode %then fill code(4) %else fill own(4)
  7795            %else
  7796              %if a assop(itemtype) %start

*    Failed to analyse line  7796
      %IF AASSOP(ITEMTYPE) %START
                            !

*    Failed to analyse line  7796
      %IF AASSOP(ITEMTYPE) %START
                            !
  7797                jam = jammy
  7798                dp_flags = dp_flags!okflag;  ![hum]
  7799                allow(terminator)
  7800                %cycle
  7801                  jammy = jam
  7802                  get VALUE(itemtype)
  7803                  faultnum = rangerr+point+warn %if faultnum = rangerr+point
  7804                  holdval = value
  7805                  value = 1
  7806                  %if a(left) %start

*    Failed to analyse line  7806
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  7806
      %IF A(LEFT) %START
                   !
  7807                    value = elements
  7808                    get LITERAL(halftype) %unless a(star)

*    Failed to analyse line  7808
     GETLITERAL(HALFTYPE) %UNLESS A(STAR)
                                        !

*    Failed to analyse line  7808
     GETLITERAL(HALFTYPE) %UNLESS A(STAR)
                                        !
  7809                    get(right)
  7810                  %finish

* 7810   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  7800

* 7810   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  7800
  7811                  elements = elements-value
  7812                  value = value+elements %if elements < 0
  7813                  dump const(holdval,value)
  7814                %repeat %until %not a(comma)

* 7814   FAULT 52 %REPEAT instead of %FINISH for %START at line  7795

* 7814   FAULT 52 %REPEAT instead of %FINISH for %START at line  7795

*    Failed to analyse line  7814
      %REPEATUNTILNOT A(COMMA)
                             !

*    Failed to analyse line  7814
      %REPEATUNTILNOT A(COMMA)
                             !
  7815                %if faultnum = 0 %and elements # 0 %start
  7816                  %if elements < 0 %then report(counterr,pos,elements) %c
     C                  %else report(counterr+warn,pos,elements)
  7818                %finish
  7819              %finish
  7820              dump const(0,elements) %if elements > 0
  7821            %finish

* 7821   FAULT 51 %FINISH is not required

* 7821   FAULT 51 %FINISH is not required
  7822          %finish

* 7822   FAULT 51 %FINISH is not required

* 7822   FAULT 51 %FINISH is not required
  7823        %end;  !get ARRAY DECLARATION
  7824        !
  7825        %routine GET PROCEDURE DECLARATION
  7826        %integer pos,dlim1,argmode,argad,restype,stack
  7827        %record(identinfo)%name headditem,dhold
  7828        
  7829        %integerfn DUPOK
  7830        !Check that the proc being declared can reasonably alias existing id
  7831        %record(identinfo)%name tp
  7832          %result = FALSE %if ditem_flags&proc = 0
  7833          tp == typecell(ditem_type)
  7834          %if restype = 0 %start;  !routine
  7835            %result = FALSE %if tp_type # 0 %or tp_link = 0; !not routine, or no pars
  7836          %else
  7837            %result = FALSE %if restype = tp_type;  !function of same type
  7838          %finish
  7839          %result = TRUE
  7840        %end
  7841        
  7842          restype = itemtype
  7843          stack = 0;  !unknown
  7844          decl_flags = decl_flags&(\okflag)
  7845          decl_type = procstar;             !by default
  7846          %if depth # 0 %start;             !procedure as param
  7847            decl_flags = decl_flags!proc2;  ![must push MB in case external]
  7848          %else %if mode >= framemode

*    Failed to analyse line  7848
      %ELSEIF MODE>=FRAMEMODE
           !

*    Failed to analyse line  7848
      %ELSEIF MODE>=FRAMEMODE
           !
  7849            decl_mode = procmode;  decl_val = 0
  7850            decl_flags = decl_flags!proc1
  7851            decl_flags = decl_flags!spec %if a(keyspec)

*    Failed to analyse line  7851
     DECL_FLAGS=DECL_FLAGS!SPEC %IF A(KEYSPEC)
                                             !

*    Failed to analyse line  7851
     DECL_FLAGS=DECL_FLAGS!SPEC %IF A(KEYSPEC)
                                             !
  7852          %else %if mode = ownmode;               !external (not @)

*    Failed to analyse line  7852
      %ELSEIF MODE=OWNMODE;
           !

*    Failed to analyse line  7852
      %ELSEIF MODE=OWNMODE;
           !
  7853            decl_mode = procmode;  decl_val = 0
  7854            %if a(keyspec) %start

*    Failed to analyse line  7854
      %IF A(KEYSPEC) %START
                      !

*    Failed to analyse line  7854
      %IF A(KEYSPEC) %START
                      !
  7855              decl_mode = ownmode;  decl_flags = decl_flags!spec
  7856            %finish
  7857          %else;   !@...

* 7857   FAULT 51 %FINISH is not required

* 7857   FAULT 51 %FINISH is not required
  7858            decl_flags = decl_flags!proc1
  7859            decl_val = disp
  7860            stack = 4
  7861          %finish
  7862          %if decl_flags&ext # 0 %and a(keyalias) %start

*    Failed to analyse line  7862
      %IF DECL_FLAGS&EXT#0 %AND A(KEYALIAS) %START
                                             !

*    Failed to analyse line  7862
      %IF DECL_FLAGS&EXT#0 %AND A(KEYALIAS) %START
                                             !
  7863            nonstandard(9)
  7864            get(ident)
  7865            %if item <= 0 %start
  7866              fault(namerr+point)
  7867            %else
  7868              item = 0 %and decl_flags = decl_flags!alt %if dupok

*    Failed to analyse line  7868
     ITEM=0 %AND DECL_FLAGS=DECL_FLAGS!ALT %IF DUPOK
                                                   !

*    Failed to analyse line  7868
     ITEM=0 %AND DECL_FLAGS=DECL_FLAGS!ALT %IF DUPOK
                                                   !
  7869            %finish
  7870          %else

* 7870   FAULT 51 %FINISH is not required

* 7870   FAULT 51 %FINISH is not required
  7871            get(ident)
  7872          %finish
  7873          declare(decl)
  7874          headditem == ditem
  7875          assign address(-6) %if depth # 0
  7876          argmode = c_mode&(\2_01000000)+1
  7877          %if decl_flags&spec # 0 %or decl_mode # procmode %start
  7878            speccing = speccing+1
  7879          %else
  7880            c_forward = c_forward-1 %if ditem_flags&rflag # 0
  7881            open block(item)
  7882            c_type = restype
  7883            c_type = c_type!sign16 %if decl_flags&writable # 0 {%map}
  7884          %finish
  7885          dlim1 = dlim
  7886          declare anon(details(0,restype,0,stack))
  7887         ! Result in A0 for %map or structure %fn
  7888          ditem_reg = 8 %if decl_flags&writable # 0 {%map} %C
     C                        %or size(restype) <= 0 {structure %fn}
  7890        !Declare parameters
  7891          argad = c_sp;     !ok for both spec and body
  7892          %if a(left) %start

*    Failed to analyse line  7892
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  7892
      %IF A(LEFT) %START
                   !
  7893            dhold == dlink;  dlink == ditem
  7894            get DECLARATION(okflag+writable+readable,argmode,argad,1)
  7895            dlink == dhold
  7896            get(right)
  7897          %finish

* 7897   FAULT 51 %FINISH is not required

* 7897   FAULT 51 %FINISH is not required
  7898          %if speccing # 0 %start
  7899            speccing = speccing-1
  7900            pos = crunched(dlim1)
  7901            %if pos < dlim1 %or speccing = 0 %start
  7902              headditem_type = pos
  7903            %else;                    !proc as param
  7904              fault(classerr);  dlim = dlim1
  7905            %finish
  7906          %else;                        !procedure body
  7907            %if c_dpid_flags&spec # 0 %start
  7908              c_dpid_flags = c_dpid_flags-spec
  7909              %unless parmatch(c_dpid_type,dlim1) %start

*    Failed to analyse line  7909
      %UNLESS PARMATCH(C_DPID_TYPE,DLIM1) %START
                                           !

*    Failed to analyse line  7909
      %UNLESS PARMATCH(C_DPID_TYPE,DLIM1) %START
                                           !
  7910                %if c_pid = dlim1-2 %then fault(matcherr+warn) %c
     C                %else fault(matcherr)
  7912              %finish
  7913            %finish
  7914            headditem_type = dlim1
  7915            c_parlim = dlim
  7916            c_sp = -argad
  7917            compile(np0)
  7918            get(terminator)
  7919            get STATEMENTS(keyend)
  7920          %finish

* 7920   FAULT 51 %FINISH is not required

* 7920   FAULT 51 %FINISH is not required
  7921        %end;  !get procedure declaration
  7922        
  7923        %routine GET INITIAL VALUE(%record(identinfo)%name dp)
  7924        %integer present=0

*    Failed to analyse line  7924
      %INTEGER PRESENT=0
                      !

*    Failed to analyse line  7924
      %INTEGER PRESENT=0
                      !
  7925          jammy = 0
  7926          %if a assop(itemtype) %start

*    Failed to analyse line  7926
      %IF AASSOP(ITEMTYPE) %START
                            !

*    Failed to analyse line  7926
      %IF AASSOP(ITEMTYPE) %START
                            !
  7927            get VALUE(itemtype)
  7928            dp_flags = dp_flags!okflag
  7929            present = 1
  7930          %finish

* 7930   FAULT 51 %FINISH is not required

* 7930   FAULT 51 %FINISH is not required
  7931          %if mode >= framemode %start;  !dynamic
  7932            %if present # 0 %start
  7933              atomp = expp %and nonstandard(1) %if item # 0
  7934              %if itemtype < 0 %start
  7935                putact(okass,dlim0+ad,normitem)
  7936              %else
  7937                putact(okass+jammy,dlim0,normitem)
  7938              %finish
  7939              compile(np0)
  7940            %finish
  7941          %else %if mode = constmode

*    Failed to analyse line  7941
      %ELSEIF MODE=CONSTMODE
           !

*    Failed to analyse line  7941
      %ELSEIF MODE=CONSTMODE
           !
  7942            syntax error %if present = 0
  7943            %if itemtype < 0 %start;  !name
  7944              dp_flags = writable+readable
  7945              dp_mode = absmode;  dp_val = value
  7946            %else
  7947              faultnum = rangerr+point+warn %if faultnum = rangerr+point
  7948              %if itemsize <= 0 %then dump const(value,1) %c
     C              %else dp_mode = litmode %and dp_val = value
  7950            %finish
  7951          %else;  !own
  7952            %if present # 0 %start
  7953              faultnum = rangerr+point+warn %if faultnum = rangerr+point
  7954              dump const(value,1)
  7955            %else
  7956              %if itemtype < 0 %then fill own(4) %else fill own(imod(itemsize))
  7957            %finish
  7958          %finish
  7959        %end;  !get initial value
  7960        
  7961        dreg = d0;  areg = a0;  stmax = 8;  !allow for RETAD & LINK
  7962        max = 0;  base = disp
  7963        %cycle
  7964          disp = base
  7965          %cycle
  7966            decl = 0
  7967            decl_flags = flags;  decl_mode = mode
  7968            adim = -1
  7969            %while a(kattrib) %cycle

*    Failed to analyse line  7969
      %WHILE A(KATTRIB) %CYCLE
                         !

*    Failed to analyse line  7969
      %WHILE A(KATTRIB) %CYCLE
                         !
  7970              decl_flags = decl_flags!!(1<<subatom)
  7971            %repeat
  7972            %if depth = 0 %and a(left) %start;  !start of sub-group

*    Failed to analyse line  7972
      %IF DEPTH=0 %AND A(LEFT) %START ;
                                !

*    Failed to analyse line  7972
      %IF DEPTH=0 %AND A(LEFT) %START ;
                                !
  7973              align(disp,2)
  7974        !      ad_cat = ad_cat+1 %if mode = 0
  7975              get DECLARATION(flags,mode,disp,0);  get(right)
  7976        !      ad_cat = ad_cat-1 %if mode = 0
  7977            %else %if a(rpred);  !%routine,(%predicate)

* 7977   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  7963

* 7977   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  7963

*    Failed to analyse line  7977
      %ELSEIF A(RPRED);
           !

*    Failed to analyse line  7977
      %ELSEIF A(RPRED);
           !
  7978              %if subatom # 0 %start;  !pred
  7979                decl_flags = decl_flags&(\(writable))
  7980                decl_flags = decl_flags!volatile %if control&volbit # 0
  7981                itemtype = booltype
  7982              %else
  7983                decl_flags = decl_flags&(\(writable+readable))
  7984                itemtype = 0
  7985              %finish
  7986              get PROCEDURE DECLARATION
  7987              %return %if depth = 0
  7988            %else
  7989              get DATA TYPE
  7990              !Appendages
  7991              %if a(fnmap) %start;  !%fn, %map

*    Failed to analyse line  7991
      %IF A(FNMAP) %START ;
                    !

*    Failed to analyse line  7991
      %IF A(FNMAP) %START ;
                    !
  7992                decl_flags = decl_flags!volatile %if control&volbit # 0
  7993                %if subatom = 0 %start
  7994                  decl_flags = decl_flags&(\writable)
  7995                  fault(illstarred) %if itemsize = 0
  7996                %finish
  7997                get PROCEDURE DECLARATION
  7998                %return %if depth = 0
  7999              %else
  8000                decl_flags = decl_flags&(\proc)
  8001                decl_type = itemtype
  8002                %if a(keyname) %start

*    Failed to analyse line  8002
      %IF A(KEYNAME) %START
                      !

*    Failed to analyse line  8002
      %IF A(KEYNAME) %START
                      !
  8003                  decl_flags = decl_flags+name;  itemtype = itemtype+name
  8004                  itemsize = 4
  8005                %finish
  8006                %if a(keyarray) %start

*    Failed to analyse line  8006
      %IF A(KEYARRAY) %START
                       !

*    Failed to analyse line  8006
      %IF A(KEYARRAY) %START
                       !
  8007                  fault(illstarred) %if itemtype = recstar;  !%record(*)%array
  8008                  adim = 0
  8009                 ! ITEMTYPE now reflects element type (+name)
  8010                 ! DECL is for the array itself
  8011                  decl_flags = decl_flags&(\name)
  8012                  decl_type = arrstar
  8013                  decl_flags = decl_flags!arrflag %if control&arrbit # 0
  8014                  %if a(left) %start

*    Failed to analyse line  8014
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  8014
      %IF A(LEFT) %START
                   !
  8015                    fault(notin+point) %if depth = 0
  8016                    get LITERAL(inttype)
  8017                    %if value&(\7) # 0 %then expfault(rangerr) %else adim = value
  8018                    get(right)
  8019                    get(keyname);  matched = 0
  8020                  %finish

* 8020   FAULT 51 %FINISH is not required

* 8020   FAULT 51 %FINISH is not required
  8021                 ! %array%name versus %array
  8022                  decl_flags = decl_flags+name %if a(keyname)

*    Failed to analyse line  8022
     DECL_FLAGS=DECL_FLAGS+NAME %IF A(KEYNAME)
                                             !

*    Failed to analyse line  8022
     DECL_FLAGS=DECL_FLAGS+NAME %IF A(KEYNAME)
                                             !
  8023                %finish

* 8023   FAULT 51 %FINISH is not required

* 8023   FAULT 51 %FINISH is not required
  8024               ! %record(*) or %string(*) needs %name (or @)
  8025               ! %string alone allowed only for %const%string
  8026                fault(illstarred) %if itemsize = 0 %c
     C                                  %and decl_flags >= 0 %and disp ## jokerad %c
     C                                  %and decl_type # stringtype {const}
  8029                %if disp == c_val %start;  !main declaration
  8030                  fault(notinblock) %if stopper = 0
  8031                  %if c_status >= hadon %start
  8032                    %if c_forward!c_return # 0 %or curlab # c_lab1 %start
  8033                      fault(ordererr)
  8034                    %else %if c_status&hadordererr = 0

*    Failed to analyse line  8034
      %ELSEIF C_STATUS&HADORDERERR=0
           !

*    Failed to analyse line  8034
      %ELSEIF C_STATUS&HADORDERERR=0
           !
  8035                      fault(ordererr+warn);  c_status = c_status+hadordererr
  8036                    %finish
  8037                  %finish
  8038                %else %if decl_flags&ext # 0 %and a(keyspec)

*    Failed to analyse line  8038
      %ELSEIF DECL_FLAGS&EXT#0 %AND A(KEYSPEC)
           !

*    Failed to analyse line  8038
      %ELSEIF DECL_FLAGS&EXT#0 %AND A(KEYSPEC)
           !
  8039                  decl_flags = decl_flags!(spec+indirect)
  8040                %finish
  8041               !Read identifier list
  8042                %cycle
  8043                  dlim0 = dlim
  8044                  %unless decl_type = arrstar %start;  !not array
  8045                    get QIDENT
  8046                    assign address(itemsize)
  8047                    %if mode >= ownmode %and depth = 0 %start
  8048                      %if decl_flags&spec = 0 %then get INITIAL VALUE(ditem) %c
     C                      %else set own word(0) %and set own word(0)
  8050                    %finish
  8051                  %else
  8052                    %cycle
  8053                      get QIDENT
  8054                      assign address(0);  !(4 if name)
  8055                      %exit %unless a(comma)

*    Failed to analyse line  8055
      %EXITUNLESS A(COMMA)
                         !

*    Failed to analyse line  8055
      %EXITUNLESS A(COMMA)
                         !
  8056                      atom = next atom
  8057                      %if atom # ident %start;  !ie new type
  8058                        %if adim = 0 %start;    !treat %array%name as %array(1)%name
  8059                          syntax error %if decl_flags >= 0
  8060                          adim = 1
  8061                        %finish
  8062                        get ARRAY DECLARATION(adim)
  8063                        -> exit22
  8064                      %finish
  8065                    %repeat
  8066                    %if adim # 0 %or %not a(left) %start

*    Failed to analyse line  8066
      %IF ADIM#0 %ORNOT A(LEFT) %START
                                 !

*    Failed to analyse line  8066
      %IF ADIM#0 %ORNOT A(LEFT) %START
                                 !
  8067                       %if adim = 0 %start
  8068                         syntax error %if decl_flags >= 0
  8069                         adim = 1
  8070                       %finish
  8071                       get ARRAY DECLARATION(adim)
  8072                       -> exit2
  8073                    %finish
  8074                    get ARRAY DECLARATION(adim)
  8075                  %finish

* 8075   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  8042

* 8075   FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line  8042
  8076                  -> exit2 %unless a(comma)

*    Failed to analyse line  8076
     ->EXIT2 %UNLESS A(COMMA)
                            !

*    Failed to analyse line  8076
     ->EXIT2 %UNLESS A(COMMA)
                            !
  8077                  atom = next atom
  8078                %repeat %until atom # ident

* 8078   FAULT  1 %REPEAT is not required

* 8078   FAULT  1 %REPEAT is not required
  8079        exit22:
  8080                %continue
  8081              %finish

* 8081   FAULT 51 %FINISH is not required

* 8081   FAULT 51 %FINISH is not required
  8082            %finish

* 8082   FAULT 51 %FINISH is not required

* 8082   FAULT 51 %FINISH is not required
  8083            %exit %unless a(comma);  ![NB %continue above]

*    Failed to analyse line  8083
      %EXITUNLESS A(COMMA);
                          !

*    Failed to analyse line  8083
      %EXITUNLESS A(COMMA);
                          !
  8084          %repeat

* 8084   FAULT  1 %REPEAT is not required

* 8084   FAULT  1 %REPEAT is not required
  8085        exit2:
  8086          max = disp %if disp > max
  8087        %repeat %until %not a(keyor)

* 8087   FAULT  1 %REPEAT is not required

* 8087   FAULT  1 %REPEAT is not required

*    Failed to analyse line  8087
      %REPEATUNTILNOT A(KEYOR)
                             !

*    Failed to analyse line  8087
      %REPEATUNTILNOT A(KEYOR)
                             !
  8088        disp = max
  8089        %end;  !get declaration
  8090        
  8091        initial(keyconst):
  8092          literal = 1
  8093          get DECLARATION(okflag+readable,constmode,cad,0)
  8094          -> term
  8095        
  8096        initial(atsign):
  8097          dump = 0
  8098        atted:
  8099          fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0
  8100          get LITERAL(inttype)
  8101          jokerad = value
  8102          %if a(left) %start

*    Failed to analyse line  8102
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  8102
      %IF A(LEFT) %START
                   !
  8103            get MIDENT(a0,a7)
  8104            get(right)
  8105            value = item+(dispmode-a0)
  8106          %finish %else value = absmode

* 8106   FAULT 51 %FINISH is not required

* 8106   FAULT 51 %FINISH is not required
  8107          literal = 1
  8108          get DECLARATION(dump!(okflag+writable+readable),value,jokerad,0)
  8109          -> term
  8110        
  8111        initial(keyown):
  8112          literal = 1
  8113          get DECLARATION(writable+readable,ownmode,ownad,0)
  8114          -> term
  8115        
  8116        initial(keyext):
  8117          fault(ordererr) %if level # outerlevel
  8118          literal = 1
  8119          dump = subatom<<12
  8120          -> atted %if a(atsign)

*    Failed to analyse line  8120
     ->ATTED %IF A(ATSIGN)
                         !

*    Failed to analyse line  8120
     ->ATTED %IF A(ATSIGN)
                         !
  8121          %if a(left) %start

*    Failed to analyse line  8121
      %IF A(LEFT) %START
                   !

*    Failed to analyse line  8121
      %IF A(LEFT) %START
                   !
  8122            get LITERAL(inttype);  get(right)
  8123            maxcalldreg = (d0-1)+value&15
  8124            maxcallareg = (a0-1)+value>>4&15
  8125            dump = dump!!(value&(\255))
  8126          %finish

* 8126   FAULT 51 %FINISH is not required

* 8126   FAULT 51 %FINISH is not required
  8127          get DECLARATION(dump!(writable+readable),ownmode,ownad,0)
  8128          -> term
  8129        
  8130        initial(keyrecord):
  8131          %unless a(left) %start

*    Failed to analyse line  8131
      %UNLESS A(LEFT) %START
                       !

*    Failed to analyse line  8131
      %UNLESS A(LEFT) %START
                       !
  8132            get(keyformat)
  8133            %if a(keyspec) %start

*    Failed to analyse line  8133
      %IF A(KEYSPEC) %START
                      !

*    Failed to analyse line  8133
      %IF A(KEYSPEC) %START
                      !
  8134              typeident_flags = typeid+spec+recy
  8135              get(ident);  declare(typeident)
  8136            %else

* 8136   FAULT 51 %FINISH is not required

* 8136   FAULT 51 %FINISH is not required
  8137              typeident_flags = typeid+recy
  8138              get(ident);  declare(typeident)
  8139              get(left)
  8140              dformat == ditem
  8141              get DECLARATION(writable+readable,0,dformat_val,0)
  8142              recalign(dformat_val)
  8143              get(right)
  8144            %finish
  8145            -> term
  8146          %finish

* 8146   FAULT 51 %FINISH is not required

* 8146   FAULT 51 %FINISH is not required
  8147          fp = fp-1;  atom = keyrecord;  !back-up
  8148        initial(ktype): initial(keylong):
  8149        initial(keyinteger): initial(keyreal):
  8150        initial(kattrib): initial(keystring):
  8151        initial(rpred):
  8152          matched = 0
  8153          get DECLARATION(writable+readable,c_mode,c_val,0)
  8154          -> term
  8155        
  8156        initial(keylabel):
  8157          get IDENTLIST(forwardlabel)
  8158          -> term
  8159        
  8160        %routine GET SWITCH DECLARATION
  8161        %integer i,lo,hi,dlim1
  8162        %ownrecord(objinfo) d=0
  8163          matched = 1
  8164          %cycle
  8165            d_type = arrstar;  !(in case of error)
  8166            d_flags = d_flags+arrflag %if control&arrbit # 0
  8167            d_mode = labmode
  8168            get IDENTLIST(d)
  8169            dlim1 = dlim
  8170            declare anon(details(typeid+arry,0,0,0))
  8171            get(left);  get LIT RANGE(inttype);  get(right)
  8172            dict(dlim1)_xtype = item
  8173            get bounds(item,lo,hi)
  8174            %cycle;  !For each ident in group
  8175              %for i = lo,1,hi %cycle
  8176                swpc = swpc-1;  prog(swpc) = 0
  8177                croak("Code space exhausted") %if swpc <= pc
  8178              %repeat
  8179              dict(dlim0)_val = swpc
  8180              dict(dlim0)_type = dlim1
  8181              dlim0 = dlim0+1
  8182            %repeat %until dlim0 = dlim1
  8183          %repeat %until %not a(comma)

*    Failed to analyse line  8183
      %REPEATUNTILNOT A(COMMA)
                             !

*    Failed to analyse line  8183
      %REPEATUNTILNOT A(COMMA)
                             !
  8184        %end
  8185        initial(keyswitch):
  8186          literal = 1
  8187          get SWITCH DECLARATION
  8188          c_status = c_status!hadswitch
  8189          ->term
  8190        
  8191        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  8192        !!!!!!!!!!!!!!!  Control statements  !!!!!!!!!!!!!!!!!!!!!!!!!!!
  8193        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  8194        !
  8195        %routine OPT
  8196        %integer c=control

*    Failed to analyse line  8196
      %INTEGER C=CONTROL
                !

*    Failed to analyse line  8196
      %INTEGER C=CONTROL
                !
  8197          set options(string(final0+value))
  8198          select output(listout);  !**for now - PAM may alter**
  8199          control = control&(\list) %if initcon&list = 0
  8200          control = control!list %if control&(\c)&(ttlist+codelist+explist+dictlist) # 0
  8201        %end
  8202        
  8203        initial(keyoption):
  8204          get LITSTRING
  8205          get(terminator)
  8206          opt %if faultnum = 0
  8207          -> next
  8208        
  8209        initial(keyinclude):
  8210          get LITSTRING
  8211          get(terminator)
  8212          %if faultnum = 0 %start
  8213            croak("Too many nested includes") %if curfile = 3
  8214            line = line+1 %if sym = nl
  8215            cur_fp = fp;  cur_line = line
  8216            fcontrol(curfile) = control
  8217            control = control&(\list) %if control&(codelist+explist+dictlist) = 0
  8218            curfile = curfile+1
  8219            lastfile = -1 %if curfile = lastfile
  8220            cur == file(curfile);  cur = 0
  8221            time1 = time1-cputime
  8222        !!    define param("INC",cur_name,nodefault)
  8223            opt
  8224        !!    connect edfile(cur)
  8225            time1 = time1+cputime
  8226            %signal abandon %if cur_flag # 0
  8227            line = 0;  sym = nl
  8228            curstart = cur_start2;  curlim = cur_lim2
  8229            fp = cur_start2
  8230          %finish
  8231          ->next
  8232        
  8233        initial(keycontrol):
  8234          get LITERAL(inttype)
  8235          control = 0 %if value = 0
  8236          control = control!!value
  8237          show dict(0) %if control&dictlist # 0
  8238          ->term
  8239        
  8240        initial(keylist):
  8241          control = control!list
  8242          ->term
  8243        
  8244        initial(keybegin):
  8245          get(terminator)
  8246          %if stopper = 0 %start;  !first %begin
  8247            c_localdpos = dlim;  c_parlim = dlim
  8248            c_access = 1
  8249            get STATEMENTS(keyend)
  8250            %return
  8251          %finish
  8252          declare anon(beginblock)
  8253          open block(dlim0)
  8254          get STATEMENTS(keyend)
  8255          update sp
  8256          this is inst
  8257          srcall(dlim-1)
  8258          -> term
  8259        
  8260        initial(keyend):
  8261          %if stopper > keyend %start
  8262            %if stopper = keyrepeat %then fault(norepeat+now) %C
     C            %else fault(nofinish+now)
  8264          %else
  8265            %if a(keyof) %start

*    Failed to analyse line  8265
      %IF A(KEYOF) %START
                    !

*    Failed to analyse line  8265
      %IF A(KEYOF) %START
                    !
  8266              %if a(keylist) %start

*    Failed to analyse line  8266
      %IF A(KEYLIST) %START
                      !

*    Failed to analyse line  8266
      %IF A(KEYLIST) %START
                      !
  8267                control = control&(\list)
  8268                ->term
  8269              %finish
  8270              %if a(keyfile) %start

*    Failed to analyse line  8270
      %IF A(KEYFILE) %START
                      !

*    Failed to analyse line  8270
      %IF A(KEYFILE) %START
                      !
  8271               fp = curlim;  sym = nl
  8272                ->next
  8273              %finish

* 8273   FAULT 51 %FINISH is not required

* 8273   FAULT 51 %FINISH is not required
  8274              get(keyprogram)
  8275              fault(noend+now) %if level # outerlevel
  8276            %finish

* 8276   FAULT 51 %FINISH is not required

* 8276   FAULT 51 %FINISH is not required
  8277            fault(nobegin+now) %if stopper = 0
  8278            %if c_access > 0 %start
  8279              fault(noresult+now) %if c_type # 0;  !fn/map/pred
  8280            %finish
  8281            close block
  8282          %finish

* 8282   FAULT 51 %FINISH is not required

* 8282   FAULT 51 %FINISH is not required
  8283        %end;  !GET STATEMENTS
  8284        
  8285        !<<BOTH
  8286        
  8287        %routine ANNOUNCE(%integer value,%string(255) message)
  8288          write(value,1);  space;  printstring(message)
  8289          printsymbol('s') %if value # 1
  8290        %end
  8291        
  8292        %routine OUTPUT OBJECT FILE
  8293        %constinteger OBJOUT=1
  8294        %constinteger INITSIZE=18
  8295        !%constinteger INITSIZE=30
  8296        %integer i,reset,totsize,ownsize
  8297        ! INIT SEQUENCE
  8298        !   code to copy own values from end of code area to data area
  8299        !
  8300        !    Program area                 Data area
  8301        !   ________________         __________________
  8302        !   |              |         |                |
  8303        !   |              |         |  STACK SPACE   |
  8304        !   |    CODE      |         |                |
  8305        !   |              |     SP->|~~~~~~~~~~~~~~~~|
  8306        !   |______________|         |                |
  8307        !   |    init      |         |                |
  8308        !   |~~~~~~~~~~~~~~|         |GLOBAL DYNAMICS |
  8309        !   |              |         |                |
  8310        !   |  OWN VALUES  |     MB->|~~~~~~~~~~~~~~~~|
  8311        !   |              |         |                |
  8312        !   |              |         |    OWNS        |
  8313        !   |______________|         |                |
  8314        !                        orig|                |
  8315        !                        SP->|~~~~~~~~~~~~~~~~|
  8316        !
  8317         
  8318          reset = 0;  totsize = cad
  8319          ownsize =  ownad
  8320          %if ownsize # 0 %start
  8321            fill own(4-ownad&3) %if ownad&3 # 0
  8322            ownsize = ownad
  8323            reset = cad;    !entry-point for RESET
  8324            totsize = totsize+(initsize+ownad);  !total code size
  8325          %finish
  8326          set extension(objfile,".mob")
  8327          time1 = time1-cputime
  8328          open output(objout,objfile)
  8329          select output(objout)
  8330          put word(16_FE02);  !object module flag, version
  8331          put word(control>>20<<4);  !checking options
  8332          value = 0
  8333          do externals(externs,-1) %if externs # 0;  !find size
  8334          put word(value);        !length of exports
  8335          value = 0
  8336          do externals(extspecs,-1) %if extspecs # 0;  !find size
  8337          put word(value);        !length of imports
  8338          put word(totsize>>16);  !length of code + init pattern
  8339          put word(totsize)
  8340          put word(reset>>1);     !reset entry-point
  8341          put word(c_dpid_val>>1);  !main entry-point
  8342          put word(ownsize>>16);       !static data requirement
  8343          put word(ownsize)
  8344          put word(c_totstack>>16);  !stack requirement
  8345          put word(c_totstack)
  8346          put word(0);            !spare for diag
  8347          put word(0)
  8348          put word(0)
  8349          put word(0)
  8350          do externals(externs,0) %if externs # 0
  8351          do externals(extspecs,1) %if extspecs # 0
  8352          final(0) = 16_4E;  final(1) =16_75;  !RTS (as null reset,main?)
  8353          i = 0
  8354          %cycle
  8355            print symbol(final(i));  i = i+1
  8356          %repeat %until i = cad
  8357          %if ownsize # 0 %start
  8358            put word(16_2248+mb-a0);       !   move.l mb,a1
  8359            put word(16_41FA);             !   lea initpatt,a0
  8360            put word(16_000E)
  8361            put word(16_303C);             !   move.w #????,d0
  8362            put word(ownad>>1-1);          ![individual owns in shortwords - 1]
  8363            put word(16_32D8);             !l1 move.w (a0)+,(a1)+
  8364            put word(16_51C8);             !   dbra d0,l1
  8365            put word(-4)
  8366            put word(16_4E75);             !   rts
  8367            i = 0
  8368            %cycle
  8369              print symbol(final(i+ownbase));  i = i+1
  8370            %repeat %until i = ownad
  8371          %finish
  8372          time1 = time1+cputime
  8373        %end
  8374        
  8375        %routine CLOSE EDIT
  8376        !_FLAG is negative if edit abandoned
  8377        !_CHANGE is untouched (inf) if no changes
  8378          %if file(main)_flag >= 0 %and 0 < file(main)_change # 16_7FFFFFFF %start
  8379            file(main)_name = mainfile;  ![in case modified by OPEN IN]
  8380            time1 = time1-cputime
  8381        !!    disconnect edfile(file(main))
  8382            printstring(file(main)_name."  updated");  newline
  8383            time1 = time1+cputime
  8384          %finish
  8385        %end
  8386        
  8387        %begin
  8388        %on %event redo,abandon %start
  8389          close edit %and %stop %if event_event = abandon
  8390        %finish
  8391          time2 = cputime-time1
  8392          statements = 1;  comments = 0;  atoms = 0
  8393          identatoms = 0;  litatoms = 0
  8394          faults = 0;  others = 0;  faultnum = 0
  8395          zaps = 0;  steps = 0;  jumps = 0;  shorts = 0
  8396          rep = ""
  8397          forget triples;  !reset LITPOS,EXPLO,OLDEXPLO
  8398          char0 = addr(char(0));  final0 = addr(final(0))
  8399          preset
  8400          dint == dict(inttype)
  8401          dtemp == dict(lablim);  dtemp2 == dtemp[1]

*    Failed to analyse line  8401
     DTEMP2==DTEMP[1]
                  !

*    Failed to analyse line  8401
     DTEMP2==DTEMP[1]
                  !
  8402          dtsprel == dtemp2[1]

*    Failed to analyse line  8402
     DTSPREL==DTEMP2[1]
                    !

*    Failed to analyse line  8402
     DTSPREL==DTEMP2[1]
                    !
  8403          dmin = dictlim;  dmin0 = dmin
  8404          inclim = 0
  8405          accounted = 0
  8406          firstentry = finalbound;  firstpos = dictlim
  8407          pc = 1;  swpc = progbound+1
  8408          cad = 2
  8409          final(0) = 0;  !for empty string (compile-time only)
  8410          ownbase = finalbound-4095;  ownad = 0
  8411          level = outerlevel;  vintage = 1
  8412          pendout = 0;  pendin = 0;  polarity = 0
  8413          curlab = dictlim+1
  8414          reset context(procstar,defaultfree)
  8415          c_sp = -4;   !allow for BSR
  8416        
  8417          control = initcon
  8418          lastfile = main
  8419          curfile = main;  cur == file(main)
  8420          curstart = file(main)_start1;  curlim = file(main)_lim1
  8421          fp = file(main)_start1
  8422          line = 0;  sym = nl
  8423          np = np0
  8424        !<<IMP
  8425          get STATEMENTS(0)
  8426        !<<BOTH
  8427        %end
  8428        
  8429          time2 = cputime-time2-time1
  8430          close edit
  8431          output object file %if faults = 0 %or control&forcebit # 0
  8432          %cycle
  8433            select output(listout)
  8434            printstring(file(main)_name)
  8435            %if faults = 0 %or control&forcebit # 0 %start
  8436              printstring(" compiled:")
  8437              announce(statements,"statement")
  8438              print string(" (+")
  8439              announce(comments,"comment")
  8440              printstring(") to")
  8441              announce(cad,"byte")
  8442              printstring(" (+");  write(ownad,1)
  8443              printsymbol(')')
  8444              newline
  8445            %finish
  8446            %if faults # 0 %start
  8447              printsymbol(':')
  8448              announce(faults,"fault")
  8449              printstring(" reported")
  8450              %if others # 0 %start
  8451                printstring(" (+");  announce(others,"other")
  8452                printsymbol(')')
  8453              %finish
  8454              newline
  8455            %finish
  8456            %if control&logbit # 0 %start
  8457              printstring(%c
     C        "  CODE  OWNS  JUMPS SHORT STEPS  ZAPS | ATOMS LITS IDS  TIME")
  8459              newline
  8460              write(cad,5)
  8461              write(ownad,5)
  8462              write(jumps,6);  write(shorts,5)
  8463              write(steps,5);  write(zaps,5)
  8464              print(atoms/statements,5,1)
  8465              print(litatoms/statements,2,1)
  8466              print(identatoms/statements,1,1)
  8467              print(time2/statements,2,3)
  8468              printsymbol('+')
  8469              print(time1/statements,0,3)
  8470              newline
  8471            %finish
  8472            %exit %if listout = 0
  8473            listout = 0
  8474          %repeat
  8475        !<<IMP
  8476        %endofprogram

CODE GENERATION NOT ATTEMPTED
gcc: imp22g.o: No such file or directory
