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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

16.1
date     87.04.26.15.12.07;  author jws;  state Exp;
branches ;
next     15.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


desc
@Base file for PWS 3.2 release.

@


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

implement

type
  fileclass = (untyped,directfile,textphile,any);

var donteval,varparm: boolean;

procedure identproc(fsys: setofsys); forward;

function newexpr: exptr;
  var lexp: exptr;
  begin
    new(lexp);
    with lexp^ do
      begin
      ekind := xpr; etyptr := nil;
      attr := nil;
      num_ops := 1;  { Most common case is 1 so make that the default }
      $IF FULLDUMP$
      echain := nil;
      if inbody then
	begin
	lastexp^.echain := lexp;
	lastexp := lexp;
	enum := ectr; ectr := ectr+1;
	end; { used by tree dumper }
      $END$
      end;
    newexpr := lexp
  end (*newexpr*);

function newexplist: elistptr;
  { Get an expression-list node of the short form }
  var lp: elistptr;
  begin
  new(lp,false);
  with lp^ do
    begin expptr := nil; nextptr := nil end;
  newexplist := lp
  end (*newexplist*);

function arithtype(fsp: stp): boolean;
  { Returns true if type is integer, real or longreal }
  begin
  if fsp = intptr then arithtype := true
  else if fsp = shortintptr then arithtype := true
  else if fsp = realptr then arithtype := true
  else arithtype := false;
  end; {arithtype}

function  widenconst(var fsp: stp;
	  var fvalu: valu; target: stp): boolean;
  var lval: integer;
  begin widenconst := false;
  if (target=realptr) and (fsp=intptr) then
    with fvalu do
      begin lval := ival;
      fsp := realptr;
      intval := false;
      new(valp,true,reel);
      with valp^ do
	begin cclass := reel; rval := lval end;
      widenconst := true;
      end;
  end; {widenconst}

function trytowiden(var fexp: exptr; newtype: stp): boolean;
  (* attempt arithmetic widening coercion on fexp *)
  var lsp: stp; lexp: exptr;
  begin trytowiden := false;
  lsp := fexp^.etyptr;
  if (lsp = intptr) or (lsp = shortintptr) then
    if newtype=realptr then
      if fexp^.eclass = litnode then
	trytowiden := widenconst
	      (fexp^.etyptr,fexp^.litval,realptr)
      else
	begin       (* insert floatnode between fexp and fexp^ *)
	lexp := newexpr;
	with lexp^ do
	  begin
	  eclass := floatnode; ekind := xpr;
	  etyptr := newtype; opnd := fexp;
	  end;
	fexp := lexp; trytowiden := true;
	end;
  end; (*trytowiden*)

function shortintandint(fsp1,fsp2: stp): boolean;
  begin
  shortintandint := ((fsp1 = intptr) or (fsp1 = shortintptr)) and
		    ((fsp2 = intptr) or (fsp2 = shortintptr));
  end;

function paofcharcomp(source: exptr; desttyptr: stp): boolean;
  { assignment compatibility for packed arrays of characters;}
  var dlgth: integer;
  begin paofcharcomp := false;
  with source^ do
    if paofchar(desttyptr) and (eclass = litnode) then
      if desttyptr^.aisstrng then
	begin
	if (etyptr = char_ptr) or paofchar(etyptr) then
	  begin
	  if etyptr=char_ptr then dlgth:=1
	  else dlgth:= litval.valp^.slgth;
	  if dlgth <= desttyptr^.maxleng then
	    begin paofcharcomp:=true;
	    if not strgtype(etyptr) then
	      begin stretchpaofchar(etyptr,litval,dlgth);
	      etyptr^.aisstrng:=true; etyptr^.unpacksize:=dlgth+1;
	      litval.valp^.cclass := strng;
	      end;
	    end;
	  end;
	end
      else if isPAC(desttyptr^.inxtype) then
	begin
	dlgth := desttyptr^.inxtype^.max;
	if etyptr = char_ptr then
	  begin
	  stretchpaofchar(etyptr,litval,dlgth);
	  paofcharcomp := true;
	  end
	else
	  if paofchar(etyptr) then
	    if litval.valp^.cclass = paofch then
	      begin
	      if litval.valp^.slgth < dlgth then
		stretchpaofchar(etyptr,litval,dlgth);
	      paofcharcomp := litval.valp^.slgth = dlgth;
	      end;
	end; {isPAC}
  end; {paofcharcomp}

function strgvalue(expr: exptr): boolean;
  {determine whether an expression can be considered a string}
  begin strgvalue := false;
  with expr^ do
    if strgtype(etyptr) then strgvalue := true
    else if eclass = litnode then
      if etyptr = char_ptr then strgvalue := true
      else if paofchar(etyptr) then
	strgvalue := litval.valp^.cclass = paofch;
  end;

procedure checkconst(dest: stp; source: exptr);
  {check constant to be assigned to object of type 'stp';
   assumes compatible types}
  var lmin,lmax: integer;
$if not bigsets$
	 k: shortint;
$end$
$if bigsets$
	k : integer;
      s : setrecptr;                    (* current set record item *)
      j : shortint;                     (* simple counter *)
      bias, rel_elem: shortint;         (* ordinal bias and relative elem *)
$end$
  begin
  if (source^.eclass = litnode) and (dest <> NIL) then
    with source^ do
      if (dest <> intptr) and (dest^.form <= subrange) then
	begin getbounds(dest,lmin,lmax);
	if (litval.ival < lmin) or (litval.ival > lmax)
	  then error(303);
	end
      else if (dest^.form = power) and (dest^.elset <> NIL) then
	begin getbounds(dest^.elset,lmin,lmax);
	with litval.valp^ do
	  if plgth-1 > lmax then error(182)
	  else
	    begin k := 0;
	    while (k < lmin) and (k < plgth) do
  $if bigsets$
	     begin
	       bias := k DIV (oldsethigh + 1);
	       rel_elem := k MOD (oldsethigh + 1);
	       s := pval;
	       for j := 1 to bias do s := s^.nxt;
	       if rel_elem in s^.val then
  $end$
  $if not bigsets$
	      if k in pval then
  $end$
		begin error(182); k := plgth end
	      else k := k+1;
  $if bigsets$
	     end;                         (* while k < lmin... *)
  $end$
	    end;
	end; (*power*)
  end; (*checkconst*)

