!   Intel 8086 IMP77 compiler second pass

! Copyright 2002 NB Information Limited.  From an original
! version probably Copyright The University of Edinburgh and
! various contributions Copyright many other individuals, but
! most particularly Copyright 1977-1980 Peter Robertson

%begin

!SIZE CONSTANTS
%constinteger  max vars = 600
%constinteger  max stack = 16
%constinteger	max labs = 50
%constinteger  max level = 16
%constinteger  Max GP = 100

! SOME WEE ENVIRONMENTAL THINGS
%conststring(8)  program ep = "__impmain";     ! Main program external name
%conststring(5)  system prefix = "_imp_";     ! prefixed to %system routine idents

! I/O file handles
%constinteger icode   = 1
%constinteger source  = 2
%constinteger report  = 0
%constinteger objout  = 1
%constinteger listout = 2

!CONTROL BITS
%constinteger  check capacity = 1
%constinteger  check unass    = 2
%constinteger  check array    = 4
%constinteger  check bits     = check array;  ! The only one that does anything so far

!REGISTERS - basic register number = actual value + 1
%constinteger  AX = 1
%constinteger  CX = 2
%constinteger  DX = 3
%constinteger  BX = 4
%constinteger  SP = 5
%constinteger  BP = 6
%constinteger  SI = 7
%constinteger  DI = 8

! Floating point coprocessor stack registers
%constinteger  FR0	= 9
!%constinteger  FR1	= 10
!%constinteger  FR2	= 11
!%constinteger  FR3	= 12
!%constinteger  FR4	= 13
!%constinteger  FR5	= 14
!%constinteger  FR6	= 15
%constinteger  FR7	= 16

! 8 bit registers - actual value + 17
%constinteger	AL	= 17
%constinteger	CL	= 18
%constinteger	DL	= 19
%constinteger	BL	= 20
%constinteger	AH	= 21
%constinteger	CH	= 22
%constinteger	DH	= 23
%constinteger	BH	= 24


! Pseudo Registers
%constinteger  any   = 25  ; ! Truly any 16 bit register
%constinteger  anyg  = 26  ; ! A "General Purpose" byte accessible register (AX, BX, CX, DX)
%constinteger  anyp  = 27  ; ! A 16 bit pointing register (BX, SI, DI)
%constinteger  anyf  = 28  ; ! Generally means the top of the 8087 stack

!DATA FORMS

! EXTERNAL
%constinteger  recordformat   = 4
%constinteger  switch         = 6
%constinteger  array          = 11
%constinteger  arrayname      = 12
%constinteger  namearray      = 13
%constinteger  namearrayname  = 14

! INTERNAL
%constinteger  constant    = 0
%constinteger  v in r      = 1
%constinteger  av in r     = 2
%constinteger  a in r      = 3
%constinteger  v in s      = 4
%constinteger  av in s     = 5
%constinteger  a in s      = 6
%constinteger  v in rec    = 7
%constinteger  av in rec   = 8
%constinteger  a in rec    = 9
%constinteger  pgm label   = 10

!DATA TYPES
%constinteger  general  = 0
%constinteger  integer  = 1
%constinteger  real     = 2
%constinteger  string   = 3
%constinteger  record   = 4
! Private internal derived types
%constinteger  byte     = 5
%constinteger  lreal    = 6

! SIZE OF EACH OF THOSE TYPES IN BYTES
%constbyteintegerarray  vsize(0:6) = 0,2,4,0,0,1,8

! GENERIC STORE ALIGNMENT - ASSUME 8086
%constinteger  align = 1
%constinteger  wordsize = 2;  ! in bytes

!OWN INFO
%constinteger  own = 1
%constinteger  con = 2
%constinteger  external = 3
%constinteger  system = 4
%constinteger  dynamic = 5
%constinteger  primrt = 6
%constinteger  permrt = 7

! Define type codes known externally (to pass 3 and user):
%constbyteintegerarray  gen map(general:lreal) =
      0,      1,     2,      3,     4,       6,     8

! PERM ROUTINE INDEXES
%constinteger  iexp=1;     ! Integer Exponent
%constinteger  fexp=2;     ! floating exponent
%constinteger  smove=3;    ! string copy (length checked)
%constinteger  sjam=4;     ! string copy (whatever fits)
%constinteger  sconc=5;    ! string concatenate (length checked)
%constinteger	sjconc=6;	! concatenate whatever fits
%constinteger  sresln=7;   ! string resolution
%constinteger  scomp=8;    ! string compare
%constinteger  aref=9;     ! array access
%constinteger  adef=10;    ! array definition
%constinteger  signal=11;  ! %signal
%constinteger	lastperm=signal

! and the corresponding linkage names for the perms
%const %string(12)%array permname(1:lastperm)=
"__impiexp",
"__impfexp",
"__impstrcpy",
"__impstrjam",
"__impstrcat",
"__impstrjcat",
"__impstrres",
"__impstrcmp",
"__imparef",
"__impadef",
"__impsignal"

! COMPILER OPERATIONS (not to be confused with OpCodes)
%constinteger  op add = 1
%constinteger  op sub = 2
%constinteger  op mul = 3
%constinteger  op div = 4
%constinteger  op conc = 5
%constinteger  op and = 6
%constinteger  op or  = 7
%constinteger  op xor = 8
%constinteger  op lsh = 9
%constinteger  op rsh = 10
%constinteger  op rem = 11
%constinteger  op exp = 12
%constinteger  op rexp = 13
%constinteger  op rdiv = 14
%constinteger  op not = 15
%constinteger  op neg = 16
%constinteger  op abs = 17
%constinteger  unaries = 15

! opcode indexes...

! simple (no operand) ones first
%constinteger NOP	= 0
%constinteger CWD = 1
%constinteger RET = 2
%constinteger SAHF = 3

! simple unary math functions
%constinteger DEC = 4
%constinteger INC = 5
%constinteger NEG = 6
%constinteger NOT = 7

! simple unary moves
%constinteger POP = 8
%constinteger PUSH = 9

! two operand moves
%constinteger LEA = 10
%constinteger MOV = 11
%constinteger XCHG = 12

! simple two operand math functions
%constinteger ADC = 13
%constinteger ADD = 14
%constinteger AND = 15
%constinteger CMP = 16
%constinteger OR = 17
%constinteger SUB = 18
%constinteger XOR = 19
! slightly more complicated two operand math
%constinteger SHL = 20
%constinteger SHR = 21
%constinteger IDIV = 22
%constinteger IMUL = 23

! calls and jumps
%constinteger CALL = 24
%constinteger JE  = 25
%constinteger JNE = 26
%constinteger JG  = 27
%constinteger JGE = 28
%constinteger JL  = 29
%constinteger JLE = 30
%constinteger JA  = 31
%constinteger JAE = 32
%constinteger JB  = 33
%constinteger JBE = 34
%constinteger JMP = 35

! Floating point instructions - note that these map directly onto
! 8087 sequences, unlike the generic MOV, ADD style of the base
! operations for the 8086
%constinteger	FILD	= 36
%constinteger	FLDD	= 37
%constinteger	FLDQ	= 38
%constinteger	FSTI	= 39
%constinteger	FSTD	= 40
%constinteger	FSTQ	= 41
%constinteger	FADD	= 42
%constinteger	FSUB	= 43
%constinteger	FSUBR	= 44
%constinteger	FMUL	= 45
%constinteger	FDIV	= 46
%constinteger	FDIVR	= 47
%constinteger	FCMP	= 48
%constinteger	FCHS	= 49
%constinteger	FABS	= 50
! Special floating point things
%constinteger  FSTSW = 51
%constinteger  FLDZ  = 52
%constinteger  FLDPI = 53

! modifiers to memory base for accessing global memory
%constinteger DATA   = 16_10
%constinteger COT		= 16_20
%constinteger BSS		= 16_30
%constinteger DISPLAY = 16_40
%constinteger EXT		= 16_50
%constinteger SWT    = 16_60
%constinteger CODE	= 16_70

! Standard IMPish data structures

! Variables are declared here
%recordformat  varfm(%byteinteger type, form, level, scope, dim, %c
                     %integer  disp, format, size, pbase, extra)
%record(varfm)%array  var(0:max vars)
%record(varfm)%name   decvar
%record(varfm)     begin

! The compiler is stack based
%recordformat  stackfm(%byteinteger type, form, aform, base, scope, dim, %c
                     %integer  disp, format, size, pbase, extra, %c
                     %integer  var no)
%record(stackfm)%array  stack(1:max stack)
%record(stackfm)   null
%record(stackfm)%name top

! Pass 1 uses a lame label redefinition that forces us to map
! label ID's into unique labels for pass 3, using this database
%recordformat LabelFm(%integer id, tag)
%record(LabelFm)%array Labels(1:Max Labs)

! Status of registers
%ownintegerarray  activity(0:fr7) = 0, 0, 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
%owninteger  claimed = 0

! Pointer registers may be pointing to non-local display - we remember
! them for future use
%ownintegerarray displayhint(AX:DI) = 0, 0, 0, 0, 0, 0, 0, 0

! Math Co-processor uses a stack - we remember where it should be
! with this pointer
%owninteger fpustack = 0

! A general purpose workspace resource
%recordformat gp tag(%integer info, addr, flags, link)
%record(gptag)%array gptags(0:Max GP)
%integer gp asl;

%owninteger  control = check bits;  ! Current compiler flags (set by %control statement)
%owninteger  diagnose = 0;          ! Current diagnostic flags (set by %diagnose statement)

%owninteger nextcad = 0;            ! notional code address (not real - pass3 shuffles stuff)
%owninteger level = 0;              ! current contextual level
%integer    sym, next sym;          ! CODE SYMBOL, NEXT SYMBOL
%integer    vlb,vub;                ! VECTOR LOWER/UPPER BOUND
%owninteger current line = 0;       ! SOURCE LINE NUMBER
%owninteger stp = 0;                ! STACK POINTER
%integer    data size;              ! CURRENT DATA ITEM SIZE
%owninteger frame = 0;              ! LOCAL STACK FRAME EXTENT
%integer    parms;                  ! START OF PARAMETER STACK
%owninteger invert = 0;             ! CONDITION INVERSION FLAG
%owninteger compare unsign = 0;     ! CONDITION WAS NON-STANDARD (GENERALLY FPU COMPARE)
%owninteger uncond jump = 0;        ! ADDRESS OF CODE HOLE
%owninteger block type = 1;         ! -1 = RECORDS, 1 = PROCEDURE, 2 = SPEC
%owninteger in params = 0;          ! NON-ZERO INSIDE PARAMETER LISTS
%integer    decl;                   ! LAST-DEFINED DESCRIPTOR
%integer    otype, owntype, ownform;  ! Information about OWNs currently being declared
%integer    spec, frozen, potype;   ! More about current declaration
%integer    dim;                    ! Dimensions
%integer		i, j;							! used in the initialisation loops only
%owninteger Fp Result Loc = -1;     ! Place to store Real and LReal function results

%constinteger max dataseg = 12000;  ! Size in bytes of data segment table
%byteintegerarray datat(0:max dataseg)
%owninteger datatp = 0;             ! pointer to next data segment byte

%constinteger max switch = 1000;    ! Size in WORDS of switch segment table
%integerarray swtab(0:max switch)
%owninteger swtp = 0;               ! pointer to next switch segment entry

%ownstring(255)  external id = "", alias = ""
%ownstring(255)  internal id = ""

%byteintegername   cslen
%byteintegerarray  current string(0:255);   ! current string literal

%integer  xlen
%byteintegerarray xsymbuff(0:255);     ! current external string name

! WORK List - used to optimise use of temporary storage
! There is a head of list for each contextual level
%ownintegerarray worklist(1:max level) = 
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0

%longreal	rvalue;		! floating point value for constants and initialisers

%owninteger ownval = 0; ! value to use when initialising OWNs

!-----------------------------------------------------------
! Start with machine independent utility functions and stack
! manipulation and debug
!-----------------------------------------------------------

!                                                             >> SHOW <<
%routine  show(%record(stackfm)%name  v)
   write(v_varno,3);
   print string(" : Typ="); write(v_type,1)
   print string(" Frm="); write(v_form,1)
   print string(" Bse="); write(v_base,1);
   print string(" Dsp="); write(v_disp,4)
   print string(" Siz="); write(v_size,1)
   print string(" Xtr="); write(v_extra,1)
   print string(" Fmt="); write(v_format,1)
   print string(" Dim="); write(v_dim,1)
   print string(" Pba="); write(v_pbase,1)
   newline
%end

! Simple ABORT routine
%routine abort(%string(255) message)
   %integer j

   select output(report)
   printstring("Pass 2 abandoned at line ");
   write(current line, 1);
   printstring(" : ");
   printstring(message)
   newline
   %if stp # 0 %start
      print string("STACK:");  newline
      show(stack(j)) %for j = 1,1,stp
   %finish
   %stop
%end

!                                                             >> WARN <<
%routine  warn(%integer  n)
%switch  w(1:8)
   select output(report)
   print string("*WARNING: line")
   write(current line, 1);  print string(": ")
   -> w(n)
w(1): print string("division by zero");  -> at
w(2): print string("Illegal FOR");  -> at
w(3): print string("Non-local control variable?");  -> at
w(4): print string("Invalid parameter for READ SYMBOL");  -> at
w(5): print string("String constant too long");  -> at
w(6): print string("No. of shifts outwith 0..31");  -> at
w(7): print string("Illegal constant exponent");  -> at
w(8): print string("Numerical constant too big");  -> at
at: newline
   select output(objout)
%end

!                                                          >> MONITOR <<
%routine  monitor(%record(stackfm)%name  v, %string(15) text)
   select output(report)
   print string(text);  print symbol(':')
   spaces(10-length(text))
   show(v)
   select output(objout)
%end

!                                                             >> GET GP TAG <<
%integerfn get gp tag
   %integer l

   %if gp asl = 0 %then abort("GP Tags")
   l = gp asl
   gp asl = gp tags(l)_link
   %result = l
%end

!                                                             >> RET GP TAG <<
%routine ret gp tag(%integer index)

   gp tags(index)_link = gp asl
   gp asl = index
%end
   
!------------------------------------------------------
! Machine dependent utility routines
!------------------------------------------------------

! Routines to write the intermediate file
! Record format is:
! <type><length><data>
! For debug purposes, the elements are all written as ascii
! characters, where <type> is a single letter, <length> is a single
! hex digit, length refers to the number of bytes (2 chars) of data.

! Intermediate file types:
%constinteger IF OBJ		      = 0;	! A - plain object code
%constinteger IF DATA	      = 1;	! B - dataseg offset code word
%constinteger IF CONST	      = 2;	! C - const seg offset code word
%constinteger IF DISPLAY	   = 3;	! D - display seg offset code word
%constinteger IF JUMP		   = 4;	! E - unconditional jump to label
%constinteger IF JCOND	      = 5;	! F - cond jump to label JE, JNE, JLE, JL, JGE, JG
%constinteger IF CALL		   = 6;	! G - call a label
%constinteger IF LABEL	      = 7;	! H - define a label
%constinteger IF FIXUP	      = 8;	! I - define location for stack fixup instruction
%constinteger IF SETFIX	      = 9;	! J - stack fixup <location> <amount>
%constinteger IF REQEXT	      = 10;	! K - external name spec
%constinteger IF REFEXT	      = 12;	! M - external name relative offset code word
%constinteger IF BSS		      = 13;	! N - BSS segment offset code word
%constinteger IF COTWORD	   = 14;	! O - Constant table word
%constinteger IF DATWORD	   = 15;	! P - Data segment word
%constinteger IF SWTWORD	   = 16;	! Q - switch table entry - actually a label ID
%constinteger IF SOURCE	      = 17;	! R - name of the source file
%constinteger IF DEFEXTCODE	= 18;	! S - define a code label that is external
%constinteger IF DEFEXTDATA	= 19;	! T - define a data label that is external
%constinteger IF SWT		      = 20;	! U - switch table offset code word
%constinteger IF LINE		   = 21;	! V - line number info for debugger

%routine  writenibble(%integer n)
	n = n & 16_f;
	%if 0 <= n %and n <= 9 %start
		printsymbol(n + '0');
	%else
		printsymbol(n + ('A' - 10));
   %finish
%end

! print a number in hexadecimal, to "places" size
%routine write hex(%integer n, places)
   %integer p, shift

   shift = (places - 1) * 4
   %while shift > 0 %cycle
      p = n >> shift
      writenibble(p)
      shift = shift - 4
   %repeat
   writenibble(n)
%end

%routine  writeifrecord(%integer type, %integer length, %byteintegerarrayname buffer)
	%integer c1, c2, i;

   select output(objout)
	printsymbol('A'+type);
	%if (length > 255) %then abort("Intermediate file record too long");
	writenibble(length>>4);
	writenibble(length&15);
	
	i = 0;
   %while (length > 0) %cycle
		c1 = buffer(i) >> 4;
		c2 = buffer(i) & 15;
		writenibble(c1);
		writenibble(c2);
		i = i + 1;
		length = length - 1;
   %repeat
	newline
%end

! Simple buffered output of code bytes...
%own %integer objectptr = 0;
%own %byte %integer %array objectbytes(0:7);
! And corresponding bytes for the listing (not always the same for fudged opcodes)
%own %integer listptr = 0;
%own %byte %integer %array listbytes(0:7);

! Routine to provide the address and hex opcode listing in the
! diagnostic output
%routine  listpreamble
	%integer i;

	select output(listout)
   space; writehex(nextcad, 4); space;
	%for i = 0, 1, 7 %cycle
		%if i < listptr %start
         writehex(listbytes(i), 2)
         space
		%else
         spaces(3)
      %finish
	%repeat
   spaces(8)
	nextcad = nextcad + listptr;
	listptr = 0;
%end

! flush the code buffer
%routine flushcode
	%if objectptr # 0 %start
		writeifrecord(IF OBJ, objectptr, objectbytes);
		objectptr = 0;	! reset the output pipe
   %finish
%end

! puts a normal code byte into the listing and code pipes
%routine  putbyte(%integer b)
	listbytes(listptr) = b;
	listptr = listptr + 1;
	objectbytes(objectptr) = b;
	objectptr = objectptr + 1;
%end

! A very handy little boolean function, used for instructions
! with variable size immediate operands
%integerfn issmall(%integer i)
	%result = 1 %if i < 128 %and i > -128
	%result = 0;
%end

! And aide-memoire of intel 8086 address modes...
!		DS:[BX+SI]
!		DS:[BX+DI]
!		SS:[BP+SI]
!		SS:[BP+DI]
!		DS:[SI];
!		DS:[DI];
!		DS: [offset16]
!		DS: [BX]
!		DS:[BX + SI + offset8]
!		DS:[BX + DI + offset8]
!		SS:[BP + SI + offset8]
!		SS:[BP + DI + offset8]
!		DS:[SI + offset8]
!		DS:[DI + offset8]
!		SS:[BP + offset8]
!		DS:[BX + offset8]
!		DS:[BX + SI + offset16]
!		DS:[BX + DI + offset16]
!		SS:[BP + SI + offset16]
!		SS:[BP + DI + offset16]
!		DS:[SI + offset16]
!		DS:[DI + offset16]
!		SS:[BP + offset16]
!		DS:[BX + offset16]

! mod r/m format is:
! mod LHREG R/M
! where mod = 11 for rh registers

