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


56.4
date     93.01.27.13.32.37;  author jwh;  state Exp;
branches ;
next     56.3;

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

56.2
date     92.11.05.07.54.27;  author cfb;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.30.19;  author jwh;  state Exp;
branches ;
next     55.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

30.1
date     88.12.09.13.35.14;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.19.13;  author bayes;  state Exp;
branches ;
next     28.2;

28.2
date     88.10.14.10.56.16;  author jwh;  state Exp;
branches ;
next     28.1;

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

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

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

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

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

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

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

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

22.1
date     87.08.17.10.33.51;  author bayes;  state Exp;
branches ;
next     21.2;

21.2
date     87.08.13.17.31.51;  author jws;  state Exp;
branches ;
next     21.1;

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

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

19.1
date     87.06.01.07.50.07;  author jws;  state Exp;
branches ;
next     18.2;

18.2
date     87.05.30.11.16.30;  author jws;  state Exp;
branches ;
next     18.1;

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

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

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

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

15.1
date     87.04.13.08.42.14;  author jws;  state Exp;
branches ;
next     14.2;

14.2
date     87.04.07.09.47.54;  author jws;  state Exp;
branches ;
next     14.1;

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

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

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

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

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

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

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

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

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

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

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

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

4.1
date     86.09.30.19.11.58;  author hal;  state Exp;
branches ;
next     3.1;

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

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

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


desc
@Base file for PWS 3.2 release.

@


56.4
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@		      { file GENEXPR }

implement {genexprmod}

var  {save/reload regs stuff}
  rstring, disp: attrtype; numsavedregs: 0..15;
  onereg : record        { if there is only one register this is it }
	     rt: regtype;
	     rn: regrange;
	   end;

procedure makeaddressable{varexp: exptr};
  { ensure addressability of variable }
  begin genexpr(varexp);
    with varexp^.attr^ do
      begin
      if packd then bitaddress(varexp);
      if access = indirect then
	loadaddress(varexp,false)
      else checkoffset(varexp);
      if packd then unpack(varexp);
      end;
  end; {makeaddressable}

procedure extend(*fexp: exptr; fstorage: stortype*);
  {extend is a general routine called to ensure that its parameter
   is of a given storage (size).  The desired final storage could
   be smaller, the same, or larger then the current storage}

  var
    op: attrtype;
  begin
    genexpr(fexp);
    with fexp^, attr^ do
      begin if packd then makeaddressable(fexp);
      { if eclass = litnode then fixliteral(fexp,fstorage,true); }
      { BUG FIX 10/14/88 - JWH }
      if addrmode = immediate then fixliteral(fexp,fstorage,true);
      if storage <> fstorage then
	begin
	if fstorage > storage then
	  begin
	  if (not signbit) then
	    begin
	    getregattr(D,op);
	    emit2(moveq,immed0,op);
	    makeaddressable(fexp);
	    op.storage := storage;
	    emit2(move,attr^,op);
	    freeregs(attr);
	    addrmode := inDreg;
	    regnum := op.regnum;
	    signbit := true;
	    if ensure_valid_condition_code then
	      begin
	      op.storage := fstorage;
	      emit1(tst,op);
	      end;
	    end
	  else
	    begin
	    loadvalue(fexp);
	    $IF MC68020$
	    if (storage = bytte) and (fstorage = long) then
	      emit1(extb,attr^)
	    else
	    $END$
	    while storage < fstorage do
	      begin storage := succ(storage); emit1(ext,attr^); end;
	    end;
	  end
	else {fstorage < storage}
	  begin
	  if addrmode = topofstack then loadvalue(fexp)
	  else makeaddressable(fexp);
	  if storage = wrd then offset := offset + 1
	  else {storage = long}
	    if fstorage = wrd then offset := offset + 2
	    else if fstorage = bytte then offset := offset + 3;
	  end;
	storage := fstorage;
	end;
      end;
  end; {extend}

procedure checkstackandextend(exp1,exp2: exptr; len: stortype);
  {if exp2's storage <> len then extend it, checking for
   exp2 at topofstack-1 }
  begin
  with exp2^.attr^ do
    if storage <> len then
      begin
      if (addrmode=topofstack) and (exp1^.attr^.addrmode=topofstack) then
	loadvalue(exp1); {pop}
      extend(exp2,len);
      end;
  end; {checkstackandextend}