procedure checkint;
  begin
  with curexp^ do
    if (etyptr<>nil) and (etyptr<>intptr) and (etyptr<>shortintptr) then
      error(125);
  end;

function integerparm(fsys: setofsys): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  checkint;
  lexp^.expptr := curexp; integerparm := lexp;
  end;

function charparm(fsys: setofsys): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  with curexp^ do
    if (etyptr<>nil) and (etyptr<>char_ptr) then error(125);
  lexp^.expptr := curexp; charparm := lexp;
  end;

function anyparm(fsys: setofsys; isvar: boolean): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  with curexp^ do
    if ekind = vrbl then
      begin
      if etyptr<>nil then
	if eclass = selnnode then
	  begin if fieldptr^.fispackd then error(125) end
	else if eclass = unqualfldnode then
	  begin if fieldref^.fispackd then error(125) end
	else if eclass = subscrnode then
	  if arayp^.etyptr<>nil then
	    with arayp^.etyptr^ do
	      if aispackd then
		if not (aelbitsize in [8,16]) then error(125);
      end
    else if ekind = xpr then error(125)
    else {ekind = cnst}
      if isvar then error(125)
      else if eclass = litnode then
	begin
	with litval do
	  if intval then error(125)
	  else if valp^.cclass < pset then error(125);
	end;
  lexp^.expptr := curexp; anyparm := lexp;
end;

function makeintparm(i: integer): elistptr;
var lexp: elistptr;
begin
  lexp := newexplist; lexp^.expptr := newexpr;
  with lexp^.expptr^ do
    begin  eclass := litnode; ekind := cnst; etyptr := intptr;
    with litval do begin intval := true; ival := i end;
    end;
  makeintparm := lexp;
end;

function makestrparm(s: string255): elistptr;
var lexp: elistptr;
begin
lexp := newexplist; lexp^.expptr := newexpr;
with lexp^.expptr^ do
  begin  eclass := litnode; ekind := cnst;
  new(etyptr,arrays,true,true);
  etyptr^ := strgptr^;
  with etyptr^ do
    begin maxleng := strlen(s);
    unpacksize := maxleng+1;
    end;
  with litval do
    begin intval := false;
    newwords(valp,(sizeof(constrec,true,strng)
      -(strglgth-strlen(s))+1) div 2);
    with valp^ do
      begin cclass := strng;
      slgth := strlen(s);
      moveleft(s[1],sval,strlen(s));
      end;
    end;
  end;
makestrparm := lexp;
end;

function stringparm(fsys: setofsys): elistptr;
var lexp: elistptr;
begin lexp := newexplist;
expression(fsys+[comma,rparent]);
with curexp^ do
  if (etyptr<>nil) then
    if not strgvalue(curexp) then
      begin
      error(125);
      etyptr := NIL;
      end
    else if not strgtype(etyptr) then
      begin
      if etyptr=char_ptr then stretchpaofchar(etyptr,litval,1)
      else stretchpaofchar(etyptr,litval,litval.valp^.slgth);
      with etyptr^ do
	begin
	aisstrng := true;
	maxleng := etyptr^.unpacksize;
	unpacksize := unpacksize+1;
	end;
      litval.valp^.cclass := strng;
      end;
lexp^.expptr := curexp; stringparm := lexp;
end;

function fileparm(fsys: setofsys; fclass: fileclass): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  with curexp^ do
   if (etyptr<>nil) then
    if etyptr^.form <> files then error(125)
    else
      case fclass of
	untyped: if etyptr^.filtype <> nil then error(125);
	directfile:
	  if (etyptr = textptr) or (etyptr^.filtype = nil) then error(125);
	textphile: if etyptr <> textptr then error(184);
	any: ;
	end;
  lexp^.expptr := curexp; fileparm := lexp;
  end;

function makefileexp(fileptr: ctp): exptr;
  var fileexp: exptr;
  begin fileexp := newexpr;
  with fileexp^ do
    begin ekind := vrbl; eclass := idnode;
    etyptr := textptr; symptr := fileptr;
    end;
  makefileexp := fileexp;
  end;