! plant a modrm reference where the rh operand is a register
! Both parameters are actual register numbers, not internal ID's
%routine  modrmreg(%integer reg1, %integer reg2)
	putbyte(16_C0 ! (reg1 << 3) ! (reg2));
%end

! tags corresponding to linker directives...
%const %integer %array reltag(0:6) =
	0,			   ;! no relocation
	1,	         ;! dataseg offset code word
	2,    	   ;! const seg offset code word
	13,   		;! BSS relative code word
	3,       	;! display seg offset code word
	12,      	;! external name relative offset code word
	20    		;! switch table offset code word

! plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
%routine relocateoffset(%integer reloc, %integer offset)
	%integer tag;

	flushcode %if reloc # 0;	! so that only the offset is going into the queue

	putbyte(offset & 255);
	putbyte(offset >> 8);

	%if reloc # 0 %start
		tag = reltag(reloc);
		writeifrecord(tag, 2, objectbytes);
		objectptr = 0;	! clear the queue
	%finish
%end

! plant a modrm reference where the rh operand is in memory
! Parameter REG1 is an actual register number, but BASE is an internal ID
%routine  modrmmem(%integer reg1, %integer base, %integer disp)
	%integer mod, rm, reloc;

	reloc = base>>4;
	base = base & 15;

	%if base = 0 %start; 	! no register, just a displacement
		! mod = 000, rm = 110
		putbyte((reg1 << 3) ! 6);
		relocateoffset(reloc, disp);
	%else
		%if disp = 0 %start
			mod = 0
		%else
         %if issmall(disp) # 0 %start;		! fits in one byte
			   mod = 1
		   %else
			   mod = 2
         %finish
      %finish

		! unfortunately displacement (even zero) must be output in full if
		! the offset is relocatable
		%if reloc # 0 %then mod = 2;

		%if base = BP %start
			rm = 6;
		%else
         %if base = BX %start
			   rm = 7;
		   %else
            %if base = DI %start
			      rm = 5;
		      %else
               %if base = SI %start
			         rm = 4;
		         %else
			         abort("Internal address mode error");
               %finish
            %finish
         %finish
      %finish

		putbyte((mod << 6)!(reg1 << 3)!rm);

		%if mod = 1 %start
			putbyte(disp);
		%else
         %if mod = 2 %then relocateoffset(reloc, disp)
      %finish
   %finish
%end

%const %string(2) %array regname(AX:DI) =
	"AX", "CX", "DX", "BX", "SP", "BP", "SI", "DI"

%const %string(2) %array reg8name(AL:BH) =
	"AL", "CL", "DL", "BL", "AH", "CH", "DH", "BH"

%const %string(7) %array relocname(0:6) =
	"", "DATA", "COT", "BSS", "DISPLAY", "EXTERN", "SWTAB"

! Print the corresponding memory access string
! BASE is an internal ID, not an actual register number
%routine  printmemref(%integer base, %integer disp)
	%integer reloc;

	reloc = base >> 4;
	base = base & 15;
   selectoutput(listout)
	printsymbol('[');
	%if base # 0 %start
		printstring(regname(base));
		%if reloc # 0 %start
         printsymbol('+'); printstring(relocname(reloc));
      %finish
		%if disp # 0 %then %start
         printsymbol('+') %if disp > 0
         write(disp,1)
      %finish
	%else
		%if reloc # 0 %start
         printstring(relocname(reloc)); printsymbol('+')
      %finish
      writehex(disp, 4)
   %finish
   printsymbol(']');
%end

! opcodes
%const %string(4) %array opname(NOP:JMP) =
	"NOP", "CWD", "RET", "SAHF",
	"DEC", "INC", "NEG", "NOT",
	"POP", "PUSH",
	"LEA", "MOV", "XCHG",
	"ADC", "ADD", "AND", "CMP", "OR", "SUB", "XOR",
	"SHL", "SHR", "IDIV", "IMUL",
	"CALL", "JE", "JNE",
   "JG", "JGE", "JL", "JLE",
   "JA", "JAE", "JB", "JBE", "JMP"


%const %byte %integer %array opvalue(NOP:JMP) =
	16_90, 16_99, 16_C3, 16_9E,
	16_FF, 16_FF, 16_F7, 16_F7,
	16_8F, 16_FF,
	16_8B, 16_89, 16_87,		;! LEA is fudged as if it were m <- r, to allow the flip
	16_11, 16_01, 16_21, 16_39, 16_09, 16_29, 16_31,
	16_D1, 16_D1, 16_F7, 16_F7,
	16_E8, 16_74, 16_75,
   16_7F, 16_7D, 16_7C, 16_7E,
   16_77, 16_73, 16_72, 16_76, 16_EB

! 8 bit equivalent opcodes
%const %byte %integer %array op8value(NOP:JMP) =
	16_90, 16_99, 16_C3, 16_9E,	;! not 8 bit, included for completeness
	16_FE, 16_FE, 16_F6, 16_F6,
	16_8F, 16_FF,				      ;! not 8 bit, included for completeness
	16_8B, 16_88, 16_86,		      ;! LEA is not applicable for 8 bit
	16_10, 16_00, 16_20, 16_38, 16_08, 16_28, 16_30,
	16_D0, 16_D0, 16_F6, 16_F6,
	16_E8, 16_74, 16_75,
   16_7F, 16_7D, 16_7C, 16_7E,
   16_77, 16_73, 16_72, 16_76, 16_EB	;! not 8 bit, included for completeness

! An opcode with no operands (eg RET)
%routine dumpsimple(%integer opn)

	putbyte(opvalue(opn));

	listpreamble;
   printstring(opname(opn));
   newline
	flushcode;
%end

! A special bit of magic, used in record assignment
%routine dumprepmovsb
	putbyte(16_f3);	! rep
	putbyte(16_a4);	! movsb

	listpreamble;
	printstring("REP MOVSB");
   newline
	flushcode;
%end

! Used in record = 0 assignment
%routine dumprepstosb
	putbyte(16_f3);	! rep
	putbyte(16_aa);	! stosb

	listpreamble;
	printstring("REP STOSB");
   newline
	flushcode;
%end

! unary register operation - DEC, INC, NEG, NOT, POP, PUSH, IDIV, IMUL
! REG is an internal ID, not an actual register number
%routine dumpur(%integer opn, %integer reg)
   %switch ops(DEC:IMUL)

	displayhint(reg) = 0;

	->ops(opn)

	ops(DEC):
		putbyte(16_48 + reg - AX);
		->break;

	ops(INC):
		putbyte(16_40 + reg - AX);
		->break;

	ops(NEG):
		putbyte(16_F7);
		modrmreg(3, reg - AX);
		->break;

	ops(NOT):
		putbyte(16_F7);
		modrmreg(2, reg - AX);
		->break;

	ops(POP):
		putbyte(16_58 + reg - AX);
		->break;

	ops(PUSH):
		putbyte(16_50 + reg - AX);
		->break;

	ops(IDIV):
		putbyte(16_F7);
		modrmreg(7, reg - AX);
		->break;

	ops(IMUL):
		putbyte(16_F7);
		modrmreg(5, reg - AX);

break:
	listpreamble;
   printstring(opname(opn))
   space
   printstring(regname(reg));
   newline
	flushcode

%end

! Plant code for a unary operation on memory
! BASE is an internal ID, not the actual register number
%routine dumpum(%integer opn, %integer base, %integer disp)
   %switch ops(DEC:JMP)

	->ops(opn)

	ops(DEC):
		putbyte(16_FF);
		modrmmem(1, base, disp);
		->break;

	ops(INC):
		putbyte(16_FF);
		modrmmem(0, base, disp);
		->break;

	ops(NEG):
		putbyte(16_F7);
		modrmmem(3, base, disp);
		->break;

	ops(NOT):
		putbyte(16_F7);
		modrmmem(2, base, disp);
		->break;

	ops(POP):
		putbyte(16_8F);
		modrmmem(0, base, disp);
		->break;

	ops(PUSH):
		putbyte(16_FF);
		modrmmem(6, base, disp);
		->break;

	ops(IDIV):
		putbyte(16_F7);
		modrmmem(7, base, disp);
		->break;

	ops(IMUL):
		putbyte(16_F7);
		modrmmem(5, base, disp);
		->break;

	ops(JMP):
		putbyte(16_FF);
		modrmmem(4, base, disp);

	ops(CALL):
		putbyte(16_FF);
		modrmmem(2, base, disp);

break:
	listpreamble;
   printstring(opname(opn))
   printstring(" WORD ");	! otherwise it's ambiguous for the reader
	printmemref(base, disp);
   newline
	flushcode;
%end

! Plant code for a unary operation on an 8 bit memory location
! Not all of the possible unary ops make sense as 8 bit destinations
! BASE is an internal ID, not the actual register number
%routine dumpum8(%integer opn, %integer base, %integer disp)
	%integer base op, index

	%if opn = DEC %or opn = INC %start
		base op = 16_FE
		%if opn = DEC %then index = 1 %else index = 0
	%else
		%if opn = NOT %or opn = NEG %start
			base op = 16_F6
			%if opn = NOT %then index = 2 %else index = 3
		%else
			Abort("Invalid UM8")
		%finish
	%finish

	putbyte(base op)
	modrmmem(index, base, disp)

	listpreamble;
   printstring(opname(opn))
   printstring(" BYTE ");	! otherwise it's ambiguous for the reader
	printmemref(base, disp);
   newline
	flushcode;
%end

! Plant a Memory <- Reg operation
! Both BASE and REG are internal ID's, not actual register numbers
%routine dumpmr(%integer opn, %integer base, %integer disp, %integer reg)

	%if opn = SHL %start;	! special "shift by CL"
		putbyte(16_D3);
		modrmmem(4, base, disp);
	%else
      %if opn = SHR %start
         putbyte(16_D3);
		   modrmmem(5, base, disp);
      %else;               ! normal stuff
			putbyte(opvalue(opn));
			modrmmem(reg - AX, base, disp);
      %finish
   %finish

	listpreamble;
   printstring(opname(opn))
   space
	printmemref(base, disp);
   printsymbol(',')
   printstring(regname(reg));
   newline
	flushcode;
%end

! Plant an 8 bit Memory <- Reg operation
! Both BASE and REG are internal ID's, not actual register numbers
%routine dumpmr8(%integer opn, %integer base, %integer disp, %integer reg)

	%if opn = SHL %start;	! special "shift by CL"
		putbyte(16_D2);
		modrmmem(4, base, disp);
	%else
      %if opn = SHR %start
         putbyte(16_D2);
		   modrmmem(5, base, disp);
      %else;               ! normal stuff
			putbyte(op8value(opn));
			modrmmem(reg - AL, base, disp);
      %finish
   %finish

	listpreamble;
   printstring(opname(opn))
   space
	printmemref(base, disp);
   printsymbol(',')
   printstring(reg8name(reg));
   newline
	flushcode;
%end

! Plant a 16 bit Reg <- Memory operation
! Both BASE and REG are internal ID's, not actual register numbers
%routine dumprm(%integer opn, %integer reg, %integer base, %integer disp)

! We optimise the fairly common instruction MOV AX,[disp] with
! the special short-form quirk of the 8086...

	%if reg = AX %and opn = MOV %and base & 15 = 0 %start
		putbyte(16_A1)
   	relocateoffset(base>>4, disp)
	%else
		displayhint(reg) = 0;

		putbyte(opvalue(opn)+2);
		modrmmem(reg - AX, base, disp);
	%finish

	listpreamble;
   printstring(opname(opn))
   space
   printstring(regname(reg));
   printsymbol(',')
	printmemref(base, disp);
   newline
	flushcode;
%end

! Plant an 8 bit Reg <- Memory operation
! Both BASE and REG are internal ID's, not actual register numbers
%routine dumprm8(%integer opn, %integer reg, %integer base, %integer disp)

	putbyte(op8value(opn)+2);
	modrmmem(reg - AL, base, disp);

	listpreamble;
   printstring(opname(opn))
   space
   printstring(reg8name(reg));
   printsymbol(',')
	printmemref(base, disp);
   newline
	flushcode;
%end

! Plant a 16 bit Reg <- Reg operation
! Both register parameters are internal ID's
%routine dumprr(%integer opn, %integer reg1, %integer reg2)

	displayhint(reg1) = 0;

	%if opn = SHL %start;	! special "shift by CL"
		putbyte(16_D3);
		modrmreg(4, reg1 - AX);
	%else
      %if opn = SHR %start
         putbyte(16_D3);
		   modrmreg(5, reg1 - AX);
      %else;               ! normal stuff
   		putbyte(opvalue(opn));
	   	modrmreg(reg2 - AX, reg1 - AX);
      %finish
   %finish

	listpreamble;
   printstring(opname(opn))
   space
   printstring(regname(reg1));
   printsymbol(',')
   printstring(regname(reg2));
   newline
	flushcode;
%end

%routine dumprr8(%integer opn, %integer reg1, %integer reg2)

	%if opn = SHL %start;	! special "shift by CL"
		putbyte(16_D2);
		modrmreg(4, reg1 - AL);
	%else
      %if opn = SHR %start
   		putbyte(16_D2);
	   	modrmreg(5, reg1 - AL);
	   %else
   		putbyte(op8value(opn));
	   	modrmreg(reg2 - AL, reg1 - AL);
      %finish
   %finish

	listpreamble;
   printstring(opname(opn))
   space
   printstring(reg8name(reg1));
   printsymbol(',')
   printstring(reg8name(reg2));
   newline
	flushcode;
%end

%const %byte %integer %array aximmediatevalue(NOP:XOR) =
	0, 0, 0, 0,
	0, 0, 0, 0,
	0, 0,
	0, 16_B8, 0,
	16_15, 16_05, 16_25, 16_3D, 16_0D, 16_2D, 16_35

! Register immediate operations - can be MOV, Math, or Shift
! The immediate operand may be a relocated offset as part of
! an address calculation
%routine dumprioffset(%integer opn, %integer reg, %integer reloc, %integer immed)
	%integer subop;
   %switch ops(MOV:SHR)

	displayhint(reg) = 0;
	reloc = reloc >> 4;			! because we pass around the or-able version

	%if reg = AX %and opn <= XOR %start
		putbyte(aximmediatevalue(opn));
   	relocateoffset(reloc, immed);
      ->break
	%else
		->ops(opn)
   %finish

		ops(MOV):
			putbyte(16_B8 + reg - AX);
      	relocateoffset(reloc, immed);
			->break;

		ops(ADD): subop = 0; ->addsub
		ops(ADC): subop = 2; ->addsub
		ops(CMP): subop = 7; ->addsub
		ops(SUB): subop = 5
      addsub:
			%if issmall(immed) # 0 %and reloc = 0 %start
				putbyte(16_83);
				modrmreg(subop, reg - AX);
				putbyte(immed & 255);
			%else
				putbyte(16_81);
				modrmreg(subop, reg - AX);
           	relocateoffset(reloc, immed);
			%finish
			->break;
	
		ops(AND): subop = 4; ->logical
		ops(OR):  subop = 1; ->logical
		ops(XOR): subop = 6
      logical:
			putbyte(16_81);
			modrmreg(subop, reg - AX);
        	relocateoffset(reloc, immed);
			->break;

		ops(SHL):
			putbyte(16_D1);
			modrmreg(4, reg - AX);
			->break;

		ops(SHR):
			putbyte(16_D1);
			modrmreg(5, reg - AX);

break:
	listpreamble;
   printstring(opname(opn))
   space
   printstring(regname(reg));
   printsymbol(',')
	%if reloc # 0 %start
		printstring(relocname(reloc)); printsymbol('+')
   %finish
   write(immed, 1)
   newline
	flushcode;
%end

! Since many math operations don't involve relocated addresses
! we provide a chep version of dumprioffset
%routine dumpri(%integer opn, %integer reg, %integer immed)
   dumprioffset(opn, reg, 0, immed)
%end

! Memory (16 bit) immediate operations - can be MOV, Math, or Shift
%routine dumpmi(%integer opn, %integer base, disp, %integer immed)
	%integer subop;
   %switch ops(MOV:SHR)

		->ops(opn)

	ops(MOV):
		putbyte(16_C7)
		modrmmem(0, base, disp)
		putbyte(immed & 255)
		putbyte(immed >> 8)
		->break;

	ops(ADD): subop = 0; ->addsub
	ops(ADC): subop = 2; ->addsub
	ops(CMP): subop = 7; ->addsub
	ops(SUB): subop = 5
   addsub:
			%if issmall(immed) # 0 %start
				putbyte(16_83);
      		modrmmem(subop, base, disp)
				putbyte(immed & 255);
			%else
				putbyte(16_81);
      		modrmmem(subop, base, disp)
				putbyte(immed & 255);
				putbyte(immed >> 8);
			%finish
			->break;
	
		ops(AND): subop = 4; ->logical
		ops(OR):  subop = 1; ->logical
		ops(XOR): subop = 6
      logical:
			putbyte(16_81);
     		modrmmem(subop, base, disp)
			putbyte(immed & 255);
			putbyte(immed >> 8);
			->break;

		ops(SHL):
			putbyte(16_D1);
     		modrmmem(4, base, disp)
			->break;

		ops(SHR):
			putbyte(16_D1);
     		modrmmem(5, base, disp)

break:
	listpreamble;
   printstring(opname(opn))
   printstring(" WORD ");	! otherwise it's ambiguous for the reader
	printmemref(base, disp);
   printsymbol(',')
   write(immed, 1)
   newline
	flushcode;
%end

! Memory (8 bit) immediate operations - can be MOV, Math, or Shift
%routine dumpmi8(%integer opn, %integer base, disp, %integer immed)
	%integer subop;
   %switch ops(MOV:SHR)

		->ops(opn)

	ops(MOV):
		putbyte(16_C6)
		modrmmem(0, base, disp)
		putbyte(immed & 255)
		->break;

	ops(ADD): subop = 0; ->op80
	ops(ADC): subop = 2; ->op80
	ops(CMP): subop = 7; ->op80
	ops(SUB): subop = 5; ->op80
	ops(AND): subop = 4; ->op80
	ops(OR):  subop = 1; ->op80
	ops(XOR): subop = 6
   op80:
		putbyte(16_80);
  		modrmmem(subop, base, disp)
		putbyte(immed & 255);
			->break;
	
	ops(SHL):
		putbyte(16_D0);
  		modrmmem(4, base, disp)
		->break;

	ops(SHR):
		putbyte(16_D0);
   	modrmmem(5, base, disp)

break:
	listpreamble;
   printstring(opname(opn))
   printstring(" BYTE ");	! otherwise it's ambiguous for the reader
	printmemref(base, disp);
   printsymbol(',')
   write(immed, 1)
   newline
	flushcode;
%end

! Finally, a catch-all that recasts operations using generic
! Var Stack structures
! Plant a 16 bit Reg <- Var operation
%routine dumprv(%integer opn, %integer reg, %record(stackfm)%name v)

   %if v_form = V in R %start
      dumprr(opn, reg, v_base)
   %else
      %if v_form = V in S %start
         dumprm(opn, reg, v_base!v_scope, v_disp)
      %else
         %if v_form = constant %start
            dumprioffset(opn, reg, v_scope, v_disp)
         %else
            abort("Address Mode")
         %finish
      %finish
   %finish
%end

