head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.32.19;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.09.06;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.30.01;  author jwh;  state Exp;
branches ;
next     55.2;

55.2
date     91.09.26.12.35.26;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.08.05;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.16.17;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.16.55;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.02.08;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.01.16;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.14.52;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.03.10;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.08.57;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.46.07;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.34.29;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.41.22;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.21.59.10;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.48.57;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.34.30;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.16.51;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.39.48;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.25.10;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.15.24;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.28.41;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.07.45;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.18.42;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.15.54.09;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.29.46;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.35.30;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.17.56.26;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.34.48;  author dew;  state Exp;
branches ;
next     29.2;

29.2
date     88.11.18.13.55.17;  author jwh;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.18.42;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.48.35;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.13.32;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.12.29.09;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.07.35;  author bayes;  state Exp;
branches ;
next     24.3;

24.3
date     88.02.09.11.00.24;  author brad;  state Exp;
branches ;
next     24.2;

24.2
date     88.02.08.12.53.27;  author brad;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.15.48;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.09.52.24;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.32.39;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.20.36;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.30.48;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.07.49.11;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.14.43.49;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.01.11;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.16.09;  author jws;  state Exp;
branches ;
next     15.2;

15.2
date     87.04.21.13.41.42;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.08.41.03;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.14.35.24;  author jws;  state Exp;
branches ;
next     13.2;

13.2
date     87.03.18.10.43.39;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.04.56;  author jws;  state Exp;
branches ;
next     12.2;

12.2
date     87.02.25.10.34.35;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.12.50.55;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.17.53;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.23.43;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.13.45.03;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.21.08;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.06.40;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.07.10;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.15.57.52;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.10.24;  author hal;  state Exp;
branches ;
next     3.2;

3.2
date     86.09.26.08.20.22;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.23.20;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.14.06;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.13.28.36;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@				{ file GENCODE }
import
  genexprmod,assemble,genutils,genmove,fs,ci,float_hdw;
implement

procedure bigmove
   (var source,dest: attrtype; wdstomove: integer;
    A1isfree: boolean; bytetomove: boolean);
  (* source   - will be A0+ or A1+ or disp(Areg)
     dest     - will be A0+ or A1+ or disp(Areg)
     for disp(Areg),
	Areg is (A0, A1 or A6)
	disp may not be zero
     wdstomove- is a word count not a byte count
     A1isfree - reflects the mode of addressing the dest *)
  var
    curmove: shortint;
    multiple,op: attrtype;
  begin
    if source.addrmode <> locinreg then
      begin
      source.offset := 0;
      source.gloptr := NIL;
      source.indexed := false;
      end;
    if dest.addrmode <> locinreg then
      begin
      dest.offset := 0;
      dest.gloptr := NIL;
      dest.indexed := false;
      end;
    if wdstomove < 28 then
      while wdstomove > 0 do
	case wdstomove of
	  1: begin
	     with source do
	       if addrmode <> locinreg then
		 begin
		 addrmode := locinreg; offset := 0; indexed := false;
		 gloptr := NIL;
		 end;
	     with dest do
	       if addrmode <> locinreg then
		 begin
		 offset := 0; indexed := false; addrmode := locinreg;
		 gloptr := NIL;
		 end;
	     dest.storage := wrd;
	     emit2(move,source,dest);
	     wdstomove := 0;
	     dest.offset := dest.offset + 2;
	     source.offset := source.offset + 2;
	     end;
       2..4: begin
	     if wdstomove = 2 then
	       begin
	       with source do
		 if addrmode <> locinreg then
		   begin
		   addrmode := locinreg; offset := 0; indexed := false;
		   gloptr := NIL;
		   end;
	       with dest do
		 if addrmode <> locinreg then
		   begin
		   offset := 0; addrmode := locinreg; indexed := false;
		   gloptr := NIL;
		   end;
	       end;
	     dest.storage := long;
	     emit2(move,source,dest);
	     wdstomove := wdstomove-2;
	     dest.offset := dest.offset + 4;
	     source.offset := source.offset + 4;
	     end;
   5,7,9,11: begin    {move multiple words}
	     getmultattr(wdstomove,A1isfree,multiple);
	     with source do
	       if addrmode <> locinreg then
		 begin
		 addrmode := locinreg; offset := 0; indexed := false;
		 gloptr := NIL;
		 end;
	     with dest do
	       begin
	       if addrmode <> locinreg then
		 begin
		 addrmode := locinreg; offset := 0; indexed := false;
		 gloptr := NIL;
		 end;
	       storage := wrd;
	       end;
	     multiple.storage := wrd;
	     emit2(movem,source,multiple);
	     emit2(movem,multiple,dest);
	     dest.offset := dest.offset + wdstomove * 2;
	     source.offset := source.offset + wdstomove * 2;
	     wdstomove := 0;
	     end;
6,8,10,12..24: begin      {move multiple long words}
	     if not A1isfree and (wdstomove > 22) then
	       curmove := 11{long words}
	     else
	       curmove := wdstomove DIV 2;
	     wdstomove := wdstomove - curmove*2;
	     if wdstomove = 0 then
	       begin
	       with source do
		 if addrmode <> locinreg then
		   begin
		   addrmode := locinreg; offset := 0; indexed := false;
		   gloptr := NIL;
		   end;
	       with dest do
		 if addrmode <> locinreg then
		   begin
		   addrmode := locinreg; offset := 0; indexed := false;
		   gloptr := NIL;
		   end;
	       end;
	     dest.storage := long;
	     multiple.storage := long;
	     getmultattr(curmove,A1isfree,multiple);
	     emit2(movem,source,multiple);
	     emit2(movem,multiple,dest);
	     dest.offset := dest.offset + curmove*4;
	     source.offset := source.offset + curmove*4;
	     end;
	  otherwise     {move multiple 11 or 12 long words}
	     begin
	     curmove := 11 + ord(A1isfree);
	     wdstomove := wdstomove - curmove * 2;
	     getmultattr(curmove,A1isfree,multiple);
	     multiple.storage := long;
	     emit2(movem,source,multiple);
	     dest.storage := long;
	     emit2(movem,multiple,dest);
	     dest.offset := dest.offset + curmove*4;
	     source.offset := source.offset + curmove*4;
	     end;
	  end {case}
    else { BIG  bigmove }
      begin
      { if bytetomove then saveregs; }  { <===== jwh 11/17/88 }
      forgetbaseregs;
      source.addrmode := locinreg;
      dest.addrmode := locinreg;
      emit1(pea,source);
      emit1(pea,dest);
      SPminus.storage := long;
      with op do
	begin
	addrmode := immediate;
	smallval := wdstomove * 2;
	if bytetomove then             { <======= jwh 11/17/88 }
	   smallval := smallval + 1;
	end;
      emit2(move,op,SPminus);
      callstdproc('ASM_MOVEL');
      { if bytetomove then reloadregs; }   { <==== JWH 11/17/88 }
      source.offset := source.offset + op.smallval;
      dest.offset := dest.offset + op.smallval;
      end;
  end; { bigmove }

procedure genbody (curbody: stptr; fprocp: ctp);
  type
    initlocvartype = (isnew,isdispose);

  procedure initlocvar
		  (varid: ctp; heapaddr: exptr;
		   disp: addrrange; fsp: stp;
		   initype: initlocvartype);
    { initialize local variables.  Base points to id for variable.
      Disp is offset from varid's location.  Fsp points to structure
      of current var or one of its fields or elements. }
    var
      lmin,lmax: integer; lsize,lcnt: integer; lcp: ctp;
      op1,op2,op3 : attrtype;
      patchloc: addrrange;

    procedure varaddress(opcd: opcodetype;
				disp: addrrange);
      var
	op1 : attrtype;
      begin
      if varid <> NIL then
	with varid^, op1 do
	  begin
	  if vtype < localvar then
	    begin
	    gloptr := NIL;
	    case vtype of
	      shortvar: addrmode := shortabs;
	      longvar:  addrmode := longabs;
	      relvar:   addrmode := prel;
	      end;
	    absaddr := varid^.absaddr; offset := disp;
	    end
	  else
	    begin
	    addrmode := locinreg;
	    offset := disp + vaddr;
	    indexed := false;
	    if vlev = 1 then
	      begin
	      regnum := SB; gloptr := currentglobal;
	      end
	    else
	      begin
	      regnum := localbase; gloptr := NIL;
	      end;
	    end;
	  storage := long;
	  emit1(opcd,op1);
	  freeregs(addr(op1));
	  end
	else { varid = NIL: heap variable }
	  begin
	  if disp = 0 then
	    pushaddress(heapaddr)
	  else
	    if disp > 32767 then
	      begin
	      pushaddress(heapaddr);
	      with op1 do
		begin
		addrmode := immediate;
		smallval := disp;
		end;
	      SPind.storage := long;
	      emit2(addi,op1,SPind);
	      end
	    else
	      begin
	      loadaddress(heapaddr,false);
	      with heapaddr^.attr^ do
		begin
		addrmode := locinreg;
		offset := disp;
		indexed := false;
		emit1(pea,heapaddr^.attr^);
		offset := 0;
		end;
	      end;
	  freeregs(heapaddr^.attr);
	  end;
      end;

    begin { initlocvar }
    if fsp <> NIL then
      with fsp^ do
	if mustinitialize in info then
	  case form of
	    files:
	      begin
	      if modulebody then
		begin
		varaddress(tst,disp+4);
		patchloc := codephile.bytecount + 2;
		op1.offset := 0;
		op1.storage := bytte;
		emit1(bne,op1);
		end;
	      SPminus.storage := long;
	      varaddress(pea,disp);
	      if initype = isnew then
		begin
		if filtype = NIL then
		  begin
		  emit1(clr,SPminus);      {CLR.L -(SP) assumes nilvalue = 0}
		  with op2 do
		    begin addrmode := immediate; smallval := -1; end;
		  emit2(move,op2,SPminus);      { MOVE.L #-1,-(SP) }
		  end
		else
		  begin
		  varaddress(pea,disp+filesize);
		  if (filtype^.unpacksize=1) then
		    with op2 do
		      begin
		      addrmode := immediate;
		      if fsp = textptr then smallval := -3
		      else smallval := -2;
		      emit2(move,op2,SPminus);
		      end
		  else
		    with op2 do
		      begin
		      addrmode := immediate;
		      smallval := filtype^.unpacksize;
		      emit2(move,op2,SPminus);
		      end;
		  end;
		callstdproc('FS_FINITB');
		end
	      else { initype = isdispose }
		begin
		SPminus.storage := wrd;
		emit1(clr,SPminus);
		callstdproc('FS_FCLOSE');
		end;
	      if varid <> NIL then
		if varid^.vtype = localvar then
		  with varid^ do
		    begin
		    with op3 do
		      begin
		      addrmode := locinreg;
		      offset := disp + vaddr;
		      indexed := false;
		      if vlev  = 1 then
			begin
			regnum := SB; gloptr := currentglobal;
			end
		      else
			begin
			regnum := localbase; gloptr := NIL;
			end;
		      end; { with op3 }
		    getregattr(A,op1);
		    emit2(lea,op3,op1);
		    with op1 do
		      begin
		      addrmode := locinreg;
		      offset := 4;
		      indexed := false;
		      gloptr := nil;
		      end;
		    SBind.offset := FIBptrdisp;
		    SBind.storage := long;
		    SBind.gloptr := sysglobalptr;
		    emit2(move,SBind,op1);
		    op1.addrmode := inAreg;
		    emit2(move,op1,SBind);
		    freeit(A,op1.regnum);
		    SBind.gloptr := NIL;
		    end; { with varid^ }
	      if modulebody then
		fixbyte(patchloc-1,codephile.bytecount-patchloc);
	      end;
	    arrays:
	      if inxtype <> NIL then
		begin
		getbounds(inxtype,lmin,lmax);
		if aeltype <> NIL then
		  begin
		  lsize := aeltype^.unpacksize;
		  if odd(lsize) then
		    lsize := lsize + 1;
		  if (varid = NIL) and
		     (lmax-lmin > 0) then
		    begin
		    getlocstorage(ptrsize,op1);
		    moveaddress(heapaddr,op1);
		    op1.access := indirect;
		    op2 := op1;
		    end
		  else if heapaddr <> NIL then
		    op2 := heapaddr^.attr^;
		  for lcnt:=0 to lmax-lmin do
		    begin
		    if heapaddr <> NIL then
		      begin
		      op1 := op2;
		      heapaddr^.attr := addr(op1);
		      end;
		    initlocvar(varid,heapaddr,
		      disp+lcnt*lsize,aeltype,initype);
		    end;
		  end;
		end;
	    records:
	      begin
	      lcp := fstfld;
	      if (varid = NIL) and
		 (lcp^.next <> NIL) then
		begin
		getlocstorage(ptrsize,op1);
		moveaddress(heapaddr,op1);
		op1.access := indirect;
		op2 := op1;
		end
	      else if heapaddr <> NIL then
		op2 := heapaddr^.attr^;
	      while lcp <> NIL do
		with lcp^ do
		  begin
		  if heapaddr <> NIL then
		    begin
		    op1 := op2;
		    heapaddr^.attr := addr(op1);
		    end;
		  initlocvar(varid,heapaddr,
		    disp+fldaddr,idtype,initype);
		  lcp := lcp^.next;
		  end;
	      end;
	    otherwise escape(-8);
	    end; {case}
    end; {initlocvar}


  procedure getcnfsize(cnf: stp; var op: attrtype);
    var
      lobound_attr,
      hibound_attr,
      cnfsize_attr,
      op1,op2: attrtype;
      hi,lo: integer;
      big_range: boolean;

    begin
    with op1 do
      begin
      addrmode := inDreg;
      regnum := getreg(D);
      case cnf^.inxtype^.unpacksize of
	1: storage := bytte;
	2: storage := wrd;
	4: storage := long;
      end;
      with hibound_attr do
	begin
	addrmode := locinreg;
	regnum := getbasereg(cnf^.cnf_index^.hiboundid^.vlev);
	offset := cnf^.cnf_index^.hiboundid^.vaddr;
	indexed := false;
	gloptr := NIL;
	end;
      if op1.storage = bytte then
	begin
	op1.storage := long;
	emit1(clr,op1);
	op1.storage := bytte;
	end;
      emit2(move,hibound_attr,op1);
      getbounds(cnf^.inxtype,hi,lo);
      try
	big_range := hi - lo >= 32767;
      recover
	if escapecode = -4 {overflow} then
	  big_range := true
	else
	  escape(escapecode);

      lobound_attr := hibound_attr;
      lobound_attr.offset := cnf^.cnf_index^.loboundid^.vaddr;
      if (op1.storage = long) or big_range then
	begin
	if op1.storage = wrd then
	  begin
	  op1.storage := long;
	  emit1(ext,op1);
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := wrd;
	    end;
	  emit2(move,lobound_attr,op2);
	  op2.storage := long;
	  emit1(ext,op2);
	  freeit(D,op2.regnum);
	  end
	else
	  begin
	  op2 := lobound_attr;
	  op2.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  op2.storage := long;
	  end;
	end
      else {wrd result}
	begin
	if op1.storage = bytte then
	  begin
	  op1.storage := wrd;
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := long;
	    end;
	  lobound_attr.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  emit1(clr,op2);
	  op2.storage := bytte;
	  emit2(move,lobound_attr,op2);
	  op2.storage := wrd;
	  freeit(D,op2.regnum);
	  end
	else { op1.storage := wrd }
	  begin
	  op2 := lobound_attr;
	  op2.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  op2.storage := wrd;
	  end;
	end;
      emit2(sub,op2,op1);
      op2.addrmode := immediate;
      op2.smallval := 1;
      emit2(addq,op2,op1);                {hi - lo + 1}

      {multiply by size}

      cnfsize_attr := lobound_attr;
      if op1.storage = long then  {call routine}
	begin
	if cnf^.inxtype^.unpacksize = 2 then
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg; regnum := getreg(D);
	    storage := wrd;
	    end;
	  cnfsize_attr.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := long;
	  emit1(ext,op2);
	  end
	else
	  begin
	  op2 := cnfsize_attr;
	  op2.storage := long;
	  op2.offset := cnf^.cnf_index^.hiboundid^.vaddr + 4;
	  end;
	$IF MC68020$
	  emit2(muls,op2,op1);
	  with op do
	    begin
	    addrmode := inDreg;
	    regnum := op1.regnum;
	    storage := long;
	    signbit := true;
	    end;
	$END$
	$IF not MC68020$
	  SPminus.storage := long;
	  emit2(move,op1,SPminus);
	  freeit(D,op1.regnum);
	  emit2(move,op2,SPminus);
	  if op2.addrmode = inDreg then
	    freeit(D,op2.regnum);
	  freeregs(addr(hibound_attr));
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_MPY');
	  reloadregs;
	  with op do
	    begin
	    addrmode := topofstack;
	    storage := long;
	    signbit := true;
	    end;
	$END$
	end     { multiply routine }
      else
	begin   { in line multiply }
	if cnf^.inxtype^.unpacksize = 1 then
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := wrd;
	    end;
	  cnfsize_attr.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  emit1(clr,op2);
	  op2.storage := bytte;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := wrd;
	  end
	else
	  begin
	  op2 := cnfsize_attr;
	  op2.storage := wrd;
	  op2.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  end;
	emit2(muls,op2,op1);
	if op2.addrmode = inDreg then
	  freeit(D,op2.regnum);
	op := op1;
	op.storage := long;
	freeregs(addr(hibound_attr));
	end;
      {Packed array ?}
      if cnf^.aispackd then
	begin { turn bit count into a whole byte count }
	if op.addrmode <> inDreg then
	  with op1 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := long;
	    emit2(move,op,op1);
	    freeregs(addr(op));
	    op := op1;
	    end;
	with op1 do
	  begin
	  addrmode := immediate;
	  smallval := 7;
	  emit2(add,op1,op);
	  smallval := 3;
	  emit2(lsr,op1,op);
	  end;
	end;
      end;
    end;

  procedure gencode(curstmt: stptr);
    var
      oldlc: addrrange;
      attrlistptr: attrptr;
      opnd: attrtype;
      i: shortint;
      p: reflistptr;

    procedure releaseattr;
      {release attribute records for the current statement}
      var
	p: attrptr;
      begin
	if attrlistptr <> NIL then
	  begin
	  p := attrlistptr;
	  while p^.next <> NIL do
	    p := p^.next;
	  p^.next := freeattr;
	  freeattr := attrlistptr;
	  end;
      end;

    function treematch(lhs,rhs: exptr): boolean;
      var
	temp: exptr;

      begin {treematch}
	with rhs^ do begin
	  if (eclass in [addnode,subnode]) or
	     ((eclass in [ornode,andnode]) and not shortcircuit) then
	    if eclass = subnode then treematch := branchmatch(lhs,opnd1)
	    else if branchmatch(lhs,opnd1) then treematch := true
	    else if branchmatch(lhs,opnd2) then
	      begin
	      treematch := true;
	      temp := opnd1;
	      opnd1 := opnd2;
	      opnd2 := temp;
	      end
	    else treematch := false
	  else treematch := false;
	end; {with rhs^}
      end; {treematch}

    procedure movemulti(source,dest: exptr;
				numbytes: integer);
      var
	numregs : 0..13; {D0-D7,A0-A4}
	rt : regtype;
	rn : regrange;
	numwords,curmove: integer;
	oddnum : boolean;
	op,multiregs : attrtype;
      begin
      numwords := numbytes div 2;
      makeaddressable(source);
      makeaddressable(dest);
      { If either source or dest has an index register the offset field
	in the 68010 addressing modes would be restricted to 8 bits.  We
	can't be sure that the final word or byte moves would have an
	offset that would fit in 8 bits so we get rid of indexing. }
      if (source^.attr^.addrmode in [locinreg, prel]) and
	  source^.attr^.indexed then
	loadaddress(source,false);
      if (dest^.attr^.addrmode in [locinreg, prel]) and
	  dest^.attr^.indexed then
	loadaddress(dest,false);
      if (numwords = 1) or (numwords = 2) then
	begin
	if numwords = 1 then dest^.attr^.storage := wrd
			else dest^.attr^.storage := long;
	emit2(move,source^.attr^,dest^.attr^);
	if odd(numbytes) then
	  begin
	  with source^.attr^ do offset := offset+numbytes-1;
	  with dest^.attr^ do offset := offset+numbytes-1;
	  end;
	end
      else if numwords > 0 then
	begin
	numregs := 0;
	{ build MOVEM format with list of available registers }
	for rt := A to D do
	  for rn := 0 to maxreg do
	    if (reg[rt,rn].allocstate = free) and (numregs < numwords) then
	      begin
	      numregs := numregs + 1;
	      if (rt = A) then forgetbasereg(rn);
	      multiregs.regs[rt,rn] := true;
	      end
	    else
	      multiregs.regs[rt,rn] := false;

	if numwords <= numregs then
	  begin  { enough regs available for word move multiple }
	  with multiregs do
	    begin addrmode := multiple; storage := wrd; end;
	  emit2(movem,source^.attr^,multiregs);
	  dest^.attr^.storage := wrd;
	  emit2(movem,multiregs,dest^.attr^);
	  if odd(numbytes) then
	    begin
	    with source^.attr^ do offset := offset+numbytes-1;
	    with dest^.attr^ do offset := offset+numbytes-1;
	    end;
	  end {word move multiple}
	else if numwords <= 2 * numregs + 1 then
	  begin  { enough regs available for long word move multiple }
	  oddnum := false;
	  if odd(numwords) then
	    begin
	    oddnum := true;
	    numwords := numwords - 1
	    end;
	  if numwords <> 2 * numregs then { remove extra regs }
	    begin
	    numregs := 0;
	    for rt := A to D do
	      for rn := 0 to maxreg do
		if (reg[rt,rn].allocstate = free) and
		   ((numregs*2) < numwords) then
		  begin
		  numregs := numregs + 1;
		  if (rt = A) then forgetbasereg(rn);
		  multiregs.regs[rt,rn] := true;
		  end
		else
		  multiregs.regs[rt,rn] := false;
	    end;
	  with multiregs do
	    begin addrmode := multiple; storage := long; end;
	  emit2(movem,source^.attr^,multiregs);
	  dest^.attr^.storage := long;
	  emit2(movem,multiregs,dest^.attr^);
	  with source^.attr^ do
	    offset := offset + 2*numwords;
	  with dest^.attr^ do
	    offset := offset + 2*numwords;
	  if oddnum then { move "odd" word }
	    begin
	    dest^.attr^.storage := wrd;
	    emit2(move,source^.attr^,dest^.attr^);
	    with source^.attr^ do offset := offset+2;
	    with dest^.attr^ do offset := offset+2;
	    end; {if oddnum}
	  end {long word move multiple}
	else
	  begin { not enough available regs, use D0-D7 and A2-A4 }
	  clear(false);
	  { set up source and dest pointers subject to :
	    1) addressing mode must use offset attribute
	    2) A0 and A1 are reserved for source/dest pointers }

	  with source^.attr^ do { form source address, if necessary }
	    if (addrmode = locinreg) and (regnum in [2..4])
		or (addrmode <> locinreg) or indexed then
	      begin { address via A0 or A1 }
	      with op do
		begin
		addrmode := inAreg;
		if (dest^.attr^.addrmode=locinreg) and
		   (dest^.attr^.regnum = 0)
		then regnum := 1
		else regnum := 0;
		end;
	      emit2(lea,source^.attr^,op);
	      with source^.attr^ do
		begin
		addrmode := locinreg; offset := 0; indexed := false;
		regnum := op.regnum; gloptr := NIL;
		end;
	      end;

	  with dest^.attr^ do { form dest address, if necessary }
	    if (addrmode = locinreg) and (regnum in [2..4])
		or (addrmode <> locinreg) or indexed then
	      begin { address via A0 or A1 }
	      with op do
		begin
		addrmode := inAreg;
		if (source^.attr^.addrmode=locinreg) and
		   (source^.attr^.regnum = 1)
		then regnum := 0
		else regnum := 1;
		end;
	      emit2(lea,dest^.attr^,op);
	      with dest^.attr^ do
		begin
		addrmode := locinreg; offset := 0; indexed := false;
		regnum := op.regnum; gloptr := NIL;
		end;
	      end;

	  { emit appropriate move sequence }
	  with source^.attr^ do
	    if (regnum = 0) or (regnum = 1) then
	      with reg[A,regnum] do
		begin
		allocstate := allocated;
		usage := other;
		end;
	  with dest^.attr^ do
	    if (regnum = 0) or (regnum = 1) then
	      with reg[A,regnum] do
		begin
		allocstate := allocated;
		usage := other;
		end;
	  bigmove(source^.attr^,dest^.attr^,
		   numwords,false,odd(numbytes));
	  end; {else begin}
	end; { if numwords > 0 }
      if ((odd(numbytes)) and (numbytes <= 55)) then  { <=== JWH 11/17/88 }
	begin
	dest^.attr^.storage := bytte;
	emit2(move,source^.attr^,dest^.attr^);
	end;
      freeregs(source^.attr); freeregs(dest^.attr);
      end; {movemulti}

    procedure cnfassign(lhs,rhs: exptr);
      var
	op: attrtype;
      begin
      pushaddress(rhs);
      pushaddress(lhs);
      getcnfsize(lhs^.etyptr,op);
      if op.addrmode = inDreg then
	begin
	SPminus.storage := long;
	emit2(move,op,SPminus);
	freeit(D,op.regnum);
	end;
      forgetbaseregs;
      callstdproc('ASM_MOVEL');
      end;

    procedure genassign (lhs,rhs : exptr);
      var
	lmin,lmax: valu; r: regrange;
      begin
      if RANGECHECK then
	emitcheck(rhs,lhs^.etyptr,true);
      if lhs^.attr^.packd then
	if rhs^.attr^.packd then packtopack (lhs,rhs)
			    else pack(lhs,rhs)
      else with rhs^.attr^ do begin
	if packd then makeaddressable(rhs);
	makeaddressable(lhs);
	if storage = multi then
	  storage := lhs^.attr^.storage
	else if (storage <> lhs^.attr^.storage) then
	  extend(rhs,lhs^.attr^.storage);
	if (addrmode = immediate) and (smallval = 0) then
	  emit1(clr,lhs^.attr^)
	else begin
	  if not rangecheck then maskboolexpr(rhs);
	  movevalue(rhs,lhs^.attr^);
	  end;
	freeregs(lhs^.attr);
	end; {with rhs^.attr^}
      end; {genassign}

    procedure substrassign(source,dest: exptr);
      var
	destisstring: boolean;
      begin
      pushsubstr(dest);
      if strgtype(dest^.arayp^.etyptr) then
	destisstring := true
      else destisstring := false;
      if source^.eclass = substrnode then
	begin
	pushsubstr(source);
	clear(false);
	if destisstring then
	  if strgtype(source^.arayp^.etyptr) then
	    callstdproc('ASM_SSUBTOSSUB')
	  else callstdproc('ASM_PSUBTOSSUB')
	else
	  if strgtype(source^.arayp^.etyptr) then
	    callstdproc('ASM_SSUBTOPSUB')
	  else callstdproc('ASM_PSUBTOPSUB');
	end
      else escape(-8);
      end;

    procedure specialassign(lhs,rhs: exptr; var done: boolean);
      begin
      genexpr(lhs);
      with lhs^,attr^ do begin
	if packd then done := false
	else if etyptr^.form = reals then done := false
	else if (rhs^.eclass in [addnode,subnode]) and
	  ((storage = bytte) or (not signbit)) then done := false
	else if RANGECHECK and ((etyptr^.form = subrange) or
	  ((etyptr^.form=scalar) and (etyptr<>intptr))) then done := false
	else with rhs^ do begin
	  makeaddressable(lhs);
	  makeaddressable(opnd2);
	  if opnd2^.eclass = litnode then
	    fixliteral(opnd2,lhs^.attr^.storage,lhs^.attr^.signbit);
	  if opnd2^.attr^.storage > lhs^.attr^.storage then done := false
	  else
	    begin
	    extend(opnd2,lhs^.attr^.storage);
	    if (opnd2^.eclass = litnode) then
	      begin
	      if (eclass in [addnode,subnode]) then
		begin
		if opnd2^.attr^.smallval <> 0 then
		  begin
		  case eclass of
		    addnode: emit2(add,opnd2^.attr^,lhs^.attr^);
		    subnode: emit2(sub,opnd2^.attr^,lhs^.attr^);
		  end; {case}
		  ovflck;
		  end;
		end
	      else {eclass in [ornode,andnode]}
		case eclass of
		  ornode: if opnd2^.attr^.smallval = 1 then
			    emit2(move,opnd2^.attr^,lhs^.attr^);
		  andnode: if opnd2^.attr^.smallval = 0 then
			     emit1(clr,lhs^.attr^);
		end; {case}
	      end
	    else {opnd2^.eclass <> litnode}
	      begin
	      loadvalue(opnd2);
	      case eclass of
		addnode: emit2(add,opnd2^.attr^,lhs^.attr^);
		subnode: emit2(sub,opnd2^.attr^,lhs^.attr^);
		ornode:  emit2(orr,opnd2^.attr^,lhs^.attr^);
		andnode: emit2(andd,opnd2^.attr^,lhs^.attr^);
		end; {case}
	      if eclass in [addnode,subnode] then ovflck;
	      end;
	    freeregs(opnd2^.attr);
	    freeregs(lhs^.attr);
	    done := true;
	    end;
	  end;
	end; {with}
      end; {specialassign}

