		      { 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}