! Another special dumper - the only "Unary" operation that
! takes an immediate operand is PUSH
%routine dumppushi(%integer reloc, %integer immed)

	reloc = reloc >> 4;			! because we pass around the or-able version

   %if reloc = 0 %and is small(immed) # 0 %start
	   putbyte(16_6A);
	   putbyte(immed & 255);
   %else
	   putbyte(16_68);
     	relocateoffset(reloc, immed);
   %finish

	listpreamble;
   printstring("PUSH")
   space
	%if reloc # 0 %start
		printstring(relocname(reloc)); printsymbol('+')
   %finish
   write(immed, 1)
   newline
	flushcode
%end

%routine dumpvpush(%record(stackfm)%name v)

   %if v_form = V in R %start
      dumpur(PUSH, v_base)
   %else
      %if v_form = V in S %start
         dumpum(PUSH, v_base!v_scope, v_disp)
      %else
         %if v_form = constant %start
            dumppushi(v_scope, v_disp)
         %else
            abort("Push Mode")
         %finish
      %finish
   %finish
%end
      
!----------------------------------------------------------
! Floating point instructions - much simpler since there are
! only two forms - RR and RM

%conststring(10)%array flopname(FILD:FLDPI) =
   "FILD", "FLD DWORD", "FLD QWORD", "FISTP",
   "FSTP DWORD", "FSTP QWORD", "FADDP", "FSUBP",
	"FSUBRP", "FMULP", "FDIVP", "FDIVRP",
	"FCOMPP", "FCHS", "FABS",
   "FSTSW AX", "FLDZ", "FLDPI"

! The prefix opcode
%constbyteintegerarray flprefix(FILD:FLDPI) =
	16_DF, 16_D9, 16_DD, 16_DF,
	16_D9, 16_DD, 16_DE, 16_DE,
	16_DE, 16_DE, 16_DE, 16_DE,
	16_DE, 16_D9, 16_D9,
   16_DF, 16_D9, 16_D9

! The function selector to put in the field in the second byte
! (or the second byte)
%constbyteintegerarray flindex(FILD:FLDPI) =
	16_00, 16_00, 16_00, 16_03,
	16_03, 16_03, 16_C0, 16_E8,
	16_E0, 16_C8, 16_F8, 16_F0,
	16_D8, 16_E0, 16_E1,
   16_E0, 16_EE, 16_EB

! Plant a Floating Point Reg <- Memory operation
! BASE is an internal ID, not actual register number
! Destination regsiter is implicitly the stack top
%routine dumpfloprm(%integer opn, %integer base, %integer disp)

	%if opn <= FLDQ %start;	! a load type
		fpu stack = fpu stack + 1
		%if fpu stack > 8 %then abort("FPU Stack Overflow")
	%else
		fpu stack = fpu stack - 1
		%if fpu stack < 0 %then abort("FPU Stack Underflow")
	%finish

   putbyte(16_9B);         ! we prepend a WAIT to everything
	putbyte(flprefix(opn));
	modrmmem(flindex(opn), base, disp);

	listpreamble;
   printstring(flopname(opn))
   space
	printmemref(base, disp);
   newline
	flushcode;
%end

! Plant a Floating Point Reg <- Reg operation
! Both register parameters are internal ID's that we
! convert to stack offsets
%routine dumpfloprr(%integer opn, %integer reg1, %integer reg2)
	%integer top

	top = fpustack + (FR0 - 1)

	%if reg2 # top %then abort("FPU Stack Address")

	%if opn < FCHS %start;	! two operands - will pop one
		fpu stack = fpu stack - 1
      %if opn = FCMP %then fpu stack = fpu stack - 1;   ! COMPP pops both registers
		%if fpu stack < 0 %then abort("FPU Stack Underflow")
	%finish

   putbyte(16_9B);         ! we prepend a WAIT to everything
	putbyte(flprefix(opn));
	putbyte(flindex(opn)!(top - reg1))

	listpreamble;
   printstring(flopname(opn))
   space
   printstring("ST(");
	write(top-reg1, 1)
	printstring("),ST")
   newline
	flushcode;
%end

! Plant a "special" floating point operation
%routine dumpflopspec(%integer opn)

	%if opn >= FLDZ %start;       ! load a constant
      fpu stack = fpu stack + 1
	   %if fpu stack > 8 %then abort("FPU Stack Overflow")
   %finish

   putbyte(16_9B);         ! we prepend a WAIT to everything
	putbyte(flprefix(opn));
	putbyte(flindex(opn))

	listpreamble
   printstring(flopname(opn))
   newline
	flushcode
%end

%routine dumpjump(%integer opn, %integer labelid)
	%integer jtype, count;

	! we put conventional assembler into the pipe for the listing
	! (with a zero jump offset) but then re-use the pipe for the
	! pseudo-code for the jump
	putbyte(opvalue(opn));
	putbyte(0);
	%if opn = CALL %then putbyte(0);

	listpreamble;
   printstring(opname(opn))
   space
   printsymbol('L');
   write(labelid,1)
   newline

	objectptr = 0;		! zap the current contents of the pipe
	count = 0;
	%if opn = JMP %start
		jtype = IF JUMP;
	%else
      %if opn = CALL %start
		   jtype = IF CALL;
      %else
   		jtype = IF JCOND;
	   	objectbytes(0) = (opn - JE);
		   count = 1;
      %finish
   %finish

	objectbytes(count) = (labelid & 255);
	objectbytes(count+1) = (labelid >> 8);

	writeifrecord(jtype, count+2, objectbytes);

	! finally, calls may trash registers...
	%if opn = CALL %start
      displayhint(BX) = 0
      displayhint(SI) = 0
      displayhint(DI) = 0
   %finish
%end

! call the n'th external routine we've spec'ed
%routine dumpextcall(%integer labelid)

   displayhint(BX) = 0
   displayhint(SI) = 0
   displayhint(DI) = 0

	putbyte(opvalue(CALL));
	flushcode;	! plant the "CALL" instruction
	putbyte(labelid & 255);
	putbyte(labelid >> 8);
	listpreamble;
	printstring("CALL EXTERN")
   write(labelid, 1);
   newline

	writeifrecord(IF REFEXT, 2, objectbytes);
	objectptr = 0;		! zap the current contents of the pipe
%end

%routine dumplabel(%integer labelid)

	select output(listout)
   space; writehex(nextcad, 4); spaces(22);
   printsymbol('L');
   write(labelid, 1);
   printstring("  EQU $")
   newline

	objectbytes(0) = labelid & 255;
	objectbytes(1) = labelid >> 8;
	writeifrecord(IF LABEL, 2, objectbytes);

   displayhint(BX) = 0
   displayhint(SI) = 0
   displayhint(DI) = 0
%end

%routine dumpstaticalloc(%integer which)

	! we pretend to dump "83 ec 00 SUB SP,0000" but we actually plant a special pass 2 directive
	putbyte(16_83);
	putbyte(16_ec);
	putbyte(16_00);
	listpreamble;
	printstring("SUB SP,00");
   newline
	objectptr = 0;		! zap the current contents of the pipe

	objectbytes(0) = which & 255;
	objectbytes(1) = which >> 8;
	writeifrecord(IF FIXUP, 2, objectbytes);
%end

! Pass 3 goes back and plants the correct preamble code for
! the static allocation based on this directive
%routine dumpstaticfill(%integer which, %integer size)

	objectptr = 0;		! zap the current contents of the pipe

	objectbytes(0) = which & 255;
	objectbytes(1) = which >> 8;
	objectbytes(2) = size & 255;
	objectbytes(3) = size >> 8;
	writeifrecord(IF SETFIX, 4, objectbytes);
%end

! dump words for the constant segment or the data segment
! Adjusts CAD so that the diagnostic listing looks sensible
%routine dumpcdword(%integer word, %integer which)

	%integer tag, tmpcad, hi, lo
   %owninteger cptr = 0
   %owninteger dptr = 0
   %owninteger sptr = 0

   tmpcad = next cad
	%if which = 2 %start
		tag = IF SWTWORD;
      next cad = sptr; sptr = sptr + 2
	%else
      %if which = 1 %start
		   tag = IF COTWORD;
         next cad = cptr; cptr = cptr + 2
	   %else
		   tag = IF DATWORD;
         next cad = dptr; dptr = dptr + 2
      %finish
   %finish

   hi = word >> 8
   lo = word & 255
	putbyte(lo);
	putbyte(hi);
	listpreamble;
	printstring("db ")
   writehex(lo, 2); printsymbol(','); writehex(hi, 2);
   printstring(" ; ")
   %if lo > 32 %and lo < 127 %then printsymbol(lo) %else printsymbol('.')
   %if hi > 32 %and hi < 127 %then printsymbol(hi) %else printsymbol('.')
   newline
	writeifrecord(tag, 2, objectbytes);
	objectptr = 0;		   ! clear the pipe
   nextcad = tmp cad;   ! restore the real CAD
%end

! tell the object file maker what source line we are on
%routine dumplinenumber(%integer line)

	%byteintegerarray buffer(0:1);
	%own %integer lastcad = 0;		! code address last time we did this

	%if nextcad # lastcad %start
		buffer(0) = (line & 255);
		buffer(1) = (line >> 8);
		writeifrecord(IF LINE, 2, buffer);
		lastcad = nextcad;
	%finish
%end

! utility to copy an IMP string into a simple buffer to
! pass to the IF Record routine
%routine str to xsym(%string(255)%name s)
   %integer l

   l = length(s)
   xlen = 0
   %while xlen < l %cycle
      x sym buff(xlen) = charno(s, xlen+1)
      xlen = xlen + 1
   %repeat
%end

! tell the object maker the source file name
%routine dumpsourcename(%string(255) filename)

   str to xsym(filename)
	writeifrecord(IF SOURCE, xlen, x sym buff);

%end

! tell the linker about an external definition
%routine fill external(%integer seg, offset, %string(255) extname)
	
   str to xsym(extname)
	%if seg = CODE %start
		writeifrecord(IF DEFEXTCODE, xlen, x sym buff);
	%else
		writeifrecord(IF DEFEXTDATA, xlen, x sym buff);
	   ! er, this doesn't actually work yet!
	%finish
%end

! Plant a request to the linker for the external name, and
! return an index number to refer to it with in future
%integerfn externalref(%string(255) extname)
   %owninteger nextextref=1

   str to xsym(extname)
	writeifrecord(IF REQEXT, xlen, x sym buff);
   nextextref = nextextref + 1
	%result = nextextref - 1;
%end

!------------------------------------------------------
! Constant table utility routines
!
! Rather than dump literal constants as they occur, we
! collect them in a table.  Whenever the compiler wants
! any kind of literal, we look to see if we already
! have it.  Note this automatically solves re-use of
! things like floating point constants, string newline,
! and fixed array dope vectors.  When the table starts
! to get fairly full, we flush it.  Obviously that means
! in a large program we might not actually get full re-use
! of constants after we've flushed, but the idea is sound.
!
! For the convenience of the caller, several versions of
! pretty much the same thing are provided.
!------------------------------------------------------
%constinteger cot size = 2000
%ownbyteintegerarray contable(0:cot size)
%owninteger cotp = 0
%owninteger cotoffset = 0;       ! updated on a flush

%routine flushcot
   %integer i