procedure relCMP(* fexp: exptr; var fdestonleft,fsigned: boolean *);
  var destonleft,cmpwith0: boolean;
      lmode,rmode: addrtype; lstorage,rstorage: stortype;
      signed,lsigned,rsigned: boolean; cmptype: opcodetype;

  procedure relprok(lop,rop: exptr);
    { compare procedure objects for (in)equality.
      note: const relop const handled by front end }

    procedure relprokVC(pexp,pconst: exptr);
      {compare prok var or expr with prok const}
      begin pexp^.attr^.storage := long;
      if callmode = relcall then
	begin loadaddress(pconst,false);
	pconst^.attr^.addrmode := inAreg;
	emit2(cmpa,pexp^.attr^,pconst^.attr^);
	freeit(A,pconst^.attr^.regnum);
	end
      else emit2(cmpi,pconst^.attr^,pexp^.attr^);      { CMPI.L pconst,pexp }
      freeregs(pexp^.attr);
      end;

    begin {relprok}
    makeaddressable(lop); makeaddressable(rop);
    if lop^.ekind <> cnst then
      if rop^.ekind <> cnst then
	begin
	rop^.attr^.storage := long; {to fool loadvalue}
	loadvalue(rop);
	emit2(cmp,lop^.attr^,rop^.attr^);   { CMP.L lop,rop }
	freeregs(lop^.attr); freeregs(rop^.attr);
	end
      else relprokVC(lop,rop)
    else relprokVC(rop,lop);
    end; {relprok}

  begin {relCMP}
    with fexp^ do
      if opnd1^.etyptr^.form = prok then
	begin relprok(opnd1,opnd2); fdestonleft := false {don't care} end
      else {not prok compare}
	begin {select CMP or CMPI, and order of operands}
	cmpwith0 := false;
	if opnd1^.ekind > opnd2^.ekind then
	  begin makeaddressable(opnd1); makeaddressable(opnd2) end
	else begin makeaddressable(opnd2); makeaddressable(opnd1) end;
	maskboolexpr(opnd1); maskboolexpr(opnd2);
	with opnd1^.attr^ do
	  begin lmode := addrmode;
	  lstorage := storage;
	  lsigned := signbit;
	  end;
	with opnd2^.attr^ do
	  begin rmode := addrmode;
	  rstorage := storage;
	  rsigned := signbit;
	  end;
	if rmode = immediate then
	  begin destonleft := true; cmptype := cmpi;
	  fixliteral(opnd2,lstorage,lsigned);
	  with opnd2^.attr^ do
	    begin rstorage := storage; rsigned := signbit;
	    if rmode = immediate then
	      if (smallval = 0) and
		 (lmode <> namedconst) then
		cmpwith0 := true
	      else if (smallval >= -128) and (smallval <= 127) then
		begin loadvalue(opnd2); cmptype := cmp end;
	    end;
	  end
	else if lmode = immediate then
	  begin destonleft := false; cmptype := cmpi;
	  fixliteral(opnd1,rstorage,rsigned);
	  with opnd1^.attr^ do
	    begin lstorage := storage; lsigned := signbit;
	    if lmode = immediate then
	      if (smallval = 0) and
		 (rmode <> namedconst) then
		cmpwith0 := true
	      else if (smallval >= -128) and (smallval <= 127) then
		begin loadvalue(opnd1); cmptype := cmp end;
	    end;
	  end
	else cmptype := cmp;
	if (lstorage = rstorage) and (lsigned = rsigned) then
	  signed := lsigned
	else if rstorage = long then
	  begin signed := true;
	  if lstorage <> long then extend(opnd1,long);
	  end
	else if lstorage = long then
	  begin signed := true;
	  if rstorage <> long then
	    checkstackandextend(opnd1,opnd2,long);
	  end
	else if (rstorage = wrd) and rsigned and (lstorage = bytte) then
	  begin signed := true; extend(opnd1,wrd) end
	else if (lstorage = wrd) and lsigned and (rstorage = bytte) then
	  begin signed := true; checkstackandextend(opnd1,opnd2,wrd) end
	else if (lstorage = bytte) and not lsigned then
	  begin
	  if rsigned then {opnd2 is signed byte}
	    begin signed := true; extend(opnd1,wrd);
	    checkstackandextend(opnd1,opnd2,wrd);
	    end
	  else {opnd2 is unsigned word}
	    begin signed := false; extend(opnd1,wrd) end
	  end
	else if (rstorage = bytte) and not rsigned then
	  begin
	  if lsigned then {opnd1 is signed byte}
	    begin signed := true; extend(opnd1,wrd);
	    checkstackandextend(opnd1,opnd2,wrd);
	    end
	  else {opnd1 is unsigned word}
	    begin signed := false; checkstackandextend(opnd1,opnd2,wrd) end
	  end
	else {unsigned word vs signed or word signed byte}
	  begin signed := true; extend(opnd1,long);
	  checkstackandextend(opnd1,opnd2,long);
	  end;
	if cmptype <>  cmpi then
	  begin destonleft := (opnd2^.attr^.addrmode <> inDreg);
	  if destonleft then loadvalue(opnd1);
	  end;
	{emit appropriate code}
	if destonleft then
	  begin
	  if not cmpwith0 then                     { CMP[I].size op2,op1 }
	    emit2(cmptype,opnd2^.attr^,opnd1^.attr^)
	  else if (opnd1^.attr^.addrmode<>inDreg) or (opnd1^.eclass=modnode) or
		  ((opnd1^.eclass=shftnode) and (not opnd1^.attr^.signbit))
	    then emit1(tst,opnd1^.attr^);           { TST.size op1 }
	  end
	else
	  if not cmpwith0 then                     { CMP[I].size op1,op2 }
	    emit2(cmptype,opnd1^.attr^,opnd2^.attr^)
	  else if (opnd2^.attr^.addrmode<>inDreg) or (opnd2^.eclass=modnode) or
		  ((opnd2^.eclass=shftnode) and (not opnd2^.attr^.signbit))
	    then emit1(tst,opnd2^.attr^);           { TST.size op2 }
	freeregs(opnd1^.attr); freeregs(opnd2^.attr);
	fdestonleft := destonleft; fsigned := signed;
	end; {not prok compare}
  end; {relCMP}

procedure saveregs;
  { save allocated registers in local storage using MOVEM.L ...,disp(A6).
    Save register list in rstring for reloading. }
  var
    rt: regtype; rn: regrange;
  begin
    if float = flt_on then saverealregs;
    with rstring do
      begin
      numsavedregs := 0;
      for rt := A to D do
	for rn := 0 to maxreg do
	  if reg[rt,rn].allocstate = allocated then
	    begin
	    numsavedregs := numsavedregs+1;
	    regs[rt,rn] := true;
	    onereg.rt := rt; onereg.rn := rn;
	    end
	  else regs[rt,rn] := false;
      if numsavedregs <> 0 then
	begin
	getlocstorage(numsavedregs*4,disp);
	disp.storage := long;
	if numsavedregs = 1 then
	  begin
	  regnum := onereg.rn;
	  if onereg.rt = A then addrmode := inAreg
			   else addrmode := inDreg;
	  emit2(move,rstring,disp);
	  end
	else
	  begin
	  addrmode := multiple;
	  emit2(movem,rstring,disp);
	  end;
	end;
      end;
  end; {saveregs}

procedure reloadregs;
  { reload allocated registers from local storage }
  begin
    if numsavedregs > 0 then
      begin
      rstring.storage := long;
      if numsavedregs > 1 then
	emit2(movem,disp,rstring)
      else
	emit2(move,disp,rstring);
      end;
    if float = flt_on then reloadrealregs;
  end;

procedure gensetop {fexp: exptr};
  const
    attos = true;
    inloc = false;

  procedure stackops (fopnd1,fopnd2 : exptr);
    { operands appear on the stack in the following order:
	  address of left operand (+8)
	  address of right operand (+4) }
    begin {stackops}
    pushaddress(fopnd1);
    pushaddress(fopnd2);
    end; {stackops}

  procedure stackresult (fexp : exptr ; fattos : boolean);
    { fill in attributes for result of set operation }
    begin
    with fexp^,attr^ do
      if fattos then addrmode := topofstack { boolean result }
      else { set result }
	begin getlocstorage(etyptr^.unpacksize,attr^);
	pushaddress(fexp) { result address on stack (at +12) }
	end;
    end; {stackresult}

  begin {gensetop}
  with fexp^ do
    begin { set up for external routines for =,<>,<=,>=,+,*,-,in }
    case eclass of
      unionnode,intersectnode,diffnode :
	begin stackresult(fexp,inloc); { set result in local storage }
	stackops(opnd1,opnd2);
	end;
      eqnode,nenode,subsetnode :
	begin stackresult(fexp,attos); { boolean result at tos }
	stackops(opnd1,opnd2);
	end;
      supersetnode :
	begin stackresult(fexp,attos); { boolean result at tos }
	{ reverse arguments => subset operation }
	stackops(opnd2,opnd1);
	end;
      innode:
	begin stackresult(fexp,attos);
	extend(opnd1,long); pushvalue(opnd1);
	pushaddress(opnd2);
	end;
      otherwise escape(-8);
      end; {case}
    saveregs; forgetbaseregs;
    case fexp^.eclass of
      diffnode      : callstdproc('ASM_DIFFERENCE');
      intersectnode : callstdproc('ASM_INTERSECT');
      unionnode     : callstdproc('ASM_UNION');
      supersetnode,
      subsetnode    : callstdproc('ASM_INCLUSION');
      eqnode        : callstdproc('ASM_EQUAL');
      nenode        : callstdproc('ASM_NEQUAL');
      innode        :
$if not bigsets$
		      callstdproc('ASM_IN');
$end$
$if bigsets$
		      callstdproc('ASM_XIN');
$end$
      end; {case}
    reloadregs;
    end {with}
  end; {gensetop}

procedure ovflck;
  begin
  if ovflcheck then emit0(trapv);
  end;

procedure pushvarstring(fexp: exptr);
  var
    op1: attrtype;
  begin
  genexpr(fexp);
  SPminus.storage := bytte;
  with fexp^,attr^ do
    if etyptr = strgptr then
      begin  {actual is var string}
      offset := offset+4;
      emit2(move,attr^,SPminus);
      offset := offset-4;
      end
    else
      begin
      op1.addrmode := immediate;
      op1.smallval := etyptr^.maxleng;
      emit2(move,op1,SPminus);
      end;
  pushaddress(fexp);
  end;

procedure pushsubstr(fexp: exptr);
  var
    op: attrtype;
    temp: integer;
  begin
  with fexp^ do
    begin
    if strgtype(arayp^.etyptr) then
      pushvarstring(arayp)
    else { paoc }
      begin
      with op do
	begin
	addrmode := immediate;
	getbounds(arayp^.etyptr^.inxtype,temp,
				       smallval);
	end;
      SPminus.storage := long;
      emit2(move,op,SPminus);
      pushaddress(arayp);
      end;
    extend(indxp,long);
    pushvalue(indxp);
    if lengthp <> NIL then
      begin
      extend(lengthp,long);
      pushvalue(lengthp);
      end;
    end;
  end;

procedure genconcat(dest,tree: exptr); forward;

function branchmatch(exp1,exp2: exptr): boolean;
  begin
    if exp1^.eclass <> exp2^.eclass then branchmatch := false
    else case exp1^.eclass of
      eqnode..andnode:
	branchmatch := branchmatch(exp1^.opnd1,exp2^.opnd1) and
		       branchmatch(exp1^.opnd2,exp2^.opnd2);
      negnode..truncnode:
	branchmatch := branchmatch(exp1^.opnd,exp2^.opnd);
      idnode:
	branchmatch := exp1^.symptr = exp2^.symptr;
      subscrnode:
	branchmatch := branchmatch(exp1^.arayp,exp2^.arayp) and
		       branchmatch(exp1^.indxp,exp2^.indxp);
      selnnode:
	branchmatch := branchmatch(exp1^.recptr,exp2^.recptr) and
		       (exp1^.fieldptr = exp2^.fieldptr);
      unqualfldnode:
	branchmatch := (exp1^.withstptr = exp2^.withstptr) and
		       (exp1^.fieldref = exp2^.fieldref);
      litnode:
	if exp1^.litval.intval then
	  if exp2^.litval.intval then
	    branchmatch := exp1^.litval.ival = exp2^.litval.ival
	  else branchmatch := false
	else branchmatch := false;
      otherwise branchmatch := false;
    end; {case}
  end; {branchmatch}

procedure stringassign(source,dest: exptr);

  var
    op1,op2,
    sourceattr,destattr: attrtype;
    checking: boolean;
    lexp: exptr;
    lstp: stp;

  begin { string assign }
  if source^.eclass = concatnode then
    begin
    getlocstorage(256,op1);
    new(lexp);
    new(lstp);
    with lexp^ do
      begin
      attr := addr(op1);
      lstp^:= strgptr^;
      lstp^.unpacksize := 256;
      etyptr := lstp;
      eclass := idnode;
      symptr := NIL;
      end;
    genconcat(lexp,source);
    stringassign(lexp,dest);
    end
  else { string }
    if not branchmatch(source,dest) then
      begin
      with source^ do
	begin
	makeaddressable(source);
	with sourceattr do
	  begin
	  addrmode := inAreg;
	  regnum := getreg(A);
	  end;
	emit2(lea,{source^.}attr^,sourceattr);
	freeregs({source^.}attr);
	sourceattr.addrmode := postincr;
	with op1 do
	  begin
	  addrmode := inDreg; regnum := getreg(D);
	  storage := bytte;
	  end;
	emit2(move,sourceattr,op1); {load source size}
	checking := false;
	if rangecheck then
	  if dest^.etyptr = strgptr then { var string }
	    begin
	    genexpr(dest);
	    with dest^, attr^ do
	      begin
	      offset := offset + 4;
	      emit2(cmp,attr^,op1);
	      offset := offset - 4;
	      end;
	    checking := true;
	    end
	  else if ({source^.}eclass <> litnode) and
		  strgtype({source^.}etyptr) then
	    begin
	    with op2 do
	      begin
	      addrmode := immediate; storage := bytte;
	      smallval := dest^.etyptr^.maxleng;
	      end;
	    emit2(cmpi,op2,op1);
	    checking := true;
	    end;
	end; { with source^ }
      if checking then
	begin
	with op2 do
	  begin offset := 2; storage := bytte; end;
	emit1(bls,op2);
	op2.smallval := 7;
	emit1(trap,op2);
	end;
      with destattr do
	begin
	addrmode := inAreg;
	regnum := getreg(A);
	end;
      makeaddressable(dest);
      emit2(lea,dest^.attr^,destattr);
      freeregs(dest^.attr);
      destattr.addrmode := postincr;
      destattr.storage := bytte;
      emit2(move,op1,destattr);
      emit2(move,sourceattr,destattr);
      with op2 do
	begin
	addrmode := immediate; smallval := 1;
	end;
      emit2(subq,op2,op1);
      op2.offset := -6;
      emit1(bhi,op2);
      freeit(A,destattr.regnum);
      freeit(D,op1.regnum);
      freeit(A,sourceattr.regnum);
      end; { string }
  end; { stringassign }

procedure pushparms{formalp: ctp; actualp: elistptr};
  var
    formaltype: stp; op1: attrtype;

    procedure pushdopevector(formalpidtype: stp; dopevec: stp);
      var
	lo,hi: integer;
	op,
	dope_element : attrtype;

      begin
      if formalpidtype^.aeltype^.form = cnfarrays then
	pushdopevector(formalpidtype^.aeltype,dopevec^.aeltype);

      with dopevec^ do
	begin
	case formalpidtype^.inxtype^.unpacksize of
	  1: SPminus.storage := bytte;
	  2: SPminus.storage := wrd;
	  4: SPminus.storage := long;
	end;
	if form = cnfarrays then
	  begin
	  with dope_element do
	    begin
	    addrmode := locinreg;
	    regnum := getbasereg(dopevec^.cnf_index^.hiboundid^.vlev);
	    indexed := false;
	    gloptr := NIL;
	    end;
	  with cnf_index^ do
	    if formalpidtype^.inxtype^.unpacksize = inxtype^.unpacksize then
	      begin
	      if SPminus.storage = long then
		dope_element.offset := hiboundid^.vaddr + 4
	      else
		dope_element.offset := hiboundid^.vaddr + 2;
	      emit2(move,dope_element,SPminus); {push length}
	      if SPminus.storage = long then
		dope_element.offset := dope_element.offset - 4
	      else
		dope_element.offset := dope_element.offset - 2;
	      emit2(move,dope_element,SPminus); {push upper bound}
	      dope_element.offset := loboundid^.vaddr;
	      emit2(move,dope_element,SPminus); {push lower bound}
	      end
	    else { extend word to long before pushing }
	      begin
	      with op do
		begin
		addrmode := inDreg;
		storage := wrd;
		regnum := getreg(D);
		end;
	      if inxtype^.unpacksize = 4 then
		dope_element.offset := hiboundid^.vaddr + 4
	      else
		dope_element.offset := hiboundid^.vaddr + 2;
	      emit2(move,dope_element,op);
	      op.storage := long;
	      emit1(ext,op);
	      emit2(move,op,SPminus); {push length}
	      if inxtype^.unpacksize = 4 then
		dope_element.offset := dope_element.offset - 4
	      else
		dope_element.offset := dope_element.offset - 2;
	      op.storage := wrd;
	      emit2(move,dope_element,op);
	      op.storage := long;
	      emit1(ext,op);
	      emit2(move,op,SPminus); {push upper bound}
	      dope_element.offset := loboundid^.vaddr;
	      op.storage := wrd;
	      emit2(move,dope_element,op);
	      op.storage := long;
	      emit1(ext,op);
	      emit2(move,op,SPminus); {push lower bound}
	      freeit(D,op.regnum);
	      end;
	  freeregs(addr(dope_element));
	  end
	else {form = arrays}
	  begin
	  op.addrmode := immediate;
	  if (aeltype^.form = arrays) then
	    op.smallval := aelsize
	  else
	    if aispackd then
	      op.smallval := aelbitsize
	    else
	      op.smallval := aelsize;
	  getbounds(inxtype,lo,hi);
	  emit2(movei,op,SPminus);  {push length}
	  op.smallval := hi;
	  emit2(movei,op,SPminus);  {push upper bound}
	  op.smallval := lo;
	  emit2(movei,op,SPminus);  {push lower bound}
	  end;
	end;
      end;

begin { pushparms }
while formalp <> NIL do
  with formalp^ do
    begin
    if rangecheck and (vtype = valparm) then
      emitcheck(actualp^.expptr,idtype,true);
    { cvalparms will be rangechecked in the routine itself }
    if (vtype = cvalparm) then
      pushaddress(actualp^.expptr)
    else if (vtype = refparm) or
	    (vtype = anyvarparm) then
      pushaddress(actualp^.expptr)
    else if vtype = strparm then {var str formal}
      pushvarstring(actualp^.expptr)
    else if vtype = dopeparm then { conformant array dope vector }
      pushdopevector(formalp^.idtype,actualp^.expptr^.etyptr)
    else
      with actualp^ do
	begin {valparm}
	with formalp^ do
	  if klass = vars then formaltype := idtype
	  else formaltype := proktype;
	makeaddressable(expptr);
	case formaltype^.unpacksize of
	  0  : {empty record};
	  1  : if expptr^.attr^.storage <> bytte then extend(expptr,bytte);
	  2  : if expptr^.attr^.storage <> wrd then extend(expptr,wrd);
	  3,4: if expptr^.attr^.storage <> long then extend(expptr,long);
	  8  : {real or procedure variable or constant};
	  end;
	if formaltype^.form in [prok,funk] then
	  with expptr^ do
	    if ekind <> cnst then pushvalue(expptr)
	    else {actual is prok constant}
	      begin SPminus.storage := long;
	      if symptr^.pflev > 1 then movestatic(symptr^.pflev,SPminus)
	      else emit1(clr,SPminus);  {assumes nilvalue = 0}
	      if not isoverlay(symptr,getaddress) then { OVERLAY MODULE }
		emit1(pea,attr^);
	      end
	else
	  begin
	  if not rangecheck then maskboolexpr(expptr);
	  pushvalue(expptr);
	  end;
	end;
    if vtype <> dopeparm then
      actualp := actualp^.nextptr;
    formalp := next;
    end;
end; {pushparms}

procedure genaddr(* fexp,dest: exptr *);
  { code gen for addr function.  Fexp is the fcallnode;
    if dest is NIL result goes to stack, else to dest. }
  var offsetexpr: exptr;
      destattr: attrtype;

  procedure moveaddr(fexp: exptr);
    begin
      if dest=NIL then pushaddress(fexp)
      else moveaddress(fexp,destattr);
    end;

  begin {genaddr}
    with fexp^.actualp^ do
      begin
      if dest <> NIL then destattr := dest^.attr^
      else
	begin
	SPind.storage := long;
	destattr := SPind;
	end;
      genexpr(expptr);
      if nextptr = NIL then moveaddr(expptr)
      else begin {optional offset supplied}
	offsetexpr := nextptr^.expptr;
	genexpr(offsetexpr);
	with offsetexpr^.attr^ do
	  if addrmode = immediate then
	    if expptr^.attr^.access = indirect then
	      begin moveaddr(expptr);
	      if smallval <> 0 then
		emit2(add,offsetexpr^.attr^,destattr);
	      end
	    else
	      begin {direct access}
	      expptr^.attr^.offset := expptr^.attr^.offset+smallval;
	      moveaddr(expptr);
	      end
	  else
	    begin {non-constant offset}
	    loadvalue(offsetexpr);
	    if expptr^.attr^.indexed or
		(expptr^.attr^.access = indirect) then
	      begin
	      moveaddr(expptr);
	      extend(offsetexpr,long);
	      emit2(add,offsetexpr^.attr^,destattr);
	      freeit(D,regnum);
	      end
	    else {make offset the index reg}
	      begin
	      if storage = bytte then extend(offsetexpr,wrd);
	      if (storage = wrd) and not signbit then
		extend(offsetexpr,long);
	      expptr^.attr^.indexed := true;
	      expptr^.attr^.indexreg := regnum;
	      expptr^.attr^.indexstorage := storage;
	      $IF MC68020$
	      expptr^.attr^.indexscale := 0;
	      $END$
	      moveaddr(expptr);
	      end;
	    end; {non-constant offset}
	end; {optional offset}
      end; {with actualp^}
  end; {genaddr}

    procedure callvar
      (* formalp: ctp; actualp: elistptr; isfunc: boolean *);
      {call prok var, prok or func param}
      var op1: attrtype; patchloc: addrrange;
      begin
      with actualp^ do
	begin
	pushparms(formalp,nextptr);
	genexpr(expptr);
	if isfunc then {in case genexpr found generalized func}
	  expptr^.attr^.access := direct;
	makeaddressable(expptr);
	with expptr^,attr^ do
	  begin
	  offset := offset+4;
	  storage := long;
	  emit1(tst,attr^);
	  {  code sequence assumes nilvalue = 0  }
	  patchloc := codephile.bytecount + 2;
	  op1.offset := 0; op1.storage := bytte;
	  emit1(beq,op1);
	  SPminus.storage := long;
	  emit2(move,attr^,SPminus);
	  offset := offset-4;
	  fixbyte(patchloc-1,codephile.bytecount - patchloc);
	  freeregs(attr);
	  getregattr(A,op1);
	  emit2(movea,attr^,op1);
	  freeit(A,op1.regnum);
	  with op1 do
	    begin addrmode := locinreg;
	    indexed := false; gloptr := NIL;
	    end;
	  if isfunc then begin saveregs; forgetbaseregs end;
	  emit1(jsr,op1);             { jsr (A0) }
	  if isfunc then reloadregs else clear(false);
	  end;
	end;
      end;

    function getstorageinfo(fsp: stp): stortype;
      begin
	if fsp = NIL then getstorageinfo := wrd
	else
	  case fsp^.unpacksize of
	    1: getstorageinfo := bytte;
	    2: getstorageinfo := wrd;
	    4: getstorageinfo := long;
	    otherwise getstorageinfo := multi
	    end;
      end; {getstorageinfo}

    procedure getattrec(fexp: exptr);
      begin
	with fexp^ do
	  begin
	  if freeattr = NIL then new(attr)
	  else
	    begin
	     attr := freeattr;
	    freeattr := freeattr^.next;
	    end;
	  attr^.next := globalattrlist^;
	  globalattrlist^ := attr;
	  with attr^ do
	    begin
	    storage := getstorageinfo(etyptr);
	    packd := false;
	    access := direct;
	    indexed := false;
	    offset := 0;
	    regnum := 0;
	    signbit := false;
	    gloptr := NIL;
	    {ensure known values for packed fields}
	    bitsize := 0;
	    with bitoffset do
	      begin static := 0; variable := -1; end;
	    end;
	  end;

      end;

    procedure genshortand(fexp: exptr;
	VAR truelist,falselist: reflistptr;
	onright,falsedefined, value: boolean; valueattr : attrptr);
      var
	bptr,newtruelist,
	templist1,templist2: reflistptr;
	op: attrtype;
      begin
	with fexp^ do
	  begin
	  newtruelist := NIL;
	  if opnd1^.eclass = andnode then
	    genshortand(opnd1,newtruelist,falselist,false,falsedefined,
			value,valueattr)
	  else if opnd1^.eclass = ornode then
	    begin
	    genshortor(opnd1,newtruelist,falselist,false,falsedefined,
		       value,valueattr);
	    {generate jump to false}
	    if not falsedefined then
	      begin
	      new(bptr);
	      bptr^.next := falselist;
	      falselist := bptr;
	      end;
	    getbrattr(falselist^.pc,falsedefined,op);
	    emit1(bra,op)
	    end
	  else if not value then
	    if falsedefined then
	      gencond(opnd1,falselist,true)
	    else
	      begin
	      gencond(opnd1,templist2,false);
	      templist1 := templist2;
	      if templist2 <> NIL then
		begin
		while templist2^.next <> NIL do
		  templist2 := templist2^.next;
		templist2^.next := falselist;
		falselist := templist1;
		end;
	      end
	  else
	    begin
	    movevalue(opnd1,valueattr^);
	    conditionis := bne;
	    if not falsedefined then
	      begin
	      new(bptr);
	      bptr^.next := falselist;
	      falselist := bptr;
	      end;
	    getbrattr(falselist^.pc,falsedefined,op);
	    case conditionis of { use opposite }
	      beq: emit1(bne,op);
	      bne: emit1(beq,op);
	      blt: emit1(bge,op);
	      bcs: emit1(bcc,op);
	      ble: emit1(bgt,op);
	      bls: emit1(bhi,op);
	      bgt: emit1(ble,op);
	      bhi: emit1(bls,op);
	      bge: emit1(blt,op);
	      bcc: emit1(bcs,op);
	      otherwise escape(-8);
	    end; { case }
	    end;
	  fixreflist(newtruelist);
	  if opnd2^.eclass = andnode then
	    genshortand(opnd2,truelist,falselist,onright,falsedefined,
		       value,valueattr)
	  else if opnd2^.eclass = ornode then
	    begin
	    genshortor(opnd2,truelist,falselist,onright,falsedefined,
			value,valueattr);
	    {generate jump to false}
	    if not falsedefined then
	      begin
	      new(bptr);
	      bptr^.next := falselist;
	      falselist := bptr;
	      end;
	    getbrattr(falselist^.pc,falsedefined,op);
	    emit1(bra,op)
	    end
	  else
	    if value then
	      begin
	      movevalue(opnd2,valueattr^);
	      conditionis := bne;
	      if not onright then
		begin
		if not falsedefined then
		  begin
		  new(bptr);
		  bptr^.next := falselist;
		  falselist := bptr;
		  end;
		getbrattr(falselist^.pc,falsedefined,op);
		case conditionis of { use opposite }
		  beq: emit1(bne,op);
		  bne: emit1(beq,op);
		  blt: emit1(bge,op);
		  bcs: emit1(bcc,op);
		  ble: emit1(bgt,op);
		  bls: emit1(bhi,op);
		  bgt: emit1(ble,op);
		  bhi: emit1(bls,op);
		  bge: emit1(blt,op);
		  bcc: emit1(bcs,op);
		  otherwise escape(-8);
		end; { case }
		end;
	      end
	  else
	    if falsedefined then
	      gencond(opnd2,falselist,true)
	    else
	      begin
	      gencond(opnd2,templist2,false);
	      templist1 := templist2;
	      if templist2 <> NIL then
		begin
		while templist2^.next <> NIL do
		  templist2 := templist2^.next;
		templist2^.next := falselist;
		falselist := templist1;
		end;
	      end;
	  end; { with fexp }
      forgetbaseregs;
      end; { genshortand }

    procedure genshortor(fexp: exptr;
	VAR truelist,falselist: reflistptr;
	onright,falsedefined,value: boolean; valueattr : attrptr);
      var
	bptr,newfalselist: reflistptr;
	op: attrtype;
      begin
	with fexp^ do
	  begin
	  newfalselist := NIL;
	  if opnd1^.eclass = andnode then
	    begin
	    genshortand(opnd1,truelist,newfalselist,false,false,
			value,valueattr);
	    {generate jump to true}
	    new(bptr);
	    bptr^.next := truelist;
	    truelist := bptr;
	    getbrattr(truelist^.pc,false,op);
	    emit1(bra,op)
	    end
	  else if opnd1^.eclass = ornode then
	    genshortor(opnd1,truelist,newfalselist,false,false,
		      value,valueattr)
	  else
	    begin
	    if value then
	      begin
	      movevalue(opnd1,valueattr^);
	      conditionis := bne;
	      end
	    else
	      begin
	      conditionis := bne;
	      loadvalue(opnd1);
	      freeregs(opnd1^.attr);
	      end;
	    new(bptr);
	    bptr^.next := truelist;
	    truelist := bptr;
	    getbrattr(truelist^.pc,false,op);
	    emit1(conditionis,op)
	    end;
	  fixreflist(newfalselist);
	  if opnd2^.eclass = andnode then
	    begin
	    genshortand(opnd2,truelist,falselist,onright,falsedefined,
		       value,valueattr);
	    new(bptr);
	    bptr^.next := truelist;
	    truelist := bptr;
	    getbrattr(truelist^.pc,false,op);
	    emit1(bra,op)
	    end
	  else if opnd2^.eclass = ornode then
	    genshortor(opnd2,truelist,falselist,onright,falsedefined,
		      value,valueattr)
	  else
	    begin
	    if value then
	      begin
	      movevalue(opnd2,valueattr^);
	      conditionis := bne;
	      end
	    else
	      begin
	      conditionis := bne;
	      loadvalue(opnd2);
	      freeregs(opnd2^.attr);
	      end;
	    if not onright or not value then
	      begin
	      new(bptr);
	      bptr^.next := truelist;
	      truelist := bptr;
	      getbrattr(truelist^.pc,false,op);
	      emit1(conditionis,op);
	      end;
	    end;
	  end; { with fexp }
      forgetbaseregs;
      end; { genshortor }

    procedure genconcat(dest,tree: exptr);
      var
	op: attrtype;

      procedure genappend(dest,tree: exptr);
	begin
	if tree^.eclass = concatnode then
	  begin
	  genappend(dest,tree^.opnd1);
	  genappend(dest,tree^.opnd2);
	  end
	else
	  begin
	  makeaddressable(tree);
	  genexpr(dest);
	  pushvarstring(dest);
	  if strgtype(tree^.etyptr) then
	    pushaddress(tree)
	  else escape(-8);
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_SAPPEND');
	  reloadregs;
	  end;
	end; { genappend }

      procedure findfarleft(dest,tree: exptr);
	begin
	if tree^.eclass = concatnode then
	  begin
	  findfarleft(dest,tree^.opnd1);
	  genappend(dest,tree^.opnd2);
	  end
	else
	  begin
	  loadaddress(dest,false);
	  if reg[A,dest^.attr^.regnum].usage =
				 withrecbase then
	    with op do
	      begin
	      addrmode := inAreg;
	      storage := long;
	      regnum := getreg(A);
	      emit2(movea,dest^.attr^,op);
	      dest^.attr^.regnum := regnum;
	      end;
	  with reg[A,dest^.attr^.regnum] do
	    begin
	    usage := basereg;
	    usesleft := maxint;
	    baselevel := 0;
	    end;
	  stringassign(tree,dest);
	  end;
	end;

      begin { genconcat }
      findfarleft(dest,tree^.opnd1);
      genappend(dest,tree^.opnd2);
      with reg[A,dest^.attr^.regnum] do
	begin
	usage := other;
	allocstate := allocated;
	usesleft := 0;
	end;
      end;

    function isoverlay(pfptr: ctp; callt: calltype): boolean;
      var
	found: boolean;
	i: shortint;
	nametemp: string255;
	expptr: exptr;
	ctptemp: ctp;
	op: attrtype;
      begin
      isoverlay := false;
      if not(pfptr^.alias) and not(pfptr^.isdumped) then
	begin
	if pfptr^.othername <> NIL then
	  begin
	  found := false;
	  i := 1;
	  while not found and (i <= overlaytop) do
	    if pfptr^.othername^ = overlaylistptr^[i] then
	      found := true
	    else
	      i := i + 1;
	  if found then { overlay }
	    begin
	    nametemp := pfptr^.othername^ + '_' +
			pfptr^.namep^;
	    new(expptr);
	    with expptr^ do
	      begin
	      eclass := litnode;
	      etyptr := NIL;
	      attr := NIL;
	      litval.intval := false;
	      new(litval.valp);
	      with litval.valp^ do
		begin
		cclass := strng;
		slgth := strlen(nametemp);
		strmove(slgth,nametemp,1,sval,1);
		end;
	      end;
	    genexpr(expptr);
	    pushaddress(expptr);
	    new(ctptemp);
	    ctptemp^ := pfptr^;
	    ctptemp^.othername := addr(OVERLAY);
	    if callt = getaddress then
	      ctptemp^.namep := addr(ADDRESS)
	    else
	      ctptemp^.namep := addr(EXEC);
	    getprokconst(ctptemp,op);
	    emit1(jsr,op);
	    isoverlay := true;
	    end; { if found }
	  end; { othername <> NIL }
	end;
      end;

    procedure genexpr{fexp: exptr};
      var
	lform: structform;
	lop,rop,oldattr,op: attrtype;
	lexp: exptr;
	lstp: stp;

      procedure genfcall(fexp: exptr);
	var destoffset,resultsize: addrrange;
	    offsetexpr,source,letter,lngth: exptr;
	    sexp: elistptr; op: attrtype;
	    $IF MC68020$
	    i: shortint;
	    lbl1,lbl2: localref;
	    at: attrptr;
	    $END$

	begin
	with fexp^,fptr^ do
	  if (klass <> func) or (pfdeckind = declared) then
	    begin
	    if etyptr^.form >= prok then
	      begin getlocstorage(etyptr^.unpacksize,attr^);
	      emit1(pea,attr^);
	      end
	    else
	      begin resultsize := etyptr^.unpacksize;
	      if odd(resultsize) then resultsize := resultsize+1;
	      with op do
		begin addrmode := immediate; smallval := resultsize end;
	      SPdir.storage := long;
	      emit2(subq,op,SPdir);
	      attr^.addrmode := topofstack;
	      getsignbit(etyptr,attr);
	      end;
	    if klass = routineparm then
	      callvar(proktype^.params,actualp,true)
	    else {function constant}
	      begin pushparms(next,actualp);
	      if pflev > 1 then
		begin SPminus.storage := long; movestatic(pflev,SPminus) end;
	      saveregs; forgetbaseregs;
	      if not isoverlay(fptr,gencall) then
		begin
		getprokconst(fptr,op);
		emit1(jsr,op);
		end;
	      reloadregs;
	      end;
	    end
	  else
	    case spkey of
	      spunitbusy,speoln,speof,spposition,
	      spmaxpos,sppos,spstrpos,spstrrpt,
	      spltrim,sprtrim,spmemavail:
		begin
		if spkey in
		    [spstrrpt,spltrim,sprtrim] then
		  begin {string-valued func}
		  getlocstorage(etyptr^.unpacksize,attr^);
		  emit1(pea,attr^);
		  end
		else
		  begin resultsize := etyptr^.unpacksize;
		  if odd(resultsize) then resultsize := resultsize+1;
		  with op do
		    begin addrmode := immediate; smallval := resultsize; end;
		  SPdir.storage := long;
		  emit2(subq,op,SPdir);
		  attr^.addrmode := topofstack;
		  getsignbit(etyptr,attr);
		  end;
		if spkey in [spposition,
		    spmaxpos,speoln,speof] then
		  pushaddress(actualp^.expptr)
		else pushparms(next,actualp);
		saveregs; forgetbaseregs;
		if (spkey=speoln)     or
		   (spkey=speof)      or
		   (spkey=spposition) or
		   (spkey=spmaxpos) then
		  callIOproc('FS_F' + namep^)
		else if (spkey = spstrpos) or
			(spkey = sppos) then
		  callstdproc('ASM_POS')
		else
		  case spkey of
		    spunitbusy:
		      callstdproc('UIO_UNITBUSY');
		    spstrrpt,spltrim,sprtrim,
		    spmemavail:
		      callstdproc('ASM_' + namep^);
		  end;
		reloadregs;
		end;
	      spstr,spcopy:
		begin
		getlocstorage(etyptr^.unpacksize,op);
		op.storage := long;
		emit1(pea,op);                         { PEA localtemp }
		attr^.addrmode := loconstack;
		attr^.access := indirect;
		SPminus.storage := long;
		emit2(move,SPind,SPminus);             { MOVE.L (SP),-(SP) }
		pushparms(next,actualp);
		saveregs; forgetbaseregs;
		callstdproc('ASM_SCOPY');
		reloadregs;
		end;
	      spconcat:
		begin
		getlocstorage(etyptr^.unpacksize,op);
		op.storage := bytte;
		emit1(clr,op);               { CLR.B  dest temp }
		op.storage := long;
		emit1(pea,op);               { PEA    dest temp }
		sexp := actualp;
		with op do
		  begin
		  addrmode := immediate;
		  smallval := etyptr^.unpacksize - 1;
		  end;
		repeat
		  SPminus.storage := bytte;
		  emit2(move,op,SPminus);
		  SPminus.storage := long;
		  SPind.offset := 2;
		  emit2(move,SPind,SPminus);
		  SPind.offset := 0;             { MOVE.L (SP),-(SP) }
		  pushaddress(sexp^.expptr);
		  saveregs; forgetbaseregs;
		  callstdproc('ASM_SAPPEND');
		  reloadregs;
		  sexp := sexp^.nextptr;
		  until sexp = NIL;
		attr^.addrmode := loconstack;
		attr^.access := indirect;
		end;
	      spesccode:
		with attr^ do
		  begin storage := wrd; addrmode := locinreg;
		  regnum := SB; offset := escapecodedisp;
		  signbit := true; indexed := false;
		  gloptr := sysglobalptr;
		  end;
	      spaddr:
		begin attr^.addrmode := topofstack;
		attr^.signbit := false;
		genaddr(fexp,NIL);
		end;
	      spscan:
		begin
		extend(actualp^.expptr,wrd);
		pushvalue(actualp^.expptr);    { 0 for until 1 for while }
		actualp := actualp^.nextptr;
		with actualp^ do
		  begin
		  source := expptr;
		  letter := nextptr^.expptr;
		  lngth := nextptr^.nextptr^.expptr;
		  end;
		pushaddress(source);
		extend(letter,bytte);
		pushvalue(letter);
		extend(lngth,long);
		pushvalue(lngth);
		saveregs; forgetbaseregs;
		callstdproc('ASM_SCAN');
		reloadregs;
		with attr^ do
		  begin
		  addrmode := topofstack; signbit := true; storage := long;
		  end;
		end;
	      spblockread, spblockwrite:
		with attr^ do
		  begin
		  storage:=long; signbit:=true; addrmode:=topofstack;
		  with op do
		    begin addrmode := immediate; smallval := 4; end;
		  SPdir.storage := long;
		  emit2(subq,op,SPdir);        { SUBQ.L #4,SP }
		  sexp := actualp; pushaddress(sexp^.expptr); {file}
		  sexp := sexp^.nextptr; pushaddress(sexp^.expptr); {buffer}
		  sexp := sexp^.nextptr; extend(sexp^.expptr, long);
		  pushvalue(sexp^.expptr);                     {# of blocks}
		  sexp := sexp^.nextptr; extend(sexp^.expptr, long);
		  pushvalue(sexp^.expptr);                     {block number}
		  with op do
		    begin
		    addrmode := immediate;
		    if spkey=spblockread
		      then smallval := 1
		      else smallval := 0;
		    end;
		  SPminus.storage := bytte;
		  emit2(move,op,SPminus);              { MOVE.B 1or0,-SP }
		  saveregs; forgetbaseregs;
		  callIOproc('FS_FBLOCKIO');
		  reloadregs;
		  end;
	      spsin,spcos,spsqrt,spln,spexp,sparctan:
		$IF MC68020$
		if (float = flt_test) then
		  begin
		  {Emit test for card present}
		  with op do
		    begin
		    storage := bytte;
		    addrmode := longabs;
		    offset := 0;
		    indexed := false;
		    absaddr.intval := false;
		    new(absaddr.valp);
		    with absaddr.valp^ do
		      begin
		      cclass := paofch;
		      slgth := strlen(float_flag);
		      for i := 1 to slgth do
			sval[i] := float_flag[i];
		      end;
		    end;
		  emit1(tst,op);                        {TST.B float_flag}
		  lbl1.next := NIL;
		  getbrattr(lbl1.pc,false,op);
		  emit1(bne,op);                         {BNE  card present code}

		  {Generate code for libraries}
		  float := flt_off;
		  genfcall(fexp);
		  at := fexp^.attr;
		  NIL_attributes(fexp);
		  fexp^.attr := at;

		  lbl2.next := NIL;
		  getbrattr(lbl2.pc,false,op);
		  emit1(bra,op);                        {BRA  convergence point}

		  {Generate code for card}
		  fixreflist(addr(lbl1));
		  float:= flt_on;
		  genfcall(fexp);
		  pushvalue(fexp);       {Result must be same place as library result}
		  fixreflist(addr(lbl2));               {Convergence point}
		  float := flt_test;
		  forgetbaseregs;
		  end
		else if (float = flt_on) then
		  realop(fexp)
		else
		$END$
		with attr^ do
		  begin
		  storage := multi;
		  addrmode := topofstack;
		  signbit := true;
		  pushvalue(actualp^.expptr);
		  saveregs; forgetbaseregs;
		  case spkey of
		    spsin: callstdproc('ASM_SIN');
		    spcos: callstdproc('ASM_COS');
		    spsqrt: callstdproc('ASM_SQRT');
		    spln:  callstdproc('ASM_LN');
		    spexp: callstdproc('ASM_EXP');
		    sparctan: callstdproc('ASM_ARCTAN');
		  end;
		  reloadregs;
		  end;
	      sphex,spoctal,spbinary:
		begin
		pushaddress(actualp^.expptr);
		saveregs; forgetbaseregs;
		case spkey of
		  sphex: callstdproc('ASM_HEX');
		  spoctal: callstdproc('ASM_OCTAL');
		  spbinary: callstdproc('ASM_BINARY');
		end;
		reloadregs;
		with attr^ do
		  begin
		  addrmode := topofstack;
		  signbit := true;
		  storage := long;
		  end;
		end;
	      otherwise escape(-8);
	      end; {case spkey}
	end; {genfcall}

      procedure unaryops(fexp: exptr);
	var
	  lsp: stp;
	  op: attrtype;
	  chkovfl: boolean;
	  lbl1,lbl2: localref;
	  at: attrptr;
	  i: shortint;
	begin
	if (float = flt_test) and (fexp^.etyptr^.form = reals) and
	   (fexp^.eclass in [negnode,absnode,sqrnode,floatnode,roundnode]) then
	  begin
	  {Emit test for card present}
	  with op do
	    begin
	    storage := bytte;
	    addrmode := longabs;
	    offset := 0;
	    indexed := false;
	    absaddr.intval := false;
	    new(absaddr.valp);
	    with absaddr.valp^ do
	      begin
	      cclass := paofch;
	      slgth := strlen(float_flag);
	      for i := 1 to slgth do
		sval[i] := float_flag[i];
	      end;
	    end;
	  emit1(tst,op);                        {TST.B float_flag}
	  lbl1.next := NIL;
	  getbrattr(lbl1.pc,false,op);
	  emit1(bne,op);                         {BNE  card present code}

	  {Generate code for libraries}
	  float := flt_off;
	  unaryops(fexp);
	  at := fexp^.attr;
	  forgetbaseregs;
	  NIL_attributes(fexp);
	  fexp^.attr := at;

	  lbl2.next := NIL;
	  getbrattr(lbl2.pc,false,op);
	  emit1(bra,op);                        {BRA  convergence point}

	  {Generate code for card}
	  fixreflist(addr(lbl1));
	  float:= flt_on;
	  realop(fexp);
	  pushvalue(fexp);       {Result must be save place as library result}
	  fixreflist(addr(lbl2));               {Convergence point}
	  float := flt_test;
	  forgetbaseregs;
	  end
	else with fexp^,attr^ do
	  begin lsp := opnd^.etyptr;
	  if (float = flt_on) and (etyptr^.form = reals) then {no op}
	  else if (etyptr^.form = reals) and (eclass=negnode) then pushvalue(opnd)
	  else if eclass in [negnode,notnode,oddnode] then loadvalue(opnd)
	  else genexpr(opnd);
	  case eclass of
	    negnode:
	      begin
	      if etyptr^.form = reals then
		if float = flt_on then realop(fexp)
		else
		  begin
		  op.addrmode := immediate;
		  op.smallval := 7;
		  emit2(bchg,op,SPind);                   { BCHG #7,(SP) }
		  liftattr(fexp,opnd);
		  storage := opnd^.attr^.storage; { copy storage too }
		  end
	      else
		begin
		if not opnd^.attr^.signbit then
		  extend(opnd,succ(opnd^.attr^.storage));
		emit1(neg,opnd^.attr^);                  { NEG.z Dregnum }
		liftattr(fexp,opnd);
		storage := opnd^.attr^.storage; { copy storage too }
		end;
	      end;
	    notnode:
	      begin
	      if opnd^.ekind = xpr then maskboolexpr(opnd);
	      liftattr(fexp,opnd);
	      emit2(bchg,immed0,attr^);                 { BCHG #0,Dregnum }
	      conditionis := beq;
	      end;
	    absnode:
	      begin
	      if etyptr^.form = reals then
		if float = flt_on then realop(fexp)
		else
		  begin
		  pushvalue(opnd);
		  SPind.storage := wrd;
		  emit1(tst,SPind);                       { TST.W (SP) }
		  with op do
		    begin offset := 4; storage := bytte end;
		  emit1(bge,op);                          { BGE.S *+6 }
		  op.smallval := 7;
		  emit2(bchg,op,SPind);                   { BCHG #7,(SP) }
		  liftattr(fexp,opnd);
		  storage := opnd^.attr^.storage;
		  end
	      else
		begin
		if opnd^.attr^.signbit then
		  with opnd^.attr^ do
		    begin
		    loadvalue(opnd);
		    chkovfl := true;
		    if storage <> long then
		      begin
		      extend(opnd,succ(storage));
		      chkovfl := false;
		      end;
		    with op do
		      begin offset := 2; storage := bytte end;
		    emit1(bge,op);                          { BGE *+4 }
		    emit1(neg,opnd^.attr^);                 { NEG.z Dregnum }
		    if chkovfl then ovflck;
		    end;
		liftattr(fexp,opnd);
		storage := opnd^.attr^.storage;
		end;
	      end;
	    ordnode:
	      begin
	      maskboolexpr(opnd);
	      liftattr(fexp,opnd);
	      storage := opnd^.attr^.storage;
	      end;
	    strlennode:
	      begin
	      liftattr(fexp,opnd);
	      storage := bytte;
	      signbit := false;
	      end;
	    strmaxnode:
	      begin liftattr(fexp,opnd);
	      access := direct;
	      storage := bytte;
	      offset := offset+4;
	      signbit := false;
	      end;
	    chrnode:
	      begin
	      if opnd^.attr^.addrmode <> immediate then
		begin
		if rangecheck then
		  emitcheck(opnd,char_ptr,true);
		extend(opnd,bytte);
		end;
	      liftattr(fexp,opnd);
	      signbit := false;
	      end; {chrnode}
	    oddnode:
	      begin liftattr(fexp,opnd); signbit := false;
	      op.addrmode := immediate; op.smallval := 1;
	      emit2(andd,op,attr^);
	      end;
	    sqrnode:
	      if etyptr^.form = reals then
		if float = flt_on then realop(fexp)
		else
		  begin pushvalue(opnd);
		  SPminus.storage := long;
		  SPind.offset := 4;
		  {now push a copy}
		  emit2(move,SPind,SPminus);              { MOVE.L 4(sp),-(sp) }
		  emit2(move,SPind,SPminus);              { MOVE.L 4(sp),-(sp) }
		  SPind.offset := 0; {restore}
		  saveregs; forgetbaseregs;
		  callstdproc('ASM_RMUL');
		  reloadregs;
		  addrmode := topofstack; storage := multi;
		  signbit := true;
		  end
	      else
		begin if opnd^.attr^.packd then makeaddressable(opnd);
		if opnd^.eclass = litnode then
		  fixliteral(opnd,wrd,true)
		else with opnd^.attr^ do
		  if (storage = wrd) and not signbit then extend(opnd,long);
		if opnd^.attr^.storage = long then
		  begin
		  $IF MC68020$
		    loadvalue(opnd);
		    emit2(muls,opnd^.attr^,opnd^.attr^);
		    ovflck;
		    liftattr(fexp,opnd);
		  $END$
		  $IF not MC68020$
		    pushvalue(opnd);
		    SPminus.storage := long;
		    emit2(move,SPind,SPminus);             { MOVE.L (SP),-(SP) }
		    saveregs; forgetbaseregs;
		    callstdproc('ASM_MPY');
		    reloadregs;
		    addrmode := topofstack;
		  $END$
		  storage := long; signbit := true;
		  end
		else
		  begin extend(opnd,wrd);
		  loadvalue(opnd);
		  emit2(muls,opnd^.attr^,opnd^.attr^);   { MULS Dr,Dr }
		  liftattr(fexp,opnd);
		  storage := long;
		  end;
		end;
	    roundnode,truncnode: { no support on float card }
	      begin
	      pushvalue(opnd);
	      saveregs; forgetbaseregs;
	      case eclass of
		roundnode: callstdproc('ASM_ROUND');
		truncnode: callstdproc('ASM_TRUNC');
	      end;
	      storage := long;
	      reloadregs;
	      addrmode := topofstack;
	      signbit := true;
	      end; {roundnode, truncnode}
	    floatnode:
	      if float = flt_on then realop(fexp)
	      else
		begin
		extend(opnd,long);
		pushvalue(opnd);
		saveregs; forgetbaseregs;
		if opnd^.etyptr^.form = reals then
		  liftattr(fexp,opnd)
		else
		  callstdproc('ASM_FLOAT');
		storage := multi;
		reloadregs;
		signbit := true;
		addrmode := topofstack;
		end;
	    end; {case eclass}
	  end; {with fexp^}
	end; {unaryops}

      procedure realrelCMP ( fexp : exptr );
	begin
	with fexp^, attr^ do
	  begin
	  pushvalue(opnd2); pushvalue(opnd1);
	  saveregs; forgetbaseregs;
	  case eclass of
	    eqnode: callstdproc('ASM_EQ');
	    nenode: callstdproc('ASM_NE');
	    gtnode: callstdproc('ASM_GT');
	    genode: callstdproc('ASM_GE');
	    ltnode: callstdproc('ASM_LT');
	    lenode: callstdproc('ASM_LE');
	    end; { case }
	  reloadregs;
	  addrmode := topofstack;
	  end; { with }
	end; { realrelCMP }

      procedure relxpr(fexp: exptr);
	{ code gen for relational node when a boolean result
	  is required }
	var
	  destonleft,signed: boolean;
	begin
	if fexp^.opnd1^.etyptr^.form = reals then realrelCMP(fexp)
	else
	  begin relCMP(fexp,destonleft,signed);
	  getregattr(D,fexp^.attr^);
	  fexp^.attr^.storage := bytte;
	  if destonleft then
	    case fexp^.eclass of
	      eqnode:
		begin
		emit1(seq,fexp^.attr^);
		conditionis := beq;
		end;
	      nenode:
		begin
		emit1(sne,fexp^.attr^);
		conditionis := bne;
		end;
	      ltnode:
		if signed then
		  begin
		  emit1(slt,fexp^.attr^);
		  conditionis := blt;
		  end
		else
		  begin
		  emit1(scs,fexp^.attr^);
		  conditionis := bcs;
		  end;
	      lenode:
		if signed then
		  begin
		  emit1(sle,fexp^.attr^);
		  conditionis := ble;
		  end
		else
		  begin
		  emit1(sls,fexp^.attr^);
		  conditionis := bls;
		  end;
	      gtnode:
		if signed then
		  begin
		  emit1(sgt,fexp^.attr^);
		  conditionis := bgt;
		  end
		else
		  begin
		  emit1(shi,fexp^.attr^);
		  conditionis := bhi;
		  end;
	      genode:
		if signed then
		  begin
		  emit1(sge,fexp^.attr^);
		  conditionis := bge;
		  end
		else
		  begin
		  emit1(scc,fexp^.attr^);
		  conditionis := bcc;
		  end;
	      end
	  else
	    case fexp^.eclass of
	      eqnode:
		begin
		emit1(seq,fexp^.attr^);
		conditionis := beq;
		end;
	      nenode:
		begin
		emit1(sne,fexp^.attr^);
		conditionis := bne;
		end;
	      ltnode:
		if signed then
		  begin
		  emit1(sgt,fexp^.attr^);
		  conditionis := bgt;
		  end
		else
		  begin
		  emit1(shi,fexp^.attr^);
		  conditionis := bhi;
		  end;
	      lenode:
		if signed then
		  begin
		  emit1(sge,fexp^.attr^);
		  conditionis := bge;
		  end
		else
		  begin
		  emit1(scc,fexp^.attr^);
		  conditionis := bcc;
		  end;
	      gtnode:
		if signed then
		  begin
		  emit1(slt,fexp^.attr^);
		  conditionis := blt;
		  end
		else
		  begin
		  emit1(scs,fexp^.attr^);
		  conditionis := bcs;
		  end;
	      genode:
		if signed then
		  begin
		  emit1(sle,fexp^.attr^);
		  conditionis := ble;
		  end
		else
		  begin
		  emit1(sls,fexp^.attr^);
		  conditionis := bls;
		  end;
	      end;
	  end; { if }
	end; {relxpr}

      procedure relpaofchxpr(fexp: exptr);
	{ generate a boolean result for a packed array of char relation}
	var
	  flbl: reflistptr;
	  op,r: attrtype;
	begin
	  getregattr(D,r);
	  new(flbl); flbl^.next := NIL;
	  genpaofchcond(fexp,flbl,false); {forward branch}
	  { if true then }
	  op.smallval := 1;
	  emit2(moveq,op,r);                            { MOVEQ #1,Dr }
	  with op do
	    begin offset := 2; storage := bytte end;
	  emit1(bra,op);                                { BRA.S *+4 }
	  { if false then }
	  fixreflist(flbl);                           { flbl EQU * }
	  r.storage := long;
	  emit1(clr,r);                                 { CLR.L Dr }
	  with fexp^.attr^ do
	    begin addrmode := inDreg; regnum := r.regnum end;
	end; { relpaofchxpr }

procedure powerof2(elsize:integer; var power:shortint);
  var i: shortint;
  begin
  power := 0;
  for i := 1 to bitsperword-2 do
    if elsize = power_table[i] then power := i;
  end;

procedure alops(fexp: exptr);
  { +,-,*,div,mod,and,or }
  type
    opindextype = (tos,mem,reg,slowlit,fastlit,quicklit,zilchlit);
    optype = array[addnode..andnode] of opcodetype;
  const
    op = optype
	[add,sub,
	 muls,divs,swap,divs, {dummies - only add,sub,andd,orr are needed}
	 orr,andd];
  var
    lopindex,ropindex: opindextype;
    lsigned,rsigned: boolean;
    lstorage,rstorage: stortype;
    lmode,rmode: addrtype;

  procedure genrealop;
    var
      op: attrtype;
      lbl1,lbl2: localref;
      at: attrptr;
      i: shortint;
    {real + - * /}
    begin
    if float = flt_test then
      begin
      {Emit test for card present}
      with op do
	begin
	storage := bytte;
	addrmode := longabs;
	offset := 0;
	indexed := false;
	absaddr.intval := false;
	new(absaddr.valp);
	with absaddr.valp^ do
	  begin
	  cclass := paofch;
	  slgth := strlen(float_flag);
	  for i := 1 to slgth do
	    sval[i] := float_flag[i];
	  end;
	end;
      emit1(tst,op);                        {TST.B float_flag}
      lbl1.next := NIL;
      getbrattr(lbl1.pc,false,op);
      emit1(bne,op);                         {BNE  card present code}

      {Generate code for libraries}
      float := flt_off;
      genrealop;
      at := fexp^.attr;
      NIL_attributes(fexp);
      fexp^.attr := at;

      lbl2.next := NIL;
      getbrattr(lbl2.pc,false,op);
      emit1(bra,op);                        {BRA  convergence point}

      {Generate code for card}
      fixreflist(addr(lbl1));
      float:= flt_on;
      realop(fexp);
      pushvalue(fexp);       {Result must be save place as library result}
      fixreflist(addr(lbl2));               {Convergence point}
      float := flt_test;
      forgetbaseregs;
      end
    else if float = flt_on then realop(fexp)
    else with fexp^,attr^ do
      begin
      pushvalue(opnd2); pushvalue(opnd1);
      saveregs; forgetbaseregs;
      case eclass of
	addnode: callstdproc('ASM_RADD');
	subnode: callstdproc('ASM_RSUB');
	mulnode: callstdproc('ASM_RMUL');
	divnode: callstdproc('ASM_RDIV');
	end; { case }
      reloadregs;
      addrmode := topofstack;
      storage := multi;
      signbit := true;
      end; {with}
    end;

  procedure genmulop;
    {code gen for *, DIV, MOD}
    var
      op: attrtype;
      patchloc: addrrange;
      res: shortint;
    begin
    with fexp^ do
      if eclass = mulnode then
	begin makeaddressable(opnd2);
	with opnd2^.attr^ do
	  begin
	  if addrmode = immediate then fixliteral(opnd2,wrd,true)
	  else if not signbit and (storage = wrd) then
	    extend(opnd2,long);
	  if storage = long then pushvalue(opnd2);
	  end;
	makeaddressable(opnd1);
	if opnd1^.attr^.addrmode = immediate then
	  fixliteral(opnd1,wrd,true);
	if (opnd1^.attr^.storage = long)
	    or (opnd2^.attr^.storage = long)
	    or (opnd1^.attr^.storage = wrd)
	    and not opnd1^.attr^.signbit then
	  begin
	  with opnd2^.attr^ do
	    if storage <> long then
	      begin
	      if addrmode = immediate then
		begin storage := long; signbit := true end
	      else checkstackandextend(opnd1,opnd2,long);
	      pushvalue(opnd2);
	      end;
	  with opnd1^.attr^ do
	    if storage <> long then
	      if addrmode = immediate then
		begin storage := long; signbit := true end
	      else extend(opnd1,long);
	  pushvalue(opnd1);
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_MPY');
	  reloadregs;
	  with attr^ do
	    begin addrmode := topofstack;
	    storage := long; signbit := true;
	    end;
	  end
	else
	  begin {in-line MPY}
	  extend(opnd1,wrd);
	  checkstackandextend(opnd1,opnd2,wrd);
	  if opnd2^.attr^.addrmode = inDreg then
	    begin
	    emit2(muls,opnd1^.attr^,opnd2^.attr^);{ MULS op1,Dop2 }
	    liftattr(fexp,opnd2);
	    freeregs(opnd1^.attr);
	    end
	  else
	    begin
	    loadvalue(opnd1);
	    emit2(muls,opnd2^.attr^,opnd1^.attr^);      { MULS op2,Dop1 }
	    liftattr(fexp,opnd1);
	    freeregs(opnd2^.attr);
	    end;
	  attr^.storage := long;
	  end;
	etyptr := intptr;
	end
      else
	begin {DIV or MOD}
	makeaddressable(opnd1);
	if opnd2^.eclass = litnode then
	  powerof2(opnd2^.litval.ival,res)
	else res := 0;
	if (eclass = modnode) and (res <> 0) then
	  begin
	  opnd2^.litval.ival := opnd2^.litval.ival - 1;
	  loadvalue(opnd1);
	  genexpr(opnd2);
	  fixliteral(opnd2,opnd1^.attr^.storage,true);
	  extend(opnd1,opnd2^.attr^.storage);
	  emit2(andi,opnd2^.attr^,opnd1^.attr^);
	  liftattr(fexp,opnd1);
	  attr^.storage := opnd1^.attr^.storage;
	  opnd2^.litval.ival := opnd2^.litval.ival + 1; { undo damage }
	  end
	else
	  begin
	  with opnd1^.attr^ do
	    begin
	    if addrmode = immediate then
	      fixliteral(opnd1,wrd,true)
	      else if not signbit and (storage = wrd) then
		extend(opnd1,long);
	    if storage = long then
	      $IF not MC68020$
	      pushvalue(opnd1)
	      $END$
	    else
	      if ((opnd2^.eclass = fcallnode) and
		  (opnd2^.etyptr^.unpacksize = 4{bytes})) or
		  (opnd2^.ekind = xpr) then
		begin
		extend(opnd1,long);
		$IF not MC68020$
		pushvalue(opnd1)
		$END$
		end;
	    end;
	  $IF MC68020$
	  loadvalue(opnd1);
	  $END$
	  makeaddressable(opnd2);
	  with opnd2^.attr^ do
	    begin
	    if addrmode = immediate then fixliteral(opnd2,wrd,true)
	    else if not signbit and (storage = wrd) then
	      extend(opnd2,long);
	    if (storage = long) or (opnd1^.attr^.storage = long) then
	      begin
	      $IF not MC68020$
	      extend(opnd1,long);
	      pushvalue(opnd1);
	      extend(opnd2,long);
	      pushvalue(opnd2);
	      saveregs; forgetbaseregs;
	      if eclass = divnode then
		callstdproc('ASM_DIV')
	      else callstdproc('ASM_MOD');
	      reloadregs;
	      with attr^ do
		begin addrmode := topofstack;
		storage := long; signbit := true;
		end;
	      $END$

	      $IF MC68020$
	      extend(opnd1,long);
	      loadvalue(opnd1);
	      extend(opnd2,long);

	      if RANGECHECK and (eclass = modnode) and
		 (opnd2^.eclass <> litnode) then
		begin
		loadvalue(opnd2);
		with op do
		  begin
		  addrmode := immediate;
		  smallval := maxint;
		  end;
		emit2(chk,op,opnd2^.attr^);
		end;

	      if eclass = divnode then
		begin
		emit2(divs,opnd2^.attr^,opnd1^.attr^);
		liftattr(fexp,opnd1);
		with attr^ do
		  begin
		  storage := long;
		  signbit := true;
		  end;
		ovflck;
		end
	      else
		begin
		divsl_reg := getreg(D);
		emit2(divsl,opnd2^.attr^,opnd1^.attr^);
		liftattr(fexp,opnd1);
		with attr^ do
		  begin
		  freeit(D,regnum);
		  regnum := divsl_reg;
		  storage := long;
		  signbit := true;
		  end;
		if  (opnd1^.eclass <> litnode) or
		   ((opnd1^.eclass = litnode) and
		    (opnd1^.litval.ival < 0)) then
		  begin
		  emit1(tst,attr^);
		  patchloc := codephile.bytecount + 2;
		  op.offset := 0;
		  op.storage := bytte;
		  emit1(bge,op);
		  emit2(add,opnd2^.attr^,attr^);
		  fixbyte(patchloc - 1, codephile.bytecount - patchloc);
		  end;
		freeregs(opnd2^.attr);
		end;
	      $END$
	      etyptr := intptr;
	      end
	    else
	      begin {in-line div or mod}
	      with opnd1^.attr^ do
		if addrmode = immediate then
		  begin storage := long; signbit := true; end
		else if (addrmode = topofstack) and
			(opnd2^.attr^.addrmode = topofstack) then
		  loadvalue(opnd2);
	      loadvalue(opnd1);
	      extend(opnd1,long);
	      extend(opnd2,wrd);
	      if RANGECHECK and (eclass = modnode) and
		 (opnd2^.eclass <> litnode) then
		begin
		loadvalue(opnd2);
		with op do
		  begin
		  addrmode := immediate;
		  smallval := 32767;
		  end;
		emit2(chk,op,opnd2^.attr^);
		end;
	      opnd1^.attr^.storage := wrd;
	      emit2(divs,opnd2^.attr^,opnd1^.attr^);      { DIVS op2,Dop1 }
	      liftattr(fexp,opnd1);
	      with attr^ do
		begin storage := wrd; signbit := true;
		if eclass = modnode then
		  begin
		  emit1(swap,attr^);
		  if (opnd1^.eclass <> litnode) or
		    ((opnd1^.eclass = litnode) and
		     (opnd1^.litval.ival < 0)) then
		    begin
		    emit1(tst,attr^);
		    patchloc := codephile.bytecount + 2;
		    op.offset := 0;
		    op.storage := bytte;
		    emit1(bge,op);
		    emit2(add,opnd2^.attr^,attr^);
		    fixbyte(patchloc-1,codephile.bytecount - patchloc);
		    end;
		  end
		else ovflck;
		end;
	      etyptr := shortintptr;
	      freeregs(opnd2^.attr);
	      end; {in-line div or mod}
	    end; {with opnd2^.attr^}
	  end;
	end; {div or mod}
    end; {genmulop}

  procedure genshft;
    var
      op: attrtype;
      temp: shortint;
      patchloc: addrrange;
      ovflpossible: boolean;
    begin
    with fexp^ do
      begin
      if opnd2^.litval.ival > 0 then { multiply }
	begin
	ovflpossible := false;
	makeaddressable(opnd1);
	if opnd1^.attr^.storage <> long then
	  if opnd2^.litval.ival >= 8 then extend(opnd1,long)
	  else extend(opnd1,succ(opnd1^.attr^.storage))
	else ovflpossible := true;
	loadvalue(opnd1);
	emitshift(opnd2^.litval.ival,
		  opnd1^.attr^.regnum,asl,
		  opnd1^.attr^.storage);
	if ovflpossible then ovflck;
	end
      else { divide }
	begin
	loadvalue(opnd1);
	if opnd1^.attr^.signbit then
	  begin
	  patchloc := codephile.bytecount + 2;
	  op.offset := 0; op.storage := bytte;
	  emit1(bge,op);
	  op.smallval := 1;
	  for temp := 1 to -opnd2^.litval.ival do
	    op.smallval := op.smallval * 2;
	  op.smallval := op.smallval - 1;
	  op.addrmode := immediate;
	  emit2(add,op,opnd1^.attr^); { ADD #fudge,opnd }
	  fixbyte(patchloc-1,codephile.bytecount - patchloc);
	  with opnd1^.attr^ do
	    emitshift(-opnd2^.litval.ival,
		      regnum,asr,storage);
	  end
	else
	  with opnd1^.attr^ do
	    emitshift(-opnd2^.litval.ival,
		      regnum,lsr,storage);
	end;
      liftattr(fexp,opnd1);
      {fexp^}attr^.storage := opnd1^.attr^.storage;
      if attr^.storage = long then etyptr := intptr
      else etyptr := shortintptr;
      end;
    end;

  procedure genandor;
    var
      truelist,falselist: reflistptr;
    begin
      if shortcircuit then
	begin
	truelist := NIL;
	falselist := NIL;
	with fexp^.attr^ do
	  begin
	  addrmode := inDreg;
	  regnum := getreg(D);
	  storage := bytte;
	  end;
	if fexp^.eclass = andnode then
	  genshortand(fexp,truelist,falselist,true,false,true,fexp^.attr)
	else { fexp^.eclass = ornode }
	  genshortor(fexp,truelist,falselist,true,false,true,fexp^.attr);
	fixreflist(truelist);
	fixreflist(falselist);
	forgetbaseregs;
	end
      else
	with fexp^, attr^ do
	  begin
	  if opnd1^.num_ops >= opnd2^.num_ops then
	    begin makeaddressable(opnd1); makeaddressable(opnd2); end
	  else
	    begin makeaddressable(opnd2); makeaddressable(opnd1); end;
	  if opnd2^.attr^.addrmode = inDreg then
	    begin
	    opnd2^.attr^.storage := bytte;
	    liftattr(fexp,opnd2);
	    emit2(op[eclass],opnd1^.attr^,opnd2^.attr^);
	    freeregs(opnd1^.attr);
	    end
	  else
	    begin
	    loadvalue(opnd1);
	    opnd1^.attr^.storage := bytte;
	    liftattr(fexp,opnd1);
	    emit2(op[eclass],opnd2^.attr^,opnd1^.attr^);
	    freeregs(opnd2^.attr);
	    end;
	  end;
    end; { genandor }

  function getopindex(attr: attrptr): opindextype;
    begin
    with attr^ do
      case addrmode of
	topofstack:               getopindex := tos;
	locinreg,shortabs,
	namedconst,
	longabs,prel:             getopindex := mem;
	inDreg:                   getopindex := reg;
	immediate:
	  if smallval = 0 then getopindex := zilchlit
	  else if (smallval >= 1) and (smallval <= 8) then
	    getopindex := quicklit
	  else if (smallval >= -128) and (smallval <= 127) then
	    getopindex := fastlit
	  else getopindex := slowlit;
	end; {case}
    end; {getopindex}

  procedure couldbequick(fexp: exptr);
    { case 1: fexp is addnode or subnode and opnd2 is a litnode.
	      If opnd2^.litval is in [-8..-1] then flip its sign
	      and change fexp from addnode to subnode or vice versa.
      case 2: fexp is addnode and opnd1 is a litnode.
	      If opnd1^.litval is in [-8..-1] then flip its sign,
	      change fexp to subnode, and exchange opnd1 and opnd2 }
    var
      exptemp: exptr;

    function quickexceptforsign(fattr: attrptr): boolean;
      begin
      with fattr^ do
	quickexceptforsign := (addrmode = immediate)
		  and (smallval >= -8) and (smallval <= -1);
      end;

    begin {couldbequick}
    with fexp^ do
      begin
      if quickexceptforsign(opnd2^.attr) then
	begin
	with opnd2^.attr^ do smallval := -smallval;
	if eclass = addnode then eclass := subnode
	else eclass := addnode;
	end;
      if eclass = addnode then
	if quickexceptforsign(opnd1^.attr) then
	  begin
	  with opnd1^.attr^ do smallval := -smallval;
	  eclass := subnode;
	  exptemp := opnd1;
	  opnd1 := opnd2;
	  opnd2 := exptemp;
	  end;
      end;
    end; {couldbequick}

  begin {alops}
  with fexp^,attr^ do
    if etyptr = realptr then genrealop
    $IF MC68020$
    else if eclass in [divnode,modnode] then genmulop
    $END$
    $IF not MC68020$
    else if eclass in [mulnode,divnode,modnode] then genmulop
    $END$
    else if eclass = shftnode then genshft
    else if eclass in [andnode,ornode] then genandor
    else { integer ADD,SUB and MUL for 68020 }
      begin
      if opnd1^.ekind > opnd2^.ekind then
	begin makeaddressable(opnd1); makeaddressable(opnd2) end
      else begin makeaddressable(opnd2); makeaddressable(opnd1) end;
      with opnd1^.attr^ do
	begin lmode := addrmode;
	lstorage := storage; lsigned := signbit;
	end;
      with opnd2^.attr^ do
	begin rmode := addrmode;
	rstorage := storage; rsigned := signbit;
	end;
      if lmode = immediate then
	begin
	if (rstorage = long) or (rstorage = wrd) and not rsigned
	  then fixliteral(opnd1,long,true)
	else fixliteral(opnd1,wrd,true);
	with opnd1^.attr^ do
	  begin lstorage := storage; lsigned := signbit end;
	end
      else if rmode = immediate then
	begin
	if (lstorage = long) or (lstorage = wrd) and not lsigned then
	  fixliteral(opnd2,long,true)
	else fixliteral(opnd2,wrd,true);
	with opnd2^.attr^ do
	  begin rstorage := storage; rsigned := signbit end;
	end;
      if (lstorage = long) or (rstorage = long)
	  or (lstorage = wrd) and not lsigned
	  or (rstorage = wrd) and not rsigned then
	begin extend(opnd1,long);
	checkstackandextend(opnd1,opnd2,long);
	storage := long;
	etyptr := intptr;
	end
      else
	begin extend(opnd1,wrd);
	checkstackandextend(opnd1,opnd2,wrd);
	storage := wrd;
	etyptr := shortintptr;
	end;
      $IF MC68020$
	if not (eclass = mulnode) then
      $END$
      couldbequick(fexp);
      lopindex := getopindex(opnd1^.attr);
      ropindex := getopindex(opnd2^.attr);
      case ord(lopindex)*10+ord(ropindex) of
	00, {stack op stack}
	01, {stack op mem}
	10, {mem op stack}
	11, {mem op mem}
	13, {mem op slowlit}
	15, {mem op quicklit}
	31, {slowlit op mem}
	40, {fastlit op stack}
	41, {fastlit op mem}
	42, {fastlit op reg}
	51: {quicklit op mem}
	   begin loadvalue(opnd1); liftattr(fexp,opnd1);
	   emit2(op[eclass],opnd2^.attr^,opnd1^.attr^);
	   freeregs(opnd2^.attr);
	   ovflck;
	   end;
	02, {stack op reg}
	04: {stack op fastlit}
	   begin if ropindex = fastlit then loadvalue(opnd2);
	   if eclass = addnode then
	     begin liftattr(fexp,opnd2);
	     emit2(add,opnd1^.attr^,opnd2^.attr^);{ ADD.z (SP)+,Dop2 }
	     end
	   else if eclass = subnode then
	     begin SPind.storage := storage;
	     liftattr(fexp,opnd1);
	     emit2(sub,opnd2^.attr^,SPind);        { SUB.z Dop1,(SP) }
	     freeregs(opnd2^.attr);
	     end
	   $IF MC68020$
	   else if eclass = mulnode then
	     begin
	     liftattr(fexp,opnd2);
	     emit2(muls,opnd1^.attr^,opnd2^.attr^);{ MUL.z (SP)+,Dop2 }
	     end
	   $END$;
	   ovflck;
	   end;
	03, {stack op slowlit}
	05, {stack op quicklit}
	20, {reg op stack}
	21, {reg op mem}
	22, {reg op reg}
	23, {reg op slowlit}
	25: {reg op quicklit}
	   begin liftattr(fexp,opnd1);
	   if lopindex <> tos then
	     emit2(op[eclass],opnd2^.attr^,opnd1^.attr^)
	   else
	   $IF MC68020$
	     if eclass = mulnode then
	       begin
	       loadvalue(opnd1);
	       liftattr(fexp,opnd1);
	       emit2(muls,opnd2^.attr^,opnd1^.attr^);
	       end
	     else
	   $END$
	     begin SPind.storage := storage;
	     emit2(op[eclass],opnd2^.attr^,SPind);
	     end;
	   freeregs(opnd2^.attr);
	   ovflck;
	   end;
	06,16,26,36,46,56,66: {opnd2 is zero}
	   begin
	   $IF MC68020$
	   if eclass = mulnode then
	     liftattr(fexp,opnd2)
	   else
	   $END$
	     liftattr(fexp,opnd1);
	   end;
	12, {mem op reg}
	30, {slowlit op stack}
	32, {slowlit op reg}
	50, {quicklit op stack}
	52: {quicklit op reg}
	   begin
	   if eclass = addnode then
	     begin liftattr(fexp,opnd2);
	     if ropindex = tos then
	       begin SPind.storage := storage;
	       emit2(add,opnd1^.attr^,SPind);
	       end
	     else emit2(add,opnd1^.attr^,opnd2^.attr^);
	     freeregs(opnd1^.attr);
	     end
	   else if eclass = subnode then
	     begin loadvalue(opnd1); liftattr(fexp,opnd1);
	     emit2(sub,opnd2^.attr^,opnd1^.attr^);
	     freeregs(opnd2^.attr);
	     end
	   $IF MC68020$
	   else {mulnode}
	     begin
	     loadvalue(opnd2);
	     liftattr(fexp,opnd2);
	     emit2(muls,opnd1^.attr^,opnd2^.attr^);
	     freeregs(opnd1^.attr);
	     end
	   $END$;
	   ovflck;
	   end;
	14: {mem op fastlit}
	   begin loadvalue(opnd2); liftattr(fexp,opnd2);
	   emit2(op[eclass],opnd1^.attr^,opnd2^.attr^);
	   freeregs(opnd1^.attr);
	   ovflck;
	   if eclass = subnode then
	     begin
	     emit1(neg,attr^);
	     ovflck;
	     end;
	   end;
	24: {reg op fastlit}
	   begin loadvalue(opnd2); liftattr(fexp,opnd1);
	   emit2(op[eclass],opnd2^.attr^,opnd1^.attr^);
	   freeregs(opnd2^.attr);
	   ovflck;
	   end;
	60,61,62,63,64,65: {opnd1 is zilchlit}
	   begin
	   if eclass = subnode then
	     begin
	     if ropindex = mem then loadvalue(opnd2);
	     if ropindex <> tos then emit1(neg,opnd2^.attr^)
	     else
	       begin
	       SPind.storage := storage;
	       emit1(neg,SPind);
	       end;
	     ovflck;
	     end;
	   $IF MC68020$
	   if eclass = mulnode then
	     liftattr(fexp,opnd1)
	   else
	   $END$
	     liftattr(fexp,opnd2);
	   end;
      end; {case}
      $IF MC68020$
      if eclass = mulnode then
	storage := long;
      $END$
      end; { integer ADD or SUB or MUL for 68020}
  end; {alops}

procedure combineoffsets(fattr: attrptr; fsize: addrrange);
  { for fattr^, attempt to set PACKD to false by consolidating
    bit offset and offset information.
    Fsize is unpacksize of type associated with fattr }
  begin
  with fattr^ do
    begin
    offset := offset + mydiv(bitoffset.static,16) * 2;
    bitoffset.static := (bitoffset.static mod 16);
    if (bitoffset.static = 8) and (bitsize = 8) then
      begin offset := offset + 1;
      bitoffset.static := 0;
      end;
    if ((bitoffset.static = 0) and (bitoffset.variable = -1)) and
	(fsize = bitsize div bitsperaddr)
      then packd := false;
    end;
  end;

procedure genrecsel ( fexp,frecptr : exptr; ffldptr : ctp);
  { fexp^ is a selection node.
    frecptr^ is the node of the record selected into.
    ffldptr is the field id pointer. }
  begin
    with fexp^, attr^, ffldptr^ do
      begin genexpr(frecptr); { obtain address info for base of record }
      if (fldaddr <> 0) or fispackd then
	begin
	if frecptr^.attr^.access = indirect then
	  loadaddress(frecptr,false);
	liftattr(fexp,frecptr);
	getsignbit(etyptr,attr);
	offset := offset + fldaddr;
	if fispackd then
	  begin packd := true;
	  bitsize := idtype^.bitsize;
	  signbit := idtype^.signbit;
	  bitoffset.static := bitoffset.static + fldfbit;
	  combineoffsets(attr,idtype^.unpacksize);
	  end;
	end
      else
	begin {unpacked, offset=0}
	liftattr(fexp,frecptr);
	getsignbit(idtype,attr);
	end;
      end; {with}
  end; {genrecsel}

procedure gensubscr(fexp : exptr);
  var
    arraytype : stp; arrayattr : attrptr;
    lobound,hibound,
    temp : integer;
    elementsize : addrrange;
    op,xop : attrtype;

    $IF MC68020$
    type
      two_to_the_type = array[0..3] of 1..8;
    const
      two_to_the = two_to_the_type[1,2,4,8];
    $END$

  procedure cnf_subscr;
    var
      lobound_attr,
      hibound_attr,
      cnfsize_attr,
      op1,op2: attrtype;
      lbl: localref;
      savelink: attrptr;

  begin
  with fexp^ do
    begin
    if arrayattr^.access = indirect then
      loadaddress(arayp,false);
    liftattr(fexp,arayp);
    getsignbit(etyptr,attr);
    makeaddressable(indxp);
    maskboolexpr(indxp);
    if indxp^.attr^.storage = bytte then
      extend(indxp,wrd);
    if (indxp^.attr^.storage = wrd) and not (indxp^.attr^.signbit) then
      extend(indxp,long);
    loadvalue(indxp);
    {Subtract lower bound}
    with lobound_attr do
      begin
      addrmode := locinreg;
      regnum := getbasereg(arraytype^.cnf_index^.loboundid^.vlev);
      offset := arraytype^.cnf_index^.loboundid^.vaddr;
      indexed := false;
      gloptr := NIL;
      case arraytype^.inxtype^.unpacksize of
	1: storage := bytte;
	2: storage := wrd;
	4: storage := long;
      end;
      if ord(indxp^.attr^.storage) < ord(storage) then
	extend(indxp,storage);
      end; { with lobound_attr }
    if RANGECHECK then
      begin
      with hibound_attr do
	begin
	addrmode := locinreg;
	regnum := lobound_attr.regnum; { loboundid and hiboundid
					 are at the same level }
	offset := arraytype^.cnf_index^.hiboundid^.vaddr;
	indexed := false;
	gloptr := NIL;
	storage := lobound_attr.storage;
      { less than or equal to upper bound ? }
	if ord(storage) < ord(indxp^.attr^.storage) then
	  begin
	  if (storage = bytte) then
	    begin
	    with op1 do
	      begin
	      addrmode := inDreg;
	      regnum := getreg(D);
	      storage := long;
	      end;
	    emit1(clr,op1);
	    op1.storage := bytte;
	    emit2(move,hibound_attr,op1);
	    op1.storage := indxp^.attr^.storage;
	    end
	  else {storage = wrd}
	    begin
	    with op1 do
	      begin
	      addrmode := inDreg; regnum := getreg(D);
	      storage := wrd;
	      end;
	    emit2(move,hibound_attr,op1);
	    op1.storage := long;
	    emit1(ext,op1);
	    end;
	  end
	else
	  op1 := hibound_attr;
	emit2(cmp,op1,indxp^.attr^);
	if op1.addrmode = inDreg then
	  freeit(D,op1.regnum);
	lbl.next := NIL;
	getbrattr(lbl.pc,false,op1);
	emit1(bgt,op1);
	end;
      end; { with hibound_attr }
    with lobound_attr do
      begin
      if ord(storage) < ord(indxp^.attr^.storage) then
	begin
	if (storage = bytte) then
	  begin
	  with op1 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := long;
	    end;
	  emit1(clr,op1);
	  op1.storage := bytte;
	  emit2(move,lobound_attr,op1);
	  op1.storage := indxp^.attr^.storage;
	  end
	else {storage = wrd}
	  begin
	  with op1 do
	    begin
	    addrmode := inDreg; regnum := getreg(D);
	    storage := wrd;
	    end;
	  emit2(move,lobound_attr,op1);
	  op1.storage := long;
	  emit1(ext,op1);
	  end
	end
      else
	op1 := lobound_attr;
      emit2(sub,op1,indxp^.attr^);
      if op1.addrmode = inDreg then
	freeit(D,op1.regnum);
      end; {with lobound_attr}
    if RANGECHECK then
      { greater than or equal to lower bound ? }
      with op1 do
	begin
	offset := 2;
	storage := bytte;
	emit1(bge,op1);
	fixreflist(addr(lbl));
	op1.smallval := 7;
	emit1(trap,op1);              { TRAP #7 }
	end;
    {multiply by size}
    cnfsize_attr := lobound_attr;
    cnfsize_attr.offset := arraytype^.cnf_index^.hiboundid^.vaddr;
    with cnfsize_attr do
      begin
      case arraytype^.inxtype^.unpacksize of
	1: begin
	   storage := bytte;
	   offset := offset + 2;
	   end;
	2: begin
	   storage := wrd;
	   offset := offset + 2;
	   end;
	4: begin
	   storage := long;
	   offset := offset + 4;
	   end;
      end;
      if storage <> indxp^.attr^.storage then
	begin
	if storage = bytte then
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg; regnum := getreg(D);
	    storage := long;
	    end;
	  emit1(clr,op2);
	  op2.storage := bytte;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := op1.storage;
	  end
	else {storage = wrd}
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := wrd;
	    end;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := long;
	  emit1(ext,op2);
	  end
	end
      else
	op2 := cnfsize_attr;
      end; {with cnfsize_attr}
    freeregs(addr(lobound_attr));
    if op2.storage = long then {call routine}
      begin

      $IF MC68020$
      emit2(muls,op2,indxp^.attr^);
      ovflck;
      if op2.addrmode = inDreg then
	freeit(D,op2.regnum);
      $END$

      $IF not MC68020$
      SPminus.storage := long;
      emit2(move,indxp^.attr^,SPminus);
      freeregs(indxp^.attr);
      emit2(move,op2,SPminus);
      if op2.addrmode = inDreg then
	freeit(D,op2.regnum);
      saveregs;
      forgetbaseregs;
      callstdproc('ASM_MPY');
      reloadregs;
      indxp^.attr^.addrmode := topofstack;
      $END$

      end
    else {in line multiply}
      begin
      emit2(muls,op2,indxp^.attr^);
      indxp^.attr^.storage := long;
      if op2.addrmode = inDreg then
	freeit(D,op2.regnum);
      end;
    if (arraytype^.aispackd) then
      begin
      if indxp^.attr^.addrmode <> inDreg then
	loadvalue(indxp);
      with fexp^.attr^ do
	begin
	packd := true;
	bitoffset.variable := indxp^.attr^.regnum;
	bitoffset.static := 0;
	bitoffset.storage := long;
	bitsize := arraytype^.aelbitsize;
	signbit := arraytype^.aeltype^.signbit;
	if arrayattr^.indexed then
	  begin
	  indexed := true;
	  indexreg := arrayattr^.indexreg;
	  indexstorage := arrayattr^.indexstorage;
	  $IF MC68020$
	  indexscale := arrayattr^.indexscale;
	  $END$
	  end
	else
	  indexed := false;
	end;
      end
    else
      begin
      if arrayattr^.indexed then {add index regs}
	begin
	with op2 do
	  begin
	  addrmode := inDreg;
	  regnum := arrayattr^.indexreg;
	  storage := long;
	  end;
	emit2(add,indxp^.attr^,op2);
	freeregs(indxp^.attr);
	savelink := indxp^.attr^.next;
	indxp^.attr^ := op2;
	indxp^.attr^.next := savelink;
	end;
      if indxp^.attr^.addrmode <> inDreg then
	loadvalue(indxp);
      with fexp^.attr^ do
	begin
	indexreg := indxp^.attr^.regnum;
	indexstorage := long;
	indexed := true;
	$IF MC68020$
	  indexscale := 0;
	$END$
	end;
      end;
    end;
  end; {cnf_subscr}

  procedure multiplyindex
	     (fsize: integer; xreg: regrange; var xstorage: stortype);
    { multiply value in xreg by fsize, the array element size or
      bitsize.  Modify xstorage as needed }
    var
      power : shortint;  { 0..8 }
      xop,op2: attrtype;

    begin
    powerof2(fsize,power);
    with xop do
      begin
      addrmode := inDreg; regnum := xreg;
      storage := xstorage;
      end;
    if power <> 0 then
      begin
      if xstorage = wrd then
	begin
	xop.storage := long;
	emit1(ext,xop);                           { EXT.L Dx }
	end;
      if power = 1 then
	emit2(add,xop,xop)                        { ADD.L Dx,Dx }
      else emitshift(power,xreg,asl,long);
      if xstorage = long then ovflck
      else xstorage := long;
      end
    else {fsize not a power of 2}
      if fsize <> 1 then
	begin
	op2.addrmode := immediate;
	op2.smallval := fsize;

	if (xop.storage = wrd) and
	   (fsize > 32767) then
	  begin
	  xop.storage := long;
	  emit1(ext,xop);
	  xstorage := long;
	  end;

	if xop.storage = wrd then
	  begin
	  emit2(muls,op2,xop);                      { MULS #fsize,Dx }
	  xstorage := long;
	  end
	else { xop.storage = long }
	  begin

	  $IF MC68020$
	  emit2(muls,op2,xop);
	  ovflck;
	  $END$

	  $IF not MC68020$
	  SPminus.storage := long;
	  emit2(move,xop,SPminus);
	  emit2(move,op2,SPminus);
	  reg[D,xop.regnum].allocstate := free;
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_MPY');
	  reloadregs;
	  reg[D,xop.regnum].allocstate := allocated;
	  emit2(move,SPplus,xop);
	  $END$

	  end;
	end;
    end; {multiplyindex}

  begin {gensubscr}
  with fexp^, attr^ do
    begin genexpr(arayp); { obtain array accessing info }
    arrayattr := arayp^.attr;
    arraytype := arayp^.etyptr;
    if arraytype^.form = cnfarrays then
      cnf_subscr
    else
      begin
      if strgtype(arraytype) then
	begin lobound := 0; hibound := arraytype^.maxleng; end
      else getbounds(arraytype^.inxtype,lobound,hibound);
      elementsize := arraytype^.aelsize;
      if arrayattr^.access = indirect then
	loadaddress(arayp,false);
      if RANGECHECK and strgtype(arraytype) then
	makeaddressable(arayp);
      liftattr(fexp,arayp);
      getsignbit(etyptr,attr);
      if (indxp^.eclass = litnode) then   {constant index}
	begin
	if RANGECHECK and strgtype(arraytype) then
	  begin
	  extend(indxp,bytte);
	  getregattr(D,op);        {for string length}
	  if indxp^.attr^.storage <> bytte then
	    emit2(moveq,immed0,op);               { MOVEQ #0,Dr }
	  op.storage := bytte;
	  emit2(move,arrayattr^,op);            { MOVE.B string[0],Dr }
	  op.storage := indxp^.attr^.storage;
	  emit2(cmpi,indxp^.attr^,op);
	  freeit(D,op.regnum);
	  with op do
	    begin offset := 2;
	    storage := bytte;
	    emit1(bcc,op);  {BCC.S *+4}
	    smallval := 7;
	    emit1(trap,op); {TRAP #7}
	    end;
	  end;
	IF arraytype^.AISPACKD THEN
	  begin PACKD := TRUE;
	  BITSIZE := arraytype^.AELBITSIZE;
	  SIGNBIT := arraytype^.AELTYPE^.SIGNBIT;
	  temp := BITOFFSET.STATIC +
		  (INDXP^.LITVAL.IVAL - LOBOUND) *
		  arraytype^.AELBITSIZE;
	  offset := offset + mydiv(temp,16) * 2;
	  bitoffset.static := (temp mod 16);
	  combineoffsets(attr,etyptr^.unpacksize);
	  end { AISPACKD }
	else { add index to displacement }
	  offset := offset +
		      (indxp^.litval.ival - lobound) * elementsize;
	end {litnode}
      else { non-constant index }
	begin
	makeaddressable(indxp); maskboolexpr(indxp);
	if RANGECHECK then
	  ensure_valid_condition_code := true;
	if indxp^.attr^.storage = bytte then
	  extend(indxp,wrd);
	if (indxp^.attr^.storage=wrd) and not(indxp^.attr^.signbit) then
	  extend(indxp,long);
	ensure_valid_condition_code := false;
	loadvalue(indxp);
	indexreg := indxp^.attr^.regnum;
	indexstorage := indxp^.attr^.storage;
	indexed := true;
	$IF MC68020$
	  indexscale := 0;
	$END$
	if RANGECHECK then
	  if strgtype(arraytype) then
	    begin
	    if not ucsd then {prohibit s[0]}
	      with op do
		begin
		offset := 2;
		storage := bytte;
		emit1(bgt,op);  {BGT.S *+4}
		smallval := 7;
		emit1(trap,op); {TRAP #7}
		end;
	    getregattr(D,op);        {for string length}
	    emit2(moveq,immed0,op);               { MOVEQ #0,Dr }
	    op.storage := bytte;
	    emit2(move,arrayattr^,op);            { MOVE.B string[0],Dr }
	    xop.addrmode := inDreg; xop.regnum := indexreg;
	    emit2(chk,op,xop);                    { CHK Dr,Dindexreg }
	    freeit(D,op.regnum);
	    end
	  else
	    emitcheck(indxp,arraytype^.inxtype,true);
	IF (arraytype^.AISPACKD) AND (arraytype^.AELBITSIZE<>8)
	    AND (arraytype^.AELBITSIZE<>16) THEN
	  begin
	  PACKD := TRUE;
	  BITOFFSET.VARIABLE := INDEXREG;
	  bitoffset.storage := indexstorage;
	  BITSIZE := arraytype^.AELBITSIZE;
	  SIGNBIT := arraytype^.AELTYPE^.SIGNBIT;
	  IF arrayattr^.INDEXED THEN
	    BEGIN INDEXED := TRUE;
	    INDEXREG := arrayattr^.INDEXREG;
	    indexstorage := arrayattr^.indexstorage;
	    $IF MC68020$
	      indexscale := arrayattr^.indexscale;
	    $END$
	    END
	  ELSE INDEXED := FALSE;
	  multiplyindex(arraytype^.aelbitsize,
				bitoffset.variable,bitoffset.storage);
	  BITOFFSET.STATIC := BITOFFSET.STATIC - LOBOUND * BITSIZE;
	  END
	ELSE {bytte, word, or unpacked array}
	  BEGIN
	  with arraytype^ do
	    IF AISPACKD THEN
	      begin
	      ELEMENTSIZE := AELBITSIZE DIV BITSPERADDR;
	      attr^.signbit := aeltype^.signbit;
	      end;

	  $IF not MC68020$
	  multiplyindex(elementsize,indexreg,indexstorage);
	  $END$

	  $IF MC68020$
	  case elementsize of
	    2: indexscale := 1;
	    4: indexscale := 2;
	    8: indexscale := 3;
	    otherwise
	      begin
	      indexscale := 0;
	      multiplyindex(elementsize,indexreg,indexstorage);
	      end;
	  end;

	  if arrayattr^.indexed then { account for scale factors }
	    begin
	    if (arrayattr^.indexscale <> 0) then
	      if (indexscale <> 0) then
		multiplyindex(two_to_the[arrayattr^.indexscale-indexscale],
			      arrayattr^.indexreg,arrayattr^.indexstorage)
	      else
		multiplyindex(two_to_the[arrayattr^.indexscale],
			      arrayattr^.indexreg,arrayattr^.indexstorage)
	    else if indexscale <> 0 then
	      begin
	      multiplyindex(two_to_the[indexscale],indexreg,indexstorage);
	      indexscale := 0;
	      end;
	    end;
	  $END$

	  if arrayattr^.indexed then  { add index regs }
	    begin
	    with op do
	      begin addrmode := inDreg; regnum := arrayattr^.indexreg;
	      storage := arrayattr^.indexstorage;
	      end;
	    xop.addrmode := inDreg; xop.regnum := indexreg;
	    xop.storage := indexstorage;
	    if arrayattr^.indexstorage < indexstorage then
	      begin op.storage := long;
	      emit1(ext,op);            { EXT.L DarrayX }
	      arrayattr^.indexstorage := long;
	      end;
	    if indexstorage < arrayattr^.indexstorage then
	      begin xop.storage := long;
	      emit1(ext,xop);            { EXT.L DfexpX }
	      indexstorage := long;
	      end;
	    emit2(add,op,xop);             { ADD.xsize DarrayX,DfexpX }
	    freeit(D,arrayattr^.indexreg)
	    end;
	  { adjust displacement }
	  offset := offset - lobound * elementsize;
	  with arraytype^ do
	    IF AISPACKD and (AELTYPE^.UNPACKSIZE <> ELEMENTSIZE) THEN
	      if elementsize = 1      then storage := bytte
	      else if elementsize = 2 then storage := wrd
	      else                         storage := long;
	  END; {bytte,word, or unpacked array}
	end; {non-constant index}
      end; { standard array subscript }
    end; { with fexp^,attr^ }
  end; { gensubscr }

procedure genset(fexp: exptr);  {generate a set having variable part}
  var
    ptr: elistptr;
    op: attrtype;
    checkstp : stp;
    possible_low,
    possible_hi : integer;
    lbltemp,
    lbl1,
    lbl2 : reflistptr;
  begin
  with fexp^, attr^ do
    begin getlocstorage(etyptr^.unpacksize,op);
    emit1(pea,op);                { PEA temp }
    ekind := cnst;  {deal with the constant part first}
    pushaddress(fexp);
    ptr:=setvarpart;
    saveregs;
    repeat
      with ptr^ do
	if lowptr = hiptr then
	  begin
	  if RANGECHECK then
	    begin
	    new(checkstp);
	    with checkstp^ do
	      begin
	      form := subrange;
	      min := etyptr^.setmin;
	      max := etyptr^.setmax;
	      end;
	    emitcheck(expptr,checkstp,false);
	    end; { RANGECHECK }
	  extend(expptr,long);
	  pushvalue(expptr);
	  forgetbaseregs;
$if bigsets$
	  if etyptr^.setmax > setdefaulthigh then
	   callstdproc('ASM_XXADELEMENT')
	  else
	    callstdproc('ASM_XADELEMENT');
$end$
$if not bigsets$
	   callstdproc('ASM_ADELEMENT');
$end$
	  end
	else { range with variable limit }
	  begin
	  if RANGECHECK then
	    begin
	    genexpr(hiptr);
	    genexpr(lowptr);
	    with hiptr^.attr^ do
	      if packd then
		if (bitsize = 31) and not signbit then
		  possible_hi := maxint
		else
		  possible_hi := power_table[bitsize-ord(signbit)]-1
	      else
		case storage of
		  bytte: if signbit then
			   possible_hi := 127
			 else
			   possible_hi := 255;
		  wrd: if signbit then
			 possible_hi := 32767
		       else
			 possible_hi := 65535;
		  long: possible_hi := maxint;
		end;
	    if lowptr^.attr^.signbit then
	      possible_low := 0
	    else { minint is good enough since sets don't have negative elems }
	      possible_low := minint;
	    if (possible_low < etyptr^.setmin) or
	       (possible_hi > etyptr^.setmax) then
	      begin
	      lbl2 := NIL;
	      loadvalue(lowptr);
	      extend(lowptr,long);
	      loadvalue(hiptr);
	      extend(hiptr,long);
	      emit2(cmp,lowptr^.attr^,hiptr^.attr^);    {CMP low,hi}
	      new(lbl1);
	      lbl1^.next := NIL;
	      lbl1^.pc := 0;
	      getbrattr(lbl1^.pc,false,op);
	      { branch around rangecheck code if hi < low }
	      emit1(blt,op);                            {BLT lbl1}

	      if (possible_hi < etyptr^.setmax) then
		begin { Test for low range only }
		with op do
		  begin
		  addrmode := immediate;
		  smallval := etyptr^.setmin;
		  end;
		emit2(cmpi,op,lowptr^.attr^);           {CMPI min,low}
		new(lbltemp);
		lbltemp^.next := lbl1;
		lbltemp^.pc := 0;
		lbl1 := lbltemp;
		getbrattr(lbl1^.pc,false,op);
		emit1(bge,op);                          {BGE lbl1}
		end
	      else
		begin
		if (possible_low < etyptr^.setmin) then
		  begin
		  with op do
		    begin
		    addrmode := immediate;
		    smallval := etyptr^.setmin;
		    end;
		  emit2(cmpi,op,lowptr^.attr^);         {CMPI min,low}
		  new(lbl2);
		  lbl2^.next := NIL;
		  lbl2^.pc := 0;
		  getbrattr(lbl2^.pc,false,op);
		  emit1(blt,op);                        {BLT lbl2}
		  end;
		with op do
		  begin
		  addrmode := immediate;
		  smallval := etyptr^.setmax;
		  end;
		emit2(cmpi,op,hiptr^.attr^);            {CMPI max,hi}
		new(lbltemp);
		lbltemp^.next := lbl1;
		lbltemp^.pc := 0;
		lbl1 := lbltemp;
		getbrattr(lbl1^.pc,false,op);
		emit1(ble,op);                          {BLE lbl1}
		end;
	      if lbl2 <> NIL then                       {lbl2:}
		fixreflist(lbl2);
	      op.smallval := 7;
	      emit1(trap,op);                           {TRAP #7}
	      fixreflist(lbl1);                         {lbl1:}
	      end;
	    end; { RANGECHECK }
$if bigsets$
	    extend(lowptr,long);
	    extend(hiptr,long);
$end$
$if not bigsets$
	  extend(lowptr,wrd);
	  extend(hiptr,wrd);
$end$
	  pushvalue(lowptr);
	  pushvalue(hiptr);
	  forgetbaseregs;
$if bigsets$
	  if etyptr^.setmax > setdefaulthigh then
	   callstdproc('ASM_XXADDSETRANGE')
	  else
	   callstdproc('ASM_XADDSETRANGE');
$end$
$if not bigsets$
	   callstdproc('ASM_ADDSETRANGE');
$end$
	end;
      ptr := ptr^.nextptr;
      if ptr <> NIL then
	begin
	SPminus.storage := long;
	emit2(move,SPind,SPminus);              { MOVE.L (SP),-(SP) }
	end;
    until ptr = NIL;
    addrmode := loconstack;
    access := indirect;
    reloadregs;
    end;
  end; (*genset*)

begin {genexpr}
  with fexp^ do
    if attr = NIL then
      begin
      getattrec(fexp);
      with attr^ do
	case eclass of
	  eqnode..andnode: {binops}
	    begin
	    lform := opnd2^.etyptr^.form;
	    if lform = power then gensetop(fexp)
	    else if lform = arrays then relpaofchxpr(fexp)
	    else if eclass <= genode then relxpr(fexp)
	    else alops(fexp)
	    end;
	  negnode,notnode,floatnode,
	  absnode,chrnode,oddnode,ordnode,
	  strlennode,strmaxnode,roundnode,
	  sqrnode,truncnode:
	    unaryops(fexp);
	  idnode:
	    with symptr^ do
	      case klass of
		vars,routineparm:
		  begin
		  if (vtype < localvar) then
		    begin
		    case vtype of
		      shortvar: addrmode := shortabs;
		      longvar: addrmode := longabs;
		      relvar: addrmode := prel;
		      end;
		    gloptr := NIL;
		    attr^.absaddr := {symptr^.}absaddr;
		    end
		  else
		    begin offset := vaddr;
		    addrmode := locinreg;
		    regnum := getbasereg(vlev);
		    $PARTIAL_EVAL$
		    if (vtype = refparm) or
		       (vtype = strparm) or
		       (vtype = anyvarparm) or
		       ((vtype = cvalparm) and (idtype^.form = cnfarrays)) then
		      access := indirect
		    else if (vtype = funcparm) then
		      if idtype^.form >= prok then
			 access := indirect;
		    $IF not partialevaling$
		      $PARTIAL_EVAL OFF$
		    $END$
		    gloptr := globalptr;
		    end;
		  getsignbit(etyptr,attr);
		  end; {vars}
		func:
		  if ekind = cnst then
		    begin
		    getprokconst(symptr,attr^);
		    if not constptr^.isdumped then
		      callmode := abscall;
		    end
		  else
		    begin addrmode := locinreg;
		    regnum := getbasereg(pflev+1);
		    offset := pfaddr; gloptr := NIL;
		    if etyptr^.form >= prok then
		      access := indirect;
		    end;
		prox:
		  begin
		  getprokconst(symptr,attr^);
		  if not constptr^.isdumped then
		    callmode := abscall;
		  end;
		otherwise escape(-8);
		end;
	  litnode:
	    with litval do
	      if intval then
		begin addrmode := immediate; smallval := ival end
	      else
		with valp^ do
		  if cclass <> strctconst then
		    begin
		    addrmode := labelledconst;
		    valp := poolit(valp);
		    constvalp := valp;
		    end
		  else {structured constant}
		    begin addrmode := namedconst;
		    constptr := valp; callmode := abscall;
		    end;
	  fcallnode: genfcall(fexp);
	  concatnode:
	    begin
	    getlocstorage(256,op);
	    new(lexp);
	    new(lstp);
	    with lexp^ do
	      begin
	      attr := addr(op);
	      lstp^:= strgptr^;
	      lstp^.unpacksize := 256;
	      etyptr := lstp;
	  symptr := NIL;                        /* Added 04NOV92 - CFB */
	      end;
	    genconcat(lexp,fexp);
	    liftattr(fexp,lexp);
	    end;
	  substrnode:
	    with fexp^ do
	      begin
	      genexpr(arayp);
	      liftattr(fexp,arayp);
	      genexpr(indxp);
	      if lengthp <> NIL then genexpr(lengthp);
	      end;
	  subscrnode: gensubscr(fexp);
	  selnnode: genrecsel(fexp,recptr,fieldptr);
	  unqualfldnode:
	    with withstptr^ do
	      begin
	      if refbit <> 0 then  {load variable bit offset}
		begin
		with lop do
		  begin addrmode := locinreg;
		  offset := refbit; indexed := false;
		  if bodylev = 1 then regnum := SB
		  else regnum := localbase; gloptr := NIL;
		  end;
		getregattr(D,rop);
		emit2(move,lop,rop);
		refexpr^.attr^.bitoffset.variable := rop.regnum;
		end;
	      if addrinreg(refexpr) then
		with reg[A,refexpr^.attr^.regnum] do
		  begin allocstate := allocated; usesleft := usesleft+1;
		  genrecsel(fexp,refexpr,fieldref);
		  end
	      else begin {record base not loaded}
		oldattr := refexpr^.attr^;
		if oldattr.access = indirect then
		  loadaddress(refexpr,false);
		genrecsel(fexp,refexpr,fieldref);
		if addrinreg(refexpr) then
		  with reg[A,refexpr^.attr^.regnum] do
		    begin usage := withrecbase;
		    allocstate := allocated; usesleft := 1;
		    curcontents := refexpr^.attr; oldcontents := oldattr;
		    end;
		end;
	      end;
	  bufnode:
	    begin
	    rop.addrmode := immediate;
	    rop.smallval := 4;
	    SPdir.storage := long;
	    emit2(subq,rop,SPdir); {SUBQ.L #4,SP}
	    pushaddress(opnd);
	    saveregs; forgetbaseregs;
	    callIOproc('FS_FBUFFERREF');
	    reloadregs;
	    addrmode := loconstack;
	    loadaddress(fexp,false);
	    getsignbit(etyptr,attr);
	    end;
	  derfnode:
	    begin genexpr(opnd);
	    with opnd^.attr^ do
	      begin
	      if access = indirect then
		loadaddress(opnd,false);
	      if addrmode = inDreg then
		extend(opnd,long);
	      end;
	    liftattr(fexp,opnd);
	    getsignbit(etyptr,attr);
	    access := indirect;
	    if rangecheck and (addrmode <> immediate) then
	      begin   {check for NIL pointer}
	      if addrmode <> inDreg then
		begin loadaddress(fexp,false);
		getregattr(D,rop);
		lop.addrmode := inAreg; lop.regnum := regnum;
		emit2(move,lop,rop);             { MOVE.L Aregnum,Dr }
		freeit(D,rop.regnum);
		end;
	      with rop do
		begin offset:=2; storage := bytte end;
	      emit1(bne,rop);        { BNE.S *+4 (assumes nilvalue = 0) }
	      rop.smallval:=8;
	      emit1(trap,rop);       { TRAP #8 }
	      end;
	    end; {derfnode}
	  setdenonode:
	    begin
	    addrmode := labelledconst;
	    setcstpart.valp := poolit(setcstpart.valp);
	    constptr := setcstpart.valp;
	    if ekind <> cnst then genset(fexp);
	    end;
	  succnode,prednode:
	    begin
	    genexpr(opnd);
	    if not opnd^.attr^.signbit then
	      extend(opnd,succ(opnd^.attr^.storage));
	    loadvalue(opnd);
	    with op do
	      begin
	      addrmode := immediate;
	      smallval := 1;
	      end;
	    if eclass = succnode then
	      emit2(addq,op,opnd^.attr^)
	    else
	      emit2(subq,op,opnd^.attr^);
	    ovflck;
	    if RANGECHECK then
	      emitcheck(opnd,opnd^.etyptr,false);
	    liftattr(fexp,opnd);
	    storage := opnd^.attr^.storage;
	    end;
	  otherwise escape(-8);
	  end; {case eclass}
      end; {if attr = NIL}
end; {genexpr}



@


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


56.2
log
@Added line to initialize symptr to NIL in the concatnode case of
the routine genexpr. In one particular program, the uninitialized value
of symptr just happened to point to a structure that already existed.
No plans to turn the compiler for this defect, but the change is being
checked in just in case there is a turn in the future.
@
text
@a0 3621
		      { file GENEXPR }

implement {genexprmod}

var  {save/reload regs stuff}
  rstring, disp: attrtype; numsavedregs: 0..15;
  onereg : record        { if there is only one register this is it }
	     rt: regtype;
	     rn: regrange;
	   end;

procedure makeaddressable{varexp: exptr};
  { ensure addressability of variable }
  begin genexpr(varexp);
    with varexp^.attr^ do
      begin
      if packd then bitaddress(varexp);
      if access = indirect then
	loadaddress(varexp,false)
      else checkoffset(varexp);
      if packd then unpack(varexp);
      end;
  end; {makeaddressable}

procedure extend(*fexp: exptr; fstorage: stortype*);
  {extend is a general routine called to ensure that its parameter
   is of a given storage (size).  The desired final storage could
   be smaller, the same, or larger then the current storage}

  var
    op: attrtype;
  begin
    genexpr(fexp);
    with fexp^, attr^ do
      begin if packd then makeaddressable(fexp);
      { if eclass = litnode then fixliteral(fexp,fstorage,true); }
      { BUG FIX 10/14/88 - JWH }
      if addrmode = immediate then fixliteral(fexp,fstorage,true);
      if storage <> fstorage then
	begin
	if fstorage > storage then
	  begin
	  if (not signbit) then
	    begin
	    getregattr(D,op);
	    emit2(moveq,immed0,op);
	    makeaddressable(fexp);
	    op.storage := storage;
	    emit2(move,attr^,op);
	    freeregs(attr);
	    addrmode := inDreg;
	    regnum := op.regnum;
	    signbit := true;
	    if ensure_valid_condition_code then
	      begin
	      op.storage := fstorage;
	      emit1(tst,op);
	      end;
	    end
	  else
	    begin
	    loadvalue(fexp);
	    $IF MC68020$
	    if (storage = bytte) and (fstorage = long) then
	      emit1(extb,attr^)
	    else
	    $END$
	    while storage < fstorage do
	      begin storage := succ(storage); emit1(ext,attr^); end;
	    end;
	  end
	else {fstorage < storage}
	  begin
	  if addrmode = topofstack then loadvalue(fexp)
	  else makeaddressable(fexp);
	  if storage = wrd then offset := offset + 1
	  else {storage = long}
	    if fstorage = wrd then offset := offset + 2
	    else if fstorage = bytte then offset := offset + 3;
	  end;
	storage := fstorage;
	end;
      end;
  end; {extend}

procedure checkstackandextend(exp1,exp2: exptr; len: stortype);
  {if exp2's storage <> len then extend it, checking for
   exp2 at topofstack-1 }
  begin
  with exp2^.attr^ do
    if storage <> len then
      begin
      if (addrmode=topofstack) and (exp1^.attr^.addrmode=topofstack) then
	loadvalue(exp1); {pop}
      extend(exp2,len);
      end;
  end; {checkstackandextend}

procedure relCMP(* fexp: exptr; var fdestonleft,fsigned: boolean *);
  var destonleft,cmpwith0: boolean;
      lmode,rmode: addrtype; lstorage,rstorage: stortype;
      signed,lsigned,rsigned: boolean; cmptype: opcodetype;

  procedure relprok(lop,rop: exptr);
    { compare procedure objects for (in)equality.
      note: const relop const handled by front end }

    procedure relprokVC(pexp,pconst: exptr);
      {compare prok var or expr with prok const}
      begin pexp^.attr^.storage := long;
      if callmode = relcall then
	begin loadaddress(pconst,false);
	pconst^.attr^.addrmode := inAreg;
	emit2(cmpa,pexp^.attr^,pconst^.attr^);
	freeit(A,pconst^.attr^.regnum);
	end
      else emit2(cmpi,pconst^.attr^,pexp^.attr^);      { CMPI.L pconst,pexp }
      freeregs(pexp^.attr);
      end;

    begin {relprok}
    makeaddressable(lop); makeaddressable(rop);
    if lop^.ekind <> cnst then
      if rop^.ekind <> cnst then
	begin
	rop^.attr^.storage := long; {to fool loadvalue}
	loadvalue(rop);
	emit2(cmp,lop^.attr^,rop^.attr^);   { CMP.L lop,rop }
	freeregs(lop^.attr); freeregs(rop^.attr);
	end
      else relprokVC(lop,rop)
    else relprokVC(rop,lop);
    end; {relprok}

  begin {relCMP}
    with fexp^ do
      if opnd1^.etyptr^.form = prok then
	begin relprok(opnd1,opnd2); fdestonleft := false {don't care} end
      else {not prok compare}
	begin {select CMP or CMPI, and order of operands}
	cmpwith0 := false;
	if opnd1^.ekind > opnd2^.ekind then
	  begin makeaddressable(opnd1); makeaddressable(opnd2) end
	else begin makeaddressable(opnd2); makeaddressable(opnd1) end;
	maskboolexpr(opnd1); maskboolexpr(opnd2);
	with opnd1^.attr^ do
	  begin lmode := addrmode;
	  lstorage := storage;
	  lsigned := signbit;
	  end;
	with opnd2^.attr^ do
	  begin rmode := addrmode;
	  rstorage := storage;
	  rsigned := signbit;
	  end;
	if rmode = immediate then
	  begin destonleft := true; cmptype := cmpi;
	  fixliteral(opnd2,lstorage,lsigned);
	  with opnd2^.attr^ do
	    begin rstorage := storage; rsigned := signbit;
	    if rmode = immediate then
	      if (smallval = 0) and
		 (lmode <> namedconst) then
		cmpwith0 := true
	      else if (smallval >= -128) and (smallval <= 127) then
		begin loadvalue(opnd2); cmptype := cmp end;
	    end;
	  end
	else if lmode = immediate then
	  begin destonleft := false; cmptype := cmpi;
	  fixliteral(opnd1,rstorage,rsigned);
	  with opnd1^.attr^ do
	    begin lstorage := storage; lsigned := signbit;
	    if lmode = immediate then
	      if (smallval = 0) and
		 (rmode <> namedconst) then
		cmpwith0 := true
	      else if (smallval >= -128) and (smallval <= 127) then
		begin loadvalue(opnd1); cmptype := cmp end;
	    end;
	  end
	else cmptype := cmp;
	if (lstorage = rstorage) and (lsigned = rsigned) then
	  signed := lsigned
	else if rstorage = long then
	  begin signed := true;
	  if lstorage <> long then extend(opnd1,long);
	  end
	else if lstorage = long then
	  begin signed := true;
	  if rstorage <> long then
	    checkstackandextend(opnd1,opnd2,long);
	  end
	else if (rstorage = wrd) and rsigned and (lstorage = bytte) then
	  begin signed := true; extend(opnd1,wrd) end
	else if (lstorage = wrd) and lsigned and (rstorage = bytte) then
	  begin signed := true; checkstackandextend(opnd1,opnd2,wrd) end
	else if (lstorage = bytte) and not lsigned then
	  begin
	  if rsigned then {opnd2 is signed byte}
	    begin signed := true; extend(opnd1,wrd);
	    checkstackandextend(opnd1,opnd2,wrd);
	    end
	  else {opnd2 is unsigned word}
	    begin signed := false; extend(opnd1,wrd) end
	  end
	else if (rstorage = bytte) and not rsigned then
	  begin
	  if lsigned then {opnd1 is signed byte}
	    begin signed := true; extend(opnd1,wrd);
	    checkstackandextend(opnd1,opnd2,wrd);
	    end
	  else {opnd1 is unsigned word}
	    begin signed := false; checkstackandextend(opnd1,opnd2,wrd) end
	  end
	else {unsigned word vs signed or word signed byte}
	  begin signed := true; extend(opnd1,long);
	  checkstackandextend(opnd1,opnd2,long);
	  end;
	if cmptype <>  cmpi then
	  begin destonleft := (opnd2^.attr^.addrmode <> inDreg);
	  if destonleft then loadvalue(opnd1);
	  end;
	{emit appropriate code}
	if destonleft then
	  begin
	  if not cmpwith0 then                     { CMP[I].size op2,op1 }
	    emit2(cmptype,opnd2^.attr^,opnd1^.attr^)
	  else if (opnd1^.attr^.addrmode<>inDreg) or (opnd1^.eclass=modnode) or
		  ((opnd1^.eclass=shftnode) and (not opnd1^.attr^.signbit))
	    then emit1(tst,opnd1^.attr^);           { TST.size op1 }
	  end
	else
	  if not cmpwith0 then                     { CMP[I].size op1,op2 }
	    emit2(cmptype,opnd1^.attr^,opnd2^.attr^)
	  else if (opnd2^.attr^.addrmode<>inDreg) or (opnd2^.eclass=modnode) or
		  ((opnd2^.eclass=shftnode) and (not opnd2^.attr^.signbit))
	    then emit1(tst,opnd2^.attr^);           { TST.size op2 }
	freeregs(opnd1^.attr); freeregs(opnd2^.attr);
	fdestonleft := destonleft; fsigned := signed;
	end; {not prok compare}
  end; {relCMP}

procedure saveregs;
  { save allocated registers in local storage using MOVEM.L ...,disp(A6).
    Save register list in rstring for reloading. }
  var
    rt: regtype; rn: regrange;
  begin
    if float = flt_on then saverealregs;
    with rstring do
      begin
      numsavedregs := 0;
      for rt := A to D do
	for rn := 0 to maxreg do
	  if reg[rt,rn].allocstate = allocated then
	    begin
	    numsavedregs := numsavedregs+1;
	    regs[rt,rn] := true;
	    onereg.rt := rt; onereg.rn := rn;
	    end
	  else regs[rt,rn] := false;
      if numsavedregs <> 0 then
	begin
	getlocstorage(numsavedregs*4,disp);
	disp.storage := long;
	if numsavedregs = 1 then
	  begin
	  regnum := onereg.rn;
	  if onereg.rt = A then addrmode := inAreg
			   else addrmode := inDreg;
	  emit2(move,rstring,disp);
	  end
	else
	  begin
	  addrmode := multiple;
	  emit2(movem,rstring,disp);
	  end;
	end;
      end;
  end; {saveregs}

procedure reloadregs;
  { reload allocated registers from local storage }
  begin
    if numsavedregs > 0 then
      begin
      rstring.storage := long;
      if numsavedregs > 1 then
	emit2(movem,disp,rstring)
      else
	emit2(move,disp,rstring);
      end;
    if float = flt_on then reloadrealregs;
  end;

procedure gensetop {fexp: exptr};
  const
    attos = true;
    inloc = false;

  procedure stackops (fopnd1,fopnd2 : exptr);
    { operands appear on the stack in the following order:
	  address of left operand (+8)
	  address of right operand (+4) }
    begin {stackops}
    pushaddress(fopnd1);
    pushaddress(fopnd2);
    end; {stackops}

  procedure stackresult (fexp : exptr ; fattos : boolean);
    { fill in attributes for result of set operation }
    begin
    with fexp^,attr^ do
      if fattos then addrmode := topofstack { boolean result }
      else { set result }
	begin getlocstorage(etyptr^.unpacksize,attr^);
	pushaddress(fexp) { result address on stack (at +12) }
	end;
    end; {stackresult}

  begin {gensetop}
  with fexp^ do
    begin { set up for external routines for =,<>,<=,>=,+,*,-,in }
    case eclass of
      unionnode,intersectnode,diffnode :
	begin stackresult(fexp,inloc); { set result in local storage }
	stackops(opnd1,opnd2);
	end;
      eqnode,nenode,subsetnode :
	begin stackresult(fexp,attos); { boolean result at tos }
	stackops(opnd1,opnd2);
	end;
      supersetnode :
	begin stackresult(fexp,attos); { boolean result at tos }
	{ reverse arguments => subset operation }
	stackops(opnd2,opnd1);
	end;
      innode:
	begin stackresult(fexp,attos);
	extend(opnd1,long); pushvalue(opnd1);
	pushaddress(opnd2);
	end;
      otherwise escape(-8);
      end; {case}
    saveregs; forgetbaseregs;
    case fexp^.eclass of
      diffnode      : callstdproc('ASM_DIFFERENCE');
      intersectnode : callstdproc('ASM_INTERSECT');
      unionnode     : callstdproc('ASM_UNION');
      supersetnode,
      subsetnode    : callstdproc('ASM_INCLUSION');
      eqnode        : callstdproc('ASM_EQUAL');
      nenode        : callstdproc('ASM_NEQUAL');
      innode        :
$if not bigsets$
		      callstdproc('ASM_IN');
$end$
$if bigsets$
		      callstdproc('ASM_XIN');
$end$
      end; {case}
    reloadregs;
    end {with}
  end; {gensetop}

procedure ovflck;
  begin
  if ovflcheck then emit0(trapv);
  end;

procedure pushvarstring(fexp: exptr);
  var
    op1: attrtype;
  begin
  genexpr(fexp);
  SPminus.storage := bytte;
  with fexp^,attr^ do
    if etyptr = strgptr then
      begin  {actual is var string}
      offset := offset+4;
      emit2(move,attr^,SPminus);
      offset := offset-4;
      end
    else
      begin
      op1.addrmode := immediate;
      op1.smallval := etyptr^.maxleng;
      emit2(move,op1,SPminus);
      end;
  pushaddress(fexp);
  end;

procedure pushsubstr(fexp: exptr);
  var
    op: attrtype;
    temp: integer;
  begin
  with fexp^ do
    begin
    if strgtype(arayp^.etyptr) then
      pushvarstring(arayp)
    else { paoc }
      begin
      with op do
	begin
	addrmode := immediate;
	getbounds(arayp^.etyptr^.inxtype,temp,
				       smallval);
	end;
      SPminus.storage := long;
      emit2(move,op,SPminus);
      pushaddress(arayp);
      end;
    extend(indxp,long);
    pushvalue(indxp);
    if lengthp <> NIL then
      begin
      extend(lengthp,long);
      pushvalue(lengthp);
      end;
    end;
  end;

procedure genconcat(dest,tree: exptr); forward;

function branchmatch(exp1,exp2: exptr): boolean;
  begin
    if exp1^.eclass <> exp2^.eclass then branchmatch := false
    else case exp1^.eclass of
      eqnode..andnode:
	branchmatch := branchmatch(exp1^.opnd1,exp2^.opnd1) and
		       branchmatch(exp1^.opnd2,exp2^.opnd2);
      negnode..truncnode:
	branchmatch := branchmatch(exp1^.opnd,exp2^.opnd);
      idnode:
	branchmatch := exp1^.symptr = exp2^.symptr;
      subscrnode:
	branchmatch := branchmatch(exp1^.arayp,exp2^.arayp) and
		       branchmatch(exp1^.indxp,exp2^.indxp);
      selnnode:
	branchmatch := branchmatch(exp1^.recptr,exp2^.recptr) and
		       (exp1^.fieldptr = exp2^.fieldptr);
      unqualfldnode:
	branchmatch := (exp1^.withstptr = exp2^.withstptr) and
		       (exp1^.fieldref = exp2^.fieldref);
      litnode:
	if exp1^.litval.intval then
	  if exp2^.litval.intval then
	    branchmatch := exp1^.litval.ival = exp2^.litval.ival
	  else branchmatch := false
	else branchmatch := false;
      otherwise branchmatch := false;
    end; {case}
  end; {branchmatch}

procedure stringassign(source,dest: exptr);

  var
    op1,op2,
    sourceattr,destattr: attrtype;
    checking: boolean;
    lexp: exptr;
    lstp: stp;

  begin { string assign }
  if source^.eclass = concatnode then
    begin
    getlocstorage(256,op1);
    new(lexp);
    new(lstp);
    with lexp^ do
      begin
      attr := addr(op1);
      lstp^:= strgptr^;
      lstp^.unpacksize := 256;
      etyptr := lstp;
      eclass := idnode;
      symptr := NIL;
      end;
    genconcat(lexp,source);
    stringassign(lexp,dest);
    end
  else { string }
    if not branchmatch(source,dest) then
      begin
      with source^ do
	begin
	makeaddressable(source);
	with sourceattr do
	  begin
	  addrmode := inAreg;
	  regnum := getreg(A);
	  end;
	emit2(lea,{source^.}attr^,sourceattr);
	freeregs({source^.}attr);
	sourceattr.addrmode := postincr;
	with op1 do
	  begin
	  addrmode := inDreg; regnum := getreg(D);
	  storage := bytte;
	  end;
	emit2(move,sourceattr,op1); {load source size}
	checking := false;
	if rangecheck then
	  if dest^.etyptr = strgptr then { var string }
	    begin
	    genexpr(dest);
	    with dest^, attr^ do
	      begin
	      offset := offset + 4;
	      emit2(cmp,attr^,op1);
	      offset := offset - 4;
	      end;
	    checking := true;
	    end
	  else if ({source^.}eclass <> litnode) and
		  strgtype({source^.}etyptr) then
	    begin
	    with op2 do
	      begin
	      addrmode := immediate; storage := bytte;
	      smallval := dest^.etyptr^.maxleng;
	      end;
	    emit2(cmpi,op2,op1);
	    checking := true;
	    end;
	end; { with source^ }
      if checking then
	begin
	with op2 do
	  begin offset := 2; storage := bytte; end;
	emit1(bls,op2);
	op2.smallval := 7;
	emit1(trap,op2);
	end;
      with destattr do
	begin
	addrmode := inAreg;
	regnum := getreg(A);
	end;
      makeaddressable(dest);
      emit2(lea,dest^.attr^,destattr);
      freeregs(dest^.attr);
      destattr.addrmode := postincr;
      destattr.storage := bytte;
      emit2(move,op1,destattr);
      emit2(move,sourceattr,destattr);
      with op2 do
	begin
	addrmode := immediate; smallval := 1;
	end;
      emit2(subq,op2,op1);
      op2.offset := -6;
      emit1(bhi,op2);
      freeit(A,destattr.regnum);
      freeit(D,op1.regnum);
      freeit(A,sourceattr.regnum);
      end; { string }
  end; { stringassign }

procedure pushparms{formalp: ctp; actualp: elistptr};
  var
    formaltype: stp; op1: attrtype;

    procedure pushdopevector(formalpidtype: stp; dopevec: stp);
      var
	lo,hi: integer;
	op,
	dope_element : attrtype;

      begin
      if formalpidtype^.aeltype^.form = cnfarrays then
	pushdopevector(formalpidtype^.aeltype,dopevec^.aeltype);

      with dopevec^ do
	begin
	case formalpidtype^.inxtype^.unpacksize of
	  1: SPminus.storage := bytte;
	  2: SPminus.storage := wrd;
	  4: SPminus.storage := long;
	end;
	if form = cnfarrays then
	  begin
	  with dope_element do
	    begin
	    addrmode := locinreg;
	    regnum := getbasereg(dopevec^.cnf_index^.hiboundid^.vlev);
	    indexed := false;
	    gloptr := NIL;
	    end;
	  with cnf_index^ do
	    if formalpidtype^.inxtype^.unpacksize = inxtype^.unpacksize then
	      begin
	      if SPminus.storage = long then
		dope_element.offset := hiboundid^.vaddr + 4
	      else
		dope_element.offset := hiboundid^.vaddr + 2;
	      emit2(move,dope_element,SPminus); {push length}
	      if SPminus.storage = long then
		dope_element.offset := dope_element.offset - 4
	      else
		dope_element.offset := dope_element.offset - 2;
	      emit2(move,dope_element,SPminus); {push upper bound}
	      dope_element.offset := loboundid^.vaddr;
	      emit2(move,dope_element,SPminus); {push lower bound}
	      end
	    else { extend word to long before pushing }
	      begin
	      with op do
		begin
		addrmode := inDreg;
		storage := wrd;
		regnum := getreg(D);
		end;
	      if inxtype^.unpacksize = 4 then
		dope_element.offset := hiboundid^.vaddr + 4
	      else
		dope_element.offset := hiboundid^.vaddr + 2;
	      emit2(move,dope_element,op);
	      op.storage := long;
	      emit1(ext,op);
	      emit2(move,op,SPminus); {push length}
	      if inxtype^.unpacksize = 4 then
		dope_element.offset := dope_element.offset - 4
	      else
		dope_element.offset := dope_element.offset - 2;
	      op.storage := wrd;
	      emit2(move,dope_element,op);
	      op.storage := long;
	      emit1(ext,op);
	      emit2(move,op,SPminus); {push upper bound}
	      dope_element.offset := loboundid^.vaddr;
	      op.storage := wrd;
	      emit2(move,dope_element,op);
	      op.storage := long;
	      emit1(ext,op);
	      emit2(move,op,SPminus); {push lower bound}
	      freeit(D,op.regnum);
	      end;
	  freeregs(addr(dope_element));
	  end
	else {form = arrays}
	  begin
	  op.addrmode := immediate;
	  if (aeltype^.form = arrays) then
	    op.smallval := aelsize
	  else
	    if aispackd then
	      op.smallval := aelbitsize
	    else
	      op.smallval := aelsize;
	  getbounds(inxtype,lo,hi);
	  emit2(movei,op,SPminus);  {push length}
	  op.smallval := hi;
	  emit2(movei,op,SPminus);  {push upper bound}
	  op.smallval := lo;
	  emit2(movei,op,SPminus);  {push lower bound}
	  end;
	end;
      end;

begin { pushparms }
while formalp <> NIL do
  with formalp^ do
    begin
    if rangecheck and (vtype = valparm) then
      emitcheck(actualp^.expptr,idtype,true);
    { cvalparms will be rangechecked in the routine itself }
    if (vtype = cvalparm) then
      pushaddress(actualp^.expptr)
    else if (vtype = refparm) or
	    (vtype = anyvarparm) then
      pushaddress(actualp^.expptr)
    else if vtype = strparm then {var str formal}
      pushvarstring(actualp^.expptr)
    else if vtype = dopeparm then { conformant array dope vector }
      pushdopevector(formalp^.idtype,actualp^.expptr^.etyptr)
    else
      with actualp^ do
	begin {valparm}
	with formalp^ do
	  if klass = vars then formaltype := idtype
	  else formaltype := proktype;
	makeaddressable(expptr);
	case formaltype^.unpacksize of
	  0  : {empty record};
	  1  : if expptr^.attr^.storage <> bytte then extend(expptr,bytte);
	  2  : if expptr^.attr^.storage <> wrd then extend(expptr,wrd);
	  3,4: if expptr^.attr^.storage <> long then extend(expptr,long);
	  8  : {real or procedure variable or constant};
	  end;
	if formaltype^.form in [prok,funk] then
	  with expptr^ do
	    if ekind <> cnst then pushvalue(expptr)
	    else {actual is prok constant}
	      begin SPminus.storage := long;
	      if symptr^.pflev > 1 then movestatic(symptr^.pflev,SPminus)
	      else emit1(clr,SPminus);  {assumes nilvalue = 0}
	      if not isoverlay(symptr,getaddress) then { OVERLAY MODULE }
		emit1(pea,attr^);
	      end
	else
	  begin
	  if not rangecheck then maskboolexpr(expptr);
	  pushvalue(expptr);
	  end;
	end;
    if vtype <> dopeparm then
      actualp := actualp^.nextptr;
    formalp := next;
    end;
end; {pushparms}

procedure genaddr(* fexp,dest: exptr *);
  { code gen for addr function.  Fexp is the fcallnode;
    if dest is NIL result goes to stack, else to dest. }
  var offsetexpr: exptr;
      destattr: attrtype;

  procedure moveaddr(fexp: exptr);
    begin
      if dest=NIL then pushaddress(fexp)
      else moveaddress(fexp,destattr);
    end;

  begin {genaddr}
    with fexp^.actualp^ do
      begin
      if dest <> NIL then destattr := dest^.attr^
      else
	begin
	SPind.storage := long;
	destattr := SPind;
	end;
      genexpr(expptr);
      if nextptr = NIL then moveaddr(expptr)
      else begin {optional offset supplied}
	offsetexpr := nextptr^.expptr;
	genexpr(offsetexpr);
	with offsetexpr^.attr^ do
	  if addrmode = immediate then
	    if expptr^.attr^.access = indirect then
	      begin moveaddr(expptr);
	      if smallval <> 0 then
		emit2(add,offsetexpr^.attr^,destattr);
	      end
	    else
	      begin {direct access}
	      expptr^.attr^.offset := expptr^.attr^.offset+smallval;
	      moveaddr(expptr);
	      end
	  else
	    begin {non-constant offset}
	    loadvalue(offsetexpr);
	    if expptr^.attr^.indexed or
		(expptr^.attr^.access = indirect) then
	      begin
	      moveaddr(expptr);
	      extend(offsetexpr,long);
	      emit2(add,offsetexpr^.attr^,destattr);
	      freeit(D,regnum);
	      end
	    else {make offset the index reg}
	      begin
	      if storage = bytte then extend(offsetexpr,wrd);
	      if (storage = wrd) and not signbit then
		extend(offsetexpr,long);
	      expptr^.attr^.indexed := true;
	      expptr^.attr^.indexreg := regnum;
	      expptr^.attr^.indexstorage := storage;
	      $IF MC68020$
	      expptr^.attr^.indexscale := 0;
	      $END$
	      moveaddr(expptr);
	      end;
	    end; {non-constant offset}
	end; {optional offset}
      end; {with actualp^}
  end; {genaddr}

    procedure callvar
      (* formalp: ctp; actualp: elistptr; isfunc: boolean *);
      {call prok var, prok or func param}
      var op1: attrtype; patchloc: addrrange;
      begin
      with actualp^ do
	begin
	pushparms(formalp,nextptr);
	genexpr(expptr);
	if isfunc then {in case genexpr found generalized func}
	  expptr^.attr^.access := direct;
	makeaddressable(expptr);
	with expptr^,attr^ do
	  begin
	  offset := offset+4;
	  storage := long;
	  emit1(tst,attr^);
	  {  code sequence assumes nilvalue = 0  }
	  patchloc := codephile.bytecount + 2;
	  op1.offset := 0; op1.storage := bytte;
	  emit1(beq,op1);
	  SPminus.storage := long;
	  emit2(move,attr^,SPminus);
	  offset := offset-4;
	  fixbyte(patchloc-1,codephile.bytecount - patchloc);
	  freeregs(attr);
	  getregattr(A,op1);
	  emit2(movea,attr^,op1);
	  freeit(A,op1.regnum);
	  with op1 do
	    begin addrmode := locinreg;
	    indexed := false; gloptr := NIL;
	    end;
	  if isfunc then begin saveregs; forgetbaseregs end;
	  emit1(jsr,op1);             { jsr (A0) }
	  if isfunc then reloadregs else clear(false);
	  end;
	end;
      end;

    function getstorageinfo(fsp: stp): stortype;
      begin
	if fsp = NIL then getstorageinfo := wrd
	else
	  case fsp^.unpacksize of
	    1: getstorageinfo := bytte;
	    2: getstorageinfo := wrd;
	    4: getstorageinfo := long;
	    otherwise getstorageinfo := multi
	    end;
      end; {getstorageinfo}

    procedure getattrec(fexp: exptr);
      begin
	with fexp^ do
	  begin
	  if freeattr = NIL then new(attr)
	  else
	    begin
	     attr := freeattr;
	    freeattr := freeattr^.next;
	    end;
	  attr^.next := globalattrlist^;
	  globalattrlist^ := attr;
	  with attr^ do
	    begin
	    storage := getstorageinfo(etyptr);
	    packd := false;
	    access := direct;
	    indexed := false;
	    offset := 0;
	    regnum := 0;
	    signbit := false;
	    gloptr := NIL;
	    {ensure known values for packed fields}
	    bitsize := 0;
	    with bitoffset do
	      begin static := 0; variable := -1; end;
	    end;
	  end;

      end;

    procedure genshortand(fexp: exptr;
	VAR truelist,falselist: reflistptr;
	onright,falsedefined, value: boolean; valueattr : attrptr);
      var
	bptr,newtruelist,
	templist1,templist2: reflistptr;
	op: attrtype;
      begin
	with fexp^ do
	  begin
	  newtruelist := NIL;
	  if opnd1^.eclass = andnode then
	    genshortand(opnd1,newtruelist,falselist,false,falsedefined,
			value,valueattr)
	  else if opnd1^.eclass = ornode then
	    begin
	    genshortor(opnd1,newtruelist,falselist,false,falsedefined,
		       value,valueattr);
	    {generate jump to false}
	    if not falsedefined then
	      begin
	      new(bptr);
	      bptr^.next := falselist;
	      falselist := bptr;
	      end;
	    getbrattr(falselist^.pc,falsedefined,op);
	    emit1(bra,op)
	    end
	  else if not value then
	    if falsedefined then
	      gencond(opnd1,falselist,true)
	    else
	      begin
	      gencond(opnd1,templist2,false);
	      templist1 := templist2;
	      if templist2 <> NIL then
		begin
		while templist2^.next <> NIL do
		  templist2 := templist2^.next;
		templist2^.next := falselist;
		falselist := templist1;
		end;
	      end
	  else
	    begin
	    movevalue(opnd1,valueattr^);
	    conditionis := bne;
	    if not falsedefined then
	      begin
	      new(bptr);
	      bptr^.next := falselist;
	      falselist := bptr;
	      end;
	    getbrattr(falselist^.pc,falsedefined,op);
	    case conditionis of { use opposite }
	      beq: emit1(bne,op);
	      bne: emit1(beq,op);
	      blt: emit1(bge,op);
	      bcs: emit1(bcc,op);
	      ble: emit1(bgt,op);
	      bls: emit1(bhi,op);
	      bgt: emit1(ble,op);
	      bhi: emit1(bls,op);
	      bge: emit1(blt,op);
	      bcc: emit1(bcs,op);
	      otherwise escape(-8);
	    end; { case }
	    end;
	  fixreflist(newtruelist);
	  if opnd2^.eclass = andnode then
	    genshortand(opnd2,truelist,falselist,onright,falsedefined,
		       value,valueattr)
	  else if opnd2^.eclass = ornode then
	    begin
	    genshortor(opnd2,truelist,falselist,onright,falsedefined,
			value,valueattr);
	    {generate jump to false}
	    if not falsedefined then
	      begin
	      new(bptr);
	      bptr^.next := falselist;
	      falselist := bptr;
	      end;
	    getbrattr(falselist^.pc,falsedefined,op);
	    emit1(bra,op)
	    end
	  else
	    if value then
	      begin
	      movevalue(opnd2,valueattr^);
	      conditionis := bne;
	      if not onright then
		begin
		if not falsedefined then
		  begin
		  new(bptr);
		  bptr^.next := falselist;
		  falselist := bptr;
		  end;
		getbrattr(falselist^.pc,falsedefined,op);
		case conditionis of { use opposite }
		  beq: emit1(bne,op);
		  bne: emit1(beq,op);
		  blt: emit1(bge,op);
		  bcs: emit1(bcc,op);
		  ble: emit1(bgt,op);
		  bls: emit1(bhi,op);
		  bgt: emit1(ble,op);
		  bhi: emit1(bls,op);
		  bge: emit1(blt,op);
		  bcc: emit1(bcs,op);
		  otherwise escape(-8);
		end; { case }
		end;
	      end
	  else
	    if falsedefined then
	      gencond(opnd2,falselist,true)
	    else
	      begin
	      gencond(opnd2,templist2,false);
	      templist1 := templist2;
	      if templist2 <> NIL then
		begin
		while templist2^.next <> NIL do
		  templist2 := templist2^.next;
		templist2^.next := falselist;
		falselist := templist1;
		end;
	      end;
	  end; { with fexp }
      forgetbaseregs;
      end; { genshortand }

    procedure genshortor(fexp: exptr;
	VAR truelist,falselist: reflistptr;
	onright,falsedefined,value: boolean; valueattr : attrptr);
      var
	bptr,newfalselist: reflistptr;
	op: attrtype;
      begin
	with fexp^ do
	  begin
	  newfalselist := NIL;
	  if opnd1^.eclass = andnode then
	    begin
	    genshortand(opnd1,truelist,newfalselist,false,false,
			value,valueattr);
	    {generate jump to true}
	    new(bptr);
	    bptr^.next := truelist;
	    truelist := bptr;
	    getbrattr(truelist^.pc,false,op);
	    emit1(bra,op)
	    end
	  else if opnd1^.eclass = ornode then
	    genshortor(opnd1,truelist,newfalselist,false,false,
		      value,valueattr)
	  else
	    begin
	    if value then
	      begin
	      movevalue(opnd1,valueattr^);
	      conditionis := bne;
	      end
	    else
	      begin
	      conditionis := bne;
	      loadvalue(opnd1);
	      freeregs(opnd1^.attr);
	      end;
	    new(bptr);
	    bptr^.next := truelist;
	    truelist := bptr;
	    getbrattr(truelist^.pc,false,op);
	    emit1(conditionis,op)
	    end;
	  fixreflist(newfalselist);
	  if opnd2^.eclass = andnode then
	    begin
	    genshortand(opnd2,truelist,falselist,onright,falsedefined,
		       value,valueattr);
	    new(bptr);
	    bptr^.next := truelist;
	    truelist := bptr;
	    getbrattr(truelist^.pc,false,op);
	    emit1(bra,op)
	    end
	  else if opnd2^.eclass = ornode then
	    genshortor(opnd2,truelist,falselist,onright,falsedefined,
		      value,valueattr)
	  else
	    begin
	    if value then
	      begin
	      movevalue(opnd2,valueattr^);
	      conditionis := bne;
	      end
	    else
	      begin
	      conditionis := bne;
	      loadvalue(opnd2);
	      freeregs(opnd2^.attr);
	      end;
	    if not onright or not value then
	      begin
	      new(bptr);
	      bptr^.next := truelist;
	      truelist := bptr;
	      getbrattr(truelist^.pc,false,op);
	      emit1(conditionis,op);
	      end;
	    end;
	  end; { with fexp }
      forgetbaseregs;
      end; { genshortor }

    procedure genconcat(dest,tree: exptr);
      var
	op: attrtype;

      procedure genappend(dest,tree: exptr);
	begin
	if tree^.eclass = concatnode then
	  begin
	  genappend(dest,tree^.opnd1);
	  genappend(dest,tree^.opnd2);
	  end
	else
	  begin
	  makeaddressable(tree);
	  genexpr(dest);
	  pushvarstring(dest);
	  if strgtype(tree^.etyptr) then
	    pushaddress(tree)
	  else escape(-8);
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_SAPPEND');
	  reloadregs;
	  end;
	end; { genappend }

      procedure findfarleft(dest,tree: exptr);
	begin
	if tree^.eclass = concatnode then
	  begin
	  findfarleft(dest,tree^.opnd1);
	  genappend(dest,tree^.opnd2);
	  end
	else
	  begin
	  loadaddress(dest,false);
	  if reg[A,dest^.attr^.regnum].usage =
				 withrecbase then
	    with op do
	      begin
	      addrmode := inAreg;
	      storage := long;
	      regnum := getreg(A);
	      emit2(movea,dest^.attr^,op);
	      dest^.attr^.regnum := regnum;
	      end;
	  with reg[A,dest^.attr^.regnum] do
	    begin
	    usage := basereg;
	    usesleft := maxint;
	    baselevel := 0;
	    end;
	  stringassign(tree,dest);
	  end;
	end;

      begin { genconcat }
      findfarleft(dest,tree^.opnd1);
      genappend(dest,tree^.opnd2);
      with reg[A,dest^.attr^.regnum] do
	begin
	usage := other;
	allocstate := allocated;
	usesleft := 0;
	end;
      end;

    function isoverlay(pfptr: ctp; callt: calltype): boolean;
      var
	found: boolean;
	i: shortint;
	nametemp: string255;
	expptr: exptr;
	ctptemp: ctp;
	op: attrtype;
      begin
      isoverlay := false;
      if not(pfptr^.alias) and not(pfptr^.isdumped) then
	begin
	if pfptr^.othername <> NIL then
	  begin
	  found := false;
	  i := 1;
	  while not found and (i <= overlaytop) do
	    if pfptr^.othername^ = overlaylistptr^[i] then
	      found := true
	    else
	      i := i + 1;
	  if found then { overlay }
	    begin
	    nametemp := pfptr^.othername^ + '_' +
			pfptr^.namep^;
	    new(expptr);
	    with expptr^ do
	      begin
	      eclass := litnode;
	      etyptr := NIL;
	      attr := NIL;
	      litval.intval := false;
	      new(litval.valp);
	      with litval.valp^ do
		begin
		cclass := strng;
		slgth := strlen(nametemp);
		strmove(slgth,nametemp,1,sval,1);
		end;
	      end;
	    genexpr(expptr);
	    pushaddress(expptr);
	    new(ctptemp);
	    ctptemp^ := pfptr^;
	    ctptemp^.othername := addr(OVERLAY);
	    if callt = getaddress then
	      ctptemp^.namep := addr(ADDRESS)
	    else
	      ctptemp^.namep := addr(EXEC);
	    getprokconst(ctptemp,op);
	    emit1(jsr,op);
	    isoverlay := true;
	    end; { if found }
	  end; { othername <> NIL }
	end;
      end;

    procedure genexpr{fexp: exptr};
      var
	lform: structform;
	lop,rop,oldattr,op: attrtype;
	lexp: exptr;
	lstp: stp;

      procedure genfcall(fexp: exptr);
	var destoffset,resultsize: addrrange;
	    offsetexpr,source,letter,lngth: exptr;
	    sexp: elistptr; op: attrtype;
	    $IF MC68020$
	    i: shortint;
	    lbl1,lbl2: localref;
	    at: attrptr;
	    $END$

	begin
	with fexp^,fptr^ do
	  if (klass <> func) or (pfdeckind = declared) then
	    begin
	    if etyptr^.form >= prok then
	      begin getlocstorage(etyptr^.unpacksize,attr^);
	      emit1(pea,attr^);
	      end
	    else
	      begin resultsize := etyptr^.unpacksize;
	      if odd(resultsize) then resultsize := resultsize+1;
	      with op do
		begin addrmode := immediate; smallval := resultsize end;
	      SPdir.storage := long;
	      emit2(subq,op,SPdir);
	      attr^.addrmode := topofstack;
	      getsignbit(etyptr,attr);
	      end;
	    if klass = routineparm then
	      callvar(proktype^.params,actualp,true)
	    else {function constant}
	      begin pushparms(next,actualp);
	      if pflev > 1 then
		begin SPminus.storage := long; movestatic(pflev,SPminus) end;
	      saveregs; forgetbaseregs;
	      if not isoverlay(fptr,gencall) then
		begin
		getprokconst(fptr,op);
		emit1(jsr,op);
		end;
	      reloadregs;
	      end;
	    end
	  else
	    case spkey of
	      spunitbusy,speoln,speof,spposition,
	      spmaxpos,sppos,spstrpos,spstrrpt,
	      spltrim,sprtrim,spmemavail:
		begin
		if spkey in
		    [spstrrpt,spltrim,sprtrim] then
		  begin {string-valued func}
		  getlocstorage(etyptr^.unpacksize,attr^);
		  emit1(pea,attr^);
		  end
		else
		  begin resultsize := etyptr^.unpacksize;
		  if odd(resultsize) then resultsize := resultsize+1;
		  with op do
		    begin addrmode := immediate; smallval := resultsize; end;
		  SPdir.storage := long;
		  emit2(subq,op,SPdir);
		  attr^.addrmode := topofstack;
		  getsignbit(etyptr,attr);
		  end;
		if spkey in [spposition,
		    spmaxpos,speoln,speof] then
		  pushaddress(actualp^.expptr)
		else pushparms(next,actualp);
		saveregs; forgetbaseregs;
		if (spkey=speoln)     or
		   (spkey=speof)      or
		   (spkey=spposition) or
		   (spkey=spmaxpos) then
		  callIOproc('FS_F' + namep^)
		else if (spkey = spstrpos) or
			(spkey = sppos) then
		  callstdproc('ASM_POS')
		else
		  case spkey of
		    spunitbusy:
		      callstdproc('UIO_UNITBUSY');
		    spstrrpt,spltrim,sprtrim,
		    spmemavail:
		      callstdproc('ASM_' + namep^);
		  end;
		reloadregs;
		end;
	      spstr,spcopy:
		begin
		getlocstorage(etyptr^.unpacksize,op);
		op.storage := long;
		emit1(pea,op);                         { PEA localtemp }
		attr^.addrmode := loconstack;
		attr^.access := indirect;
		SPminus.storage := long;
		emit2(move,SPind,SPminus);             { MOVE.L (SP),-(SP) }
		pushparms(next,actualp);
		saveregs; forgetbaseregs;
		callstdproc('ASM_SCOPY');
		reloadregs;
		end;
	      spconcat:
		begin
		getlocstorage(etyptr^.unpacksize,op);
		op.storage := bytte;
		emit1(clr,op);               { CLR.B  dest temp }
		op.storage := long;
		emit1(pea,op);               { PEA    dest temp }
		sexp := actualp;
		with op do
		  begin
		  addrmode := immediate;
		  smallval := etyptr^.unpacksize - 1;
		  end;
		repeat
		  SPminus.storage := bytte;
		  emit2(move,op,SPminus);
		  SPminus.storage := long;
		  SPind.offset := 2;
		  emit2(move,SPind,SPminus);
		  SPind.offset := 0;             { MOVE.L (SP),-(SP) }
		  pushaddress(sexp^.expptr);
		  saveregs; forgetbaseregs;
		  callstdproc('ASM_SAPPEND');
		  reloadregs;
		  sexp := sexp^.nextptr;
		  until sexp = NIL;
		attr^.addrmode := loconstack;
		attr^.access := indirect;
		end;
	      spesccode:
		with attr^ do
		  begin storage := wrd; addrmode := locinreg;
		  regnum := SB; offset := escapecodedisp;
		  signbit := true; indexed := false;
		  gloptr := sysglobalptr;
		  end;
	      spaddr:
		begin attr^.addrmode := topofstack;
		attr^.signbit := false;
		genaddr(fexp,NIL);
		end;
	      spscan:
		begin
		extend(actualp^.expptr,wrd);
		pushvalue(actualp^.expptr);    { 0 for until 1 for while }
		actualp := actualp^.nextptr;
		with actualp^ do
		  begin
		  source := expptr;
		  letter := nextptr^.expptr;
		  lngth := nextptr^.nextptr^.expptr;
		  end;
		pushaddress(source);
		extend(letter,bytte);
		pushvalue(letter);
		extend(lngth,long);
		pushvalue(lngth);
		saveregs; forgetbaseregs;
		callstdproc('ASM_SCAN');
		reloadregs;
		with attr^ do
		  begin
		  addrmode := topofstack; signbit := true; storage := long;
		  end;
		end;
	      spblockread, spblockwrite:
		with attr^ do
		  begin
		  storage:=long; signbit:=true; addrmode:=topofstack;
		  with op do
		    begin addrmode := immediate; smallval := 4; end;
		  SPdir.storage := long;
		  emit2(subq,op,SPdir);        { SUBQ.L #4,SP }
		  sexp := actualp; pushaddress(sexp^.expptr); {file}
		  sexp := sexp^.nextptr; pushaddress(sexp^.expptr); {buffer}
		  sexp := sexp^.nextptr; extend(sexp^.expptr, long);
		  pushvalue(sexp^.expptr);                     {# of blocks}
		  sexp := sexp^.nextptr; extend(sexp^.expptr, long);
		  pushvalue(sexp^.expptr);                     {block number}
		  with op do
		    begin
		    addrmode := immediate;
		    if spkey=spblockread
		      then smallval := 1
		      else smallval := 0;
		    end;
		  SPminus.storage := bytte;
		  emit2(move,op,SPminus);              { MOVE.B 1or0,-SP }
		  saveregs; forgetbaseregs;
		  callIOproc('FS_FBLOCKIO');
		  reloadregs;
		  end;
	      spsin,spcos,spsqrt,spln,spexp,sparctan:
		$IF MC68020$
		if (float = flt_test) then
		  begin
		  {Emit test for card present}
		  with op do
		    begin
		    storage := bytte;
		    addrmode := longabs;
		    offset := 0;
		    indexed := false;
		    absaddr.intval := false;
		    new(absaddr.valp);
		    with absaddr.valp^ do
		      begin
		      cclass := paofch;
		      slgth := strlen(float_flag);
		      for i := 1 to slgth do
			sval[i] := float_flag[i];
		      end;
		    end;
		  emit1(tst,op);                        {TST.B float_flag}
		  lbl1.next := NIL;
		  getbrattr(lbl1.pc,false,op);
		  emit1(bne,op);                         {BNE  card present code}

		  {Generate code for libraries}
		  float := flt_off;
		  genfcall(fexp);
		  at := fexp^.attr;
		  NIL_attributes(fexp);
		  fexp^.attr := at;

		  lbl2.next := NIL;
		  getbrattr(lbl2.pc,false,op);
		  emit1(bra,op);                        {BRA  convergence point}

		  {Generate code for card}
		  fixreflist(addr(lbl1));
		  float:= flt_on;
		  genfcall(fexp);
		  pushvalue(fexp);       {Result must be same place as library result}
		  fixreflist(addr(lbl2));               {Convergence point}
		  float := flt_test;
		  forgetbaseregs;
		  end
		else if (float = flt_on) then
		  realop(fexp)
		else
		$END$
		with attr^ do
		  begin
		  storage := multi;
		  addrmode := topofstack;
		  signbit := true;
		  pushvalue(actualp^.expptr);
		  saveregs; forgetbaseregs;
		  case spkey of
		    spsin: callstdproc('ASM_SIN');
		    spcos: callstdproc('ASM_COS');
		    spsqrt: callstdproc('ASM_SQRT');
		    spln:  callstdproc('ASM_LN');
		    spexp: callstdproc('ASM_EXP');
		    sparctan: callstdproc('ASM_ARCTAN');
		  end;
		  reloadregs;
		  end;
	      sphex,spoctal,spbinary:
		begin
		pushaddress(actualp^.expptr);
		saveregs; forgetbaseregs;
		case spkey of
		  sphex: callstdproc('ASM_HEX');
		  spoctal: callstdproc('ASM_OCTAL');
		  spbinary: callstdproc('ASM_BINARY');
		end;
		reloadregs;
		with attr^ do
		  begin
		  addrmode := topofstack;
		  signbit := true;
		  storage := long;
		  end;
		end;
	      otherwise escape(-8);
	      end; {case spkey}
	end; {genfcall}

      procedure unaryops(fexp: exptr);
	var
	  lsp: stp;
	  op: attrtype;
	  chkovfl: boolean;
	  lbl1,lbl2: localref;
	  at: attrptr;
	  i: shortint;
	begin
	if (float = flt_test) and (fexp^.etyptr^.form = reals) and
	   (fexp^.eclass in [negnode,absnode,sqrnode,floatnode,roundnode]) then
	  begin
	  {Emit test for card present}
	  with op do
	    begin
	    storage := bytte;
	    addrmode := longabs;
	    offset := 0;
	    indexed := false;
	    absaddr.intval := false;
	    new(absaddr.valp);
	    with absaddr.valp^ do
	      begin
	      cclass := paofch;
	      slgth := strlen(float_flag);
	      for i := 1 to slgth do
		sval[i] := float_flag[i];
	      end;
	    end;
	  emit1(tst,op);                        {TST.B float_flag}
	  lbl1.next := NIL;
	  getbrattr(lbl1.pc,false,op);
	  emit1(bne,op);                         {BNE  card present code}

	  {Generate code for libraries}
	  float := flt_off;
	  unaryops(fexp);
	  at := fexp^.attr;
	  forgetbaseregs;
	  NIL_attributes(fexp);
	  fexp^.attr := at;

	  lbl2.next := NIL;
	  getbrattr(lbl2.pc,false,op);
	  emit1(bra,op);                        {BRA  convergence point}

	  {Generate code for card}
	  fixreflist(addr(lbl1));
	  float:= flt_on;
	  realop(fexp);
	  pushvalue(fexp);       {Result must be save place as library result}
	  fixreflist(addr(lbl2));               {Convergence point}
	  float := flt_test;
	  forgetbaseregs;
	  end
	else with fexp^,attr^ do
	  begin lsp := opnd^.etyptr;
	  if (float = flt_on) and (etyptr^.form = reals) then {no op}
	  else if (etyptr^.form = reals) and (eclass=negnode) then pushvalue(opnd)
	  else if eclass in [negnode,notnode,oddnode] then loadvalue(opnd)
	  else genexpr(opnd);
	  case eclass of
	    negnode:
	      begin
	      if etyptr^.form = reals then
		if float = flt_on then realop(fexp)
		else
		  begin
		  op.addrmode := immediate;
		  op.smallval := 7;
		  emit2(bchg,op,SPind);                   { BCHG #7,(SP) }
		  liftattr(fexp,opnd);
		  storage := opnd^.attr^.storage; { copy storage too }
		  end
	      else
		begin
		if not opnd^.attr^.signbit then
		  extend(opnd,succ(opnd^.attr^.storage));
		emit1(neg,opnd^.attr^);                  { NEG.z Dregnum }
		liftattr(fexp,opnd);
		storage := opnd^.attr^.storage; { copy storage too }
		end;
	      end;
	    notnode:
	      begin
	      if opnd^.ekind = xpr then maskboolexpr(opnd);
	      liftattr(fexp,opnd);
	      emit2(bchg,immed0,attr^);                 { BCHG #0,Dregnum }
	      conditionis := beq;
	      end;
	    absnode:
	      begin
	      if etyptr^.form = reals then
		if float = flt_on then realop(fexp)
		else
		  begin
		  pushvalue(opnd);
		  SPind.storage := wrd;
		  emit1(tst,SPind);                       { TST.W (SP) }
		  with op do
		    begin offset := 4; storage := bytte end;
		  emit1(bge,op);                          { BGE.S *+6 }
		  op.smallval := 7;
		  emit2(bchg,op,SPind);                   { BCHG #7,(SP) }
		  liftattr(fexp,opnd);
		  storage := opnd^.attr^.storage;
		  end
	      else
		begin
		if opnd^.attr^.signbit then
		  with opnd^.attr^ do
		    begin
		    loadvalue(opnd);
		    chkovfl := true;
		    if storage <> long then
		      begin
		      extend(opnd,succ(storage));
		      chkovfl := false;
		      end;
		    with op do
		      begin offset := 2; storage := bytte end;
		    emit1(bge,op);                          { BGE *+4 }
		    emit1(neg,opnd^.attr^);                 { NEG.z Dregnum }
		    if chkovfl then ovflck;
		    end;
		liftattr(fexp,opnd);
		storage := opnd^.attr^.storage;
		end;
	      end;
	    ordnode:
	      begin
	      maskboolexpr(opnd);
	      liftattr(fexp,opnd);
	      storage := opnd^.attr^.storage;
	      end;
	    strlennode:
	      begin
	      liftattr(fexp,opnd);
	      storage := bytte;
	      signbit := false;
	      end;
	    strmaxnode:
	      begin liftattr(fexp,opnd);
	      access := direct;
	      storage := bytte;
	      offset := offset+4;
	      signbit := false;
	      end;
	    chrnode:
	      begin
	      if opnd^.attr^.addrmode <> immediate then
		begin
		if rangecheck then
		  emitcheck(opnd,char_ptr,true);
		extend(opnd,bytte);
		end;
	      liftattr(fexp,opnd);
	      signbit := false;
	      end; {chrnode}
	    oddnode:
	      begin liftattr(fexp,opnd); signbit := false;
	      op.addrmode := immediate; op.smallval := 1;
	      emit2(andd,op,attr^);
	      end;
	    sqrnode:
	      if etyptr^.form = reals then
		if float = flt_on then realop(fexp)
		else
		  begin pushvalue(opnd);
		  SPminus.storage := long;
		  SPind.offset := 4;
		  {now push a copy}
		  emit2(move,SPind,SPminus);              { MOVE.L 4(sp),-(sp) }
		  emit2(move,SPind,SPminus);              { MOVE.L 4(sp),-(sp) }
		  SPind.offset := 0; {restore}
		  saveregs; forgetbaseregs;
		  callstdproc('ASM_RMUL');
		  reloadregs;
		  addrmode := topofstack; storage := multi;
		  signbit := true;
		  end
	      else
		begin if opnd^.attr^.packd then makeaddressable(opnd);
		if opnd^.eclass = litnode then
		  fixliteral(opnd,wrd,true)
		else with opnd^.attr^ do
		  if (storage = wrd) and not signbit then extend(opnd,long);
		if opnd^.attr^.storage = long then
		  begin
		  $IF MC68020$
		    loadvalue(opnd);
		    emit2(muls,opnd^.attr^,opnd^.attr^);
		    ovflck;
		    liftattr(fexp,opnd);
		  $END$
		  $IF not MC68020$
		    pushvalue(opnd);
		    SPminus.storage := long;
		    emit2(move,SPind,SPminus);             { MOVE.L (SP),-(SP) }
		    saveregs; forgetbaseregs;
		    callstdproc('ASM_MPY');
		    reloadregs;
		    addrmode := topofstack;
		  $END$
		  storage := long; signbit := true;
		  end
		else
		  begin extend(opnd,wrd);
		  loadvalue(opnd);
		  emit2(muls,opnd^.attr^,opnd^.attr^);   { MULS Dr,Dr }
		  liftattr(fexp,opnd);
		  storage := long;
		  end;
		end;
	    roundnode,truncnode: { no support on float card }
	      begin
	      pushvalue(opnd);
	      saveregs; forgetbaseregs;
	      case eclass of
		roundnode: callstdproc('ASM_ROUND');
		truncnode: callstdproc('ASM_TRUNC');
	      end;
	      storage := long;
	      reloadregs;
	      addrmode := topofstack;
	      signbit := true;
	      end; {roundnode, truncnode}
	    floatnode:
	      if float = flt_on then realop(fexp)
	      else
		begin
		extend(opnd,long);
		pushvalue(opnd);
		saveregs; forgetbaseregs;
		if opnd^.etyptr^.form = reals then
		  liftattr(fexp,opnd)
		else
		  callstdproc('ASM_FLOAT');
		storage := multi;
		reloadregs;
		signbit := true;
		addrmode := topofstack;
		end;
	    end; {case eclass}
	  end; {with fexp^}
	end; {unaryops}

      procedure realrelCMP ( fexp : exptr );
	begin
	with fexp^, attr^ do
	  begin
	  pushvalue(opnd2); pushvalue(opnd1);
	  saveregs; forgetbaseregs;
	  case eclass of
	    eqnode: callstdproc('ASM_EQ');
	    nenode: callstdproc('ASM_NE');
	    gtnode: callstdproc('ASM_GT');
	    genode: callstdproc('ASM_GE');
	    ltnode: callstdproc('ASM_LT');
	    lenode: callstdproc('ASM_LE');
	    end; { case }
	  reloadregs;
	  addrmode := topofstack;
	  end; { with }
	end; { realrelCMP }

      procedure relxpr(fexp: exptr);
	{ code gen for relational node when a boolean result
	  is required }
	var
	  destonleft,signed: boolean;
	begin
	if fexp^.opnd1^.etyptr^.form = reals then realrelCMP(fexp)
	else
	  begin relCMP(fexp,destonleft,signed);
	  getregattr(D,fexp^.attr^);
	  fexp^.attr^.storage := bytte;
	  if destonleft then
	    case fexp^.eclass of
	      eqnode:
		begin
		emit1(seq,fexp^.attr^);
		conditionis := beq;
		end;
	      nenode:
		begin
		emit1(sne,fexp^.attr^);
		conditionis := bne;
		end;
	      ltnode:
		if signed then
		  begin
		  emit1(slt,fexp^.attr^);
		  conditionis := blt;
		  end
		else
		  begin
		  emit1(scs,fexp^.attr^);
		  conditionis := bcs;
		  end;
	      lenode:
		if signed then
		  begin
		  emit1(sle,fexp^.attr^);
		  conditionis := ble;
		  end
		else
		  begin
		  emit1(sls,fexp^.attr^);
		  conditionis := bls;
		  end;
	      gtnode:
		if signed then
		  begin
		  emit1(sgt,fexp^.attr^);
		  conditionis := bgt;
		  end
		else
		  begin
		  emit1(shi,fexp^.attr^);
		  conditionis := bhi;
		  end;
	      genode:
		if signed then
		  begin
		  emit1(sge,fexp^.attr^);
		  conditionis := bge;
		  end
		else
		  begin
		  emit1(scc,fexp^.attr^);
		  conditionis := bcc;
		  end;
	      end
	  else
	    case fexp^.eclass of
	      eqnode:
		begin
		emit1(seq,fexp^.attr^);
		conditionis := beq;
		end;
	      nenode:
		begin
		emit1(sne,fexp^.attr^);
		conditionis := bne;
		end;
	      ltnode:
		if signed then
		  begin
		  emit1(sgt,fexp^.attr^);
		  conditionis := bgt;
		  end
		else
		  begin
		  emit1(shi,fexp^.attr^);
		  conditionis := bhi;
		  end;
	      lenode:
		if signed then
		  begin
		  emit1(sge,fexp^.attr^);
		  conditionis := bge;
		  end
		else
		  begin
		  emit1(scc,fexp^.attr^);
		  conditionis := bcc;
		  end;
	      gtnode:
		if signed then
		  begin
		  emit1(slt,fexp^.attr^);
		  conditionis := blt;
		  end
		else
		  begin
		  emit1(scs,fexp^.attr^);
		  conditionis := bcs;
		  end;
	      genode:
		if signed then
		  begin
		  emit1(sle,fexp^.attr^);
		  conditionis := ble;
		  end
		else
		  begin
		  emit1(sls,fexp^.attr^);
		  conditionis := bls;
		  end;
	      end;
	  end; { if }
	end; {relxpr}

      procedure relpaofchxpr(fexp: exptr);
	{ generate a boolean result for a packed array of char relation}
	var
	  flbl: reflistptr;
	  op,r: attrtype;
	begin
	  getregattr(D,r);
	  new(flbl); flbl^.next := NIL;
	  genpaofchcond(fexp,flbl,false); {forward branch}
	  { if true then }
	  op.smallval := 1;
	  emit2(moveq,op,r);                            { MOVEQ #1,Dr }
	  with op do
	    begin offset := 2; storage := bytte end;
	  emit1(bra,op);                                { BRA.S *+4 }
	  { if false then }
	  fixreflist(flbl);                           { flbl EQU * }
	  r.storage := long;
	  emit1(clr,r);                                 { CLR.L Dr }
	  with fexp^.attr^ do
	    begin addrmode := inDreg; regnum := r.regnum end;
	end; { relpaofchxpr }

procedure powerof2(elsize:integer; var power:shortint);
  var i: shortint;
  begin
  power := 0;
  for i := 1 to bitsperword-2 do
    if elsize = power_table[i] then power := i;
  end;

procedure alops(fexp: exptr);
  { +,-,*,div,mod,and,or }
  type
    opindextype = (tos,mem,reg,slowlit,fastlit,quicklit,zilchlit);
    optype = array[addnode..andnode] of opcodetype;
  const
    op = optype
	[add,sub,
	 muls,divs,swap,divs, {dummies - only add,sub,andd,orr are needed}
	 orr,andd];
  var
    lopindex,ropindex: opindextype;
    lsigned,rsigned: boolean;
    lstorage,rstorage: stortype;
    lmode,rmode: addrtype;

  procedure genrealop;
    var
      op: attrtype;
      lbl1,lbl2: localref;
      at: attrptr;
      i: shortint;
    {real + - * /}
    begin
    if float = flt_test then
      begin
      {Emit test for card present}
      with op do
	begin
	storage := bytte;
	addrmode := longabs;
	offset := 0;
	indexed := false;
	absaddr.intval := false;
	new(absaddr.valp);
	with absaddr.valp^ do
	  begin
	  cclass := paofch;
	  slgth := strlen(float_flag);
	  for i := 1 to slgth do
	    sval[i] := float_flag[i];
	  end;
	end;
      emit1(tst,op);                        {TST.B float_flag}
      lbl1.next := NIL;
      getbrattr(lbl1.pc,false,op);
      emit1(bne,op);                         {BNE  card present code}

      {Generate code for libraries}
      float := flt_off;
      genrealop;
      at := fexp^.attr;
      NIL_attributes(fexp);
      fexp^.attr := at;

      lbl2.next := NIL;
      getbrattr(lbl2.pc,false,op);
      emit1(bra,op);                        {BRA  convergence point}

      {Generate code for card}
      fixreflist(addr(lbl1));
      float:= flt_on;
      realop(fexp);
      pushvalue(fexp);       {Result must be save place as library result}
      fixreflist(addr(lbl2));               {Convergence point}
      float := flt_test;
      forgetbaseregs;
      end
    else if float = flt_on then realop(fexp)
    else with fexp^,attr^ do
      begin
      pushvalue(opnd2); pushvalue(opnd1);
      saveregs; forgetbaseregs;
      case eclass of
	addnode: callstdproc('ASM_RADD');
	subnode: callstdproc('ASM_RSUB');
	mulnode: callstdproc('ASM_RMUL');
	divnode: callstdproc('ASM_RDIV');
	end; { case }
      reloadregs;
      addrmode := topofstack;
      storage := multi;
      signbit := true;
      end; {with}
    end;

  procedure genmulop;
    {code gen for *, DIV, MOD}
    var
      op: attrtype;
      patchloc: addrrange;
      res: shortint;
    begin
    with fexp^ do
      if eclass = mulnode then
	begin makeaddressable(opnd2);
	with opnd2^.attr^ do
	  begin
	  if addrmode = immediate then fixliteral(opnd2,wrd,true)
	  else if not signbit and (storage = wrd) then
	    extend(opnd2,long);
	  if storage = long then pushvalue(opnd2);
	  end;
	makeaddressable(opnd1);
	if opnd1^.attr^.addrmode = immediate then
	  fixliteral(opnd1,wrd,true);
	if (opnd1^.attr^.storage = long)
	    or (opnd2^.attr^.storage = long)
	    or (opnd1^.attr^.storage = wrd)
	    and not opnd1^.attr^.signbit then
	  begin
	  with opnd2^.attr^ do
	    if storage <> long then
	      begin
	      if addrmode = immediate then
		begin storage := long; signbit := true end
	      else checkstackandextend(opnd1,opnd2,long);
	      pushvalue(opnd2);
	      end;
	  with opnd1^.attr^ do
	    if storage <> long then
	      if addrmode = immediate then
		begin storage := long; signbit := true end
	      else extend(opnd1,long);
	  pushvalue(opnd1);
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_MPY');
	  reloadregs;
	  with attr^ do
	    begin addrmode := topofstack;
	    storage := long; signbit := true;
	    end;
	  end
	else
	  begin {in-line MPY}
	  extend(opnd1,wrd);
	  checkstackandextend(opnd1,opnd2,wrd);
	  if opnd2^.attr^.addrmode = inDreg then
	    begin
	    emit2(muls,opnd1^.attr^,opnd2^.attr^);{ MULS op1,Dop2 }
	    liftattr(fexp,opnd2);
	    freeregs(opnd1^.attr);
	    end
	  else
	    begin
	    loadvalue(opnd1);
	    emit2(muls,opnd2^.attr^,opnd1^.attr^);      { MULS op2,Dop1 }
	    liftattr(fexp,opnd1);
	    freeregs(opnd2^.attr);
	    end;
	  attr^.storage := long;
	  end;
	etyptr := intptr;
	end
      else
	begin {DIV or MOD}
	makeaddressable(opnd1);
	if opnd2^.eclass = litnode then
	  powerof2(opnd2^.litval.ival,res)
	else res := 0;
	if (eclass = modnode) and (res <> 0) then
	  begin
	  opnd2^.litval.ival := opnd2^.litval.ival - 1;
	  loadvalue(opnd1);
	  genexpr(opnd2);
	  fixliteral(opnd2,opnd1^.attr^.storage,true);
	  extend(opnd1,opnd2^.attr^.storage);
	  emit2(andi,opnd2^.attr^,opnd1^.attr^);
	  liftattr(fexp,opnd1);
	  attr^.storage := opnd1^.attr^.storage;
	  opnd2^.litval.ival := opnd2^.litval.ival + 1; { undo damage }
	  end
	else
	  begin
	  with opnd1^.attr^ do
	    begin
	    if addrmode = immediate then
	      fixliteral(opnd1,wrd,true)
	      else if not signbit and (storage = wrd) then
		extend(opnd1,long);
	    if storage = long then
	      $IF not MC68020$
	      pushvalue(opnd1)
	      $END$
	    else
	      if ((opnd2^.eclass = fcallnode) and
		  (opnd2^.etyptr^.unpacksize = 4{bytes})) or
		  (opnd2^.ekind = xpr) then
		begin
		extend(opnd1,long);
		$IF not MC68020$
		pushvalue(opnd1)
		$END$
		end;
	    end;
	  $IF MC68020$
	  loadvalue(opnd1);
	  $END$
	  makeaddressable(opnd2);
	  with opnd2^.attr^ do
	    begin
	    if addrmode = immediate then fixliteral(opnd2,wrd,true)
	    else if not signbit and (storage = wrd) then
	      extend(opnd2,long);
	    if (storage = long) or (opnd1^.attr^.storage = long) then
	      begin
	      $IF not MC68020$
	      extend(opnd1,long);
	      pushvalue(opnd1);
	      extend(opnd2,long);
	      pushvalue(opnd2);
	      saveregs; forgetbaseregs;
	      if eclass = divnode then
		callstdproc('ASM_DIV')
	      else callstdproc('ASM_MOD');
	      reloadregs;
	      with attr^ do
		begin addrmode := topofstack;
		storage := long; signbit := true;
		end;
	      $END$

	      $IF MC68020$
	      extend(opnd1,long);
	      loadvalue(opnd1);
	      extend(opnd2,long);

	      if RANGECHECK and (eclass = modnode) and
		 (opnd2^.eclass <> litnode) then
		begin
		loadvalue(opnd2);
		with op do
		  begin
		  addrmode := immediate;
		  smallval := maxint;
		  end;
		emit2(chk,op,opnd2^.attr^);
		end;

	      if eclass = divnode then
		begin
		emit2(divs,opnd2^.attr^,opnd1^.attr^);
		liftattr(fexp,opnd1);
		with attr^ do
		  begin
		  storage := long;
		  signbit := true;
		  end;
		ovflck;
		end
	      else
		begin
		divsl_reg := getreg(D);
		emit2(divsl,opnd2^.attr^,opnd1^.attr^);
		liftattr(fexp,opnd1);
		with attr^ do
		  begin
		  freeit(D,regnum);
		  regnum := divsl_reg;
		  storage := long;
		  signbit := true;
		  end;
		if  (opnd1^.eclass <> litnode) or
		   ((opnd1^.eclass = litnode) and
		    (opnd1^.litval.ival < 0)) then
		  begin
		  emit1(tst,attr^);
		  patchloc := codephile.bytecount + 2;
		  op.offset := 0;
		  op.storage := bytte;
		  emit1(bge,op);
		  emit2(add,opnd2^.attr^,attr^);
		  fixbyte(patchloc - 1, codephile.bytecount - patchloc);
		  end;
		freeregs(opnd2^.attr);
		end;
	      $END$
	      etyptr := intptr;
	      end
	    else
	      begin {in-line div or mod}
	      with opnd1^.attr^ do
		if addrmode = immediate then
		  begin storage := long; signbit := true; end
		else if (addrmode = topofstack) and
			(opnd2^.attr^.addrmode = topofstack) then
		  loadvalue(opnd2);
	      loadvalue(opnd1);
	      extend(opnd1,long);
	      extend(opnd2,wrd);
	      if RANGECHECK and (eclass = modnode) and
		 (opnd2^.eclass <> litnode) then
		begin
		loadvalue(opnd2);
		with op do
		  begin
		  addrmode := immediate;
		  smallval := 32767;
		  end;
		emit2(chk,op,opnd2^.attr^);
		end;
	      opnd1^.attr^.storage := wrd;
	      emit2(divs,opnd2^.attr^,opnd1^.attr^);      { DIVS op2,Dop1 }
	      liftattr(fexp,opnd1);
	      with attr^ do
		begin storage := wrd; signbit := true;
		if eclass = modnode then
		  begin
		  emit1(swap,attr^);
		  if (opnd1^.eclass <> litnode) or
		    ((opnd1^.eclass = litnode) and
		     (opnd1^.litval.ival < 0)) then
		    begin
		    emit1(tst,attr^);
		    patchloc := codephile.bytecount + 2;
		    op.offset := 0;
		    op.storage := bytte;
		    emit1(bge,op);
		    emit2(add,opnd2^.attr^,attr^);
		    fixbyte(patchloc-1,codephile.bytecount - patchloc);
		    end;
		  end
		else ovflck;
		end;
	      etyptr := shortintptr;
	      freeregs(opnd2^.attr);
	      end; {in-line div or mod}
	    end; {with opnd2^.attr^}
	  end;
	end; {div or mod}
    end; {genmulop}

  procedure genshft;
    var
      op: attrtype;
      temp: shortint;
      patchloc: addrrange;
      ovflpossible: boolean;
    begin
    with fexp^ do
      begin
      if opnd2^.litval.ival > 0 then { multiply }
	begin
	ovflpossible := false;
	makeaddressable(opnd1);
	if opnd1^.attr^.storage <> long then
	  if opnd2^.litval.ival >= 8 then extend(opnd1,long)
	  else extend(opnd1,succ(opnd1^.attr^.storage))
	else ovflpossible := true;
	loadvalue(opnd1);
	emitshift(opnd2^.litval.ival,
		  opnd1^.attr^.regnum,asl,
		  opnd1^.attr^.storage);
	if ovflpossible then ovflck;
	end
      else { divide }
	begin
	loadvalue(opnd1);
	if opnd1^.attr^.signbit then
	  begin
	  patchloc := codephile.bytecount + 2;
	  op.offset := 0; op.storage := bytte;
	  emit1(bge,op);
	  op.smallval := 1;
	  for temp := 1 to -opnd2^.litval.ival do
	    op.smallval := op.smallval * 2;
	  op.smallval := op.smallval - 1;
	  op.addrmode := immediate;
	  emit2(add,op,opnd1^.attr^); { ADD #fudge,opnd }
	  fixbyte(patchloc-1,codephile.bytecount - patchloc);
	  with opnd1^.attr^ do
	    emitshift(-opnd2^.litval.ival,
		      regnum,asr,storage);
	  end
	else
	  with opnd1^.attr^ do
	    emitshift(-opnd2^.litval.ival,
		      regnum,lsr,storage);
	end;
      liftattr(fexp,opnd1);
      {fexp^}attr^.storage := opnd1^.attr^.storage;
      if attr^.storage = long then etyptr := intptr
      else etyptr := shortintptr;
      end;
    end;

  procedure genandor;
    var
      truelist,falselist: reflistptr;
    begin
      if shortcircuit then
	begin
	truelist := NIL;
	falselist := NIL;
	with fexp^.attr^ do
	  begin
	  addrmode := inDreg;
	  regnum := getreg(D);
	  storage := bytte;
	  end;
	if fexp^.eclass = andnode then
	  genshortand(fexp,truelist,falselist,true,false,true,fexp^.attr)
	else { fexp^.eclass = ornode }
	  genshortor(fexp,truelist,falselist,true,false,true,fexp^.attr);
	fixreflist(truelist);
	fixreflist(falselist);
	forgetbaseregs;
	end
      else
	with fexp^, attr^ do
	  begin
	  if opnd1^.num_ops >= opnd2^.num_ops then
	    begin makeaddressable(opnd1); makeaddressable(opnd2); end
	  else
	    begin makeaddressable(opnd2); makeaddressable(opnd1); end;
	  if opnd2^.attr^.addrmode = inDreg then
	    begin
	    opnd2^.attr^.storage := bytte;
	    liftattr(fexp,opnd2);
	    emit2(op[eclass],opnd1^.attr^,opnd2^.attr^);
	    freeregs(opnd1^.attr);
	    end
	  else
	    begin
	    loadvalue(opnd1);
	    opnd1^.attr^.storage := bytte;
	    liftattr(fexp,opnd1);
	    emit2(op[eclass],opnd2^.attr^,opnd1^.attr^);
	    freeregs(opnd2^.attr);
	    end;
	  end;
    end; { genandor }

  function getopindex(attr: attrptr): opindextype;
    begin
    with attr^ do
      case addrmode of
	topofstack:               getopindex := tos;
	locinreg,shortabs,
	namedconst,
	longabs,prel:             getopindex := mem;
	inDreg:                   getopindex := reg;
	immediate:
	  if smallval = 0 then getopindex := zilchlit
	  else if (smallval >= 1) and (smallval <= 8) then
	    getopindex := quicklit
	  else if (smallval >= -128) and (smallval <= 127) then
	    getopindex := fastlit
	  else getopindex := slowlit;
	end; {case}
    end; {getopindex}

  procedure couldbequick(fexp: exptr);
    { case 1: fexp is addnode or subnode and opnd2 is a litnode.
	      If opnd2^.litval is in [-8..-1] then flip its sign
	      and change fexp from addnode to subnode or vice versa.
      case 2: fexp is addnode and opnd1 is a litnode.
	      If opnd1^.litval is in [-8..-1] then flip its sign,
	      change fexp to subnode, and exchange opnd1 and opnd2 }
    var
      exptemp: exptr;

    function quickexceptforsign(fattr: attrptr): boolean;
      begin
      with fattr^ do
	quickexceptforsign := (addrmode = immediate)
		  and (smallval >= -8) and (smallval <= -1);
      end;

    begin {couldbequick}
    with fexp^ do
      begin
      if quickexceptforsign(opnd2^.attr) then
	begin
	with opnd2^.attr^ do smallval := -smallval;
	if eclass = addnode then eclass := subnode
	else eclass := addnode;
	end;
      if eclass = addnode then
	if quickexceptforsign(opnd1^.attr) then
	  begin
	  with opnd1^.attr^ do smallval := -smallval;
	  eclass := subnode;
	  exptemp := opnd1;
	  opnd1 := opnd2;
	  opnd2 := exptemp;
	  end;
      end;
    end; {couldbequick}

  begin {alops}
  with fexp^,attr^ do
    if etyptr = realptr then genrealop
    $IF MC68020$
    else if eclass in [divnode,modnode] then genmulop
    $END$
    $IF not MC68020$
    else if eclass in [mulnode,divnode,modnode] then genmulop
    $END$
    else if eclass = shftnode then genshft
    else if eclass in [andnode,ornode] then genandor
    else { integer ADD,SUB and MUL for 68020 }
      begin
      if opnd1^.ekind > opnd2^.ekind then
	begin makeaddressable(opnd1); makeaddressable(opnd2) end
      else begin makeaddressable(opnd2); makeaddressable(opnd1) end;
      with opnd1^.attr^ do
	begin lmode := addrmode;
	lstorage := storage; lsigned := signbit;
	end;
      with opnd2^.attr^ do
	begin rmode := addrmode;
	rstorage := storage; rsigned := signbit;
	end;
      if lmode = immediate then
	begin
	if (rstorage = long) or (rstorage = wrd) and not rsigned
	  then fixliteral(opnd1,long,true)
	else fixliteral(opnd1,wrd,true);
	with opnd1^.attr^ do
	  begin lstorage := storage; lsigned := signbit end;
	end
      else if rmode = immediate then
	begin
	if (lstorage = long) or (lstorage = wrd) and not lsigned then
	  fixliteral(opnd2,long,true)
	else fixliteral(opnd2,wrd,true);
	with opnd2^.attr^ do
	  begin rstorage := storage; rsigned := signbit end;
	end;
      if (lstorage = long) or (rstorage = long)
	  or (lstorage = wrd) and not lsigned
	  or (rstorage = wrd) and not rsigned then
	begin extend(opnd1,long);
	checkstackandextend(opnd1,opnd2,long);
	storage := long;
	etyptr := intptr;
	end
      else
	begin extend(opnd1,wrd);
	checkstackandextend(opnd1,opnd2,wrd);
	storage := wrd;
	etyptr := shortintptr;
	end;
      $IF MC68020$
	if not (eclass = mulnode) then
      $END$
      couldbequick(fexp);
      lopindex := getopindex(opnd1^.attr);
      ropindex := getopindex(opnd2^.attr);
      case ord(lopindex)*10+ord(ropindex) of
	00, {stack op stack}
	01, {stack op mem}
	10, {mem op stack}
	11, {mem op mem}
	13, {mem op slowlit}
	15, {mem op quicklit}
	31, {slowlit op mem}
	40, {fastlit op stack}
	41, {fastlit op mem}
	42, {fastlit op reg}
	51: {quicklit op mem}
	   begin loadvalue(opnd1); liftattr(fexp,opnd1);
	   emit2(op[eclass],opnd2^.attr^,opnd1^.attr^);
	   freeregs(opnd2^.attr);
	   ovflck;
	   end;
	02, {stack op reg}
	04: {stack op fastlit}
	   begin if ropindex = fastlit then loadvalue(opnd2);
	   if eclass = addnode then
	     begin liftattr(fexp,opnd2);
	     emit2(add,opnd1^.attr^,opnd2^.attr^);{ ADD.z (SP)+,Dop2 }
	     end
	   else if eclass = subnode then
	     begin SPind.storage := storage;
	     liftattr(fexp,opnd1);
	     emit2(sub,opnd2^.attr^,SPind);        { SUB.z Dop1,(SP) }
	     freeregs(opnd2^.attr);
	     end
	   $IF MC68020$
	   else if eclass = mulnode then
	     begin
	     liftattr(fexp,opnd2);
	     emit2(muls,opnd1^.attr^,opnd2^.attr^);{ MUL.z (SP)+,Dop2 }
	     end
	   $END$;
	   ovflck;
	   end;
	03, {stack op slowlit}
	05, {stack op quicklit}
	20, {reg op stack}
	21, {reg op mem}
	22, {reg op reg}
	23, {reg op slowlit}
	25: {reg op quicklit}
	   begin liftattr(fexp,opnd1);
	   if lopindex <> tos then
	     emit2(op[eclass],opnd2^.attr^,opnd1^.attr^)
	   else
	   $IF MC68020$
	     if eclass = mulnode then
	       begin
	       loadvalue(opnd1);
	       liftattr(fexp,opnd1);
	       emit2(muls,opnd2^.attr^,opnd1^.attr^);
	       end
	     else
	   $END$
	     begin SPind.storage := storage;
	     emit2(op[eclass],opnd2^.attr^,SPind);
	     end;
	   freeregs(opnd2^.attr);
	   ovflck;
	   end;
	06,16,26,36,46,56,66: {opnd2 is zero}
	   begin
	   $IF MC68020$
	   if eclass = mulnode then
	     liftattr(fexp,opnd2)
	   else
	   $END$
	     liftattr(fexp,opnd1);
	   end;
	12, {mem op reg}
	30, {slowlit op stack}
	32, {slowlit op reg}
	50, {quicklit op stack}
	52: {quicklit op reg}
	   begin
	   if eclass = addnode then
	     begin liftattr(fexp,opnd2);
	     if ropindex = tos then
	       begin SPind.storage := storage;
	       emit2(add,opnd1^.attr^,SPind);
	       end
	     else emit2(add,opnd1^.attr^,opnd2^.attr^);
	     freeregs(opnd1^.attr);
	     end
	   else if eclass = subnode then
	     begin loadvalue(opnd1); liftattr(fexp,opnd1);
	     emit2(sub,opnd2^.attr^,opnd1^.attr^);
	     freeregs(opnd2^.attr);
	     end
	   $IF MC68020$
	   else {mulnode}
	     begin
	     loadvalue(opnd2);
	     liftattr(fexp,opnd2);
	     emit2(muls,opnd1^.attr^,opnd2^.attr^);
	     freeregs(opnd1^.attr);
	     end
	   $END$;
	   ovflck;
	   end;
	14: {mem op fastlit}
	   begin loadvalue(opnd2); liftattr(fexp,opnd2);
	   emit2(op[eclass],opnd1^.attr^,opnd2^.attr^);
	   freeregs(opnd1^.attr);
	   ovflck;
	   if eclass = subnode then
	     begin
	     emit1(neg,attr^);
	     ovflck;
	     end;
	   end;
	24: {reg op fastlit}
	   begin loadvalue(opnd2); liftattr(fexp,opnd1);
	   emit2(op[eclass],opnd2^.attr^,opnd1^.attr^);
	   freeregs(opnd2^.attr);
	   ovflck;
	   end;
	60,61,62,63,64,65: {opnd1 is zilchlit}
	   begin
	   if eclass = subnode then
	     begin
	     if ropindex = mem then loadvalue(opnd2);
	     if ropindex <> tos then emit1(neg,opnd2^.attr^)
	     else
	       begin
	       SPind.storage := storage;
	       emit1(neg,SPind);
	       end;
	     ovflck;
	     end;
	   $IF MC68020$
	   if eclass = mulnode then
	     liftattr(fexp,opnd1)
	   else
	   $END$
	     liftattr(fexp,opnd2);
	   end;
      end; {case}
      $IF MC68020$
      if eclass = mulnode then
	storage := long;
      $END$
      end; { integer ADD or SUB or MUL for 68020}
  end; {alops}

procedure combineoffsets(fattr: attrptr; fsize: addrrange);
  { for fattr^, attempt to set PACKD to false by consolidating
    bit offset and offset information.
    Fsize is unpacksize of type associated with fattr }
  begin
  with fattr^ do
    begin
    offset := offset + mydiv(bitoffset.static,16) * 2;
    bitoffset.static := (bitoffset.static mod 16);
    if (bitoffset.static = 8) and (bitsize = 8) then
      begin offset := offset + 1;
      bitoffset.static := 0;
      end;
    if ((bitoffset.static = 0) and (bitoffset.variable = -1)) and
	(fsize = bitsize div bitsperaddr)
      then packd := false;
    end;
  end;

procedure genrecsel ( fexp,frecptr : exptr; ffldptr : ctp);
  { fexp^ is a selection node.
    frecptr^ is the node of the record selected into.
    ffldptr is the field id pointer. }
  begin
    with fexp^, attr^, ffldptr^ do
      begin genexpr(frecptr); { obtain address info for base of record }
      if (fldaddr <> 0) or fispackd then
	begin
	if frecptr^.attr^.access = indirect then
	  loadaddress(frecptr,false);
	liftattr(fexp,frecptr);
	getsignbit(etyptr,attr);
	offset := offset + fldaddr;
	if fispackd then
	  begin packd := true;
	  bitsize := idtype^.bitsize;
	  signbit := idtype^.signbit;
	  bitoffset.static := bitoffset.static + fldfbit;
	  combineoffsets(attr,idtype^.unpacksize);
	  end;
	end
      else
	begin {unpacked, offset=0}
	liftattr(fexp,frecptr);
	getsignbit(idtype,attr);
	end;
      end; {with}
  end; {genrecsel}

procedure gensubscr(fexp : exptr);
  var
    arraytype : stp; arrayattr : attrptr;
    lobound,hibound,
    temp : integer;
    elementsize : addrrange;
    op,xop : attrtype;

    $IF MC68020$
    type
      two_to_the_type = array[0..3] of 1..8;
    const
      two_to_the = two_to_the_type[1,2,4,8];
    $END$

  procedure cnf_subscr;
    var
      lobound_attr,
      hibound_attr,
      cnfsize_attr,
      op1,op2: attrtype;
      lbl: localref;
      savelink: attrptr;

  begin
  with fexp^ do
    begin
    if arrayattr^.access = indirect then
      loadaddress(arayp,false);
    liftattr(fexp,arayp);
    getsignbit(etyptr,attr);
    makeaddressable(indxp);
    maskboolexpr(indxp);
    if indxp^.attr^.storage = bytte then
      extend(indxp,wrd);
    if (indxp^.attr^.storage = wrd) and not (indxp^.attr^.signbit) then
      extend(indxp,long);
    loadvalue(indxp);
    {Subtract lower bound}
    with lobound_attr do
      begin
      addrmode := locinreg;
      regnum := getbasereg(arraytype^.cnf_index^.loboundid^.vlev);
      offset := arraytype^.cnf_index^.loboundid^.vaddr;
      indexed := false;
      gloptr := NIL;
      case arraytype^.inxtype^.unpacksize of
	1: storage := bytte;
	2: storage := wrd;
	4: storage := long;
      end;
      if ord(indxp^.attr^.storage) < ord(storage) then
	extend(indxp,storage);
      end; { with lobound_attr }
    if RANGECHECK then
      begin
      with hibound_attr do
	begin
	addrmode := locinreg;
	regnum := lobound_attr.regnum; { loboundid and hiboundid
					 are at the same level }
	offset := arraytype^.cnf_index^.hiboundid^.vaddr;
	indexed := false;
	gloptr := NIL;
	storage := lobound_attr.storage;
      { less than or equal to upper bound ? }
	if ord(storage) < ord(indxp^.attr^.storage) then
	  begin
	  if (storage = bytte) then
	    begin
	    with op1 do
	      begin
	      addrmode := inDreg;
	      regnum := getreg(D);
	      storage := long;
	      end;
	    emit1(clr,op1);
	    op1.storage := bytte;
	    emit2(move,hibound_attr,op1);
	    op1.storage := indxp^.attr^.storage;
	    end
	  else {storage = wrd}
	    begin
	    with op1 do
	      begin
	      addrmode := inDreg; regnum := getreg(D);
	      storage := wrd;
	      end;
	    emit2(move,hibound_attr,op1);
	    op1.storage := long;
	    emit1(ext,op1);
	    end;
	  end
	else
	  op1 := hibound_attr;
	emit2(cmp,op1,indxp^.attr^);
	if op1.addrmode = inDreg then
	  freeit(D,op1.regnum);
	lbl.next := NIL;
	getbrattr(lbl.pc,false,op1);
	emit1(bgt,op1);
	end;
      end; { with hibound_attr }
    with lobound_attr do
      begin
      if ord(storage) < ord(indxp^.attr^.storage) then
	begin
	if (storage = bytte) then
	  begin
	  with op1 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := long;
	    end;
	  emit1(clr,op1);
	  op1.storage := bytte;
	  emit2(move,lobound_attr,op1);
	  op1.storage := indxp^.attr^.storage;
	  end
	else {storage = wrd}
	  begin
	  with op1 do
	    begin
	    addrmode := inDreg; regnum := getreg(D);
	    storage := wrd;
	    end;
	  emit2(move,lobound_attr,op1);
	  op1.storage := long;
	  emit1(ext,op1);
	  end
	end
      else
	op1 := lobound_attr;
      emit2(sub,op1,indxp^.attr^);
      if op1.addrmode = inDreg then
	freeit(D,op1.regnum);
      end; {with lobound_attr}
    if RANGECHECK then
      { greater than or equal to lower bound ? }
      with op1 do
	begin
	offset := 2;
	storage := bytte;
	emit1(bge,op1);
	fixreflist(addr(lbl));
	op1.smallval := 7;
	emit1(trap,op1);              { TRAP #7 }
	end;
    {multiply by size}
    cnfsize_attr := lobound_attr;
    cnfsize_attr.offset := arraytype^.cnf_index^.hiboundid^.vaddr;
    with cnfsize_attr do
      begin
      case arraytype^.inxtype^.unpacksize of
	1: begin
	   storage := bytte;
	   offset := offset + 2;
	   end;
	2: begin
	   storage := wrd;
	   offset := offset + 2;
	   end;
	4: begin
	   storage := long;
	   offset := offset + 4;
	   end;
      end;
      if storage <> indxp^.attr^.storage then
	begin
	if storage = bytte then
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg; regnum := getreg(D);
	    storage := long;
	    end;
	  emit1(clr,op2);
	  op2.storage := bytte;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := op1.storage;
	  end
	else {storage = wrd}
	  begin
	  with op2 do
	    begin
	    addrmode := inDreg;
	    regnum := getreg(D);
	    storage := wrd;
	    end;
	  emit2(move,cnfsize_attr,op2);
	  op2.storage := long;
	  emit1(ext,op2);
	  end
	end
      else
	op2 := cnfsize_attr;
      end; {with cnfsize_attr}
    freeregs(addr(lobound_attr));
    if op2.storage = long then {call routine}
      begin

      $IF MC68020$
      emit2(muls,op2,indxp^.attr^);
      ovflck;
      if op2.addrmode = inDreg then
	freeit(D,op2.regnum);
      $END$

      $IF not MC68020$
      SPminus.storage := long;
      emit2(move,indxp^.attr^,SPminus);
      freeregs(indxp^.attr);
      emit2(move,op2,SPminus);
      if op2.addrmode = inDreg then
	freeit(D,op2.regnum);
      saveregs;
      forgetbaseregs;
      callstdproc('ASM_MPY');
      reloadregs;
      indxp^.attr^.addrmode := topofstack;
      $END$

      end
    else {in line multiply}
      begin
      emit2(muls,op2,indxp^.attr^);
      indxp^.attr^.storage := long;
      if op2.addrmode = inDreg then
	freeit(D,op2.regnum);
      end;
    if (arraytype^.aispackd) then
      begin
      if indxp^.attr^.addrmode <> inDreg then
	loadvalue(indxp);
      with fexp^.attr^ do
	begin
	packd := true;
	bitoffset.variable := indxp^.attr^.regnum;
	bitoffset.static := 0;
	bitoffset.storage := long;
	bitsize := arraytype^.aelbitsize;
	signbit := arraytype^.aeltype^.signbit;
	if arrayattr^.indexed then
	  begin
	  indexed := true;
	  indexreg := arrayattr^.indexreg;
	  indexstorage := arrayattr^.indexstorage;
	  $IF MC68020$
	  indexscale := arrayattr^.indexscale;
	  $END$
	  end
	else
	  indexed := false;
	end;
      end
    else
      begin
      if arrayattr^.indexed then {add index regs}
	begin
	with op2 do
	  begin
	  addrmode := inDreg;
	  regnum := arrayattr^.indexreg;
	  storage := long;
	  end;
	emit2(add,indxp^.attr^,op2);
	freeregs(indxp^.attr);
	savelink := indxp^.attr^.next;
	indxp^.attr^ := op2;
	indxp^.attr^.next := savelink;
	end;
      if indxp^.attr^.addrmode <> inDreg then
	loadvalue(indxp);
      with fexp^.attr^ do
	begin
	indexreg := indxp^.attr^.regnum;
	indexstorage := long;
	indexed := true;
	$IF MC68020$
	  indexscale := 0;
	$END$
	end;
      end;
    end;
  end; {cnf_subscr}

  procedure multiplyindex
	     (fsize: integer; xreg: regrange; var xstorage: stortype);
    { multiply value in xreg by fsize, the array element size or
      bitsize.  Modify xstorage as needed }
    var
      power : shortint;  { 0..8 }
      xop,op2: attrtype;

    begin
    powerof2(fsize,power);
    with xop do
      begin
      addrmode := inDreg; regnum := xreg;
      storage := xstorage;
      end;
    if power <> 0 then
      begin
      if xstorage = wrd then
	begin
	xop.storage := long;
	emit1(ext,xop);                           { EXT.L Dx }
	end;
      if power = 1 then
	emit2(add,xop,xop)                        { ADD.L Dx,Dx }
      else emitshift(power,xreg,asl,long);
      if xstorage = long then ovflck
      else xstorage := long;
      end
    else {fsize not a power of 2}
      if fsize <> 1 then
	begin
	op2.addrmode := immediate;
	op2.smallval := fsize;

	if (xop.storage = wrd) and
	   (fsize > 32767) then
	  begin
	  xop.storage := long;
	  emit1(ext,xop);
	  xstorage := long;
	  end;

	if xop.storage = wrd then
	  begin
	  emit2(muls,op2,xop);                      { MULS #fsize,Dx }
	  xstorage := long;
	  end
	else { xop.storage = long }
	  begin

	  $IF MC68020$
	  emit2(muls,op2,xop);
	  ovflck;
	  $END$

	  $IF not MC68020$
	  SPminus.storage := long;
	  emit2(move,xop,SPminus);
	  emit2(move,op2,SPminus);
	  reg[D,xop.regnum].allocstate := free;
	  saveregs; forgetbaseregs;
	  callstdproc('ASM_MPY');
	  reloadregs;
	  reg[D,xop.regnum].allocstate := allocated;
	  emit2(move,SPplus,xop);
	  $END$

	  end;
	end;
    end; {multiplyindex}

  begin {gensubscr}
  with fexp^, attr^ do
    begin genexpr(arayp); { obtain array accessing info }
    arrayattr := arayp^.attr;
    arraytype := arayp^.etyptr;
    if arraytype^.form = cnfarrays then
      cnf_subscr
    else
      begin
      if strgtype(arraytype) then
	begin lobound := 0; hibound := arraytype^.maxleng; end
      else getbounds(arraytype^.inxtype,lobound,hibound);
      elementsize := arraytype^.aelsize;
      if arrayattr^.access = indirect then
	loadaddress(arayp,false);
      if RANGECHECK and strgtype(arraytype) then
	makeaddressable(arayp);
      liftattr(fexp,arayp);
      getsignbit(etyptr,attr);
      if (indxp^.eclass = litnode) then   {constant index}
	begin
	if RANGECHECK and strgtype(arraytype) then
	  begin
	  extend(indxp,bytte);
	  getregattr(D,op);        {for string length}
	  if indxp^.attr^.storage <> bytte then
	    emit2(moveq,immed0,op);               { MOVEQ #0,Dr }
	  op.storage := bytte;
	  emit2(move,arrayattr^,op);            { MOVE.B string[0],Dr }
	  op.storage := indxp^.attr^.storage;
	  emit2(cmpi,indxp^.attr^,op);
	  freeit(D,op.regnum);
	  with op do
	    begin offset := 2;
	    storage := bytte;
	    emit1(bcc,op);  {BCC.S *+4}
	    smallval := 7;
	    emit1(trap,op); {TRAP #7}
	    end;
	  end;
	IF arraytype^.AISPACKD THEN
	  begin PACKD := TRUE;
	  BITSIZE := arraytype^.AELBITSIZE;
	  SIGNBIT := arraytype^.AELTYPE^.SIGNBIT;
	  temp := BITOFFSET.STATIC +
		  (INDXP^.LITVAL.IVAL - LOBOUND) *
		  arraytype^.AELBITSIZE;
	  offset := offset + mydiv(temp,16) * 2;
	  bitoffset.static := (temp mod 16);
	  combineoffsets(attr,etyptr^.unpacksize);
	  end { AISPACKD }
	else { add index to displacement }
	  offset := offset +
		      (indxp^.litval.ival - lobound) * elementsize;
	end {litnode}
      else { non-constant index }
	begin
	makeaddressable(indxp); maskboolexpr(indxp);
	if RANGECHECK then
	  ensure_valid_condition_code := true;
	if indxp^.attr^.storage = bytte then
	  extend(indxp,wrd);
	if (indxp^.attr^.storage=wrd) and not(indxp^.attr^.signbit) then
	  extend(indxp,long);
	ensure_valid_condition_code := false;
	loadvalue(indxp);
	indexreg := indxp^.attr^.regnum;
	indexstorage := indxp^.attr^.storage;
	indexed := true;
	$IF MC68020$
	  indexscale := 0;
	$END$
	if RANGECHECK then
	  if strgtype(arraytype) then
	    begin
	    if not ucsd then {prohibit s[0]}
	      with op do
		begin
		offset := 2;
		storage := bytte;
		emit1(bgt,op);  {BGT.S *+4}
		smallval := 7;
		emit1(trap,op); {TRAP #7}
		end;
	    getregattr(D,op);        {for string length}
	    emit2(moveq,immed0,op);               { MOVEQ #0,Dr }
	    op.storage := bytte;
	    emit2(move,arrayattr^,op);            { MOVE.B string[0],Dr }
	    xop.addrmode := inDreg; xop.regnum := indexreg;
	    emit2(chk,op,xop);                    { CHK Dr,Dindexreg }
	    freeit(D,op.regnum);
	    end
	  else
	    emitcheck(indxp,arraytype^.inxtype,true);
	IF (arraytype^.AISPACKD) AND (arraytype^.AELBITSIZE<>8)
	    AND (arraytype^.AELBITSIZE<>16) THEN
	  begin
	  PACKD := TRUE;
	  BITOFFSET.VARIABLE := INDEXREG;
	  bitoffset.storage := indexstorage;
	  BITSIZE := arraytype^.AELBITSIZE;
	  SIGNBIT := arraytype^.AELTYPE^.SIGNBIT;
	  IF arrayattr^.INDEXED THEN
	    BEGIN INDEXED := TRUE;
	    INDEXREG := arrayattr^.INDEXREG;
	    indexstorage := arrayattr^.indexstorage;
	    $IF MC68020$
	      indexscale := arrayattr^.indexscale;
	    $END$
	    END
	  ELSE INDEXED := FALSE;
	  multiplyindex(arraytype^.aelbitsize,
				bitoffset.variable,bitoffset.storage);
	  BITOFFSET.STATIC := BITOFFSET.STATIC - LOBOUND * BITSIZE;
	  END
	ELSE {bytte, word, or unpacked array}
	  BEGIN
	  with arraytype^ do
	    IF AISPACKD THEN
	      begin
	      ELEMENTSIZE := AELBITSIZE DIV BITSPERADDR;
	      attr^.signbit := aeltype^.signbit;
	      end;

	  $IF not MC68020$
	  multiplyindex(elementsize,indexreg,indexstorage);
	  $END$

	  $IF MC68020$
	  case elementsize of
	    2: indexscale := 1;
	    4: indexscale := 2;
	    8: indexscale := 3;
	    otherwise
	      begin
	      indexscale := 0;
	      multiplyindex(elementsize,indexreg,indexstorage);
	      end;
	  end;

	  if arrayattr^.indexed then { account for scale factors }
	    begin
	    if (arrayattr^.indexscale <> 0) then
	      if (indexscale <> 0) then
		multiplyindex(two_to_the[arrayattr^.indexscale-indexscale],
			      arrayattr^.indexreg,arrayattr^.indexstorage)
	      else
		multiplyindex(two_to_the[arrayattr^.indexscale],
			      arrayattr^.indexreg,arrayattr^.indexstorage)
	    else if indexscale <> 0 then
	      begin
	      multiplyindex(two_to_the[indexscale],indexreg,indexstorage);
	      indexscale := 0;
	      end;
	    end;
	  $END$

	  if arrayattr^.indexed then  { add index regs }
	    begin
	    with op do
	      begin addrmode := inDreg; regnum := arrayattr^.indexreg;
	      storage := arrayattr^.indexstorage;
	      end;
	    xop.addrmode := inDreg; xop.regnum := indexreg;
	    xop.storage := indexstorage;
	    if arrayattr^.indexstorage < indexstorage then
	      begin op.storage := long;
	      emit1(ext,op);            { EXT.L DarrayX }
	      arrayattr^.indexstorage := long;
	      end;
	    if indexstorage < arrayattr^.indexstorage then
	      begin xop.storage := long;
	      emit1(ext,xop);            { EXT.L DfexpX }
	      indexstorage := long;
	      end;
	    emit2(add,op,xop);             { ADD.xsize DarrayX,DfexpX }
	    freeit(D,arrayattr^.indexreg)
	    end;
	  { adjust displacement }
	  offset := offset - lobound * elementsize;
	  with arraytype^ do
	    IF AISPACKD and (AELTYPE^.UNPACKSIZE <> ELEMENTSIZE) THEN
	      if elementsize = 1      then storage := bytte
	      else if elementsize = 2 then storage := wrd
	      else                         storage := long;
	  END; {bytte,word, or unpacked array}
	end; {non-constant index}
      end; { standard array subscript }
    end; { with fexp^,attr^ }
  end; { gensubscr }

procedure genset(fexp: exptr);  {generate a set having variable part}
  var
    ptr: elistptr;
    op: attrtype;
    checkstp : stp;
    possible_low,
    possible_hi : integer;
    lbltemp,
    lbl1,
    lbl2 : reflistptr;
  begin
  with fexp^, attr^ do
    begin getlocstorage(etyptr^.unpacksize,op);
    emit1(pea,op);                { PEA temp }
    ekind := cnst;  {deal with the constant part first}
    pushaddress(fexp);
    ptr:=setvarpart;
    saveregs;
    repeat
      with ptr^ do
	if lowptr = hiptr then
	  begin
	  if RANGECHECK then
	    begin
	    new(checkstp);
	    with checkstp^ do
	      begin
	      form := subrange;
	      min := etyptr^.setmin;
	      max := etyptr^.setmax;
	      end;
	    emitcheck(expptr,checkstp,false);
	    end; { RANGECHECK }
	  extend(expptr,long);
	  pushvalue(expptr);
	  forgetbaseregs;
$if bigsets$
	  if etyptr^.setmax > setdefaulthigh then
	   callstdproc('ASM_XXADELEMENT')
	  else
	    callstdproc('ASM_XADELEMENT');
$end$
$if not bigsets$
	   callstdproc('ASM_ADELEMENT');
$end$
	  end
	else { range with variable limit }
	  begin
	  if RANGECHECK then
	    begin
	    genexpr(hiptr);
	    genexpr(lowptr);
	    with hiptr^.attr^ do
	      if packd then
		if (bitsize = 31) and not signbit then
		  possible_hi := maxint
		else
		  possible_hi := power_table[bitsize-ord(signbit)]-1
	      else
		case storage of
		  bytte: if signbit then
			   possible_hi := 127
			 else
			   possible_hi := 255;
		  wrd: if signbit then
			 possible_hi := 32767
		       else
			 possible_hi := 65535;
		  long: possible_hi := maxint;
		end;
	    if lowptr^.attr^.signbit then
	      possible_low := 0
	    else { minint is good enough since sets don't have negative elems }
	      possible_low := minint;
	    if (possible_low < etyptr^.setmin) or
	       (possible_hi > etyptr^.setmax) then
	      begin
	      lbl2 := NIL;
	      loadvalue(lowptr);
	      extend(lowptr,long);
	      loadvalue(hiptr);
	      extend(hiptr,long);
	      emit2(cmp,lowptr^.attr^,hiptr^.attr^);    {CMP low,hi}
	      new(lbl1);
	      lbl1^.next := NIL;
	      lbl1^.pc := 0;
	      getbrattr(lbl1^.pc,false,op);
	      { branch around rangecheck code if hi < low }
	      emit1(blt,op);                            {BLT lbl1}

	      if (possible_hi < etyptr^.setmax) then
		begin { Test for low range only }
		with op do
		  begin
		  addrmode := immediate;
		  smallval := etyptr^.setmin;
		  end;
		emit2(cmpi,op,lowptr^.attr^);           {CMPI min,low}
		new(lbltemp);
		lbltemp^.next := lbl1;
		lbltemp^.pc := 0;
		lbl1 := lbltemp;
		getbrattr(lbl1^.pc,false,op);
		emit1(bge,op);                          {BGE lbl1}
		end
	      else
		begin
		if (possible_low < etyptr^.setmin) then
		  begin
		  with op do
		    begin
		    addrmode := immediate;
		    smallval := etyptr^.setmin;
		    end;
		  emit2(cmpi,op,lowptr^.attr^);         {CMPI min,low}
		  new(lbl2);
		  lbl2^.next := NIL;
		  lbl2^.pc := 0;
		  getbrattr(lbl2^.pc,false,op);
		  emit1(blt,op);                        {BLT lbl2}
		  end;
		with op do
		  begin
		  addrmode := immediate;
		  smallval := etyptr^.setmax;
		  end;
		emit2(cmpi,op,hiptr^.attr^);            {CMPI max,hi}
		new(lbltemp);
		lbltemp^.next := lbl1;
		lbltemp^.pc := 0;
		lbl1 := lbltemp;
		getbrattr(lbl1^.pc,false,op);
		emit1(ble,op);                          {BLE lbl1}
		end;
	      if lbl2 <> NIL then                       {lbl2:}
		fixreflist(lbl2);
	      op.smallval := 7;
	      emit1(trap,op);                           {TRAP #7}
	      fixreflist(lbl1);                         {lbl1:}
	      end;
	    end; { RANGECHECK }
$if bigsets$
	    extend(lowptr,long);
	    extend(hiptr,long);
$end$
$if not bigsets$
	  extend(lowptr,wrd);
	  extend(hiptr,wrd);
$end$
	  pushvalue(lowptr);
	  pushvalue(hiptr);
	  forgetbaseregs;
$if bigsets$
	  if etyptr^.setmax > setdefaulthigh then
	   callstdproc('ASM_XXADDSETRANGE')
	  else
	   callstdproc('ASM_XADDSETRANGE');
$end$
$if not bigsets$
	   callstdproc('ASM_ADDSETRANGE');
$end$
	end;
      ptr := ptr^.nextptr;
      if ptr <> NIL then
	begin
	SPminus.storage := long;
	emit2(move,SPind,SPminus);              { MOVE.L (SP),-(SP) }
	end;
    until ptr = NIL;
    addrmode := loconstack;
    access := indirect;
    reloadregs;
    end;
  end; (*genset*)

begin {genexpr}
  with fexp^ do
    if attr = NIL then
      begin
      getattrec(fexp);
      with attr^ do
	case eclass of
	  eqnode..andnode: {binops}
	    begin
	    lform := opnd2^.etyptr^.form;
	    if lform = power then gensetop(fexp)
	    else if lform = arrays then relpaofchxpr(fexp)
	    else if eclass <= genode then relxpr(fexp)
	    else alops(fexp)
	    end;
	  negnode,notnode,floatnode,
	  absnode,chrnode,oddnode,ordnode,
	  strlennode,strmaxnode,roundnode,
	  sqrnode,truncnode:
	    unaryops(fexp);
	  idnode:
	    with symptr^ do
	      case klass of
		vars,routineparm:
		  begin
		  if (vtype < localvar) then
		    begin
		    case vtype of
		      shortvar: addrmode := shortabs;
		      longvar: addrmode := longabs;
		      relvar: addrmode := prel;
		      end;
		    gloptr := NIL;
		    attr^.absaddr := {symptr^.}absaddr;
		    end
		  else
		    begin offset := vaddr;
		    addrmode := locinreg;
		    regnum := getbasereg(vlev);
		    $PARTIAL_EVAL$
		    if (vtype = refparm) or
		       (vtype = strparm) or
		       (vtype = anyvarparm) or
		       ((vtype = cvalparm) and (idtype^.form = cnfarrays)) then
		      access := indirect
		    else if (vtype = funcparm) then
		      if idtype^.form >= prok then
			 access := indirect;
		    $IF not partialevaling$
		      $PARTIAL_EVAL OFF$
		    $END$
		    gloptr := globalptr;
		    end;
		  getsignbit(etyptr,attr);
		  end; {vars}
		func:
		  if ekind = cnst then
		    begin
		    getprokconst(symptr,attr^);
		    if not constptr^.isdumped then
		      callmode := abscall;
		    end
		  else
		    begin addrmode := locinreg;
		    regnum := getbasereg(pflev+1);
		    offset := pfaddr; gloptr := NIL;
		    if etyptr^.form >= prok then
		      access := indirect;
		    end;
		prox:
		  begin
		  getprokconst(symptr,attr^);
		  if not constptr^.isdumped then
		    callmode := abscall;
		  end;
		otherwise escape(-8);
		end;
	  litnode:
	    with litval do
	      if intval then
		begin addrmode := immediate; smallval := ival end
	      else
		with valp^ do
		  if cclass <> strctconst then
		    begin
		    addrmode := labelledconst;
		    valp := poolit(valp);
		    constvalp := valp;
		    end
		  else {structured constant}
		    begin addrmode := namedconst;
		    constptr := valp; callmode := abscall;
		    end;
	  fcallnode: genfcall(fexp);
	  concatnode:
	    begin
	    getlocstorage(256,op);
	    new(lexp);
	    new(lstp);
	    with lexp^ do
	      begin
	      attr := addr(op);
	      lstp^:= strgptr^;
	      lstp^.unpacksize := 256;
	      etyptr := lstp;
          symptr := NIL;			/* Added 04NOV92 - CFB */
	      end;
	    genconcat(lexp,fexp);
	    liftattr(fexp,lexp);
	    end;
	  substrnode:
	    with fexp^ do
	      begin
	      genexpr(arayp);
	      liftattr(fexp,arayp);
	      genexpr(indxp);
	      if lengthp <> NIL then genexpr(lengthp);
	      end;
	  subscrnode: gensubscr(fexp);
	  selnnode: genrecsel(fexp,recptr,fieldptr);
	  unqualfldnode:
	    with withstptr^ do
	      begin
	      if refbit <> 0 then  {load variable bit offset}
		begin
		with lop do
		  begin addrmode := locinreg;
		  offset := refbit; indexed := false;
		  if bodylev = 1 then regnum := SB
		  else regnum := localbase; gloptr := NIL;
		  end;
		getregattr(D,rop);
		emit2(move,lop,rop);
		refexpr^.attr^.bitoffset.variable := rop.regnum;
		end;
	      if addrinreg(refexpr) then
		with reg[A,refexpr^.attr^.regnum] do
		  begin allocstate := allocated; usesleft := usesleft+1;
		  genrecsel(fexp,refexpr,fieldref);
		  end
	      else begin {record base not loaded}
		oldattr := refexpr^.attr^;
		if oldattr.access = indirect then
		  loadaddress(refexpr,false);
		genrecsel(fexp,refexpr,fieldref);
		if addrinreg(refexpr) then
		  with reg[A,refexpr^.attr^.regnum] do
		    begin usage := withrecbase;
		    allocstate := allocated; usesleft := 1;
		    curcontents := refexpr^.attr; oldcontents := oldattr;
		    end;
		end;
	      end;
	  bufnode:
	    begin
	    rop.addrmode := immediate;
	    rop.smallval := 4;
	    SPdir.storage := long;
	    emit2(subq,rop,SPdir); {SUBQ.L #4,SP}
	    pushaddress(opnd);
	    saveregs; forgetbaseregs;
	    callIOproc('FS_FBUFFERREF');
	    reloadregs;
	    addrmode := loconstack;
	    loadaddress(fexp,false);
	    getsignbit(etyptr,attr);
	    end;
	  derfnode:
	    begin genexpr(opnd);
	    with opnd^.attr^ do
	      begin
	      if access = indirect then
		loadaddress(opnd,false);
	      if addrmode = inDreg then
		extend(opnd,long);
	      end;
	    liftattr(fexp,opnd);
	    getsignbit(etyptr,attr);
	    access := indirect;
	    if rangecheck and (addrmode <> immediate) then
	      begin   {check for NIL pointer}
	      if addrmode <> inDreg then
		begin loadaddress(fexp,false);
		getregattr(D,rop);
		lop.addrmode := inAreg; lop.regnum := regnum;
		emit2(move,lop,rop);             { MOVE.L Aregnum,Dr }
		freeit(D,rop.regnum);
		end;
	      with rop do
		begin offset:=2; storage := bytte end;
	      emit1(bne,rop);        { BNE.S *+4 (assumes nilvalue = 0) }
	      rop.smallval:=8;
	      emit1(trap,rop);       { TRAP #8 }
	      end;
	    end; {derfnode}
	  setdenonode:
	    begin
	    addrmode := labelledconst;
	    setcstpart.valp := poolit(setcstpart.valp);
	    constptr := setcstpart.valp;
	    if ekind <> cnst then genset(fexp);
	    end;
	  succnode,prednode:
	    begin
	    genexpr(opnd);
	    if not opnd^.attr^.signbit then
	      extend(opnd,succ(opnd^.attr^.storage));
	    loadvalue(opnd);
	    with op do
	      begin
	      addrmode := immediate;
	      smallval := 1;
	      end;
	    if eclass = succnode then
	      emit2(addq,op,opnd^.attr^)
	    else
	      emit2(subq,op,opnd^.attr^);
	    ovflck;
	    if RANGECHECK then
	      emitcheck(opnd,opnd^.etyptr,false);
	    liftattr(fexp,opnd);
	    storage := opnd^.attr^.storage;
	    end;
	  otherwise escape(-8);
	  end; {case eclass}
      end; {if attr = NIL}
end; {genexpr}



@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@d3497 1
@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


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.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.2
log
@

                10/14/88 - JWH

                I modified the extend routine in file GENEXPR per
                Brad Ritter's recommendation. This changed one line
                of code.
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@d36 3
a38 1
      if eclass = litnode then fixliteral(fexp,fstorage,true);
@


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
@Follow code generated for a shftnode with a TST instruction if the
operand is unsigned.  This puts the condition code in the proper
state, a state consistant with other code generation conventions.
@
text
@@


24.2
log
@Bug fix to perform rangechecking of a set constructor contain a non
constant element expression or element expression range.
@
text
@d227 2
a228 1
	  else if (opnd1^.attr^.addrmode<>inDreg) or (opnd1^.eclass=modnode)
d234 2
a235 1
	  else if (opnd2^.attr^.addrmode<>inDreg) or (opnd2^.eclass=modnode)
@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d3214 9
a3222 1
  var ptr: elistptr; op: attrtype;
d3235 11
d3261 93
@


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.2
log
@Fix for defect in booleans expressions after "while" or "if" with
partial evalation on, and intermediate result in expression
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@d1063 1
a1066 1
	      freeregs(opnd2^.attr);
@


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.2
log
@Fixes for <funtion result> DIV <function result> bug from STARS,
and another bug (found in HP-UX compiler) relating to range check
off producing incorrect code for some operations on 68020 compiler.
(Submitted by Greg Lipinski at ISL.) Bug was also in PWS version,
so BAR made appropriate fixes.
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@d863 1
a863 1
	onright,falsedefined, value: boolean);
a870 1
	  if value then getattrec(fexp);
d873 2
a874 1
	    genshortand(opnd1,newtruelist,falselist,false,falsedefined,value)
d877 2
a878 1
	    genshortor(opnd1,newtruelist,falselist,false,falsedefined,value);
d906 1
a907 2
	    loadvalue(opnd1);
	    freeregs(opnd1^.attr);
d931 2
a932 1
	    genshortand(opnd2,truelist,falselist,onright,falsedefined,value)
d935 2
a936 1
	    genshortor(opnd2,truelist,falselist,onright,falsedefined,value);
d950 1
a951 7
	      loadvalue(opnd2);
	      {Insure that both operands are in the same register}
	      if (opnd2^.attr^.regnum <> opnd1^.attr^.regnum) then
		begin
		movevalue(opnd2,opnd1^.attr^);
		opnd2^.attr^.regnum := opnd1^.attr^.regnum;
		end;
a953 1
		freeregs(opnd2^.attr);
a990 1
	  if value then liftattr(fexp,opnd2);
d997 1
a997 1
	onright,falsedefined,value: boolean);
a1003 1
	  if value then getattrec(fexp);
d1007 2
a1008 1
	    genshortand(opnd1,truelist,newfalselist,false,false,value);
d1017 2
a1018 1
	    genshortor(opnd1,truelist,newfalselist,false,false,value)
d1021 11
a1031 3
	    conditionis := bne;
	    loadvalue(opnd1);
	    freeregs(opnd1^.attr);
d1041 2
a1042 1
	    genshortand(opnd2,truelist,falselist,onright,falsedefined,value);
d1050 2
a1051 1
	    genshortor(opnd2,truelist,falselist,onright,falsedefined,value)
a1053 2
	    conditionis := bne;
	    loadvalue(opnd2);
d1055 9
a1063 5
	      if (opnd2^.attr^.regnum <> opnd1^.attr^.regnum) then
		begin
		movevalue(opnd2,opnd1^.attr^);
		opnd2^.attr^.regnum := opnd1^.attr^.regnum;
		end;
a1073 1
	  if value then liftattr(fexp,opnd2);
d2110 3
d2309 6
d2316 1
a2316 1
	  genshortand(fexp,truelist,falselist,true,false,true)
d2318 1
a2318 1
	  genshortor(fexp,truelist,falselist,true,false,true);
@


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
@Bug fixes by Brad Ritter 4/14/87
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@d565 2
a566 1
	op: attrtype;
d580 8
d592 1
a592 1
		A6ind.offset := hiboundid^.vaddr + 4
d594 2
a595 2
		A6ind.offset := hiboundid^.vaddr + 2;
	      emit2(move,A6ind,SPminus); {push length}
d597 1
a597 1
		A6ind.offset := A6ind.offset - 4
d599 4
a602 4
		A6ind.offset := A6ind.offset - 2;
	      emit2(move,A6ind,SPminus); {push upper bound}
	      A6ind.offset := loboundid^.vaddr;
	      emit2(move,A6ind,SPminus); {push lower bound}
d612 2
a613 2
	      if SPminus.storage = long then
		A6ind.offset := hiboundid^.vaddr + 4
d615 2
a616 2
		A6ind.offset := hiboundid^.vaddr + 2;
	      emit2(move,A6ind,op);
d620 2
a621 2
	      if SPminus.storage = long then
		A6ind.offset := A6ind.offset - 4
d623 1
a623 1
		A6ind.offset := A6ind.offset - 2;
d625 1
a625 1
	      emit2(move,A6ind,op);
d629 1
a629 1
	      A6ind.offset := loboundid^.vaddr;
d631 1
a631 1
	      emit2(move,A6ind,op);
d636 3
a638 1
	      end
d2847 1
@


14.2
log
@Fixes for structured constants, expressions with constants, and 
relaxed allow_packed for sizeof on packed elements
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d2504 1
a2504 1
	06,16,26: {opnd2 is zero}
d2561 1
a2561 1
	60,61,62: {opnd1 is zilchlit}
@


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
@d1483 1
a1483 1
	   (fexp^.eclass in [nenode,absnode,sqrnode,floatnode,roundnode]) then
d1511 1
d2494 1
a2494 1
	       emit2(muls,opnd2^.attr^,opnd2^.attr^);
@


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
@d2137 5
d2654 3
d2676 15
a2690 7
    case arraytype^.inxtype^.unpacksize of
      1: A6ind.storage := bytte;
      2: A6ind.storage := wrd;
      4: A6ind.storage := long;
    end;
    if ord(indxp^.attr^.storage) < ord(A6ind.storage) then
      extend(indxp,A6ind.storage);
d2693 9
d2703 40
a2742 2
      A6ind.offset := arraytype^.cnf_index^.hiboundid^.vaddr;
      if ord(A6ind.storage) < ord(indxp^.attr^.storage) then
d2744 1
a2744 1
	if (A6ind.storage = bytte) then
d2754 1
a2754 1
	  emit2(move,A6ind,op1);
d2757 1
a2757 1
	else {A6ind.storage = wrd}
d2764 1
a2764 1
	  emit2(move,A6ind,op1);
d2767 1
a2767 1
	  end;
d2770 2
a2771 2
	op1 := A6ind;
      emit2(cmp,op1,indxp^.attr^);
d2774 1
a2774 37
      lbl.next := NIL;
      getbrattr(lbl.pc,false,op1);
      emit1(bgt,op1);
      end;
    A6ind.offset := arraytype^.cnf_index^.loboundid^.vaddr;
    if ord(A6ind.storage) < ord(indxp^.attr^.storage) then
      begin
      if (A6ind.storage = bytte) then
	begin
	with op1 do
	  begin
	  addrmode := inDreg;
	  regnum := getreg(D);
	  storage := long;
	  end;
	emit1(clr,op1);
	op1.storage := bytte;
	emit2(move,A6ind,op1);
	op1.storage := indxp^.attr^.storage;
	end
      else {A6ind.storage = wrd}
	begin
	with op1 do
	  begin
	  addrmode := inDreg; regnum := getreg(D);
	  storage := wrd;
	  end;
	emit2(move,A6ind,op1);
	op1.storage := long;
	emit1(ext,op1);
	end
      end
    else
      op1 := A6ind;
    emit2(sub,op1,indxp^.attr^);
    if op1.addrmode = inDreg then
      freeit(D,op1.regnum);
d2787 3
a2789 16
    A6ind.offset := arraytype^.cnf_index^.hiboundid^.vaddr;
    case arraytype^.inxtype^.unpacksize of
      1: begin
	 A6ind.storage := bytte;
	 A6ind.offset := A6ind.offset + 2;
	 end;
      2: begin
	 A6ind.storage := wrd;
	 A6ind.offset := A6ind.offset + 2;
	 end;
      4: begin
	 A6ind.storage := long;
	 A6ind.offset := A6ind.offset + 4;
	 end;
    end;
    if A6ind.storage <> indxp^.attr^.storage then
d2791 15
a2805 1
      if A6ind.storage = bytte then
d2807 1
a2807 1
	with op2 do
d2809 11
a2819 11
	  addrmode := inDreg; regnum := getreg(D);
	  storage := long;
	  end;
	emit1(clr,op2);
	op2.storage := bytte;
	emit2(move,A6ind,op2);
	op2.storage := op1.storage;
	end
      else {storage = wrd}
	begin
	with op2 do
d2821 10
a2830 7
	  addrmode := inDreg;
	  regnum := getreg(D);
	  storage := wrd;
	  end;
	emit2(move,A6ind,op2);
	op2.storage := long;
	emit1(ext,op2);
d2832 3
a2834 3
      end
    else
      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.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


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


1.1
log
@Initial revision
@
text
@@
