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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

25.1
date     88.03.02.09.12.20;  author bayes;  state Exp;
branches ;
next     24.2;

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

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

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

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

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

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

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

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

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

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

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

14.1
date     87.04.01.14.49.43;  author jws;  state Exp;
branches ;
next     13.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

1.1
date     86.06.30.13.57.38;  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 UTILITIES}

PROCEDURE CONSTANT (FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
  VAR LSP: STP; LCP,rcp: CTP;
      LVALU: VALU; LVP: CSP;
      lmin,lmax,i,numelems,elemcount,repcount: integer;
      scstr: scstref; vcptr,vcpbk: vcref;
      badstruct: boolean;
      expmark: ^integer;

  procedure setconst(fsp: stp);
    var tmpconst: constrec;

$if bigsets$
	(* setcrunch - moves the entire set constant list back up the
			stack, using recursion to get copies of each
			list item (chunk) out of the heap before releasing *)

	procedure setcrunch(  var s : setrecptr );
	  var   tmp : setrec;                (* copy of current set chunk*)
	  begin
		if s = NIL then
		  begin                 (* move constant record itself *)
			release( curexp );
			lvalu.intval := false;
			new( lvalu.valp, true, pset );
			moveleft( tmpconst, lvalu.valp^,
					sizeof( constrec, true, pset ) );
		  end
		else
		  begin                 (* move list items *)
			tmp := s^;
			setcrunch( tmp.nxt );
			new( s );
			moveleft( tmp, s^, sizeof( setrec ) );
		  end;
	  end;  (* setcrunch *)
$end$

    begin   (* setconst *)
    setdeno(fsys,fsp);
    with curexp^ do
      if etyptr <> nil then
	if ekind <> cnst then
	  begin
	  error(50);
	  lsp := NIL;
	  end
	else if eclass = setdenonode then
	  begin lsp := etyptr;
	  if inbody then lvalu := setcstpart
	  else begin
	    tmpconst := setcstpart.valp^;
$if bigsets$
	    setcrunch( tmpconst.pval );
	    lvalu.valp^.pval := tmpconst.pval;
$end$
$if not bigsets$
	    release(curexp); lvalu.intval := false;
	    new(lvalu.valp,true,pset);
	    moveleft(tmpconst,lvalu.valp^,sizeof(constrec,true,pset));
$end$
	    end;
	  end;
    end;

  procedure structure;
    var
      lform: structform;
      i: integer;
      done,firsttime,
      paoc_or_strg,isstring: boolean;
      curval: vcref;
      constmark: anyptr;

    procedure addcel;
      {add array element at end of list}
      begin
      new(vcptr,false);
      vcptr^.vcval := fvalu;
      if scstr^.scvcp = nil then scstr^.scvcp := vcptr
      else vcpbk^.vcnxt := vcptr;
      vcptr^.vcnxt := nil;
      vcpbk := vcptr;
      end;

    procedure addpaoccell(repcount: integer;
			  firsttime: boolean);
      var
	tmpconst: constrec;
	tmptr: anyptr;
	curspace,newchars,i,j: integer;
      begin
      tmpconst := fvalu.valp^;
      release(constmark);
      if firsttime then addcel;
      with vcpbk^ do
	begin
	if firsttime then
	  begin
	  new(vcval.valp);
	  vcval.valp^.cclass := bigpaoc;
	  vcval.valp^.paoclgth := 0;
	  end;
	with vcval.valp^ do
	  begin

	  { Compute size to extend bigpaoc structure }
	  curspace := (2+256-4) - paoclgth;
	  if curspace < 0 then curspace := 0;
	  if tmpconst.cclass = paofch then
	    newchars := tmpconst.slgth * repcount
	  else
	    newchars := tmpconst.paoclgth * repcount;
	  if newchars > curspace then
	    newbytes(tmptr,newchars - curspace);

	  for i := 1 to repcount do
	    if tmpconst.cclass = paofch then
	      for j := 1 to tmpconst.slgth do
		begin
		paoclgth := paoclgth + 1;
		$RANGE OFF$
		paocval[paoclgth] := tmpconst.sval[j];
		$IF rangechecking$
		  $RANGE ON$
		$END$
		end
	    else if tmpconst.cclass = bigpaoc then
	      for j := 1 to tmpconst.paoclgth do
		begin
		paoclgth := paoclgth + 1;
		$RANGE OFF$
		paocval[paoclgth] := fvalu.valp^.paocval[j];
		$IF rangechecking$
		  $RANGE ON$
		$END$
		end;
	  end; { with valp^ }
	end; { with scstr^ }
      end;

    procedure stripsc(var fvalu: valu);
      begin
      fvalu := fvalu.valp^.kstruc^.scvcp^.vcval;
      end;

    procedure creatvalucel;
      {create and insert record field}

      procedure insort(cur: vcref);
	{insert field 'vcptr' in list by ascending address}
	label 1;
	var p,prev: vcref;

	function lt(f1,f2: ctp): boolean;
	  {f1 & f2 are field id's.}
	  {LT <=> f1^.'offset' < f2^.'offset' }
	  begin
	  if f1^.fldaddr < f2^.fldaddr then lt := true
	  else if f1^.fldaddr > f2^.fldaddr then lt := false
	  else if f1^.fispackd and f2^.fispackd then
	    lt := f1^.fldfbit < f2^.fldfbit
	  else lt := f2^.fispackd;
	  end;

	begin {insort}
	p := scstr^.scvcp;
	if p = nil then scstr^.scvcp := vcptr
	else if lt(cur^.vid,p^.vid) then
	  begin scstr^.scvcp := cur; cur^.vcnxt := p end
	else
	  begin prev := p; p := p^.vcnxt;
	  while p<>nil do
	    if lt(cur^.vid,p^.vid) then goto 1
	    else begin prev := p; p := p^.vcnxt end;
       1: prev^.vcnxt := cur;
	  cur^.vcnxt := p;
	  end;
	end; {insort}

      begin {creatvalucel}
	new(vcptr,true);
	vcptr^.vid := rcp; vcptr^.vcnxt := nil;
	insymbol;
	if sy = colon then insymbol
	else begin error(5); badstruct := true end;
	constant(fsys+[comma,rbrack],fsp,fvalu);
	if fsp=nil then badstruct := true
	else
	  begin
	  if fsp^.form in [arrays,records,power] then
	    with fvalu.valp^ do
	      if cclass = strctconst then
		if kstruc = nil then
		  begin error(676); badstruct := true end
		else if paofchar(fsp) then stripsc(fvalu);
	  if paofchar(rcp^.idtype) and (fsp = char_ptr) then
	    stretchpaofchar(fsp,fvalu,1);
	  if rcp^.idtype <> nil then
	    if paofchar(fsp) and paofchar(rcp^.idtype) then
	      begin
	      if rcp^.idtype^.aisstrng then
		begin lmin := 1; lmax := rcp^.idtype^.maxleng end
	      else
		with rcp^.idtype^ do
		  begin
		  getbounds(inxtype,lmin,lmax);
		  end;
	      if fvalu.valp^.cclass = bigpaoc then
		begin
		if fvalu.valp^.paoclgth > lmax-lmin+1 then
		  begin error(303); badstruct := true end;
		end
	      else
		if fvalu.valp^.slgth > lmax-lmin+1 then
		  begin error(303); badstruct := true end;
	      end
	    else if comptypes(fsp,rcp^.idtype) then
	      with rcp^.idtype^ do
		begin
		if form = subrange then
		  if (fvalu.ival < min) or
		     (fvalu.ival > max) then error(303);
		end
	    else if not widenconst(fsp,fvalu,rcp^.idtype) then
	    begin error(129); badstruct := true end;
	  vcptr^.vcval := fvalu;
	  end; {fsp<>nil}
	insort(vcptr);
      end;

    procedure runfields (lcp: ctp);
      begin
      while (lcp <> nil) and (curval <> nil) do
	if lcp <> curval^.vid then
	  begin error(674); badstruct := true; lcp := nil end
	else
	  begin lcp := lcp^.next; curval := curval^.vcnxt end;
      if lcp <> nil then begin error(674); badstruct := true end;
      END;

    procedure runvariants(varp: stp);
      var vrnt: stp; lcp: ctp;

      procedure findvariant(varpt: stp);
	{tries to find a symbol equal to rcp that begins a variant.
	 This is complicated by the fact that a variant could begin the
	 variant (ad nauseum), so the search must be recursive}
	begin
	while (varpt <> nil) and (vrnt = nil) do
	  with varpt^ do
	    begin
	    if vflds = curval^.vid then vrnt := varpt;
	    if subvar <> nil then
	      with subvar^ do
		if not hasfixedpart then findvariant(fstvar);
	    varpt := nxtvar;
	    end;
	end; {findvariant}

      begin {runvariants}
      if (curval <> nil) and not badstruct then
	begin vrnt := nil;
	findvariant(varp);
	if vrnt = nil then
	  begin error(674); badstruct := true end
	else {vrnt<>nil}
	  if curval^.vcnxt = nil then
	    begin  {last value}
	    if curval^.vid^.next<> nil then
	      begin error(674); badstruct := true end;
	    end
	  else  {more values follow}
	    with vrnt^ do
	      begin lcp := curval^.vid;
	      curval := curval^.vcnxt;
	      if subvar = nil then runfields(lcp^.next)
	      else
		begin
		if subvar^.hasfixedpart then runfields(lcp^.next);
		runvariants(subvar^.fstvar);
		end;
	      end; {with vrnt^}
	end;
      end; {runvariants}

    begin {structure}
      lform := lsp^.form;
      if lform in [arrays,records,power] then
	begin
	if lform <> power then
	  begin
	  new(lvp,false,strctconst);
	  if curglobalname <> nil then
	    newident(lvp^.namep,
		curglobalname^ + '_' + gnamep^)
	  else lvp^.namep := gnamep;
	  new(scstr);
	  scstr^.scstp := lsp;
	  scstr^.scvcp := nil;
	  end;
	with lsp^ do case form of
	  arrays:
	    begin
	    insymbol;
	    if aispackd and (aeltype = char_ptr) then {string or PAOC}
	      begin
	      paoc_or_strg := true;
	      if strgtype(lsp) then
		begin
		isstring := true;
		numelems := lsp^.maxleng;
		end
	      else
		begin
		isstring := false;
		if inxtype <> NIL then
		  begin
		  getbounds(inxtype,lmin,lmax);
		  numelems := lmax - lmin + 1;
		  end
		else
		  numelems := 0;
		end;
	      end
	    else
	      begin
	      paoc_or_strg := false;
	      if inxtype <> NIL then
		begin
		getbounds(inxtype,lmin,lmax);
		numelems := lmax - lmin + 1;
		end
	      else
		numelems := 0;
	      end;
	    firsttime := true;
	    elemcount := 0;
	    REPEAT
	      mark(constmark);
	      constant(fsys+[ofsy,rbrack,comma],fsp,fvalu);
	      if sy = ofsy then {have repeat factor}
		if fsp <> intptr then
		  begin error(15); badstruct := true; repcount:=0 end
		else
		  BEGIN
		  repcount := fvalu.ival;
		  insymbol;
		  constant(fsys+[comma,rbrack],fsp,fvalu);
		  END
	      else repcount := 1;
	      if fsp = nil then badstruct := true
	      else
		begin
		if fsp^.form in [arrays,records,power] then
		  with fvalu.valp^ do
		    if cclass = strctconst then
		      if kstruc = nil then
			begin error(676); badstruct := true end
		      else if paofchar(fsp) then stripsc(fvalu);

		if paoc_or_strg then
		  begin
		  if fsp = char_ptr then stretchpaofchar(fsp,fvalu,1);
		  if not paofchar(fsp) then
		    begin
		    error(129);
		    badstruct := true;
		    end;
		  end
		else
		  begin
		  if paofchar(aeltype) then
		    begin {treat array of paofchar specially}
		    if fsp = char_ptr then
		      stretchpaofchar(fsp,fvalu,1);
		    if paofchar(fsp) then
		      begin
		      if aeltype^.aisstrng then
			begin lmin := 1; lmax := aeltype^.maxleng end
		      else
			getbounds(aeltype^.inxtype,lmin,lmax);
		      if fvalu.valp^.cclass = bigpaoc then
			begin
			if fvalu.valp^.paoclgth > lmax-lmin+1 then
			  begin error(303); badstruct := true end
			end
		      else
			if fvalu.valp^.slgth > lmax-lmin+1 then
			  begin error(303); badstruct := true end;
		      end
		    else begin error(129); badstruct := true end;
		    end { paofchar(aeltype) }
		  else if comptypes(fsp,aeltype) then
		    begin
		    if aeltype <> NIL then
		      with aeltype^ do
			begin
			if form = subrange then
			  if (fvalu.ival<min) or
			     (fvalu.ival>max) then
			    error(303);
			end;
		    end
		  else if not widenconst(fsp,fvalu,aeltype) then
		      begin error(129); badstruct := true end;
		  end;
		end; {fsp <> nil}
	      if paoc_or_strg then
		begin
		if not badstruct then
		  begin
		  if fvalu.valp^.cclass = bigpaoc then
		    elemcount := elemcount + repcount*fvalu.valp^.paoclgth
		  else
		    elemcount := elemcount + repcount*fvalu.valp^.slgth;
		  addpaoccell(repcount,firsttime);
		  end;
		end
	      else
		begin
		for i := 1 to repcount do addcel;
		elemcount := elemcount + repcount;
		end;

	    if elemcount < numelems then
	      if sy = rbrack then
		BEGIN
		elemcount := numelems;
		if not paoc_or_strg then
		  begin
		  error(731);
		  badstruct := true;
		  end;
		END
	      else if sy = comma then insymbol
	      else
		begin error(6);
		elemcount := numelems;
		badstruct := true;
		skip(fsys+[comma]);
		END;
	      firsttime := false;
	    UNTIL elemcount >= numelems;
	    if elemcount > numelems then
	      begin error(731); badstruct := true end;
	    if sy = rbrack then insymbol
	    else begin error(12); badstruct := true end;
	    end; {arrays}

	  records:
	    begin insymbol; done := false;
	    repeat    {build value structure}
	      if sy <> ident then
		begin
		error(2); badstruct := true;
		skip(fsys+[ident,rbrack]-[comma]);
		if sy = rbrack then done := true;
		end
	      else
		begin searchsection(lsp^.fstfld,rcp);
		if rcp = nil then
		  begin error(104); badstruct := true end
		else creatvalucel;
		if sy=comma then insymbol
		else if sy=rbrack then
		  begin insymbol; done := true end
		else
		  begin
		  error(6);
		  badstruct := true;
		  skip(fsys+[comma,rbrack]);
		  done := true;
		  end;
		end;
	      until done;
	    if not badstruct then
	      begin   {check value vs. type}
	      curval := scstr^.scvcp;
	      if recvar = nil then runfields(fstfld)
	      else
		begin
		if recvar^.hasfixedpart then
		  runfields(fstfld);
		runvariants(recvar^.fstvar);
		end;
	      end;
	    end;

	  power: setconst(lsp);

	  END; {case}

	if lform <> power then
	  begin lvalu.intval := false; lvalu.valp := lvp;
	  lvp^.cclass := strctconst; lvp^.kstruc := scstr;
	  lsp := scstr^.scstp; {in case it got clobbered}
	  lvp^.hasbeenoutput := false;
	  end;
	END; {arrays,records,power}
    end; {structure}

  procedure copyconstant;
    {This procedure exists to permit the creation of large structured
    constants:  The calls to expression generate garbage that is not needed
    during the generation of the s.c. but consumes memory.  A mark is made
    before the call to expression, and this procedure does whatever is needed
    so that a release can be done, and the final value preserved.  The pointer
    expmark is the mark for the call to the procedure.  Note that if CONSTANT is
    called from bodyanalyzer (inbody = true) then we don't want to release}

    var tmpconst: constrec;  {temporary storage for the constant, if needed}
      lsize: addrrange;
    begin
      with curexp^ do
	begin lvalu := litval;
	lsp := etyptr;
	if not inbody then
	  begin if not lvalu.intval then tmpconst := litval.valp^;
	  release(expmark);
	  if not lvalu.intval then
	    begin
	    case tmpconst.cclass of
	       reel:
		 begin new(lvalu.valp,true,reel);
		 lsize := sizeof(constrec,true,reel);
		 end;
	      otherwise {gave error 750}
	      end; {case}
	    moveleft(tmpconst,lvalu.valp^,lsize);
	    end; {not lvalu.intval}
	  end; {not inbody}
	end; {with}
    end {copyconstant};

  procedure constexpression;
    begin mark(expmark);
    expression(fsys);
    with curexp^ do
      if etyptr <> nil then
	begin
	if (ekind <> cnst) or (eclass <> litnode)
	  then
	    begin
	    error(50);
	    lsp := nil;
	    end
	else if not litval.intval and (etyptr<>realptr)
	  then
	    begin
	    error(750);
	    lsp := nil;
	    end
	else copyconstant;
	end
      else     { etyptr = nil }
	lsp := nil;
    end;

  BEGIN {constant}
    LSP := NIL; lvalu.intval:=true; LVALU.IVAL := 0; badstruct := false;
    IF NOT (SY IN CONSTBEGSYS) THEN
      BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END;
    case sy of
      lbrack: setconst(nil);
      stringconst:
	BEGIN
	IF LGTH = 1 THEN LSP := CHAR_PTR
	ELSE lsp := makepaofchartype(lgth);
	LVALU := VAL; INSYMBOL;
	END;
      realconst:
	begin lvalu := val; lsp := realptr; insymbol end;
      addop,intconst,notsy,lparent:
	constexpression;
      ident:
	BEGIN
	SEARCHID([KONST,types,func],LCP);
	if lcp = nil then begin insymbol; error(6); skip(fsys) end
	else
	  begin
	  LSP := lcp^.IDTYPE;
	  if lcp^.klass = func then
	    constexpression
	  else if (lcp^.klass = konst) and (lsp <> NIL) then
	    if (lsp^.form = scalar) and (lsp <> realptr) then
	      constexpression
	    else
	      begin
	      LVALU := lcp^.VALUES;
	      insymbol;
	      end
	  else if (lcp^.klass = types) and (lsp <> nil) then
	    begin
	    if lsp=strgptr then error(732);
	    insymbol;
	    if sy = lbrack then structure
	    else begin error(11); badstruct := true end;
	    end {types}
	  else begin error(50); badstruct := true end;
	  end; {lcp<>nil}
	END (* sy=ident *)
      otherwise error(106); skip(fsys);
      end; {case sy}
    IF NOT (SY IN FSYS) THEN
      BEGIN ERROR(6); SKIP(FSYS) END;
    if not badstruct then begin fsp := lsp; fvalu := lvalu end
    else
      with fvalu do
	begin fsp := nil; intval := true; ival := 0 end;
  END; (*CONSTANT*)

function compvalus (*v1,v2: valu): shortint*);
  { Returns -1,0,+1 as v1<v2, v1=v2, v1>v2 }
  { This implementation assumes that big integers can never equal small ones}
  var v: shortint;
  begin
    if v1.ival = v2.ival then v := 0
    else if v1.ival < v2.ival then v := -1
    else v := +1;
    compvalus := v
  end; {compvalus}

procedure countbits (v: integer; var nbits: shortint; var needsignbit: boolean);
  { Counts bits needed to represent an integer value }
  var
    numbits: shortint;
    power2: integer;
    done,minus,negative: boolean;
  begin
    minus := (v<0);
    if v = minint then numbits := 31
    else
      begin
      if minus then v := -v;            {get abs value}
      if v > 1073741824 then numbits := 31        {avoid overflow in loop}
      else
	begin
	numbits := 1; power2 := 2;                {find least power of 2 >= v}
	while power2 < v do
	  begin power2 := power2+power2; numbits := numbits+1 end;
	if power2 = v then                   {Handle exact power of 2}
	  if not minus then numbits := numbits+1;
	end;
      end;
  nbits := numbits; needsignbit := minus;
  end; {countbits}

function allocate (*var flc: addrrange; fsp: stp;
		    incrlc: boolean; minalign: shortint): addrrange*);
  {Allocate an instance of the given type, returning its address.
   FLC is the location counter, and INCRLC indicates whether FLC is to
   be incremented or decremented. If INCRLC=true, FLC is the first free
   address, whereas if INCRLC=false, FLC is the last used address.
   The allocated address has alignment max(fsp^.align,minalign). }
  var t,al: shortint;
      siz: integer;
  begin
  if fsp=nil then begin siz:=wordsize; al:=wordalign end
  else
    begin
    siz := fsp^.unpacksize; al := fsp^.align;
    if fsp^.sizeoflo then error(672);
    end;
  if al < minalign then al := minalign;
  try
    $ovflcheck on$
    if incrlc then
      begin
      t := FLC mod al;            {Increment FLC to a multiple of AL}
      if t<>0 then FLC := FLC + (al-t);
      allocate := FLC;            {Return current FLC}
      FLC := FLC + siz;           {Reserve space}
      end
    else
      begin {decrementing FLC}
      FLC := FLC - siz;           {Reserve space}
      t := FLC mod al;            {Decrement FLC to a multiple of AL}
      if t<>0 then FLC := FLC - t;
      allocate := FLC;            {Return current FLC}
      end;
    $if not ovflchecking$
      $ovflcheck off$
    $end$
  recover
    if escapecode = -4 (*integer overflow *) then
      begin error(672); flc := 0; allocate := 0 end
    else escape(escapecode);
  end; {allocate}

procedure wrapup(*term: termtype*);
  {Compiler termination}
  var
    s: string[10];
    i,ior: integer;
  begin
  codewrapup(term);
  iowrapup(term);
  if initlistmode <> listnone then
    begin
    if (initlistmode = listerronly) and
       (totalerrors = 0) and (totalwarnings = 0) then
      close(lp,'purge')
    else
      close(lp,'lock');
    if ioresult <> ord(inoerror) then
      begin
      setstrlen(s,0);
      ior := ioresult;
      strwrite(s,1,i,ior:1);
      warning(linenumber,'Error closing listing file, ioresult('+s+')');
      end;
    end;
  end; {wrapup}


@


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


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

PROCEDURE CONSTANT (FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
  VAR LSP: STP; LCP,rcp: CTP;
      LVALU: VALU; LVP: CSP;
      lmin,lmax,i,numelems,elemcount,repcount: integer;
      scstr: scstref; vcptr,vcpbk: vcref;
      badstruct: boolean;
      expmark: ^integer;

  procedure setconst(fsp: stp);
    var tmpconst: constrec;

$if bigsets$
	(* setcrunch - moves the entire set constant list back up the
			stack, using recursion to get copies of each
			list item (chunk) out of the heap before releasing *)

	procedure setcrunch(  var s : setrecptr );
	  var   tmp : setrec;                (* copy of current set chunk*)
	  begin
		if s = NIL then
		  begin                 (* move constant record itself *)
			release( curexp );
			lvalu.intval := false;
			new( lvalu.valp, true, pset );
			moveleft( tmpconst, lvalu.valp^,
					sizeof( constrec, true, pset ) );
		  end
		else
		  begin                 (* move list items *)
			tmp := s^;
			setcrunch( tmp.nxt );
			new( s );
			moveleft( tmp, s^, sizeof( setrec ) );
		  end;
	  end;  (* setcrunch *)
$end$

    begin   (* setconst *)
    setdeno(fsys,fsp);
    with curexp^ do
      if etyptr <> nil then
	if ekind <> cnst then
	  begin
	  error(50);
	  lsp := NIL;
	  end
	else if eclass = setdenonode then
	  begin lsp := etyptr;
	  if inbody then lvalu := setcstpart
	  else begin
	    tmpconst := setcstpart.valp^;
$if bigsets$
	    setcrunch( tmpconst.pval );
	    lvalu.valp^.pval := tmpconst.pval;
$end$
$if not bigsets$
	    release(curexp); lvalu.intval := false;
	    new(lvalu.valp,true,pset);
	    moveleft(tmpconst,lvalu.valp^,sizeof(constrec,true,pset));
$end$
	    end;
	  end;
    end;

  procedure structure;
    var
      lform: structform;
      i: integer;
      done,firsttime,
      paoc_or_strg,isstring: boolean;
      curval: vcref;
      constmark: anyptr;

    procedure addcel;
      {add array element at end of list}
      begin
      new(vcptr,false);
      vcptr^.vcval := fvalu;
      if scstr^.scvcp = nil then scstr^.scvcp := vcptr
      else vcpbk^.vcnxt := vcptr;
      vcptr^.vcnxt := nil;
      vcpbk := vcptr;
      end;

    procedure addpaoccell(repcount: integer;
			  firsttime: boolean);
      var
	tmpconst: constrec;
	tmptr: anyptr;
	curspace,newchars,i,j: integer;
      begin
      tmpconst := fvalu.valp^;
      release(constmark);
      if firsttime then addcel;
      with vcpbk^ do
	begin
	if firsttime then
	  begin
	  new(vcval.valp);
	  vcval.valp^.cclass := bigpaoc;
	  vcval.valp^.paoclgth := 0;
	  end;
	with vcval.valp^ do
	  begin

	  { Compute size to extend bigpaoc structure }
	  curspace := (2+256-4) - paoclgth;
	  if curspace < 0 then curspace := 0;
	  if tmpconst.cclass = paofch then
	    newchars := tmpconst.slgth * repcount
	  else
	    newchars := tmpconst.paoclgth * repcount;
	  if newchars > curspace then
	    newbytes(tmptr,newchars - curspace);

	  for i := 1 to repcount do
	    if tmpconst.cclass = paofch then
	      for j := 1 to tmpconst.slgth do
		begin
		paoclgth := paoclgth + 1;
		$RANGE OFF$
		paocval[paoclgth] := tmpconst.sval[j];
		$IF rangechecking$
		  $RANGE ON$
		$END$
		end
	    else if tmpconst.cclass = bigpaoc then
	      for j := 1 to tmpconst.paoclgth do
		begin
		paoclgth := paoclgth + 1;
		$RANGE OFF$
		paocval[paoclgth] := fvalu.valp^.paocval[j];
		$IF rangechecking$
		  $RANGE ON$
		$END$
		end;
	  end; { with valp^ }
	end; { with scstr^ }
      end;

    procedure stripsc(var fvalu: valu);
      begin
      fvalu := fvalu.valp^.kstruc^.scvcp^.vcval;
      end;

    procedure creatvalucel;
      {create and insert record field}

      procedure insort(cur: vcref);
	{insert field 'vcptr' in list by ascending address}
	label 1;
	var p,prev: vcref;

	function lt(f1,f2: ctp): boolean;
	  {f1 & f2 are field id's.}
	  {LT <=> f1^.'offset' < f2^.'offset' }
	  begin
	  if f1^.fldaddr < f2^.fldaddr then lt := true
	  else if f1^.fldaddr > f2^.fldaddr then lt := false
	  else if f1^.fispackd and f2^.fispackd then
	    lt := f1^.fldfbit < f2^.fldfbit
	  else lt := f2^.fispackd;
	  end;

	begin {insort}
	p := scstr^.scvcp;
	if p = nil then scstr^.scvcp := vcptr
	else if lt(cur^.vid,p^.vid) then
	  begin scstr^.scvcp := cur; cur^.vcnxt := p end
	else
	  begin prev := p; p := p^.vcnxt;
	  while p<>nil do
	    if lt(cur^.vid,p^.vid) then goto 1
	    else begin prev := p; p := p^.vcnxt end;
       1: prev^.vcnxt := cur;
	  cur^.vcnxt := p;
	  end;
	end; {insort}

      begin {creatvalucel}
	new(vcptr,true);
	vcptr^.vid := rcp; vcptr^.vcnxt := nil;
	insymbol;
	if sy = colon then insymbol
	else begin error(5); badstruct := true end;
	constant(fsys+[comma,rbrack],fsp,fvalu);
	if fsp=nil then badstruct := true
	else
	  begin
	  if fsp^.form in [arrays,records,power] then
	    with fvalu.valp^ do
	      if cclass = strctconst then
		if kstruc = nil then
		  begin error(676); badstruct := true end
		else if paofchar(fsp) then stripsc(fvalu);
	  if paofchar(rcp^.idtype) and (fsp = char_ptr) then
	    stretchpaofchar(fsp,fvalu,1);
	  if rcp^.idtype <> nil then
	    if paofchar(fsp) and paofchar(rcp^.idtype) then
	      begin
	      if rcp^.idtype^.aisstrng then
		begin lmin := 1; lmax := rcp^.idtype^.maxleng end
	      else
		with rcp^.idtype^ do
		  begin
		  getbounds(inxtype,lmin,lmax);
		  end;
	      if fvalu.valp^.cclass = bigpaoc then
		begin
		if fvalu.valp^.paoclgth > lmax-lmin+1 then
		  begin error(303); badstruct := true end;
		end
	      else
		if fvalu.valp^.slgth > lmax-lmin+1 then
		  begin error(303); badstruct := true end;
	      end
	    else if comptypes(fsp,rcp^.idtype) then
	      with rcp^.idtype^ do
		begin
		if form = subrange then
		  if (fvalu.ival < min) or
		     (fvalu.ival > max) then error(303);
		end
	    else if not widenconst(fsp,fvalu,rcp^.idtype) then
	    begin error(129); badstruct := true end;
	  vcptr^.vcval := fvalu;
	  end; {fsp<>nil}
	insort(vcptr);
      end;

    procedure runfields (lcp: ctp);
      begin
      while (lcp <> nil) and (curval <> nil) do
	if lcp <> curval^.vid then
	  begin error(674); badstruct := true; lcp := nil end
	else
	  begin lcp := lcp^.next; curval := curval^.vcnxt end;
      if lcp <> nil then begin error(674); badstruct := true end;
      END;

    procedure runvariants(varp: stp);
      var vrnt: stp; lcp: ctp;

      procedure findvariant(varpt: stp);
	{tries to find a symbol equal to rcp that begins a variant.
	 This is complicated by the fact that a variant could begin the
	 variant (ad nauseum), so the search must be recursive}
	begin
	while (varpt <> nil) and (vrnt = nil) do
	  with varpt^ do
	    begin
	    if vflds = curval^.vid then vrnt := varpt;
	    if subvar <> nil then
	      with subvar^ do
		if not hasfixedpart then findvariant(fstvar);
	    varpt := nxtvar;
	    end;
	end; {findvariant}

      begin {runvariants}
      if (curval <> nil) and not badstruct then
	begin vrnt := nil;
	findvariant(varp);
	if vrnt = nil then
	  begin error(674); badstruct := true end
	else {vrnt<>nil}
	  if curval^.vcnxt = nil then
	    begin  {last value}
	    if curval^.vid^.next<> nil then
	      begin error(674); badstruct := true end;
	    end
	  else  {more values follow}
	    with vrnt^ do
	      begin lcp := curval^.vid;
	      curval := curval^.vcnxt;
	      if subvar = nil then runfields(lcp^.next)
	      else
		begin
		if subvar^.hasfixedpart then runfields(lcp^.next);
		runvariants(subvar^.fstvar);
		end;
	      end; {with vrnt^}
	end;
      end; {runvariants}

    begin {structure}
      lform := lsp^.form;
      if lform in [arrays,records,power] then
	begin
	if lform <> power then
	  begin
	  new(lvp,false,strctconst);
	  if curglobalname <> nil then
	    newident(lvp^.namep,
		curglobalname^ + '_' + gnamep^)
	  else lvp^.namep := gnamep;
	  new(scstr);
	  scstr^.scstp := lsp;
	  scstr^.scvcp := nil;
	  end;
	with lsp^ do case form of
	  arrays:
	    begin
	    insymbol;
	    if aispackd and (aeltype = char_ptr) then {string or PAOC}
	      begin
	      paoc_or_strg := true;
	      if strgtype(lsp) then
		begin
		isstring := true;
		numelems := lsp^.maxleng;
		end
	      else
		begin
		isstring := false;
		if inxtype <> NIL then
		  begin
		  getbounds(inxtype,lmin,lmax);
		  numelems := lmax - lmin + 1;
		  end
		else
		  numelems := 0;
		end;
	      end
	    else
	      begin
	      paoc_or_strg := false;
	      if inxtype <> NIL then
		begin
		getbounds(inxtype,lmin,lmax);
		numelems := lmax - lmin + 1;
		end
	      else
		numelems := 0;
	      end;
	    firsttime := true;
	    elemcount := 0;
	    REPEAT
	      mark(constmark);
	      constant(fsys+[ofsy,rbrack,comma],fsp,fvalu);
	      if sy = ofsy then {have repeat factor}
		if fsp <> intptr then
		  begin error(15); badstruct := true; repcount:=0 end
		else
		  BEGIN
		  repcount := fvalu.ival;
		  insymbol;
		  constant(fsys+[comma,rbrack],fsp,fvalu);
		  END
	      else repcount := 1;
	      if fsp = nil then badstruct := true
	      else
		begin
		if fsp^.form in [arrays,records,power] then
		  with fvalu.valp^ do
		    if cclass = strctconst then
		      if kstruc = nil then
			begin error(676); badstruct := true end
		      else if paofchar(fsp) then stripsc(fvalu);

		if paoc_or_strg then
		  begin
		  if fsp = char_ptr then stretchpaofchar(fsp,fvalu,1);
		  if not paofchar(fsp) then
		    begin
		    error(129);
		    badstruct := true;
		    end;
		  end
		else
		  begin
		  if paofchar(aeltype) then
		    begin {treat array of paofchar specially}
		    if fsp = char_ptr then
		      stretchpaofchar(fsp,fvalu,1);
		    if paofchar(fsp) then
		      begin
		      if aeltype^.aisstrng then
			begin lmin := 1; lmax := aeltype^.maxleng end
		      else
			getbounds(aeltype^.inxtype,lmin,lmax);
		      if fvalu.valp^.cclass = bigpaoc then
			begin
			if fvalu.valp^.paoclgth > lmax-lmin+1 then
			  begin error(303); badstruct := true end
			end
		      else
			if fvalu.valp^.slgth > lmax-lmin+1 then
			  begin error(303); badstruct := true end;
		      end
		    else begin error(129); badstruct := true end;
		    end { paofchar(aeltype) }
		  else if comptypes(fsp,aeltype) then
		    begin
		    if aeltype <> NIL then
		      with aeltype^ do
			begin
			if form = subrange then
			  if (fvalu.ival<min) or
			     (fvalu.ival>max) then
			    error(303);
			end;
		    end
		  else if not widenconst(fsp,fvalu,aeltype) then
		      begin error(129); badstruct := true end;
		  end;
		end; {fsp <> nil}
	      if paoc_or_strg then
		begin
		if not badstruct then
		  begin
		  if fvalu.valp^.cclass = bigpaoc then
		    elemcount := elemcount + repcount*fvalu.valp^.paoclgth
		  else
		    elemcount := elemcount + repcount*fvalu.valp^.slgth;
		  addpaoccell(repcount,firsttime);
		  end;
		end
	      else
		begin
		for i := 1 to repcount do addcel;
		elemcount := elemcount + repcount;
		end;

	    if elemcount < numelems then
	      if sy = rbrack then
		BEGIN
		elemcount := numelems;
		if not paoc_or_strg then
		  begin
		  error(731);
		  badstruct := true;
		  end;
		END
	      else if sy = comma then insymbol
	      else
		begin error(6);
		elemcount := numelems;
		badstruct := true;
		skip(fsys+[comma]);
		END;
	      firsttime := false;
	    UNTIL elemcount >= numelems;
	    if elemcount > numelems then
	      begin error(731); badstruct := true end;
	    if sy = rbrack then insymbol
	    else begin error(12); badstruct := true end;
	    end; {arrays}

	  records:
	    begin insymbol; done := false;
	    repeat    {build value structure}
	      if sy <> ident then
		begin
		error(2); badstruct := true;
		skip(fsys+[ident,rbrack]-[comma]);
		if sy = rbrack then done := true;
		end
	      else
		begin searchsection(lsp^.fstfld,rcp);
		if rcp = nil then
		  begin error(104); badstruct := true end
		else creatvalucel;
		if sy=comma then insymbol
		else if sy=rbrack then
		  begin insymbol; done := true end
		else
		  begin
		  error(6);
		  badstruct := true;
		  skip(fsys+[comma,rbrack]);
		  done := true;
		  end;
		end;
	      until done;
	    if not badstruct then
	      begin   {check value vs. type}
	      curval := scstr^.scvcp;
	      if recvar = nil then runfields(fstfld)
	      else
		begin
		if recvar^.hasfixedpart then
		  runfields(fstfld);
		runvariants(recvar^.fstvar);
		end;
	      end;
	    end;

	  power: setconst(lsp);

	  END; {case}

	if lform <> power then
	  begin lvalu.intval := false; lvalu.valp := lvp;
	  lvp^.cclass := strctconst; lvp^.kstruc := scstr;
	  lsp := scstr^.scstp; {in case it got clobbered}
	  lvp^.hasbeenoutput := false;
	  end;
	END; {arrays,records,power}
    end; {structure}

  procedure copyconstant;
    {This procedure exists to permit the creation of large structured
    constants:  The calls to expression generate garbage that is not needed
    during the generation of the s.c. but consumes memory.  A mark is made
    before the call to expression, and this procedure does whatever is needed
    so that a release can be done, and the final value preserved.  The pointer
    expmark is the mark for the call to the procedure.  Note that if CONSTANT is
    called from bodyanalyzer (inbody = true) then we don't want to release}

    var tmpconst: constrec;  {temporary storage for the constant, if needed}
      lsize: addrrange;
    begin
      with curexp^ do
	begin lvalu := litval;
	lsp := etyptr;
	if not inbody then
	  begin if not lvalu.intval then tmpconst := litval.valp^;
	  release(expmark);
	  if not lvalu.intval then
	    begin
	    case tmpconst.cclass of
	       reel:
		 begin new(lvalu.valp,true,reel);
		 lsize := sizeof(constrec,true,reel);
		 end;
	      otherwise {gave error 750}
	      end; {case}
	    moveleft(tmpconst,lvalu.valp^,lsize);
	    end; {not lvalu.intval}
	  end; {not inbody}
	end; {with}
    end {copyconstant};

  procedure constexpression;
    begin mark(expmark);
    expression(fsys);
    with curexp^ do
      if etyptr <> nil then
	begin
	if (ekind <> cnst) or (eclass <> litnode)
	  then
	    begin
	    error(50);
	    lsp := nil;
	    end
	else if not litval.intval and (etyptr<>realptr)
	  then
	    begin
	    error(750);
	    lsp := nil;
	    end
	else copyconstant;
	end
      else     { etyptr = nil }
	lsp := nil;
    end;

  BEGIN {constant}
    LSP := NIL; lvalu.intval:=true; LVALU.IVAL := 0; badstruct := false;
    IF NOT (SY IN CONSTBEGSYS) THEN
      BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END;
    case sy of
      lbrack: setconst(nil);
      stringconst:
	BEGIN
	IF LGTH = 1 THEN LSP := CHAR_PTR
	ELSE lsp := makepaofchartype(lgth);
	LVALU := VAL; INSYMBOL;
	END;
      realconst:
	begin lvalu := val; lsp := realptr; insymbol end;
      addop,intconst,notsy,lparent:
	constexpression;
      ident:
	BEGIN
	SEARCHID([KONST,types,func],LCP);
	if lcp = nil then begin insymbol; error(6); skip(fsys) end
	else
	  begin
	  LSP := lcp^.IDTYPE;
	  if lcp^.klass = func then
	    constexpression
	  else if (lcp^.klass = konst) and (lsp <> NIL) then
	    if (lsp^.form = scalar) and (lsp <> realptr) then
	      constexpression
	    else
	      begin
	      LVALU := lcp^.VALUES;
	      insymbol;
	      end
	  else if (lcp^.klass = types) and (lsp <> nil) then
	    begin
	    if lsp=strgptr then error(732);
	    insymbol;
	    if sy = lbrack then structure
	    else begin error(11); badstruct := true end;
	    end {types}
	  else begin error(50); badstruct := true end;
	  end; {lcp<>nil}
	END (* sy=ident *)
      otherwise error(106); skip(fsys);
      end; {case sy}
    IF NOT (SY IN FSYS) THEN
      BEGIN ERROR(6); SKIP(FSYS) END;
    if not badstruct then begin fsp := lsp; fvalu := lvalu end
    else
      with fvalu do
	begin fsp := nil; intval := true; ival := 0 end;
  END; (*CONSTANT*)

function compvalus (*v1,v2: valu): shortint*);
  { Returns -1,0,+1 as v1<v2, v1=v2, v1>v2 }
  { This implementation assumes that big integers can never equal small ones}
  var v: shortint;
  begin
    if v1.ival = v2.ival then v := 0
    else if v1.ival < v2.ival then v := -1
    else v := +1;
    compvalus := v
  end; {compvalus}

procedure countbits (v: integer; var nbits: shortint; var needsignbit: boolean);
  { Counts bits needed to represent an integer value }
  var
    numbits: shortint;
    power2: integer;
    done,minus,negative: boolean;
  begin
    minus := (v<0);
    if v = minint then numbits := 31
    else
      begin
      if minus then v := -v;            {get abs value}
      if v > 1073741824 then numbits := 31        {avoid overflow in loop}
      else
	begin
	numbits := 1; power2 := 2;                {find least power of 2 >= v}
	while power2 < v do
	  begin power2 := power2+power2; numbits := numbits+1 end;
	if power2 = v then                   {Handle exact power of 2}
	  if not minus then numbits := numbits+1;
	end;
      end;
  nbits := numbits; needsignbit := minus;
  end; {countbits}

function allocate (*var flc: addrrange; fsp: stp;
		    incrlc: boolean; minalign: shortint): addrrange*);
  {Allocate an instance of the given type, returning its address.
   FLC is the location counter, and INCRLC indicates whether FLC is to
   be incremented or decremented. If INCRLC=true, FLC is the first free
   address, whereas if INCRLC=false, FLC is the last used address.
   The allocated address has alignment max(fsp^.align,minalign). }
  var t,al: shortint;
      siz: integer;
  begin
  if fsp=nil then begin siz:=wordsize; al:=wordalign end
  else
    begin
    siz := fsp^.unpacksize; al := fsp^.align;
    if fsp^.sizeoflo then error(672);
    end;
  if al < minalign then al := minalign;
  try
    $ovflcheck on$
    if incrlc then
      begin
      t := FLC mod al;            {Increment FLC to a multiple of AL}
      if t<>0 then FLC := FLC + (al-t);
      allocate := FLC;            {Return current FLC}
      FLC := FLC + siz;           {Reserve space}
      end
    else
      begin {decrementing FLC}
      FLC := FLC - siz;           {Reserve space}
      t := FLC mod al;            {Decrement FLC to a multiple of AL}
      if t<>0 then FLC := FLC - t;
      allocate := FLC;            {Return current FLC}
      end;
    $if not ovflchecking$
      $ovflcheck off$
    $end$
  recover
    if escapecode = -4 (*integer overflow *) then
      begin error(672); flc := 0; allocate := 0 end
    else escape(escapecode);
  end; {allocate}

procedure wrapup(*term: termtype*);
  {Compiler termination}
  var
    s: string[10];
    i,ior: integer;
  begin
  codewrapup(term);
  iowrapup(term);
  if initlistmode <> listnone then
    begin
    if (initlistmode = listerronly) and
       (totalerrors = 0) and (totalwarnings = 0) then
      close(lp,'purge')
    else
      close(lp,'lock');
    if ioresult <> ord(inoerror) then
      begin
      setstrlen(s,0);
      ior := ioresult;
      strwrite(s,1,i,ior:1);
      warning(linenumber,'Error closing listing file, ioresult('+s+')');
      end;
    end;
  end; {wrapup}


@


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.2
log
@Make explicit checks for the pointer to the index type being NIL before
dereferencing it to create a structured constant.
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d318 7
a324 2
		getbounds(inxtype,lmin,lmax);
		numelems := lmax - lmin + 1;
d330 7
a336 2
	      getbounds(inxtype,lmin,lmax);
	      numelems := lmax - lmin + 1;
d338 2
a339 2
	      firsttime := true;
	      elemcount := 0;
@


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


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
@d211 1
d213 2
a214 1
		  begin error(303); badstruct := true end
@


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
@@