! We output a position hint to the diagnostic stream
! Note that although this is intended to look like
! 8086 assembly directives the real work is done by
! pass 3 - this is only to guide the human reader as
! to what is going on

   selectoutput(listout)
   printstring("      _TEXT    ENDS
      CONST  SEGMENT WORD PUBLIC 'CONST'
")
	i = 0
	%while i < cotp %cycle
		dumpcdword((contable(i+1) << 8) ! contable(i), 1)
		i = i + 2;
   %repeat

! Update the pointers
   cotp = 0
   cotoffset = cotoffset + i

! and send another hint
   selectoutput(listout)
	printstring("      CONST    ENDS
      _TEXT  SEGMENT WORD PUBLIC 'CODE'
")

%end

! return the offset in the const segment of a byte
! with value b
%integerfn getcotb(%byteinteger b)
   %integer i

   i = 0
   %while i < cotp %cycle
      %if contable(i) = b %then %result = i + cotoffset
      i = i + 1
   %repeat

   ! value wasn't there
   %if cotp = cotsize %then flushcot

   contable(cotp) = b
   cotp = cotp + 1
   %result = (cotp - 1) + cotoffset
%end

! return the offset in the const segment of a word
! with value w
%integerfn getcotw(%integer w)
   %integer i, cw

   i = 0
   %while i < cotp-1 %cycle
      cw = contable(i)!(contable(i+1)<<8)
      %if cw = w %then %result = i + cotoffset
      i = i + 2
   %repeat

   ! value wasn't there - first make sure there is space
   %if cotp > cotsize-2 %then flushcot

   ! now round off the COT
   cotp = (cotp + 1) & (\1)
   contable(cotp) = w & 255
   contable(cotp+1) = w >> 8
   cotp = cotp + 2
   %result = (cotp - 2) + cotoffset
%end

! return the offset in the const segment of a double word
! with value dl:dh
%integerfn getcot2(%integer dl, dh)
   %integer i, cwl, cwh

   i = 0
   cwl = contable(i)!(contable(i+1)<<8)
   %while i < cotp-3 %cycle
      cwh = contable(i+2)!(contable(i+3)<<8)
      %if cwl = dl %and cwh = dh %then %result = i + cotoffset
      i = i + 2
      cwl = cwh
   %repeat

   ! value wasn't there - first make sure there is space
   %if cotp > cotsize-4 %then flushcot

   ! now round off the COT
   cotp = (cotp + 1) & (\1)

   contable(cotp) = dl & 255
   contable(cotp+1) = dl >> 8
   contable(cotp+2) = dh & 255
   contable(cotp+3) = dh >> 8
   cotp = cotp + 4
   %result = (cotp - 4) + cotoffset
%end

! return the offset in the const segment of a quad word
! with value q0:q1:q2:q3 (lo to hi)
%integerfn getcot4(%integer q0, q1, q2, q3)
   %integer i, cw0, cw1, cw2, cw3

   i = 0
   cw0 = contable(i)!(contable(i+1)<<8)
   cw1 = contable(i+2)!(contable(i+3)<<8)
   cw2 = contable(i+4)!(contable(i+5)<<8)
   %while i < cotp-3 %cycle
      cw3 = contable(i+6)!(contable(i+7)<<8)
      %if cw0 = q0 %and cw1 = q1 %and cw2 = q2 %and cw3 = q3 %then %result = i + cotoffset
      i = i + 2
      cw0 = cw1
      cw1 = cw2
      cw2 = cw3
   %repeat

   ! value wasn't there - first make sure there is space
   %if cotp > cotsize-8 %then flushcot

   ! now round off the COT
   cotp = (cotp + 1) & (\1)

   contable(cotp) = q0 & 255
   contable(cotp+1) = q0 >> 8
   contable(cotp+2) = q1 & 255
   contable(cotp+3) = q1 >> 8
   contable(cotp+4) = q2 & 255
   contable(cotp+5) = q2 >> 8
   contable(cotp+6) = q3 & 255
   contable(cotp+7) = q3 >> 8
   cotp = cotp + 8
   %result = (cotp - 8) + cotoffset
%end

%owninteger null string = -1

! get an index into the constant table for the string literal
! in the array s
%integerfn getcots(%byteintegerarrayname s)
	%integer i, first, len, match;

   len = s(0) + 1;      ! number of bytes to search for

! We optimise the Null String "" in comparisons, so we remember
! the location here
   %if len = 0 %start
      null string = getcotb(0)
      %result = null string
   %finish

   first = 0;           ! offset to search in contable

   %while first + len - 1 < cotp %cycle;   ! so long as there are that many bytes left
      match = 1
      %for i = 0, 1, len-1 %cycle
         %if s(i) # contable(first + i) %start
            match = 0
            %exit
         %finish
      %repeat
      %if match = 1 %then %result = first + cotoffset
      first = first + 1;               ! try the next solution
   %repeat

   ! if we get here, it wasn't already in the constant table
	%if (cotp + len) >= cotsize %then flushcot

	first = cotp
   i = 0;
	%while len > 0 %cycle
		contable(cotp) = s(i)
		cotp = cotp + 1
		i = i + 1
		len = len - 1
	%repeat
	%result = first + cotoffset
%end

!------------------------------------------------------
! Data segment utility routines
!
! Unlike constants, we can't re-use data segment items,
! which makes this much simpler
!------------------------------------------------------

!                                                            >> GBYTE <<
! Simple byte in data segment
%routine  gbyte(%integer  n)

   Abort("Data Seg Overflow") %if datatp > max dataseg   
   datat(datatp) = n & 255;
   datatp = datatp + 1
%end

!                                                            >> GPUT <<
! Put a word into data segment
%routine  gput(%integer  n)

   gbyte(n & 255)
   gbyte(n >> 8);
%end

!                                                             >> GFIX <<
! round off the datasegment pointer for alignment
%routine  gfix(%integer align)
   gbyte(0) %while datatp & align # 0
%end

%routine flush data
   %integer i

! We output a position hint to the diagnostic stream

   selectoutput(listout)
   printstring("              ENDS
      DATA  SEGMENT WORD PUBLIC 'DATA'
")
	i = 0
	%while i < datatp %cycle
		dumpcdword((datat(i+1) << 8) ! datat(i), 0)
		i = i + 2;
   %repeat

! and send another hint
   selectoutput(listout)
	printstring("      DATA    ENDS
")

%end

!-----------------------------------------------------
! The last table we collect as we go along is the switch
! table.  We don't provide individual routines to fill
! it in, but for tidyness we provide this routine to send
! the contents to pass 3

%routine flush switch
   %integer i

   select output(listout)
   printstring("              ENDS
      _SWTAB  SEGMENT WORD PUBLIC '_SWTAB'
")
	i = 0
	%while i < swtp %cycle
		dumpcdword(swtab(i), 2)
		i = i + 1
   %repeat

! and send another hint
   selectoutput(listout)
	printstring("      _SWTAB   ENDS
")

%end

!-------------------------------------------------------------
! Print the source code lines up to the indicated line
! number - these will interleave with the diagnostic assembly
! output

%owninteger echoline = 0

%routine echo source line
   %integer ch
   %owninteger source eof = 0

   echoline = echoline + 1;            ! update the count even if there's no input

   %if source eof # 0 %then %return;   ! silently ignore lack of source file

   select input(source)
   select output(listout)
   %cycle
      readsymbol(ch)
      printsymbol(ch)
      %exit %if ch = 10 %or ch < 0
   %repeat

   %if ch < 0 %then source eof = 1

   select input(icode)
   select output(objout)
%end

!-----------------------------------------------------------
! General descriptor and register manipulation routines
!-----------------------------------------------------------

!                                                         >> FLOATING <<
%integerfn  floating(%record(stackfm)%name v)
! check descriptor for floating point quantity
   %result = 1 %if v_type = real %or v_type = lreal
   %result = 0
%end

!                                                             >> ZERO <<
%integerfn  zero(%record(stackfm)%name  v)
! CHECK DESCRIPTOR FOR (INTEGER) ZERO
   %result = 0 %if v_disp # 0 %or v_base # 0 %or (v_form # constant %and v_form # AV in S)
   %result = 1
%end

!                                                            >> CONST <<
%integerfn  const(%record(stackfm)%name  v)
! CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE
   %result = 0 %unless v_form = constant
   %result = 0 %if v_type > byte
   %result = 1
%end

%integerfn Min Record Size(%record(stackfm)%name A, B)
   %integer N, M
   N = A_format;  N = var(N)_size & 16_7FFF %if N # 0
   M = B_format;  M = var(M)_size & 16_7FFF %if M # 0
   N = M %if N = 0 %or (M # 0 %and M < N)
   %result = N %if N > 0
   Abort("Min Rec Size")
%end

!                                                             >> MULSHIFT <<
%integerfn mulshift(%integer n)
   %integer shift, ref
   ref = 1
   %for shift = 1, 1, 14 %cycle
      ref = ref<<1
      %if ref >= n %start
         %if ref = n %then %result = shift %else %result = -1
      %finish
   %repeat
   %result = -1
%end

!                                                             >> SAME <<
%integerfn  same(%record(stackfm)%name  v,w)
! Test whether or not V and W describe the same object.
   %result = 0 %if v_disp # w_disp %or v_base # w_base
	%result = 0 %if v_type # w_type %or v_form # w_form
	%result = 0 %if v_extra # w_extra %or v_scope # w_scope
   %result = 1
%end

!                                                              >> READ TAG <<
%integerfn  read tag
   %integer s1, s2
   s1 = next sym
   readsymbol(s2)
   readsymbol(next sym)
   %result = s1<<8!s2
%end

!                                                            >> GET D <<
! Read a floating point literal.  Pass 1 treats these as strings
! and leaves it up to us to make a floating point number out of it
! We therefore expect [COUNT]NNN.NNN@NN
%routine  get d
	%integer n
	%longreal p
	n = read tag; read symbol(next sym);	! char count, skip comma
   rvalue = 0
! Start with the bit ahead of the decimal point
   %cycle
      sym = next sym;  read symbol(next sym)
      %exit %if sym = '.'
      n = n-1
      -> power %if sym = '@'
      rvalue = rvalue*10+(sym-'0')
      -> SIGN %if n = 0
   %repeat
   p = 1
   %cycle
      n = n-1;  -> SIGN %if n = 0
      sym = next sym;  read symbol(next sym)
      -> POWER %if sym = '@'
      p = p/10
      rvalue = rvalue + (sym-'0')*p
   %repeat
POWER:
   n = read tag
	! somewhat clunky so that we can be portable to a system that
	! doesn't do exponents
	%while n > 0 %cycle
	   rvalue = rvalue * 10
		n = n - 1
	%repeat
	%while n < 0 %cycle
		rvalue = rvalue / 10
		n = n + 1
	%repeat
SIGN:               ! sign of whole value
   %if next sym = 'U' %start
      read symbol(next sym)
      rvalue = -rvalue
   %finish
%end

! grab a slab of working store in the local stack
%integerfn getwork(%integer size)
	%integer cell;

	cell = worklist(level);
	%while cell # 0 %cycle
		%if gp tags(cell)_info = size %and gp tags(cell)_flags = 0 %start; ! suitable candidate?
			gp tags(cell)_flags = 1;		! mark it as in use
			%result = gp tags(cell)_addr;
		%finish
		cell = gp tags(cell)_link;
	%repeat

	! no space available already - make more
	cell = get gp tag
	frame = (frame - size) & (\1);   ! make them all even boundaries
	gp tags(cell)_addr = frame;
	gp tags(cell)_info = size;
	gp tags(cell)_link = worklist(level);
	worklist(level) = cell;
	gp tags(cell)_flags = 1;		! in use
	%result = gp tags(cell)_addr;
%end

! Return a slab of working store to the free pool.  Note that
! ReturnWork is cautious about what it accepts - it only takes
! in items it has previously given out, so we can call it
! fairly liberally with any old rubbish and it will do the
! right thing
%routine Return Work(%integer addr)
	%integer cell

	cell = worklist(level);
	%while cell # 0 %cycle
		%if gp tags(cell)_addr = addr %start
			%if gp tags(cell)_flags = 0 %then abort("Return Work")
			gp tags(cell)_flags = 0;		! mark it as free
			%return
		%finish
		cell = gp tags(cell)_link;
	%repeat

! Here, work area was not found - it probably wasn't a work area!
%end

! Check to see if a variable is in a work list assigned block
%integerfn Is Work(%record(stackfm)%name v)
	%integer cell

	%if v_base # BP %or v_disp >= 0 %or v_scope # 0 %or v_form # v in s %then %result = 0

	cell = worklist(level);
	%while cell # 0 %cycle
		%if gp tags(cell)_addr = v_disp %start
			%if gp tags(cell)_flags = 0 %then abort("Is Work")
			%result = 1
		%finish
		cell = gp tags(cell)_link;
	%repeat

	%result = 0
%end


!                                                          >> RELEASE <<
%routine  release(%integer  reg)
! Hazard the value in a register
!   abort("Release bad register") %if reg > fr7
   %return %if reg = 0 %or reg > fr7 %or activity(reg) < 0;  ! LOCKED
   activity(reg) = activity(reg)-1
   abort("Release inactive") %if activity(reg) < 0
   claimed = claimed - 1
%end

!                                                            >> CLAIM <<
%routine  claim(%integer  reg)
! Cherish the value in a register
   abort("Claim bad register") %if reg > fr7
   %return %if reg = 0 %or activity(reg) < 0
   activity(reg) = activity(reg)+1
   claimed = claimed+1
%end

!                                                           >> HAZARD <<
! Protect any value in register REG by storing in a temporary.
%routine  hazard(%integer  reg)
   %integer  i, n, t, type
   
         %routine  mod(%record(stackfm)%name  v)
            %switch  sw(0:a in rec)
            v_base = BP
            n = n-1
            -> sw(v_form)
         sw(a in rec):
         sw(av in rec):
         sw(v in rec):
         sw(constant): abort("Mod")

         sw(v in s):   %if v_disp = 0 %and v_scope = 0 %start
                          v_disp = t;  v_form = a in s;  ->out1
                       %finish
         sw(a in s):
         sw(av in s):
      !  change (X in S) to (X in REC)
            v_form = v_form + 3;  v_extra = t;  -> OUT1

         sw(v in r): v_form = v in s;  v_disp = t
            v_type = type
         OUT1:
         %end

   n = activity(reg);  %return %if n <= 0;  ! NOT IN USE OR CLAIMED

   claimed = claimed - n
   activity(reg) = 0
   %if reg >= fr0 %start
		! Note that the FPU can only save the top of the stack.
		! If we need to save something lower down, we need to pop
		! the things above me first...
		%if reg - FR0 >= FPU Stack %then hazard(reg+1); ! and recurse as required
      type = lreal
      t = getwork(8)
		dumpfloprm(FSTQ, BP, t)
   %else
      type = integer
      t = getwork(2)
      dumpmr(MOV, BP,t, reg)
   %finish
   %for i = 1, 1, stp %cycle
      mod(stack(i)) %if stack(i)_base = reg
   %repeat
   abort("Usage Outstanding") %if n # 0;      ! USE STILL OUTSTANDING
%end

!																					>> HAZARD ALL <<
%routine  hazard all
   %integer  j

   %if claimed # 0 %start;            ! at least one register claimed
      hazard(j) %for j = AX,1,FR7
   %finish
%end

!                                                              >> GP REG <<
! Get a general (integer) register
! Note that registers AX, CX, DX, BX are, in order
! numbers 1, 2, 3 and 4 (which is convenient)
%integerfn  gpreg
   %integer  r

! look for an empty one
   %for r = AX,1,BX %cycle
      %result = r %if activity(r) = 0
   %repeat

! look for an unlocked one
   %for r = AX,1,BX %cycle
      %if activity(r) > 0 %start
         hazard(r)
         %result = r
      %finish
   %repeat

   abort("Get Reg")
%end

!                                                              >> PT REG <<
%integerfn  pt reg
! Get a register we can use as a pointer.  We deliberately rotate
! around the candidates to make re-use more likely
   %constbyteintegerarray  pt pref(0:2) =
         7,  8,  4
       ! SI, DI, BX
   %owninteger next = 0
   %integer  r,j

! look for an empty one
   %for j = 1,1,3 %cycle
      r = pt pref(next)
      next = next+1; next = 0 %if next = 3
      %result = r %if activity(r) = 0
   %repeat

! look for an unlocked one
   %for j = 1,1,3 %cycle
      r = pt pref(j)
      %if activity(r) > 0 %start
         hazard(r)
         %result = r
      %finish
   %repeat

   abort("Get PT Reg")
%end

!                                                              >> FPU REG <<
! Returns the next register on the FPU stack
%integerfn  fpu reg
	%result = FR0 + FPU Stack
%end

!                                                              >> GET DISPLAY <<
! return the register to use to access display level <n>
%integerfn getdisplay(%integer l)
   %integer r, lev

   lev = l & 15;                  ! get rid of any relocation info
	%if lev = 0 %then %result = l; ! global
	%if lev = level %then %result = BP; ! local

   ! We now try the 3 pointer register - they are not contiguously
   ! numbered, which is why this is unrolled!
   %if displayhint(BX) = lev %then %result = BX
   %if displayhint(SI) = lev %then %result = SI
   %if displayhint(DI) = lev %then %result = DI

   r = pt reg
   dumprm(MOV, r, DISPLAY, lev*2)
   displayhint(r) = lev
	%result = r
%end

!																					>> SET DOPE VECTOR <<
! Plants a dope vector for a 1-D constant bound array (usually
! OWN or CONST arrays) in the CONST segment, returns the offset
! Note that it also modifies the vlb and vub variables - after
! the call, VLB contains the byte offset for the first member
! and VUB contains the size to allocate for the array in bytes.
%integerfn  set dope vector
   %integer  t, dv

   t = vub-vlb+1
   dv = getcot4(1, vlb, vub, data size)
   vub = t*data size;  vlb = vlb*data size
   %result = dv
%end

!																					>> PERM <<
! calls a PERM and adjusts the stack by SPACE bytes afterwards
%routine  perm(%integer  n, space)
! PERM routines are written in MS C, and they preserve SI and DI,
! but trash the general purpose registers
   hazard(AX); hazard(CX); hazard(DX); hazard(BX)
	dumpextcall(n)
   %if space # 0 %then dumpri(ADD, SP, space)
%end

!																					>> ASSEMBLE <<
! AMODE:
!  -3: initial call
!  -2: alternate record format
!  -1: record format
!   0: begin block
!   1: procedure
!   2: %spec

%routine Assemble(%integer  amode, labs, names)
   %switch c(33:127)
   %record(varfm)%name  v;                ! General purpose pointer
   %record(varfm)%name  procvar;          ! Var of the current procedure we're compiling
   %record(varfm)%name ap, fp;            ! Actual parameter & formal parameter ptrs, used to copy parms to parm area
   %record(stackfm)%name  lhs, rhs;       ! General stack pointers
   %record(stackfm) temp;                 ! A stack record for shuffling and copying
	%integer max frame;							! Used for alternate records to find the largest alternate
   %integer first name;                   ! First descriptor at this level
   %integer staticalloc;                  ! Tag used by pass 3 to fix up this level's stack allocation
   %integer skipproc, lastskip;           ! Used to jump around routines
   %integer First label;                  ! First label at this level
   %integer old frame;                    ! Previous level's static allocation
   %integer  i, j, k, n, t
   %integer opr, val, dv

   %routinespec compile to string(%record(stackfm)%name v)
   %routinespec  load(%record(stackfm)%name  v, %integer  reg)
   %routinespec  assign(%integer  assop)
   %routinespec  array ref(%integer  mode)
   %routinespec  operate(%integer  n)
   %routinespec  compare(%record(stackfm)%name  l,r)
   %routinespec test zero(%record(stackfm)%name v)
   %integerfnspec new tag


! Actual code for Assemble is down around label NEXT


!                                                       >> DEFINE VAR <<
%routine  define var
   %integer  type, form, tf, size, format, s, new, round, dimension
   %integer  dv;              ! dope vector offset
   %owninteger  prim no = 0

   internal id = "";  new = 0;  round = align

   ! Get the var index
   decl = read tag
   %if decl = 0 %start;         ! RECORD FORMAT ELEMENT NAME
      parms = parms-1;  abort("Def Var Parms") %if parms <= names
      decvar == var(parms)
      decvar = 0
   %else
      abort("Def Var Names") %if decl >= parms
      decvar == var(decl)
      %if decl > names %start
         names = decl;  new = 1
         decvar = 0
      %finish
   %finish

   ! Now get the variable name
   %cycle
      sym = next sym;  read symbol(next sym);  %exit %if sym = ','
      %if length(internal id) # 255 %start
         internal id = internal id.to string(sym)
      %finish
   %repeat

   ! Now read the type and form word
   tf = read tag;  read symbol(next sym)
   type = tf>>4;  form = tf&15

   ! And get the size/format word
   size = read tag;  read symbol(next sym)

   ! Map external type numbers into internal equivalents,
   ! and adjust for short/byte/long things
   %if type = integer %and size # 1 %start;			! INTEGER
      type = byte  %and round = 0 %if size = 2
      size = vsize(type)
   %else
      %if type = real %start;                      ! REAL
         type = lreal %if size = 4;                ! LONG REAL
         size = vsize(type)
      %else
         %if type = record %start;                 ! record
            format = size
            decvar_format = format
            size = var(format)_size %if format <= names
         %else
            %if type = string %start;              !  string
               round = 0
               decvar_size = size
               size = size + 1
            %else
               size = vsize(type)
            %finish
         %finish
      %finish
   %finish

   decvar_size = size %if type # string
   decvar_type = type;  decvar_form = form

   ! Now read the Scope word
   otype = read tag
   spec = (otype>>3)&1;  dimension = otype>>8&255;  otype = otype&7

   %if otype # 0 %start;      ! Set external linkage name if appropriate
      %if otype >= external %start
         %if length(alias) # 0 %start
            external id = alias
         %else
            %if otype = system %start
               external id = system prefix.internal id
            %else
               external id = "_".internal id
            %finish
         %finish
         otype = external %if otype <= dynamic; !external, system, dynamic
      %finish
   %finish
   alias = ""

   %if 7 <= form %and form <= 10 %start;        ! PROCEDURE
      block type = 1 + spec;                    ! 1 for normal proc, 2 for spec
      %if otype # 0 %and spec # 0 %start;       ! external spec
         %if otype = primrt %start
            primno = primno + 1
            decvar_level = 128
            decvar_disp = prim no
            %return
         %finish
			decvar_disp = externalref(external id)
         decvar_level = 0
         decvar_scope = EXT
         %return
      %finish

      %if in params = 0 %start;              ! NOT A PARAMETER
         potype = otype
         %if new # 0 %start;             ! NEW NAME
            decvar_disp = new tag;       ! Procedure ID
         %finish
         %return
      %finish

      otype = 0;  size = 2;  data size = 2;  ! procedure parameter

   %else;   ! This is not a procedure declaration

      data size = size

      %if form # 1 %start
         Round = Align
         %if type = general %start;                ! General %name
            decvar_extra = in params;            ! FOR LABELS
            size = 4
         %else
            %if form = array %or form = name array %start
               ! We will fill in dimensions and allocate space when
               ! we are told the bounds later
               size = 0
               data size = 2 %if form = name array
            %else
               %if form = array name %or form = name array name %start
                  decvar_dim = dimension
                  size = 4;  round = align;         ! array header
               %else
                  size = 2;                       ! integer (etc) %name
               %finish
            %finish
         %finish
      %finish
   %finish

! Now deal with OWN (or const/extern/etc) data items

   %if otype # 0 %start;      ! OWN DATA
      %if otype = con %start;      ! CONST INTEGER ETC.
         data size = 0 %if type = string %and form = 1;    ! use actual size for plain strings
         %if form = 2 %or form = arrayname %or form = namearrayname %start
            otype = 0;        ! Treat as special later
         %finish
      %else;                  ! OWN, not CONST
         gfix(round);         ! so make it even if needed
      %finish

      ! set globals used by our data collection utilities
      own type = type;  own form = form
      own type = integer %and data size = 2 %if form = 2; ! %name's are really integers

      %if spec = 0 %start
         %if form = array %or form = name array %start
            gfix(align)
            dv = set dope vector;      ! N.B.  changes vlb, vub
            ! We treat OWN and CONST arrays identically - both are in data segment
            gfix(align)
            decvar_disp = datatp - vlb;  decvar_level = 0; decvar_scope = DATA
            decvar_pbase = dv;                  ! save the dope vector pointer here
            decvar_dim = 1;                     ! own arrays are always 1-D
            fill external(DATA, decvar_disp, external id) %if otype = external
         %finish
      %else
         decvar_level = 0; decvar_scope = EXT
         decvar_disp = external ref(external id)
      %finish
      %return
   %finish

   %if form = 3 %start;         !%label
      decvar_disp = new tag
      %return
   %finish

   %if form = switch %start
      size = vub - vlb
      %if swtp + size > Max Switch %then abort("Switch Table Full")
      decvar_scope = SWT;  decvar_disp = swtp - vlb
      decvar_extra = set dope vector
      %for s = swtp, 1, swtp + size %cycle
         swtab(s) = 0;     ! should really deal with undefined switch entries
      %repeat
      swtp = swtp + size + 1
      %return
   %finish

   %if form = record format %start
      %if in params # 0 %start
         frame = decvar_size %if decvar_size > frame
      %else
         block type = -1;  spec = -1
      %finish
      %return
   %finish

   ! Here we've got an ordinary local variable, parameter or record entry
   
   decvar_level = level
   %if in params = 0 %start;      ! local variable
      frame = (frame - size) & (\round)
      decvar_disp = frame
   %else;                     ! parameter or record
      %if block type > 0 %start;   ! procedure parameters
			frame = (frame + size + 1) & (\1);	! parameters are always word aligned
			decvar_disp = frame;						! offset will be adjusted at '}'
		%else;								! records
			frame = (frame + round) & (\round)
			decvar_disp = frame
			frame = frame + size
         decvar_level = 0;          ! no base register
      %finish
   %finish
%end;        !    define var


!----------------------------------------------------------------------
! Stack manipulation routines
!----------------------------------------------------------------------

!                                                             >> POP STACK <<
! Pop the top of the stack
%routine  Pop Stack
   %if stp = 0 %then abort("Pop")
   monitor(top, "Pop") %if diagnose&1 # 0
   stp = stp - 1
   %if stp # 0 %then top == stack(stp) %else top == null
%end

!                                                             >> POP REL <<
! Pop the top of the stack, and release its' register
%routine  pop rel
   release(top_base)
   pop stack
%end

!                                                           >> PUSH VAR <<
! Push a descriptor on the stack corresponding to Var "var no"
! We map the variable form to a stack form, and assign a register
! for the base if it is non local.  Finally, we absorb the scope
! into the base register.
%routine  push var(%integer  var no)
   %record(varfm)%name  w
   %constbyteintegerarray fmap(0:15) = %c
    0,  4,        6,     10,          4,        0,
!   0, v in s, a in s, pgm label, recordformat, 0,
    6,      0, 1,      4,      1,      4,      6,      4,      6,      0
!   switch, 0, v in r, v in s, v in r, v in s, a in s, v in s, a in s, 0
   
   abort("Push Var Idx") %unless 0 <= var no %and var no <= max vars
   w == var(varno)
   stp = stp + 1
   %if stp > Max Stack %then abort("Push V Stack Overflow")
   top == stack(stp)
   top = 0

   ! Translate "level" into "base register" - if it is non local
   ! we flag it by adding 16 to the desired level, which later will
   ! force us to pick up a pointer register
   %if w_level # 0 %start
      %if w_level = level %then top_base = BP %else top_base = w_level + 16
   %else
      top_base = 0
   %finish

   top_scope = w_scope
   top_type = w_type

   ! AFORM contains the real original declared form, while
   ! FORM contains the on-the-stack subset of possible forms
   top_aform = w_form
   top_form = fmap(w_form)
	top_dim = w_dim
   top_disp = w_disp
   top_scope = w_scope
   top_format = w_format
   top_size = w_size
   top_extra = w_extra
   top_pbase = w_pbase

   top_varno = varno
   monitor(top, "Var stack") %if diagnose&1 # 0
%end

!                                                           >> PUSH COPY <<
! Push a duplicate of a stack record onto the stack
%routine  push copy(%record(stackfm)%name  v)
   stp = stp + 1
   %if stp > Max Stack %then abort("Stack Const")
   top == stack(stp)
   top = v
   monitor(top, "Stack Copy") %if diagnose&1 # 0
%end

!                                                          >> PUSH CONST <<
! Push a constant on the stack
%routine  push const(%integer  n)
   stp = stp + 1
   %if stp > Max Stack %then abort("Stack Const")
   top == stack(stp)
   top = 0
   top_disp = n
   top_type = integer
   top_form = constant
   monitor(top, "push const") %if diagnose&1 # 0
%end

!-----------------------------------------------------------------------
!STRING PROCESSING
!-----------------------------------------------------------------------

!                                                      >> DUMP STRING <<
! writes the latest received string (in Current String) to
! either const or data segment (depending on SIZE).  Returns
! the offset in that segment of the string.  The size of space
! to reserve is in SIZE.  In the special case where SIZE is zero
! this is a fixed constant string and can be re-used in the
! constant table, otherwise we put it in the data segment
%integerfn  dump string(%integer  size)
   %integer  j, p
   
   %if size = 0 %start;       ! Fixed constant string
      %result = getcots(current string)
   %finish

! check for overflow
   %if cslen+1 > size %start
      ! String constant too long - warn and truncate
      warn(5);  current string(0) = size-1
   %finish

   p = datatp
   %for j = 0,1,size-1 %cycle
      gbyte(current string(j))
   %repeat
   %result = p
%end

!                                                       >> GET STRING <<
! Read a string literal from the iCode stream
%routine  get string
   %integer  l
   l = next sym;                  !length
   cslen = 0
   %while l > 0 %cycle
      l = l-1
      read symbol(next sym)
      cslen = (cslen+1)&255;  current string(cslen) = next sym
   %repeat

   ! if this is about to be used as a literal, put it straight into
   ! the CONST segment and stack it, otherwise leave it in curr string to see
   ! what comes next and stack a dummy zero
   readsymbol(next sym)
   %if next sym # 'A' %and next sym # '$' %start
      otype = con;        ! anonymous %const
      push const(dump string(0));  top_type = string
      top_base = 0; top_scope = COT; top_form = VinS;  top_format = cslen+1
   %else
      push const(0);         ! explicit string initialisation coming next
   %finish
%end

!                                                    >> REAL CONSTANT <<
! Put the current rvalue in the constant table, return the offset
%integerfn  real constant
	%integer w1, w2, w3, w4

! Warning - this is horribly non-portable, and relies on this
! being a native compiler.  For cross-compiling, think again!
! It's also a wee bit messy 'cos we've redefined the word INTEGER
! so we can't use the built-in map!
	w1 = byteinteger(addr(rvalue)) ! byteinteger(addr(rvalue)+1)<<8
	w2 = byteinteger(addr(rvalue)+2) ! byteinteger(addr(rvalue)+3)<<8
	w3 = byteinteger(addr(rvalue)+4) ! byteinteger(addr(rvalue)+5)<<8
	w4 = byteinteger(addr(rvalue)+6) ! byteinteger(addr(rvalue)+7)<<8

   %result = getcot4(w1, w2, w3, w4)
%end;                  ! real constant

!-------------------------------------------------------
!LABEL PROCESSING
!
! Labels fixups are handled by pass 3 - we just plant
! numerical labels for code locations, and then jump to or call
! those labels.  Pass 3 turns them into real locations.
! Unfortunately Pass 3 needs unique label numbers whereas
! Pass 1 produces lame local label numbers that can
! be reused once they've been defined.  We therefore
! maintain an indirect database to map Pass 1 label numbers
! into unique tags

!                                                          >> NEW TAG <<
! Get the next consecutive Pass 3 label ID
%integerfn  new tag
   %owninteger free tag = 999

   free tag = free tag + 1
   %result = free tag
%end

!                                                        >> NEW LABEL <<
! Get the next available label database index
%integerfn  New Label
   labs = labs+1;  abort("Labels") %if labs > Max Labs
   %result = labs
%end

!                                                        >> FIND LABEL<<
! return the index in our label table of the Pass 1 label
%integerfn  Find Label(%integer  label)
	%integer  lp

   lp = labs
   %while lp # first label %cycle
      %result = lp %if labels(lp)_id = label
      lp = lp-1
   %repeat
   %result = 0
%end

!                                                     >> DEFINE LABEL <<
! This label is "here"
%routine  Define Label(%integer  label)
   %integer lp
   %record(labelfm)%name  l

	lp = Find Label(label)
	%if lp = 0 %start;				! Not yet been used
		lp = New Label
		l == labels(lp)
		l_id = label
		l_tag = new tag
	%else
		l == labels(lp)
		%if l_tag & 16_8000 # 0 %and label > 0 %then l_tag = new tag
	%finish

	dump label(l_tag)
	l_tag = l_tag ! 16_8000
   uncond jump = 0;            ! You can get here
%end;       ! define label

!                                                          >> JUMP TO <<
! A wrapper for conditional jumps to labels that we're going
! to map into tags
%routine  Jump To(%integer  label, op, flag)
	%record(labelfm)%name  l
	%integer  lp

	lp = Find Label(label)
	%if lp = 0 %start
		lp = New Label
		l == labels(lp)
		l_id = label
		l_tag = new tag
	%else
		l == labels(lp)
		%if flag # 0 %and l_tag & 16_8000 # 0 %then l_tag = new tag
	%finish

	dump jump(op, l_tag & 16_7FFF)

	%if op = JMP %then uncond jump = nextcad
%end;            ! jump to


!-------------------------------------------------------
! Stack variable transformations
!-------------------------------------------------------

!                                                           >> REDUCE <<
! Convert a variable which is addressed in a Rec into a simple variable
! by loading the indirect value into a register and changing the form
%routine  reduce(%record(stackfm)%name  v)
   %integer  type, form, disp, scope
   
   form = v_form - 3;         ! X in REC => X in S
   type = v_type
   disp = v_disp
! Here's a trick - we've got two displacements, DISP and EXTRA, but only
! one SCOPE hint.  Which does it belong to?  If the REC form came from
! a HAZARD then the scope belongs to the DISP, but for all other cases
! the scope belongs to the EXTRA.  If we got here through HAZARD then
! the BASE will be BP - for all other cases it will be either a different
! register, or zero.
   %if v_base = BP %start
      scope = v_scope
      v_scope = 0
   %else
      scope = 0
   %finish
   v_disp = v_extra;  v_type = integer;  v_form = v in s
   load(v, anyp)
   v_type = type;  v_form = form
   v_disp = disp;  v_scope = scope
%end

!                                                             >> AMAP <<
! convert V into a descriptor for the address of V
%routine  amap(%record(stackfm)%name  v)
   %integer f
   %constintegerarray  addr map(0:15) =
    -1, -2, -3, -4, 5,       -5, 4,      8,         -6, 7,
!   -1, -2, -3, -4, av in s, -5, v in s, av in rec, -6, v in rec,
    -7, -8, -9, -10, -11            , -12
!   -7, -8, -9, -10, -11 {PGM LABEL}, -12 {record format}

! ABD - should be code here to deal with ADDR(pgm label)

   f = addr map(v_form)
   %if f < 0 %start
      monitor(v, "AMAP target")
      abort("AMAP")
   %finish

! Try to simplify some forms...
   %if v_disp = 0 %and v_scope = 0 %start
      %if f = AVinS %start
         %if v_base = 0 %then f = constant %else f = VinR
      %else
         %if (f = VinREC %or f = AVinREC) %start; ! eliminate redundant LOAD
            %if f = VinREC %then f = AinS %else f = VinS
            v_disp = v_extra
         %finish
      %finish
   %finish
   v_type = integer
   v_form = f
%end

!                                                             >> VMAP <<
! The inverse of AMAP:  i.e. vmap(amap(x)) => x
%routine  vmap(%record(stackfm)%name  v)
   %integer  f, t
   %constintegerarray  var map(0:8) =
            4,       4,   -1, -2,    6,      4,   -3,    9,        7  
   !      v in s, v in s, -1, -2, a in s, v in s, -3, a in rec, v in rec

   %if v_form = a in s %or v_form = a in rec %start
      t = v_type
      amap(v)
      load(v,anyp)
      v_type = t;  v_form = VinS
   %finish
   f = var map(v_form);  abort("VMap") %if f < 0
   v_form = f
%end;            !  v map

!                                                          >> ADDRESS <<
! convert V into a form in which it is directly addressable
! that means either V in R, V in S or Constant
%routine  address(%record(stackfm)%name  v)
   %integer  type, form, r
   
   monitor(v, "ADDRESS") %if diagnose&2 # 0

   form = v_form;  type = v_type
   %if form >= V in REC %start
      reduce(v);  form = v_form
   %finish

! Now pick up a base register if we needed one...
   %if v_base > 16 %start
      v_base = get display(v_base - 16)
      claim(v_base)
   %finish

   %return %if form = V in R %or form = constant

   %if form = AV in S %start
      %if v_base = 0 %start
         v_form = constant
      %else
         %if v_disp = 0 %and v_scope = 0 %start
            v_form = V in R
         %else
            load(v, any)
         %finish
      %finish
      %return
   %finish

! It is possible to end up with an in-store form, but the
! base register isn't one that can be used in an address...
   %if v_base # 0 %and v_base < BX %start
      r = PT Reg; claim(r)
      dumprr(MOV, r, v_base); release(v_base)
      v_base = r
   %finish

   %return %if form = V in S
   
   %if form = A in S %start
      v_form = V in S;  v_type = integer
      load(v,anyp)
      v_type = type;  v_form = V in S;  v_disp = 0
   %finish
%end;            ! address

!                                                             >> LOAD <<
! Load variable V into register R
! Along the way any register the variable owned is released, and
! the new register is claimed.
%routine Load(%record(stackfm)%name v, %integer r)
   %switch f(0:9)
   %integer ptr, op

   monitor(v, "LOAD") %if diagnose&2 # 0

	%if r = anyf %then ->reals

! If the request is one of the variations on "any" then we need
! to first allocate a target register.  First, we make a local
! adjustment because we can't load bytes into "any" register,
! only into the GP registers...
	%if v_type = byte %start
		%if r = any %then r = anyg
! What's more, there is only one register that is both a pointer
! and a legal byte destination
		%if r = anyp %then r = BX
	%finish

! We also map the virtual display into a real register if we
! need to.  Also, it is possible that an in-store form may
! be derived from a non-pointer register, so we fix that too.
   %if v_base > 16 %then %start
      v_base = get display(v_base - 16)
      claim(v_base)
   %else
      %if v_base # 0 %and v_base < BX %and v_form >= V in S %start
         ptr = pt reg
         dumprr(MOV, ptr, v_base)
         claim(ptr); release(v_base)
         v_base = ptr
      %finish
   %finish

! Now go ahead and allocate a register
   %if r = any %then %start
! If we've got a base, it's not in use by anyone else, and isn't a display register, use it
      %if v_base # 0 %and activity(v_base) = 1 %and displayhint(v_base) = 0 %start
         r = v_base
      %else
         r = gp reg
      %finish
   %else
      %if r = anyg %then %start
         %if 0 < v_base %and v_base <= BX %and activity(v_base) = 1 %start
            r = v_base
         %else
            r = gp reg
         %finish
      %else
         %if r = anyp %then %start
            %if activity(v_base) = 1 %and (v_base = BX %or v_base = SI %or v_base = DI) %then %start
               r = v_base
            %else
               r = pt reg
            %finish
         %else
			   %if v_base = r %start
				   %if activity(r) > 1 %start;      ! protect other uses
					   release(r);  v_base = 0;      ! Hide my ownership for the moment
					   hazard(r);							! Zap everybody else
					   claim(r);    v_base = r;      ! Get it back
				   %finish
			   %else
				   hazard(r)
			   %finish
         %finish
      %finish
   %finish
   -> f(v_form)

f(constant):
ldconst:
      %if v_disp = 0 %and v_scope = 0 %start
         dumprr(XOR, r, r)
      %else
         dumprioffset(MOV, r, v_scope, v_disp)
      %finish
setup:v_base = r
      v_disp = 0
      v_scope = 0
      v_form = v in r
      claim(r)
      %return

f(v in r):
      %return %if v_base = r
      dumprr(MOV, r, v_base)
      release(v_base)
      -> setup

f(av in r):
f(a in r):
      Abort("Unexpected Stack Form")
         
f(a in s):
      ! is the register a pointer?
      %if r = BX %or r = SI %or r = DI %start
         ptr = r
      %else
         ptr = pt reg
      %finish
      dumprm(MOV, ptr, v_base!v_scope, v_disp)
		release(v_base); claim(ptr)
      v_base = ptr
      v_disp = 0
      v_scope = 0
      ! fall through to normal V in S

f(v in s):
      %if v_type = integer %start
         dumprm(MOV, r, v_base!v_scope, v_disp)
      %else
         %if v_type = byte %start
            dumprm8(MOV, r+16, v_base!v_scope, v_disp)
            dumprr8(XOR, r+20, r+20)
            v_type = integer
         %else; ! reals
				abort("Load Real")
         %finish
      %finish
		release(v_base)
      ->setup

f(av in s):
      %if v_base # 0 %start
         dumprm(LEA, r, v_base!v_scope, v_disp)
			release(v_base)
			v_type = integer
			->setup
      %finish
		! else
      ->ldconst
      
f(v in rec):
f(av in rec):
f(a in rec):
      reduce(v)
      ->f(v_form)

! Equivalents for real numbers...

reals:;		! because there's very little clever we can do, we first
				! simplify somewhat...
		Address(v)

		! Now it's either Constant, V in R or V in S - we now turn them
		! all into V in S - the only thing we can load

      ! Start with one we have no instructions for, and promote it to
		! something we know how to handle...
		%if v_type = byte %then load(v, any)

		%if v_form = V in R %start
			%return %if v_base >= FR0
			! This must be an integer in a CPU register - we need to store it
			! before we can use it
			v_disp = getwork(2)
			dumpmr(MOV, BP, v_disp, v_base)
			release(v_base)
			v_base = BP
			v_scope = 0
			v_form = V in S
			! Now it looks like an integer V in S
		%finish

		%if v_form = constant %start;		! This is an integer constant
			%if v_disp = 0 %start;			! We have a special instruction for zero
				r = FR0 + FPU Stack
				dumpflopspec(FLDZ)
				-> set up real
			%finish
			! Otherwise, we need it in store
			v_disp = getcotw(v_disp)
			v_form = V in S
			v_base = 0
			v_scope = COT
		%finish

	! Now everything that's left is a V in S

      %if v_type = integer %start
         op = FILD
      %else
			%if v_type = real %start
				op = FLDD
			%else
				op = FLDQ
         %finish
      %finish

		! register is going to be the top of stack
		r = FR0 + FPU Stack
		
		dumpfloprm(op, v_base!v_scope, v_disp)
		release(v_base)
set up real:
		v_base = r
		claim(r)
      v_disp = 0;
      v_form = v in r
		v_type = real
%end

!                                                          >> OPERATE <<
! perform the operation OP on the top two elements of the stack.
!   (single element for unary operators)
%routine  operate(%integer  op)
   %record(stackfm)%name  lhs, rhs
   %integer assign pending, work, value, s
   %switch oper(1:17), roper(1:17), fold(1:17)
%constintegerarray opmap(1:17) = 
   14,  18,  23,  22,  0,   15, 17,  19,  20,  21,  22,  0,   0,    0,    7,   6,   0
!  add, sub, mul, div, conc,and,or,  xor, lsh, rsh, rem, exp, rexp, rdiv, not, neg, abs

%constintegerarray flopmap(1:17) = 
   42,   43,   45,   46,   0, 0, 0, 0, 0, 0, 0,   0,   0,    46,   0, 49,   50
!  fadd, fsub, fmul, fdiv, 0, 0, 0, 0, 0, 0, rem, exp, rexp, fdiv, 0, fchs, fabs

%constintegerarray indec(-1:1) = 4, 0, 5; ! decrement, and increment opcodes

   %routine swap
      %record(stackfm) temp
      temp = lhs
      lhs = rhs
      rhs = temp
   %end

   assign pending = 0
   rhs == top
   %if op < Unaries %then %start
      lhs == stack(stp-1)
      %if lhs_type = real %or lhs_type = lreal %then ->reals
   %finish

   %if rhs_type = real %or rhs_type = lreal %then ->reals

   %if rhs_form = constant %and (op >= Unaries %or lhs_form = constant) %then ->fold(op)

   ! now look for optimisations for x = x <op> whatever
   %if next sym = 'S' %or next sym = 'j' %start;           ! the next task is an assignment
      %if op >= Unaries %start
         %if same(top, stack(stp-1)) # 0 %then assign pending = 1
      %else
         %if same(lhs, stack(stp-2)) # 0 %then assign pending = 1
      %finish
   %finish

   ->oper(op)

oper(op not):
oper(op neg):
   ! we optimise for e.g. fred = -fred as one instruction
   %if assign pending # 0 %then %start
      read symbol(next sym)
      address(rhs)
		%if rhs_type = byte %start
			dumpum8(opmap(op), rhs_base!rhs_scope, rhs_disp)
		%else
			dumpum(opmap(op), rhs_base!rhs_scope, rhs_disp)
		%finish
      pop rel
      pop rel
      %return
   %finish
   load(rhs, any)
   dumpur(opmap(op), rhs_base)
   %return

!  8086 has no "abs" instructions, so we do a test and jump
oper(op abs):
   load(rhs, any)
   dumpri(CMP, rhs_base, 0)
	work = new tag
	dumpjump(JGE, work)
   dumpur(NEG, rhs_base)
	dumplabel(work)
   %return


oper(op add):
   %if lhs_form = constant %then swap
   ! and fall through to minus

oper(op sub):
   ! First look for fred = fred + <whatever>
   ! We can only safely do this for bytes if we're jamming or ignoring overflow
   %if assign pending # 0 %and %c
      (lhs_type = integer %or control & check capacity = 0 %or Next Sym = 'j') %then %start
      readsymbol(next sym)  ; ! we will do the assignment ourselves
      address(lhs)      ; ! make LHS accessible
      %if rhs_form = constant %then %start
         value = rhs_disp
			%if value # 0 %start
				%if op = op sub %then value = -value
				! look for increment or decrement instructions
				%if value < 2 %and value > -2 %then %start
					%if lhs_type = byte %start
						dumpum8(indec(value), lhs_base!lhs_scope, lhs_disp)
					%else
						dumpum(indec(value), lhs_base!lhs_scope, lhs_disp)
					%finish
				%else
					%if lhs_type = byte %start
						dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
					%else
						dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
					%finish
				%finish
			%finish
      %else;         ! RHS not a constant
         load(rhs, any)
			%if lhs_type = byte %start
				dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base+16)
			%else
				dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base)
			%finish
      %finish
      pop rel
      pop rel
      pop rel
      %return
   %finish

! So, there is no assign pending        

   %if rhs_form = constant %then %start
      value = rhs_disp
      %if op = op sub %then value = -value
		! If it is already an address, do the math on the address offset
      %if lhs_form = avins %or lhs_form = avinrec %start
         lhs_disp = lhs_disp + value
      %else
         load(lhs, any)
			! We don't particulary try for it, but if we ended up with a pointer
			! register, we might as well convert this to use the address form...
			%if lhs_base = BX %start;		! BX is the only GP reg that's also a pointer
				lhs_form = avins
				lhs_disp = value
			%else;								! otherwise, don't bother deferring the operation
				! look for increment or decrement instructions
				%if value < 2 %and value > -2 %then %start
					%if value # 0 %then dumpur(indec(value), lhs_base)
				%else
					dumpri(opmap(op), lhs_base, rhs_disp)
				%finish
			%finish
      %finish
   %else;                  ! not a constant
      %if op = op add %and rhs_form = v in r %then swap; ! commutative, so flip it
      load(lhs, any)
		%if rhs_type = byte %start
			load(rhs, any)
		%else
		   address(rhs)
		%finish
      dumprv(opmap(op), lhs_base, rhs)
   %finish
   pop rel;    ! the RHS
   %return


oper(op and):
oper(op or):
oper(op xor):
!  Logical ops are a subset of ADD - similar behaviour, but no inc/dec/addr short forms
   %if lhs_form = constant %then swap

   ! First look for fred = fred <op> <whatever>
   %if assign pending # 0 %then %start
      readsymbol(next sym);   ! we will do the assignment ourselves
      address(lhs);				! make LHS accessible
      %if rhs_form = constant %then %start
         value = rhs_disp
			%if lhs_type = byte %start
            warn(8) %if rhs_disp & (\255) # 0
				dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
			%else
				dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
			%finish
      %else;         ! RHS not a constant
         load(rhs, any)
			%if lhs_type = byte %start
				dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base+16)
			%else
				dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base)
			%finish
      %finish
      pop rel; ! RHS
      pop rel; ! LHS
      pop rel; ! Assignment destination
      %return
   %finish

! So, there is no assign pending        

   %if rhs_form = constant %then %start
      value = rhs_disp
      load(lhs, any)
      dumpri(opmap(op), lhs_base, value)
   %else;                  ! not a constant
      %if rhs_form = v in r %then swap; ! all these are commutative, so flip it to make it easier
      load(lhs, any)
		%if rhs_type = byte %and op = op and %start;	! AND needs all the bits to make sense
			load(rhs, any);									! NB Load changes type to Integer
		%else
			address(rhs)
		%finish
		%if rhs_type = byte %start;		! must be V in S - everything else would be Integer
			dumprm8(opmap(op), lhs_base+16, rhs_scope!rhs_base, rhs_disp)
		%else
			dumprv(opmap(op), lhs_base, rhs)
      %finish
   %finish
   pop rel;    ! the RHS
   %return

oper(op mul):
   %if lhs_form = constant %or rhs_base = AX %then swap

   %if rhs_form = constant %then %start
      value = rhs_disp
      %if value = 0 %then %start; ! mul by zero is zero
         release(lhs_base)
         lhs = rhs
         pop stack
         %return
      %finish
      %if value = 1 %then %start; ! mul by 1 is the identity
         pop stack
         %return
      %finish
      s = mulshift(value);        ! find a shift factor
      %if s > 0 %then %start
         rhs_disp = s
         op = op lsh
         -> shift it
      %finish
      ! 8086 multiply instruction doesn't have an immediate operand form
      ! so we use an entry in the constant table...
      rhs_base = 0; rhs_scope = COT; rhs_disp = getcotw(value)
      rhs_form = V in S
		! and fall through to the not-a-constant path
   %finish

do mul:
   load(lhs, AX)
   address(rhs)
   hazard(DX)
   %if rhs_form = V in R %start
      dumpur(IMUL, rhs_base)
   %else
      dumpum(IMUL, rhs_base!rhs_scope, rhs_disp)
   %finish
   pop rel
   %return

oper(op div):
oper(op rem):
   load(lhs, AX)
   address(rhs)
   hazard(DX)
   dumpsimple(CWD)
	! Plain 8086 Divide instruction also has no immediate operand form, so
	! we move constants to the COT
	%if rhs_form = constant %start
		%if rhs_disp = 0 %then warn(1)
      rhs_base = 0; rhs_scope = COT; rhs_disp = getcotw(rhs_disp)
      rhs_form = V in S
	%finish
   %if rhs_form = V in R %start
      dumpur(IDIV, rhs_base)
   %else
      dumpum(IDIV, rhs_base!rhs_scope, rhs_disp)
   %finish
   pop rel
   %if op = op div %then %start
      lhs_base = AX
   %else
      lhs_base = DX
      release(AX)
      claim(DX)
   %finish
   %return

oper(op lsh):
oper(op rsh):
shift it:
   %if assign pending # 0 %and %c
      (op = op rsh %or lhs_type = integer %or control & check capacity = 0 %or Next Sym = 'j') %then %start
      readsymbol(next sym);   ! we will do the assignment ourselves
      address(lhs);				! make LHS accessible
		! Note that in-register shifting it is actually quicker for small
		! constant shifts to plant multiple "shift by one" instructions than
		! it is to load up CL with the shift count.  That is NOT true for
		! in-store shifts, since there's a fetch and store for every bit shift
		! Hence the test for disp = 1 below
		%if rhs_form = constant %and rhs_disp = 1 %start
			%if lhs_type = byte %start
	         dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, 1)
			%else
	         dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, 1)
			%finish
      %else;         ! RHS not a one
			! Since the shift instruction only uses the bottom 4 bits of the
			! value in CX, the value is "byte safe".  Rather than do a full
			! "load(rhs,CX)" we therefore fiddle about and do it the hard way
			! to save redundant coding
			%if rhs_type = byte %start
				hazard(CX)
				address(rhs)
				dumprm8(MOV, CL, rhs_scope!rhs_base, rhs_disp)
			%else
				load(rhs,CX)
			%finish
			%if lhs_type = byte %start
	         dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, CL)
			%else
	         dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, CX)
			%finish
      %finish
      pop rel; ! RHS
      pop rel; ! LHS
      pop rel; ! Assignment destination
      %return
	%finish

   ! deal with constant shifts first...
   %if rhs_form = constant %then %start
      value = rhs_disp
      %if value <= 4 %then %start;     ! plant individual shift 1 instructions
         load(lhs, any)
         %while value > 0 %cycle
            dumpri(opmap(op), lhs_base, 1)
            value = value - 1
         %repeat
      %else
         load(rhs, CX)
         load(lhs, any)
         dumprr(opmap(op), lhs_base, CX)
      %finish
   %else;                              ! RHS variable
		! Since the shift instruction only uses the bottom 4 bits of the
		! value in CX, the value is "byte safe".  Rather than do a full
		! "load(rhs,CX)" we therefore fiddle about and do it the hard way
		! to save redundant coding
		%if rhs_type = byte %start
			hazard(CX)
			address(rhs)
			dumprm8(MOV, CL, rhs_scope!rhs_base, rhs_disp)
         release(rhs_base)
         rhs_base = CX
         claim(CX)
		%else
			load(rhs,CX)
		%finish
      load(lhs, any)
		dumprr(opmap(op), lhs_base, CX);
   %finish
   pop rel
   %return