procedure actparmlist
(fsys: setofsys; var actualptr: elistptr; formalptr: ctp);

  var lexp: elistptr;

  procedure actualroutine(formalptr: ctp);
    begin donteval := true;  {change state of expression analyzer}
    expression(fsys+[comma,rparent]);
    donteval := false;
    with curexp^ do
      if etyptr <> nil then
	if not (etyptr^.form in [prok,funk]) then error(127)
	else if not compparmlists(formalptr^.proktype^.params,etyptr^.params,false,false)
	  then error(127)
	else if formalptr^.vtype = funcparm then
	  begin
	  if etyptr^.form <> funk then error(127)
	  else if symptr^.idtype <> formalptr^.idtype then error(127)
	  end
	else {formal is procedure parm}
	  if etyptr^.form <> prok then error(127);
    end; {actualroutine}

  procedure checkparm(var formalptr: ctp);
    label 1;
    var
      doneptr: ctp;
      firstparmtype: stp;
      parm1err: boolean;

    function conformable(cnfarray,fexptype: stp): boolean;
      label 1;
      var
	cnfmin,cnfmax,fexpmin,fexpmax : integer;

      begin
      conformable := true;
      if (cnfarray <> NIL) and (fexptype <> NIL) then
	begin
	if (fexptype^.form <> arrays) and (fexptype^.form <> cnfarrays) then
	  begin conformable := false; goto 1; end;
	if (cnfarray^.inxtype <> NIL) and (fexptype^.inxtype <> NIL) then
	  begin
	  if not comptypes(cnfarray^.inxtype,fexptype^.inxtype) then
	    begin conformable := false; goto 1; end
	  else
	    begin
	    getbounds(cnfarray^.inxtype,cnfmin,cnfmax);
	    getbounds(fexptype^.inxtype,fexpmin,fexpmax);
	    if (fexpmin < cnfmin) or (fexpmax > cnfmax) then
	      begin conformable := false; goto 1; end;
	    end;
	  end;
	if (cnfarray^.aeltype <> NIL) and (fexptype^.aeltype <> NIL) then
	  begin
	  if cnfarray^.aeltype^.form = cnfarrays then
	    begin
	    if not conformable(cnfarray^.aeltype,fexptype^.aeltype) then
	      begin conformable := false; goto 1; end;
	    end
	  else
	    if not (cnfarray^.aeltype = fexptype^.aeltype) then
	      begin conformable := false; goto 1; end;
	  end;
	if cnfarray^.aispackd or fexptype^.aispackd then
	  conformable := (cnfarray^.aispackd = fexptype^.aispackd) and
			 not fexptype^.aisstrng
	else
	  conformable := cnfarray^.strucwaspackd = fexptype^.strucwaspackd;
	end;
    1: end; {conformable}

    begin
    if (formalptr^.idtype <> nil) and (curexp^.etyptr <> nil) then
      begin
      if comptypes(curexp^.etyptr,formalptr^.idtype) then
	begin
	if (curexp^.eclass = litnode)
	    and (formalptr^.vtype <> refparm)
	    and (formalptr^.vtype <> strparm) then
	  checkconst(formalptr^.idtype,curexp)
	end
      else
	with formalptr^ do
	  if vtype = dopeparm then
	    begin { Conformant array parameters }
	    { coerce a single char literal to a packed array of char }
	    if (curexp^.etyptr = char_ptr) and (curexp^.eclass = litnode) then
	      stretchpaofchar(curexp^.etyptr,curexp^.litval,1);
	    doneptr := formalptr^.firstparm;
	    formalptr := formalptr^.next;
	    firstparmtype := curexp^.etyptr;
	    parm1err := false;
	    if not conformable(formalptr^.idtype,curexp^.etyptr) then
	      begin error(127); parm1err := true; end
	    else if formalptr^.vtype = refparm then
	      begin
	      if curexp^.ekind <> vrbl then
		error(127);
	      end
	    else {formalptr^.vtype = cvalparm}
	      begin
	      if curexp^.etyptr^.form = cnfarrays then
		error(127);
	      end;
	    while (formalptr <> NIL) and (formalptr <> doneptr) and
		  (sy = comma) do
	      begin
	      lexp^.expptr := curexp;
	      lexp^.nextptr := newexplist;
	      lexp := lexp^.nextptr;
	      insymbol;
	      expression(fsys + [comma,rparent]);
	      formalptr := formalptr^.next;
	      if formalptr^.vtype = refparm then
		if curexp^.ekind <> vrbl then
		  error(127);
	      if (curexp^.etyptr <> NIL) then
		begin
		if parm1err then
		  begin
		  if not conformable({original formalptr^}idtype,
							curexp^.etyptr) then
		    error(127)
		  else
		    begin
		    parm1err := false;
		    firstparmtype := curexp^.etyptr;
		    end;
		  end
		else if curexp^.etyptr <> firstparmtype then
		  error(127);
		end;
	      end;
	    goto 1;
	    end
	  else if (vtype=refparm) or (vtype=strparm)
	    then error(127)
	  else if (vtype = anyvarparm) then {ok}
	  else (*check for possible coercions*)
	    if arithtype(curexp^.etyptr) and arithtype(idtype) then
	      begin if not trytowiden(curexp,idtype) then error(127) end
	    else
	      if not paofcharcomp(curexp,idtype) then error(127);
      if (formalptr^.vtype = refparm)
	   or (formalptr^.vtype = strparm)
	   or (formalptr^.vtype = anyvarparm) then
	with curexp^ do
	  begin
	  if ekind <> vrbl then error(154)
	  else if (formalptr^.idtype <> curexp^.etyptr)
	      and (formalptr^.idtype <> anyptrptr)
	      and (etyptr <> anyptrptr)
	      and (formalptr^.idtype <> anyfileptr)
	      and (formalptr^.idtype <> strgptr)
	      and (formalptr^.vtype <> anyvarparm) then
	    error(154)
	  else if (eclass = selnnode) or (eclass = unqualfldnode) then
	    begin
	    if fieldptr^.fispackd or
	       (fieldptr^.strucwaspackd and (not allow_packed)) then
	      if not (allow_packed and (formalptr^.vtype = anyvarparm)) then
		error(154);
	    end
	  else if eclass = subscrnode then
	    with arayp^ do
	      if etyptr <> nil then
		if (etyptr^.aispackd and not paofchar(etyptr)) or
		   (etyptr^.strucwaspackd and (not allow_packed)) then
		 if not (allow_packed and (formalptr^.vtype = anyvarparm)) then
		   error(154);
	  if etyptr^.form = subrange then
	    etyptr := etyptr^.rangetype;
	  end; {with curexp^}
      if (formalptr^.vtype = anyvarparm) and
	 (curexp^.ekind <> vrbl) then error(154);
      end; {types <> nil}
 1: end; {checkparm}

  begin (*actparmlist*)
  lexp := newexplist;
  actualptr := lexp;
  repeat
    insymbol;
    if formalptr = nil then
      begin expression(fsys+[comma,rparent]);
      error(126);
      end
    else
      begin
      if formalptr^.klass = routineparm then actualroutine(formalptr)
      else
	begin  {formal not routine}
	with formalptr^ do
	  if (vtype = refparm) or
	     (vtype = strparm) or
	     (vtype = anyvarparm) then
	    varparm := true;
	expression(fsys+[comma,rparent]);
	{ Check for FOR loop index variable }
	if varparm and (curexp^.eclass = idnode) then
	  if cantassign in curexp^.symptr^.info then
	    error(702);
	varparm := false;
	checkparm(formalptr);
	end; {formal not routine}
      formalptr := formalptr^.next;
      end;
    lexp^.expptr := curexp;
    if sy = comma then (* extend parameter list *)
      begin lexp^.nextptr := newexplist; lexp := lexp^.nextptr end;
  until sy <> comma;
  if formalptr <> nil then error(126)
  end (*actparmlist*);

