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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

41.1
date     89.12.22.11.16.31;  author jwh;  state Exp;
branches ;
next     40.3;

40.3
date     89.12.12.17.47.48;  author jwh;  state Exp;
branches ;
next     40.2;

40.2
date     89.12.11.15.29.46;  author jwh;  state Exp;
branches ;
next     40.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

25.1
date     88.03.02.09.06.49;  author bayes;  state Exp;
branches ;
next     24.4;

24.4
date     88.02.09.11.45.15;  author brad;  state Exp;
branches ;
next     24.3;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

13.1
date     87.02.28.18.03.53;  author jws;  state Exp;
branches ;
next     12.1;

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

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

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

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

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

7.1
date     86.11.20.13.05.20;  author hal;  state Exp;
branches ;
next     6.2;

6.2
date     86.11.19.15.43.55;  author bayes;  state Exp;
branches ;
next     6.1;

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

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

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

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

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

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


desc
@Base file for PWS 3.2 release.

@


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

procedure funcref (fcp: ctp; fsys: setofsys);
  (* create tree for function reference *)
  var
    lexp: exptr;
    parmptr: ctp;
    tp: elistptr;
    realval: real;

  procedure splfuncref;
    (* reference to special function *)
    var lexp: exptr; lval,lmin,lmax: integer;
	sexp: elistptr; s: string[255];
	waslparent,folded: boolean;

    procedure wsscan;
      { Process scan     (bytecount, <relop>testchar, source): integer }
      var ex1,ex2,ex3: elistptr;
      begin
      with lexp^ do
       begin eclass := fcallnode; ekind := xpr;
	etyptr := intptr; fptr := fcp;
	ex1 := integerparm(fsys);
	if sy=comma then insymbol else error(20);
	if sy=relop then
	  begin if op = eqop then actualp := makeintparm(0)     {scanuntil}
	    else if op = neop then actualp := makeintparm(1)    {scanwhile}
	    else begin actualp := makeintparm(0); error(125); end;
	    insymbol;
	  end
	else begin actualp := makeintparm(0); error(125); end;
	ex2 := charparm(fsys);
	if sy=comma then insymbol else error(20);
	ex3 := anyparm(fsys,false);
	actualp^.nextptr := ex3;   {link parameters in same order as scanwhile}
	ex3^.nextptr := ex2;
	ex2^.nextptr := ex1;
       end;
      end;

    procedure addr;
      { Process addr (variable [,offset]): anyptr }
      {   &  absaddr (variable [,offset]): anyabsptr }
      begin
      with lexp^ do
	begin eclass := fcallnode; ekind := xpr; fptr := fcp;
	etyptr := anyptrptr;
	actualp := anyparm(fsys,false);
	with actualp^.expptr^ do
	  if (ekind = cnst) and (etyptr <> nil) then
	    if etyptr^.form = prok then error(125)
	    else
	      warning(linenumber+1,
		'''ADDR'' of a constant may not be supported on other implementations');
	if sy <> comma then actualp^.nextptr := nil
	else begin insymbol; actualp^.nextptr := integerparm(fsys); end;
	end;
      end (*addr*);

    procedure blockio;
      { Process blockread/write(file, buffer, nblocks [, blocknum]): integer }
      var lxlp: elistptr;
      begin
      with lexp^ do
       begin eclass := fcallnode; ekind := xpr;
	 etyptr := intptr; fptr := fcp;
	 lxlp := fileparm(fsys,untyped); actualp := lxlp;
	 if sy = comma then insymbol else error(20);
	 lxlp^.nextptr := anyparm(fsys,fcp^.spkey=spblockread);
	 lxlp:=lxlp^.nextptr; if sy = comma then insymbol else error(20);
	 lxlp^.nextptr := integerparm(fsys); lxlp := lxlp^.nextptr;
	 if sy <> comma then lxlp^.nextptr := makeintparm(-1)
	 else begin insymbol; lxlp^.nextptr := integerparm(fsys); end;
       end;
      end (*blockio*);

    procedure sizefunc;
      {SIZEOF function}
      var lcp,lcp2: ctp; lsp: stp; lsize: addrrange;
      begin
      lsp := nil; lsize := 0;
      if sy=ident then
	begin                   {get type of type name or identifier}
	searchid([types,konst,vars,field],lcp);
	if lcp^.klass = types then              {type name}
	  begin lsp := lcp^.idtype;
	  if lsp=strgptr then error(125);
	  insymbol;
	  end
	else                                    {variable name}
	  begin
	  identproc(fsys+[comma,rparent]);
	  lsp := curexp^.etyptr;
	  lcp2 := NIL;
	  if curexp^.eclass = selnnode then
	    lcp2 := curexp^.fieldptr
	  else if curexp^.eclass = unqualfldnode then
	    lcp2 := curexp^.fieldref;
	  if (lcp2 <> NIL) and (not allow_packed) then
	    if lcp2^.klass = field then
	      if lcp2^.fispackd then
		error(125)
	      else if lcp2^.strucwaspackd then
		error(125);
	  end;
	if lsp <> nil then      {remember size; set LSP = TAGFIELD struct}
	  with lsp^ do
	    begin lsize := unpacksize;
	      if sizeoflo then error(672);
	      if form = records then lsp := recvar else lsp := nil;
	    end;
	end
      else error(2);
      getvariantsize(fsys, lsp, lsize);         {look for variants}
      with lexp^ do             {return an integer constant expression}
	begin
	eclass := litnode; ekind := cnst;
	etyptr := intptr; litval.intval := true;
	litval.ival := lsize;
	end;
      end; {sizefunc}

    begin (*splfuncref*)
    with fcp^ do
      begin
      insymbol;
      if sy = lparent then
	begin insymbol; waslparent := true end
      else
	begin waslparent := false;
	if (spkey <> speof) and
	   (spkey <> speoln) then error(9);
	end;
      if spkey in [spabs..spsucc] then expression(fsys+[rparent]);
      lexp := newexpr;
      case spkey of
	spabs,spsqr:
	  begin
	  with curexp^ do
	    if etyptr <> nil then
	      if not arithtype(etyptr) then error(125);
	  with lexp^ do
	    begin etyptr := curexp^.etyptr; folded := false;
	    if curexp^.eclass = litnode then
	      if spkey = spabs then
		begin
		eclass := litnode;
		ekind := cnst;
		folded := true;
		with litval do
		  if etyptr = intptr then
		    try
		      $ovflcheck on$
		      intval := true;
		      ival := abs(curexp^.litval.ival);
		      $if not ovflchecking$
			$ovflcheck off$
		      $end$
		    recover
		      begin
		      if escapecode = -4 then
			error(301);
		      end
		  else if etyptr = realptr then
		    begin
		    if not inbody then error(50);
		    intval := false;
		    new(valp,true,reel);
		    valp^.cclass := reel;
		    valp^.rval := abs(curexp^.litval.valp^.rval);
		    end
		  else {error}
		    begin
		    intval := true;
		    ival := 0;
		    etyptr := nil;
		    end;
		end
	      else {sqrnode}
		if curexp^.litval.intval and
		   ((not MC68020) or (float = flt_off)) then
		  try
		    $ovflcheck on$
		    lval := sqr(curexp^.litval.ival);
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		    folded := true;
		    eclass := litnode; ekind := cnst;
		    with litval do
		      begin intval := true; ival := lval end;
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode);
	    if not folded then
	      begin ekind := xpr; opnd := curexp;
	      if spkey = spsqr then eclass := sqrnode
	      else eclass := absnode;
	      end;
	    end;
	  end;
	spchr:
	  begin
	  with curexp^ do
	    if (etyptr <> nil) and (etyptr <> intptr)
	      and (etyptr <> shortintptr) then error(125);
	  with lexp^ do
	     begin eclass := chrnode; ekind := xpr;
	     etyptr := char_ptr; opnd := curexp;
	     if curexp^.eclass = litnode then
	       with curexp^.litval do
		 if not intval then error(125)
		 else if (ival<0) or (ival>255) then error(125)
		 else begin
		   eclass := litnode; ekind := cnst;
		   litval := curexp^.litval;
		   end;
	     end; {with lexp^}
	  end;
	spodd:
	  begin
	  with curexp^ do
	    if (etyptr<>nil) and (etyptr<>intptr)
	      and (etyptr <> shortintptr) then error(125);
	  with lexp^ do
	    begin etyptr := boolptr;
	    if curexp^.eclass = litnode then
	      begin ekind := cnst; eclass := litnode;
	      with litval do
		begin intval := true;
		ival := ord(odd(curexp^.litval.ival))
		end;
	      end
	    else {operand not constant}
	      begin eclass := oddnode; ekind := xpr; opnd := curexp end;
	    end; {with lexp^}
	  end;
	spord:
	  begin
	  with curexp^ do
	    if etyptr <> nil then
	      if not (etyptr^.form in [scalar,subrange,pointer])
		then error(125);
	  with lexp^ do
	    begin etyptr := intptr;
	    if curexp^.eclass <> litnode then
	      begin eclass := ordnode; ekind := xpr;
	      opnd := curexp;
	      end
	    else begin
	      eclass := litnode; ekind := cnst;
	      litval := curexp^.litval;
	      end;
	    end;
	  end;
	spstrlen,splength:
	  with lexp^ do
	    begin etyptr := intptr;
	    folded := false;
	    if curexp^.etyptr <> nil then
	      if not strgvalue(curexp) then
		error(125)
	      else if curexp^.eclass=litnode then
		if curexp^.etyptr=char_ptr then
		  begin litval.ival := 1;
		  folded := true;
		  end
		else
		  with curexp^.litval.valp^ do
		   if cclass = paofch then
		     begin litval.ival := slgth;
		     folded := true;
		     end;
	    if not folded then
	      begin eclass := strlennode;
	      ekind := xpr; opnd := curexp;
	      end
	    else
	      begin eclass := litnode;
	      ekind := cnst;
	      litval.intval := true;
	      end;
	    end;
	spstrmax:
	  with lexp^ do
	    begin etyptr := intptr;
	    eclass := strmaxnode;
	    ekind := xpr; opnd := curexp;
	    if curexp^.etyptr <> nil then
	      if not strgtype(curexp^.etyptr) then
		error(125)
	      else if curexp^.ekind<>vrbl then
		error(125)
	      else if curexp^.etyptr<>strgptr then
		begin eclass := litnode;
		ekind := cnst;
		with litval do
		  begin intval := true;
		  ival := curexp^.etyptr^.maxleng;
		  end;
		end;
	    end;
	spconcat:
	  with lexp^, fcp^ do
	    begin eclass := fcallnode;
	    fptr := fcp; ekind := xpr;
	    etyptr := idtype; sexp := stringparm(fsys);
	    actualp := sexp;
	    while sy = comma do
	      begin insymbol;
	      sexp^.nextptr := stringparm(fsys); sexp := sexp^.nextptr;
	      end;
	    end;
	spround,sptrunc:
	  begin
	  with curexp^ do
	    if etyptr<>nil then
	      if etyptr<>realptr then error(125);
	  with lexp^ do
	    begin
	    if spkey = sptrunc then eclass := truncnode
	    else eclass := roundnode;
	    ekind := xpr; etyptr := intptr; opnd := curexp;
	    end;
	  end;
	sppred,spsucc:
	  begin
	  with curexp^ do
	    begin lmin := minint; lmax := maxint;
	    if etyptr <> nil then
	      with etyptr^ do
		if form > subrange then
		   error(125)
		else if form = subrange then
		  getbounds(rangetype,lmin,lmax)
		else getbounds(etyptr,lmin,lmax);
	    folded := false;
	    if eclass = litnode then
	      with litval do
		if intval then
		  try
		    $ovflcheck on$
		    if spkey = spsucc then lval := ival+1
		    else lval := ival-1;
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		    folded := true;
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode) ;
	    end; {with curexp^}
	  with lexp^ do
	    begin etyptr := curexp^.etyptr;
	    if folded then
	      begin eclass := litnode; ekind := cnst;
	      with litval do
		begin intval := true;
		ival := lval;
		if (lval<lmin) or (lval>lmax) then
		  error(303);
		end;
	      end
	    else
	      begin ekind := xpr;
	      if spkey = spsucc
		then eclass := succnode
		else eclass := prednode;
	      opnd := curexp;
	      end; {not folded}
	    end; {with lexp^}
	  end;
	spaddr: addr;
	spsizeof: sizefunc;
	spscan: wsscan;
	spblockread, spblockwrite: blockio;
	spmaxpos,spposition,splinepos:
	  with lexp^ do
	    begin eclass := fcallnode; ekind := xpr;
	    etyptr := intptr; fptr := fcp;
	    if spkey = splinepos then
	      begin error(651);
	      if waslparent then
		actualp := fileparm(fsys,textphile);
	      end
	    else actualp := fileparm(fsys,directfile);
	    end;
	sphex,spoctal,spbinary:
	  with lexp^ do
	    begin eclass := fcallnode;
	    ekind := xpr; etyptr := intptr;
	    fptr := fcp;
	    actualp := stringparm(fsys);
	    folded := false;
	    with actualp^.expptr^ do
	      if (eclass=litnode)
		  and not litval.intval then
		with litval.valp^ do
		  if cclass=strng then
		    begin setstrlen(s,slgth);
		    moveleft(sval[1],s[1],slgth);
		    folded := true;
		    end;
	    if folded then
	      try
		case spkey of
		  sphex:    lval := hex(s);
		  spoctal:  lval := octal(s);
		  spbinary: lval := binary(s);
		  end;
		eclass := litnode; ekind := cnst;
		litval.intval := true;
		litval.ival := lval;
	      recover
		if inbody then
		  {not called by constant so
		   give the error here} error(50);
	    end;
	speoln,speof:
	  with lexp^ do
	    begin eclass := fcallnode;
	    ekind := xpr; etyptr := boolptr;
	    fptr := fcp;
	    if waslparent then
	      if spkey = speof then
		actualp := fileparm(fsys,any)
	      else actualp := fileparm(fsys,textphile)
	    else
	      begin
	      actualp := newexplist;
	      if inputptr <> NIL then
		actualp^.expptr := makefileexp(inputptr)
	      else
		begin
		error(185);
		actualp^.expptr := NIL;
		end;
	      end;
	    end;
	otherwise error(651)
	end; (*case spkey*)
      end; (*with fcp^*)
    curexp := lexp;
    if waslparent then
      if sy = rparent then insymbol else error(4);
    end (*splfuncref*);

  begin (*funcref*)
  if not inbody and stdpasc then error(606);
  with fcp^ do
    if (klass = func) and (pfdeckind = special) then
      splfuncref
    else
      begin (* standard or declared func *)
      insymbol; lexp := newexpr;
      with lexp^ do
	begin eclass := fcallnode;
	ekind := xpr; etyptr := idtype;
	actualp := nil; fptr := fcp;
	if klass = func then parmptr := next
	else parmptr := proktype^.params;
	if sy = lparent then
	  begin
	  actparmlist(fsys,actualp,parmptr);
	  if sy = rparent then insymbol
			  else error(4);
	  if (klass = func) and (pfdeckind = standard) then
	    if (spkey = spstrpos) then
	      if switch_strpos then
		with lexp^ do
		  begin { switch parameters }
		  actualp^.nextptr^.nextptr := actualp;
		  actualp := actualp^.nextptr;
		  actualp^.nextptr^.nextptr := NIL;
		  end
	      else
		if strpos_warn then
		  warning(linenumber+1,
		  'STRPOS does not conform to HP standard, see $SWITCH_STRPOS$')
	    else if (spkey in [spsin,spcos,spsqrt,spln,spexp,sparctan]) then
	      with actualp^ do
		if (expptr^.eclass = litnode) and
		   ((not MC68020) or (float = flt_off)) then
		  begin
		  try
		    with expptr^.litval.valp^ do
		      case spkey of
			spsin:     realval := sin(rval);
			spcos:     realval := cos(rval);
			spsqrt:    realval := sqrt(rval);
			spln:      realval := ln(rval);
			spexp:     realval := exp(rval);
			sparctan:  realval := arctan(rval);
		      end; {case}
		  recover
		    if (escapecode = -6) or (escapecode = -7) or
		       ((escapecode <= -15) and (escapecode >= -17)) then
		      begin
		      error(50);
		      realval := 0.0;
		      end
		    else
		      escape(escapecode);
		  eclass := litnode;
		  ekind := cnst;
		  litval.intval := false;
		  litval.valp := opnd^.litval.valp;
		  litval.valp^.rval := realval;
		  litval.valp^.cclass := reel;
		  end;
	  end
	else if parmptr <> nil then error(126)
	end; (* with lexp^ *)
      curexp := lexp;
      if curexp^.eclass = fcallnode then
	tp := curexp^.actualp
      else
	tp := NIL;
      curexp^.num_ops := 0;
      while tp <> NIL do
	begin
	if tp^.expptr^.num_ops > curexp^.num_ops then
	  curexp^.num_ops := tp^.expptr^.num_ops;
	tp := tp^.nextptr;
	end;
      if klass = routineparm then
	begin {make func id the first param}
	tp := newexplist;
	tp^.nextptr := curexp^.actualp;
	curexp^.actualp := tp;
	tp^.expptr := newexpr;
	with tp^.expptr^ do
	  begin ekind := vrbl; eclass := idnode;
	  etyptr := proktype; symptr := curexp^.fptr;
	  end;
	end; {routineparm}
      end; (* standard or declared func *)
  end (*funcref*);

procedure setdeno (*fsys: setofsys; settype: stp*);
  label 1;
  var unknowntype,hascstpart,hasvarpart,ldone: boolean;
      setexp,lexp: exptr; lxlp: elistptr; lsp: stp;
  $if bigsets$
      constpart: setrecptr;             (* head of set record list *)
      endptr : setrecptr;               (* tail of set record list *)
      s : setrecptr;                    (* current set record *)
      j : shortint;                      (* simple counter *)
      bias : shortint;                  (* set list ordinal bias index *)
      rel_elem : shortint;              (* bias relative element value *)
      max_bias : shortint;              (* max ordinal bias *)
      high_bias : shortint;             (* range high bias *)
      cur_bias : shortint;              (* current ordinal bias *)
      rel_high : shortint;         (* current bias's high relative ord *)
  $end$
  $if not bigsets$
      constpart: set of SETLOW..SETHIGH;
  $end$
       lmin,lmax,i: integer;

  begin insymbol;
  unknowntype := (settype=nil);
  if unknowntype then
    begin
    new(settype,power);
    with settype^ do   (*create new set type*)
      begin form := power; elset := nil;
      ispackable := false; sizeoflo := false;
$if bigsets$
      unpacksize := SETDEFAULTSIZE; align := SETALIGN;
      setmin := SETLOW; setmax := SETDEFAULTHIGH;
$end$
$if not bigsets$
      unpacksize := SETSIZE; align := SETALIGN;
      setmin := SETLOW; setmax := SETHIGH;
$end$
      info := sysinfo;
      end;
    end;
  setexp := newexpr;
  with setexp^ do
    begin eclass := setdenonode; ekind := xpr;
    etyptr := settype; setcstpart.intval := false;
    setcstpart.valp := nil; setvarpart := nil;
    end;
$if bigsets$
  constpart := NIL;
  endptr := NIL;
  max_bias := -1;
  cur_bias := -1;
$end$
$if not bigsets$
  constpart := [];
$end$
  hascstpart:=false; hasvarpart:=false;
  if sy <> rbrack then
    repeat expression(fsys+[comma,rbrack,rangesy]);
      lexp := curexp; lsp := curexp^.etyptr;
      if lsp<>nil then
	if unknowntype then
	  begin
	  if lsp^.form <> scalar then error(136)
	  else begin
	       settype^.elset := lsp; unknowntype := false;
	       if (lsp<>intptr) and (lsp<>shortintptr) then
		 begin
		 getbounds(lsp,lmin,lmax);
		 if lmax > SETHIGH then error(658)
		 else
		   with settype^ do
		      begin
		      setmax := lmax;
		(***  if lmax+1 < bitsperword then
			begin ispackable := true; signbit := false;
			  bitsize := lmax+1
			end;  ***)
		      unpacksize := setlensize + SETELEMSIZE *
			      ((lmax + setelembits) div setelembits)
		      end
		 end
	       end
	  end
	else  {set type is known}
	  begin
	  if not comptypes(lsp,settype^.elset) then error(137);
	  end;
      if sy = rangesy then
	begin insymbol; expression(fsys+[comma,rbrack]);
	  if not comptypes(lsp,curexp^.etyptr) then error(137);
	end;
      if (lexp^.eclass=litnode) and (curexp^.eclass=litnode)
	 and not unknowntype then
	begin         {constant element}
	if not lexp^.litval.intval or not curexp^.litval.intval
	   or (lexp^.litval.ival < settype^.setmin)
	   or (curexp^.litval.ival > settype^.setmax) then
	     error(182)
	else if lexp^.litval.ival >
		curexp^.litval.ival then error(50)
	else
   $if bigsets$
	  begin
	    high_bias := curexp^.litval.ival div (oldsethigh+1);
	    i := lexp^.litval.ival;
	    repeat
		  bias := i div (oldsethigh+1);
		  rel_elem := i mod (oldsethigh+1);
		  if ( bias > max_bias ) then (* need new chunk(s) for set *)
			begin
			  repeat
			      max_bias := max_bias + 1;
			      new( s );
			      with s^ do
				begin
				  nxt := NIL;
				  val := [];
				end;
			      if ( endptr <> NIL ) then
				begin                   (* add to end/list *)
				  endptr^.nxt := s;
				  endptr := s;
				end
			      else
				begin                   (* begin new list *)
				  endptr := s;
				  constpart := s;
				end;
			  until max_bias = bias;
			end
		      else              (* fits in current chunk list *)
			begin
			s := constpart;
			for j := 0 to (bias - 1) do s := s^.nxt;
			end;
		  cur_bias := bias;
		  if bias = high_bias then
		    rel_high := curexp^.litval.ival mod (oldsethigh+1)
		  else
		    rel_high := oldsethigh;
		  for j := rel_elem to rel_high do
			s^.val := s^.val + [ j ];
		  i := i + rel_high - rel_elem + 1;
	    until ( i >= curexp^.litval.ival);
	  end;
$end$
$if not bigsets$
	  for i := lexp^.litval.ival to curexp^.litval.ival do
	       constpart := constpart + [i];
$end$
	hascstpart := true;
	end
      else
	begin         {variable element}
	if hasvarpart then
	  begin new(lxlp^.nextptr,true); lxlp := lxlp^.nextptr end
	else
	  begin new(setexp^.setvarpart); lxlp := setexp^.setvarpart end;
	with lxlp^ do
	  begin nextptr := nil; lowptr := lexp; hiptr := curexp end;
	hasvarpart := true;
	end;
      ldone := sy <> comma;
      if not ldone then insymbol;
    until ldone;
  if sy = rbrack then insymbol else error(12);
  if hasvarpart then setexp^.ekind := xpr else setexp^.ekind := cnst;
  new(setexp^.setcstpart.valp,true,pset);
  with setexp^.setcstpart.valp^ do
    begin cclass := pset; plgth:=0;  { now find highest "on" bit }
 $if bigsets$
   if constpart <> NIL then
     begin
       s :=  constpart;  bias := 0;
       while ( s^.nxt <> NIL ) do
	 begin  s := s^.nxt;  bias := bias + 1;  end;
       i := (bias+1) * (oldsethigh+1) - 1;
       if ( i > settype^.setmax ) then i := settype^.setmax;
       rel_elem := i MOD (oldsethigh + 1);
       for j := rel_elem downto 0 do
	 if j in s^.val then
	   begin
	      plgth := ( j + ( bias * (oldsethigh + 1) )  + 1 );
	      goto 1;
	   end;
     end;               (* if constpart <> NIL *)
$end$
$if not bigsets$
    for i:=settype^.setmax downto settype^.setmin do
      if i in constpart then begin plgth:=i+1; goto 1 end;
$end$
1:   pval := constpart;
    end;
  curexp := setexp
  end (*setdeno*);

procedure makedummyexpr(fcp: ctp);
  begin
  curexp := newexpr;
  with curexp^ do
    begin
    eclass := idnode;
    etyptr := NIL;
    ekind := vrbl;
    symptr := fcp;
    end;
  end;

procedure constructor (fsys: setofsys; fsp: stp);
  (* Parse a set constructor of the given type *)
  var lsp: stp; lvalu: valu;
  begin
  if stdpasc then error(606);
  if fsp = nil then
    begin
    skip(fsys+[rbrack]);
    if sy=rbrack then insymbol;
    end
  else
    if fsp^.form = power then
      setdeno(fsys,fsp)
    else
      begin
      error(655);
      skip(fsys+[rbrack]);
      if sy=rbrack then insymbol;
      makedummyexpr(uvarptr);
      end;
  end; {constructor}

procedure funcresult (fcp: ctp);
  (* create a tree for assignment to function name *)
  begin curexp := newexpr;
  with curexp^ do
    begin eclass := idnode; ekind := vrbl;
    etyptr := fcp^.idtype; symptr := fcp;
    with fcp^ do
      if klass = routineparm then error(103)
      else if pfdeckind <> declared then error(150)
      else if not inscope then error(177);
    end;
  if fcp^.pfdeckind = declared then
    fcp^.assignedto := true;
  insymbol;
  end (*funcresult*);

procedure cast(fsys: setofsys; fsp: stp);

  procedure casttypecheck(fsp1,fsp2: stp);
    var lform1,lform2: structform;
    begin
    if (fsp1<>nil) and (fsp2<>nil) then
      begin
      lform1 := fsp1^.form; lform2 := fsp2^.form;
      if (lform1 in [scalar,subrange,reals,pointer]) and
	 (lform2 in [scalar,subrange,reals,pointer]) then
	{ For FSDdt03843 : }
	begin  if fsp1^.unpacksize <> fsp2^.unpacksize then
	     begin
		if ((lform1 = pointer) and (lform2 = scalar)
		    and (fsp1^.unpacksize = 4) and (fsp2^.unpacksize = 2)
		    and (curexp^.ekind = XPR)) then
		begin { DO NOTHING }
		end
	       else
		error(134)
	     end
	end
      else if lform1 <> lform2 then error(134)
      end;
    end; {casttypecheck}

  begin {cast}
  if not modcal then error(612);
  if fsp = strgptr then error(732);
  insymbol;
  expression(fsys+[rparent]);
  if sy = rparent then insymbol else error(4);
  casttypecheck(fsp,curexp^.etyptr);
  curexp^.etyptr := fsp;
  end; {cast}

procedure assignableid (fsys: setofsys; fcp: ctp);
  (* handle lhs of assignment statement *)
  begin
  case fcp^.klass of
    types: begin insymbol;
	   if sy = lparent then
	     begin cast(fsys,fcp^.idtype);
	     selector(fsys);
	     end
	   else
	     begin
	     if modcal then error(9)
		       else error(103);
	     skip(fsys);
	     makedummyexpr(fcp);
	     end;
	   end;
    vars:  begin
	   variable(fcp);
	   selector(fsys);
	   { Check for FOR loop variable }
	   if cantassign in fcp^.info then error(702);
	   end;
    field: begin unqualfield(fcp); selector(fsys) end;
    routineparm,
    func:  begin funcresult(fcp);
	   if sy=arrow then error(6);
	   selector(fsys);
	   end;
    end;
  end (*assignableid*);

procedure identproc(*fsys: setofsys*);
  (* parse identifier in an expression *)
  var lcp: ctp;

  procedure makeroutineconst(fcp: ctp);
    var proctyp: stp;
    begin
    with fcp^ do
      if pfdeckind <> declared then error(652)
      else if klass = prox then
       if ismodulebody then error(704);
    new(proctyp,prok);
    with proctyp^ do
      begin
      ispackable := false; sizeoflo := false;
      unpacksize := PROKSIZE; align := PROKALIGN;
      info := sysinfo; params := fcp^.next;
      if fcp^.klass = prox then form := prok else form := funk;
      end;
    curexp := newexpr;
    with curexp^ do
      begin ekind := cnst; eclass := idnode;
      etyptr := proctyp; symptr := fcp;
      end;
    insymbol;
    end; {makeroutineconst}

  begin {identproc}
  if sy <> ident then error(2)
  else
    begin searchid([types,konst,vars,field,func,prox,routineparm],lcp);
    case lcp^.klass of
      types: begin insymbol;
	     if sy = lbrack then constructor(fsys,lcp^.idtype)
	     else if sy = lparent then
	       begin cast(fsys,lcp^.idtype); selector(fsys) end
	     else
	       begin error(6); skip(fsys);
	       makedummyexpr(lcp);
	       end;
	     end;
      konst: begin constid(lcp); selector(fsys) end;
      vars:  begin variable(lcp); selector(fsys) end;
      field: begin unqualfield(lcp); selector(fsys) end;
      routineparm:
	     if donteval or (lcp^.vtype = procparm) then
	       begin curexp := newexpr;
	       with curexp^ do
		 begin ekind := vrbl; eclass := idnode;
		 etyptr := lcp^.proktype; symptr := lcp;
		 end;
	       insymbol;
	       end
	     else
	       begin
	       if lcp^.vtype <> funcparm then error(103);
	       funcref(lcp,fsys); selector(fsys);
	       end;
      func:  if donteval then makeroutineconst(lcp)
	     else
	       begin funcref(lcp,fsys); selector(fsys) end;
      prox:  makeroutineconst(lcp);
      end; {case}
    with curexp^ do
      if etyptr <> nil then
	if (etyptr^.form = subrange) and not varparm then
	  etyptr := etyptr^.rangetype;
    end; (*sy = ident*)
  end; (*identproc*)

procedure expression (*fsys: setofsys*);
  var lexp: exptr;

  procedure simpleexpression (fsys: setofsys);
    var lsigned,lpositive,sywaslit: boolean;
	lexp: exptr;

    procedure term (fsys: setofsys);
      var lexp: exptr; lop: operator;

      procedure factor (fsys: setofsys);
	var oldvarparm: boolean;

	procedure notoperation (fsys: setofsys);
	  var lnot: exptr;
	  begin
	  insymbol; factor(fsys);
	  with curexp^ do
	    begin if (etyptr <> nil) and (etyptr <> boolptr) then error(135);
	    if (ekind = xpr) and
	       (eclass in [eqnode,nenode,ltnode,lenode,gtnode,genode]) then
	      case eclass of
		eqnode: eclass := nenode;
		nenode: eclass := eqnode;
		ltnode: eclass := genode;
		lenode: eclass := gtnode;
		gtnode: eclass := lenode;
		genode: eclass := ltnode;
		end
	    else begin
	      lnot := newexpr;
	      with lnot^ do
		begin etyptr := boolptr;
		if curexp^.eclass <> litnode then
		  begin
		  ekind := xpr;
		  eclass := notnode;
		  opnd := curexp;
		  num_ops := opnd^.num_ops;
		  end
		else {fold}
		  begin
		  if not inbody then error(50);
		  ekind := cnst; eclass := litnode;
		  with litval do
		    begin intval := true;
		    ival := abs(curexp^.litval.ival-1);
		    end;
		  end;
		end; {with lnot^}
	      curexp := lnot;
	      end;
	    end; {with curexp^}
	  end (*notoperation*);

	begin (*factor*)
	  if not (sy in facbegsys) then
	    begin error(58);
	    skip(fsys+facbegsys);
	    if not (sy in facbegsys) then
	      curexp := newexpr;
	    end;
	  while sy in facbegsys do
	    begin
	    oldvarparm := varparm;
	    if sy<>ident then varparm := false;
	    case sy of
	      intconst,
	      realconst,
	      stringconst:
		begin oldvarparm := varparm;
		varparm := false;
		literals;
		varparm := oldvarparm;
		end;
	      ident:
		identproc(fsys);
	      lbrack:
		begin oldvarparm := varparm;
		varparm := false;
		setdeno(fsys,nil);
		varparm := oldvarparm;
		end;
	      notsy:
		notoperation(fsys);
	      lparent:
		begin insymbol;
		expression(fsys+[rparent]);
		if (curexp <> NIL) and (curexp^.ekind = vrbl) then
		  curexp^.ekind := xpr;
		if not inbody and
		  (curexp^.etyptr=realptr)
		    then error(750);
		if sy = rparent then insymbol
		else error(4)
		end;
	      end; (*case*)
	    if not (sy in fsys) then
	      begin error(6); skip(fsys+facbegsys) end
	    end; (*while*)
	end (*factor*);

      procedure muloptypecheck;
	(* type checker, constant folder for '*','/','div','mod','and' *)
	var
	  lltype,lrtype: stp;
	  llval,lrval,lval: integer;
	  res: integer; exptemp: exptr;
	  fold_ok: boolean;
	  realval: real;

	procedure powerof2(fexp: exptr; var res: integer);
	  var i: integer;
	  begin
	  res := 0;
	  with fexp^.litval do
	    if intval then
	      for i := 1 to 14 do
		if ival = power_table[i] then res := i;
	  end;

	begin {muloptypecheck}
	with curexp^ do
	  begin
	  fold_ok := true;
	  num_ops := opnd1^.num_ops + opnd2^.num_ops;
	  lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
	  if (lltype = nil) or (lrtype = nil) then etyptr := nil
	  else
	    begin
	    if [arrays,records,files,pointer,prok] *
	       [lltype^.form,lrtype^.form] <> [] then error(134)
	    else
	      case lop of
		mul:
		  begin
		  if lltype^.form = power then
		    begin eclass := intersectnode;
		    if comptypes(lltype,lrtype) then
		      begin
		      if lltype^.setmax > lrtype^.setmax then
			etyptr := lrtype        {Result type = smaller}
		      end
		    else error(129);
		    end
		  else if arithtype(lltype) and arithtype(lrtype) then
		    begin
		    if lltype<>lrtype then
		      begin
		      if not shortintandint(lltype,lrtype) then
			if not trytowiden(opnd1,lrtype) then
			  if not trytowiden(opnd2,lltype) then
			    error(999);   {should never get here!}
		      etyptr := opnd1^.etyptr;
		      end
		    end
		  else
		    begin
		    error(134);
		    fold_ok := false;
		    end;
		  if eclass = mulnode then
		    if (opnd1^.eclass = litnode)
			and (opnd2^.eclass <> litnode) then
		      begin powerof2(opnd1,res);
		      if res <> 0 then
			begin eclass := shftnode; exptemp := opnd1;
			opnd1 := opnd2; opnd2 := exptemp;
			opnd2^.litval.ival := res end;
		      end
		    else if (opnd1^.eclass <> litnode)
			and (opnd2^.eclass = litnode) then
		      begin powerof2(opnd2,res);
		      if res <> 0 then
			begin eclass := shftnode; opnd2^.litval.ival := res end;
		      end;
		  end;
		idiv,imod:
		  begin
		  if (lltype <> intptr) and (lltype <> shortintptr)
		    or (lrtype <> intptr) and (lrtype <> shortintptr) then
		    begin error(134); etyptr := intptr end;
		  if opnd2^.eclass = litnode then
		    if opnd2^.litval.ival = 0 then
		      error(300)
		    else if (eclass = divnode) and
			    (opnd1^.eclass <> litnode) then
		      begin
		      powerof2(opnd2,res);
		      if res <> 0 then
			begin
			eclass := shftnode;
			opnd2^.litval.ival := -res;
			end;
		      end
		    else if eclass = modnode then
		      if opnd2^.litval.ival < 0 then
			begin
			error(125);
			opnd2^.litval.ival := 1;
			end;
		  end;
		rdiv:
		  begin etyptr := realptr;
		  if lltype<>etyptr then
		    if not trytowiden(opnd1,etyptr) then
		      begin
		      error(134);
		      fold_ok := false;
		      end;
		  if lrtype<>etyptr then
		    if not trytowiden(opnd2,etyptr) then
		      begin
		      error(134);
		      fold_ok := false;
		      end;
		  end;
		andop:
		  if (lltype <> boolptr) or (lrtype <> boolptr) then
		    begin error(134); etyptr := boolptr end
		end; (*case lop*)
	    if fold_ok and
	       (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	      begin
	      if opnd1^.litval.intval and opnd2^.litval.intval then
		begin llval := opnd1^.litval.ival;
		lrval := opnd2^.litval.ival;
		if eclass = andnode then
		  begin
		  if not inbody then error(50);
		  lval := ord( (llval=1) and (lrval=1) );
		  end
		else
		  try
		    $ovflcheck on$
		    case eclass of
		      mulnode: lval := llval*lrval;
		      divnode: if lrval = 0 then error(300)
			       else lval := llval div lrval;
		      modnode: if lrval = 0 then error(300)
			       else lval := llval mod lrval;
		    end; {case}
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode);
		eclass := litnode;
		ekind := cnst;
		num_ops := 1;  { result of folding 2 operands }
		with litval do
		  begin intval := true; ival := lval end;
		end {constant folding integer}
	      else if inbody and (etyptr = realptr) and
		      ((not MC68020) or (float = flt_off)) then
		begin
		try
		  if eclass = mulnode then
		    realval := opnd1^.litval.valp^.rval *
			       opnd2^.litval.valp^.rval
		  else { eclass = divnode }
		    realval := opnd1^.litval.valp^.rval /
			       opnd2^.litval.valp^.rval;
		recover
		  if (escapecode = -6) or (escapecode = -7)
		     or (escapecode = -5) then
		    begin
		    realval := 0.0;
		    error(301);
		    end
		  else
		    escape(escapecode);
		eclass := litnode;
		ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		with litval do
		  begin
		  valp := opnd1^.litval.valp;
		  valp^.rval := realval;
		  valp^.cclass := reel;
		  intval := false;
		  end;
		end;
	      end
	    else if fold_ok and (opnd1^.eclass = litnode) then
	      case eclass of
		mulnode:
		  if (opnd1^.litval.intval) then
		    begin
		    if (opnd1^.litval.ival = 0) then
		      { 0 * xxx : fold out mul operation }
		      curexp := opnd1
		    else if (opnd1^.litval.ival = 1) then
		      { 1 * xxx : fold out mul operation }
		      curexp := opnd2;
		    end
		  else if (opnd1^.litval.valp^.cclass = reel) and
			  (opnd1^.litval.valp^.rval = 0.0) then
		      { 0.0 * xxx : fold out mul operation }
		      curexp := opnd1
		  else if (opnd1^.litval.valp^.cclass = reel) and
			  (opnd1^.litval.valp^.rval = 1.0) then
		      { 1.0 * xxx : fold out mul operation }
		      curexp := opnd2;
		andnode:
		  if (opnd1^.litval.intval) then
		    begin
		    if (opnd1^.litval.ival = ord(false)) then
		      { false and xxx : fold out and operation }
		      curexp := opnd1
		    else if (opnd1^.litval.ival = ord(true)) then
		      { true and xxx : fold out and operation }
		      curexp := opnd2;
		    end;
		otherwise   {do nothing} ;
	      end { case }
	    else if fold_ok and (opnd2^.eclass = litnode) then
	      case eclass of
		mulnode:
		  if (opnd2^.litval.intval) then
		    begin
		    if (opnd2^.litval.ival = 0) then
		      { xxx * 0 : fold out mul operation }
		      curexp := opnd2
		    else if (opnd2^.litval.ival = 1) then
		      { xxx * 1 : fold out mul operation }
		      curexp := opnd1;
		    end
		  else if (opnd2^.litval.valp^.cclass = reel) and
			  (opnd2^.litval.valp^.rval = 0.0) then
		      { xxx * 0.0 : fold out mul operation }
		      curexp := opnd2
		  else if (opnd2^.litval.valp^.cclass = reel) and
			  (opnd2^.litval.valp^.rval = 1.0) then
		      { xxx * 1.0 : fold out mul operation }
		      curexp := opnd1;
		divnode:
		  if (opnd2^.litval.intval) then
		    begin
		    if (opnd2^.litval.ival = 1) then
		      { xxx DIV 1 : fold out DIV operation }
		      curexp := opnd1;
		    end
		  else if (opnd2^.litval.valp^.cclass = reel) and
			  (opnd2^.litval.valp^.rval = 1.0) then
		    { xxx / 1.0 : fold out division operation }
		    curexp := opnd1;
		andnode:
		  if (opnd2^.litval.intval) then
		    begin
		    if (opnd2^.litval.ival = ord(false)) then
		      { xxx and false : fold out and operation }
		      curexp := opnd2
		    else if (opnd2^.litval.ival = ord(true)) then
		      { xxx and true : fold out and operation }
		      curexp := opnd1;
		    end;
		otherwise   {do nothing} ;
	      end; { case }
	    end; (*types <> nil*)
	  end (*with curexp^*)
	end (*muloptypecheck*);

      begin (*term*)
	factor(fsys+[mulop]);
	if (sy = mulop) and not inbody and
	   stdpasc then error(606);
	while sy = mulop do begin
	  lexp := newexpr; lop := op;
	  with lexp^ do begin
	    case op of
	      mul:       eclass := mulnode;
	      rdiv,idiv: eclass := divnode;
	      imod:      eclass := modnode;
	      andop:     eclass := andnode
	      end;
	    etyptr := curexp^.etyptr;
	    ekind := xpr;
	    opnd1 := curexp;
	    insymbol;
	    factor(fsys+[mulop]);
	    opnd2 := curexp;
	    curexp := lexp;
	    muloptypecheck
	    end (* with lexp^ *)
	  end (* sy=mulop *)
      end (*term*);

    procedure addoptypecheck;
      (* type checker for binary plus and minus, and 'or' *)
      var
	lltype,lrtype: stp;
	llval,lrval,lval: integer;
	fold_ok: boolean;
	realval: real;
	optemp : exptr;

      procedure trytomakestr(fexp: exptr);
	var
	  stretch: boolean;
	  lgth: shortint;
	begin
	with fexp^ do
	  if eclass = litnode then
	    begin
	    if etyptr = char_ptr then
	      stretch := true
	    else if litval.valp^.cclass = paofch then
	      stretch := true
	    else { struct const }
	      stretch := false;
	    if stretch then
	      begin
	      if etyptr=char_ptr then lgth := 1
	      else lgth := litval.valp^.slgth;
	      stretchpaofchar(etyptr,litval,lgth);
	      etyptr^.aisstrng := true;
	      etyptr^.unpacksize := lgth+1;
	      litval.valp^.cclass := strng;
	      end;
	    end;
	end;

      begin {addoptypecheck}
      with curexp^ do
	begin
	num_ops := opnd1^.num_ops + opnd2^.num_ops;
	fold_ok := true;
	lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
	if (lltype = nil) or (lrtype = nil) then etyptr := nil
	else
	  begin
	  if [records,files,pointer,prok] *
	     [lltype^.form,lrtype^.form] <> [] then error(134)
	  else
	    case eclass of
	      addnode,subnode:
		if lltype^.form = power then
		  begin
		  if comptypes(lltype,lrtype) then
		    begin
		    if eclass = addnode then
		      begin
		      eclass := unionnode;
		      if lltype^.setmax < lrtype^.setmax then
			etyptr := lrtype;       {Result type = larger}
		      end
		    else eclass := diffnode;    {Result type = left side}
		    end
		  else error(129);
		  end
		else if arithtype(lltype) and arithtype(lrtype) then
		  begin
		  if lltype<>lrtype then
		    begin
		    if not shortintandint(lltype,lrtype) then
		      if not trytowiden(opnd1,lrtype) then
			if not trytowiden(opnd2,lltype) then
			  error(999);   {should never get here!}
		    etyptr := opnd1^.etyptr;
		    end
		  end
		else if (eclass = addnode)
		       and strgvalue(opnd1)
		       and strgvalue(opnd2) then
		  begin
		  if stdpasc then error(606);
		  eclass := concatnode;
		  new(etyptr);
		  etyptr^ := strgptr^;
		  trytomakestr(opnd1);
		  trytomakestr(opnd2);
		  end
		else
		  begin
		  error(134);
		  fold_ok := false;
		  end;
	      ornode:
		if (lltype <> boolptr) or (lrtype <> boolptr) then
		  begin error(134); etyptr := boolptr end
	    end; (*case eclass*)
	  if fold_ok and
	     (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	    begin
	    if opnd1^.litval.intval and opnd2^.litval.intval then
	      begin llval := opnd1^.litval.ival; lrval := opnd2^.litval.ival;
	      if eclass = ornode then
		begin
		if not inbody then error(50);
		lval := ord((llval=1) or (lrval=1));
		end
	      else {addnode,subnode}
		try
		  $ovflcheck on$
		  if eclass = addnode then
		    lval := llval+lrval
		  else lval := llval-lrval;
		  $if not ovflchecking$
		    $ovflcheck off$
		  $end$
		recover
		  if escapecode = -4 then
		    error(301)
		  else escape(escapecode);
	      eclass := litnode; ekind := cnst;
	      num_ops := 1; { result of folding 2 operands }
	      with litval do
		begin intval := true; ival := lval end;
	      end
	    else if inbody and (etyptr = realptr) and
		    ((not MC68020) or (float = flt_off)) then
	      begin
	      try
		if eclass = addnode then
		  realval := opnd1^.litval.valp^.rval +
			     opnd2^.litval.valp^.rval
		else { ecalss = subnode }
		  realval := opnd1^.litval.valp^.rval -
			     opnd2^.litval.valp^.rval;
	      recover
		if (escapecode = -6) or (escapecode = -7) then
		  begin
		  error(301);
		  realval := 0.0;
		  end
		else
		  escape(escapecode);
	      eclass := litnode;
	      ekind := cnst;
	      num_ops := 1; { result of folding 2 operands }
	      with litval do
		begin intval := false;
		new(valp,true,reel);
		valp^.rval := realval;
		valp^.cclass := reel;
		end;
	      end;
	    end
	  else if fold_ok and (opnd1^.eclass = litnode) then
	    case eclass of
	      addnode:
		if (opnd1^.litval.intval) then
		  begin
		  if (opnd1^.litval.ival = 0) then
		    { 0 + xxx : fold out the add operation }
		    curexp := opnd2;
		  end
		else if (opnd1^.litval.valp^.cclass = reel) and
			(opnd1^.litval.valp^.rval = 0) then
		  { 0.0 + xxx : fold out the add operation }
		  curexp := opnd2;
	      subnode:
		if (opnd1^.litval.intval) then
		  begin
		  if (opnd1^.litval.ival=0) then
		    begin { 0 - xxx : turn subtract into a negate node }
		    optemp := opnd2;
		    eclass := negnode;
		    opnd := optemp;
		    num_ops := optemp^.num_ops;
		    end;
		  end
		else if (opnd1^.litval.valp^.cclass = reel) and
			(opnd1^.litval.valp^.rval = 0) then
		  begin { 0.0 - xxx : turn subtract into a negate node }
		  optemp := opnd2;
		  eclass := negnode;
		  opnd := optemp;
		  num_ops := optemp^.num_ops;
		  end;
	      ornode:
		if (opnd1^.litval.intval) and
		   (opnd1^.litval.ival = ord(true)) then
		  { true or xxx : fold out the or operation }
		  curexp := opnd1
		else if (opnd1^.litval.intval) and
		   (opnd1^.litval.ival = ord(false)) then
		  { false or xxx : fold out the or operation }
		  curexp := opnd2;
	      otherwise   {do nothing} ;
	    end
	  else if fold_ok and (opnd2^.eclass = litnode) then
	    case eclass of
	      addnode:
		if (opnd2^.litval.intval) then
		  begin
		  if (opnd2^.litval.ival = 0) then
		    { xxx + 0 : fold out the add operation }
		    curexp := opnd1;
		  end
		else if (opnd2^.litval.valp^.cclass = reel) and
			(opnd2^.litval.valp^.rval = 0) then
		  { xxx + 0.0 : fold out the add operation }
		  curexp := opnd1;
	      subnode:
		if (opnd2^.litval.intval) then
		  begin
		  if (opnd2^.litval.ival=0) then
		    { xxx - 0 : fold out the subtract operation }
		    curexp := opnd1;
		  end
		else if (opnd2^.litval.valp^.cclass = reel) and
			(opnd2^.litval.valp^.rval = 0) then
		  { xxx - 0.0 : fold out the subtract node }
		  curexp := opnd1;
	      ornode:
		if (opnd2^.litval.intval) and
		   (opnd2^.litval.ival = ord(true)) then
		  { xxx or true : fold out the or operation }
		  curexp := opnd2
		else if (opnd2^.litval.intval) and
		   (opnd2^.litval.ival = ord(false)) then
		  { xxx or false : fold out the or operation }
		  curexp := opnd1;
	      otherwise   {do nothing} ;
	    end; { case }
	  end; (*types <> nil*)
	end; (*with curexp^*)
      end (*addoptypecheck*);

    begin (*simpleexpression*)
      lsigned := false;
      if sy = addop then
	if op in [plus,minus] then
	  begin lsigned := true; lpositive := (op=plus);
	  uminus := not lpositive; insymbol; uminus := false;
	  sywaslit := (sy = intconst) or (sy = realconst);
	  end;
      term(fsys+[addop]);
      if lsigned then
	with curexp^ do
	  if etyptr <> nil then
	    if not arithtype(etyptr) then error(105)
	    else if not (lpositive or sywaslit) then
	      if (eclass = litnode) and
		 (etyptr = intptr) then
		if litval.ival = minint then error(661)
		else litval.ival := -litval.ival
	      else if (eclass = litnode) and
		      (etyptr = realptr) then
		litval.valp^.rval:= -litval.valp^.rval
	      else
		begin lexp := newexpr;
		with lexp^ do
		  begin etyptr := curexp^.etyptr;
		  eclass := negnode; ekind := xpr;
		  opnd := curexp;
		  end;
		curexp := lexp
		end;
      if (sy = addop) and not inbody and
	 stdpasc then error(606);
      while sy = addop do
	begin
	lexp := newexpr;
	with lexp^ do begin
	  case op of
	    plus:  eclass := addnode;
	    minus: eclass := subnode;
	    orop:  eclass := ornode
	    end;
	  etyptr := curexp^.etyptr;
	  ekind := xpr;
	  opnd1 := curexp;
	  insymbol;
	  term(fsys+[addop]);
	  opnd2 := curexp;
	  curexp := lexp;
	  addoptypecheck
	  end (* with lexp^ *)
	end (* sy=addop *)
    end (*simpleexpression*);

  procedure reltypecheck;
    (* checks operands of the relational node ref'd by curexp *)
    var
      lltype,lrtype: stp;
      llval,lrval: integer;
      lclass: exprs;
      l_realval,r_realval: real;
      is_in : boolean;                  (* is element in set ? *)
  $if bigsets$
      j : shortint;                     (* simple local counter *)
      s : setrecptr;                    (* current set record item *)
      bias, rel_elem: shortint;         (* ordinal bias and relative
						element value in list *)
  $end$

    procedure check_for_special_situation(opnd1,opnd2 : exptr);
      { Bug fix for the specific situation of a character literal begin
	compared with an empty packed array of char literal. ('A' = '')
	This is allowed because packed array of char literals can be
	padded with blanks. }
      begin
      $PARTIAL_EVAL ON$
      with opnd2^.etyptr^ do
	if (opnd1^.etyptr = char_ptr) and (opnd1^.eclass = litnode) and
	   paofchar(opnd2^.etyptr) and (not {opnd2^.etyptr^.}aisstrng) and
	   isPAC({opnd2^.etyptr^.}inxtype) and
	   ({opnd2^.etyptr^.}inxtype^.max = 0) then
	  {Change char literal to a packed array of char literal of length 1}
	  stretchpaofchar(opnd1^.etyptr,opnd1^.litval,1);

      $IF not partialevaling$
	$PARTIAL_EVAL OFF$
      $END$
      end;

    begin
    with curexp^ do
      begin
      num_ops := opnd1^.num_ops + opnd2^.num_ops;
      lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
      if (lltype <> nil) and (lrtype <> nil) then
	if eclass = innode then
	  begin
	  if lrtype^.form <> power then error(130)
	  else if not comptypes(lltype,lrtype^.elset) then error(129);
	  if opnd1^.eclass = litnode then
	    if not opnd1^.litval.intval or (opnd1^.litval.ival<setlow)
	      or (opnd1^.litval.ival>sethigh) then error(182)
	    else if opnd2^.eclass = litnode then
	      begin ekind := cnst; eclass := litnode;
  $if bigsets$
	      bias := opnd1^.litval.ival DIV (oldsethigh + 1);
	      rel_elem := opnd1^.litval.ival MOD (oldsethigh + 1);
	      s := opnd2^.litval.valp^.pval;
	      is_in := false;
	      if s <> NIL then
		begin
		  j := 0;
		  while ( (s^.nxt <> NIL) and (j < bias) ) do
		    begin
			s := s^.nxt;
			j := j + 1;
		    end;
		  if j = bias then
		    is_in := rel_elem in s^.val;
		end;
  $end$
  $if not bigsets$
	      is_in := opnd1^.litval.ival in opnd2^.litval.valp^.pval;
  $end$
	      llval := ord( is_in );
	      with litval do
		begin intval := true; ival := llval end;
	      end;
	  end
	else
	  begin (* relational op *)
	  if lltype <> lrtype then      {check for arithmetic widening}
	    if arithtype(lltype) and arithtype(lrtype) then
	      begin
	      if not shortintandint(lltype,lrtype) then
		if not trytowiden(opnd1,lrtype) then
		  if not trytowiden(opnd2,lltype) then
		    error(999);     {should never get here!}
	      lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
	      end;
	  if comptypes(lltype,lrtype) then
	    begin
	    case lltype^.form of
	      pointer:
		if not (eclass in [eqnode,nenode]) then error(131);
	      prok:
		if eclass in [eqnode,nenode] then
		  begin
		  if (opnd1^.ekind = cnst) and (opnd2^.ekind = cnst) then
		    begin lclass := eclass; eclass := litnode;
		    ekind := cnst; litval.intval := true;
		    if opnd1^.symptr = opnd2^.symptr
		      then litval.ival := ord(lclass = eqnode)
		      else litval.ival := ord(lclass = nenode);
		    end;
		  end
		else error(131);
	      power: case eclass of
		       lenode: eclass := subsetnode;
		       genode: eclass := supersetnode;
		       ltnode,gtnode: error(132);
		       otherwise
		       end;
	      arrays: if not paofchar(lltype) then error(133);
	      records,files: error(133);
	      cnfarrays: error(133);
	      otherwise
	      end; (*case*)
	    if (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	      if opnd1^.litval.intval and opnd2^.litval.intval then
		begin
		if not inbody then error(50);
		llval := opnd1^.litval.ival;
		lrval := opnd2^.litval.ival;
		lclass := eclass; eclass := litnode; ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		with litval do
		  begin intval := true;
		  case lclass of
		    ltnode: ival := ord(llval <  lrval);
		    lenode: ival := ord(llval <= lrval);
		    gtnode: ival := ord(llval >   lrval);
		    genode: ival := ord(llval >=  lrval);
		    eqnode: ival := ord(llval =   lrval);
		    nenode: ival := ord(llval <>  lrval);
		    end;
		  end;
		end
	      else if inbody and (etyptr = realptr) then
		begin
		l_realval := opnd1^.litval.valp^.rval;
		r_realval := opnd2^.litval.valp^.rval;
		with litval do
		  begin
		  intval := true;
		  case eclass of
		    ltnode: ival := ord(l_realval <  r_realval);
		    lenode: ival := ord(l_realval <= r_realval);
		    gtnode: ival := ord(l_realval >  r_realval);
		    genode: ival := ord(l_realval >= r_realval);
		    eqnode: ival := ord(l_realval =  r_realval);
		    nenode: ival := ord(l_realval <> r_realval);
		  end; { case }
		  end; { with litval }
		eclass := litnode;
		ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		end;
	    end {compatible types}
	  else
	    begin
	    check_for_special_situation(opnd1,opnd2);
	    check_for_special_situation(opnd2,opnd1);
	    if not paofcharcomp(opnd1,opnd2^.etyptr) then
	      if not paofcharcomp(opnd2,opnd1^.etyptr) then
		error(129);
	    end;
	  end (*relational op*)
      end (*with curexp^*)
    end (*reltypecheck*);

  begin (*expression*)
    simpleexpression(fsys+[relop]);
    if sy = relop then
      begin
      if not inbody and stdpasc then error(606);
      lexp := newexpr;
      with lexp^ do begin
	case op of
	  ltop: eclass := ltnode;
	  leop: eclass := lenode;
	  geop: eclass := genode;
	  gtop: eclass := gtnode;
	  neop: eclass := nenode;
	  eqop: eclass := eqnode;
	  inop: eclass := innode
	  end;
	ekind := xpr;
	etyptr := boolptr;
	opnd1 := curexp;
	insymbol;
	simpleexpression(fsys);
	opnd2 := curexp
	end;
      curexp := lexp;
      reltypecheck
      end (* sy = relop *)
  end (*expression*);

@


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


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 1797
			{file EXPRESSION}

procedure funcref (fcp: ctp; fsys: setofsys);
  (* create tree for function reference *)
  var
    lexp: exptr;
    parmptr: ctp;
    tp: elistptr;
    realval: real;

  procedure splfuncref;
    (* reference to special function *)
    var lexp: exptr; lval,lmin,lmax: integer;
	sexp: elistptr; s: string[255];
	waslparent,folded: boolean;

    procedure wsscan;
      { Process scan     (bytecount, <relop>testchar, source): integer }
      var ex1,ex2,ex3: elistptr;
      begin
      with lexp^ do
       begin eclass := fcallnode; ekind := xpr;
	etyptr := intptr; fptr := fcp;
	ex1 := integerparm(fsys);
	if sy=comma then insymbol else error(20);
	if sy=relop then
	  begin if op = eqop then actualp := makeintparm(0)     {scanuntil}
	    else if op = neop then actualp := makeintparm(1)    {scanwhile}
	    else begin actualp := makeintparm(0); error(125); end;
	    insymbol;
	  end
	else begin actualp := makeintparm(0); error(125); end;
	ex2 := charparm(fsys);
	if sy=comma then insymbol else error(20);
	ex3 := anyparm(fsys,false);
	actualp^.nextptr := ex3;   {link parameters in same order as scanwhile}
	ex3^.nextptr := ex2;
	ex2^.nextptr := ex1;
       end;
      end;

    procedure addr;
      { Process addr (variable [,offset]): anyptr }
      {   &  absaddr (variable [,offset]): anyabsptr }
      begin
      with lexp^ do
	begin eclass := fcallnode; ekind := xpr; fptr := fcp;
	etyptr := anyptrptr;
	actualp := anyparm(fsys,false);
	with actualp^.expptr^ do
	  if (ekind = cnst) and (etyptr <> nil) then
	    if etyptr^.form = prok then error(125)
	    else
	      warning(linenumber+1,
		'''ADDR'' of a constant may not be supported on other implementations');
	if sy <> comma then actualp^.nextptr := nil
	else begin insymbol; actualp^.nextptr := integerparm(fsys); end;
	end;
      end (*addr*);

    procedure blockio;
      { Process blockread/write(file, buffer, nblocks [, blocknum]): integer }
      var lxlp: elistptr;
      begin
      with lexp^ do
       begin eclass := fcallnode; ekind := xpr;
	 etyptr := intptr; fptr := fcp;
	 lxlp := fileparm(fsys,untyped); actualp := lxlp;
	 if sy = comma then insymbol else error(20);
	 lxlp^.nextptr := anyparm(fsys,fcp^.spkey=spblockread);
	 lxlp:=lxlp^.nextptr; if sy = comma then insymbol else error(20);
	 lxlp^.nextptr := integerparm(fsys); lxlp := lxlp^.nextptr;
	 if sy <> comma then lxlp^.nextptr := makeintparm(-1)
	 else begin insymbol; lxlp^.nextptr := integerparm(fsys); end;
       end;
      end (*blockio*);

    procedure sizefunc;
      {SIZEOF function}
      var lcp,lcp2: ctp; lsp: stp; lsize: addrrange;
      begin
      lsp := nil; lsize := 0;
      if sy=ident then
	begin                   {get type of type name or identifier}
	searchid([types,konst,vars,field],lcp);
	if lcp^.klass = types then              {type name}
	  begin lsp := lcp^.idtype;
	  if lsp=strgptr then error(125);
	  insymbol;
	  end
	else                                    {variable name}
	  begin
	  identproc(fsys+[comma,rparent]);
	  lsp := curexp^.etyptr;
	  lcp2 := NIL;
	  if curexp^.eclass = selnnode then
	    lcp2 := curexp^.fieldptr
	  else if curexp^.eclass = unqualfldnode then
	    lcp2 := curexp^.fieldref;
	  if (lcp2 <> NIL) and (not allow_packed) then
	    if lcp2^.klass = field then
	      if lcp2^.fispackd then
		error(125)
	      else if lcp2^.strucwaspackd then
		error(125);
	  end;
	if lsp <> nil then      {remember size; set LSP = TAGFIELD struct}
	  with lsp^ do
	    begin lsize := unpacksize;
	      if sizeoflo then error(672);
	      if form = records then lsp := recvar else lsp := nil;
	    end;
	end
      else error(2);
      getvariantsize(fsys, lsp, lsize);         {look for variants}
      with lexp^ do             {return an integer constant expression}
	begin
	eclass := litnode; ekind := cnst;
	etyptr := intptr; litval.intval := true;
	litval.ival := lsize;
	end;
      end; {sizefunc}

    begin (*splfuncref*)
    with fcp^ do
      begin
      insymbol;
      if sy = lparent then
	begin insymbol; waslparent := true end
      else
	begin waslparent := false;
	if (spkey <> speof) and
	   (spkey <> speoln) then error(9);
	end;
      if spkey in [spabs..spsucc] then expression(fsys+[rparent]);
      lexp := newexpr;
      case spkey of
	spabs,spsqr:
	  begin
	  with curexp^ do
	    if etyptr <> nil then
	      if not arithtype(etyptr) then error(125);
	  with lexp^ do
	    begin etyptr := curexp^.etyptr; folded := false;
	    if curexp^.eclass = litnode then
	      if spkey = spabs then
		begin
		eclass := litnode;
		ekind := cnst;
		folded := true;
		with litval do
		  if etyptr = intptr then
		    try
		      $ovflcheck on$
		      intval := true;
		      ival := abs(curexp^.litval.ival);
		      $if not ovflchecking$
			$ovflcheck off$
		      $end$
		    recover
		      begin
		      if escapecode = -4 then
			error(301);
		      end
		  else if etyptr = realptr then
		    begin
		    if not inbody then error(50);
		    intval := false;
		    new(valp,true,reel);
		    valp^.cclass := reel;
		    valp^.rval := abs(curexp^.litval.valp^.rval);
		    end
		  else {error}
		    begin
		    intval := true;
		    ival := 0;
		    etyptr := nil;
		    end;
		end
	      else {sqrnode}
		if curexp^.litval.intval and
		   ((not MC68020) or (float = flt_off)) then
		  try
		    $ovflcheck on$
		    lval := sqr(curexp^.litval.ival);
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		    folded := true;
		    eclass := litnode; ekind := cnst;
		    with litval do
		      begin intval := true; ival := lval end;
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode);
	    if not folded then
	      begin ekind := xpr; opnd := curexp;
	      if spkey = spsqr then eclass := sqrnode
	      else eclass := absnode;
	      end;
	    end;
	  end;
	spchr:
	  begin
	  with curexp^ do
	    if (etyptr <> nil) and (etyptr <> intptr)
	      and (etyptr <> shortintptr) then error(125);
	  with lexp^ do
	     begin eclass := chrnode; ekind := xpr;
	     etyptr := char_ptr; opnd := curexp;
	     if curexp^.eclass = litnode then
	       with curexp^.litval do
		 if not intval then error(125)
		 else if (ival<0) or (ival>255) then error(125)
		 else begin
		   eclass := litnode; ekind := cnst;
		   litval := curexp^.litval;
		   end;
	     end; {with lexp^}
	  end;
	spodd:
	  begin
	  with curexp^ do
	    if (etyptr<>nil) and (etyptr<>intptr)
	      and (etyptr <> shortintptr) then error(125);
	  with lexp^ do
	    begin etyptr := boolptr;
	    if curexp^.eclass = litnode then
	      begin ekind := cnst; eclass := litnode;
	      with litval do
		begin intval := true;
		ival := ord(odd(curexp^.litval.ival))
		end;
	      end
	    else {operand not constant}
	      begin eclass := oddnode; ekind := xpr; opnd := curexp end;
	    end; {with lexp^}
	  end;
	spord:
	  begin
	  with curexp^ do
	    if etyptr <> nil then
	      if not (etyptr^.form in [scalar,subrange,pointer])
		then error(125);
	  with lexp^ do
	    begin etyptr := intptr;
	    if curexp^.eclass <> litnode then
	      begin eclass := ordnode; ekind := xpr;
	      opnd := curexp;
	      end
	    else begin
	      eclass := litnode; ekind := cnst;
	      litval := curexp^.litval;
	      end;
	    end;
	  end;
	spstrlen,splength:
	  with lexp^ do
	    begin etyptr := intptr;
	    folded := false;
	    if curexp^.etyptr <> nil then
	      if not strgvalue(curexp) then
		error(125)
	      else if curexp^.eclass=litnode then
		if curexp^.etyptr=char_ptr then
		  begin litval.ival := 1;
		  folded := true;
		  end
		else
		  with curexp^.litval.valp^ do
		   if cclass = paofch then
		     begin litval.ival := slgth;
		     folded := true;
		     end;
	    if not folded then
	      begin eclass := strlennode;
	      ekind := xpr; opnd := curexp;
	      end
	    else
	      begin eclass := litnode;
	      ekind := cnst;
	      litval.intval := true;
	      end;
	    end;
	spstrmax:
	  with lexp^ do
	    begin etyptr := intptr;
	    eclass := strmaxnode;
	    ekind := xpr; opnd := curexp;
	    if curexp^.etyptr <> nil then
	      if not strgtype(curexp^.etyptr) then
		error(125)
	      else if curexp^.ekind<>vrbl then
		error(125)
	      else if curexp^.etyptr<>strgptr then
		begin eclass := litnode;
		ekind := cnst;
		with litval do
		  begin intval := true;
		  ival := curexp^.etyptr^.maxleng;
		  end;
		end;
	    end;
	spconcat:
	  with lexp^, fcp^ do
	    begin eclass := fcallnode;
	    fptr := fcp; ekind := xpr;
	    etyptr := idtype; sexp := stringparm(fsys);
	    actualp := sexp;
	    while sy = comma do
	      begin insymbol;
	      sexp^.nextptr := stringparm(fsys); sexp := sexp^.nextptr;
	      end;
	    end;
	spround,sptrunc:
	  begin
	  with curexp^ do
	    if etyptr<>nil then
	      if etyptr<>realptr then error(125);
	  with lexp^ do
	    begin
	    if spkey = sptrunc then eclass := truncnode
	    else eclass := roundnode;
	    ekind := xpr; etyptr := intptr; opnd := curexp;
	    end;
	  end;
	sppred,spsucc:
	  begin
	  with curexp^ do
	    begin lmin := minint; lmax := maxint;
	    if etyptr <> nil then
	      with etyptr^ do
		if form > subrange then
		   error(125)
		else if form = subrange then
		  getbounds(rangetype,lmin,lmax)
		else getbounds(etyptr,lmin,lmax);
	    folded := false;
	    if eclass = litnode then
	      with litval do
		if intval then
		  try
		    $ovflcheck on$
		    if spkey = spsucc then lval := ival+1
		    else lval := ival-1;
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		    folded := true;
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode) ;
	    end; {with curexp^}
	  with lexp^ do
	    begin etyptr := curexp^.etyptr;
	    if folded then
	      begin eclass := litnode; ekind := cnst;
	      with litval do
		begin intval := true;
		ival := lval;
		if (lval<lmin) or (lval>lmax) then
		  error(303);
		end;
	      end
	    else
	      begin ekind := xpr;
	      if spkey = spsucc
		then eclass := succnode
		else eclass := prednode;
	      opnd := curexp;
	      end; {not folded}
	    end; {with lexp^}
	  end;
	spaddr: addr;
	spsizeof: sizefunc;
	spscan: wsscan;
	spblockread, spblockwrite: blockio;
	spmaxpos,spposition,splinepos:
	  with lexp^ do
	    begin eclass := fcallnode; ekind := xpr;
	    etyptr := intptr; fptr := fcp;
	    if spkey = splinepos then
	      begin error(651);
	      if waslparent then
		actualp := fileparm(fsys,textphile);
	      end
	    else actualp := fileparm(fsys,directfile);
	    end;
	sphex,spoctal,spbinary:
	  with lexp^ do
	    begin eclass := fcallnode;
	    ekind := xpr; etyptr := intptr;
	    fptr := fcp;
	    actualp := stringparm(fsys);
	    folded := false;
	    with actualp^.expptr^ do
	      if (eclass=litnode)
		  and not litval.intval then
		with litval.valp^ do
		  if cclass=strng then
		    begin setstrlen(s,slgth);
		    moveleft(sval[1],s[1],slgth);
		    folded := true;
		    end;
	    if folded then
	      try
		case spkey of
		  sphex:    lval := hex(s);
		  spoctal:  lval := octal(s);
		  spbinary: lval := binary(s);
		  end;
		eclass := litnode; ekind := cnst;
		litval.intval := true;
		litval.ival := lval;
	      recover
		if inbody then
		  {not called by constant so
		   give the error here} error(50);
	    end;
	speoln,speof:
	  with lexp^ do
	    begin eclass := fcallnode;
	    ekind := xpr; etyptr := boolptr;
	    fptr := fcp;
	    if waslparent then
	      if spkey = speof then
		actualp := fileparm(fsys,any)
	      else actualp := fileparm(fsys,textphile)
	    else
	      begin
	      actualp := newexplist;
	      if inputptr <> NIL then
		actualp^.expptr := makefileexp(inputptr)
	      else
		begin
		error(185);
		actualp^.expptr := NIL;
		end;
	      end;
	    end;
	otherwise error(651)
	end; (*case spkey*)
      end; (*with fcp^*)
    curexp := lexp;
    if waslparent then
      if sy = rparent then insymbol else error(4);
    end (*splfuncref*);

  begin (*funcref*)
  if not inbody and stdpasc then error(606);
  with fcp^ do
    if (klass = func) and (pfdeckind = special) then
      splfuncref
    else
      begin (* standard or declared func *)
      insymbol; lexp := newexpr;
      with lexp^ do
	begin eclass := fcallnode;
	ekind := xpr; etyptr := idtype;
	actualp := nil; fptr := fcp;
	if klass = func then parmptr := next
	else parmptr := proktype^.params;
	if sy = lparent then
	  begin
	  actparmlist(fsys,actualp,parmptr);
	  if sy = rparent then insymbol
			  else error(4);
	  if (klass = func) and (pfdeckind = standard) then
	    if (spkey = spstrpos) then
	      if switch_strpos then
		with lexp^ do
		  begin { switch parameters }
		  actualp^.nextptr^.nextptr := actualp;
		  actualp := actualp^.nextptr;
		  actualp^.nextptr^.nextptr := NIL;
		  end
	      else
		if strpos_warn then
		  warning(linenumber+1,
		  'STRPOS does not conform to HP standard, see $SWITCH_STRPOS$')
	    else if (spkey in [spsin,spcos,spsqrt,spln,spexp,sparctan]) then
	      with actualp^ do
		if (expptr^.eclass = litnode) and
		   ((not MC68020) or (float = flt_off)) then
		  begin
		  try
		    with expptr^.litval.valp^ do
		      case spkey of
			spsin:     realval := sin(rval);
			spcos:     realval := cos(rval);
			spsqrt:    realval := sqrt(rval);
			spln:      realval := ln(rval);
			spexp:     realval := exp(rval);
			sparctan:  realval := arctan(rval);
		      end; {case}
		  recover
		    if (escapecode = -6) or (escapecode = -7) or
		       ((escapecode <= -15) and (escapecode >= -17)) then
		      begin
		      error(50);
		      realval := 0.0;
		      end
		    else
		      escape(escapecode);
		  eclass := litnode;
		  ekind := cnst;
		  litval.intval := false;
		  litval.valp := opnd^.litval.valp;
		  litval.valp^.rval := realval;
		  litval.valp^.cclass := reel;
		  end;
	  end
	else if parmptr <> nil then error(126)
	end; (* with lexp^ *)
      curexp := lexp;
      if curexp^.eclass = fcallnode then
	tp := curexp^.actualp
      else
	tp := NIL;
      curexp^.num_ops := 0;
      while tp <> NIL do
	begin
	if tp^.expptr^.num_ops > curexp^.num_ops then
	  curexp^.num_ops := tp^.expptr^.num_ops;
	tp := tp^.nextptr;
	end;
      if klass = routineparm then
	begin {make func id the first param}
	tp := newexplist;
	tp^.nextptr := curexp^.actualp;
	curexp^.actualp := tp;
	tp^.expptr := newexpr;
	with tp^.expptr^ do
	  begin ekind := vrbl; eclass := idnode;
	  etyptr := proktype; symptr := curexp^.fptr;
	  end;
	end; {routineparm}
      end; (* standard or declared func *)
  end (*funcref*);