oper(op exp):
   %if rhs_form = constant %then %start
      %if rhs_disp = 0 %start
         pop rel
         pop rel
         push const(1)
         %return
      %finish

      %if rhs_disp = 1 %then %start
         pop rel
         %return
      %finish

      %if rhs_disp = 2 %then %start
         rhs = lhs
         claim(rhs_base)
         ->do mul
      %finish
   %finish

   load(rhs, any)
   dumpur(PUSH, rhs_base)
   pop rel
   load(lhs, any)
   dumpur(PUSH, lhs_base)
   release(lhs_base)
   perm(iexp, 4)
   lhs_base = AX; claim(AX)
   lhs_form = V in R
   %return

oper(op rexp):
oper(op rdiv):
   abort("Oper unexpected op")

!-----------------------------------------------
! Fold constant expressions at compile time
fold(op neg):  value = -rhs_disp; -> set unary
fold(op not):  value = \rhs_disp; -> set unary
fold(op abs):  value = rhs_disp; %if value < 0 %then value = -value; -> set value
fold(op add):  value = lhs_disp + rhs_disp; -> set value
fold(op sub):  value = lhs_disp - rhs_disp; -> set value
fold(op or):   value = lhs_disp ! rhs_disp; -> set value
fold(op and):  value = lhs_disp & rhs_disp; -> set value
fold(op xor):  value = lhs_disp !! rhs_disp; -> set value
fold(op lsh):  value = lhs_disp << rhs_disp; -> set value
fold(op mul):  value = lhs_disp * rhs_disp; -> set value
fold(op rsh):  value = lhs_disp >> rhs_disp; -> set value
fold(op exp):  %if rhs_disp < 0 %then abort("Fold -ve Exp")
               value = 1
               %for op=1, 1, rhs_disp %cycle
                  value = value * lhs_disp
               %repeat
               -> set value