procedure getvariantsize (fsys: setofsys; fsp: stp; var fsize: addrrange);
  {Subroutine for NEW,DISPOSE,SIZEOF: scan list of variant names}
  {FSP is ptr to TAGFLD structure (if any); FSIZE is updated to actual size}
  label 1;
  var lsp: stp; lvalu: valu; btemp: boolean;
  begin
  while sy = comma do
    begin insymbol;
    btemp := inbody;
    inbody := false;   {don't save expression node for constant }
    constant(fsys+[comma,rparent],lsp,lvalu);
    inbody := btemp;
    if fsp = nil then error(158)
    else
      begin
      if fsp^.tagfieldp <> nil then     {validate type of selector}
	if not comptypes(fsp^.tagfieldp^.idtype,lsp) then error(111);
      lsp := fsp^.fstvar;               {look for variant}
      while lsp <> nil do               {LSP is ptr to VARIANT struct}
	with lsp^ do
	  if (lvalu.ival >= varval.lo) and
	     (lvalu.ival <= varval.hi) then
	    begin fsize := unpacksize; fsp := subvar; goto 1 end
	  else lsp := nxtvar;
      fsize := fsp^.unpacksize; fsp := nil;     {no variant for this case}
      end;
  1:end;
  end; {getvariantsize}

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

  procedure subscription (fsys: setofsys);
    var larray,lsub: exptr; lsp: stp;
	lmin,lmax: integer;
    begin
    repeat larray := curexp;
      insymbol;
      expression(fsys+[comma,rbrack]);
      lsp := larray^.etyptr;
      lsub := newexpr;
      with lsub^ do
	begin eclass := subscrnode;
	ekind := larray^.ekind;
	arayp := larray; indxp := curexp;
	if lsp <> nil then
	  if (lsp^.form <> arrays) and (lsp^.form <> cnfarrays) then
	    begin error(138); etyptr := nil end
	  else (*check*)
	    begin
	    etyptr := lsp^.aeltype;
	    if not comptypes(lsp^.inxtype,indxp^.etyptr)
	      then error(139);
	    if indxp^.eclass = litnode then
	      begin
	      if strgtype(lsp) then
		begin lmax := lsp^.maxleng;
		lmin := ord(not ucsd);
		end
	      else getbounds(lsp^.inxtype,lmin,lmax);
	      if (indxp^.litval.ival < lmin)
		  or (indxp^.litval.ival > lmax) then error(302);
	      end;
	    end; {check}
	end; (*with lsub^*)
      curexp := lsub;
      until sy <> comma;
    if sy = rbrack then insymbol else error(12);
    end; (*subscription*)

  procedure selection (fsys: setofsys);
    var lcp: ctp; lsp: stp; lseln: exptr;
    begin
    insymbol;
    if sy <> ident then begin error(2); skip(fsys+selectsys) end
    else
      begin lsp := curexp^.etyptr;
      if lsp <> nil then
	if lsp^.form <> records then error(140)
	else
	  begin searchsection(lsp^.fstfld,lcp);
	  lseln := newexpr;
	  with lseln^ do
	    begin eclass := selnnode; ekind := curexp^.ekind;
	    recptr := curexp; fieldptr := lcp;
	    if lcp = nil then begin etyptr := nil; error(152) end
	    else etyptr := lcp^.idtype;
	    end;
	  curexp := lseln
	  end; (*form is record*)
      insymbol;
      end; (*sy = ident*)
    end; (*selection*)

  procedure dereference (fsys: setofsys);
    var lderf: exptr; lsp: stp;
    begin
    lderf := newexpr;
    with lderf^ do
      begin
      eclass := derfnode; ekind := vrbl; opnd := curexp;
      (* type check *)
      lsp := curexp^.etyptr;
      if lsp <> nil then
	if lsp^.form = pointer then
	  begin
	  if (lsp=anyptrptr) or
	     (lsp^.eltype=cant_deref) then
	    error(701);
	  etyptr := lsp^.eltype;
	  end
	else if lsp^.form = files then
	  begin
	  etyptr := lsp^.filtype;
	  eclass := bufnode;
	  if etyptr = NIL then error(6);
	  end
	else error(141)
      end;
    insymbol;
    curexp := lderf;
    end (*dereference*);

  begin (*selector*)
  oldvarparm := varparm; varparm := false;
  if not (sy in selectsys + fsys) then
    begin error(59); skip(selectsys+fsys) end;
  while sy in selectsys do
    begin
    if sy = lbrack then subscription(fsys)
    else if sy = period then selection(fsys)
    else dereference(fsys);
    if not (sy in fsys+selectsys) then
      begin error(59); skip(fsys+selectsys) end
    end;
  varparm := oldvarparm;
  end (*selector*);

procedure literals;
  (* parse literal in an expression *)
  begin
  curexp := newexpr;
  with curexp^ do begin
    ekind := cnst;
    eclass := litnode;
    litval := val;
    case sy of
      intconst:    etyptr := intptr;
      realconst:   etyptr := realptr;
      stringconst: if lgth = 1 then etyptr := char_ptr
		   else etyptr := makepaofchartype(lgth);
      end (*case*)
    end (*with curexp^*);
  insymbol;
  end (*literals*);

procedure constid (fcp: ctp);
  (* create tree for constant identifier *)
  begin
    curexp := newexpr;
    with curexp^ do
      begin eclass := litnode; ekind := cnst;
      etyptr := fcp^.idtype;  litval := fcp^.values;
      with litval do
	if not intval then
	  case valp^.cclass of
	    reel:
	      begin new(valp,true,reel);
	      with valp^,fcp^.values do
		begin cclass := valp^.cclass; rval := valp^.rval end;
	      end;
	    paofch:     {copy to allow later coercion to string}
	      with fcp^.values.valp^ do
		begin
		newwords(valp,(sizeof(constrec,true,strng)
			       - (strglgth-slgth)+1) div 2);
		valp^.cclass := paofch; valp^.slgth := slgth;
		moveleft(sval[1],valp^.sval[1],slgth);
		end;
	    otherwise {don't copy}
	    end;{case}
      end;
    insymbol;
  end (* constid *);

procedure variable (fcp: ctp);
  (* create tree for variable *)
  begin
    curexp := newexpr;
    with curexp^ do begin
      eclass := idnode; ekind := vrbl;
      etyptr := fcp^.idtype; symptr := fcp;
      end;
    insymbol;
  end (*variable*);

procedure unqualfield (fcp: ctp);
  (* create tree for unqualified field reference within WITH stmt scope *)
  begin
    curexp := newexpr;
    with curexp^ do begin
      eclass := unqualfldnode; ekind := vrbl;
      etyptr := fcp^.idtype;
      fieldref := fcp;
      withstptr := display[disx].wnodeptr;    {link back to WITH stmt node}
      end;
    insymbol;
  end (*unqualfield*);



@


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


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

implement

type
  fileclass = (untyped,directfile,textphile,any);

var donteval,varparm: boolean;

procedure identproc(fsys: setofsys); forward;

function newexpr: exptr;
  var lexp: exptr;
  begin
    new(lexp);
    with lexp^ do
      begin
      ekind := xpr; etyptr := nil;
      attr := nil;
      num_ops := 1;  { Most common case is 1 so make that the default }
      $IF FULLDUMP$
      echain := nil;
      if inbody then
	begin
	lastexp^.echain := lexp;
	lastexp := lexp;
	enum := ectr; ectr := ectr+1;
	end; { used by tree dumper }
      $END$
      end;
    newexpr := lexp
  end (*newexpr*);

function newexplist: elistptr;
  { Get an expression-list node of the short form }
  var lp: elistptr;
  begin
  new(lp,false);
  with lp^ do
    begin expptr := nil; nextptr := nil end;
  newexplist := lp
  end (*newexplist*);

function arithtype(fsp: stp): boolean;
  { Returns true if type is integer, real or longreal }
  begin
  if fsp = intptr then arithtype := true
  else if fsp = shortintptr then arithtype := true
  else if fsp = realptr then arithtype := true
  else arithtype := false;
  end; {arithtype}

function  widenconst(var fsp: stp;
	  var fvalu: valu; target: stp): boolean;
  var lval: integer;
  begin widenconst := false;
  if (target=realptr) and (fsp=intptr) then
    with fvalu do
      begin lval := ival;
      fsp := realptr;
      intval := false;
      new(valp,true,reel);
      with valp^ do
	begin cclass := reel; rval := lval end;
      widenconst := true;
      end;
  end; {widenconst}

function trytowiden(var fexp: exptr; newtype: stp): boolean;
  (* attempt arithmetic widening coercion on fexp *)
  var lsp: stp; lexp: exptr;
  begin trytowiden := false;
  lsp := fexp^.etyptr;
  if (lsp = intptr) or (lsp = shortintptr) then
    if newtype=realptr then
      if fexp^.eclass = litnode then
	trytowiden := widenconst
	      (fexp^.etyptr,fexp^.litval,realptr)
      else
	begin       (* insert floatnode between fexp and fexp^ *)
	lexp := newexpr;
	with lexp^ do
	  begin
	  eclass := floatnode; ekind := xpr;
	  etyptr := newtype; opnd := fexp;
	  end;
	fexp := lexp; trytowiden := true;
	end;
  end; (*trytowiden*)

function shortintandint(fsp1,fsp2: stp): boolean;
  begin
  shortintandint := ((fsp1 = intptr) or (fsp1 = shortintptr)) and
		    ((fsp2 = intptr) or (fsp2 = shortintptr));
  end;

function paofcharcomp(source: exptr; desttyptr: stp): boolean;
  { assignment compatibility for packed arrays of characters;}
  var dlgth: integer;
  begin paofcharcomp := false;
  with source^ do
    if paofchar(desttyptr) and (eclass = litnode) then
      if desttyptr^.aisstrng then
	begin
	if (etyptr = char_ptr) or paofchar(etyptr) then
	  begin
	  if etyptr=char_ptr then dlgth:=1
	  else dlgth:= litval.valp^.slgth;
	  if dlgth <= desttyptr^.maxleng then
	    begin paofcharcomp:=true;
	    if not strgtype(etyptr) then
	      begin stretchpaofchar(etyptr,litval,dlgth);
	      etyptr^.aisstrng:=true; etyptr^.unpacksize:=dlgth+1;
	      litval.valp^.cclass := strng;
	      end;
	    end;
	  end;
	end
      else if isPAC(desttyptr^.inxtype) then
	begin
	dlgth := desttyptr^.inxtype^.max;
	if etyptr = char_ptr then
	  begin
	  stretchpaofchar(etyptr,litval,dlgth);
	  paofcharcomp := true;
	  end
	else
	  if paofchar(etyptr) then
	    if litval.valp^.cclass = paofch then
	      begin
	      if litval.valp^.slgth < dlgth then
		stretchpaofchar(etyptr,litval,dlgth);
	      paofcharcomp := litval.valp^.slgth = dlgth;
	      end;
	end; {isPAC}
  end; {paofcharcomp}

function strgvalue(expr: exptr): boolean;
  {determine whether an expression can be considered a string}
  begin strgvalue := false;
  with expr^ do
    if strgtype(etyptr) then strgvalue := true
    else if eclass = litnode then
      if etyptr = char_ptr then strgvalue := true
      else if paofchar(etyptr) then
	strgvalue := litval.valp^.cclass = paofch;
  end;

procedure checkconst(dest: stp; source: exptr);
  {check constant to be assigned to object of type 'stp';
   assumes compatible types}
  var lmin,lmax: integer;
$if not bigsets$
	 k: shortint;
$end$
$if bigsets$
	k : integer;
      s : setrecptr;                    (* current set record item *)
      j : shortint;                     (* simple counter *)
      bias, rel_elem: shortint;         (* ordinal bias and relative elem *)
$end$
  begin
  if (source^.eclass = litnode) and (dest <> NIL) then
    with source^ do
      if (dest <> intptr) and (dest^.form <= subrange) then
	begin getbounds(dest,lmin,lmax);
	if (litval.ival < lmin) or (litval.ival > lmax)
	  then error(303);
	end
      else if (dest^.form = power) and (dest^.elset <> NIL) then
	begin getbounds(dest^.elset,lmin,lmax);
	with litval.valp^ do
	  if plgth-1 > lmax then error(182)
	  else
	    begin k := 0;
	    while (k < lmin) and (k < plgth) do
  $if bigsets$
	     begin
	       bias := k DIV (oldsethigh + 1);
	       rel_elem := k MOD (oldsethigh + 1);
	       s := pval;
	       for j := 1 to bias do s := s^.nxt;
	       if rel_elem in s^.val then
  $end$
  $if not bigsets$
	      if k in pval then
  $end$
		begin error(182); k := plgth end
	      else k := k+1;
  $if bigsets$
	     end;                         (* while k < lmin... *)
  $end$
	    end;
	end; (*power*)
  end; (*checkconst*)

procedure checkint;
  begin
  with curexp^ do
    if (etyptr<>nil) and (etyptr<>intptr) and (etyptr<>shortintptr) then
      error(125);
  end;

function integerparm(fsys: setofsys): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  checkint;
  lexp^.expptr := curexp; integerparm := lexp;
  end;

function charparm(fsys: setofsys): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  with curexp^ do
    if (etyptr<>nil) and (etyptr<>char_ptr) then error(125);
  lexp^.expptr := curexp; charparm := lexp;
  end;

function anyparm(fsys: setofsys; isvar: boolean): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  with curexp^ do
    if ekind = vrbl then
      begin
      if etyptr<>nil then
	if eclass = selnnode then
	  begin if fieldptr^.fispackd then error(125) end
	else if eclass = unqualfldnode then
	  begin if fieldref^.fispackd then error(125) end
	else if eclass = subscrnode then
	  if arayp^.etyptr<>nil then
	    with arayp^.etyptr^ do
	      if aispackd then
		if not (aelbitsize in [8,16]) then error(125);
      end
    else if ekind = xpr then error(125)
    else {ekind = cnst}
      if isvar then error(125)
      else if eclass = litnode then
	begin
	with litval do
	  if intval then error(125)
	  else if valp^.cclass < pset then error(125);
	end;
  lexp^.expptr := curexp; anyparm := lexp;
end;

function makeintparm(i: integer): elistptr;
var lexp: elistptr;
begin
  lexp := newexplist; lexp^.expptr := newexpr;
  with lexp^.expptr^ do
    begin  eclass := litnode; ekind := cnst; etyptr := intptr;
    with litval do begin intval := true; ival := i end;
    end;
  makeintparm := lexp;
end;

function makestrparm(s: string255): elistptr;
var lexp: elistptr;
begin
lexp := newexplist; lexp^.expptr := newexpr;
with lexp^.expptr^ do
  begin  eclass := litnode; ekind := cnst;
  new(etyptr,arrays,true,true);
  etyptr^ := strgptr^;
  with etyptr^ do
    begin maxleng := strlen(s);
    unpacksize := maxleng+1;
    end;
  with litval do
    begin intval := false;
    newwords(valp,(sizeof(constrec,true,strng)
      -(strglgth-strlen(s))+1) div 2);
    with valp^ do
      begin cclass := strng;
      slgth := strlen(s);
      moveleft(s[1],sval,strlen(s));
      end;
    end;
  end;
makestrparm := lexp;
end;

function stringparm(fsys: setofsys): elistptr;
var lexp: elistptr;
begin lexp := newexplist;
expression(fsys+[comma,rparent]);
with curexp^ do
  if (etyptr<>nil) then
    if not strgvalue(curexp) then
      begin
      error(125);
      etyptr := NIL;
      end
    else if not strgtype(etyptr) then
      begin
      if etyptr=char_ptr then stretchpaofchar(etyptr,litval,1)
      else stretchpaofchar(etyptr,litval,litval.valp^.slgth);
      with etyptr^ do
	begin
	aisstrng := true;
	maxleng := etyptr^.unpacksize;
	unpacksize := unpacksize+1;
	end;
      litval.valp^.cclass := strng;
      end;
lexp^.expptr := curexp; stringparm := lexp;
end;

function fileparm(fsys: setofsys; fclass: fileclass): elistptr;
  var lexp: elistptr;
  begin
  lexp := newexplist; expression(fsys+[comma,rparent]);
  with curexp^ do
   if (etyptr<>nil) then
    if etyptr^.form <> files then error(125)
    else
      case fclass of
	untyped: if etyptr^.filtype <> nil then error(125);
	directfile:
	  if (etyptr = textptr) or (etyptr^.filtype = nil) then error(125);
	textphile: if etyptr <> textptr then error(184);
	any: ;
	end;
  lexp^.expptr := curexp; fileparm := lexp;
  end;

function makefileexp(fileptr: ctp): exptr;
  var fileexp: exptr;
  begin fileexp := newexpr;
  with fileexp^ do
    begin ekind := vrbl; eclass := idnode;
    etyptr := textptr; symptr := fileptr;
    end;
  makefileexp := fileexp;
  end;

procedure actparmlist
(fsys: setofsys; var actualptr: elistptr; formalptr: ctp);

  var lexp: elistptr;

  procedure actualroutine(formalptr: ctp);
    begin donteval := true;  {change state of expression analyzer}
    expression(fsys+[comma,rparent]);
    donteval := false;
    with curexp^ do
      if etyptr <> nil then
	if not (etyptr^.form in [prok,funk]) then error(127)
	else if not compparmlists(formalptr^.proktype^.params,etyptr^.params,false,false)
	  then error(127)
	else if formalptr^.vtype = funcparm then
	  begin
	  if etyptr^.form <> funk then error(127)
	  else if symptr^.idtype <> formalptr^.idtype then error(127)
	  end
	else {formal is procedure parm}
	  if etyptr^.form <> prok then error(127);
    end; {actualroutine}

  procedure checkparm(var formalptr: ctp);
    label 1;
    var
      doneptr: ctp;
      firstparmtype: stp;
      parm1err: boolean;

    function conformable(cnfarray,fexptype: stp): boolean;
      label 1;
      var
	cnfmin,cnfmax,fexpmin,fexpmax : integer;

      begin
      conformable := true;
      if (cnfarray <> NIL) and (fexptype <> NIL) then
	begin
	if (fexptype^.form <> arrays) and (fexptype^.form <> cnfarrays) then
	  begin conformable := false; goto 1; end;
	if (cnfarray^.inxtype <> NIL) and (fexptype^.inxtype <> NIL) then
	  begin
	  if not comptypes(cnfarray^.inxtype,fexptype^.inxtype) then
	    begin conformable := false; goto 1; end
	  else
	    begin
	    getbounds(cnfarray^.inxtype,cnfmin,cnfmax);
	    getbounds(fexptype^.inxtype,fexpmin,fexpmax);
	    if (fexpmin < cnfmin) or (fexpmax > cnfmax) then
	      begin conformable := false; goto 1; end;
	    end;
	  end;
	if (cnfarray^.aeltype <> NIL) and (fexptype^.aeltype <> NIL) then
	  begin
	  if cnfarray^.aeltype^.form = cnfarrays then
	    begin
	    if not conformable(cnfarray^.aeltype,fexptype^.aeltype) then
	      begin conformable := false; goto 1; end;
	    end
	  else
	    if not (cnfarray^.aeltype = fexptype^.aeltype) then
	      begin conformable := false; goto 1; end;
	  end;
	if cnfarray^.aispackd or fexptype^.aispackd then
	  conformable := (cnfarray^.aispackd = fexptype^.aispackd) and
			 not fexptype^.aisstrng
	else
	  conformable := cnfarray^.strucwaspackd = fexptype^.strucwaspackd;
	end;
    1: end; {conformable}

    begin
    if (formalptr^.idtype <> nil) and (curexp^.etyptr <> nil) then
      begin
      if comptypes(curexp^.etyptr,formalptr^.idtype) then
	begin
	if (curexp^.eclass = litnode)
	    and (formalptr^.vtype <> refparm)
	    and (formalptr^.vtype <> strparm) then
	  checkconst(formalptr^.idtype,curexp)
	end
      else
	with formalptr^ do
	  if vtype = dopeparm then
	    begin { Conformant array parameters }
	    { coerce a single char literal to a packed array of char }
	    if (curexp^.etyptr = char_ptr) and (curexp^.eclass = litnode) then
	      stretchpaofchar(curexp^.etyptr,curexp^.litval,1);
	    doneptr := formalptr^.firstparm;
	    formalptr := formalptr^.next;
	    firstparmtype := curexp^.etyptr;
	    parm1err := false;
	    if not conformable(formalptr^.idtype,curexp^.etyptr) then
	      begin error(127); parm1err := true; end
	    else if formalptr^.vtype = refparm then
	      begin
	      if curexp^.ekind <> vrbl then
		error(127);
	      end
	    else {formalptr^.vtype = cvalparm}
	      begin
	      if curexp^.etyptr^.form = cnfarrays then
		error(127);
	      end;
	    while (formalptr <> NIL) and (formalptr <> doneptr) and
		  (sy = comma) do
	      begin
	      lexp^.expptr := curexp;
	      lexp^.nextptr := newexplist;
	      lexp := lexp^.nextptr;
	      insymbol;
	      expression(fsys + [comma,rparent]);
	      formalptr := formalptr^.next;
	      if formalptr^.vtype = refparm then
		if curexp^.ekind <> vrbl then
		  error(127);
	      if (curexp^.etyptr <> NIL) then
		begin
		if parm1err then
		  begin
		  if not conformable({original formalptr^}idtype,
							curexp^.etyptr) then
		    error(127)
		  else
		    begin
		    parm1err := false;
		    firstparmtype := curexp^.etyptr;
		    end;
		  end
		else if curexp^.etyptr <> firstparmtype then
		  error(127);
		end;
	      end;
	    goto 1;
	    end
	  else if (vtype=refparm) or (vtype=strparm)
	    then error(127)
	  else if (vtype = anyvarparm) then {ok}
	  else (*check for possible coercions*)
	    if arithtype(curexp^.etyptr) and arithtype(idtype) then
	      begin if not trytowiden(curexp,idtype) then error(127) end
	    else
	      if not paofcharcomp(curexp,idtype) then error(127);
      if (formalptr^.vtype = refparm)
	   or (formalptr^.vtype = strparm)
	   or (formalptr^.vtype = anyvarparm) then
	with curexp^ do
	  begin
	  if ekind <> vrbl then error(154)
	  else if (formalptr^.idtype <> curexp^.etyptr)
	      and (formalptr^.idtype <> anyptrptr)
	      and (etyptr <> anyptrptr)
	      and (formalptr^.idtype <> anyfileptr)
	      and (formalptr^.idtype <> strgptr)
	      and (formalptr^.vtype <> anyvarparm) then
	    error(154)
	  else if (eclass = selnnode) or (eclass = unqualfldnode) then
	    begin
	    if fieldptr^.fispackd or
	       (fieldptr^.strucwaspackd and (not allow_packed)) then
	      if not (allow_packed and (formalptr^.vtype = anyvarparm)) then
		error(154);
	    end
	  else if eclass = subscrnode then
	    with arayp^ do
	      if etyptr <> nil then
		if (etyptr^.aispackd and not paofchar(etyptr)) or
		   (etyptr^.strucwaspackd and (not allow_packed)) then
		 if not (allow_packed and (formalptr^.vtype = anyvarparm)) then
		   error(154);
	  if etyptr^.form = subrange then
	    etyptr := etyptr^.rangetype;
	  end; {with curexp^}
      if (formalptr^.vtype = anyvarparm) and
	 (curexp^.ekind <> vrbl) then error(154);
      end; {types <> nil}
 1: end; {checkparm}

  begin (*actparmlist*)
  lexp := newexplist;
  actualptr := lexp;
  repeat
    insymbol;
    if formalptr = nil then
      begin expression(fsys+[comma,rparent]);
      error(126);
      end
    else
      begin
      if formalptr^.klass = routineparm then actualroutine(formalptr)
      else
	begin  {formal not routine}
	with formalptr^ do
	  if (vtype = refparm) or
	     (vtype = strparm) or
	     (vtype = anyvarparm) then
	    varparm := true;
	expression(fsys+[comma,rparent]);
	{ Check for FOR loop index variable }
	if varparm and (curexp^.eclass = idnode) then
	  if cantassign in curexp^.symptr^.info then
	    error(702);
	varparm := false;
	checkparm(formalptr);
	end; {formal not routine}
      formalptr := formalptr^.next;
      end;
    lexp^.expptr := curexp;
    if sy = comma then (* extend parameter list *)
      begin lexp^.nextptr := newexplist; lexp := lexp^.nextptr end;
  until sy <> comma;
  if formalptr <> nil then error(126)
  end (*actparmlist*);

procedure getvariantsize (fsys: setofsys; fsp: stp; var fsize: addrrange);
  {Subroutine for NEW,DISPOSE,SIZEOF: scan list of variant names}
  {FSP is ptr to TAGFLD structure (if any); FSIZE is updated to actual size}
  label 1;
  var lsp: stp; lvalu: valu; btemp: boolean;
  begin
  while sy = comma do
    begin insymbol;
    btemp := inbody;
    inbody := false;   {don't save expression node for constant }
    constant(fsys+[comma,rparent],lsp,lvalu);
    inbody := btemp;
    if fsp = nil then error(158)
    else
      begin
      if fsp^.tagfieldp <> nil then     {validate type of selector}
	if not comptypes(fsp^.tagfieldp^.idtype,lsp) then error(111);
      lsp := fsp^.fstvar;               {look for variant}
      while lsp <> nil do               {LSP is ptr to VARIANT struct}
	with lsp^ do
	  if (lvalu.ival >= varval.lo) and
	     (lvalu.ival <= varval.hi) then
	    begin fsize := unpacksize; fsp := subvar; goto 1 end
	  else lsp := nxtvar;
      fsize := fsp^.unpacksize; fsp := nil;     {no variant for this case}
      end;
  1:end;
  end; {getvariantsize}

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

  procedure subscription (fsys: setofsys);
    var larray,lsub: exptr; lsp: stp;
	lmin,lmax: integer;
    begin
    repeat larray := curexp;
      insymbol;
      expression(fsys+[comma,rbrack]);
      lsp := larray^.etyptr;
      lsub := newexpr;
      with lsub^ do
	begin eclass := subscrnode;
	ekind := larray^.ekind;
	arayp := larray; indxp := curexp;
	if lsp <> nil then
	  if (lsp^.form <> arrays) and (lsp^.form <> cnfarrays) then
	    begin error(138); etyptr := nil end
	  else (*check*)
	    begin
	    etyptr := lsp^.aeltype;
	    if not comptypes(lsp^.inxtype,indxp^.etyptr)
	      then error(139);
	    if indxp^.eclass = litnode then
	      begin
	      if strgtype(lsp) then
		begin lmax := lsp^.maxleng;
		lmin := ord(not ucsd);
		end
	      else getbounds(lsp^.inxtype,lmin,lmax);
	      if (indxp^.litval.ival < lmin)
		  or (indxp^.litval.ival > lmax) then error(302);
	      end;
	    end; {check}
	end; (*with lsub^*)
      curexp := lsub;
      until sy <> comma;
    if sy = rbrack then insymbol else error(12);
    end; (*subscription*)

  procedure selection (fsys: setofsys);
    var lcp: ctp; lsp: stp; lseln: exptr;
    begin
    insymbol;
    if sy <> ident then begin error(2); skip(fsys+selectsys) end
    else
      begin lsp := curexp^.etyptr;
      if lsp <> nil then
	if lsp^.form <> records then error(140)
	else
	  begin searchsection(lsp^.fstfld,lcp);
	  lseln := newexpr;
	  with lseln^ do
	    begin eclass := selnnode; ekind := curexp^.ekind;
	    recptr := curexp; fieldptr := lcp;
	    if lcp = nil then begin etyptr := nil; error(152) end
	    else etyptr := lcp^.idtype;
	    end;
	  curexp := lseln
	  end; (*form is record*)
      insymbol;
      end; (*sy = ident*)
    end; (*selection*)

  procedure dereference (fsys: setofsys);
    var lderf: exptr; lsp: stp;
    begin
    lderf := newexpr;
    with lderf^ do
      begin
      eclass := derfnode; ekind := vrbl; opnd := curexp;
      (* type check *)
      lsp := curexp^.etyptr;
      if lsp <> nil then
	if lsp^.form = pointer then
	  begin
	  if (lsp=anyptrptr) or
	     (lsp^.eltype=cant_deref) then
	    error(701);
	  etyptr := lsp^.eltype;
	  end
	else if lsp^.form = files then
	  begin
	  etyptr := lsp^.filtype;
	  eclass := bufnode;
	  if etyptr = NIL then error(6);
	  end
	else error(141)
      end;
    insymbol;
    curexp := lderf;
    end (*dereference*);

  begin (*selector*)
  oldvarparm := varparm; varparm := false;
  if not (sy in selectsys + fsys) then
    begin error(59); skip(selectsys+fsys) end;
  while sy in selectsys do
    begin
    if sy = lbrack then subscription(fsys)
    else if sy = period then selection(fsys)
    else dereference(fsys);
    if not (sy in fsys+selectsys) then
      begin error(59); skip(fsys+selectsys) end
    end;
  varparm := oldvarparm;
  end (*selector*);

procedure literals;
  (* parse literal in an expression *)
  begin
  curexp := newexpr;
  with curexp^ do begin
    ekind := cnst;
    eclass := litnode;
    litval := val;
    case sy of
      intconst:    etyptr := intptr;
      realconst:   etyptr := realptr;
      stringconst: if lgth = 1 then etyptr := char_ptr
		   else etyptr := makepaofchartype(lgth);
      end (*case*)
    end (*with curexp^*);
  insymbol;
  end (*literals*);

procedure constid (fcp: ctp);
  (* create tree for constant identifier *)
  begin
    curexp := newexpr;
    with curexp^ do
      begin eclass := litnode; ekind := cnst;
      etyptr := fcp^.idtype;  litval := fcp^.values;
      with litval do
	if not intval then
	  case valp^.cclass of
	    reel:
	      begin new(valp,true,reel);
	      with valp^,fcp^.values do
		begin cclass := valp^.cclass; rval := valp^.rval end;
	      end;
	    paofch:     {copy to allow later coercion to string}
	      with fcp^.values.valp^ do
		begin
		newwords(valp,(sizeof(constrec,true,strng)
			       - (strglgth-slgth)+1) div 2);
		valp^.cclass := paofch; valp^.slgth := slgth;
		moveleft(sval[1],valp^.sval[1],slgth);
		end;
	    otherwise {don't copy}
	    end;{case}
      end;
    insymbol;
  end (* constid *);

procedure variable (fcp: ctp);
  (* create tree for variable *)
  begin
    curexp := newexpr;
    with curexp^ do begin
      eclass := idnode; ekind := vrbl;
      etyptr := fcp^.idtype; symptr := fcp;
      end;
    insymbol;
  end (*variable*);

procedure unqualfield (fcp: ctp);
  (* create tree for unqualified field reference within WITH stmt scope *)
  begin
    curexp := newexpr;
    with curexp^ do begin
      eclass := unqualfldnode; ekind := vrbl;
      etyptr := fcp^.idtype;
      fieldref := fcp;
      withstptr := display[disx].wnodeptr;    {link back to WITH stmt node}
      end;
    insymbol;
  end (*unqualfield*);



@


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


28.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
@Set constant bug fix. Don't dereference elset pointer until you have
checked to make sure it is not NIL.
@
text
@@


24.3
log
@Allow a single character literal to be passed to a conformant array,
packed array of char value parameter.
@
text
@d170 1
a170 1
      else if dest^.form = power then
@


24.2
log
@Change made to prevent a string from being passed to a conformant array
value parameter.
@
text
@d428 3
@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d407 2
a408 1
	  conformable := cnfarray^.aispackd = fexptype^.aispackd
@


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


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


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


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d483 2
a484 1
	   or (formalptr^.vtype = strparm) then
d493 2
a494 1
	    then error(154)
d498 3
a500 2
	       (fieldptr^.strucwaspackd and not allow_packed) then
	      error(154);
d506 3
a508 2
		   (etyptr^.strucwaspackd and not allow_packed) then
		  error(154);
@


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


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


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


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


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


1.1
log
@Initial revision
@
text
@@