procedure setdeno (*fsys: setofsys; settype: stp*);
  label 1;
  var unknowntype,hascstpart,hasvarpart,ldone: boolean;
      setexp,lexp: exptr; lxlp: elistptr; lsp: stp;
  $if bigsets$
      constpart: setrecptr;             (* head of set record list *)
      endptr : setrecptr;               (* tail of set record list *)
      s : setrecptr;                    (* current set record *)
      j : shortint;                      (* simple counter *)
      bias : shortint;                  (* set list ordinal bias index *)
      rel_elem : shortint;              (* bias relative element value *)
      max_bias : shortint;              (* max ordinal bias *)
      high_bias : shortint;             (* range high bias *)
      cur_bias : shortint;              (* current ordinal bias *)
      rel_high : shortint;         (* current bias's high relative ord *)
  $end$
  $if not bigsets$
      constpart: set of SETLOW..SETHIGH;
  $end$
       lmin,lmax,i: integer;

  begin insymbol;
  unknowntype := (settype=nil);
  if unknowntype then
    begin
    new(settype,power);
    with settype^ do   (*create new set type*)
      begin form := power; elset := nil;
      ispackable := false; sizeoflo := false;
$if bigsets$
      unpacksize := SETDEFAULTSIZE; align := SETALIGN;
      setmin := SETLOW; setmax := SETDEFAULTHIGH;
$end$
$if not bigsets$
      unpacksize := SETSIZE; align := SETALIGN;
      setmin := SETLOW; setmax := SETHIGH;
$end$
      info := sysinfo;
      end;
    end;
  setexp := newexpr;
  with setexp^ do
    begin eclass := setdenonode; ekind := xpr;
    etyptr := settype; setcstpart.intval := false;
    setcstpart.valp := nil; setvarpart := nil;
    end;
$if bigsets$
  constpart := NIL;
  endptr := NIL;
  max_bias := -1;
  cur_bias := -1;
$end$
$if not bigsets$
  constpart := [];
$end$
  hascstpart:=false; hasvarpart:=false;
  if sy <> rbrack then
    repeat expression(fsys+[comma,rbrack,rangesy]);
      lexp := curexp; lsp := curexp^.etyptr;
      if lsp<>nil then
	if unknowntype then
	  begin
	  if lsp^.form <> scalar then error(136)
	  else begin
	       settype^.elset := lsp; unknowntype := false;
	       if (lsp<>intptr) and (lsp<>shortintptr) then
		 begin
		 getbounds(lsp,lmin,lmax);
		 if lmax > SETHIGH then error(658)
		 else
		   with settype^ do
		      begin
		      setmax := lmax;
		(***  if lmax+1 < bitsperword then
			begin ispackable := true; signbit := false;
			  bitsize := lmax+1
			end;  ***)
		      unpacksize := setlensize + SETELEMSIZE *
			      ((lmax + setelembits) div setelembits)
		      end
		 end
	       end
	  end
	else  {set type is known}
	  begin
	  if not comptypes(lsp,settype^.elset) then error(137);
	  end;
      if sy = rangesy then
	begin insymbol; expression(fsys+[comma,rbrack]);
	  if not comptypes(lsp,curexp^.etyptr) then error(137);
	end;
      if (lexp^.eclass=litnode) and (curexp^.eclass=litnode)
	 and not unknowntype then
	begin         {constant element}
	if not lexp^.litval.intval or not curexp^.litval.intval
	   or (lexp^.litval.ival < settype^.setmin)
	   or (curexp^.litval.ival > settype^.setmax) then
	     error(182)
	else if lexp^.litval.ival >
		curexp^.litval.ival then error(50)
	else
   $if bigsets$
	  begin
	    high_bias := curexp^.litval.ival div (oldsethigh+1);
	    i := lexp^.litval.ival;
	    repeat
		  bias := i div (oldsethigh+1);
		  rel_elem := i mod (oldsethigh+1);
		  if ( bias > max_bias ) then (* need new chunk(s) for set *)
			begin
			  repeat
			      max_bias := max_bias + 1;
			      new( s );
			      with s^ do
				begin
				  nxt := NIL;
				  val := [];
				end;
			      if ( endptr <> NIL ) then
				begin                   (* add to end/list *)
				  endptr^.nxt := s;
				  endptr := s;
				end
			      else
				begin                   (* begin new list *)
				  endptr := s;
				  constpart := s;
				end;
			  until max_bias = bias;
			end
		      else              (* fits in current chunk list *)
			begin
			s := constpart;
			for j := 0 to (bias - 1) do s := s^.nxt;
			end;
		  cur_bias := bias;
		  if bias = high_bias then
		    rel_high := curexp^.litval.ival mod (oldsethigh+1)
		  else
		    rel_high := oldsethigh;
		  for j := rel_elem to rel_high do
			s^.val := s^.val + [ j ];
		  i := i + rel_high - rel_elem + 1;
	    until ( i >= curexp^.litval.ival);
	  end;
$end$
$if not bigsets$
	  for i := lexp^.litval.ival to curexp^.litval.ival do
	       constpart := constpart + [i];
$end$
	hascstpart := true;
	end
      else
	begin         {variable element}
	if hasvarpart then
	  begin new(lxlp^.nextptr,true); lxlp := lxlp^.nextptr end
	else
	  begin new(setexp^.setvarpart); lxlp := setexp^.setvarpart end;
	with lxlp^ do
	  begin nextptr := nil; lowptr := lexp; hiptr := curexp end;
	hasvarpart := true;
	end;
      ldone := sy <> comma;
      if not ldone then insymbol;
    until ldone;
  if sy = rbrack then insymbol else error(12);
  if hasvarpart then setexp^.ekind := xpr else setexp^.ekind := cnst;
  new(setexp^.setcstpart.valp,true,pset);
  with setexp^.setcstpart.valp^ do
    begin cclass := pset; plgth:=0;  { now find highest "on" bit }
 $if bigsets$
   if constpart <> NIL then
     begin
       s :=  constpart;  bias := 0;
       while ( s^.nxt <> NIL ) do
	 begin  s := s^.nxt;  bias := bias + 1;  end;
       i := (bias+1) * (oldsethigh+1) - 1;
       if ( i > settype^.setmax ) then i := settype^.setmax;
       rel_elem := i MOD (oldsethigh + 1);
       for j := rel_elem downto 0 do
	 if j in s^.val then
	   begin
	      plgth := ( j + ( bias * (oldsethigh + 1) )  + 1 );
	      goto 1;
	   end;
     end;               (* if constpart <> NIL *)
$end$
$if not bigsets$
    for i:=settype^.setmax downto settype^.setmin do
      if i in constpart then begin plgth:=i+1; goto 1 end;
$end$
1:   pval := constpart;
    end;
  curexp := setexp
  end (*setdeno*);

procedure makedummyexpr(fcp: ctp);
  begin
  curexp := newexpr;
  with curexp^ do
    begin
    eclass := idnode;
    etyptr := NIL;
    ekind := vrbl;
    symptr := fcp;
    end;
  end;

procedure constructor (fsys: setofsys; fsp: stp);
  (* Parse a set constructor of the given type *)
  var lsp: stp; lvalu: valu;
  begin
  if stdpasc then error(606);
  if fsp = nil then
    begin
    skip(fsys+[rbrack]);
    if sy=rbrack then insymbol;
    end
  else
    if fsp^.form = power then
      setdeno(fsys,fsp)
    else
      begin
      error(655);
      skip(fsys+[rbrack]);
      if sy=rbrack then insymbol;
      makedummyexpr(uvarptr);
      end;
  end; {constructor}

procedure funcresult (fcp: ctp);
  (* create a tree for assignment to function name *)
  begin curexp := newexpr;
  with curexp^ do
    begin eclass := idnode; ekind := vrbl;
    etyptr := fcp^.idtype; symptr := fcp;
    with fcp^ do
      if klass = routineparm then error(103)
      else if pfdeckind <> declared then error(150)
      else if not inscope then error(177);
    end;
  if fcp^.pfdeckind = declared then
    fcp^.assignedto := true;
  insymbol;
  end (*funcresult*);

procedure cast(fsys: setofsys; fsp: stp);

  procedure casttypecheck(fsp1,fsp2: stp);
    var lform1,lform2: structform;
    begin
    if (fsp1<>nil) and (fsp2<>nil) then
      begin
      lform1 := fsp1^.form; lform2 := fsp2^.form;
      if (lform1 in [scalar,subrange,reals,pointer]) and
	 (lform2 in [scalar,subrange,reals,pointer]) then
	{ For FSDdt03843 : }
	begin  if fsp1^.unpacksize <> fsp2^.unpacksize then
	     begin
		if ((lform1 = pointer) and (lform2 = scalar)
		    and (fsp1^.unpacksize = 4) and (fsp2^.unpacksize = 2)
		    and (curexp^.ekind = XPR)) then
		begin { DO NOTHING }
		end
	       else
		error(134)
	     end
	end
      else if lform1 <> lform2 then error(134)
      end;
    end; {casttypecheck}

  begin {cast}
  if not modcal then error(612);
  if fsp = strgptr then error(732);
  insymbol;
  expression(fsys+[rparent]);
  if sy = rparent then insymbol else error(4);
  casttypecheck(fsp,curexp^.etyptr);
  curexp^.etyptr := fsp;
  end; {cast}

procedure assignableid (fsys: setofsys; fcp: ctp);
  (* handle lhs of assignment statement *)
  begin
  case fcp^.klass of
    types: begin insymbol;
	   if sy = lparent then
	     begin cast(fsys,fcp^.idtype);
	     selector(fsys);
	     end
	   else
	     begin
	     if modcal then error(9)
		       else error(103);
	     skip(fsys);
	     makedummyexpr(fcp);
	     end;
	   end;
    vars:  begin
	   variable(fcp);
	   selector(fsys);
	   { Check for FOR loop variable }
	   if cantassign in fcp^.info then error(702);
	   end;
    field: begin unqualfield(fcp); selector(fsys) end;
    routineparm,
    func:  begin funcresult(fcp);
	   if sy=arrow then error(6);
	   selector(fsys);
	   end;
    end;
  end (*assignableid*);

procedure identproc(*fsys: setofsys*);
  (* parse identifier in an expression *)
  var lcp: ctp;

  procedure makeroutineconst(fcp: ctp);
    var proctyp: stp;
    begin
    with fcp^ do
      if pfdeckind <> declared then error(652)
      else if klass = prox then
       if ismodulebody then error(704);
    new(proctyp,prok);
    with proctyp^ do
      begin
      ispackable := false; sizeoflo := false;
      unpacksize := PROKSIZE; align := PROKALIGN;
      info := sysinfo; params := fcp^.next;
      if fcp^.klass = prox then form := prok else form := funk;
      end;
    curexp := newexpr;
    with curexp^ do
      begin ekind := cnst; eclass := idnode;
      etyptr := proctyp; symptr := fcp;
      end;
    insymbol;
    end; {makeroutineconst}

  begin {identproc}
  if sy <> ident then error(2)
  else
    begin searchid([types,konst,vars,field,func,prox,routineparm],lcp);
    case lcp^.klass of
      types: begin insymbol;
	     if sy = lbrack then constructor(fsys,lcp^.idtype)
	     else if sy = lparent then
	       begin cast(fsys,lcp^.idtype); selector(fsys) end
	     else
	       begin error(6); skip(fsys);
	       makedummyexpr(lcp);
	       end;
	     end;
      konst: begin constid(lcp); selector(fsys) end;
      vars:  begin variable(lcp); selector(fsys) end;
      field: begin unqualfield(lcp); selector(fsys) end;
      routineparm:
	     if donteval or (lcp^.vtype = procparm) then
	       begin curexp := newexpr;
	       with curexp^ do
		 begin ekind := vrbl; eclass := idnode;
		 etyptr := lcp^.proktype; symptr := lcp;
		 end;
	       insymbol;
	       end
	     else
	       begin
	       if lcp^.vtype <> funcparm then error(103);
	       funcref(lcp,fsys); selector(fsys);
	       end;
      func:  if donteval then makeroutineconst(lcp)
	     else
	       begin funcref(lcp,fsys); selector(fsys) end;
      prox:  makeroutineconst(lcp);
      end; {case}
    with curexp^ do
      if etyptr <> nil then
	if (etyptr^.form = subrange) and not varparm then
	  etyptr := etyptr^.rangetype;
    end; (*sy = ident*)
  end; (*identproc*)

procedure expression (*fsys: setofsys*);
  var lexp: exptr;

  procedure simpleexpression (fsys: setofsys);
    var lsigned,lpositive,sywaslit: boolean;
	lexp: exptr;

    procedure term (fsys: setofsys);
      var lexp: exptr; lop: operator;

      procedure factor (fsys: setofsys);
	var oldvarparm: boolean;

	procedure notoperation (fsys: setofsys);
	  var lnot: exptr;
	  begin
	  insymbol; factor(fsys);
	  with curexp^ do
	    begin if (etyptr <> nil) and (etyptr <> boolptr) then error(135);
	    if (ekind = xpr) and
	       (eclass in [eqnode,nenode,ltnode,lenode,gtnode,genode]) then
	      case eclass of
		eqnode: eclass := nenode;
		nenode: eclass := eqnode;
		ltnode: eclass := genode;
		lenode: eclass := gtnode;
		gtnode: eclass := lenode;
		genode: eclass := ltnode;
		end
	    else begin
	      lnot := newexpr;
	      with lnot^ do
		begin etyptr := boolptr;
		if curexp^.eclass <> litnode then
		  begin
		  ekind := xpr;
		  eclass := notnode;
		  opnd := curexp;
		  num_ops := opnd^.num_ops;
		  end
		else {fold}
		  begin
		  if not inbody then error(50);
		  ekind := cnst; eclass := litnode;
		  with litval do
		    begin intval := true;
		    ival := abs(curexp^.litval.ival-1);
		    end;
		  end;
		end; {with lnot^}
	      curexp := lnot;
	      end;
	    end; {with curexp^}
	  end (*notoperation*);

	begin (*factor*)
	  if not (sy in facbegsys) then
	    begin error(58);
	    skip(fsys+facbegsys);
	    if not (sy in facbegsys) then
	      curexp := newexpr;
	    end;
	  while sy in facbegsys do
	    begin
	    oldvarparm := varparm;
	    if sy<>ident then varparm := false;
	    case sy of
	      intconst,
	      realconst,
	      stringconst:
		begin oldvarparm := varparm;
		varparm := false;
		literals;
		varparm := oldvarparm;
		end;
	      ident:
		identproc(fsys);
	      lbrack:
		begin oldvarparm := varparm;
		varparm := false;
		setdeno(fsys,nil);
		varparm := oldvarparm;
		end;
	      notsy:
		notoperation(fsys);
	      lparent:
		begin insymbol;
		expression(fsys+[rparent]);
		if (curexp <> NIL) and (curexp^.ekind = vrbl) then
		  curexp^.ekind := xpr;
		if not inbody and
		  (curexp^.etyptr=realptr)
		    then error(750);
		if sy = rparent then insymbol
		else error(4)
		end;
	      end; (*case*)
	    if not (sy in fsys) then
	      begin error(6); skip(fsys+facbegsys) end
	    end; (*while*)
	end (*factor*);

      procedure muloptypecheck;
	(* type checker, constant folder for '*','/','div','mod','and' *)
	var
	  lltype,lrtype: stp;
	  llval,lrval,lval: integer;
	  res: integer; exptemp: exptr;
	  fold_ok: boolean;
	  realval: real;

	procedure powerof2(fexp: exptr; var res: integer);
	  var i: integer;
	  begin
	  res := 0;
	  with fexp^.litval do
	    if intval then
	      for i := 1 to 14 do
		if ival = power_table[i] then res := i;
	  end;

	begin {muloptypecheck}
	with curexp^ do
	  begin
	  fold_ok := true;
	  num_ops := opnd1^.num_ops + opnd2^.num_ops;
	  lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
	  if (lltype = nil) or (lrtype = nil) then etyptr := nil
	  else
	    begin
	    if [arrays,records,files,pointer,prok] *
	       [lltype^.form,lrtype^.form] <> [] then error(134)
	    else
	      case lop of
		mul:
		  begin
		  if lltype^.form = power then
		    begin eclass := intersectnode;
		    if comptypes(lltype,lrtype) then
		      begin
		      if lltype^.setmax > lrtype^.setmax then
			etyptr := lrtype        {Result type = smaller}
		      end
		    else error(129);
		    end
		  else if arithtype(lltype) and arithtype(lrtype) then
		    begin
		    if lltype<>lrtype then
		      begin
		      if not shortintandint(lltype,lrtype) then
			if not trytowiden(opnd1,lrtype) then
			  if not trytowiden(opnd2,lltype) then
			    error(999);   {should never get here!}
		      etyptr := opnd1^.etyptr;
		      end
		    end
		  else
		    begin
		    error(134);
		    fold_ok := false;
		    end;
		  if eclass = mulnode then
		    if (opnd1^.eclass = litnode)
			and (opnd2^.eclass <> litnode) then
		      begin powerof2(opnd1,res);
		      if res <> 0 then
			begin eclass := shftnode; exptemp := opnd1;
			opnd1 := opnd2; opnd2 := exptemp;
			opnd2^.litval.ival := res end;
		      end
		    else if (opnd1^.eclass <> litnode)
			and (opnd2^.eclass = litnode) then
		      begin powerof2(opnd2,res);
		      if res <> 0 then
			begin eclass := shftnode; opnd2^.litval.ival := res end;
		      end;
		  end;
		idiv,imod:
		  begin
		  if (lltype <> intptr) and (lltype <> shortintptr)
		    or (lrtype <> intptr) and (lrtype <> shortintptr) then
		    begin error(134); etyptr := intptr end;
		  if opnd2^.eclass = litnode then
		    if opnd2^.litval.ival = 0 then
		      error(300)
		    else if (eclass = divnode) and
			    (opnd1^.eclass <> litnode) then
		      begin
		      powerof2(opnd2,res);
		      if res <> 0 then
			begin
			eclass := shftnode;
			opnd2^.litval.ival := -res;
			end;
		      end
		    else if eclass = modnode then
		      if opnd2^.litval.ival < 0 then
			begin
			error(125);
			opnd2^.litval.ival := 1;
			end;
		  end;
		rdiv:
		  begin etyptr := realptr;
		  if lltype<>etyptr then
		    if not trytowiden(opnd1,etyptr) then
		      begin
		      error(134);
		      fold_ok := false;
		      end;
		  if lrtype<>etyptr then
		    if not trytowiden(opnd2,etyptr) then
		      begin
		      error(134);
		      fold_ok := false;
		      end;
		  end;
		andop:
		  if (lltype <> boolptr) or (lrtype <> boolptr) then
		    begin error(134); etyptr := boolptr end
		end; (*case lop*)
	    if fold_ok and
	       (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	      begin
	      if opnd1^.litval.intval and opnd2^.litval.intval then
		begin llval := opnd1^.litval.ival;
		lrval := opnd2^.litval.ival;
		if eclass = andnode then
		  begin
		  if not inbody then error(50);
		  lval := ord( (llval=1) and (lrval=1) );
		  end
		else
		  try
		    $ovflcheck on$
		    case eclass of
		      mulnode: lval := llval*lrval;
		      divnode: if lrval = 0 then error(300)
			       else lval := llval div lrval;
		      modnode: if lrval = 0 then error(300)
			       else lval := llval mod lrval;
		    end; {case}
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode);
		eclass := litnode;
		ekind := cnst;
		num_ops := 1;  { result of folding 2 operands }
		with litval do
		  begin intval := true; ival := lval end;
		end {constant folding integer}
	      else if inbody and (etyptr = realptr) and
		      ((not MC68020) or (float = flt_off)) then
		begin
		try
		  if eclass = mulnode then
		    realval := opnd1^.litval.valp^.rval *
			       opnd2^.litval.valp^.rval
		  else { eclass = divnode }
		    realval := opnd1^.litval.valp^.rval /
			       opnd2^.litval.valp^.rval;
		recover
		  if (escapecode = -6) or (escapecode = -7)
		     or (escapecode = -5) then
		    begin
		    realval := 0.0;
		    error(301);
		    end
		  else
		    escape(escapecode);
		eclass := litnode;
		ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		with litval do
		  begin
		  valp := opnd1^.litval.valp;
		  valp^.rval := realval;
		  valp^.cclass := reel;
		  intval := false;
		  end;
		end;
	      end
	    else if fold_ok and (opnd1^.eclass = litnode) then
	      case eclass of
		mulnode:
		  if (opnd1^.litval.intval) then
		    begin
		    if (opnd1^.litval.ival = 0) then
		      { 0 * xxx : fold out mul operation }
		      curexp := opnd1
		    else if (opnd1^.litval.ival = 1) then
		      { 1 * xxx : fold out mul operation }
		      curexp := opnd2;
		    end
		  else if (opnd1^.litval.valp^.cclass = reel) and
			  (opnd1^.litval.valp^.rval = 0.0) then
		      { 0.0 * xxx : fold out mul operation }
		      curexp := opnd1
		  else if (opnd1^.litval.valp^.cclass = reel) and
			  (opnd1^.litval.valp^.rval = 1.0) then
		      { 1.0 * xxx : fold out mul operation }
		      curexp := opnd2;
		andnode:
		  if (opnd1^.litval.intval) then
		    begin
		    if (opnd1^.litval.ival = ord(false)) then
		      { false and xxx : fold out and operation }
		      curexp := opnd1
		    else if (opnd1^.litval.ival = ord(true)) then
		      { true and xxx : fold out and operation }
		      curexp := opnd2;
		    end;
		otherwise   {do nothing} ;
	      end { case }
	    else if fold_ok and (opnd2^.eclass = litnode) then
	      case eclass of
		mulnode:
		  if (opnd2^.litval.intval) then
		    begin
		    if (opnd2^.litval.ival = 0) then
		      { xxx * 0 : fold out mul operation }
		      curexp := opnd2
		    else if (opnd2^.litval.ival = 1) then
		      { xxx * 1 : fold out mul operation }
		      curexp := opnd1;
		    end
		  else if (opnd2^.litval.valp^.cclass = reel) and
			  (opnd2^.litval.valp^.rval = 0.0) then
		      { xxx * 0.0 : fold out mul operation }
		      curexp := opnd2
		  else if (opnd2^.litval.valp^.cclass = reel) and
			  (opnd2^.litval.valp^.rval = 1.0) then
		      { xxx * 1.0 : fold out mul operation }
		      curexp := opnd1;
		divnode:
		  if (opnd2^.litval.intval) then
		    begin
		    if (opnd2^.litval.ival = 1) then
		      { xxx DIV 1 : fold out DIV operation }
		      curexp := opnd1;
		    end
		  else if (opnd2^.litval.valp^.cclass = reel) and
			  (opnd2^.litval.valp^.rval = 1.0) then
		    { xxx / 1.0 : fold out division operation }
		    curexp := opnd1;
		andnode:
		  if (opnd2^.litval.intval) then
		    begin
		    if (opnd2^.litval.ival = ord(false)) then
		      { xxx and false : fold out and operation }
		      curexp := opnd2
		    else if (opnd2^.litval.ival = ord(true)) then
		      { xxx and true : fold out and operation }
		      curexp := opnd1;
		    end;
		otherwise   {do nothing} ;
	      end; { case }
	    end; (*types <> nil*)
	  end (*with curexp^*)
	end (*muloptypecheck*);

      begin (*term*)
	factor(fsys+[mulop]);
	if (sy = mulop) and not inbody and
	   stdpasc then error(606);
	while sy = mulop do begin
	  lexp := newexpr; lop := op;
	  with lexp^ do begin
	    case op of
	      mul:       eclass := mulnode;
	      rdiv,idiv: eclass := divnode;
	      imod:      eclass := modnode;
	      andop:     eclass := andnode
	      end;
	    etyptr := curexp^.etyptr;
	    ekind := xpr;
	    opnd1 := curexp;
	    insymbol;
	    factor(fsys+[mulop]);
	    opnd2 := curexp;
	    curexp := lexp;
	    muloptypecheck
	    end (* with lexp^ *)
	  end (* sy=mulop *)
      end (*term*);

    procedure addoptypecheck;
      (* type checker for binary plus and minus, and 'or' *)
      var
	lltype,lrtype: stp;
	llval,lrval,lval: integer;
	fold_ok: boolean;
	realval: real;
	optemp : exptr;

      procedure trytomakestr(fexp: exptr);
	var
	  stretch: boolean;
	  lgth: shortint;
	begin
	with fexp^ do
	  if eclass = litnode then
	    begin
	    if etyptr = char_ptr then
	      stretch := true
	    else if litval.valp^.cclass = paofch then
	      stretch := true
	    else { struct const }
	      stretch := false;
	    if stretch then
	      begin
	      if etyptr=char_ptr then lgth := 1
	      else lgth := litval.valp^.slgth;
	      stretchpaofchar(etyptr,litval,lgth);
	      etyptr^.aisstrng := true;
	      etyptr^.unpacksize := lgth+1;
	      litval.valp^.cclass := strng;
	      end;
	    end;
	end;

      begin {addoptypecheck}
      with curexp^ do
	begin
	num_ops := opnd1^.num_ops + opnd2^.num_ops;
	fold_ok := true;
	lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
	if (lltype = nil) or (lrtype = nil) then etyptr := nil
	else
	  begin
	  if [records,files,pointer,prok] *
	     [lltype^.form,lrtype^.form] <> [] then error(134)
	  else
	    case eclass of
	      addnode,subnode:
		if lltype^.form = power then
		  begin
		  if comptypes(lltype,lrtype) then
		    begin
		    if eclass = addnode then
		      begin
		      eclass := unionnode;
		      if lltype^.setmax < lrtype^.setmax then
			etyptr := lrtype;       {Result type = larger}
		      end
		    else eclass := diffnode;    {Result type = left side}
		    end
		  else error(129);
		  end
		else if arithtype(lltype) and arithtype(lrtype) then
		  begin
		  if lltype<>lrtype then
		    begin
		    if not shortintandint(lltype,lrtype) then
		      if not trytowiden(opnd1,lrtype) then
			if not trytowiden(opnd2,lltype) then
			  error(999);   {should never get here!}
		    etyptr := opnd1^.etyptr;
		    end
		  end
		else if (eclass = addnode)
		       and strgvalue(opnd1)
		       and strgvalue(opnd2) then
		  begin
		  if stdpasc then error(606);
		  eclass := concatnode;
		  new(etyptr);
		  etyptr^ := strgptr^;
		  trytomakestr(opnd1);
		  trytomakestr(opnd2);
		  end
		else
		  begin
		  error(134);
		  fold_ok := false;
		  end;
	      ornode:
		if (lltype <> boolptr) or (lrtype <> boolptr) then
		  begin error(134); etyptr := boolptr end
	    end; (*case eclass*)
	  if fold_ok and
	     (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	    begin
	    if opnd1^.litval.intval and opnd2^.litval.intval then
	      begin llval := opnd1^.litval.ival; lrval := opnd2^.litval.ival;
	      if eclass = ornode then
		begin
		if not inbody then error(50);
		lval := ord((llval=1) or (lrval=1));
		end
	      else {addnode,subnode}
		try
		  $ovflcheck on$
		  if eclass = addnode then
		    lval := llval+lrval
		  else lval := llval-lrval;
		  $if not ovflchecking$
		    $ovflcheck off$
		  $end$
		recover
		  if escapecode = -4 then
		    error(301)
		  else escape(escapecode);
	      eclass := litnode; ekind := cnst;
	      num_ops := 1; { result of folding 2 operands }
	      with litval do
		begin intval := true; ival := lval end;
	      end
	    else if inbody and (etyptr = realptr) and
		    ((not MC68020) or (float = flt_off)) then
	      begin
	      try
		if eclass = addnode then
		  realval := opnd1^.litval.valp^.rval +
			     opnd2^.litval.valp^.rval
		else { ecalss = subnode }
		  realval := opnd1^.litval.valp^.rval -
			     opnd2^.litval.valp^.rval;
	      recover
		if (escapecode = -6) or (escapecode = -7) then
		  begin
		  error(301);
		  realval := 0.0;
		  end
		else
		  escape(escapecode);
	      eclass := litnode;
	      ekind := cnst;
	      num_ops := 1; { result of folding 2 operands }
	      with litval do
		begin intval := false;
		new(valp,true,reel);
		valp^.rval := realval;
		valp^.cclass := reel;
		end;
	      end;
	    end
	  else if fold_ok and (opnd1^.eclass = litnode) then
	    case eclass of
	      addnode:
		if (opnd1^.litval.intval) then
		  begin
		  if (opnd1^.litval.ival = 0) then
		    { 0 + xxx : fold out the add operation }
		    curexp := opnd2;
		  end
		else if (opnd1^.litval.valp^.cclass = reel) and
			(opnd1^.litval.valp^.rval = 0) then
		  { 0.0 + xxx : fold out the add operation }
		  curexp := opnd2;
	      subnode:
		if (opnd1^.litval.intval) then
		  begin
		  if (opnd1^.litval.ival=0) then
		    begin { 0 - xxx : turn subtract into a negate node }
		    optemp := opnd2;
		    eclass := negnode;
		    opnd := optemp;
		    num_ops := optemp^.num_ops;
		    end;
		  end
		else if (opnd1^.litval.valp^.cclass = reel) and
			(opnd1^.litval.valp^.rval = 0) then
		  begin { 0.0 - xxx : turn subtract into a negate node }
		  optemp := opnd2;
		  eclass := negnode;
		  opnd := optemp;
		  num_ops := optemp^.num_ops;
		  end;
	      ornode:
		if (opnd1^.litval.intval) and
		   (opnd1^.litval.ival = ord(true)) then
		  { true or xxx : fold out the or operation }
		  curexp := opnd1
		else if (opnd1^.litval.intval) and
		   (opnd1^.litval.ival = ord(false)) then
		  { false or xxx : fold out the or operation }
		  curexp := opnd2;
	      otherwise   {do nothing} ;
	    end
	  else if fold_ok and (opnd2^.eclass = litnode) then
	    case eclass of
	      addnode:
		if (opnd2^.litval.intval) then
		  begin
		  if (opnd2^.litval.ival = 0) then
		    { xxx + 0 : fold out the add operation }
		    curexp := opnd1;
		  end
		else if (opnd2^.litval.valp^.cclass = reel) and
			(opnd2^.litval.valp^.rval = 0) then
		  { xxx + 0.0 : fold out the add operation }
		  curexp := opnd1;
	      subnode:
		if (opnd2^.litval.intval) then
		  begin
		  if (opnd2^.litval.ival=0) then
		    { xxx - 0 : fold out the subtract operation }
		    curexp := opnd1;
		  end
		else if (opnd2^.litval.valp^.cclass = reel) and
			(opnd2^.litval.valp^.rval = 0) then
		  { xxx - 0.0 : fold out the subtract node }
		  curexp := opnd1;
	      ornode:
		if (opnd2^.litval.intval) and
		   (opnd2^.litval.ival = ord(true)) then
		  { xxx or true : fold out the or operation }
		  curexp := opnd2
		else if (opnd2^.litval.intval) and
		   (opnd2^.litval.ival = ord(false)) then
		  { xxx or false : fold out the or operation }
		  curexp := opnd1;
	      otherwise   {do nothing} ;
	    end; { case }
	  end; (*types <> nil*)
	end; (*with curexp^*)
      end (*addoptypecheck*);

    begin (*simpleexpression*)
      lsigned := false;
      if sy = addop then
	if op in [plus,minus] then
	  begin lsigned := true; lpositive := (op=plus);
	  uminus := not lpositive; insymbol; uminus := false;
	  sywaslit := (sy = intconst) or (sy = realconst);
	  end;
      term(fsys+[addop]);
      if lsigned then
	with curexp^ do
	  if etyptr <> nil then
	    if not arithtype(etyptr) then error(105)
	    else if not (lpositive or sywaslit) then
	      if (eclass = litnode) and
		 (etyptr = intptr) then
		if litval.ival = minint then error(661)
		else litval.ival := -litval.ival
	      else if (eclass = litnode) and
		      (etyptr = realptr) then
		litval.valp^.rval:= -litval.valp^.rval
	      else
		begin lexp := newexpr;
		with lexp^ do
		  begin etyptr := curexp^.etyptr;
		  eclass := negnode; ekind := xpr;
		  opnd := curexp;
		  end;
		curexp := lexp
		end;
      if (sy = addop) and not inbody and
	 stdpasc then error(606);
      while sy = addop do
	begin
	lexp := newexpr;
	with lexp^ do begin
	  case op of
	    plus:  eclass := addnode;
	    minus: eclass := subnode;
	    orop:  eclass := ornode
	    end;
	  etyptr := curexp^.etyptr;
	  ekind := xpr;
	  opnd1 := curexp;
	  insymbol;
	  term(fsys+[addop]);
	  opnd2 := curexp;
	  curexp := lexp;
	  addoptypecheck
	  end (* with lexp^ *)
	end (* sy=addop *)
    end (*simpleexpression*);

  procedure reltypecheck;
    (* checks operands of the relational node ref'd by curexp *)
    var
      lltype,lrtype: stp;
      llval,lrval: integer;
      lclass: exprs;
      l_realval,r_realval: real;
      is_in : boolean;                  (* is element in set ? *)
  $if bigsets$
      j : shortint;                     (* simple local counter *)
      s : setrecptr;                    (* current set record item *)
      bias, rel_elem: shortint;         (* ordinal bias and relative
						element value in list *)
  $end$

    procedure check_for_special_situation(opnd1,opnd2 : exptr);
      { Bug fix for the specific situation of a character literal begin
	compared with an empty packed array of char literal. ('A' = '')
	This is allowed because packed array of char literals can be
	padded with blanks. }
      begin
      $PARTIAL_EVAL ON$
      with opnd2^.etyptr^ do
	if (opnd1^.etyptr = char_ptr) and (opnd1^.eclass = litnode) and
	   paofchar(opnd2^.etyptr) and (not {opnd2^.etyptr^.}aisstrng) and
	   isPAC({opnd2^.etyptr^.}inxtype) and
	   ({opnd2^.etyptr^.}inxtype^.max = 0) then
	  {Change char literal to a packed array of char literal of length 1}
	  stretchpaofchar(opnd1^.etyptr,opnd1^.litval,1);

      $IF not partialevaling$
	$PARTIAL_EVAL OFF$
      $END$
      end;

    begin
    with curexp^ do
      begin
      num_ops := opnd1^.num_ops + opnd2^.num_ops;
      lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
      if (lltype <> nil) and (lrtype <> nil) then
	if eclass = innode then
	  begin
	  if lrtype^.form <> power then error(130)
	  else if not comptypes(lltype,lrtype^.elset) then error(129);
	  if opnd1^.eclass = litnode then
	    if not opnd1^.litval.intval or (opnd1^.litval.ival<setlow)
	      or (opnd1^.litval.ival>sethigh) then error(182)
	    else if opnd2^.eclass = litnode then
	      begin ekind := cnst; eclass := litnode;
  $if bigsets$
	      bias := opnd1^.litval.ival DIV (oldsethigh + 1);
	      rel_elem := opnd1^.litval.ival MOD (oldsethigh + 1);
	      s := opnd2^.litval.valp^.pval;
	      is_in := false;
	      if s <> NIL then
		begin
		  j := 0;
		  while ( (s^.nxt <> NIL) and (j < bias) ) do
		    begin
			s := s^.nxt;
			j := j + 1;
		    end;
		  if j = bias then
		    is_in := rel_elem in s^.val;
		end;
  $end$
  $if not bigsets$
	      is_in := opnd1^.litval.ival in opnd2^.litval.valp^.pval;
  $end$
	      llval := ord( is_in );
	      with litval do
		begin intval := true; ival := llval end;
	      end;
	  end
	else
	  begin (* relational op *)
	  if lltype <> lrtype then      {check for arithmetic widening}
	    if arithtype(lltype) and arithtype(lrtype) then
	      begin
	      if not shortintandint(lltype,lrtype) then
		if not trytowiden(opnd1,lrtype) then
		  if not trytowiden(opnd2,lltype) then
		    error(999);     {should never get here!}
	      lltype := opnd1^.etyptr; lrtype := opnd2^.etyptr;
	      end;
	  if comptypes(lltype,lrtype) then
	    begin
	    case lltype^.form of
	      pointer:
		if not (eclass in [eqnode,nenode]) then error(131);
	      prok:
		if eclass in [eqnode,nenode] then
		  begin
		  if (opnd1^.ekind = cnst) and (opnd2^.ekind = cnst) then
		    begin lclass := eclass; eclass := litnode;
		    ekind := cnst; litval.intval := true;
		    if opnd1^.symptr = opnd2^.symptr
		      then litval.ival := ord(lclass = eqnode)
		      else litval.ival := ord(lclass = nenode);
		    end;
		  end
		else error(131);
	      power: case eclass of
		       lenode: eclass := subsetnode;
		       genode: eclass := supersetnode;
		       ltnode,gtnode: error(132);
		       otherwise
		       end;
	      arrays: if not paofchar(lltype) then error(133);
	      records,files: error(133);
	      cnfarrays: error(133);
	      otherwise
	      end; (*case*)
	    if (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	      if opnd1^.litval.intval and opnd2^.litval.intval then
		begin
		if not inbody then error(50);
		llval := opnd1^.litval.ival;
		lrval := opnd2^.litval.ival;
		lclass := eclass; eclass := litnode; ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		with litval do
		  begin intval := true;
		  case lclass of
		    ltnode: ival := ord(llval <  lrval);
		    lenode: ival := ord(llval <= lrval);
		    gtnode: ival := ord(llval >   lrval);
		    genode: ival := ord(llval >=  lrval);
		    eqnode: ival := ord(llval =   lrval);
		    nenode: ival := ord(llval <>  lrval);
		    end;
		  end;
		end
	      else if inbody and (etyptr = realptr) then
		begin
		l_realval := opnd1^.litval.valp^.rval;
		r_realval := opnd2^.litval.valp^.rval;
		with litval do
		  begin
		  intval := true;
		  case eclass of
		    ltnode: ival := ord(l_realval <  r_realval);
		    lenode: ival := ord(l_realval <= r_realval);
		    gtnode: ival := ord(l_realval >  r_realval);
		    genode: ival := ord(l_realval >= r_realval);
		    eqnode: ival := ord(l_realval =  r_realval);
		    nenode: ival := ord(l_realval <> r_realval);
		  end; { case }
		  end; { with litval }
		eclass := litnode;
		ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		end;
	    end {compatible types}
	  else
	    begin
	    check_for_special_situation(opnd1,opnd2);
	    check_for_special_situation(opnd2,opnd1);
	    if not paofcharcomp(opnd1,opnd2^.etyptr) then
	      if not paofcharcomp(opnd2,opnd1^.etyptr) then
		error(129);
	    end;
	  end (*relational op*)
      end (*with curexp^*)
    end (*reltypecheck*);

  begin (*expression*)
    simpleexpression(fsys+[relop]);
    if sy = relop then
      begin
      if not inbody and stdpasc then error(606);
      lexp := newexpr;
      with lexp^ do begin
	case op of
	  ltop: eclass := ltnode;
	  leop: eclass := lenode;
	  geop: eclass := genode;
	  gtop: eclass := gtnode;
	  neop: eclass := nenode;
	  eqop: eclass := eqnode;
	  inop: eclass := innode
	  end;
	ekind := xpr;
	etyptr := boolptr;
	opnd1 := curexp;
	insymbol;
	simpleexpression(fsys);
	opnd2 := curexp
	end;
      curexp := lexp;
      reltypecheck
      end (* sy = relop *)
  end (*expression*);

@


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


40.3
log
@

            Put more finesse into my previous modification
       for the repair of FSDdt03843. All mods were to routine
       castypecheck.

       Jeff 12/12/89.
@
text
@@


40.2
log
@

         Commented out a line in routine casttypecheck. For
     FSDdt03843.
@
text
@d800 11
a810 1
	begin { if fsp1^.unpacksize <> fsp2^.unpacksize then error(134) } end
@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d799 2
a800 1
	begin if fsp1^.unpacksize <> fsp2^.unpacksize then error(134) end
@


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


24.4
log
@Bug fix for set constants with constant elements in descending 'chunks'.
@
text
@@


24.3
log
@Changes made so that any identifier enclosed in parenthesis becomes an
expression.
@
text
@d675 2
a676 3
			  if bias < cur_bias then
			    s := constpart;
			  for j := cur_bias to (bias - 1) do s := s^.nxt;
@


24.2
log
@Don't set assignedto to true unless you dealing with a declared function.
@
text
@d1005 2
@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d785 2
a786 1
  fcp^.assignedto := true;
@


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


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


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


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


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


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


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


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


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


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@d1137 1
d1199 76
d1311 1
d1397 10
a1406 27
	      end; (*case eclass*)
	    if fold_ok and
	       (opnd1^.eclass = litnode) and (opnd2^.eclass = litnode) then
	      if opnd1^.litval.intval and opnd2^.litval.intval then
		begin llval := opnd1^.litval.ival; lrval := opnd2^.litval.ival;
		if eclass = ornode then
		  begin
		  if not inbody then error(50);
		  lval := ord((llval=1) or (lrval=1));
		  end
		else {addnode,subnode}
		  try
		    $ovflcheck on$
		    if eclass = addnode then
		      lval := llval+lrval
		    else lval := llval-lrval;
		    $if not ovflchecking$
		      $ovflcheck off$
		    $end$
		  recover
		    if escapecode = -4 then
		      error(301)
		    else escape(escapecode);
		eclass := litnode; ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		with litval do
		  begin intval := true; ival := lval end;
d1408 1
a1408 3
	      else if inbody and (etyptr = realptr) and
		      ((not MC68020) or (float = flt_off)) then
		begin
d1410 1
d1412 5
a1416 5
		    realval := opnd1^.litval.valp^.rval +
			       opnd2^.litval.valp^.rval
		  else { ecalss = subnode }
		    realval := opnd1^.litval.valp^.rval -
			       opnd2^.litval.valp^.rval;
d1418 68
a1485 15
		  if (escapecode = -6) or (escapecode = -7) then
		    begin
		    error(301);
		    realval := 0.0;
		    end
		  else
		    escape(escapecode);
		eclass := litnode;
		ekind := cnst;
		num_ops := 1; { result of folding 2 operands }
		with litval do
		  begin intval := false;
		  new(valp,true,reel);
		  valp^.rval := realval;
		  valp^.cclass := reel;
d1487 46
a1532 1
		end;
@


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


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d100 1
a100 1
	  if lcp2 <> NIL then
@


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


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d1543 1
@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


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


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


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


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


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


6.2
log
@Pws2unix automatic delta on Wed Nov 19 15:16:12 MST 1986
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@d80 1
a80 1
      var lcp: ctp; lsp: stp; lsize: addrrange;
d92 15
a106 1
	  begin identproc(fsys+[comma,rparent]); lsp := curexp^.etyptr end;
a1191 1
		  intval := false;
d1195 1
@


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


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


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


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


1.1
log
@Initial revision
@
text
@@