fold(op rem):
fold(op div):  value = rhs_disp;
               warn(1) %and value = 1 %if value = 0
               value = lhs_disp // value
               %if op = op div %then -> set value
               value = lhs_disp - (rhs_disp * value)
               -> set value

fold(op rexp): abort("No reals yet")
fold(op rdiv): abort("No reals yet")

set value:
   pop stack
set unary:
   top_disp = value
   %return

fold(op conc): abort("Fold Conc")

!--------------------------------------------------------------------
! String operations - the only one is concatenate...

oper(op conc):

   %if assign pending # 0 %start;	! It's S = S.T
		amap(lhs)
		load(lhs, any)
		dumpur(PUSH, lhs_base)
		amap(rhs)
		load(rhs, any)
		dumpur(PUSH, rhs_base)
		pop rel
		pop rel
      dumppushi(0, lhs_size)
		%if Next Sym = 'S' %then perm(sconc, 6) %else perm(sjconc, 6)
		! and finally, skip the pending assignment, and drop the LHS
		readsymbol(Next Sym)
		pop rel
		%return
	%finish

	! here we've got T.U - if T is already in a WORK location
	! we've got a simple append.  If it is a user variable, we've
	! got to both copy it to a temp area and do the append
	
	%if Is Work(lhs) = 0 %start;		! Not a work area
		work = getwork(256)
		push const(work)
		top_form = av in s
		top_base = BP
		load(top, any)
		dumpur(PUSH, top_base)
		pop rel
		amap(lhs)
		load(lhs, any)
		dumpur(PUSH, lhs_base)
		release(lhs_base)
      dumppushi(0, 255)
		perm(smove, 6)
		! Now we need to redefine the LHS as our temporary area
		lhs = 0;			! gratuitous clear-it-all-out
		lhs_type = string
		lhs_form = V in S
		lhs_base = BP
		lhs_disp = work
		lhs_size = 255
	%finish

	! Here we are doing an in-situ concatenation

   ! We want to leave the result as a normal variable, so we
	! suck up a copy for the AMAP fiddling
	push copy(lhs)
	amap(top)
   load(top, any)
   dumpur(PUSH, top_base)
	poprel
   amap(rhs)
   load(rhs, any)
   dumpur(PUSH, rhs_base)
   pop rel
   dumppushi(0, lhs_size)
   perm(sconc, 6)
   %return

Reals:
	%if op < Unaries %then load(lhs, anyf)
	%if op # op rexp %then load(rhs, anyf)
	->roper(op)

roper(op neg):
roper(op abs):
	dumpfloprr(flopmap(op), rhs_base, rhs_base)
	%return
	
roper(op add):
roper(op mul):
	! Commutative, so we don't care
	%if lhs_base > rhs_base %then swap
	dumpfloprr(flopmap(op), lhs_base, rhs_base)
	pop rel
	%return

roper(op sub):
roper(op div):
roper(op rdiv):
	! We can't swap these, so we use the reverse form of
	! the opcode (which in our internal form is always one
	! more than the basic opcode index)
	op = flopmap(op)
	%if lhs_base > rhs_base %start
		swap
		op = op + 1
	%finish
	dumpfloprr(op, lhs_base, rhs_base)
	pop rel
	%return

roper(op rexp):
   ! This is implemented as a PERM routine
   load(rhs, any)
	dumpur(PUSH, rhs_base)
   pop rel
   ! The usual slightly clunky floating point "push"
	work = ptreg
	dumpri(SUB, SP, 8)
	dumprr(MOV, work, SP)
	dumpfloprm(FSTQ, work, 0)
   release(lhs_base)
   perm(fexp, 10)
   ! Since rexp is actually a standard C routine, the result will
   ! be in store, pointed to by AX...
   lhs_base = AX; claim(AX)
   lhs_form = V in S; lhs_disp = 0; lhs_scope = 0
   lhs_type = lreal
   load(lhs, anyf)
   %return

roper(op not):
roper(op and):
roper(op or):
roper(op xor):
roper(op rem):
roper(op lsh):
roper(op rsh):
roper(op exp):
	abort("Unsupported Real Operation")

%end;        !     operate

!                                                           >> ASSIGN <<
! ASSOP =   -1:  parameter assignment
!            0:  == assignment
!            1:  =  assignment
!            2:  <- assignment
%routine  assign(%integer  assop)
   %record(stackfm)%name  lh,rh
   %record(stackfm)  temp
   %integer  n, p, t, form, r

	! Store the item in RHS to LHS.  Encapsulates the dificulties
	! of variable length items and pushing things on the stack to
	! keep the rest of "Assign" looking tidy
	%routine Store(%record(stackfm)%name lhs, rhs)
		%integer pt, s, op

		%if lhs_base = SP %start;			! it's a push
			%if lhs_type = integer %or lhs_type = byte %start
				%if rhs_type = byte %start
               load(rhs, any)
            %else
               address(rhs)
            %finish
            dumpvpush(rhs)
			%else;		! must be a real
				%if lhs_type = real %start
					s = 4
					op = FSTD
				%else
					s = 8
					op = FSTQ
				%finish
				load(rhs, anyf)
				pt = ptreg
				dumpri(SUB, SP, s)
				dumprr(MOV, pt, SP)
				dumpfloprm(op, pt, 0)
			%finish
			%return
		%finish
		%if lhs_type = integer %start
			%if rhs_form = constant %and rhs_scope = 0 %start
				dumpmi(MOV, lhs_base!lhs_scope, lhs_disp, rhs_disp)
			%else
				load(rhs, any)
				dumpmr(MOV, lhs_base!lhs_scope, lhs_disp, rhs_base)
			%finish
		%else
			%if lhs_type = byte %start
				%if rhs_form = constant %and rhs_scope = 0 %start
					dumpmi8(MOV, lhs_base!lhs_scope, lhs_disp, rhs_disp)
				%else
               %if rhs_type = byte %start;   ! try to avoid pointless promoting to an int
                  ! We will reproduce a "Load" but without the word extension
                  address(rhs)
                  pt = gp reg
                  dumprm8(MOV, pt+16, rhs_base!rhs_scope, rhs_disp)
                  release(rhs_base)
                  rhs_base = pt; rhs_form = V in R; rhs_type = Integer
                  claim(pt)
               %else
					   load(rhs, any)
                  ! ABD - should add a capacity check here
               %finish
					dumpmr8(MOV, lhs_base!lhs_scope, lhs_disp, rhs_base+16)
				%finish
			%else
				load(rhs, anyf)
				%if lhs_type = real %start
					op = FSTD
				%else; ! long real
					op = FSTQ
				%finish
				dumpfloprm(op, lhs_base!lhs_scope, lhs_disp)
			%finish
		%finish
	%end

   abort("Assign Stack") %if stp < 2

   rh == top
   lh == stack(stp-1)

   form = lh_form;        ! to avoid the ravages of amap, load etc
   
   %if diagnose&4 # 0 %start
      monitor(lh, "ASS LH")
      monitor(rh, "ASS RH")
   %finish
   
   %if same(lh, rh) # 0 %then %start
      pop rel
      pop rel
      %return
   %finish

   %if assop < 0 %start;           ! Parameter
      %if lh_base >= 128 %start;     ! Special - prim routine
         temp = lh;  lh = rh;  rh = temp
         %return
      %finish

		! Extract the next formal parameter and make it our target
		lh_pbase = lh_pbase - 1
      push var(lh_pbase)
		! Now make our destination look reasonable
		lh == top
		lh_base = SP;							! target is the stack
      assop = 0 %if lh_form # v in s;	! %name parameter is '=='

		! We need special treatment for procedure parameters
		%if 7 <= lh_aform <= 10 %start;	! this is a procedure
			assop = 1;							! we will treat it as a value assignment
			rh_type = integer;				! of an integer
			lh_type = integer; lh_form = V in S
			%if rh_base # 0 %start;			! RH is already a parameter
				rh_form = V in S
			%else
				%if rh_scope = EXT %start;	! it is an external procedure
					rh_form = A V in S;		! pick up the addres
				%else;							! it is a local procedure
					! HACK: local procedures are Tags until Pass3 fixes them up.  The
					! only way we have of converting tags to addresses is with the switch
					! table - so we'll plant a fake switch entry for the label of the
					! local routine, and then load that value!
			      %if swtp >= Max Switch %then abort("Proc - Switch Table Full")
					swtab(swtp) = rh_disp; rh_disp = swtp * 2; swtp = swtp+1
					rh_scope = SWT
					rh_form = V in S
				%finish
			%finish
		%finish
	%finish

   %if array <= rh_aform %and rh_aform <= namearrayname %start;        ! Arrayname
      ! An array name is two words - a pointer to the data and a
      ! pointer to the dope vector.  If the RHS is already one of these
      ! then we just want to copy the two words.  If it is a static
      ! array, we need to map the data to make a pointer, and its' dope
      ! vector will be in the constant table, so we fetch that.
      amap(lh)
      address(lh)
      amap(rh);            ! This works because arrays are stacked as V in S, arraynames are A in S
      address(rh)
      ! We do the dope vector first - that makes it easier when we're parameter passing
      %if rh_aform = array %or rh_aform = name array %start;   ! simple static - DV in COT
         ! We will rustle up a dummy record for the DV address
         temp = 0
         temp_form = A V in S
         temp_type = integer
         temp_disp = rh_pbase
         temp_scope = COT
      %else;                                                   ! already an array name
         temp = rh; claim(temp_base)
         temp_disp = temp_disp + 2
      %finish
      lh_disp = lh_disp+2
      store(lh, temp)
      release(temp_base)
      lh_disp = lh_disp-2
      store(lh, rh)
      pop rel
      pop rel
      %return
   %finish

   %if lh_type = general %start;     ! general %name parameter
      abort("Assign GenName") %unless assop = 0; ! Only '==' is allowed
		! A general name pointer is two words - the pointer itself
		! and a second word to convey type information.  If the RHS
		! is already one of thse guys it's easy - just copy the two
		! words.  Otherwise, we need to rustle up the second word at
		! compile time
		amap(lh)
		address(lh)
      %if rh_type = general %start
			temp = rh;	! make a copy for the second word
			claim(temp_base); temp_disp = temp_disp + 2
			amap(temp)
		%else
			temp = 0
			temp_type = integer
			temp_disp = (rh_size << 4) + genmap(t)
		%finish
		amap(rh)
		store(lh, rh)
		lh_disp = lh_disp + 2
		store(lh, temp)
		release(temp_base)
      pop rel
      pop rel
      %return
   %finish

   %if assop = 0 %start;        ! ==
      amap(lh);      ! destination
      amap(rh);      ! ABD %string(*)%name  NOT handled special here - should be?
   %finish

   %if Lh_Type = record %start
		%if lh_base = SP %start;		! pass record by value - destination is the stack
			n = lh_size
			hazard(DI)
			dumpri(SUB, SP, lh_size)
			dumprr(MOV, DI, SP)
			claim(DI)
			lh_base = DI
		%else
			n = Min Record Size(Lh, Rh)
			amap(lh)
			load(lh, DI)
		%finish
      hazard(CX)
      dumpri(MOV, CX, n)
      %if rh_Form = Constant %start
         hazard(AX)
		   dumprr(XOR, AX,AX);		! get a zero
			dumprepstosb
      %else
         amap(rh)
         load(rh, SI)
         dumprepmovsb
      %finish
      pop rel
      pop rel
      %return
   %finish

   %if lh_type = string %start
      %if assop > 0 %and rh_format = 1 %start;    ! null string as zero byte ?
         lh_type = byte
         pop rel;       ! zap current RHS
         push const(0);     ! get a zero
         assign(assop); ! and assign it
         %return
      %finish

	! our copy routines expect DEST then SOURCE then LENGTH on the stack
		%if lh_base = SP %start;		! pass string by value - destination is the stack
         ! space is string size, plus one for length, plus make it even
         p = lh_size + 1; p = (p+1) & (\1)
			dumpri(SUB, SP, p)
			! we want to Push SP here - sadly different versions of x86
			! architecture have different interpretations of "PUSH SP", so...
			r = gp reg
			dumprr(MOV, r, SP)
			dumpur(PUSH, r)
		%else
			amap(lh)
			load(lh, any)
			dumpur(PUSH, lh_base)
		%finish
		! It is likely that the RH variable is a temporary work area
		! Before we trash the information, we try to release it
		Return Work(rh_disp)
		amap(rh)
		load(rh, any)
		dumpur(PUSH, rh_base)
      pop rel
      pop rel
      dumppushi(0, lh_size)
		%if assop = 2 %then perm(sjam, 6) %else perm(smove, 6)
      %return
   %finish

   address(lh)

	store(lh, rh)

   pop rel
   pop rel