$if bigsets$
    procedure pushlongword(i: integer);
      var op: attrtype;
      begin
      with op do
	begin
	addrmode := immediate;
	smallval := i;
	SPminus.storage := long;
	emit2(move,op,SPminus);
	end;
      end;
$end$

    procedure pushword(i: shortint);
      var op: attrtype;
      begin
      with op do
	begin
	addrmode := immediate;
	smallval := i;
	SPminus.storage := wrd;
	emit2(move,op,SPminus);
	end;
      end;

    procedure genbecomes (curstmt : stptr);
      var
	done: boolean; offsetexpr: exptr;
	op: attrtype;

      begin {genbecomes}
      with curstmt^ do
	begin
	done := false;
	if treematch(lhs,rhs) then specialassign(lhs,rhs,done);
	if not done and (rhs^.eclass = fcallnode) then
	  if (rhs^.fptr^.pfdeckind <> standard) and
	     (rhs^.fptr^.spkey = spaddr) then    { handle p := addr(...) }
	    begin makeaddressable(lhs);
	    with rhs^.actualp^,expptr^ do
	      if (eclass = derfnode) and not rangecheck then
		if branchmatch(lhs,opnd) then  { <ptr> := addr(<ptr>^... }
		  if nextptr = NIL then done := true
		  else with nextptr^,expptr^ do
		    begin done := false;
		    makeaddressable(expptr);
		    if eclass = litnode then
		      begin
		      fixliteral(expptr,long,true);
		      with litval do
			if intval and (ival = 0) then {do nothing}
			else emit2(add,expptr^.attr^,lhs^.attr^);
		      end
		    else  { offset not literal }
		      begin
		      extend(expptr,long); loadvalue(expptr);
		      emit2(add,attr^,lhs^.attr^);
		      freeit(D,attr^.regnum);
		      end;
		    done := true;
		    end;
	    if not done then  { above branchmatch failed on <ptr> }
	      begin done := true; genaddr(rhs,lhs) end;
	    freeregs(lhs^.attr);
	    end; { addr }
	if not done then
	  if lhs^.etyptr^.form = power then
	    begin
	    { set up external routine for unequal size sets }
	    if RANGECHECK then
$if bigsets$
		  begin
			pushlongword(lhs^.etyptr^.setmax);
			pushlongword(lhs^.etyptr^.setmin);
		  end;
$end$
$if not bigsets$
		  begin
		    pushword(lhs^.etyptr^.setmax);
		    pushword(lhs^.etyptr^.setmin);
		  end;
$end$
	    pushaddress(lhs) ; pushaddress(rhs);
	    if RANGECHECK then
$if bigsets$
	      callstdproc('ASM_XSETASSIGN')
$end$
$if not bigsets$
	      callstdproc('ASM_SETASSIGN')
$end$
	    else
	      callstdproc('ASM_ASSIGN');
	    clear(false);
	    end
	  else if lhs^.eclass = substrnode then
	    substrassign(rhs,lhs)
	  else if strgtype(lhs^.etyptr) then
	    stringassign(rhs,lhs)
	  else
	    begin
	    { Order is important on these genexprs }
	    if RANGECHECK then
	      begin genexpr(lhs); genexpr(rhs); end
	    else
	      begin genexpr(rhs); genexpr(lhs); end;
	    if (lhs^.etyptr^.form = prok) and (rhs^.ekind = cnst) then
	      begin
	      makeaddressable(lhs);
	      lhs^.attr^.storage := long;
	      if isoverlay(rhs^.symptr,getaddress) then { OVERLAY MODULE }
		emit2(move,SPplus,lhs^.attr^)
	      else
		moveaddress(rhs,lhs^.attr^);
	      with lhs^.attr^ do
		begin
		offset := offset+4;
		with rhs^.symptr^ do
		  if pflev > 1 then movestatic(pflev,lhs^.attr^)
		  else emit1(clr,lhs^.attr^);
		offset := offset-4;
		freeregs(lhs^.attr);
		end;
	      end
	    else if paofchar(lhs^.etyptr) then
	      movemulti(rhs,lhs,lhs^.etyptr^.unpacksize)
	    else if rhs^.attr^.addrmode = inFreg then
	      begin
	      makeaddressable(lhs);
	      moverealvalue(rhs,lhs^.attr^);
	      freeregs(lhs^.attr);
	      end
	    else if lhs^.etyptr^.form = cnfarrays then
	      cnfassign(lhs,rhs)
	    else if lhs^.attr^.storage = multi then
	      movemulti(rhs,lhs,
		   min(lhs^.etyptr^.unpacksize, rhs^.etyptr^.unpacksize) )
	    else genassign(lhs,rhs);
	    end; { not power }
      end {with}
      end; {genbecomes}

    procedure genspecialfor(curstmt: stptr; var done: boolean);
      var
	lab: addrrange;
	op: attrtype;
      begin
      done := true;
      with curstmt^ do
	begin
	genexpr(init);
	genexpr(limit);
	if ((incr=1) and
	  (init^.litval.ival>limit^.litval.ival))
	  or
	  ((incr=-1) and
	  (init^.litval.ival<limit^.litval.ival)) then
	  done := false;
	if done then {this is a special FOR stmt}
	  with ctrl^.attr^ do
	    begin
	    init^.attr^.smallval := init^.attr^.smallval - incr;
	    fixliteral(init,storage,signbit);
	    fixliteral(limit,storage,signbit);

	    genassign(ctrl,init);

	    lab := codephile.bytecount;
	    with op do
	      begin addrmode := immediate; smallval := 1; end;
	    if incr = 1 then emit2(addq,op,ctrl^.attr^)  { ADDQ #1,ctrl }
			else emit2(subq,op,ctrl^.attr^); { SUBQ #1,ctrl }
	    clear(false);
	    gencode(fbody);
	    emit2(cmpi,limit^.attr^,ctrl^.attr^);    { CMPI limit,cntrl }
	    { calculate pc relative jump to lab }
	    getbrattr(lab,true,op);
	    if signbit then
	      if incr = 1 then emit1(blt,op)        { Bcc lab }
			  else emit1(bgt,op)
	    else {unsigned test}
	      if incr = 1 then emit1(bcs,op)
			  else emit1(bhi,op);
	    end; { with ctrl^.attr^ }
	end; { with curstmt^ }
      end; { genspecial for }

    procedure genfor (curstmt : stptr);
      var
	op,opp: attrtype;
	min,max: integer;
	lab1,limitoffset : addrrange;
	lab2ref : localref;
	r : regrange;
	done,trangecheck : boolean;
	savestorage : stortype;
      begin
	with curstmt^ do
	  begin
	  genexpr(ctrl);
	  done := false;
	  if (limit^.eclass = litnode) and (init^.eclass = litnode) then
	    genspecialfor(curstmt,done);
	  { check done flag to see if genspecialfor generated code }
	  if not done then with ctrl^.attr^ do
	    begin
	    makeaddressable(init);
	    if init^.eclass = litnode then fixliteral(init,storage,signbit);
	    loadvalue(init);
	    makeaddressable(limit);
	    if limit^.eclass = litnode then fixliteral(limit,storage,signbit);

	    if init^.attr^.storage < storage then extend(init,storage);
	    if (not init^.attr^.signbit) and (init^.attr^.storage = wrd) then
	      extend(init,long);
	    if limit^.attr^.storage < init^.attr^.storage then
	      extend(limit,init^.attr^.storage);
	    if (not limit^.attr^.signbit) and (limit^.attr^.storage = wrd) then
	      extend(limit,long);
	    if init^.attr^.storage < limit^.attr^.storage then
	      extend(init,limit^.attr^.storage);

	    if limit^.eclass <> litnode then
	      begin
	      op.storage := limit^.attr^.storage;
	      case op.storage of
		bytte: getlocstorage(1,op);
		wrd: getlocstorage(2,op);
		long: getlocstorage(4,op);
	      end;
	      emit2(move,limit^.attr^,op);
	      if limit^.attr^.addrmode <> inDreg then
		with limit^.attr^ do
		  begin
		  addrmode := locinreg;
		  indexed := false;
		  packd := false;
		  access := direct;
		  offset := op.offset;
		  regnum := op.regnum;
		  gloptr := op.gloptr;
		  end;
	      end;

	    lab2ref.next := NIL;

	    if RANGECHECK then
	      if needscheck(init,ctrl^.etyptr,true) or
		 needscheck(limit,ctrl^.etyptr,true) then
		begin
		if limit^.eclass = litnode then
		  emit2(cmpi,limit^.attr^,init^.attr^)
		else
		  emit2(cmp,op,init^.attr^);             { CMP   temp,initregnum }

		{ branch corresponding to increment }
		new(lab2ref.next);
		lab2ref.next^.next := nil;
		getbrattr(lab2ref.next^.pc,false,opp);
		if limit^.attr^.signbit then
		  if incr = 1 then emit1(bgt,opp)         { Bcc lab2 }
			      else emit1(blt,opp)
		else
		  if incr = 1 then emit1(bhi,opp)
			      else emit1(bcs,opp);
		getbounds(ctrl^.etyptr,min,max);
		if (min = 0) and ((max > 32768) or
		   (init^.attr^.storage = long)) then
		  emit1(tst,init^.attr^);
		savestorage := init^.attr^.storage;
		emitcheck(init,ctrl^.etyptr,true);
		init^.attr^.storage := savestorage;

		if (min = 0) and (limit^.attr^.storage = long) and
		   (limit^.attr^.addrmode = inDreg) then
		  emit1(tst,limit^.attr^);
		emitcheck(limit,ctrl^.etyptr,true);
		limit^.attr^.storage := savestorage;
		end;

	    lab1 := codephile.bytecount;
	    if limit^.eclass = litnode then
	      emit2(cmpi,limit^.attr^,init^.attr^)
	    else
	      emit2(cmp,op,init^.attr^);             { CMP   temp,initregnum }

	    { branch corresponding to increment }
	    getbrattr(lab2ref.pc,false,op);
	    if limit^.attr^.signbit then
	      if incr = 1 then emit1(bgt,op)         { Bcc lab2 }
			  else emit1(blt,op)
	    else
	      if incr = 1 then emit1(bhi,op)
			  else emit1(bcs,op);

	    trangecheck := RANGECHECK;
	    RANGECHECK := false;
	    genassign(ctrl,init);
	    RANGECHECK := trangecheck;

	    clear(false);
	    gencode(fbody);    { emit FOR body }
	    {insure that init^.attr^.regnum is the next register to be used}
	    repeat r := getreg(D);
	    until r = init^.attr^.regnum;
	    freeit(D,r);
	    if storage < limit^.attr^.storage then
	      extend(ctrl,limit^.attr^.storage);
	    loadvalue(ctrl);

	    with op do
	      begin addrmode := immediate; smallval := 1; end;
	    if incr = 1 then emit2(addq,op,ctrl^.attr^)
			else emit2(subq,op,ctrl^.attr^);

	    getbrattr(lab1,true,op);
	    if not signbit then emit1(bcc,op)        { Bcc lab }
			   else emit1(bvc,op);
	    { lab2 }
	    fixreflist(addr(lab2ref));
	    end; { with ctrl^.attr^ }
	  end; { with curstmt^ }
	clear(false);
      end; { genfor }

procedure genproc(psymptr: ctp; actualp: elistptr);
  var
    lexp,source,dest,length,letter: exptr;
    checkstp: stp;
    packunpackcount : integer;
    datatype,pname: string[9];
    testptr,parmptr: elistptr;
    packing,extending,formatting,checking,
      isenumtype,isstrgtype,ispaoc,mustinit,
      newesccode,iseolproc,iswrite: boolean;
    op1,op2: attrtype;
    filestorage: stortype;
    destmax,lobound,hibound: integer;
    sizeofpaoc: shortint;


  procedure pushwidth(parmptr: elistptr);
    begin
    with parmptr^ do
      if expptr=NIL then
	pushword(-1)
      else
	begin
	if rangecheck and
	   ((expptr^.eclass <> litnode) or not expptr^.litval.intval) then
	  emitcheck(expptr,char_ptr,true);
	extend(expptr,wrd);
	pushvalue(expptr);
	end;
    end;

  procedure pushstring(fexp: exptr);
    begin
    if strgtype(fexp^.etyptr) then
      pushaddress(fexp)
    else
      begin
      { 255 is an arbitrary number so that
	an excessive amount of temp space
	is not used }
      sizeofpaoc := min(255,fexp^.etyptr^.unpacksize);
      getlocstorage(sizeofpaoc+1,op1);
      with op2 do
	begin
	addrmode := immediate;
	smallval := sizeofpaoc;
	end;
      op1.storage := bytte;
      emit2(move,op2,op1);
      emit1(pea,op1);
      pushaddress(fexp);
      op1.offset := op1.offset + 1;
      emit1(pea,op1);
      SPminus.storage := long;
      emit2(move,op2,Spminus);
      clear(false);
      callstdproc('ASM_MOVEL');
      op1.offset := op1.offset - 1;
      emit1(pea,op1);
      emit1(pea,op1);
      callstdproc('ASM_STRRTRIM');
      end;
    end;

  begin {genproc}
  with psymptr^ do
    if klass = routineparm then
      callvar(psymptr^.proktype^.params,actualp,false)
    else if pfdeckind = declared then
      begin pushparms(next,actualp);
      if pflev > 1 then
	begin SPminus.storage := long;
	movestatic(pflev,SPminus);
	end;
      if not isoverlay(psymptr,gencall) then
	begin
	getprokconst(psymptr,op1);
	emit1(jsr,op1);
	end;
      clear(false);
      end
    else
      case spkey of
	spsetstrlen:
	  begin dest := actualp^.expptr;
	  source := actualp^.nextptr^.expptr;
	  makeaddressable(source);
	  genexpr(dest);
	  if rangecheck then
	    begin destmax := dest^.etyptr^.maxleng;
	    checking := true;
	    if dest^.etyptr=strgptr then
	      begin  {var string}
	      with dest^.attr^ do
		begin access := direct;
		storage := bytte;
		signbit := false;
		offset := offset+4;
		end;
	      if source^.eclass = litnode then
		fixliteral(source,bytte,true);
	      if source^.attr^.storage>bytte then
		extend(dest,source^.attr^.storage);
	      loadvalue(source);
	      if (source^.attr^.storage=bytte) and
		 (source^.attr^.signbit) then
		begin
		with op1 do
		  begin offset := 6; storage := bytte end;
		emit1(blt,op1);
		end;
	      emit2(cmp,dest^.attr^,source^.attr^);
	      dest^.attr := NIL;
	      end
	    else if source^.attr^.addrmode <> immediate then
	      begin   {not var string}
	      with op1 do
		begin addrmode := immediate;
		smallval := destmax;
		end;
	      with source^, attr^ do
		if addrmode = topofstack then
		  begin
		  SPind.storage := storage;
		  emit2(cmpi,op1,SPind);
		  end
		else
		  emit2(cmpi,op1,attr^);
	      end
	    else checking := false;
	    if checking then
	      begin
	      with op1 do
		begin offset := 2; storage := bytte end;
	      emit1(bls,op1);
	      op1.smallval := 7;
	      emit1(trap,op1);
	      end;
	    end; {rangecheck}
	  makeaddressable(dest);
	  dest^.attr^.storage := bytte;
	  extend(source,bytte);
	  emit2(move,source^.attr^,dest^.attr^);
	  freeregs(source^.attr);
	  freeregs(dest^.attr);
	  end;
	spseek:
	  begin pushaddress(actualp^.expptr);
	  with actualp^.nextptr^ do
	    begin extend(expptr,long);
	    pushvalue(expptr);
	    end;
	  callIOproc('FS_FSEEK');
	  clear(false);
	  end;
	sppage:
	  begin
	  pushaddress(actualp^.expptr);
	  callIOproc('FS_FPAGE');
	  clear(false);
	  end;
	spclose:
	  with actualp^ do
	    begin
	    pushaddress(expptr);
	    pushstring(nextptr^.expptr);
	    callIOproc('FS_FCLOSEIT');
	    clear(false);
	    end;
	spgotoxy:
	  with actualp^ do
	    begin
	    pushaddress(expptr);
	    extend(nextptr^.expptr,long);
	    pushvalue(nextptr^.expptr);
	    extend(nextptr^.nextptr^.expptr,long);
	    pushvalue(nextptr^.nextptr^.expptr);
	    callstdproc('FS_FGOTOXY');
	    clear(false);
	    end;
	spunitwait,spunitclear,spget,
	spput,spnewwords,
	spdelete,spstrdelete,spstrappend,
	spinsert,spstrinsert:
	  begin
	  pushparms(next,actualp);
	  if (spkey>=spstrdelete)
	     and (spkey<=spstrappend) or
	     (spkey = spdelete) or
	     (spkey = spinsert) then
	    case spkey of
	      spdelete,
	      spstrdelete:
		callstdproc('ASM_DELETE');
	      spinsert,
	      spstrinsert:
		callstdproc('ASM_INSERT');
	      spstrappend:
		callstdproc('ASM_SAPPEND');
	      end
	  else
	    if (spkey=spget) or (spkey=spput) then
	      callIOproc('FS_F' + psymptr^.namep^)
	  else
	    case spkey of
	      spunitwait,
	      spunitclear:
		callstdproc('UIO_' + psymptr^.namep^);
	      spnewwords:
		callstdproc('ASM_NEWWORDS');
	    end;
	  clear(false);
	  end;
	spnew:
	  with actualp^ do
	    begin
	    pushaddress(expptr);
	    mustinit := mustinitialize in
		    expptr^.etyptr^.eltype^.info;
	    if mustinit then
	      begin
	      getlocstorage(ptrsize,op1);
	      op1.storage := long;
	      emit2(move,SPind,op1);
	      end;
	    pushvalue(nextptr^.expptr);
	    if heapdispose then
	      callstdproc('HPM_NEW')
	    else
	      callstdproc('ASM_NEWBYTES');
	    clear(false);
	    if mustinit then
	      begin
	      op2 := op1;
	      op1.access := indirect;
	      expptr^.attr := addr(op1);
	      loadaddress(expptr,false);
	      expptr^.attr^.access := indirect;
	      moveaddress(expptr,op2);
	      op2.access := indirect;
	      expptr^.attr := addr(op2);
	      initlocvar(NIL,expptr,0,expptr^.etyptr^.eltype,isnew);
	      clear(false);
	      end;
	    end;
	spdispose:
	  with actualp^ do
	    begin
	    makeaddressable(expptr);
	    mustinit := mustinitialize in
		expptr^.etyptr^.eltype^.info;
	    if mustinit then
	      begin
	      getlocstorage(ptrsize,op1);
	      op1.storage := long;
	      emit2(move,expptr^.attr^,op1);
	      end;
	    if heapdispose then
	      begin
	      pushaddress(expptr);
	      pushvalue(nextptr^.expptr);
	      callstdproc('HPM_DISPOSE');
	      clear(false);
	      end
	    else
	      begin
	      emit1(clr,expptr^.attr^);
	      freeregs(expptr^.attr);
	      end;
	    if mustinit then
	      begin
	      op1.access := indirect;
	      expptr^.attr := addr(op1);
	      initlocvar(NIL,expptr,0,expptr^.etyptr^.eltype,isdispose);
	      clear(false);
	      end;
	    end;
	spmark:
	  begin
	  makeaddressable(actualp^.expptr);
	  if heapdispose then
	    begin
	    pushaddress(actualp^.expptr);
	    callstdproc('HPM_MARK');
	    clear(false);
	    end
	  else
	    begin
	    SBind.offset := heapptrdisp;
	    SBind.gloptr := sysglobalptr;
	    emit2(move,SBind,actualp^.expptr^.attr^);
	    SBind.gloptr := NIL;
	    end;
	  end;
	sprelease:
	  begin
	  makeaddressable(actualp^.expptr);
	  if heapdispose then
	    begin
	    pushvalue(actualp^.expptr);
	    callstdproc('HPM_RELEASE');
	    clear(false);
	    end
	  else
	    begin
	    SBind.offset := heapptrdisp;
	    SBind.storage := long;
	    SBind.gloptr := sysglobalptr;
	    emit2(move,actualp^.expptr^.attr^,SBind);
	    SBind.gloptr := NIL;
	    end;
	  end;
	spwrite,spwriteln,spwritedir,spstrwrite,
	spprompt,spread,spreadln,spreaddir,
	spstrread,spoverprint:
	  begin
	  source := actualp^.expptr;
	  iseolproc := (spkey = spreadln) or
		       (spkey = spwriteln) or
		       (spkey = spoverprint);
	  iswrite := spkey in
		   [spwritedir,spwriteln,spwrite,
		   spstrwrite,spprompt,spoverprint];
	  if iswrite then pname := 'WRITE'
	  else pname := 'READ';
	  formatting := (source^.etyptr = textptr) or
			(spkey = spstrread) or
			(spkey = spstrwrite);
	  if not formatting then
	    begin datatype := '';
	    filestorage :=
	      getstorageinfo(source^.etyptr^.filtype);
	    end;
	  if spkey = spstrwrite then
	    pushvarstring(source)
	  else pushaddress(source);
	  parmptr := actualp^.nextptr;
	  if (spkey = spreaddir)
	      or (spkey = spwritedir) then
	    begin {first seek desired record}
	    SPminus.storage := long;
	    emit2(move,SPind,SPminus);
	    extend(parmptr^.expptr,long);
	    pushvalue(parmptr^.expptr);
	    callIOproc('FS_FSEEK');
	    clear(false);
	    parmptr := parmptr^.nextptr;
	    end
	  else if (spkey = spstrwrite) or
		  (spkey = spstrread) then
	    with parmptr^ do
	      begin
	      if not branchmatch
		    (expptr,nextptr^.expptr) then
		begin extend(expptr,long);
		loadaddress(nextptr^.expptr,false);
		movevalue(expptr,nextptr^.expptr^.attr^);
		end;
	      pushaddress(nextptr^.expptr);
	      parmptr := nextptr^.nextptr;
	      end;

	  while parmptr<>NIL do {process params}
	    with parmptr^,expptr^ do
	      begin
	      checking := false;
	      if not ISWRITE then
		begin checkstp := etyptr;
		if etyptr^.form = subrange then
		  etyptr := etyptr^.rangetype;
		end;
	      SPminus.storage := long;
	      if iseolproc then emit2(move,SPind,SPminus)
	      else if ISWRITE then
		begin {last value?}
		if not formatting then
		  testptr := parmptr^.nextptr
		else
		  begin testptr := parmptr^.nextptr^.nextptr;
		  if etyptr = realptr then
		    testptr := testptr^.nextptr;
		  end;
		if testptr <> NIL then
		  if (spkey <> spstrwrite) and
		     (spkey <> spstrread) then
		    emit2(move,SPind,SPminus)
		  else
		    begin {copy var string}
		    op2 := SPind;
		    op2.offset := 8;
		    SPminus.storage := wrd;
		    emit2(move,op2,SPminus);
		    SPminus.storage := long;
		    op2.offset := 6;
		    emit2(move,op2,SPminus);
		    emit2(move,op2,SPminus);
		    end;
		end
	      else  {READ, etc}
		if parmptr^.nextptr <> NIL then
		  if spkey <> spstrread then
		    emit2(move,SPind,SPminus)
		  else
		    begin op2 := SPind;
		    op2.offset := 4;
		    emit2(move,op2,SPminus);
		    emit2(move,op2,SPminus);
		    end;
	      isenumtype := enumtype(etyptr);
	      isstrgtype := strgtype(etyptr);
	      ispaoc := paofchar(etyptr) and not isstrgtype;

	      if ISWRITE then
		begin packing := false;
		extending := false;
		makeaddressable(expptr); {allocate attr record}
		if formatting then
		  begin
		  if ((etyptr=intptr) or
		      (etyptr=shortintptr)) and
		     ((attr^.storage=bytte) or
		      not(attr^.signbit)) then
		    if attr^.storage <> long then
		      extend(expptr,succ(attr^.storage));
		  if (etyptr=intptr) or
		     (etyptr=shortintptr) then
		    pushvalue(expptr)
		  else if isenumtype then
		    begin
		    extend(expptr,wrd);
		    pushvalue(expptr);
		    end
		  else if (etyptr=char_ptr) or
		      (etyptr=boolptr) then
		    begin
		    extend(expptr,bytte);
		    if etyptr=boolptr then
		      maskboolexpr(expptr);
		    pushvalue(expptr);
		    end
		  else if etyptr=realptr then
		    pushaddress(expptr)
		  else
		    begin {strg,paoc}
		    pushaddress(expptr);
		    if not isstrgtype then
		      pushword(etyptr^.unpacksize);
		    end;
		  {process width specification}
		  parmptr := parmptr^.nextptr;
		  pushwidth(parmptr);
		  if etyptr = realptr then
		    begin
		    parmptr := parmptr^.nextptr;
		    pushwidth(parmptr);
		    end;
		  end  {formatting}
		else
		  begin {binary write}
		  if rangecheck then
		    emitcheck(expptr,source^.etyptr^.filtype,true);
		  extend(expptr,filestorage);
		  if not (attr^.addrmode in memorymodes)  then
		    begin
		    new(lexp);
		    lexp^ := expptr^;
		    getattrec(lexp);
		    getlocstorage(source^.etyptr^.filtype^.unpacksize,
				lexp^.attr^);
		    lexp^.attr^.storage := filestorage;
		    movevalue(expptr,lexp^.attr^);
		    pushaddress(lexp);
		    end
		  else pushaddress(expptr);
		  end;{binary write}
		end {ISWRITE}
	      else {READ,readln,readdir,strread}
		begin
		genexpr(expptr);
		packing := attr^.packd;
		if formatting then
		  extending :=
		    getstorageinfo(etyptr) <> attr^.storage
		else
		  extending :=
		    (filestorage <> attr^.storage) or
		    isstrgtype;
		if packing or extending then
		  begin
		  saveregs;
		  new(lexp);
		  lexp^ := expptr^;
		  getattrec(lexp);
		  if extending and not formatting then
		    begin
		    getlocstorage(source^.etyptr^.
			  filtype^.unpacksize,lexp^.attr^);
		    lexp^.attr^.storage := filestorage;
		    lexp^.eclass := idnode;
		    lexp^.symptr := NIL;
		    end
		  else
		    begin
		    getlocstorage(etyptr^.unpacksize,
					  lexp^.attr^);
		    lexp^.attr^.storage := getstorageinfo(etyptr);
		    end;
		  pushaddress(lexp);
		  end
		else if formatting and isstrgtype then
		  pushvarstring(expptr)
		else
		  begin
		  if RANGECHECK then
		    if needscheck(expptr,checkstp,true) then
		      begin
		      checking := true;
		      loadaddress(expptr,false);
		      saveregs;
		      SPminus.storage := long;
		      attr^.addrmode := inAreg;
		      emit2(move,attr^,SPminus);
		      attr^.addrmode := locinreg;
		      end
		    else pushaddress(expptr)
		  else pushaddress(expptr);
		  if formatting then
		    if ispaoc then
		      pushword(etyptr^.unpacksize);
		  end;
		end; {READ etc.}
	      if isenumtype and formatting then
		with op1 do
		  begin addrmode := enumconst;
		  offset := 0;
		  enumstp := etyptr;
		  poolenum(etyptr);
		  emit1(pea,op1);
		  end;
	      if formatting then
		if etyptr = char_ptr then datatype := 'CHAR'
		else if etyptr = boolptr then datatype := 'BOOL'
		else if etyptr = realptr then datatype := 'REAL'
		else if isenumtype then datatype := 'ENUM'
		else if isstrgtype then datatype := 'STR'
		else if ispaoc then datatype := 'PAOC'
		else { int, shortint }
		  if ISWRITE then
		    if attr^.storage = wrd then
		      datatype := 'WORD'
		    else datatype := 'INT'
		  else { reading }
		    if etyptr = shortintptr then
		      datatype := 'WORD'
		    else datatype := 'INT';
	      if (spkey = spstrwrite) or
		 (spkey = spstrread) then
		datatype := 'STR' + datatype;
	      if (etyptr = realptr) and formatting then
		callIOproc('MFS_F' + pname + datatype)
	      else callIOproc('FS_F' + pname + datatype);
	      if packing or extending then
		begin reloadregs;
		if rangecheck then
		  emitcheck(lexp,checkstp,true);
		if packing then pack(expptr,lexp)
		else
		  begin
		  makeaddressable(expptr);
		  if isstrgtype then
		    stringassign(lexp,expptr)
		  else
		    begin
		    extend(lexp,attr^.storage);
		    movevalue(lexp,attr^);
		    freeregs(attr);
		    end;
		  end;
		end
	      else if checking then
		begin
		reloadregs;
		emitcheck(expptr,checkstp,true);
		end;
	      clear(false);
	      parmptr := parmptr^.nextptr;
	      end; {while parmptr<>NIL...}

	  if iseolproc then
	    begin
	    if spkey=spreadln then pname := 'READLN'
	    else if spkey=spwriteln then pname := 'WRITELN'
	    else pname := 'OVERPRINT';
	    callIOproc('FS_F' + pname);
	    clear(false);
	    end;
	  end;
	spcall:
	  callvar(actualp^.expptr^.etyptr^.params,
		  actualp,false);
	spescape:
	  with actualp^,expptr^ do
	    begin newesccode := true;
	    if eclass = fcallnode then
	      if fptr^.pfdeckind <> declared then
		if fptr^.spkey = spesccode then newesccode := false;
	    if newesccode then {  not 'escape(escapecode)'  }
	      begin
	      if rangecheck then
		emitcheck(expptr,shortintptr,true);
	      extend(expptr,wrd);
	      makeaddressable(expptr);
	      SBind.storage := wrd;
	      SBind.offset := escapecodedisp;
	      SBind.gloptr := sysglobalptr;
	      emit2(move,attr^,SBind);
	      SBind.gloptr := NIL;
	      end;
	    op1.smallval := 10;
	    emit1(trap,op1);
	    end;
	sphalt:
	  begin
	  SBind.storage := wrd;
	  SBind.offset := escapecodedisp;
	  SBind.gloptr := sysglobalptr;
	  if actualp <> NIL then
	    with actualp^, expptr^ do
	      begin
	      if rangecheck then
		emitcheck(expptr,shortintptr,true);
	      extend(expptr,wrd);
	      makeaddressable(expptr);
	      emit2(move,attr^,SBind);
	      end
	  else
	    emit1(clr,SBind);
	  op1.smallval := 10;
	  emit1(trap,op1);
	  SBind.gloptr := NIL;
	  end;
	spfillchar:
	  begin
	  with actualp^ do
	    begin dest := expptr;
	    length := nextptr^.expptr;
	    letter := nextptr^.nextptr^.expptr;
	    end;
	  loadaddress(dest,false); {  dest addr  }
	  loadvalue(letter); {  char  }
	  loadvalue(length);
	  op1.storage := bytte;
	  op1.offset := 6;
	  emit1(ble,op1);                         { BLE.S *+8 }
	  with dest^.attr^ do
	    begin addrmode := postincr; storage := bytte; end;
	  emit2(move,letter^.attr^,dest^.attr^);  { MOVE.B letter,<dest> }
	  with op1 do
	    begin addrmode := immediate; smallval := 1; end;
	  emit2(subq,op1,length^.attr^);          { SUBQ #1,length }
	  op1.offset := -6;
	  op1.storage := bytte;
	  emit1(bgt,op1);                         { BGT.S *-4 }
	  clear(false); { register contents will be invalid }
	  end; {fillchar}
	spmoveleft, spmoveright:
	  begin
	  with actualp^ do
	    begin
	    source := expptr;
	    dest   := nextptr^.expptr;
	    length := nextptr^.nextptr^.expptr;
	    end;
	  pushaddress(source);
	  pushaddress(dest);
	  extend(length,long);
	  pushvalue(length);
	  clear(false); { register contents will be invalid }
	  if spkey = spmoveright then
	    callstdproc('ASM_MOVER')
	  else
	    callstdproc('ASM_MOVEL');
	  end; { moveleft, moveright }
	sprewrite,spreset,spopen,spappend:
	  begin
	  pushaddress(actualp^.expptr);     {file}
	  parmptr := actualp^.nextptr;
	  with op1 do
	    begin
	    addrmode := immediate;
	    smallval := ord(spkey)-ord(spreset);
	    end;
	  SPminus.storage := wrd;
	  emit2(move,op1,SPminus);
	  if parmptr = NIL then
	    callIOproc('FS_FHPRESET')
	  else
	    begin
	    pushstring(parmptr^.expptr);
	    pushstring(parmptr^.nextptr^.expptr);
	    callIOproc('FS_FHPOPEN');
	    end;
	  clear(false);
	  end;
	spunitread,spunitwrite:
	  begin extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {unit number}
	  actualp:=actualp^.nextptr; pushaddress(actualp^.expptr);
							   {buffer}
	  actualp:=actualp^.nextptr; extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {length}
	  actualp:=actualp^.nextptr; extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {blocknumber}
	  actualp:=actualp^.nextptr; extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {async}
	  if spkey = spunitread then
	     callstdproc('UIO_UNITREAD')
	  else callstdproc('UIO_UNITWRITE');
	  clear(false);
	  end;
	sppack,spunpack:
	  with actualp^ do
	    begin
	    op1.addrmode := immediate;
	    getbounds(nextptr^.expptr^.etyptr^.inxtype,lobound,hibound);
	    packunpackcount := hibound - lobound + 1; {Z array bounds}
	    if RANGECHECK and (expptr^.indxp^.eclass <> litnode) then
	      { Check array subscript < lower bound and
		array subscript + count > upper bound }
	      begin
	      getbounds(expptr^.arayp^.etyptr^.inxtype,lobound,hibound);
	      new(checkstp);
	      with checkstp^ do
		begin
		form := subrange;
		min := lobound;
		max := hibound - packunpackcount + 1;
		end;
	      emitcheck(expptr^.indxp,checkstp,false);
	      end;
	    if spkey = spunpack then { push boolean, signed or unsigned }
	      begin
	      if nextptr^.expptr^.etyptr^.aeltype^.signbit then
		op1.smallval := 1
	      else op1.smallval := 0;
	      SPminus.storage := bytte;
	      emit2(move,op1,SPminus);    {move.b 1/0, -(SP) }
	      end;
	    op1.smallval := expptr^.arayp^.etyptr^.aelsize;
	    checking := RANGECHECK;
	    RANGECHECK := false;     { already range checked subscript }
	    pushaddress(expptr);          {address of A[i] }
	    RANGECHECK := checking;
	    pushaddress(nextptr^.expptr); {address of Z }
	    SPminus.storage := wrd;
	    emit2(move,op1,SPminus);      {move.w unpacksize,-(SP) }
	    op1.smallval := nextptr^.expptr^.etyptr^.aelbitsize;
	    emit2(move,op1,SPminus);      {move.w fieldwidth,-(SP) }
	    op1.smallval := packunpackcount;
	    SPminus.storage := long;
	    emit2(move,op1,SPminus);      {move.l count,-(SP) }
	    if spkey = sppack then
	      callstdproc('ASM_PACK')
	    else callstdproc('ASM_UNPACK');
	    clear(false);
	    end;
	otherwise escape(-8);
	end; {case}
  end; {genproc}

procedure gencase(curstmt:stptr);
  label 1;
  const
    bigcase = 256; bigcasestr = '256';
    warnthresh = 100; warnfactor = 2;
  var
    otherref1,otherref2: localref;
    lnomatch,lout,ljmptab:   addrrange;
    exitcaserefs,otherlist,p: reflistptr;
    stmt,nextstmt:           stptr;
    curclabp:                clabptr;
    i:                       integer;
    minval,maxval,maxrefs,
    tablesize,nomatchrefs:   integer;
    holes,unsignedselecter:  boolean;
    op1,op2:                 attrtype;

  procedure assigncasentry ( var list: reflistptr );
    { assign the current case table entry to the "list" }
    var
      p: reflistptr;
    begin
      new(p);
      with p^ do
	begin
	pc := codephile.bytecount;
	next := list;
	list := p;
	end;
    end;

  procedure checkcase(at: attrptr; i: integer);
    { Check the case selecter in "at" to make sure
      it is less than or equal to "i" }
    var
      op: attrtype;
      p : reflistptr;
    begin
      if RANGECHECK then
	begin
	new(p);
	p^.next := NIL;
	getbrattr(p^.pc,false,op);
	emit1(blt,op);
	with op do
	  begin addrmode := immediate; smallval := i; end;
	emit2(cmpi,op,at^);
	with op do
	  begin offset := 2; storage := bytte end;
	emit1(ble,op);
	op.smallval := 6;
	fixreflist(p);
	emit1(trap,op);                   { TRAP #6 }
	end; { else }
    end;

  begin { gencase }
    with curstmt^ do
      begin
      makeaddressable(selecter);
      maskboolexpr(selecter);
      with selecter^.attr^ do
	begin
	if storage = bytte then extend(selecter,wrd)
	else if not signbit and (otherwyse = NIL) and (minval <> 0) then
	  extend(selecter,long);
	loadvalue(selecter);
	end;
      otherlist := NIL;
      exitcaserefs := NIL;
      holes := false;
      if minlab <> NIL then begin
	minval := minlab^.lowval;
	maxval := maxlab^.hival;
	$RANGE ON$
	  try
	    tablesize := maxval-minval+1;
	    if tablesize > bigcase then
	      warning(linenum,'case table contains more than ' + bigcasestr +
			      ' entries');
	  recover
	    if escapecode = -4 { integer overflow } then
	      begin
	      error(679);
	      goto 1;
	      end
	    else
	      escape(escapecode);
	$IF not rangechecking$
	  $RANGE OFF$
	$END$
	if minval <> 0 then    {normalize}
	  with op1 do
	    begin
	    addrmode := immediate; smallval := minval;
	    emit2(sub,op1,selecter^.attr^);
	    end;

	{ check minval<=selecter<=maxval }
	with op1 do
	  begin addrmode := immediate; smallval := maxval-minval; end;
	if (otherwyse = NIL) then checkcase(selecter^.attr,op1.smallval)
	else
	  begin
	  unsignedselecter := not selecter^.attr^.signbit;
	  otherref1.next := NIL;
	  getbrattr(otherref1.pc,false,op2);
	  if unsignedselecter then emit1(bcs,op2)        { BLT otherwise }
			      else emit1(blt,op2);
	  emit2(cmp,op1,selecter^.attr^);                { CMP #max,select }
	  otherref2.next := NIL;
	  getbrattr(otherref2.pc,false,op2);
	  if unsignedselecter then emit1(bhi,op2)        { BGT otherwise }
			      else emit1(bgt,op2);
	  end;
	$IF not MC68020$
	with op1 do
	  begin addrmode := immediate; smallval := 1; end;
	emit2(asl,op1,selecter^.attr^);                  { ASL #1,select }
	$END$
	with op1 do
	  begin
	  addrmode := prel; offset := 6; indexed := true;
	  indexreg := selecter^.attr^.regnum; indexstorage := wrd;
	  $IF MC68020$
	    indexscale := 1;
	  $END$
	  end;
	getregattr(D,op2);
	op2.storage := wrd;
	emit2(move,op1,op2);
	freeit(D,selecter^.attr^.regnum);
	with op1 do
	  begin
	  offset := 2;
	  indexreg := op2.regnum;
	  $IF MC68020$
	  indexscale := 0;
	  $END$
	  end;
	emit1(jmp,op1);            { emit indexed jump into table }
	freeit(D,op1.indexreg);

	{ initialize the list of table refs for each case stmt }
	stmt := firstmt;
	while stmt <> NIL do
	  with stmt^ do
	    begin tablelist := NIL; stmt := next; refcount := 0 end;

	{ emit jump table }
	ljmptab := codephile.bytecount;
	curclabp := minlab; i := minval; nomatchrefs := 0;
	while curclabp <> NIL do
	  begin
	  with curclabp^ do
	    begin
	    while i <= hival do
	      with cstmt^ do
		begin
		assigncasentry(tablelist);
		outputcodeword(codephile.bytecount - ljmptab);
		refcount := refcount+1;
		i := i+1;
		end;
	    curclabp := clabp;
	    end;
	  if curclabp <> NIL then
	    with curclabp^ do
	      while i < lowval do
		begin
		assigncasentry(otherlist);
		outputcodeword(codephile.bytecount - ljmptab);
		nomatchrefs := nomatchrefs+1;
		holes := true;
		i := i+1;
		end;
	  end; { while curclabp <> NIL }
	  releaseattr;

	{generate code for cases}
	with firstmt^ do
	  begin
	  fixreflist(tablelist);
	  maxrefs := refcount;
	  nextstmt := next;
	  next := NIL;
	  end;
	gencode(firstmt);
	stmt := nextstmt;
	while stmt <> NIL do
	  begin
	  new(p);
	  getbrattr(p^.pc,false,op1);
	  p^.next := exitcaserefs;
	  exitcaserefs := p;
	  emit1(bra,op1);                       { BRA out of case }
	  with stmt^ do
	    begin
	    fixreflist(tablelist);
	    nextstmt := next;
	    next := NIL;
	    clear(false);
	    if maxrefs < refcount then maxrefs := refcount;
	    end;
	  gencode(stmt);
	  stmt := nextstmt;
	  end;
	end; {if minlab <> NIL}
      if holes or (otherwyse <> NIL) then
	begin
	new(p);
	getbrattr(p^.pc,false,op1);
	p^.next := exitcaserefs;
	exitcaserefs := p;
	emit1(bra,op1);                       { BRA out of case }
	if holes and (otherlist <> NIL) then fixreflist(otherlist);
	if otherwyse <> NIL then
	  begin
	  clear(false);
	  fixreflist(addr(otherref1));
	  fixreflist(addr(otherref2));
	  gencode(otherwyse);
	  end
	else {holes only}
	  if RANGECHECK then with op1 do
	    begin
	    smallval := 6;
	    emit1(trap,op1);                          { TRAP #6 }
	    end;
	if maxrefs < nomatchrefs then maxrefs := nomatchrefs;
	end;

      {fix up all branches to the end of the case stmt}
      fixreflist(exitcaserefs);
      clear(false);
      if (warnfactor*maxrefs>tablesize) and (tablesize >= warnthresh) then
	warning(linenum,
	  'most case table entries address the same statement');
      end; { with curstmt^ ... }
1: end {gencase};

procedure gengoto(curstmt: stptr);

{ Enhanced 9/26/91 JWH to fix FSDdt07193 }
{ except for variables, all changes are }
{ bewteen the lines =================== }
  var
    lbl: addrrange;
    op: attrtype;
    temp: reflistptr;
    label_temp,found_it : labelp;
    i : integer;
    done : boolean;
    upper_lim : integer;
  begin
    with curstmt^.target^ do

       if (level = staticlevel) or
	 fprocp^.ismodulebody then  { local goto }
	begin

{==================================================================}
	  found_it := NIL;
	  done := FALSE;
	  label_temp := display[top].flabel; { local labels in this scope }
	  while not done do
	   begin
	     if label_temp <> NIL then
	      begin
	       if labval = label_temp^.labval then
		begin
		 found_it := label_temp;
		 done := TRUE;
		end;
		 label_temp  := label_temp^.nextlab;
	       end
	     else
	      done := TRUE;
	   end;  { while not done do }

      if found_it <> NIL then
       begin
	 upper_lim := (body_try_level - (found_it^.try_level));
	 { writeln('upper lim is : ',upper_lim); }
	 for i := 1 to upper_lim do
	  begin
	     SBind.gloptr := NIL;
	     SPind.offset := 2*ptrsize;
	     SBind.offset := lastrecovdisp;
	     SBind.storage := long;
	     SBind.gloptr := sysglobalptr;
	     emit2(move,SPind,SBind);   { MOVE.L offset(SP),lastrecov }
	     SPind.offset := 0;    { must restore SPind.offset to 0 }
	     with op do
	      begin
	       addrmode := immediate;
	       op.smallval := 3*ptrsize;
	      end;
	     SPdir.storage := wrd;
	     emit2(adda,op,SPdir);     { ADDA.L  3*ptrsize,SP }
	end; { For }
       end; { found_it <> NIL }
{==================================================================}
{ Now same as before : JWH 9/26/91 }

	lbl := location;
	getbrattr(lbl,defined,op);

	if not defined then
	  begin
	  new(temp);
	  if isrefed then
	    temp^.next := labrefs
	  else
	    begin
	    isrefed := true;
	    temp^.next := NIL;
	    end;
	  labrefs := temp;
	  temp^.pc := lbl;
	  end;

	emit1(bra,op);
	end
      else  { non-local goto }

	begin
	op.smallval := 9;
	emit1(trap,op);        { TRAP 9 }
	if staticlevel = 1 then { destination is main program }
	  outputcodeword(-1)
	else
	  outputcodeword(level-staticlevel); {DC.W static delta}

	if not isnlrefed then
	  begin
	  uniquelabid := uniquenumber;
	  isnlrefed := true;
	  end;
	outputref(curglobalname^ + '_' + itostr(uniquelabid) + '_' +
				     itostr(labval),codephile.bytecount,rel32);
	outputcodelong(-codephile.bytecount);
	end;
  end;

procedure genif(curstmt: stptr);
  var
    lbl1: reflistptr;
    lbl2: localref;
    op: attrtype;
  begin
    with curstmt^ do
      begin
      gencond(ifcond,lbl1,false);
      releaseattr;
      gencode(tru);
      if fals <> NIL then
	begin
	lbl2.next := NIL;
	getbrattr(lbl2.pc,false,op);
	emit1(bra,op);
	end;
      fixreflist(lbl1);
      clear(false);
      if fals <> NIL then
	begin
	gencode(fals);
	fixreflist(addr(lbl2));
	clear(false);
	end;
      end;
  end {genif};

procedure genrep(curstmt: stptr);
  var
    lbl: reflistptr;
    blist: localref;
  begin
    with curstmt^ do
      begin
      lbl := addr(blist);
      blist.pc := codephile.bytecount;
      blist.next := NIL;
      clear(false);
      gencode(rbody);
      if debugging then
	begin
	emit1(trap,immed0);
	outputcodeword(lineno);
	end;
      globalattrlist := addr(attrlistptr);
      gencond(rcond,lbl,true)
      end;
  end {genrep};

procedure genwhile(curstmt: stptr);
  var
    lbl1: addrrange;
    lbl2: reflistptr;
    op: attrtype;
  begin
    with curstmt^ do
      begin
      lbl1 := codephile.bytecount;
      clear(false);
      if debugging then
	begin
	emit1(trap,immed0);
	outputcodeword(linenum);
	end;
      globalattrlist := addr(attrlistptr); { reset for current statement }
      gencond(rcond,lbl2,false);
      releaseattr;
      gencode(rbody);
      getbrattr(lbl1,true,op);
      emit1(bra,op);
      end;
    fixreflist(lbl2);
    clear(false);
  end {genwhile};

procedure gentry(curstmt: stptr);
  var
    op: attrtype;
    lrecovref, loutref: localref;
  begin
    with curstmt^ do
      begin
      SBind.offset := lastrecovdisp;
      SBind.storage := long;
      SBind.gloptr := sysglobalptr;
      SPminus.storage := long;
      emit2(move,SBind,SPminus);                { MOVE.L lastrecov,-(SP) }
      emit2(move,A6dir,SPminus);              { MOVE.L localbase,-(SP) }
      with op do
	begin
	addrmode := prel; offset := 0; indexed := false;
	absaddr.intval := true; absaddr.ival := 0;
	end;
      { REF lrecov }
      lrecovref.next := NIL;
      lrecovref.pc := codephile.bytecount + 2;
      emit1(pea,op);                            { PEA lrecov }
      emit2(move,SPdir,SBind);                  { MOVE.L SP,lastrecov }
      SBind.gloptr := NIL;
      body_try_level := body_try_level + 1;  { JWH 9/26/91 }
      gencode(tbody);
      body_try_level := body_try_level - 1;  { JWH 9/26/91 }
      SPind.offset := 2*ptrsize;
      SBind.offset := lastrecovdisp;
      SBind.storage := long;
      SBind.gloptr := sysglobalptr;
      emit2(move,SPind,SBind);              { MOVE.L offset(SP),lastrecov }
      SPind.offset := 0;    { must restore SPind.offset to 0 }
      with op do
	begin
	addrmode := immediate;
	op.smallval := 3*ptrsize;
	end;
      SPdir.storage := wrd;
      emit2(adda,op,SPdir);                 { ADDA.L  3*ptrsize,SP }
      with op do
	begin
	addrmode := prel; offset := 0; storage := wrd;
	absaddr.intval := true; absaddr.ival := 0;
	end;
      { REF lout }
      loutref.next := NIL;
      loutref.pc := codephile.bytecount + 2;
      emit1(jmp,op);                  { JMP lout }
      { DEF lrecov }
      fixreflist(addr(lrecovref));
      clear(false);
      A6dir.storage := long;
      emit2(movea,SPplus,A6dir);           { MOVEA.L (SP)+,localbase }
      emit2(move,SPplus,SBind);            { MOVE.L (SP)+,lastrecov }
      SBind.gloptr := NIL;
      gencode(recov);
      { DEF lout }
      fixreflist(addr(loutref));
      clear(false);
      end;
  end {gentry};

procedure genwith(curstmt: stptr);
  var
    op1,op2: attrtype;

  procedure getwithrecattr(var attrec: attrtype);
    { initialize access to WITH record base in local storage. }
    begin getlocstorage(ptrsize,attrec); attrec.access := indirect;
    end; {getwithrecattr}

  begin {genwith}
    with curstmt^ do
      begin
      genexpr(refexpr);
      with refexpr^,attr^ do
	begin
	if packd and (bitoffset.variable <> -1) then
	  begin
	  getlocstorage(intsize,op1);
	  refbit := op1.offset;
	  op1.storage := long;
	  with op2 do
	    begin addrmode := inDreg; regnum := bitoffset.variable; end;
	  emit2(move,op2,op1);
	  freeit(D,bitoffset.variable);
	  end
	else refbit := 0; {no bit offset saved}
	if indexed or (access = indirect)
	    or (addrmode = locinreg)
	    and (regnum <> localbase) and (regnum <> SB) then
	  begin {base is non-constant or intermediate so save it}
	  if (reg[A,regnum].usage <> withrecbase)
	      and addrinreg(refexpr) then
	    {Base is currently in "A" register.  Mark register
	    usage and save accessing info in register.}
	    with reg[A,regnum] do
	      begin usage:= withrecbase;
	      allocstate := allocated;
	      usesleft := 1;
	      oldcontents := attr^; {initialize}
	      getwithrecattr(oldcontents); curcontents := attr;
	      moveaddress(refexpr,oldcontents);
	      end
	  else {base not loaded, save access info in refexpr}
	    begin
	    op1 := attr^;  { This is a "cheap" initialization }
	    getwithrecattr(op1);
	    moveaddress(refexpr,op1);
	    attr^ := op1;
	    freeregs(attr);
	    end;
	  end { save base }
	else freeregs(attr);
	gencode(wbody);
	with reg[A,regnum] do
	  if (usage = withrecbase) then
	    if curcontents = attr then usage := other;
	end;
      end; {with curstmt^}
  end {genwith};

procedure genepilog(curstmt: stptr);
  var
    popsize: addrrange;
    opnd1,opnd2: attrtype;
  begin
  if (display[top].ffile <> NIL) and
     (proclev > 0) then { local files }
    begin
    SPminus.storage := long;
    emit2(move,A6dir,SPminus);
    callstdproc('ASM_CLOSEFILES');
    end;
  if odd(lcmax) then lcmax := lcmax-1;
  if modulebody then emit0(rts)
  else
    begin emit1(unlk,A6dir);               { UNLK A6 }
    if proclev > 0 then
      begin
      with fprocp^ do
	begin
	popsize := paramlc+ptrsize*ord(proclev>1);
	if klass=func then
	  if idtype^.form >= prok then popsize := popsize+ptrsize;
	if (popsize<>0) and (popsize<>4) then
	  begin
	  with opnd2 do
	    begin addrmode := inAreg; regnum := 0; storage := long end;
	  emit2(movea,SPplus,opnd2);             { MOVEA.L (SP)+,A0 }
	  with opnd1 do
	    begin addrmode := immediate; smallval := popsize; end;
	  if popsize < 32768 then
	    SPdir.storage := wrd
	  else
	    SPdir.storage := long;
	  emit2(add,opnd1,SPdir);                { ADDQ/I #popsize,SP }
	  with opnd2 do
	    begin addrmode := locinreg; offset := 0;
	    indexed := false; regnum:= 0; gloptr := NIL;
	    end;
	  emit1(jmp,opnd2);                      { JMP (A0) }
	  end
	else
	  begin
	  if popsize = 4 then
	    begin
	    SPind.storage := long;
	    emit2(move,SPplus,SPind);            { MOVE.L (SP)+,SP }
	    end;
	  emit0(rts);                            { RTS }
	  end;
	end;
      end
    else emit0(rts);    {main program}
    end;

  { Used by the tree dump routine for debug info }
  fprocp^.exit_location := codephile.bytecount - 2;

  if $IF MC68020$ (proclev = 0) and $END$ (lcmax < LClimit) then
$if bigsets$
	errorwithinfo( 683,
	    'Refer to manual for details of stack allocation.')
$end$
$if not bigsets$
	error(683)
$end$
  else if not modulebody then
    while maxLCpatch <> NIL do
      begin
      $IF MC68020$
	if (maxLCpatch^.next = NIL) and gstackcheck then { last one }
	  fixlong(maxLCpatch^.pc,-(lcmax-1073741824)) { convert trap #1 disp }
	else
	  fixlong(maxLCpatch^.pc,lcmax);
      $END$
      $IF not MC68020$
	fixword(maxLCpatch^.pc,lcmax);
      $END$
      maxLCpatch := maxLCpatch^.next;
      end;
  end {genepilog};

begin {gencode}
while curstmt <> NIL do
  with curstmt^ do
    begin oldlc := lc;
    { set codegen variables to reflect curstmt^ }
    linenum := lineno;
    rangecheck := sflags.rangecheck;
    ovflcheck := sflags.ovflcheck;
    iocheck := sflags.iocheck;
    shortcircuit := sflags.shortcircuit;
    callmode := sflags.callmode;
    if labp <> NIL then
      with labp^ do
	begin
	clear(false);
	if nonlocalref then
	  begin
	  outputdef(itostr(uniquelabid) + '_' + itostr(labval),
					    codephile.bytecount,relocatable,0);
	  $IF MC68020$
	  if maxLCpatch <> NIL then { not main prog }
	    begin
	    SPdir.storage := long;
	    emit2(movea,A6dir,SPdir);
	    new(p);
	    p^.next := maxLCpatch;
	    maxLCpatch := p;
	    p^.pc := codephile.bytecount + 2;
	    opnd.addrmode := immediate;
	    opnd.smallval := 0;
	    emit2(adda,opnd,SPdir);
	    end
	  else { main prog : always has link.w a6,#0 }
	    begin
	    A6ind.offset := -1;
	    emit2(lea,A6ind,SPdir);
	    fixword(codephile.bytecount-2,1);
	    end;
	  $END$
	  $IF not MC68020$
	  if maxLCpatch <> NIL then { not main prog }
	    begin
	    new(p);
	    p^.next := maxLCpatch;
	    maxLCpatch := p;
	    p^.pc := codephile.bytecount + 2;
	    end;
	  A6ind.offset := -1;
	  emit2(lea,A6ind,SPdir);
	  fixword(codephile.bytecount-2,1);
	  $END$
	  end;
	location := codephile.bytecount;
	defined := true;
	if isrefed then fixreflist(labrefs);
	end;
    if debugging and not modulebody
       and not (sclass in [emptyst,compndst,repst,whilest]) then
      begin
      emit1(trap,immed0);
      outputcodeword(linenum);
      end;
    if (sclass <> emptyst) and
       (initlistmode = listfull) and
       listpc and listopen then
      begin
      if PCcount = 0 then incrlinecount;
      write(lp,linenum:8,'-',codephile.bytecount:7,' ');
      PCcount := PCcount + 1;
      if PCcount = PCperline then
	begin writeln(lp); PCcount := 0; end;
      if ioresult <> ord(inoerror) then
	begin
	listabort := true;
	list := listnone;
	listopen := false;
	warning(linenum,'Listing aborted');
	end;
      end;
    attrlistptr := NIL;
    globalattrlist := addr(attrlistptr);
    case sclass of
      becomest:    begin genbecomes(curstmt); releaseattr end;
      pcallst:     begin
		     genproc(psymptr,actualp); releaseattr;
		   end;
      casest:      gencase(curstmt);
      compndst:    gencode(curstmt^.cbody);
      forst:       begin genfor(curstmt); releaseattr end;
      gotost:      gengoto(curstmt);
      ifst:        genif(curstmt);
      repst:       begin genrep(curstmt); releaseattr end;
      whilest:     genwhile(curstmt);
      tryst:       begin
		     gentry(curstmt);
		   end;
      withst:      begin genwith(curstmt); releaseattr end;
      endofbodyst: genepilog(curstmt);
      emptyst:     ;
      otherwise escape(-8);
      end; {case sclass ...}
    lc := oldlc;
    curstmt := next;
    end; {with curstmt^...}
end; {gencode}

  procedure getprocinfo;
    begin
    curproc := fprocp;
    with curproc^ do
      begin lcmax := lc;
      proclev := pflev;
      bodylev := pflev+1;
      if klass = prox then
	modulebody := ismodulebody
      else
	modulebody := false;
      end;
    rangecheck := curbody^.sflags.rangecheck; { use value from first statement }
    callmode := curbody^.sflags.callmode;
    end {getprocinfo};

  procedure genprolog;
    var
      i: shortint;
      parmp,varid: ctp;
      op1,op2,op3 : attrtype;
      temp: string[idlength+1];
      nametemp: alpha;

    procedure copyvalueparm;
      { move value parm whose address has parameter offset
	parmp^.vptraddr to offset given by parmp^.vaddr }
      var
	destreg, sourcereg, sourcesize: regrange;
	wdstomove, curmove: integer;
	op1,op2,op3 : attrtype;
      begin
	if (parmp^.idtype^.form = power) or strgtype(parmp^.idtype) then
	  with parmp^ do
	    begin
	    sourcereg := getreg(A);
	    destreg := getreg(A);
	    sourcesize := getreg(D);
	    { load source address }
	    A6ind.offset := vptraddr;
	    with op2 do
	      begin addrmode := inAreg; regnum:= sourcereg; storage:= long; end;
	    emit2(movea,A6ind,op2);                { MOVEA.L vptraddr(A6),Areg }
	    { load size in a reg }
	    op2.addrmode := postincr;
	    with op1 do
	      begin addrmode := inDreg; regnum := sourcesize; end;
	    if idtype^.form = power then op1.storage := wrd
				    else op1.storage := bytte;
	    op2.storage := op1.storage;
	    emit2(move,op2,op1);
	    if RANGECHECK then
	      if idtype^.form = power then
		begin
		with op2 do
		  begin
		  addrmode := immediate; smallval := idtype^.unpacksize-2;
		  end;
		emit2(chk,op2,op1);
		end
	      else if idtype^.maxleng<>255 then
		begin
		with op2 do
		  begin
		  addrmode := immediate; smallval := idtype^.maxleng;
		  end;
		emit2(cmpi,op2,op1);
		with op1 do
		  begin offset:= 2; storage:= bytte  end;
		emit1(bls,op1);              { BLS.S *+4 }
		op1.smallval := 7;
		emit1(trap,op1);             { TRAP #7 }
		end;
	    { get destination address in a register }
	    A6ind.offset := vaddr;
	    with op2 do
	      begin
	      addrmode := inAreg; regnum := destreg; storage := long;
	      end;
	    emit2(lea,A6ind,op2);
	    { move size field to destination }
	    with op1 do
	      begin addrmode := inDreg; regnum := sourcesize; end;
	    with op2 do
	      begin
	      addrmode := postincr;
	      if idtype^.form = power then storage := wrd
				      else storage := bytte;
	      end;
	    emit2(move,op1,op2);
	    { loop back to this point }
	    with op1 do
	      begin
	      addrmode := postincr; regnum := sourcereg;
	      end;
$if bigsets$
	    if idtype^.form = power then
		op2.storage := wrd
	    else op2.storage := bytte;
	    emit2(move,op1,op2);
	    with op1 do
	      begin
	      addrmode := immediate;
	      if idtype^.form = power then
		smallval := 2
	      else smallval := 1;
	      end;
	    with op2 do
	      begin
	      addrmode := inDreg; regnum := sourcesize;
	      if idtype^.form = power then
		storage := wrd
	      else  storage := bytte;
	      end;
	    emit2(subq,op1,op2);
	    with op1 do
	      begin
		offset := -6;
		if idtype^.form = power then storage := wrd
		else  storage := bytte;
	       end;
$end$
$if not bigsets$
	    op2.storage := bytte;
	    emit2(move,op1,op2);
	    with op1 do
	      begin
	      addrmode := immediate; smallval := 1;
	      end;
	    with op2 do
	      begin
	      addrmode := inDreg; regnum := sourcesize; storage := bytte;
	      end;
	    emit2(subq,op1,op2);
	    with op1 do
	      begin offset := -6; storage := bytte end;
$end$
	    emit1(bhi,op1);
	    freeit(A,destreg);
	    freeit(D,sourcesize);
	    freeit(A,sourcereg);
	    end
	  else if parmp^.idtype^.form = cnfarrays then
	    begin
	    getcnfsize(parmp^.idtype,op1);
	    if op1.addrmode <> inDreg then
	      with op2 do
		begin
		addrmode := inDreg;
		regnum := getreg(D);
		storage := long;
		emit2(move,op1,op2);
		op1 := op2;
		end;
	    { make the value even }
	    with op2 do
	      begin
	      addrmode := immediate;
	      smallval := 1;
	      emit2(add,op2,op1);
	      smallval := 0;
	      emit2(bclr,op2,op1);
	      end;
	    { Make room in stack frame }
	    SPdir.storage := long;
	    emit2(suba,op1,SPdir);
	    { copy }
	    A6ind.offset := parmp^.vptraddr;
	    SPminus.storage := long;
	    emit2(move,A6ind,SPminus);
	    SPind.offset := 4;
	    emit1(pea,SPind);
	    SPind.offset := 0;
	    emit2(move,op1,SPminus);
	    freeit(D,op1.regnum);
	    saveregs;
	    forgetbaseregs;
	    callstdproc('ASM_MOVEL');
	    reloadregs;
	    A6ind.storage := long;
	    emit2(move,SPdir,A6ind);
	    end
	  else
	    begin
	    sourcereg := getreg(A);
	    with parmp^ do
	      begin wdstomove := (idtype^.unpacksize+1) div 2;
	      A6ind.offset := vptraddr;
	      with op2 do
		begin
		addrmode := inAreg; regnum := sourcereg; storage := long;
		end;
			       { set up source pointer }
	      emit2(movea,A6ind,op2);              { MOVEA.L vptraddr(A6),Areg }
	      op2.addrmode := postincr;
	      A6ind.offset := vaddr;
	      end;
	    bigmove(op2,A6ind,wdstomove,true,false);
	    freeit(A,sourcereg);
	    end;
      end; {copyvalueparm}

    procedure callmodulebodies;
      var
	s: modstateptr;
	op: attrtype;
	found: boolean;
	i: shortint;
      begin
      with display[top] do
	begin
	s := available_module;
	while s <> NIL do
	  with s^, modinfo^ do
	    begin
	    if needscall then
	      begin
	      found := false;
	      i := 1;
	      while not found and (i <= overlaytop) do
		if modinitbody^.namep^ = overlaylistptr^[i] then
		  found := true
		else
		  i := i + 1;
	      if found then { don't emit call }
	      else
		begin
		needscall := false;
		getprokconst(modinitbody,op);
		emit1(jsr,op);
		end;
	      end;
	    s := s^.nextmodule;
	    end;
	end;
      end;

    begin { genprolog }
    if not modulebody then
      begin
      if debugging then
	begin
	outputcodeword(curbody^.lineno);
	temp := fprocp^.namep^;
	if not odd(strlen(temp)) then
	  begin
	  temp[0] := chr(ord(temp[0])+1);
	  temp[strlen(temp)] := ' ';
	  end;
	for i := 0 to strlen(temp) do
	  outputcodebyte(ord(temp[i]));
	outputcodebyte(strlen(temp)+1);
	end
      else { not debugging }
	outputcodebyte(0);
      outputcodebyte(ord(proclev>1));
      end;
    if proclev = 0 then       {main program}
      begin {define main program entry point}
      maxLCpatch := NIL;
      with fprocp^ do
	begin
	location := codephile.bytecount;
	isdumped := true;
	end;
      startaddr := codephile.bytecount;
      outputdef(fprocp^.namep^,codephile.bytecount,relocatable,0);
      A6dir.storage := wrd;
      emit1(link,A6dir); { LINK localbase }
      if heapdispose then callstdproc('HPM_HESTABLISH');
      end { proclev = 0... }
    else
      begin {define procedure entry point}
      startaddr := -1;
      with fprocp^ do
	begin
	location := codephile.bytecount;
	isdumped := not alias;
	if isexported or isrefed then
	  if not isexported then
	    begin
	    nametemp := itostr(forwid) + namep^;
	    outputdef(nametemp,codephile.bytecount,relocatable,0);
	    end
	  else
	    outputdef(namep^,codephile.bytecount,relocatable,0);
	end; { with fprocp^ }
      if not modulebody then
	begin {establish dynamic link, allocate local storage}
	new(maxLCpatch);
	maxLCpatch^.next := NIL;
	maxLCpatch^.pc := codephile.bytecount + 2;
	if gstackcheck then
	  begin
	  op1.smallval := 1;
	  emit1(trap,op1);       { trap #1 stack overflow check }
	  outputcodeword(0);
	  $IF MC68020$
	    outputcodeword(0);   { room for 32 bit displacement on 68020 }
	  $END$
	  end
	else
	  begin
	  $IF MC68020$
	    A6dir.storage := long;
	  $END$
	  $IF not MC68020$
	    A6dir.storage := wrd;
	  $END$
	  emit1(link,A6dir);
	  end;
	{move any copied-value parameters}
	parmp := fprocp^.next;
	while parmp <> NIL do
	  with parmp^ do
	    begin
	    if vtype = cvalparm then copyvalueparm;
	    parmp := next;
	    end;
	end; {not modulbody}
      end; { proclev <> 0... }
    varid := display[top].ffile;
    while varid <> NIL do
      with varid^ do
	begin initlocvar(varid,NIL,0,idtype,isnew);
	varid := varid^.next;
	end;
    callmodulebodies;
    end {genprolog};

  begin {genbody}
    getprocinfo;
    clear(true);
    genprolog;
    stringhead := NIL; sethead := NIL;
    reelhead := NIL; enumhead := NIL;

    $IF MC68020$
    wrdpairhead := NIL; longpairhead := NIL;
    $END$

    freeattr := NIL;
    PCcount := 0; PCperline := pagewidth DIV 17;
    gencode(curbody);
    dumpconsts;
    if (PCcount <> 0) and listopen and listpc then writeln(lp);
  end; {genbody}


procedure codegeninit;
  type
    filesiztype = string[5];
  var
    lok: boolean;
    i: integer;
    defaultfilename: fid;
    codevid: vid;
    sourcevid: vid;
    sourcefid: fid;
    dummy2: integer;
    dummy3: filekind;

  function filetag(var fname:fid): boolean;
    var
      lok: boolean;
      dummy1: fid;
      dummy2: integer;
      dummy3: filekind;
    begin
    fixname(fname,codefile);
    lok := scantitle(fname,codevid,
			   dummy1,dummy2,dummy3);
    if lok then
      begin
      rewrite(codephile.fileid,fname);       {Try to Open new file}
      i := ioresult;
      close(codephile.fileid,'PURGE');
      if i<>ord(inoerror) then
	begin
	if i = ord(inoroom) then
	  begin
	  error(900);
	  escape(-1);
	  end
	else if i <> ord(inofile) then
	  begin
	  file_warn(903,i);
	  escape(-1);
	  end
	else
	  filetag := false;
	end
      else filetag := true;
      end
    else
      filetag := false;
    end;

begin {codegeninit}
new(libraryptr);
new(codephile.buffer);
new(refile.buffer);
new(defile.buffer);
genutilsinit;
lok := scantitle(sourcefilename,sourcevid,
			sourcefid,dummy2,dummy3);
defaultfilename := sourcevid + ':' +
		     getfid(sourcefid) + '.CODE';
if userinfo^.gotsym then
  begin
  file_name := defaultfilename;
  if not filetag(file_name) then
    userinfo^.gotsym := false;
  end
else
  begin
  writeln(output);
  write(output,'Output file (default is "',defaultfilename,'") ? ');
  repeat
    readln(input,file_name);
    if file_name='' then
      file_name := defaultfilename;
    lok := filetag(file_name);
    if not lok then
      write(output,'Invalid file name. File ? ');
    until lok;
  end;
codefileopen := false;
if refvolname = '' then
  refvolname := codevid + ':';
fanonfile(refile.fileid,refvolname,
			    codefile,refilesize);
i := ioresult;
if i<>ord(inoerror) then
  begin
  if i = ord(inoroom) then error(901)
  else
    file_warn(904,i);
  escape(-1);
  end;
if defvolname = '' then
  defvolname := codevid + ':';
fanonfile(defile.fileid,defvolname,
			    codefile,defilesize);
i := ioresult;
if i<>ord(inoerror) then
  begin
  if i = ord(inoroom) then error(902)
  else
    file_warn(905,i);
  escape(-1);
  end;
writeln(output);
codeinit;
dedicatedregs := [SB,localbase,SP];
memorymodes := [locinreg,shortabs,longabs,prel,labelledconst,namedconst];

{ Used by "extend" for "emitcheck" }
ensure_valid_condition_code := false;

OVERLAY := 'OVERLAY';
EXEC := 'EXEC';
ADDRESS := 'ADDRESS';
force_unpack := false;          (* default condition, do not force unpacking
				   of unsigned 8 or 16 bit fields *)
end; {codegeninit}

@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 3249
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 3249
				{ file GENCODE }
import
  genexprmod,assemble,genutils,genmove,fs,ci,float_hdw;
implement

procedure bigmove
   (var source,dest: attrtype; wdstomove: integer;
    A1isfree: boolean; bytetomove: boolean);
  (* source   - will be A0+ or A1+ or disp(Areg)
     dest     - will be A0+ or A1+ or disp(Areg)
     for disp(Areg),
	Areg is (A0, A1 or A6)
	disp may not be zero
     wdstomove- is a word count not a byte count
     A1isfree - reflects the mode of addressing the dest *)
  var
    curmove: shortint;
    multiple,op: attrtype;
  begin
    if source.addrmode <> locinreg then
      begin
      source.offset := 0;
      source.gloptr := NIL;
      source.indexed := false;
      end;
    if dest.addrmode <> locinreg then
      begin
      dest.offset := 0;
      dest.gloptr := NIL;
      dest.indexed := false;
      end;
    if wdstomove < 28 then
      while wdstomove > 0 do
	case wdstomove of
	  1: begin
	     with source do
	       if addrmode <> locinreg then
		 begin
		 addrmode := locinreg; offset := 0; indexed := false;
		 gloptr := NIL;
		 end;
	     with dest do
	       if addrmode <> locinreg then
		 begin
		 offset := 0; indexed := false; addrmode := locinreg;
		 gloptr := NIL;
		 end;
	     dest.storage := wrd;
	     emit2(move,source,dest);
	     wdstomove := 0;
	     dest.offset := dest.offset + 2;
	     source.offset := source.offset + 2;
	     end;
       2..4: begin
	     if wdstomove = 2 then
	       begin
	       with source do
		 if addrmode <> locinreg then
		   begin
		   addrmode := locinreg; offset := 0; indexed := false;
		   gloptr := NIL;
		   end;
	       with dest do
		 if addrmode <> locinreg then
		   begin
		   offset := 0; addrmode := locinreg; indexed := false;
		   gloptr := NIL;
		   end;
	       end;
	     dest.storage := long;
	     emit2(move,source,dest);
	     wdstomove := wdstomove-2;
	     dest.offset := dest.offset + 4;
	     source.offset := source.offset + 4;
	     end;
   5,7,9,11: begin    {move multiple words}
	     getmultattr(wdstomove,A1isfree,multiple);
	     with source do
	       if addrmode <> locinreg then
		 begin
		 addrmode := locinreg; offset := 0; indexed := false;
		 gloptr := NIL;
		 end;
	     with dest do
	       begin
	       if addrmode <> locinreg then
		 begin
		 addrmode := locinreg; offset := 0; indexed := false;
		 gloptr := NIL;
		 end;
	       storage := wrd;
	       end;
	     multiple.storage := wrd;
	     emit2(movem,source,multiple);
	     emit2(movem,multiple,dest);
	     dest.offset := dest.offset + wdstomove * 2;
	     source.offset := source.offset + wdstomove * 2;
	     wdstomove := 0;
	     end;
6,8,10,12..24: begin      {move multiple long words}
	     if not A1isfree and (wdstomove > 22) then
	       curmove := 11{long words}
	     else
	       curmove := wdstomove DIV 2;
	     wdstomove := wdstomove - curmove*2;
	     if wdstomove = 0 then
	       begin
	       with source do
		 if addrmode <> locinreg then
		   begin
		   addrmode := locinreg; offset := 0; indexed := false;
		   gloptr := NIL;
		   end;
	       with dest do
		 if addrmode <> locinreg then
		   begin
		   addrmode := locinreg; offset := 0; indexed := false;
		   gloptr := NIL;
		   end;
	       end;
	     dest.storage := long;
	     multiple.storage := long;
	     getmultattr(curmove,A1isfree,multiple);
	     emit2(movem,source,multiple);
	     emit2(movem,multiple,dest);
	     dest.offset := dest.offset + curmove*4;
	     source.offset := source.offset + curmove*4;
	     end;
	  otherwise     {move multiple 11 or 12 long words}
	     begin
	     curmove := 11 + ord(A1isfree);
	     wdstomove := wdstomove - curmove * 2;
	     getmultattr(curmove,A1isfree,multiple);
	     multiple.storage := long;
	     emit2(movem,source,multiple);
	     dest.storage := long;
	     emit2(movem,multiple,dest);
	     dest.offset := dest.offset + curmove*4;
	     source.offset := source.offset + curmove*4;
	     end;
	  end {case}
    else { BIG  bigmove }
      begin
      { if bytetomove then saveregs; }  { <===== jwh 11/17/88 }
      forgetbaseregs;
      source.addrmode := locinreg;
      dest.addrmode := locinreg;
      emit1(pea,source);
      emit1(pea,dest);
      SPminus.storage := long;
      with op do
	begin
	addrmode := immediate;
	smallval := wdstomove * 2;
	if bytetomove then             { <======= jwh 11/17/88 }
	   smallval := smallval + 1;
	end;
      emit2(move,op,SPminus);
      callstdproc('ASM_MOVEL');
      { if bytetomove then reloadregs; }   { <==== JWH 11/17/88 }
      source.offset := source.offset + op.smallval;
      dest.offset := dest.offset + op.smallval;
      end;
  end; { bigmove }

procedure genbody (curbody: stptr; fprocp: ctp);
  type
    initlocvartype = (isnew,isdispose);

  procedure initlocvar
		  (varid: ctp; heapaddr: exptr;
		   disp: addrrange; fsp: stp;
		   initype: initlocvartype);
    { initialize local variables.  Base points to id for variable.
      Disp is offset from varid's location.  Fsp points to structure
      of current var or one of its fields or elements. }
    var
      lmin,lmax: integer; lsize,lcnt: integer; lcp: ctp;
      op1,op2,op3 : attrtype;
      patchloc: addrrange;

    procedure varaddress(opcd: opcodetype;
				disp: addrrange);
      var
	op1 : attrtype;
      begin
      if varid <> NIL then
	with varid^, op1 do
	  begin
	  if vtype < localvar then
	    begin
	    gloptr := NIL;
	    case vtype of
	      shortvar: addrmode := shortabs;
	      longvar:  addrmode := longabs;
	      relvar:   addrmode := prel;
	      end;
	    absaddr := varid^.absaddr; offset := disp;
	    end
	  else
	    begin
	    addrmode := locinreg;
	    offset := disp + vaddr;
	    indexed := false;
	    if vlev = 1 then
	      begin
	      regnum := SB; gloptr := currentglobal;
	      end
	    else
	      begin
	      regnum := localbase; gloptr := NIL;
	      end;
	    end;
	  storage := long;
	  emit1(opcd,op1);
	  freeregs(addr(op1));
	  end
	else { varid = NIL: heap variable }
	  begin
	  if disp = 0 then
	    pushaddress(heapaddr)
	  else
	    if disp > 32767 then
	      begin
	      pushaddress(heapaddr);
	      with op1 do
		begin
		addrmode := immediate;
		smallval := disp;
		end;
	      SPind.storage := long;
	      emit2(addi,op1,SPind);
	      end
	    else
	      begin
	      loadaddress(heapaddr,false);
	      with heapaddr^.attr^ do
		begin
		addrmode := locinreg;
		offset := disp;
		indexed := false;
		emit1(pea,heapaddr^.attr^);
		offset := 0;
		end;
	      end;
	  freeregs(heapaddr^.attr);
	  end;
      end;

    begin { initlocvar }
    if fsp <> NIL then
      with fsp^ do
	if mustinitialize in info then
	  case form of
	    files:
	      begin
	      if modulebody then
		begin
		varaddress(tst,disp+4);
		patchloc := codephile.bytecount + 2;
		op1.offset := 0;
		op1.storage := bytte;
		emit1(bne,op1);
		end;
	      SPminus.storage := long;
	      varaddress(pea,disp);
	      if initype = isnew then
		begin
		if filtype = NIL then
		  begin
		  emit1(clr,SPminus);      {CLR.L -(SP) assumes nilvalue = 0}
		  with op2 do
		    begin addrmode := immediate; smallval := -1; end;
		  emit2(move,op2,SPminus);      { MOVE.L #-1,-(SP) }
		  end
		else
		  begin
		  varaddress(pea,disp+filesize);
		  if (filtype^.unpacksize=1) then
		    with op2 do
		      begin
		      addrmode := immediate;
		      if fsp = textptr then smallval := -3
		      else smallval := -2;
		      emit2(move,op2,SPminus);
		      end
		  else
		    with op2 do
		      begin
		      addrmode := immediate;
		      smallval := filtype^.unpacksize;
		      emit2(move,op2,SPminus);
		      end;
		  end;
		callstdproc('FS_FINITB');
		end
	      else { initype = isdispose }
		begin
		SPminus.storage := wrd;
		emit1(clr,SPminus);
		callstdproc('FS_FCLOSE');
		end;
	      if varid <> NIL then
		if varid^.vtype = localvar then
		  with varid^ do
		    begin
		    with op3 do
		      begin
		      addrmode := locinreg;
		      offset := disp + vaddr;
		      indexed := false;
		      if vlev  = 1 then
			begin
			regnum := SB; gloptr := currentglobal;
			end
		      else
			begin
			regnum := localbase; gloptr := NIL;
			end;
		      end; { with op3 }
		    getregattr(A,op1);
		    emit2(lea,op3,op1);
		    with op1 do
		      begin
		      addrmode := locinreg;
		      offset := 4;
		      indexed := false;
		      gloptr := nil;
		      end;
		    SBind.offset := FIBptrdisp;
		    SBind.storage := long;
		    SBind.gloptr := sysglobalptr;
		    emit2(move,SBind,op1);
		    op1.addrmode := inAreg;
		    emit2(move,op1,SBind);
		    freeit(A,op1.regnum);
		    SBind.gloptr := NIL;
		    end; { with varid^ }
	      if modulebody then
		fixbyte(patchloc-1,codephile.bytecount-patchloc);
	      end;
	    arrays:
	      if inxtype <> NIL then
		begin
		getbounds(inxtype,lmin,lmax);
		if aeltype <> NIL then
		  begin
		  lsize := aeltype^.unpacksize;
		  if odd(lsize) then
		    lsize := lsize + 1;
		  if (varid = NIL) and
		     (lmax-lmin > 0) then
		    begin
		    getlocstorage(ptrsize,op1);
		    moveaddress(heapaddr,op1);
		    op1.access := indirect;
		    op2 := op1;
		    end
		  else if heapaddr <> NIL then
		    op2 := heapaddr^.attr^;
		  for lcnt:=0 to lmax-lmin do
		    begin
		    if heapaddr <> NIL then
		      begin
		      op1 := op2;
		      heapaddr^.attr := addr(op1);
		      end;
		    initlocvar(varid,heapaddr,
		      disp+lcnt*lsize,aeltype,initype);
		    end;
		  end;
		end;
	    records:
	      begin
	      lcp := fstfld;
	      if (varid = NIL) and
		 (lcp^.next <> NIL) then
		begin
		getlocstorage(ptrsize,op1);
		moveaddress(heapaddr,op1);
		op1.access := indirect;
		op2 := op1;
		end
	      else if heapaddr <> NIL then
		op2 := heapaddr^.attr^;
	      while lcp <> NIL do
		with lcp^ do
		  begin
		  if heapaddr <> NIL then
		    begin
		    op1 := op2;
		    heapaddr^.attr := addr(op1);
		    end;
		  initlocvar(varid,heapaddr,
		    disp+fldaddr,idtype,initype);
		  lcp := lcp^.next;
		  end;
	      end;
	    otherwise escape(-8);
	    end; {case}
    end; {initlocvar}


  procedure getcnfsize(cnf: stp; var op: attrtype);
    var
      lobound_attr,
      hibound_attr,
      cnfsize_attr,
      op1,op2: attrtype;
      hi,lo: integer;
      big_range: boolean;

    begin
    with op1 do
      begin
      addrmode := inDreg;
      regnum := getreg(D);
      case cnf^.inxtype^.unpacksize of
	1: storage := bytte;
	2: storage := wrd;
	4: storage := long;
      end;
      with hibound_attr do
	begin
	addrmode := locinreg;
	regnum := getbasereg(cnf^.cnf_index^.hiboundid^.vlev);
	offset := cnf^.cnf_index^.hiboundid^.vaddr;
	indexed := false;
	gloptr := NIL;
	end;
      if op1.storage = bytte then
	begin
	op1.storage := long;
	emit1(clr,op1);
	op1.storage := bytte;
	end;
      emit2(move,hibound_attr,op1);
      getbounds(cnf^.inxtype,hi,lo);
      try
	big_range := hi - lo >= 32767;
      recover
	if escapecode = -4 {overflow} then
	  big_range := true
	else
	  escape(escapecode);

      lobound_attr := hibound_attr;
      lobound_attr.offset := cnf^.cnf_index^.loboundid^.vaddr;
      if (op1.storage = long) or big_range then
	begin
	if op1.storage = wrd then
	  begin
	  op1.storage := long;
	  emit1(ext,op1);
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := wrd;
	    end;
	  emit2(move,lobound_attr,op2);
	  op2.storage := long;
	  emit1(ext,op2);
	  freeit(D,op2.regnum);
	  end
	else
	  begin
	  op2 := lobound_attr;
	  op2.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  op2.storage := long;
	  end;
	end
      else {wrd result}
	begin
	if op1.storage = bytte then
	  begin
	  op1.storage := wrd;
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := long;
	    end;
	  lobound_attr.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  emit1(clr,op2);
	  op2.storage := bytte;
	  emit2(move,lobound_attr,op2);
	  op2.storage := wrd;
	  freeit(D,op2.regnum);
	  end
	else { op1.storage := wrd }
	  begin
	  op2 := lobound_attr;
	  op2.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  op2.storage := wrd;
	  end;
	end;
      emit2(sub,op2,op1);
      op2.addrmode := immediate;
      op2.smallval := 1;
      emit2(addq,op2,op1);                {hi - lo + 1}

      {multiply by size}

      cnfsize_attr := lobound_attr;
      if op1.storage = long then  {call routine}
	begin
	if cnf^.inxtype^.unpacksize = 2 then
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg; regnum := getreg(D);
	    storage := wrd;
	    end;
	  cnfsize_attr.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := long;
	  emit1(ext,op2);
	  end
	else
	  begin
	  op2 := cnfsize_attr;
	  op2.storage := long;
	  op2.offset := cnf^.cnf_index^.hiboundid^.vaddr + 4;
	  end;
	$IF MC68020$
	  emit2(muls,op2,op1);
	  with op do
	    begin
	    addrmode := inDreg;
	    regnum := op1.regnum;
	    storage := long;
	    signbit := true;
	    end;
	$END$
	$IF not MC68020$
	  SPminus.storage := long;
	  emit2(move,op1,SPminus);
	  freeit(D,op1.regnum);
	  emit2(move,op2,SPminus);
	  if op2.addrmode = inDreg then
	    freeit(D,op2.regnum);
	  freeregs(addr(hibound_attr));
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_MPY');
	  reloadregs;
	  with op do
	    begin
	    addrmode := topofstack;
	    storage := long;
	    signbit := true;
	    end;
	$END$
	end     { multiply routine }
      else
	begin   { in line multiply }
	if cnf^.inxtype^.unpacksize = 1 then
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := wrd;
	    end;
	  cnfsize_attr.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  emit1(clr,op2);
	  op2.storage := bytte;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := wrd;
	  end
	else
	  begin
	  op2 := cnfsize_attr;
	  op2.storage := wrd;
	  op2.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  end;
	emit2(muls,op2,op1);
	if op2.addrmode = inDreg then
	  freeit(D,op2.regnum);
	op := op1;
	op.storage := long;
	freeregs(addr(hibound_attr));
	end;
      {Packed array ?}
      if cnf^.aispackd then
	begin { turn bit count into a whole byte count }
	if op.addrmode <> inDreg then
	  with op1 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := long;
	    emit2(move,op,op1);
	    freeregs(addr(op));
	    op := op1;
	    end;
	with op1 do
	  begin
	  addrmode := immediate;
	  smallval := 7;
	  emit2(add,op1,op);
	  smallval := 3;
	  emit2(lsr,op1,op);
	  end;
	end;
      end;
    end;

  procedure gencode(curstmt: stptr);
    var
      oldlc: addrrange;
      attrlistptr: attrptr;
      opnd: attrtype;
      i: shortint;
      p: reflistptr;

    procedure releaseattr;
      {release attribute records for the current statement}
      var
	p: attrptr;
      begin
	if attrlistptr <> NIL then
	  begin
	  p := attrlistptr;
	  while p^.next <> NIL do
	    p := p^.next;
	  p^.next := freeattr;
	  freeattr := attrlistptr;
	  end;
      end;

    function treematch(lhs,rhs: exptr): boolean;
      var
	temp: exptr;

      begin {treematch}
	with rhs^ do begin
	  if (eclass in [addnode,subnode]) or
	     ((eclass in [ornode,andnode]) and not shortcircuit) then
	    if eclass = subnode then treematch := branchmatch(lhs,opnd1)
	    else if branchmatch(lhs,opnd1) then treematch := true
	    else if branchmatch(lhs,opnd2) then
	      begin
	      treematch := true;
	      temp := opnd1;
	      opnd1 := opnd2;
	      opnd2 := temp;
	      end
	    else treematch := false
	  else treematch := false;
	end; {with rhs^}
      end; {treematch}

    procedure movemulti(source,dest: exptr;
				numbytes: integer);
      var
	numregs : 0..13; {D0-D7,A0-A4}
	rt : regtype;
	rn : regrange;
	numwords,curmove: integer;
	oddnum : boolean;
	op,multiregs : attrtype;
      begin
      numwords := numbytes div 2;
      makeaddressable(source);
      makeaddressable(dest);
      { If either source or dest has an index register the offset field
	in the 68010 addressing modes would be restricted to 8 bits.  We
	can't be sure that the final word or byte moves would have an
	offset that would fit in 8 bits so we get rid of indexing. }
      if (source^.attr^.addrmode in [locinreg, prel]) and
	  source^.attr^.indexed then
	loadaddress(source,false);
      if (dest^.attr^.addrmode in [locinreg, prel]) and
	  dest^.attr^.indexed then
	loadaddress(dest,false);
      if (numwords = 1) or (numwords = 2) then
	begin
	if numwords = 1 then dest^.attr^.storage := wrd
			else dest^.attr^.storage := long;
	emit2(move,source^.attr^,dest^.attr^);
	if odd(numbytes) then
	  begin
	  with source^.attr^ do offset := offset+numbytes-1;
	  with dest^.attr^ do offset := offset+numbytes-1;
	  end;
	end
      else if numwords > 0 then
	begin
	numregs := 0;
	{ build MOVEM format with list of available registers }
	for rt := A to D do
	  for rn := 0 to maxreg do
	    if (reg[rt,rn].allocstate = free) and (numregs < numwords) then
	      begin
	      numregs := numregs + 1;
	      if (rt = A) then forgetbasereg(rn);
	      multiregs.regs[rt,rn] := true;
	      end
	    else
	      multiregs.regs[rt,rn] := false;

	if numwords <= numregs then
	  begin  { enough regs available for word move multiple }
	  with multiregs do
	    begin addrmode := multiple; storage := wrd; end;
	  emit2(movem,source^.attr^,multiregs);
	  dest^.attr^.storage := wrd;
	  emit2(movem,multiregs,dest^.attr^);
	  if odd(numbytes) then
	    begin
	    with source^.attr^ do offset := offset+numbytes-1;
	    with dest^.attr^ do offset := offset+numbytes-1;
	    end;
	  end {word move multiple}
	else if numwords <= 2 * numregs + 1 then
	  begin  { enough regs available for long word move multiple }
	  oddnum := false;
	  if odd(numwords) then
	    begin
	    oddnum := true;
	    numwords := numwords - 1
	    end;
	  if numwords <> 2 * numregs then { remove extra regs }
	    begin
	    numregs := 0;
	    for rt := A to D do
	      for rn := 0 to maxreg do
		if (reg[rt,rn].allocstate = free) and
		   ((numregs*2) < numwords) then
		  begin
		  numregs := numregs + 1;
		  if (rt = A) then forgetbasereg(rn);
		  multiregs.regs[rt,rn] := true;
		  end
		else
		  multiregs.regs[rt,rn] := false;
	    end;
	  with multiregs do
	    begin addrmode := multiple; storage := long; end;
	  emit2(movem,source^.attr^,multiregs);
	  dest^.attr^.storage := long;
	  emit2(movem,multiregs,dest^.attr^);
	  with source^.attr^ do
	    offset := offset + 2*numwords;
	  with dest^.attr^ do
	    offset := offset + 2*numwords;
	  if oddnum then { move "odd" word }
	    begin
	    dest^.attr^.storage := wrd;
	    emit2(move,source^.attr^,dest^.attr^);
	    with source^.attr^ do offset := offset+2;
	    with dest^.attr^ do offset := offset+2;
	    end; {if oddnum}
	  end {long word move multiple}
	else
	  begin { not enough available regs, use D0-D7 and A2-A4 }
	  clear(false);
	  { set up source and dest pointers subject to :
	    1) addressing mode must use offset attribute
	    2) A0 and A1 are reserved for source/dest pointers }

	  with source^.attr^ do { form source address, if necessary }
	    if (addrmode = locinreg) and (regnum in [2..4])
		or (addrmode <> locinreg) or indexed then
	      begin { address via A0 or A1 }
	      with op do
		begin
		addrmode := inAreg;
		if (dest^.attr^.addrmode=locinreg) and
		   (dest^.attr^.regnum = 0)
		then regnum := 1
		else regnum := 0;
		end;
	      emit2(lea,source^.attr^,op);
	      with source^.attr^ do
		begin
		addrmode := locinreg; offset := 0; indexed := false;
		regnum := op.regnum; gloptr := NIL;
		end;
	      end;

	  with dest^.attr^ do { form dest address, if necessary }
	    if (addrmode = locinreg) and (regnum in [2..4])
		or (addrmode <> locinreg) or indexed then
	      begin { address via A0 or A1 }
	      with op do
		begin
		addrmode := inAreg;
		if (source^.attr^.addrmode=locinreg) and
		   (source^.attr^.regnum = 1)
		then regnum := 0
		else regnum := 1;
		end;
	      emit2(lea,dest^.attr^,op);
	      with dest^.attr^ do
		begin
		addrmode := locinreg; offset := 0; indexed := false;
		regnum := op.regnum; gloptr := NIL;
		end;
	      end;

	  { emit appropriate move sequence }
	  with source^.attr^ do
	    if (regnum = 0) or (regnum = 1) then
	      with reg[A,regnum] do
		begin
		allocstate := allocated;
		usage := other;
		end;
	  with dest^.attr^ do
	    if (regnum = 0) or (regnum = 1) then
	      with reg[A,regnum] do
		begin
		allocstate := allocated;
		usage := other;
		end;
	  bigmove(source^.attr^,dest^.attr^,
		   numwords,false,odd(numbytes));
	  end; {else begin}
	end; { if numwords > 0 }
      if ((odd(numbytes)) and (numbytes <= 55)) then  { <=== JWH 11/17/88 }
	begin
	dest^.attr^.storage := bytte;
	emit2(move,source^.attr^,dest^.attr^);
	end;
      freeregs(source^.attr); freeregs(dest^.attr);
      end; {movemulti}

    procedure cnfassign(lhs,rhs: exptr);
      var
	op: attrtype;
      begin
      pushaddress(rhs);
      pushaddress(lhs);
      getcnfsize(lhs^.etyptr,op);
      if op.addrmode = inDreg then
	begin
	SPminus.storage := long;
	emit2(move,op,SPminus);
	freeit(D,op.regnum);
	end;
      forgetbaseregs;
      callstdproc('ASM_MOVEL');
      end;

    procedure genassign (lhs,rhs : exptr);
      var
	lmin,lmax: valu; r: regrange;
      begin
      if RANGECHECK then
	emitcheck(rhs,lhs^.etyptr,true);
      if lhs^.attr^.packd then
	if rhs^.attr^.packd then packtopack (lhs,rhs)
			    else pack(lhs,rhs)
      else with rhs^.attr^ do begin
	if packd then makeaddressable(rhs);
	makeaddressable(lhs);
	if storage = multi then
	  storage := lhs^.attr^.storage
	else if (storage <> lhs^.attr^.storage) then
	  extend(rhs,lhs^.attr^.storage);
	if (addrmode = immediate) and (smallval = 0) then
	  emit1(clr,lhs^.attr^)
	else begin
	  if not rangecheck then maskboolexpr(rhs);
	  movevalue(rhs,lhs^.attr^);
	  end;
	freeregs(lhs^.attr);
	end; {with rhs^.attr^}
      end; {genassign}

    procedure substrassign(source,dest: exptr);
      var
	destisstring: boolean;
      begin
      pushsubstr(dest);
      if strgtype(dest^.arayp^.etyptr) then
	destisstring := true
      else destisstring := false;
      if source^.eclass = substrnode then
	begin
	pushsubstr(source);
	clear(false);
	if destisstring then
	  if strgtype(source^.arayp^.etyptr) then
	    callstdproc('ASM_SSUBTOSSUB')
	  else callstdproc('ASM_PSUBTOSSUB')
	else
	  if strgtype(source^.arayp^.etyptr) then
	    callstdproc('ASM_SSUBTOPSUB')
	  else callstdproc('ASM_PSUBTOPSUB');
	end
      else escape(-8);
      end;

    procedure specialassign(lhs,rhs: exptr; var done: boolean);
      begin
      genexpr(lhs);
      with lhs^,attr^ do begin
	if packd then done := false
	else if etyptr^.form = reals then done := false
	else if (rhs^.eclass in [addnode,subnode]) and
	  ((storage = bytte) or (not signbit)) then done := false
	else if RANGECHECK and ((etyptr^.form = subrange) or
	  ((etyptr^.form=scalar) and (etyptr<>intptr))) then done := false
	else with rhs^ do begin
	  makeaddressable(lhs);
	  makeaddressable(opnd2);
	  if opnd2^.eclass = litnode then
	    fixliteral(opnd2,lhs^.attr^.storage,lhs^.attr^.signbit);
	  if opnd2^.attr^.storage > lhs^.attr^.storage then done := false
	  else
	    begin
	    extend(opnd2,lhs^.attr^.storage);
	    if (opnd2^.eclass = litnode) then
	      begin
	      if (eclass in [addnode,subnode]) then
		begin
		if opnd2^.attr^.smallval <> 0 then
		  begin
		  case eclass of
		    addnode: emit2(add,opnd2^.attr^,lhs^.attr^);
		    subnode: emit2(sub,opnd2^.attr^,lhs^.attr^);
		  end; {case}
		  ovflck;
		  end;
		end
	      else {eclass in [ornode,andnode]}
		case eclass of
		  ornode: if opnd2^.attr^.smallval = 1 then
			    emit2(move,opnd2^.attr^,lhs^.attr^);
		  andnode: if opnd2^.attr^.smallval = 0 then
			     emit1(clr,lhs^.attr^);
		end; {case}
	      end
	    else {opnd2^.eclass <> litnode}
	      begin
	      loadvalue(opnd2);
	      case eclass of
		addnode: emit2(add,opnd2^.attr^,lhs^.attr^);
		subnode: emit2(sub,opnd2^.attr^,lhs^.attr^);
		ornode:  emit2(orr,opnd2^.attr^,lhs^.attr^);
		andnode: emit2(andd,opnd2^.attr^,lhs^.attr^);
		end; {case}
	      if eclass in [addnode,subnode] then ovflck;
	      end;
	    freeregs(opnd2^.attr);
	    freeregs(lhs^.attr);
	    done := true;
	    end;
	  end;
	end; {with}
      end; {specialassign}

$if bigsets$
    procedure pushlongword(i: integer);
      var op: attrtype;
      begin
      with op do
	begin
	addrmode := immediate;
	smallval := i;
	SPminus.storage := long;
	emit2(move,op,SPminus);
	end;
      end;
$end$

    procedure pushword(i: shortint);
      var op: attrtype;
      begin
      with op do
	begin
	addrmode := immediate;
	smallval := i;
	SPminus.storage := wrd;
	emit2(move,op,SPminus);
	end;
      end;

    procedure genbecomes (curstmt : stptr);
      var
	done: boolean; offsetexpr: exptr;
	op: attrtype;

      begin {genbecomes}
      with curstmt^ do
	begin
	done := false;
	if treematch(lhs,rhs) then specialassign(lhs,rhs,done);
	if not done and (rhs^.eclass = fcallnode) then
	  if (rhs^.fptr^.pfdeckind <> standard) and
	     (rhs^.fptr^.spkey = spaddr) then    { handle p := addr(...) }
	    begin makeaddressable(lhs);
	    with rhs^.actualp^,expptr^ do
	      if (eclass = derfnode) and not rangecheck then
		if branchmatch(lhs,opnd) then  { <ptr> := addr(<ptr>^... }
		  if nextptr = NIL then done := true
		  else with nextptr^,expptr^ do
		    begin done := false;
		    makeaddressable(expptr);
		    if eclass = litnode then
		      begin
		      fixliteral(expptr,long,true);
		      with litval do
			if intval and (ival = 0) then {do nothing}
			else emit2(add,expptr^.attr^,lhs^.attr^);
		      end
		    else  { offset not literal }
		      begin
		      extend(expptr,long); loadvalue(expptr);
		      emit2(add,attr^,lhs^.attr^);
		      freeit(D,attr^.regnum);
		      end;
		    done := true;
		    end;
	    if not done then  { above branchmatch failed on <ptr> }
	      begin done := true; genaddr(rhs,lhs) end;
	    freeregs(lhs^.attr);
	    end; { addr }
	if not done then
	  if lhs^.etyptr^.form = power then
	    begin
	    { set up external routine for unequal size sets }
	    if RANGECHECK then
$if bigsets$
		  begin
			pushlongword(lhs^.etyptr^.setmax);
			pushlongword(lhs^.etyptr^.setmin);
		  end;
$end$
$if not bigsets$
		  begin
		    pushword(lhs^.etyptr^.setmax);
		    pushword(lhs^.etyptr^.setmin);
		  end;
$end$
	    pushaddress(lhs) ; pushaddress(rhs);
	    if RANGECHECK then
$if bigsets$
	      callstdproc('ASM_XSETASSIGN')
$end$
$if not bigsets$
	      callstdproc('ASM_SETASSIGN')
$end$
	    else
	      callstdproc('ASM_ASSIGN');
	    clear(false);
	    end
	  else if lhs^.eclass = substrnode then
	    substrassign(rhs,lhs)
	  else if strgtype(lhs^.etyptr) then
	    stringassign(rhs,lhs)
	  else
	    begin
	    { Order is important on these genexprs }
	    if RANGECHECK then
	      begin genexpr(lhs); genexpr(rhs); end
	    else
	      begin genexpr(rhs); genexpr(lhs); end;
	    if (lhs^.etyptr^.form = prok) and (rhs^.ekind = cnst) then
	      begin
	      makeaddressable(lhs);
	      lhs^.attr^.storage := long;
	      if isoverlay(rhs^.symptr,getaddress) then { OVERLAY MODULE }
		emit2(move,SPplus,lhs^.attr^)
	      else
		moveaddress(rhs,lhs^.attr^);
	      with lhs^.attr^ do
		begin
		offset := offset+4;
		with rhs^.symptr^ do
		  if pflev > 1 then movestatic(pflev,lhs^.attr^)
		  else emit1(clr,lhs^.attr^);
		offset := offset-4;
		freeregs(lhs^.attr);
		end;
	      end
	    else if paofchar(lhs^.etyptr) then
	      movemulti(rhs,lhs,lhs^.etyptr^.unpacksize)
	    else if rhs^.attr^.addrmode = inFreg then
	      begin
	      makeaddressable(lhs);
	      moverealvalue(rhs,lhs^.attr^);
	      freeregs(lhs^.attr);
	      end
	    else if lhs^.etyptr^.form = cnfarrays then
	      cnfassign(lhs,rhs)
	    else if lhs^.attr^.storage = multi then
	      movemulti(rhs,lhs,
		   min(lhs^.etyptr^.unpacksize, rhs^.etyptr^.unpacksize) )
	    else genassign(lhs,rhs);
	    end; { not power }
      end {with}
      end; {genbecomes}

    procedure genspecialfor(curstmt: stptr; var done: boolean);
      var
	lab: addrrange;
	op: attrtype;
      begin
      done := true;
      with curstmt^ do
	begin
	genexpr(init);
	genexpr(limit);
	if ((incr=1) and
	  (init^.litval.ival>limit^.litval.ival))
	  or
	  ((incr=-1) and
	  (init^.litval.ival<limit^.litval.ival)) then
	  done := false;
	if done then {this is a special FOR stmt}
	  with ctrl^.attr^ do
	    begin
	    init^.attr^.smallval := init^.attr^.smallval - incr;
	    fixliteral(init,storage,signbit);
	    fixliteral(limit,storage,signbit);

	    genassign(ctrl,init);

	    lab := codephile.bytecount;
	    with op do
	      begin addrmode := immediate; smallval := 1; end;
	    if incr = 1 then emit2(addq,op,ctrl^.attr^)  { ADDQ #1,ctrl }
			else emit2(subq,op,ctrl^.attr^); { SUBQ #1,ctrl }
	    clear(false);
	    gencode(fbody);
	    emit2(cmpi,limit^.attr^,ctrl^.attr^);    { CMPI limit,cntrl }
	    { calculate pc relative jump to lab }
	    getbrattr(lab,true,op);
	    if signbit then
	      if incr = 1 then emit1(blt,op)        { Bcc lab }
			  else emit1(bgt,op)
	    else {unsigned test}
	      if incr = 1 then emit1(bcs,op)
			  else emit1(bhi,op);
	    end; { with ctrl^.attr^ }
	end; { with curstmt^ }
      end; { genspecial for }

    procedure genfor (curstmt : stptr);
      var
	op,opp: attrtype;
	min,max: integer;
	lab1,limitoffset : addrrange;
	lab2ref : localref;
	r : regrange;
	done,trangecheck : boolean;
	savestorage : stortype;
      begin
	with curstmt^ do
	  begin
	  genexpr(ctrl);
	  done := false;
	  if (limit^.eclass = litnode) and (init^.eclass = litnode) then
	    genspecialfor(curstmt,done);
	  { check done flag to see if genspecialfor generated code }
	  if not done then with ctrl^.attr^ do
	    begin
	    makeaddressable(init);
	    if init^.eclass = litnode then fixliteral(init,storage,signbit);
	    loadvalue(init);
	    makeaddressable(limit);
	    if limit^.eclass = litnode then fixliteral(limit,storage,signbit);

	    if init^.attr^.storage < storage then extend(init,storage);
	    if (not init^.attr^.signbit) and (init^.attr^.storage = wrd) then
	      extend(init,long);
	    if limit^.attr^.storage < init^.attr^.storage then
	      extend(limit,init^.attr^.storage);
	    if (not limit^.attr^.signbit) and (limit^.attr^.storage = wrd) then
	      extend(limit,long);
	    if init^.attr^.storage < limit^.attr^.storage then
	      extend(init,limit^.attr^.storage);

	    if limit^.eclass <> litnode then
	      begin
	      op.storage := limit^.attr^.storage;
	      case op.storage of
		bytte: getlocstorage(1,op);
		wrd: getlocstorage(2,op);
		long: getlocstorage(4,op);
	      end;
	      emit2(move,limit^.attr^,op);
	      if limit^.attr^.addrmode <> inDreg then
		with limit^.attr^ do
		  begin
		  addrmode := locinreg;
		  indexed := false;
		  packd := false;
		  access := direct;
		  offset := op.offset;
		  regnum := op.regnum;
		  gloptr := op.gloptr;
		  end;
	      end;

	    lab2ref.next := NIL;

	    if RANGECHECK then
	      if needscheck(init,ctrl^.etyptr,true) or
		 needscheck(limit,ctrl^.etyptr,true) then
		begin
		if limit^.eclass = litnode then
		  emit2(cmpi,limit^.attr^,init^.attr^)
		else
		  emit2(cmp,op,init^.attr^);             { CMP   temp,initregnum }

		{ branch corresponding to increment }
		new(lab2ref.next);
		lab2ref.next^.next := nil;
		getbrattr(lab2ref.next^.pc,false,opp);
		if limit^.attr^.signbit then
		  if incr = 1 then emit1(bgt,opp)         { Bcc lab2 }
			      else emit1(blt,opp)
		else
		  if incr = 1 then emit1(bhi,opp)
			      else emit1(bcs,opp);
		getbounds(ctrl^.etyptr,min,max);
		if (min = 0) and ((max > 32768) or
		   (init^.attr^.storage = long)) then
		  emit1(tst,init^.attr^);
		savestorage := init^.attr^.storage;
		emitcheck(init,ctrl^.etyptr,true);
		init^.attr^.storage := savestorage;

		if (min = 0) and (limit^.attr^.storage = long) and
		   (limit^.attr^.addrmode = inDreg) then
		  emit1(tst,limit^.attr^);
		emitcheck(limit,ctrl^.etyptr,true);
		limit^.attr^.storage := savestorage;
		end;

	    lab1 := codephile.bytecount;
	    if limit^.eclass = litnode then
	      emit2(cmpi,limit^.attr^,init^.attr^)
	    else
	      emit2(cmp,op,init^.attr^);             { CMP   temp,initregnum }

	    { branch corresponding to increment }
	    getbrattr(lab2ref.pc,false,op);
	    if limit^.attr^.signbit then
	      if incr = 1 then emit1(bgt,op)         { Bcc lab2 }
			  else emit1(blt,op)
	    else
	      if incr = 1 then emit1(bhi,op)
			  else emit1(bcs,op);

	    trangecheck := RANGECHECK;
	    RANGECHECK := false;
	    genassign(ctrl,init);
	    RANGECHECK := trangecheck;

	    clear(false);
	    gencode(fbody);    { emit FOR body }
	    {insure that init^.attr^.regnum is the next register to be used}
	    repeat r := getreg(D);
	    until r = init^.attr^.regnum;
	    freeit(D,r);
	    if storage < limit^.attr^.storage then
	      extend(ctrl,limit^.attr^.storage);
	    loadvalue(ctrl);

	    with op do
	      begin addrmode := immediate; smallval := 1; end;
	    if incr = 1 then emit2(addq,op,ctrl^.attr^)
			else emit2(subq,op,ctrl^.attr^);

	    getbrattr(lab1,true,op);
	    if not signbit then emit1(bcc,op)        { Bcc lab }
			   else emit1(bvc,op);
	    { lab2 }
	    fixreflist(addr(lab2ref));
	    end; { with ctrl^.attr^ }
	  end; { with curstmt^ }
	clear(false);
      end; { genfor }

procedure genproc(psymptr: ctp; actualp: elistptr);
  var
    lexp,source,dest,length,letter: exptr;
    checkstp: stp;
    packunpackcount : integer;
    datatype,pname: string[9];
    testptr,parmptr: elistptr;
    packing,extending,formatting,checking,
      isenumtype,isstrgtype,ispaoc,mustinit,
      newesccode,iseolproc,iswrite: boolean;
    op1,op2: attrtype;
    filestorage: stortype;
    destmax,lobound,hibound: integer;
    sizeofpaoc: shortint;


  procedure pushwidth(parmptr: elistptr);
    begin
    with parmptr^ do
      if expptr=NIL then
	pushword(-1)
      else
	begin
	if rangecheck and
	   ((expptr^.eclass <> litnode) or not expptr^.litval.intval) then
	  emitcheck(expptr,char_ptr,true);
	extend(expptr,wrd);
	pushvalue(expptr);
	end;
    end;

  procedure pushstring(fexp: exptr);
    begin
    if strgtype(fexp^.etyptr) then
      pushaddress(fexp)
    else
      begin
      { 255 is an arbitrary number so that
	an excessive amount of temp space
	is not used }
      sizeofpaoc := min(255,fexp^.etyptr^.unpacksize);
      getlocstorage(sizeofpaoc+1,op1);
      with op2 do
	begin
	addrmode := immediate;
	smallval := sizeofpaoc;
	end;
      op1.storage := bytte;
      emit2(move,op2,op1);
      emit1(pea,op1);
      pushaddress(fexp);
      op1.offset := op1.offset + 1;
      emit1(pea,op1);
      SPminus.storage := long;
      emit2(move,op2,Spminus);
      clear(false);
      callstdproc('ASM_MOVEL');
      op1.offset := op1.offset - 1;
      emit1(pea,op1);
      emit1(pea,op1);
      callstdproc('ASM_STRRTRIM');
      end;
    end;

  begin {genproc}
  with psymptr^ do
    if klass = routineparm then
      callvar(psymptr^.proktype^.params,actualp,false)
    else if pfdeckind = declared then
      begin pushparms(next,actualp);
      if pflev > 1 then
	begin SPminus.storage := long;
	movestatic(pflev,SPminus);
	end;
      if not isoverlay(psymptr,gencall) then
	begin
	getprokconst(psymptr,op1);
	emit1(jsr,op1);
	end;
      clear(false);
      end
    else
      case spkey of
	spsetstrlen:
	  begin dest := actualp^.expptr;
	  source := actualp^.nextptr^.expptr;
	  makeaddressable(source);
	  genexpr(dest);
	  if rangecheck then
	    begin destmax := dest^.etyptr^.maxleng;
	    checking := true;
	    if dest^.etyptr=strgptr then
	      begin  {var string}
	      with dest^.attr^ do
		begin access := direct;
		storage := bytte;
		signbit := false;
		offset := offset+4;
		end;
	      if source^.eclass = litnode then
		fixliteral(source,bytte,true);
	      if source^.attr^.storage>bytte then
		extend(dest,source^.attr^.storage);
	      loadvalue(source);
	      if (source^.attr^.storage=bytte) and
		 (source^.attr^.signbit) then
		begin
		with op1 do
		  begin offset := 6; storage := bytte end;
		emit1(blt,op1);
		end;
	      emit2(cmp,dest^.attr^,source^.attr^);
	      dest^.attr := NIL;
	      end
	    else if source^.attr^.addrmode <> immediate then
	      begin   {not var string}
	      with op1 do
		begin addrmode := immediate;
		smallval := destmax;
		end;
	      with source^, attr^ do
		if addrmode = topofstack then
		  begin
		  SPind.storage := storage;
		  emit2(cmpi,op1,SPind);
		  end
		else
		  emit2(cmpi,op1,attr^);
	      end
	    else checking := false;
	    if checking then
	      begin
	      with op1 do
		begin offset := 2; storage := bytte end;
	      emit1(bls,op1);
	      op1.smallval := 7;
	      emit1(trap,op1);
	      end;
	    end; {rangecheck}
	  makeaddressable(dest);
	  dest^.attr^.storage := bytte;
	  extend(source,bytte);
	  emit2(move,source^.attr^,dest^.attr^);
	  freeregs(source^.attr);
	  freeregs(dest^.attr);
	  end;
	spseek:
	  begin pushaddress(actualp^.expptr);
	  with actualp^.nextptr^ do
	    begin extend(expptr,long);
	    pushvalue(expptr);
	    end;
	  callIOproc('FS_FSEEK');
	  clear(false);
	  end;
	sppage:
	  begin
	  pushaddress(actualp^.expptr);
	  callIOproc('FS_FPAGE');
	  clear(false);
	  end;
	spclose:
	  with actualp^ do
	    begin
	    pushaddress(expptr);
	    pushstring(nextptr^.expptr);
	    callIOproc('FS_FCLOSEIT');
	    clear(false);
	    end;
	spgotoxy:
	  with actualp^ do
	    begin
	    pushaddress(expptr);
	    extend(nextptr^.expptr,long);
	    pushvalue(nextptr^.expptr);
	    extend(nextptr^.nextptr^.expptr,long);
	    pushvalue(nextptr^.nextptr^.expptr);
	    callstdproc('FS_FGOTOXY');
	    clear(false);
	    end;
	spunitwait,spunitclear,spget,
	spput,spnewwords,
	spdelete,spstrdelete,spstrappend,
	spinsert,spstrinsert:
	  begin
	  pushparms(next,actualp);
	  if (spkey>=spstrdelete)
	     and (spkey<=spstrappend) or
	     (spkey = spdelete) or
	     (spkey = spinsert) then
	    case spkey of
	      spdelete,
	      spstrdelete:
		callstdproc('ASM_DELETE');
	      spinsert,
	      spstrinsert:
		callstdproc('ASM_INSERT');
	      spstrappend:
		callstdproc('ASM_SAPPEND');
	      end
	  else
	    if (spkey=spget) or (spkey=spput) then
	      callIOproc('FS_F' + psymptr^.namep^)
	  else
	    case spkey of
	      spunitwait,
	      spunitclear:
		callstdproc('UIO_' + psymptr^.namep^);
	      spnewwords:
		callstdproc('ASM_NEWWORDS');
	    end;
	  clear(false);
	  end;
	spnew:
	  with actualp^ do
	    begin
	    pushaddress(expptr);
	    mustinit := mustinitialize in
		    expptr^.etyptr^.eltype^.info;
	    if mustinit then
	      begin
	      getlocstorage(ptrsize,op1);
	      op1.storage := long;
	      emit2(move,SPind,op1);
	      end;
	    pushvalue(nextptr^.expptr);
	    if heapdispose then
	      callstdproc('HPM_NEW')
	    else
	      callstdproc('ASM_NEWBYTES');
	    clear(false);
	    if mustinit then
	      begin
	      op2 := op1;
	      op1.access := indirect;
	      expptr^.attr := addr(op1);
	      loadaddress(expptr,false);
	      expptr^.attr^.access := indirect;
	      moveaddress(expptr,op2);
	      op2.access := indirect;
	      expptr^.attr := addr(op2);
	      initlocvar(NIL,expptr,0,expptr^.etyptr^.eltype,isnew);
	      clear(false);
	      end;
	    end;
	spdispose:
	  with actualp^ do
	    begin
	    makeaddressable(expptr);
	    mustinit := mustinitialize in
		expptr^.etyptr^.eltype^.info;
	    if mustinit then
	      begin
	      getlocstorage(ptrsize,op1);
	      op1.storage := long;
	      emit2(move,expptr^.attr^,op1);
	      end;
	    if heapdispose then
	      begin
	      pushaddress(expptr);
	      pushvalue(nextptr^.expptr);
	      callstdproc('HPM_DISPOSE');
	      clear(false);
	      end
	    else
	      begin
	      emit1(clr,expptr^.attr^);
	      freeregs(expptr^.attr);
	      end;
	    if mustinit then
	      begin
	      op1.access := indirect;
	      expptr^.attr := addr(op1);
	      initlocvar(NIL,expptr,0,expptr^.etyptr^.eltype,isdispose);
	      clear(false);
	      end;
	    end;
	spmark:
	  begin
	  makeaddressable(actualp^.expptr);
	  if heapdispose then
	    begin
	    pushaddress(actualp^.expptr);
	    callstdproc('HPM_MARK');
	    clear(false);
	    end
	  else
	    begin
	    SBind.offset := heapptrdisp;
	    SBind.gloptr := sysglobalptr;
	    emit2(move,SBind,actualp^.expptr^.attr^);
	    SBind.gloptr := NIL;
	    end;
	  end;
	sprelease:
	  begin
	  makeaddressable(actualp^.expptr);
	  if heapdispose then
	    begin
	    pushvalue(actualp^.expptr);
	    callstdproc('HPM_RELEASE');
	    clear(false);
	    end
	  else
	    begin
	    SBind.offset := heapptrdisp;
	    SBind.storage := long;
	    SBind.gloptr := sysglobalptr;
	    emit2(move,actualp^.expptr^.attr^,SBind);
	    SBind.gloptr := NIL;
	    end;
	  end;
	spwrite,spwriteln,spwritedir,spstrwrite,
	spprompt,spread,spreadln,spreaddir,
	spstrread,spoverprint:
	  begin
	  source := actualp^.expptr;
	  iseolproc := (spkey = spreadln) or
		       (spkey = spwriteln) or
		       (spkey = spoverprint);
	  iswrite := spkey in
		   [spwritedir,spwriteln,spwrite,
		   spstrwrite,spprompt,spoverprint];
	  if iswrite then pname := 'WRITE'
	  else pname := 'READ';
	  formatting := (source^.etyptr = textptr) or
			(spkey = spstrread) or
			(spkey = spstrwrite);
	  if not formatting then
	    begin datatype := '';
	    filestorage :=
	      getstorageinfo(source^.etyptr^.filtype);
	    end;
	  if spkey = spstrwrite then
	    pushvarstring(source)
	  else pushaddress(source);
	  parmptr := actualp^.nextptr;
	  if (spkey = spreaddir)
	      or (spkey = spwritedir) then
	    begin {first seek desired record}
	    SPminus.storage := long;
	    emit2(move,SPind,SPminus);
	    extend(parmptr^.expptr,long);
	    pushvalue(parmptr^.expptr);
	    callIOproc('FS_FSEEK');
	    clear(false);
	    parmptr := parmptr^.nextptr;
	    end
	  else if (spkey = spstrwrite) or
		  (spkey = spstrread) then
	    with parmptr^ do
	      begin
	      if not branchmatch
		    (expptr,nextptr^.expptr) then
		begin extend(expptr,long);
		loadaddress(nextptr^.expptr,false);
		movevalue(expptr,nextptr^.expptr^.attr^);
		end;
	      pushaddress(nextptr^.expptr);
	      parmptr := nextptr^.nextptr;
	      end;

	  while parmptr<>NIL do {process params}
	    with parmptr^,expptr^ do
	      begin
	      checking := false;
	      if not ISWRITE then
		begin checkstp := etyptr;
		if etyptr^.form = subrange then
		  etyptr := etyptr^.rangetype;
		end;
	      SPminus.storage := long;
	      if iseolproc then emit2(move,SPind,SPminus)
	      else if ISWRITE then
		begin {last value?}
		if not formatting then
		  testptr := parmptr^.nextptr
		else
		  begin testptr := parmptr^.nextptr^.nextptr;
		  if etyptr = realptr then
		    testptr := testptr^.nextptr;
		  end;
		if testptr <> NIL then
		  if (spkey <> spstrwrite) and
		     (spkey <> spstrread) then
		    emit2(move,SPind,SPminus)
		  else
		    begin {copy var string}
		    op2 := SPind;
		    op2.offset := 8;
		    SPminus.storage := wrd;
		    emit2(move,op2,SPminus);
		    SPminus.storage := long;
		    op2.offset := 6;
		    emit2(move,op2,SPminus);
		    emit2(move,op2,SPminus);
		    end;
		end
	      else  {READ, etc}
		if parmptr^.nextptr <> NIL then
		  if spkey <> spstrread then
		    emit2(move,SPind,SPminus)
		  else
		    begin op2 := SPind;
		    op2.offset := 4;
		    emit2(move,op2,SPminus);
		    emit2(move,op2,SPminus);
		    end;
	      isenumtype := enumtype(etyptr);
	      isstrgtype := strgtype(etyptr);
	      ispaoc := paofchar(etyptr) and not isstrgtype;

	      if ISWRITE then
		begin packing := false;
		extending := false;
		makeaddressable(expptr); {allocate attr record}
		if formatting then
		  begin
		  if ((etyptr=intptr) or
		      (etyptr=shortintptr)) and
		     ((attr^.storage=bytte) or
		      not(attr^.signbit)) then
		    if attr^.storage <> long then
		      extend(expptr,succ(attr^.storage));
		  if (etyptr=intptr) or
		     (etyptr=shortintptr) then
		    pushvalue(expptr)
		  else if isenumtype then
		    begin
		    extend(expptr,wrd);
		    pushvalue(expptr);
		    end
		  else if (etyptr=char_ptr) or
		      (etyptr=boolptr) then
		    begin
		    extend(expptr,bytte);
		    if etyptr=boolptr then
		      maskboolexpr(expptr);
		    pushvalue(expptr);
		    end
		  else if etyptr=realptr then
		    pushaddress(expptr)
		  else
		    begin {strg,paoc}
		    pushaddress(expptr);
		    if not isstrgtype then
		      pushword(etyptr^.unpacksize);
		    end;
		  {process width specification}
		  parmptr := parmptr^.nextptr;
		  pushwidth(parmptr);
		  if etyptr = realptr then
		    begin
		    parmptr := parmptr^.nextptr;
		    pushwidth(parmptr);
		    end;
		  end  {formatting}
		else
		  begin {binary write}
		  if rangecheck then
		    emitcheck(expptr,source^.etyptr^.filtype,true);
		  extend(expptr,filestorage);
		  if not (attr^.addrmode in memorymodes)  then
		    begin
		    new(lexp);
		    lexp^ := expptr^;
		    getattrec(lexp);
		    getlocstorage(source^.etyptr^.filtype^.unpacksize,
				lexp^.attr^);
		    lexp^.attr^.storage := filestorage;
		    movevalue(expptr,lexp^.attr^);
		    pushaddress(lexp);
		    end
		  else pushaddress(expptr);
		  end;{binary write}
		end {ISWRITE}
	      else {READ,readln,readdir,strread}
		begin
		genexpr(expptr);
		packing := attr^.packd;
		if formatting then
		  extending :=
		    getstorageinfo(etyptr) <> attr^.storage
		else
		  extending :=
		    (filestorage <> attr^.storage) or
		    isstrgtype;
		if packing or extending then
		  begin
		  saveregs;
		  new(lexp);
		  lexp^ := expptr^;
		  getattrec(lexp);
		  if extending and not formatting then
		    begin
		    getlocstorage(source^.etyptr^.
			  filtype^.unpacksize,lexp^.attr^);
		    lexp^.attr^.storage := filestorage;
		    lexp^.eclass := idnode;
		    lexp^.symptr := NIL;
		    end
		  else
		    begin
		    getlocstorage(etyptr^.unpacksize,
					  lexp^.attr^);
		    lexp^.attr^.storage := getstorageinfo(etyptr);
		    end;
		  pushaddress(lexp);
		  end
		else if formatting and isstrgtype then
		  pushvarstring(expptr)
		else
		  begin
		  if RANGECHECK then
		    if needscheck(expptr,checkstp,true) then
		      begin
		      checking := true;
		      loadaddress(expptr,false);
		      saveregs;
		      SPminus.storage := long;
		      attr^.addrmode := inAreg;
		      emit2(move,attr^,SPminus);
		      attr^.addrmode := locinreg;
		      end
		    else pushaddress(expptr)
		  else pushaddress(expptr);
		  if formatting then
		    if ispaoc then
		      pushword(etyptr^.unpacksize);
		  end;
		end; {READ etc.}
	      if isenumtype and formatting then
		with op1 do
		  begin addrmode := enumconst;
		  offset := 0;
		  enumstp := etyptr;
		  poolenum(etyptr);
		  emit1(pea,op1);
		  end;
	      if formatting then
		if etyptr = char_ptr then datatype := 'CHAR'
		else if etyptr = boolptr then datatype := 'BOOL'
		else if etyptr = realptr then datatype := 'REAL'
		else if isenumtype then datatype := 'ENUM'
		else if isstrgtype then datatype := 'STR'
		else if ispaoc then datatype := 'PAOC'
		else { int, shortint }
		  if ISWRITE then
		    if attr^.storage = wrd then
		      datatype := 'WORD'
		    else datatype := 'INT'
		  else { reading }
		    if etyptr = shortintptr then
		      datatype := 'WORD'
		    else datatype := 'INT';
	      if (spkey = spstrwrite) or
		 (spkey = spstrread) then
		datatype := 'STR' + datatype;
	      if (etyptr = realptr) and formatting then
		callIOproc('MFS_F' + pname + datatype)
	      else callIOproc('FS_F' + pname + datatype);
	      if packing or extending then
		begin reloadregs;
		if rangecheck then
		  emitcheck(lexp,checkstp,true);
		if packing then pack(expptr,lexp)
		else
		  begin
		  makeaddressable(expptr);
		  if isstrgtype then
		    stringassign(lexp,expptr)
		  else
		    begin
		    extend(lexp,attr^.storage);
		    movevalue(lexp,attr^);
		    freeregs(attr);
		    end;
		  end;
		end
	      else if checking then
		begin
		reloadregs;
		emitcheck(expptr,checkstp,true);
		end;
	      clear(false);
	      parmptr := parmptr^.nextptr;
	      end; {while parmptr<>NIL...}

	  if iseolproc then
	    begin
	    if spkey=spreadln then pname := 'READLN'
	    else if spkey=spwriteln then pname := 'WRITELN'
	    else pname := 'OVERPRINT';
	    callIOproc('FS_F' + pname);
	    clear(false);
	    end;
	  end;
	spcall:
	  callvar(actualp^.expptr^.etyptr^.params,
		  actualp,false);
	spescape:
	  with actualp^,expptr^ do
	    begin newesccode := true;
	    if eclass = fcallnode then
	      if fptr^.pfdeckind <> declared then
		if fptr^.spkey = spesccode then newesccode := false;
	    if newesccode then {  not 'escape(escapecode)'  }
	      begin
	      if rangecheck then
		emitcheck(expptr,shortintptr,true);
	      extend(expptr,wrd);
	      makeaddressable(expptr);
	      SBind.storage := wrd;
	      SBind.offset := escapecodedisp;
	      SBind.gloptr := sysglobalptr;
	      emit2(move,attr^,SBind);
	      SBind.gloptr := NIL;
	      end;
	    op1.smallval := 10;
	    emit1(trap,op1);
	    end;
	sphalt:
	  begin
	  SBind.storage := wrd;
	  SBind.offset := escapecodedisp;
	  SBind.gloptr := sysglobalptr;
	  if actualp <> NIL then
	    with actualp^, expptr^ do
	      begin
	      if rangecheck then
		emitcheck(expptr,shortintptr,true);
	      extend(expptr,wrd);
	      makeaddressable(expptr);
	      emit2(move,attr^,SBind);
	      end
	  else
	    emit1(clr,SBind);
	  op1.smallval := 10;
	  emit1(trap,op1);
	  SBind.gloptr := NIL;
	  end;
	spfillchar:
	  begin
	  with actualp^ do
	    begin dest := expptr;
	    length := nextptr^.expptr;
	    letter := nextptr^.nextptr^.expptr;
	    end;
	  loadaddress(dest,false); {  dest addr  }
	  loadvalue(letter); {  char  }
	  loadvalue(length);
	  op1.storage := bytte;
	  op1.offset := 6;
	  emit1(ble,op1);                         { BLE.S *+8 }
	  with dest^.attr^ do
	    begin addrmode := postincr; storage := bytte; end;
	  emit2(move,letter^.attr^,dest^.attr^);  { MOVE.B letter,<dest> }
	  with op1 do
	    begin addrmode := immediate; smallval := 1; end;
	  emit2(subq,op1,length^.attr^);          { SUBQ #1,length }
	  op1.offset := -6;
	  op1.storage := bytte;
	  emit1(bgt,op1);                         { BGT.S *-4 }
	  clear(false); { register contents will be invalid }
	  end; {fillchar}
	spmoveleft, spmoveright:
	  begin
	  with actualp^ do
	    begin
	    source := expptr;
	    dest   := nextptr^.expptr;
	    length := nextptr^.nextptr^.expptr;
	    end;
	  pushaddress(source);
	  pushaddress(dest);
	  extend(length,long);
	  pushvalue(length);
	  clear(false); { register contents will be invalid }
	  if spkey = spmoveright then
	    callstdproc('ASM_MOVER')
	  else
	    callstdproc('ASM_MOVEL');
	  end; { moveleft, moveright }
	sprewrite,spreset,spopen,spappend:
	  begin
	  pushaddress(actualp^.expptr);     {file}
	  parmptr := actualp^.nextptr;
	  with op1 do
	    begin
	    addrmode := immediate;
	    smallval := ord(spkey)-ord(spreset);
	    end;
	  SPminus.storage := wrd;
	  emit2(move,op1,SPminus);
	  if parmptr = NIL then
	    callIOproc('FS_FHPRESET')
	  else
	    begin
	    pushstring(parmptr^.expptr);
	    pushstring(parmptr^.nextptr^.expptr);
	    callIOproc('FS_FHPOPEN');
	    end;
	  clear(false);
	  end;
	spunitread,spunitwrite:
	  begin extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {unit number}
	  actualp:=actualp^.nextptr; pushaddress(actualp^.expptr);
							   {buffer}
	  actualp:=actualp^.nextptr; extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {length}
	  actualp:=actualp^.nextptr; extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {blocknumber}
	  actualp:=actualp^.nextptr; extend(actualp^.expptr,long);
	  pushvalue(actualp^.expptr);                      {async}
	  if spkey = spunitread then
	     callstdproc('UIO_UNITREAD')
	  else callstdproc('UIO_UNITWRITE');
	  clear(false);
	  end;
	sppack,spunpack:
	  with actualp^ do
	    begin
	    op1.addrmode := immediate;
	    getbounds(nextptr^.expptr^.etyptr^.inxtype,lobound,hibound);
	    packunpackcount := hibound - lobound + 1; {Z array bounds}
	    if RANGECHECK and (expptr^.indxp^.eclass <> litnode) then
	      { Check array subscript < lower bound and
		array subscript + count > upper bound }
	      begin
	      getbounds(expptr^.arayp^.etyptr^.inxtype,lobound,hibound);
	      new(checkstp);
	      with checkstp^ do
		begin
		form := subrange;
		min := lobound;
		max := hibound - packunpackcount + 1;
		end;
	      emitcheck(expptr^.indxp,checkstp,false);
	      end;
	    if spkey = spunpack then { push boolean, signed or unsigned }
	      begin
	      if nextptr^.expptr^.etyptr^.aeltype^.signbit then
		op1.smallval := 1
	      else op1.smallval := 0;
	      SPminus.storage := bytte;
	      emit2(move,op1,SPminus);    {move.b 1/0, -(SP) }
	      end;
	    op1.smallval := expptr^.arayp^.etyptr^.aelsize;
	    checking := RANGECHECK;
	    RANGECHECK := false;     { already range checked subscript }
	    pushaddress(expptr);          {address of A[i] }
	    RANGECHECK := checking;
	    pushaddress(nextptr^.expptr); {address of Z }
	    SPminus.storage := wrd;
	    emit2(move,op1,SPminus);      {move.w unpacksize,-(SP) }
	    op1.smallval := nextptr^.expptr^.etyptr^.aelbitsize;
	    emit2(move,op1,SPminus);      {move.w fieldwidth,-(SP) }
	    op1.smallval := packunpackcount;
	    SPminus.storage := long;
	    emit2(move,op1,SPminus);      {move.l count,-(SP) }
	    if spkey = sppack then
	      callstdproc('ASM_PACK')
	    else callstdproc('ASM_UNPACK');
	    clear(false);
	    end;
	otherwise escape(-8);
	end; {case}
  end; {genproc}

procedure gencase(curstmt:stptr);
  label 1;
  const
    bigcase = 256; bigcasestr = '256';
    warnthresh = 100; warnfactor = 2;
  var
    otherref1,otherref2: localref;
    lnomatch,lout,ljmptab:   addrrange;
    exitcaserefs,otherlist,p: reflistptr;
    stmt,nextstmt:           stptr;
    curclabp:                clabptr;
    i:                       integer;
    minval,maxval,maxrefs,
    tablesize,nomatchrefs:   integer;
    holes,unsignedselecter:  boolean;
    op1,op2:                 attrtype;

  procedure assigncasentry ( var list: reflistptr );
    { assign the current case table entry to the "list" }
    var
      p: reflistptr;
    begin
      new(p);
      with p^ do
	begin
	pc := codephile.bytecount;
	next := list;
	list := p;
	end;
    end;

  procedure checkcase(at: attrptr; i: integer);
    { Check the case selecter in "at" to make sure
      it is less than or equal to "i" }
    var
      op: attrtype;
      p : reflistptr;
    begin
      if RANGECHECK then
	begin
	new(p);
	p^.next := NIL;
	getbrattr(p^.pc,false,op);
	emit1(blt,op);
	with op do
	  begin addrmode := immediate; smallval := i; end;
	emit2(cmpi,op,at^);
	with op do
	  begin offset := 2; storage := bytte end;
	emit1(ble,op);
	op.smallval := 6;
	fixreflist(p);
	emit1(trap,op);                   { TRAP #6 }
	end; { else }
    end;

  begin { gencase }
    with curstmt^ do
      begin
      makeaddressable(selecter);
      maskboolexpr(selecter);
      with selecter^.attr^ do
	begin
	if storage = bytte then extend(selecter,wrd)
	else if not signbit and (otherwyse = NIL) and (minval <> 0) then
	  extend(selecter,long);
	loadvalue(selecter);
	end;
      otherlist := NIL;
      exitcaserefs := NIL;
      holes := false;
      if minlab <> NIL then begin
	minval := minlab^.lowval;
	maxval := maxlab^.hival;
	$RANGE ON$
	  try
	    tablesize := maxval-minval+1;
	    if tablesize > bigcase then
	      warning(linenum,'case table contains more than ' + bigcasestr +
			      ' entries');
	  recover
	    if escapecode = -4 { integer overflow } then
	      begin
	      error(679);
	      goto 1;
	      end
	    else
	      escape(escapecode);
	$IF not rangechecking$
	  $RANGE OFF$
	$END$
	if minval <> 0 then    {normalize}
	  with op1 do
	    begin
	    addrmode := immediate; smallval := minval;
	    emit2(sub,op1,selecter^.attr^);
	    end;

	{ check minval<=selecter<=maxval }
	with op1 do
	  begin addrmode := immediate; smallval := maxval-minval; end;
	if (otherwyse = NIL) then checkcase(selecter^.attr,op1.smallval)
	else
	  begin
	  unsignedselecter := not selecter^.attr^.signbit;
	  otherref1.next := NIL;
	  getbrattr(otherref1.pc,false,op2);
	  if unsignedselecter then emit1(bcs,op2)        { BLT otherwise }
			      else emit1(blt,op2);
	  emit2(cmp,op1,selecter^.attr^);                { CMP #max,select }
	  otherref2.next := NIL;
	  getbrattr(otherref2.pc,false,op2);
	  if unsignedselecter then emit1(bhi,op2)        { BGT otherwise }
			      else emit1(bgt,op2);
	  end;
	$IF not MC68020$
	with op1 do
	  begin addrmode := immediate; smallval := 1; end;
	emit2(asl,op1,selecter^.attr^);                  { ASL #1,select }
	$END$
	with op1 do
	  begin
	  addrmode := prel; offset := 6; indexed := true;
	  indexreg := selecter^.attr^.regnum; indexstorage := wrd;
	  $IF MC68020$
	    indexscale := 1;
	  $END$
	  end;
	getregattr(D,op2);
	op2.storage := wrd;
	emit2(move,op1,op2);
	freeit(D,selecter^.attr^.regnum);
	with op1 do
	  begin
	  offset := 2;
	  indexreg := op2.regnum;
	  $IF MC68020$
	  indexscale := 0;
	  $END$
	  end;
	emit1(jmp,op1);            { emit indexed jump into table }
	freeit(D,op1.indexreg);

	{ initialize the list of table refs for each case stmt }
	stmt := firstmt;
	while stmt <> NIL do
	  with stmt^ do
	    begin tablelist := NIL; stmt := next; refcount := 0 end;

	{ emit jump table }
	ljmptab := codephile.bytecount;
	curclabp := minlab; i := minval; nomatchrefs := 0;
	while curclabp <> NIL do
	  begin
	  with curclabp^ do
	    begin
	    while i <= hival do
	      with cstmt^ do
		begin
		assigncasentry(tablelist);
		outputcodeword(codephile.bytecount - ljmptab);
		refcount := refcount+1;
		i := i+1;
		end;
	    curclabp := clabp;
	    end;
	  if curclabp <> NIL then
	    with curclabp^ do
	      while i < lowval do
		begin
		assigncasentry(otherlist);
		outputcodeword(codephile.bytecount - ljmptab);
		nomatchrefs := nomatchrefs+1;
		holes := true;
		i := i+1;
		end;
	  end; { while curclabp <> NIL }
	  releaseattr;

	{generate code for cases}
	with firstmt^ do
	  begin
	  fixreflist(tablelist);
	  maxrefs := refcount;
	  nextstmt := next;
	  next := NIL;
	  end;
	gencode(firstmt);
	stmt := nextstmt;
	while stmt <> NIL do
	  begin
	  new(p);
	  getbrattr(p^.pc,false,op1);
	  p^.next := exitcaserefs;
	  exitcaserefs := p;
	  emit1(bra,op1);                       { BRA out of case }
	  with stmt^ do
	    begin
	    fixreflist(tablelist);
	    nextstmt := next;
	    next := NIL;
	    clear(false);
	    if maxrefs < refcount then maxrefs := refcount;
	    end;
	  gencode(stmt);
	  stmt := nextstmt;
	  end;
	end; {if minlab <> NIL}
      if holes or (otherwyse <> NIL) then
	begin
	new(p);
	getbrattr(p^.pc,false,op1);
	p^.next := exitcaserefs;
	exitcaserefs := p;
	emit1(bra,op1);                       { BRA out of case }
	if holes and (otherlist <> NIL) then fixreflist(otherlist);
	if otherwyse <> NIL then
	  begin
	  clear(false);
	  fixreflist(addr(otherref1));
	  fixreflist(addr(otherref2));
	  gencode(otherwyse);
	  end
	else {holes only}
	  if RANGECHECK then with op1 do
	    begin
	    smallval := 6;
	    emit1(trap,op1);                          { TRAP #6 }
	    end;
	if maxrefs < nomatchrefs then maxrefs := nomatchrefs;
	end;

      {fix up all branches to the end of the case stmt}
      fixreflist(exitcaserefs);
      clear(false);
      if (warnfactor*maxrefs>tablesize) and (tablesize >= warnthresh) then
	warning(linenum,
	  'most case table entries address the same statement');
      end; { with curstmt^ ... }
1: end {gencase};

procedure gengoto(curstmt: stptr);

{ Enhanced 9/26/91 JWH to fix FSDdt07193 }
{ except for variables, all changes are }
{ bewteen the lines =================== }
  var
    lbl: addrrange;
    op: attrtype;
    temp: reflistptr;
    label_temp,found_it : labelp;
    i : integer;
    done : boolean;
    upper_lim : integer;
  begin
    with curstmt^.target^ do

       if (level = staticlevel) or
	 fprocp^.ismodulebody then  { local goto }
	begin

{==================================================================}
	  found_it := NIL;
	  done := FALSE;
	  label_temp := display[top].flabel; { local labels in this scope }
	  while not done do
	   begin
	     if label_temp <> NIL then
	      begin
	       if labval = label_temp^.labval then
		begin
		 found_it := label_temp;
		 done := TRUE;
		end;
		 label_temp  := label_temp^.nextlab;
	       end
	     else
	      done := TRUE;
	   end;  { while not done do }

      if found_it <> NIL then
       begin
	 upper_lim := (body_try_level - (found_it^.try_level));
	 { writeln('upper lim is : ',upper_lim); }
	 for i := 1 to upper_lim do
	  begin
	     SBind.gloptr := NIL;
	     SPind.offset := 2*ptrsize;
	     SBind.offset := lastrecovdisp;
	     SBind.storage := long;
	     SBind.gloptr := sysglobalptr;
	     emit2(move,SPind,SBind);   { MOVE.L offset(SP),lastrecov }
	     SPind.offset := 0;    { must restore SPind.offset to 0 }
	     with op do
	      begin
	       addrmode := immediate;
	       op.smallval := 3*ptrsize;
	      end;
	     SPdir.storage := wrd;
	     emit2(adda,op,SPdir);     { ADDA.L  3*ptrsize,SP }
	end; { For }
       end; { found_it <> NIL }
{==================================================================}
{ Now same as before : JWH 9/26/91 }

	lbl := location;
	getbrattr(lbl,defined,op);

	if not defined then
	  begin
	  new(temp);
	  if isrefed then
	    temp^.next := labrefs
	  else
	    begin
	    isrefed := true;
	    temp^.next := NIL;
	    end;
	  labrefs := temp;
	  temp^.pc := lbl;
	  end;

	emit1(bra,op);
	end
      else  { non-local goto }

	begin
	op.smallval := 9;
	emit1(trap,op);        { TRAP 9 }
	if staticlevel = 1 then { destination is main program }
	  outputcodeword(-1)
	else
	  outputcodeword(level-staticlevel); {DC.W static delta}

	if not isnlrefed then
	  begin
	  uniquelabid := uniquenumber;
	  isnlrefed := true;
	  end;
	outputref(curglobalname^ + '_' + itostr(uniquelabid) + '_' +
				     itostr(labval),codephile.bytecount,rel32);
	outputcodelong(-codephile.bytecount);
	end;
  end;

procedure genif(curstmt: stptr);
  var
    lbl1: reflistptr;
    lbl2: localref;
    op: attrtype;
  begin
    with curstmt^ do
      begin
      gencond(ifcond,lbl1,false);
      releaseattr;
      gencode(tru);
      if fals <> NIL then
	begin
	lbl2.next := NIL;
	getbrattr(lbl2.pc,false,op);
	emit1(bra,op);
	end;
      fixreflist(lbl1);
      clear(false);
      if fals <> NIL then
	begin
	gencode(fals);
	fixreflist(addr(lbl2));
	clear(false);
	end;
      end;
  end {genif};

procedure genrep(curstmt: stptr);
  var
    lbl: reflistptr;
    blist: localref;
  begin
    with curstmt^ do
      begin
      lbl := addr(blist);
      blist.pc := codephile.bytecount;
      blist.next := NIL;
      clear(false);
      gencode(rbody);
      if debugging then
	begin
	emit1(trap,immed0);
	outputcodeword(lineno);
	end;
      globalattrlist := addr(attrlistptr);
      gencond(rcond,lbl,true)
      end;
  end {genrep};

procedure genwhile(curstmt: stptr);
  var
    lbl1: addrrange;
    lbl2: reflistptr;
    op: attrtype;
  begin
    with curstmt^ do
      begin
      lbl1 := codephile.bytecount;
      clear(false);
      if debugging then
	begin
	emit1(trap,immed0);
	outputcodeword(linenum);
	end;
      globalattrlist := addr(attrlistptr); { reset for current statement }
      gencond(rcond,lbl2,false);
      releaseattr;
      gencode(rbody);
      getbrattr(lbl1,true,op);
      emit1(bra,op);
      end;
    fixreflist(lbl2);
    clear(false);
  end {genwhile};

procedure gentry(curstmt: stptr);
  var
    op: attrtype;
    lrecovref, loutref: localref;
  begin
    with curstmt^ do
      begin
      SBind.offset := lastrecovdisp;
      SBind.storage := long;
      SBind.gloptr := sysglobalptr;
      SPminus.storage := long;
      emit2(move,SBind,SPminus);                { MOVE.L lastrecov,-(SP) }
      emit2(move,A6dir,SPminus);              { MOVE.L localbase,-(SP) }
      with op do
	begin
	addrmode := prel; offset := 0; indexed := false;
	absaddr.intval := true; absaddr.ival := 0;
	end;
      { REF lrecov }
      lrecovref.next := NIL;
      lrecovref.pc := codephile.bytecount + 2;
      emit1(pea,op);                            { PEA lrecov }
      emit2(move,SPdir,SBind);                  { MOVE.L SP,lastrecov }
      SBind.gloptr := NIL;
      body_try_level := body_try_level + 1;  { JWH 9/26/91 }
      gencode(tbody);
      body_try_level := body_try_level - 1;  { JWH 9/26/91 }
      SPind.offset := 2*ptrsize;
      SBind.offset := lastrecovdisp;
      SBind.storage := long;
      SBind.gloptr := sysglobalptr;
      emit2(move,SPind,SBind);              { MOVE.L offset(SP),lastrecov }
      SPind.offset := 0;    { must restore SPind.offset to 0 }
      with op do
	begin
	addrmode := immediate;
	op.smallval := 3*ptrsize;
	end;
      SPdir.storage := wrd;
      emit2(adda,op,SPdir);                 { ADDA.L  3*ptrsize,SP }
      with op do
	begin
	addrmode := prel; offset := 0; storage := wrd;
	absaddr.intval := true; absaddr.ival := 0;
	end;
      { REF lout }
      loutref.next := NIL;
      loutref.pc := codephile.bytecount + 2;
      emit1(jmp,op);                  { JMP lout }
      { DEF lrecov }
      fixreflist(addr(lrecovref));
      clear(false);
      A6dir.storage := long;
      emit2(movea,SPplus,A6dir);           { MOVEA.L (SP)+,localbase }
      emit2(move,SPplus,SBind);            { MOVE.L (SP)+,lastrecov }
      SBind.gloptr := NIL;
      gencode(recov);
      { DEF lout }
      fixreflist(addr(loutref));
      clear(false);
      end;
  end {gentry};

procedure genwith(curstmt: stptr);
  var
    op1,op2: attrtype;

  procedure getwithrecattr(var attrec: attrtype);
    { initialize access to WITH record base in local storage. }
    begin getlocstorage(ptrsize,attrec); attrec.access := indirect;
    end; {getwithrecattr}

  begin {genwith}
    with curstmt^ do
      begin
      genexpr(refexpr);
      with refexpr^,attr^ do
	begin
	if packd and (bitoffset.variable <> -1) then
	  begin
	  getlocstorage(intsize,op1);
	  refbit := op1.offset;
	  op1.storage := long;
	  with op2 do
	    begin addrmode := inDreg; regnum := bitoffset.variable; end;
	  emit2(move,op2,op1);
	  freeit(D,bitoffset.variable);
	  end
	else refbit := 0; {no bit offset saved}
	if indexed or (access = indirect)
	    or (addrmode = locinreg)
	    and (regnum <> localbase) and (regnum <> SB) then
	  begin {base is non-constant or intermediate so save it}
	  if (reg[A,regnum].usage <> withrecbase)
	      and addrinreg(refexpr) then
	    {Base is currently in "A" register.  Mark register
	    usage and save accessing info in register.}
	    with reg[A,regnum] do
	      begin usage:= withrecbase;
	      allocstate := allocated;
	      usesleft := 1;
	      oldcontents := attr^; {initialize}
	      getwithrecattr(oldcontents); curcontents := attr;
	      moveaddress(refexpr,oldcontents);
	      end
	  else {base not loaded, save access info in refexpr}
	    begin
	    op1 := attr^;  { This is a "cheap" initialization }
	    getwithrecattr(op1);
	    moveaddress(refexpr,op1);
	    attr^ := op1;
	    freeregs(attr);
	    end;
	  end { save base }
	else freeregs(attr);
	gencode(wbody);
	with reg[A,regnum] do
	  if (usage = withrecbase) then
	    if curcontents = attr then usage := other;
	end;
      end; {with curstmt^}
  end {genwith};

procedure genepilog(curstmt: stptr);
  var
    popsize: addrrange;
    opnd1,opnd2: attrtype;
  begin
  if (display[top].ffile <> NIL) and
     (proclev > 0) then { local files }
    begin
    SPminus.storage := long;
    emit2(move,A6dir,SPminus);
    callstdproc('ASM_CLOSEFILES');
    end;
  if odd(lcmax) then lcmax := lcmax-1;
  if modulebody then emit0(rts)
  else
    begin emit1(unlk,A6dir);               { UNLK A6 }
    if proclev > 0 then
      begin
      with fprocp^ do
	begin
	popsize := paramlc+ptrsize*ord(proclev>1);
	if klass=func then
	  if idtype^.form >= prok then popsize := popsize+ptrsize;
	if (popsize<>0) and (popsize<>4) then
	  begin
	  with opnd2 do
	    begin addrmode := inAreg; regnum := 0; storage := long end;
	  emit2(movea,SPplus,opnd2);             { MOVEA.L (SP)+,A0 }
	  with opnd1 do
	    begin addrmode := immediate; smallval := popsize; end;
	  if popsize < 32768 then
	    SPdir.storage := wrd
	  else
	    SPdir.storage := long;
	  emit2(add,opnd1,SPdir);                { ADDQ/I #popsize,SP }
	  with opnd2 do
	    begin addrmode := locinreg; offset := 0;
	    indexed := false; regnum:= 0; gloptr := NIL;
	    end;
	  emit1(jmp,opnd2);                      { JMP (A0) }
	  end
	else
	  begin
	  if popsize = 4 then
	    begin
	    SPind.storage := long;
	    emit2(move,SPplus,SPind);            { MOVE.L (SP)+,SP }
	    end;
	  emit0(rts);                            { RTS }
	  end;
	end;
      end
    else emit0(rts);    {main program}
    end;

  { Used by the tree dump routine for debug info }
  fprocp^.exit_location := codephile.bytecount - 2;

  if $IF MC68020$ (proclev = 0) and $END$ (lcmax < LClimit) then
$if bigsets$
	errorwithinfo( 683,
	    'Refer to manual for details of stack allocation.')
$end$
$if not bigsets$
	error(683)
$end$
  else if not modulebody then
    while maxLCpatch <> NIL do
      begin
      $IF MC68020$
	if (maxLCpatch^.next = NIL) and gstackcheck then { last one }
	  fixlong(maxLCpatch^.pc,-(lcmax-1073741824)) { convert trap #1 disp }
	else
	  fixlong(maxLCpatch^.pc,lcmax);
      $END$
      $IF not MC68020$
	fixword(maxLCpatch^.pc,lcmax);
      $END$
      maxLCpatch := maxLCpatch^.next;
      end;
  end {genepilog};

begin {gencode}
while curstmt <> NIL do
  with curstmt^ do
    begin oldlc := lc;
    { set codegen variables to reflect curstmt^ }
    linenum := lineno;
    rangecheck := sflags.rangecheck;
    ovflcheck := sflags.ovflcheck;
    iocheck := sflags.iocheck;
    shortcircuit := sflags.shortcircuit;
    callmode := sflags.callmode;
    if labp <> NIL then
      with labp^ do
	begin
	clear(false);
	if nonlocalref then
	  begin
	  outputdef(itostr(uniquelabid) + '_' + itostr(labval),
					    codephile.bytecount,relocatable,0);
	  $IF MC68020$
	  if maxLCpatch <> NIL then { not main prog }
	    begin
	    SPdir.storage := long;
	    emit2(movea,A6dir,SPdir);
	    new(p);
	    p^.next := maxLCpatch;
	    maxLCpatch := p;
	    p^.pc := codephile.bytecount + 2;
	    opnd.addrmode := immediate;
	    opnd.smallval := 0;
	    emit2(adda,opnd,SPdir);
	    end
	  else { main prog : always has link.w a6,#0 }
	    begin
	    A6ind.offset := -1;
	    emit2(lea,A6ind,SPdir);
	    fixword(codephile.bytecount-2,1);
	    end;
	  $END$
	  $IF not MC68020$
	  if maxLCpatch <> NIL then { not main prog }
	    begin
	    new(p);
	    p^.next := maxLCpatch;
	    maxLCpatch := p;
	    p^.pc := codephile.bytecount + 2;
	    end;
	  A6ind.offset := -1;
	  emit2(lea,A6ind,SPdir);
	  fixword(codephile.bytecount-2,1);
	  $END$
	  end;
	location := codephile.bytecount;
	defined := true;
	if isrefed then fixreflist(labrefs);
	end;
    if debugging and not modulebody
       and not (sclass in [emptyst,compndst,repst,whilest]) then
      begin
      emit1(trap,immed0);
      outputcodeword(linenum);
      end;
    if (sclass <> emptyst) and
       (initlistmode = listfull) and
       listpc and listopen then
      begin
      if PCcount = 0 then incrlinecount;
      write(lp,linenum:8,'-',codephile.bytecount:7,' ');
      PCcount := PCcount + 1;
      if PCcount = PCperline then
	begin writeln(lp); PCcount := 0; end;
      if ioresult <> ord(inoerror) then
	begin
	listabort := true;
	list := listnone;
	listopen := false;
	warning(linenum,'Listing aborted');
	end;
      end;
    attrlistptr := NIL;
    globalattrlist := addr(attrlistptr);
    case sclass of
      becomest:    begin genbecomes(curstmt); releaseattr end;
      pcallst:     begin
		     genproc(psymptr,actualp); releaseattr;
		   end;
      casest:      gencase(curstmt);
      compndst:    gencode(curstmt^.cbody);
      forst:       begin genfor(curstmt); releaseattr end;
      gotost:      gengoto(curstmt);
      ifst:        genif(curstmt);
      repst:       begin genrep(curstmt); releaseattr end;
      whilest:     genwhile(curstmt);
      tryst:       begin
		     gentry(curstmt);
		   end;
      withst:      begin genwith(curstmt); releaseattr end;
      endofbodyst: genepilog(curstmt);
      emptyst:     ;
      otherwise escape(-8);
      end; {case sclass ...}
    lc := oldlc;
    curstmt := next;
    end; {with curstmt^...}
end; {gencode}

  procedure getprocinfo;
    begin
    curproc := fprocp;
    with curproc^ do
      begin lcmax := lc;
      proclev := pflev;
      bodylev := pflev+1;
      if klass = prox then
	modulebody := ismodulebody
      else
	modulebody := false;
      end;
    rangecheck := curbody^.sflags.rangecheck; { use value from first statement }
    callmode := curbody^.sflags.callmode;
    end {getprocinfo};

  procedure genprolog;
    var
      i: shortint;
      parmp,varid: ctp;
      op1,op2,op3 : attrtype;
      temp: string[idlength+1];
      nametemp: alpha;

    procedure copyvalueparm;
      { move value parm whose address has parameter offset
	parmp^.vptraddr to offset given by parmp^.vaddr }
      var
	destreg, sourcereg, sourcesize: regrange;
	wdstomove, curmove: integer;
	op1,op2,op3 : attrtype;
      begin
	if (parmp^.idtype^.form = power) or strgtype(parmp^.idtype) then
	  with parmp^ do
	    begin
	    sourcereg := getreg(A);
	    destreg := getreg(A);
	    sourcesize := getreg(D);
	    { load source address }
	    A6ind.offset := vptraddr;
	    with op2 do
	      begin addrmode := inAreg; regnum:= sourcereg; storage:= long; end;
	    emit2(movea,A6ind,op2);                { MOVEA.L vptraddr(A6),Areg }
	    { load size in a reg }
	    op2.addrmode := postincr;
	    with op1 do
	      begin addrmode := inDreg; regnum := sourcesize; end;
	    if idtype^.form = power then op1.storage := wrd
				    else op1.storage := bytte;
	    op2.storage := op1.storage;
	    emit2(move,op2,op1);
	    if RANGECHECK then
	      if idtype^.form = power then
		begin
		with op2 do
		  begin
		  addrmode := immediate; smallval := idtype^.unpacksize-2;
		  end;
		emit2(chk,op2,op1);
		end
	      else if idtype^.maxleng<>255 then
		begin
		with op2 do
		  begin
		  addrmode := immediate; smallval := idtype^.maxleng;
		  end;
		emit2(cmpi,op2,op1);
		with op1 do
		  begin offset:= 2; storage:= bytte  end;
		emit1(bls,op1);              { BLS.S *+4 }
		op1.smallval := 7;
		emit1(trap,op1);             { TRAP #7 }
		end;
	    { get destination address in a register }
	    A6ind.offset := vaddr;
	    with op2 do
	      begin
	      addrmode := inAreg; regnum := destreg; storage := long;
	      end;
	    emit2(lea,A6ind,op2);
	    { move size field to destination }
	    with op1 do
	      begin addrmode := inDreg; regnum := sourcesize; end;
	    with op2 do
	      begin
	      addrmode := postincr;
	      if idtype^.form = power then storage := wrd
				      else storage := bytte;
	      end;
	    emit2(move,op1,op2);
	    { loop back to this point }
	    with op1 do
	      begin
	      addrmode := postincr; regnum := sourcereg;
	      end;
$if bigsets$
	    if idtype^.form = power then
		op2.storage := wrd
	    else op2.storage := bytte;
	    emit2(move,op1,op2);
	    with op1 do
	      begin
	      addrmode := immediate;
	      if idtype^.form = power then
		smallval := 2
	      else smallval := 1;
	      end;
	    with op2 do
	      begin
	      addrmode := inDreg; regnum := sourcesize;
	      if idtype^.form = power then
		storage := wrd
	      else  storage := bytte;
	      end;
	    emit2(subq,op1,op2);
	    with op1 do
	      begin
		offset := -6;
		if idtype^.form = power then storage := wrd
		else  storage := bytte;
	       end;
$end$
$if not bigsets$
	    op2.storage := bytte;
	    emit2(move,op1,op2);
	    with op1 do
	      begin
	      addrmode := immediate; smallval := 1;
	      end;
	    with op2 do
	      begin
	      addrmode := inDreg; regnum := sourcesize; storage := bytte;
	      end;
	    emit2(subq,op1,op2);
	    with op1 do
	      begin offset := -6; storage := bytte end;
$end$
	    emit1(bhi,op1);
	    freeit(A,destreg);
	    freeit(D,sourcesize);
	    freeit(A,sourcereg);
	    end
	  else if parmp^.idtype^.form = cnfarrays then
	    begin
	    getcnfsize(parmp^.idtype,op1);
	    if op1.addrmode <> inDreg then
	      with op2 do
		begin
		addrmode := inDreg;
		regnum := getreg(D);
		storage := long;
		emit2(move,op1,op2);
		op1 := op2;
		end;
	    { make the value even }
	    with op2 do
	      begin
	      addrmode := immediate;
	      smallval := 1;
	      emit2(add,op2,op1);
	      smallval := 0;
	      emit2(bclr,op2,op1);
	      end;
	    { Make room in stack frame }
	    SPdir.storage := long;
	    emit2(suba,op1,SPdir);
	    { copy }
	    A6ind.offset := parmp^.vptraddr;
	    SPminus.storage := long;
	    emit2(move,A6ind,SPminus);
	    SPind.offset := 4;
	    emit1(pea,SPind);
	    SPind.offset := 0;
	    emit2(move,op1,SPminus);
	    freeit(D,op1.regnum);
	    saveregs;
	    forgetbaseregs;
	    callstdproc('ASM_MOVEL');
	    reloadregs;
	    A6ind.storage := long;
	    emit2(move,SPdir,A6ind);
	    end
	  else
	    begin
	    sourcereg := getreg(A);
	    with parmp^ do
	      begin wdstomove := (idtype^.unpacksize+1) div 2;
	      A6ind.offset := vptraddr;
	      with op2 do
		begin
		addrmode := inAreg; regnum := sourcereg; storage := long;
		end;
			       { set up source pointer }
	      emit2(movea,A6ind,op2);              { MOVEA.L vptraddr(A6),Areg }
	      op2.addrmode := postincr;
	      A6ind.offset := vaddr;
	      end;
	    bigmove(op2,A6ind,wdstomove,true,false);
	    freeit(A,sourcereg);
	    end;
      end; {copyvalueparm}

    procedure callmodulebodies;
      var
	s: modstateptr;
	op: attrtype;
	found: boolean;
	i: shortint;
      begin
      with display[top] do
	begin
	s := available_module;
	while s <> NIL do
	  with s^, modinfo^ do
	    begin
	    if needscall then
	      begin
	      found := false;
	      i := 1;
	      while not found and (i <= overlaytop) do
		if modinitbody^.namep^ = overlaylistptr^[i] then
		  found := true
		else
		  i := i + 1;
	      if found then { don't emit call }
	      else
		begin
		needscall := false;
		getprokconst(modinitbody,op);
		emit1(jsr,op);
		end;
	      end;
	    s := s^.nextmodule;
	    end;
	end;
      end;

    begin { genprolog }
    if not modulebody then
      begin
      if debugging then
	begin
	outputcodeword(curbody^.lineno);
	temp := fprocp^.namep^;
	if not odd(strlen(temp)) then
	  begin
	  temp[0] := chr(ord(temp[0])+1);
	  temp[strlen(temp)] := ' ';
	  end;
	for i := 0 to strlen(temp) do
	  outputcodebyte(ord(temp[i]));
	outputcodebyte(strlen(temp)+1);
	end
      else { not debugging }
	outputcodebyte(0);
      outputcodebyte(ord(proclev>1));
      end;
    if proclev = 0 then       {main program}
      begin {define main program entry point}
      maxLCpatch := NIL;
      with fprocp^ do
	begin
	location := codephile.bytecount;
	isdumped := true;
	end;
      startaddr := codephile.bytecount;
      outputdef(fprocp^.namep^,codephile.bytecount,relocatable,0);
      A6dir.storage := wrd;
      emit1(link,A6dir); { LINK localbase }
      if heapdispose then callstdproc('HPM_HESTABLISH');
      end { proclev = 0... }
    else
      begin {define procedure entry point}
      startaddr := -1;
      with fprocp^ do
	begin
	location := codephile.bytecount;
	isdumped := not alias;
	if isexported or isrefed then
	  if not isexported then
	    begin
	    nametemp := itostr(forwid) + namep^;
	    outputdef(nametemp,codephile.bytecount,relocatable,0);
	    end
	  else
	    outputdef(namep^,codephile.bytecount,relocatable,0);
	end; { with fprocp^ }
      if not modulebody then
	begin {establish dynamic link, allocate local storage}
	new(maxLCpatch);
	maxLCpatch^.next := NIL;
	maxLCpatch^.pc := codephile.bytecount + 2;
	if gstackcheck then
	  begin
	  op1.smallval := 1;
	  emit1(trap,op1);       { trap #1 stack overflow check }
	  outputcodeword(0);
	  $IF MC68020$
	    outputcodeword(0);   { room for 32 bit displacement on 68020 }
	  $END$
	  end
	else
	  begin
	  $IF MC68020$
	    A6dir.storage := long;
	  $END$
	  $IF not MC68020$
	    A6dir.storage := wrd;
	  $END$
	  emit1(link,A6dir);
	  end;
	{move any copied-value parameters}
	parmp := fprocp^.next;
	while parmp <> NIL do
	  with parmp^ do
	    begin
	    if vtype = cvalparm then copyvalueparm;
	    parmp := next;
	    end;
	end; {not modulbody}
      end; { proclev <> 0... }
    varid := display[top].ffile;
    while varid <> NIL do
      with varid^ do
	begin initlocvar(varid,NIL,0,idtype,isnew);
	varid := varid^.next;
	end;
    callmodulebodies;
    end {genprolog};

  begin {genbody}
    getprocinfo;
    clear(true);
    genprolog;
    stringhead := NIL; sethead := NIL;
    reelhead := NIL; enumhead := NIL;

    $IF MC68020$
    wrdpairhead := NIL; longpairhead := NIL;
    $END$

    freeattr := NIL;
    PCcount := 0; PCperline := pagewidth DIV 17;
    gencode(curbody);
    dumpconsts;
    if (PCcount <> 0) and listopen and listpc then writeln(lp);
  end; {genbody}


procedure codegeninit;
  type
    filesiztype = string[5];
  var
    lok: boolean;
    i: integer;
    defaultfilename: fid;
    codevid: vid;
    sourcevid: vid;
    sourcefid: fid;
    dummy2: integer;
    dummy3: filekind;

  function filetag(var fname:fid): boolean;
    var
      lok: boolean;
      dummy1: fid;
      dummy2: integer;
      dummy3: filekind;
    begin
    fixname(fname,codefile);
    lok := scantitle(fname,codevid,
			   dummy1,dummy2,dummy3);
    if lok then
      begin
      rewrite(codephile.fileid,fname);       {Try to Open new file}
      i := ioresult;
      close(codephile.fileid,'PURGE');
      if i<>ord(inoerror) then
	begin
	if i = ord(inoroom) then
	  begin
	  error(900);
	  escape(-1);
	  end
	else if i <> ord(inofile) then
	  begin
	  file_warn(903,i);
	  escape(-1);
	  end
	else
	  filetag := false;
	end
      else filetag := true;
      end
    else
      filetag := false;
    end;

begin {codegeninit}
new(libraryptr);
new(codephile.buffer);
new(refile.buffer);
new(defile.buffer);
genutilsinit;
lok := scantitle(sourcefilename,sourcevid,
			sourcefid,dummy2,dummy3);
defaultfilename := sourcevid + ':' +
		     getfid(sourcefid) + '.CODE';
if userinfo^.gotsym then
  begin
  file_name := defaultfilename;
  if not filetag(file_name) then
    userinfo^.gotsym := false;
  end
else
  begin
  writeln(output);
  write(output,'Output file (default is "',defaultfilename,'") ? ');
  repeat
    readln(input,file_name);
    if file_name='' then
      file_name := defaultfilename;
    lok := filetag(file_name);
    if not lok then
      write(output,'Invalid file name. File ? ');
    until lok;
  end;
codefileopen := false;
if refvolname = '' then
  refvolname := codevid + ':';
fanonfile(refile.fileid,refvolname,
			    codefile,refilesize);
i := ioresult;
if i<>ord(inoerror) then
  begin
  if i = ord(inoroom) then error(901)
  else
    file_warn(904,i);
  escape(-1);
  end;
if defvolname = '' then
  defvolname := codevid + ':';
fanonfile(defile.fileid,defvolname,
			    codefile,defilesize);
i := ioresult;
if i<>ord(inoerror) then
  begin
  if i = ord(inoroom) then error(902)
  else
    file_warn(905,i);
  escape(-1);
  end;
writeln(output);
codeinit;
dedicatedregs := [SB,localbase,SP];
memorymodes := [locinreg,shortabs,longabs,prel,labelledconst,namedconst];

{ Used by "extend" for "emitcheck" }
ensure_valid_condition_code := false;

OVERLAY := 'OVERLAY';
EXEC := 'EXEC';
ADDRESS := 'ADDRESS';
force_unpack := false;          (* default condition, do not force unpacking
				   of unsigned 8 or 16 bit fields *)
end; {codegeninit}

@


55.2
log
@Changes to fix FSDdt07193. Most of the changes are in the routine
gengoto.
@
text
@@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@d2293 4
d2301 4
d2307 3
a2309 2
      if (level = staticlevel) or
	 fprocp^.ismodulebody then { local goto }
d2311 45
d2358 1
d2372 1
d2375 2
a2376 1
      else { non-local goto }
d2496 1
d2498 1
d2770 3
a2772 1
      tryst:       gentry(curstmt);
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.2
log
@Modified bigmove and movemulti to fix the "big move hotsite"
of 11/17/88. The changes are noted in the code (4 lines).
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@d144 1
a144 1
      if bytetomove then saveregs;
d155 2
d160 1
a160 1
      if bytetomove then reloadregs;
d822 1
a822 1
      if odd(numbytes) then
@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.3
log
@Range check structured constant field width parameters at run time.
@
text
@@


24.2
log
@Movemulti was changed to fix two defects.  If indexing was true the offset
field may not have enough range so indexing was eliminated.  The offset
field should always be incremented not assigned to.
@
text
@d1303 1
a1303 1
	   (expptr^.ekind <> cnst) then
@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d665 10
d743 1
a743 2
	    if addrmode = locinreg then offset := offset + 2*numwords
	    else offset := 2*numwords;
d745 1
a745 2
	    if addrmode = locinreg then offset := offset + 2*numwords
	    else offset := 2*numwords;
@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.2
log
@Big foBug fixes by Brad Ritter 4/14/87
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@d541 1
d580 1
@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.2
log
@Misc. fixes for STARS and bugs found in HP-UX -- see BAR/JWS for detail
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d1273 1
d1993 16
d2018 2
d2021 1
d2027 1
a2027 2
	    getbounds(nextptr^.expptr^.etyptr^.inxtype,lobound,hibound);
	    op1.smallval := hibound - lobound + 1;
@


12.2
log
@Fixes for problems with conformant arrays in local procedures and
FSDat01015 (DIV problem on COMPILE20)
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@d404 3
d421 8
a428 1
      A6ind.offset := cnf^.cnf_index^.hiboundid^.vaddr;
d435 1
a435 1
      emit2(move,A6ind,op1);
d445 2
d459 1
a459 2
	  A6ind.offset := cnf^.cnf_index^.loboundid^.vaddr;
	  emit2(move,A6ind,op2);
d466 1
a466 1
	  op2 := A6ind;
d482 1
a482 1
	  A6ind.offset := cnf^.cnf_index^.loboundid^.vaddr;
d485 1
a485 1
	  emit2(move,A6ind,op2);
d491 1
a491 1
	  op2 := A6ind;
d503 1
d513 2
a514 2
	  A6ind.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
	  emit2(move,A6ind,op2);
d520 1
a520 1
	  op2 := A6ind;
d562 1
a562 1
	  A6ind.offset := cnf^.cnf_index^.hiboundid^.vaddr + 2;
d565 1
a565 1
	  emit2(move,A6ind,op2);
d570 1
a570 1
	  op2 := A6ind;
@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.2
log
@Changes from Scott Bayes.
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@d3142 2
@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