%end;            !  assign

!                                                        >> ARRAY REF <<
! Array references always use the PERM unless they are 1 dimensional, AND
! the %control bit has been turned off
%routine  array ref(%integer mode)
   %record(stackfm)%name av
   %integer type, form, size, format

   %if mode#0 %then %start
   ! Put non-terminal index onto stack for PERM
      %if top_type = byte %start
         load(top, any)
      %else
         address(top)
      %finish
      dumpvpush(top)
      pop rel
      %return
   %finish
   
   av == stack(stp-1)
   size = av_size
   size = size + 1 %if av_type = string
   form = av_aform
   %if form=namearray %or form=namearrayname %then size = 2

   %if control & check array = 0 %and av_dim = 1 %start
      ! This will be unchecked, the top of the stack is the only index (1D),
      ! so we can do a cheap multiplication here
      %if size#1 %start;      ! multiply offset by var size
         push const(size)
         operate(op mul)
      %finish
   %else
      ! This is the final (and perhaps only) subscript for a checked array,
      ! so we are going to use the Perm - therefore pass this as a parameter
      %if top_type = byte %start
         load(top, any)
      %else
         address(top)
      %finish
      dumpvpush(top)
      pop rel
   %finish

   ! How we do the rest of the access depends on whether this is a simple
   ! static array, or an array name...

   %if form = arrayname %or form = namearrayname %start;   ! array is a "name"
      ! We will AMAP the name, so we remember the info and then put it all back later
      type = av_type
      format = av_format
      size = av_size
      %if form = arrayname %then form = v in s %else form = a in s
      amap(av)

      %if control & check array # 0 %or av_dim > 1 %start;     ! do the rest of the check
         ! This is a bit clunky, because we may load registers in order
         ! to access AV, only to Hazard them for the PERM
         address(av)
         push copy(av); claim(top_base)
         top_disp = top_disp + 2;   ! Dope Vector address follows A(0)
         dumpvpush(top)
         pop rel
         perm(aref, (av_dim * 2) + 2); ! DV word, plus a word for every subscript
         push const(0)
         top_form = V in R; top_base = AX; claim(AX)
      %finish

      load(top, anyp);        ! make sure index is in a pointer register
      operate(op add)
      top_type = type
      top_form = form
      top_format = format
      top_size = size
      top_disp = 0
   %else;     ! simple arrays are always 1D, but can still be checked
      %if control & check array # 0 %start
         ! Pass a pointer to the Dope Vector
         dumppushi(COT, av_pbase);     ! simple arrays have compile-time DV's in the COT
         perm(aref, 4)
         push const(0)
         top_form = V in R; top_base = AX; claim(AX)
      %finish

      address(av)
      %if av_form # v in s %then abort("Aref Form")
      %if top_form = constant %start;  ! simple constant a(k)
         av_disp = av_disp + top_disp; ! just add it to the offset
      %else
         load(top, anyp);              ! pick up index in a pointer
         %if av_base # 0 %start;       ! add the base we've already got
            dumprr(ADD, top_base, av_base)
            release(av_base)
         %finish
         av_base = top_base
      %finish
      %if form = array %then av_form = v in s %else av_form = a in s
      pop stack
   %finish

   top_aform = 0; ! not an array any more

%end;       !  array ref

!                                                        >> TEST ZERO <<
! test a real/integer/byte variable against zero
%routine  test zero(%record(stackfm)%name  v)

	%if v_type = integer %or v_type = byte %start
		load(v,any)
		dumpri(CMP, v_base, 0)
	%else
		abort("Test Zero")
	%finish
%end;      ! test zero

%routine Compare Records(%record(stackfm)%name L, R, %integer N)
	abort("Compare Records")
%end

!                                                    >> COMPARE REALS <<
%routine  compare reals(%record(stackfm)%name  l,r)
	load(l, anyf)
	load(r, anyf)
   hazard(AX)
	! who's ended up on top?
	%if l_base > r_base %start;   ! l_base is the top of the FPU stack
		dumpfloprr(FCMP, r_base, l_base)
	%else
		dumpfloprr(FCMP, l_base, r_base)
		invert = invert !! 1
	%finish
   dumpflopspec(FSTSW); ! puts status into AX
   dumpsimple(SAHF);    ! and move it to flags
   compare unsign = 1;  ! because FPU reports as if operands were unsigned
%end;        ! compare reals

!                                                  >> COMPARE STRINGS <<
%routine  compare strings(%record(stackfm)%name  l,r)
%record(stackfm)%name  temp
   %if l_base = COT %and l_disp = null string %start
      temp == r;  r == l; l == temp
      invert = invert !! 1
   %finish
   %if r_base = COT %and r_disp = null string %start
      l_type = byte
      test zero(l)
   %else
      amap(l)
      load(l, any)
      dumpur(PUSH, l_base)
      amap(r)
      load(r, any)
      dumpur(PUSH, r_base)
      perm(scomp, 4)
      dumpri(CMP, AX, 0)
   %finish
%end;       ! compare strings

!                                                          >> COMPARE <<
%routine  compare(%record(stackfm)%name  l,r)
   %if l_type = 0 %or l_type = string %start
      compare strings(l,r);  %return
   %finish
   %if floating(l)#0 %or floating(r)#0 %start
      compare reals(l,r);  %return
   %finish
   %if zero(r) # 0 %start
      test zero(l);  %return
   %finish
   %if zero(l) # 0 %start
      test zero(r);  invert = invert !! 1
      %return
   %finish
   %if L_Type = Record %start
      Compare Records(L, R, Min Record Size(L, R))
      %return
   %finish
   load(l,any)
	%if r_type = byte %start
		load(r, anyg)
	%else
	   address(r)
	%finish
   dumprv(CMP, l_base, r)
%end;        ! compare

!                                                          >> RESOLVE <<
%routine  resolve(%integer  flag)
!S -> A.(B).C
   %if flag&1 = 0 %then push const(0) %else amap(top);         ! C missing?
   load(top, any)
   dumpur(PUSH, top_base)
   pop rel
   amap(top);  ! B
   load(top, any)
   dumpur(PUSH, top_base)
   pop rel
   %if flag&2 = 0 %then push const(0) %else amap(top);         ! A missing?
   load(top, any)
   dumpur(PUSH, top_base)
   pop rel
   amap(top);  ! S
   load(top, any)
   dumpur(PUSH, top_base)
   pop rel
   perm(sresln, 8)
   %if flag&4 # 0 %then dumpri(CMP, AX, 0)
%end;           ! resolve


%integerfn enter
	%integer cad;

   uncond jump = -1; ! can get here

   ! This is a convenient place to include external definitions if needed
   %if potype >= external %start
      fill external(CODE, next cad, external id)
   %finish

	dumprm(MOV, BX, DISPLAY,level*2);
	dumpur(PUSH, BX);
	dumpur(PUSH, BP);
	dumprr(MOV, BP,SP);
	dumpmr(MOV, DISPLAY, level*2, BP);

	cad = nextcad;
	dumpstaticalloc(cad);	! plants code to subtract static allocation (if any) from SP
	%result = cad;
%end

!                                                           >> DUMP RETURN <<
%routine  dump return
   %return %if uncond jump = next cad;          !  can't get here ?

	dumprr(MOV, SP, BP);
	dumpur(POP, BP);
	dumpur(POP, BX);
	dumpmr(MOV, DISPLAY, level*2, BX);
	dumpsimple(RET);

   uncond jump = next cad
%end;          ! return

! Routine to do "to string" as an in-line, either by making
! a constant string in the CONST area, or putting one onto
! the current workspace
%routine  compile to string(%record(stackfm)%name  v)
   %integer tmp

   %if const(v)#0 %start
      current string(0) = 1;  current string(1) = v_disp&255
      v_base = COT; v_disp = getcots(current string)
   %else
      tmp = getwork(2)
      load(v,anyg);        ! Must be a byte-addressable register
      dumpri(AND, v_base, 255)
      dumpri(OR, v_base, 16_0100)
      dumprr8(XCHG, v_base+16, v_base+20)
      dumpmr(MOV, BP, tmp, v_base)
      release(v_base)
      v_base = BP;  v_disp = tmp
   %finish
   v_type = string;  v_form = VinS;  v_size = 1
%end

!                                                             >> COMPILE CALL <<
! Call the routine on the top of the stack.  Note - the parameters
! are all hidden underneath the routine, so we need to push them
! here
%routine  compile call(%record(stackfm)%name  v)
%switch  b(1:15)
!  1 = rem
!  2 = float
!  3 = to string
!  4 = addr
!  5 = integer
!  6 = byte integer
!  7 = string
!  8 = record
!  9 = real
! 10 = long real
! 11 = length
! 12 = charno
! 13 = type of ( type of general name parameter )
! 14 = size of ( physical length in bytes )
! 15 = int (from real)

   %constbyteintegerarray  new type(5:12) =
            1,       5,    3,       4,    2,    6,     5,    5
!         integer, byte, string, record, real, lreal, byte, byte
   %integer  t,l,p

   %if v_base >= 128 %start;         !  built-in primitive
      l = 0;  t = v_disp;  sym = 0;      ! 'sym=0' used as flag elsewhere
      pop rel
      -> b(t)
b(1):;                             ! REM
      operate(op rem);  %return
b(2):;                             ! FLOAT
      load(top, anyf)
      %return
b(3):;                             ! TO STRING
      compile to string(top)
      %return
b(4):;                             ! ADDR
      amap(top)
      %return

b(11):;                            ! LENGTH
      push const(0);					  ! length is charno zero
b(12):;                            ! CHARNO
      amap(stack(stp-1))
      operate(op add);  !LHS&RHS reversed in operate??
      -> map it
b(7):;                             ! STRING
b(5):b(6):;                        ! INTEGER, BYTE
b(8):;                             ! RECORD
b(9):b(10):;                       ! REAL, LONG REAL
map it:
      vmap(top);  top_type = new type(t)
      top_size = v size(top_Type)
      %return
b(13):;                              ! type of(..)
b(14):;                              ! size of(..)
      %if top_type # general %start;      ! type explicitly specified
         %if t = 14 %start;      ! type of
            p = gen map(top_type)
         %else
            p = top_size;  p = p+1 %if top_type = string
         %finish
         release(top_base)
         top_type = integer;  top_form = constant
         top_base = 0;  top_disp = p
      %else
         top_disp = top_disp + 2;      ! reference property-word
         top_form = V in S;  top_type = integer
         %if t = 14 %start;         ! type of
            push const(15);  operate(op and)
         %else;                     ! size of
            push const(4);  operate(op rsh)
         %finish
      %finish
      %return
b(15):;                             ! INT(real)
      load(top, anyf)
      release(top_base)
      p = getwork(2)
      dumpfloprm(FSTI, BP, p)
      top_type = integer
      top_form = V in S
      top_base = BP
      top_disp = p
      %return
   %finish

   !   -- normal routine calls --

   ! String functions have a hidden last parameter to point
   ! to the result area
   %if v_type = string %and v_aform = 8 %start
      t = getwork(v_size+1)
      p = gp reg
      dumprm(LEA, p, BP, t)
      dumpur(PUSH, p)
   %finish
   hazard all
   %if v_scope = EXT %start;        ! external
      dumpextcall(v_disp)
   %else
	   %if v_base # 0 %start;					! procedure-as-parameter
			dumpum(CALL, v_base, v_disp);		! plants call indirect through variable
	   %else;										! local routine
		   dumpjump(CALL, v_disp);				! plants fixup for the tag
		%finish
	%finish
	! adjust the stack
	%if v_extra # 0 %then dumpri(ADD, SP, v_extra)
	%if v_type = 0 %start;           ! not function or map
		pop rel
	%else;                           ! Here we've got a result
      v_scope = 0;                  ! Result is local, even if the function wasn't
      %if v_type = string %and v_aform = 8 %start
         v_base = BP;               ! String result will have been copied back here
         v_disp = t
         v_form = V in S
      %else
     	   v_base = AX;               ! Result is always in AX
         v_disp = 0;                ! Clear this for MAP results
         claim(AX)
         %if (v_type = real %or v_type = lreal) %and v_aform = 8 %start
         ! Floating result will be in the "FAC" location, pointed at by AX
         ! In other words, it comes out like a %map.  Unfortunately the
         ! FAC location is global, so we need to copy it back out of there
         ! before somebody steps on it
            v_form = V in S
            load(v, anyf)
         %finish
      %finish
	%finish
%end;            !  call

!                                                      >> COMPILE FOR <<
%routine  compile for
%record(stackfm)%name  cv, iv, inc, fv
%integer  lab, n

   ! Lock a value into a temporary to make sure it is invariant
   %routine  stab(%record(stackfm)%name  v,  %integer  type)
      %integer  t,r
      %return %if const(v)#0
      load(v,any);  r = v_base
      t = getwork(2)
      dumpmr(MOV, BP,t, r)
      v_base = BP; v_disp = t; v_scope = 0
      v_type = type;  v_form = V in S
      release(r)
   %end

   iv == top
   fv == stack(stp-1)
   inc == stack(stp-2)
   cv == stack(stp-3)
   lab = read tag

   stab(fv,integer)
   stab(inc,integer)

   %if cv_form # v in s %or (cv_base # 0 %and activity(cv_base) >= 0) %start
      n = cv_type
      amap(cv)
      stab(cv, n)
      cv_form = a in s
   %finish
   
   push copy(cv)
   push copy(iv)
   push copy(inc);
   operate(op sub)
   assign(1);        ! cv = iv - inc

   define label(lab)
   pop stack;! zap unwanted copy of IV

	! Stack is now  top->[FV[INC[CV 
   push copy(cv);		! in case compare alters it
   compare(top, fv)
   jump to(lab+1, JE, 1)
   invert = 0; ! because the compare might have flipped this (N/A for JE)
	! Stack is now top->[CV'[FV[INC[CV where CV' is a register copy of CV
   release(fv_base); fv = top;	! trash FV and make a copy of CV' in that slot
   pop stack;							! discard the top copy
   ! stack is now top->[CV'[INC[CV
   operate(op add)
   assign(1)
%end;            ! for

!--------------------------------------------------------------
! Code for ASSEMBLE starts here...


   First Name = Names
   First Label = Labs
   Proc Var == Decvar
   last skip = -1
   old frame = frame
	frame = 0

   %if amode >= 0 %start;                    ! NOT A RECORDFORMAT
      level = level+1;  abort("Level") %if level > max level %and spec = 0
		worklist(level) = 0

      %if amode = 0 %start;                  ! %begin block
         %if level = 1 %start;               ! Initial %begin ?
            external id = program ep;        ! linkage to program entry
            otype = external;  potype = otype
         %finish
         static alloc = enter
      %finish
   %else
      %if amode = -1 %start;              ! normal record format
         ProcVar_pbase = parms;           ! where our members start
		%else
			%if amode = -2 %then frame = oldframe;	! alternates start at the current offset
      %finish
      max frame = frame;						! start counting space here
   %finish

!  --- main compilation loop ---
next: sym = nextsym;  read symbol(nextsym)
      %if sym < 33 %or sym > 127 %then %start
			selectoutput(0)
			printsymbol('('); write(sym, 1); printsymbol(','); write(nextsym, 1); printsymbol(')')
			abort("Bad I Code")
		%finish
      -> c(sym)

c('l'): %if read tag # 0 %then abort("Language")
        ->next;        ! We only support standard IMP

c('O'):;                                        ! Set line number
      abort("Stack?") %if stp # 0
      abort("Claimed") %if claimed # 0
      current line = read tag
      ! Pass1 sends the line number multiple times if there's more than
      ! one statement per line - for debugging we only want "real" line numbers
      %if echo line < current line %start
         dump line number(current line)
         %while echo line < current line %cycle
            echo source line
         %repeat
      %finish
      ->next

c('$'): define var;  ->next;                 ! Define VAR

c('b'):;                                        ! Define constant bounded Dope Vector
      vub = top_disp; pop stack
      vlb = top_disp; pop stack
      ->next

! Utility routine used when dumping initialisers for OWNs
! Note non-portable use of real values
         %routine  adump
            %integer i
				%real		rv32
            %switch ot(0:6)

            ->ot(own type)

            ot(general):   abort("General Own?")

            ot(integer):   gput(ownval); -> done
            ot(real):      rv32 = rvalue;		! because our default variable is a 64 bit long real
									gput(byteinteger(addr(rv32))!byteinteger(addr(rv32)+1)<<8)
                           gput(byteinteger(addr(rv32)+2)!byteinteger(addr(rv32)+3)<<8)
                           -> done
            ot(string):    i = dump string(data size); ! need result for const strings
                           %if decvar_scope = COT %then decvar_disp = i
                           -> done
            ot(record):    %for i = 1,1,data size %cycle
                              gbyte(0)
                           %repeat
                           -> done
            ot(byte):      gbyte(ownval); -> done

            ot(lreal):     gput(byteinteger(addr(rvalue))!byteinteger(addr(rvalue)+1)<<8)
                           gput(byteinteger(addr(rvalue)+2)!byteinteger(addr(rvalue)+3)<<8)
                           gput(byteinteger(addr(rvalue)+4)!byteinteger(addr(rvalue)+5)<<8)
                           gput(byteinteger(addr(rvalue)+6)!byteinteger(addr(rvalue)+7)<<8)
            done:
         %end

c('A'):;                                           ! Initialise OWN variable
      i = read tag;           ! Number of values to assign
      %if stp # 0 %start;     ! Value supplied?
         own val = top_disp
         pop stack
         %if own type = real %or own type = lreal %start
            rvalue = own val;  ! copy integer supplied into floater
         %finish
      %else;            ! initialise to default pattern
         ownval = 0
         cslen = 0;     ! in case it's a string
      %finish

      %if own form = array %or own form = name array %start
         adump %for j = 1,1,i
      %else
         %if otype = 0 %start ;   ! %const .... %name
            Abort("Constant Name");
         %else
            ! constant strings are treated as literals - everything else is "DATA"
            %if otype = con %and own type = string %start
               decvar_scope = COT
            %else
               decvar_scope = DATA
            %finish
            decvar_level = 0; decvar_disp = datatp
            adump
         %finish
      %finish
      ->next

c(''''): get string;  ->next;             ! Stack string constant

c('G'):  get string;                         ! Alias for item about to be declared
         alias = ""
         %for j = 1, 1, cslen %cycle
            alias = alias.tostring(current string(j))
         %repeat
         pop stack
         ->next

c('N'):;                                      ! Stack integer constant
        ! pass1 is 32 bit, but we are only 16 bit
         j = read tag;  ! discard the low half
         push const(read tag);  ->next

c('D'):;                                        ! Stack real constant
      get d;                                    ! suck the value into rvalue
      push const(0) %and ->next %if rvalue = 0
      ->next %if next sym = 'A'
      otype = con;          !  anonymous %const
      j = real constant;    !  N.B. ** %fn + side-effect **
      push const(0)
      top_type = lreal; top_scope = COT; top_disp = j; top_form = v in s
      ->next

c('n'):;                                     ! Select member from record format
		! Contrary to earlier iCode versions, this one seems to use 'n' for
		! both normal record member access and alternate formats?

      lhs == top;										! Points to the base record
		i = read tag
      push var(var(top_format)_pbase - i);	! Push descriptor for the i-th member

      %if top_aform # recordformat %start;   !  not record format - must be a member
         %if lhs_form = v in s %or lhs_form = VinRec %start
            top_disp = lhs_disp + top_disp
            lhs_form = lhs_form - v in s + top_form
         %else
            %if lhs_form = a in rec %start
               lhs_form = VinRec;  lhs_type = integer
               load(lhs,any)
               lhs_form = top_form
            %else
               %if lhs_form <= VinR %start
                  lhs_form = top_form;    ! ????
               %else;		! A in S
                  lhs_extra = lhs_disp
                  lhs_form = top_form+3
               %finish
            %finish
         %finish
         lhs_disp = top_disp
         lhs_type = top_type
         lhs_aform = top_aform
         lhs_dim = top_dim
      %finish
      lhs_size = top_size;  lhs_format = top_format
      pop stack
		->next

c('@'):;																! Stack variable descriptor
      push var(read tag)
      ->next

c('E'):compile call(top);										! Call procedure
      ->next

c('M'):;                                              ! MAP result
      amap(top)
      load(top, AX)
      pop rel
      dump return
		->next

c('V'):;                                              ! FN result
      %if procvar_type = integer %start
         load(top, AX)
			pop rel
      %else
         %if procvar_type = real %or procvar_type = lreal %start
         ! Floating point results are put into store, and AX contains
         ! the address
            load(top, anyf)
				pop rel
            %if fp result loc = -1 %start;   ! clunky allocation coming up
               gfix(align)
               fp result loc = datatp
               gput(0); gput(0); gput(0); gput(0)
            %finish
            %if procvar_type = real %start
               dumpfloprm(FSTD, DATA, fp result loc)
            %else
               dumpfloprm(FSTQ, DATA, fp result loc)
            %finish
            dumprioffset(MOV, AX, DATA, fp result loc)
         %else ; ! string or record - pass back through the hidden parameter
            push copy(top);               ! Make a copy of the thing on top
            lhs == stack(stp-1);       ! point to the (now spare) next item
            lhs_type = procvar_type;   ! and make it look like a destination
            lhs_size = procvar_size
            lhs_format = procvar_format
            lhs_base = BP
            lhs_disp = 6;              ! At the offset of the last parameter
            lhs_form = a in s
            assign(1)
         %finish
      %finish

c('R'):;                                              ! RETURN
      dump return
      ->next

c('K'):;                     ! %false
      k = 0;  -> true false

c('T'):;                     ! %true
      k = -1
true false:
      dumpri(MOV, AX, k)
      dump return
      ->next

c('a'):  array ref(0);   ->next
c('i'):  array ref(1);   ->next
c('.'):  operate(op conc);  ->next
c('+'):  operate(op add);   ->next
c('\'):  operate(op not);   ->next
c('U'):  operate(op neg);   ->next
c('-'):  operate(op sub);   ->next
c('!'):  operate(op or);    ->next
c('%'):  operate(op xor);   ->next
c('&'):  operate(op and);   ->next
c('['):  operate(op lsh);   ->next
c(']'):  operate(op rsh);   ->next
c('*'):  operate(op mul);   ->next
c('/'):  operate(op div);   ->next
c('Q'):  operate(op rdiv);  ->next
c('X'):  operate(op exp);   ->next
c('x'):  operate(op rexp);  ->next
c('v'):  operate(op abs);  ->next

c('j'):  assign(2);   ->next;                      ! JAM transfer
c('S'):  assign(1);   ->next;                      ! Normal value assignment
c('Z'):  assign(0);   ->next;                      ! Assign address '=='

c('p'):	assign(-1);	 ->next;								! Pass a parameter

c('u'):	opr = op add; ->uq common;            !++
c('q'):	opr = op sub;                         !--
uq common:
	      lhs == stack(stp-1)
         t = lhs_type;  j = lhs_size
                        j = j+1 %if t = string
         amap(lhs)
         abort("++/-- size") %if j = 0
         push const(j)
         operate(op mul)
         operate(k)
         vmap(top);  top_type = t
         ->next

c('k'):  dumpri(CMP, AX, 0);                    ! Branch on FALSE (= 0)                                     ! Branch =
c('='):  opr = JE;    -> cond
c('t'):  dumpri(CMP, AX, 0);                    ! Branch on TRUE (# 0)
c('#'):  opr = JNE;   -> cond
c('<'):  %if invert # 0 %then opr = JG %else opr = JL;   -> cond
c('>'):  %if invert # 0 %then opr = JL %else opr = JG;   -> cond
c('('):  %if invert # 0 %then opr = JGE %else opr = JLE;   -> cond
c(')'):  %if invert # 0 %then opr = JLE %else opr = JGE;   -> cond
cond:
      ! move the > and < operators to unsigned versions if needed
      %if compare unsign # 0 %and opr >= JG %then opr = opr + 4
      compare unsign = 0
      val = read tag
      jump to(val, opr, 1);  invert = 0
      ->next

c('C'):;                                     ! Compare addresses
      amap(top);  amap(stack(stp-1));        ! fall through to values

c('?'):;                                     ! Compare values
      LHS == stack(stp-1)
      RHS == top
      compare(lhs,rhs)
      pop rel
      pop rel
      ->next

c('"'):;                                     ! Compare values, double sided
      LHS == stack(stp-1)
      RHS == top
      load(rhs, any)
		! We happen to know that Compare loads the left parameter in a register.
		! We've already got RHS in a register, so we flip the LHS and RHS to the
		! comparison and set Invert accordingly
      compare(rhs, lhs)
		invert = 1
      ! release LH and then overwrite it with RH
      release(lhs_base)
      lhs = rhs
      pop stack
      ->next

c('r'):  resolve(read tag);  ->next

c('_'):;                                     ! Define switch label
      uncond jump = 0
      v == var(read tag)
      j = top_disp; pop stack
		t = new tag
		dumplabel(t);
		swtab(v_disp+j) = t;
      ->next

c('W'):;                                     ! Jump to switch
      v == var(read tag)
      push const(1);  operate(op lsh);         ! subscript X 2
      load(top, anyp)
		dumpum(JMP, SWT!top_base, v_disp * 2);	! swtab is word-size, hence * 2
      pop rel
      uncond jump = next cad
      ->next

c('B'):;                                     ! Backward Jump
      val = read tag
		jump to(val, JMP, 0);
      ->next

c('F'):;                                     ! Forward Jump
      val = read tag
      %if val = 0 %then %start
         %if last skip # next cad %then %start
            skip proc = new tag
            dumpjump(JMP, skip proc)
         %finish
         ->next
      %finish
      jump to(val, JMP, 1)
      ->next

         %integerfn user label(%integer lab)
            %record(varfm)%name v
            %if lab > names %start
               names = lab
               v == var(lab)
               v = 0
               v_form = pgm label
               v_disp = new tag
               %result = v_disp
            %finish
            %result = var(lab)_disp
         %end
c('J'):;                                     ! Jump to user label
      dumpjump(JMP, user label(read tag))
      ->next

c('L'):;                                     ! Define user label
      dump label(user label(read tag))
      ->next

c(':'):;                                     ! Define compiler label
      j = read tag
		%if j = 0 %start
			dump label(skipproc)
			last skip = next cad
			Uncond Jump = 0
			-> next
		%finish
      define label(j);  ->next

c('f'):;                                     ! FOR loop header
      compile for;  ->next

c('w'):;                                     ! Machine code
      abort("Machine Code")
!      ->next

c('P'):;                                     ! Machine code literal
      abort("Machine Literal")
!      cput(top_disp)
!      pop stack
!      ->next

c('y'):;                                     ! %diagnose n
      j = read tag
      %if (j>>14)&3 = 2 %start;         ! it's for pass 2
         diagnose = j & 16_3FFF
      %else
         !***** should pass onto next pass ******
      %finish
      ->next

c('z'):;                                     ! %control n
      control = read tag;  ->next

c('m'):;                                     ! %monitor
      j = -1;  -> SIGNAL EVENT

c('s'):;                                     ! %stop
      j = 0;  -> SIGNAL EVENT

c('e'):;                                     ! %signal event
      j = read tag
SIGNAL EVENT:
      push const(0) %while stp < 2
      push const(j)
      load(top, any); dumpur(PUSH, top_base); pop rel
      load(top, any); dumpur(PUSH, top_base); pop rel
      load(top, any); dumpur(PUSH, top_base); pop rel
      perm(signal, 6)
      uncond jump = next cad
      ->next

c('o'):;                                     ! %on %event block
      ->next

c('h'):;   ! compiler op(n)
!      compiler op(tag)
      ->next

c('g'):;    !array formats
c('d'):
      ! in params:  =0 -> simple array,  # 0 -> array-in-record
      
      ! First get dimensions
      dim = read tag;  abort("Array Dim") %unless 0 < dim < 3
      
      ! Now get number of (previously declared) array variables we are defining
      read symbol(next sym);  n = read tag

      %if in params # 0 %start;         ! Array in record
         parms = parms+n
         vub = top_disp; pop stack
         vlb = top_disp; pop stack
         abort("Array Bounds") %if vlb > vub
         dv = set dope vector
      %else
         names = names-n
         ! Now we need to plant code to manufacture a dope vector
         frame = (frame - ((dim * 4)+4))&(\1);  ! space for :Dim:<bound pairs>:DataSize:
         dv = frame
         ! First store the dimension
         dumpmi(MOV, BP, dv, dim)
         ! And the data size is also constant
         dumpmi(MOV, BP, dv + (dim*4) + 2, data size)
         ! Now the bounds
         j = 0;                    ! points to before the first stack value
         %for i=1,1,dim*2 %cycle
            j = j + 1; lhs == stack(j)
            %if lhs_form = constant %start
               dumpmi(MOV, BP, dv + (i*2), lhs_disp)
            %else
               load(lhs, any)
               dumpmr(MOV, BP, dv + (i*2), lhs_base)
            %finish
         %repeat
         ! Now we need to allocate the space for the array
         %if dim > 1 %or control & check array # 0 %start
            ! Do it with the PERM
            %while stp # 0 %cycle
               pop rel; ! get rid of all the bounds - they are in the DV already
            %repeat
            dumprm(LEA, AX, BP, dv)
            dumpur(PUSH, AX)
            perm(adef, 2)
            ! We now need to make our result match the inline version
            ! by putting AX and DX into stacklike variables
            push const(0); lhs == top
            push const(0); rhs == top
            lhs_base = AX; lhs_form = V in R; claim(AX)
            rhs_base = DX; rhs_form = V in R; claim(DX)
            pop stack
            pop stack
         %else
            push const(1)
            operate(op add)
            push const(data size)
            operate(op mul)
            push copy(stack(stp-1));   ! suck up the lower bound
            push const(data size)
            operate(op mul)
            ! top is now the lower bound, next is the upper, and a bogus copy of lb is next
            load(top, any);      ! Make sure this is in a register
            lhs == top;          ! Point to it
            pop stack;           ! and drop (without release) this copy
            load(top, any);      ! This is now UB - load it in a register as well
            rhs == top;          ! Point to it
            pop stack;           ! and keep RHS (Upper)
            pop stack;           ! dump the bogus lb
         %finish
! Note - there are 4 GP registers, and we're going to need them ALL here
         t = gp reg;             ! get a working register for the dope vector address
         dumprm(LEA, t, BP, dv); ! load it
         dv = t; claim(dv);      ! use this to hold the register number
         t = gp reg;             ! the last one! (which we don't claim, 'cos we can't lose it)
			dumprr(MOV, t, SP);	   ! working copy of SP so that real SP is always "OK"
      %finish

      %for j = 1,1,n %cycle
         decvar_dim = dim
         %if in params = 0 %start;      !  array not in record
            names = names+1;  decvar == var(names)
            decvar_level = level
            frame = frame - 4;  ! 2-word header
            decvar_disp = frame
            %if decvar_form = array %or decvar_form = namearray %c
                     %then decvar_form = decvar_form + 1;         ! force arrayname
				dumprr(SUB, t, rhs_base);
				dumpmr(MOV, BP, frame, t);         ! store a(0) address
            dumpmr(MOV, BP, frame+2, dv);      ! store dope vector pointer
				dumprr(ADD, t, lhs_base);
         %else;          ! array-in-record
            parms = parms-1;  decvar == var(parms)
            decvar_disp = frame - vlb
            frame = frame + vub; ! noting that Set Dope Vector has changed VUB to the array size
            decvar_pbase = dv
         %finish
      %repeat

      %if in params = 0 %start
         dumprr(MOV,SP,t)
         release(lhs_base)
         release(rhs_base)
         release(dv)
      %finish
      ->next

c('^'):;                                     !   {Set Format}
      top_type   = record
      top_format = read tag
      ->next

c('I'):  Abort("Pascal?");!   {ESCAPE for Pascal etc.}

c('~'):;                  ! alternate record format
      sym = next sym;  read symbol(next sym)
      %if sym = 'A' %start;            ! alt start
         decvar == procvar
         assemble(-2,labs,names)
         ->next
      %finish

      %if sym = 'B' %then -> out;             ! alt end

      abort("Alt Record") %if sym # 'C';         ! faulty intermediate code
		! Compile the next alternate - update limit and set frame back to where we started
      max frame = frame %if frame > max frame
		frame = old frame
      ->next

c('{'):;                                              ! Start of formal parameters
      in params = -1
      ! this is either a record format, a procedure, or a proc spec;
      !   - block type was set by decvar to tell us which
      assemble(block type,labs,names)
      ->next

c('}'):;                                              ! End of formal parameters
      in params = 0
      -> OUT %if amode < 0;            ! end of %record %format defn.
      -> OUT %if procvar_level = 128;  ! prim routine reference

		! Here it's a real subroutine - copy any parameters to the PARM area
      %if names > first name %start
         procvar_pbase = parms;					! Point one beyond the first parameter
			frame = (frame + 1) & (\1);			! Even up the stack size
			%if procvar_type = string %and procvar_form = 8 %start
				frame = frame + 2;					! string functions have a hidden result parameter
			%finish
			procvar_extra = frame;					! Remember the stack offset
			procvar_dim = names - first name;	! and the number of parameters
			frame = frame + 6;						! leave space for return linkage
         %for j = first name+1, 1, names %cycle
            ap == var(j)
            parms = parms-1;  fp == var(parms)
            fp = ap
				! formal parameter base and displacement is implicit (on the stack)
				fp_level = 0
				! we also need to adjust the offsets of the actual parameters, because
				! they were allocated going "forwards", but will be pushed on the stack
				! "backwards" - that is, the first item passed will end up with the
				! highest address.  DefineVar has done part of the work for us by tagging
				! the displacements in the right style, but it can't tell the whole frame
				! offset, so we calculate the final offsets here...
				ap_disp = frame - ap_disp
         %repeat
         abort("Params") %if parms < names
      %finish
      -> OUT %if amode = 2;	! this was just a spec
      frame = 0
      dumplabel(procvar_disp)
      static alloc = enter
      ->next

c('H'):;                                              ! Start of BEGIN block
      decvar == begin;  decvar_disp = new tag
      otype = 0;  spec = 0;  potype = 0
      %if level # 0 %start;  ! not outermost %begin
         push const(decvar_disp)
			top_type = 0;											! it's not a function!
         compile call(top)
         skip proc = new tag
         dump jump(JMP, skip proc)
      %finish
      assemble(0,labs,names)
      %if level # 0 %start
         dump label(skip proc)
         last skip = next cad
         Uncond Jump = 0
      %finish
      ->next

   ! To catch the sinners!!
C(*):
      abort("Bad I Code")

c(';'):
   %if amode >= 0 %start;     ! No return code for %endoffile
      dump return
	   dumpstaticfill(staticalloc, frame);
   %finish

OUT:
   %if amode >= 0 %start;         ! end of declarative block
      level = level-1
   %else;                        ! end of record format defn
      %if amode = -2 %start;                  ! end of alternative only
		   frame = max frame %if max frame > frame;	! use the longest alternative
         old frame = frame
      %else
         frame = (frame+align)&(\align);   ! **** temporary ****
         procvar_size = frame
      %finish
   %finish
   frame = old frame

%end;           !  assemble


!              -------- it all starts here ---------

   select input(icode)
   select output(objout) 

   var(0) = 0;              !  for %RECORD(*) . . . . .
   parms = max vars

	cslen == current string(0)

! Initialise the GP Tag ASL
	%for i=1,1,Max GP %cycle
		GP Tags(i)_link = i - 1
	%repeat
	gp asl = Max GP

! Tell the linker our source file name
	dumpsourcename("TEST.IMP");   ! ABD - a bit bogus at the moment!

! predefine the perms for the linker.  We ignore
! the number (j) because we know they are in sequence
	%for i=1,1,lastperm %cycle
		j = externalref(permname(i))
	%repeat

   read symbol(next sym);          !  Prime SYM/NEXT pair

   Spec = 0
   decvar == begin
   assemble(-3,0,0)

! We flush constants
   flush cot
   flush data
   flush switch

%ENDOFPROGRAM