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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

4.1
date     86.09.30.19.15.54;  author hal;  state Exp;
branches ;
next     3.2;

3.2
date     86.09.24.09.58.52;  author hal;  state Exp;
branches ;
next     3.1;

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

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

1.1
date     86.06.30.13.45.08;  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 PARAMLIST}

implement

procedure routinetype(fsys: setofsys;
	    var fsp: stp; fsy: symbols); forward;

PROCEDURE PARAMETERLIST (fsys,FSY: SETOFSYS; VAR FPAR: CTP;
	  var flc: addrrange; forw: boolean; fmarkstacksize: addrrange);
  { Process a parameter list. Returns FPAR = ptr to first parameter,
    FLC = # of address units needed for parameters.
    The global variable LC is used to allocate copied value parms. }
  VAR
    LCP,LCP1,LCP2,LCP3,dope_parameter: CTP;
    LSP: STP; ltype: vartype;
    t,plc,iplc: ADDRRANGE;
    TEST: BOOLEAN;
    lsy: symbols;
    lsys: setofsys;

  procedure conformant_array(fsys: setofsys; var fsp: stp);
    var
      lsize : integer;
      lcp : ctp;
      lsp, lsp1, lsp2 : stp;
      test, packit, packing : boolean;
      numbits : shortint;
    BEGIN
    if sy = packedsy then
      begin
      packing := true;
      insymbol;
      end
    else
      packing := false;
    if sy <> arraysy then
      begin
      error(6);
      skip(fsys + [semicolon,rparent]);
      end
    else INSYMBOL;
    IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
    LSP1 := fsp;
    REPEAT
      NEW(LSP,cnfarrays);
      WITH LSP^ DO
	BEGIN
	AELTYPE := LSP1; INXTYPE := NIL;
	ispackable := false; sizeoflo := false;
	unpacksize := 0; align := wordalign;
	AISPACKD := FALSE; aelsize := wordsize;
	FORM := cnfarrays; info := sysinfo;
	aisstrng := false; strucwaspackd := packing;
	{ look for <ident> .. <ident> : typeident }
	new(cnf_index);
	with cnf_index^ do
	  begin
	  if sy <> ident then begin error(2); loboundid := NIL; end
	      else
		begin
	    new(loboundid,vars);
	    with loboundid^ do
	      begin
	      newident(namep,id); idtype := NIL; next := NIL;
	      klass := vars; vlev := level; globalptr := NIL;
	      vtype := boundparm; info := sysinfo + [cantassign];
	      end;
	    if not forw then enterid(loboundid);
	    insymbol;
	    end;
	  if sy = rangesy then insymbol
	  else
	    begin
	    error(22);
	    skip(fsys+[ident,semicolon,rbrack,ofsy]);
	    end;
	  if sy <> ident then begin error(2); hiboundid := NIL; end
	  else
	    begin
	    new(hiboundid,vars);
	    with hiboundid^ do
	      begin
	      newident(namep,id); idtype := NIL; next := NIL;
	      klass := vars; vlev := level; globalptr := NIL;
	      vtype := boundparm; info := sysinfo + [cantassign];
	      end;
	    if not forw then enterid(hiboundid);
	    insymbol;
	    end;
	  if sy <> colon then
	    begin
	    error(5);
	    skip(fsys+[ident,semicolon,rbrack,ofsy]);
	    end
	  else insymbol;
	  if sy <> ident then
	    begin
	    error(2);
	    lcp := NIL;
	    skip(fsys+[ident,semicolon,rbrack,ofsy]);
	    end
	  else
	    searchid([types],lcp);
	  IF lcp <> NIL THEN
	    begin
	    if lcp^.idtype <> NIL then
	      IF lcp^.idtype^.FORM <= SUBRANGE THEN
		LSP^.INXTYPE := lcp^.idtype
	      ELSE ERROR(113);
	    if loboundid <> NIL then loboundid^.idtype := lcp^.idtype;
	    if hiboundid <> NIL then hiboundid^.idtype := lcp^.idtype;
	    end;
	  end;
	END;
      LSP1 := LSP;
      insymbol;
      TEST := SY <> semicolon;
      IF NOT TEST THEN
	begin
	if packing then error(142);
	INSYMBOL;
	end;
    UNTIL TEST;
    IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
    IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
    if (sy = arraysy) or (sy = packedsy) then
      begin
      if packing then error(142);
      conformant_array(fsys,lsp);
      end
    else if sy = ident then
      begin
      searchid([types],lcp);
      lsp := lcp^.idtype;

      REPEAT
	WITH LSP1^ DO
	  BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
	  IF LSP <> NIL THEN
	    info := sysinfo + (lsp^.info * [mustinitialize,cantassign]);
	  IF (INXTYPE <> NIL) and (AELTYPE <> NIL) THEN
	    BEGIN
    {***** Compute array element size *****}
	    packit := PACKING and aeltype^.ispackable;
	    IF packit THEN
	      BEGIN         {packable array}
	      numbits := aeltype^.bitsize;
	      if numbits+numbits > BITSPERWORD then packit := false
	      else
		begin
		{*** 1,2,4,8,16 bit arrays only ***}
		if numbits > 8 then numbits := 16
		else if numbits > 4 then numbits := 8
		else if numbits = 3 then numbits := 4;
		end
	      END;
	    if packit then
	      begin
	      AISPACKD := TRUE; AISSTRNG := FALSE;
	      aelbitsize := numbits;
	      align := wordalign;
	      end
	    else
	      begin
	      AISPACKD := FALSE;
	      with aeltype^ do
		begin
		if sizeoflo then error(675);
		lsize := ((unpacksize + align-1) div align) * align;
		end;
	      aelsize := lsize;
	      align := wordalign;
	      end;
	    unpacksize := 0;
	    END
	  END;
	LSP := LSP1; LSP1 := LSP2
      UNTIL LSP1 = NIL;
      end
    else error(2);
    FSP := LSP;
    if stdpasc then error(606);
    END; (* conformant_array *)

BEGIN
  IF NOT (SY IN FSY + [LPARENT]) THEN
    BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END;
  IF SY = LPARENT THEN
    BEGIN INSYMBOL;
    IF NOT (SY IN [IDENT,VARSY,anyvarsy,procsy,funcsy]) THEN
      BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END;
    LCP1 := NIL; LCP3 := NIL;
    WHILE SY IN [IDENT,VARSY,anyvarsy,procsy,funcsy] DO
      begin
      if (sy = procsy) or (sy = funcsy) then
	begin lsy := sy; insymbol;
	if sy <> ident then error(2)
	else
	  begin new(lcp,routineparm,procparm);
	  with lcp^ do
	    begin newident(namep,id); idtype := nil; info := sysinfo;
	    klass := routineparm; vlev := level; globalptr := nil;
	    if lsy = funcsy then vtype := funcparm
	    else vtype := procparm;
	    next := lcp1; lcp1 := lcp;  {i.e., push}
	    end;
	  if not forw then enterid(lcp);
	  insymbol;
	  if lsy = procsy then lsys := [lparent,rparent,semicolon]
	  else lsys := [lparent,rparent,semicolon,colon];
	  if not (sy in lsys) then
	    begin error(7); skip(lsys+fsys+fsy) end;
	  routinetype(fsys+[rparent],lcp^.proktype,lsy);
	  if lsy = funcsy then
	    begin lcp^.proktype^.form := funk;
	    if sy <> colon then error(123)
	    else
	      begin insymbol;
	      if sy <> ident then error(2)
	      else
		begin searchid([types],lcp2);
		lcp^.idtype := lcp2^.idtype;
		if lcp2^.idtype=strgptr then error(733);
		end;
	      insymbol;
	      end; {colon}
	    end;
	  end; {routine name ident}
	end {proc,func}
      else {var, anyvar, ident}
	BEGIN
	IF SY = VARSY THEN
	  BEGIN ltype := refparm; INSYMBOL; END
	else if sy = anyvarsy then
	  begin
	  ltype := anyvarparm;
	  insymbol;
	  end
	ELSE ltype := valparm;
	LCP2 := NIL;
	REPEAT
	  IF SY <> IDENT THEN ERROR(2)
	  ELSE
	    BEGIN
	    if (ltype = refparm) or (ltype = anyvarparm) then
	      new(lcp,vars,refparm)
	    else new(lcp,vars,cvalparm (*worst case*));
	    WITH LCP^ DO
	      BEGIN
	      newident(namep,ID); IDTYPE := NIL; NEXT := LCP2;
	      KLASS := VARS; VLEV := LEVEL; globalptr := NIL;
	      vtype := ltype; info := sysinfo;
	      END;
	    if not forw then ENTERID(LCP);
	    LCP2 := LCP;
	    INSYMBOL;
	    END;
	  IF NOT (SY IN FSYS + [COMMA,COLON]) THEN
	    BEGIN ERROR(7);
	      SKIP(FSYS + [COMMA,SEMICOLON,RPARENT,COLON])
	    END;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN
	  BEGIN INSYMBOL;
	  IF SY = IDENT THEN
	    BEGIN
	    SEARCHID([TYPES],LCP);
	    LSP := LCP^.IDTYPE;
	    if ltype = valparm then   {check for copied value parameter}
	      IF LSP <> NIL THEN
		begin
		IF cantassign in lsp^.info THEN ERROR(121);
		IF lsp = strgptr THEN ERROR(733);
		if lsp^.sizeoflo then error(653);
		if lsp <> nil then
		  with lsp^ do
		    IF ((unpacksize > wordsize) and (form <> prok)) OR
		       strgtype(lsp) THEN
		      ltype := cvalparm;            {pass copied value}
		end;
	    { Fill in IDTYPE, record value pass choice in current parms }
	    LCP3 := LCP2;
	    if (ltype=refparm) and
	      (lsp=strgptr) then ltype := strparm;
	    if (ltype = anyvarparm) and
	       (lsp = strgptr) then error(733);
	    WHILE LCP2 <> NIL DO
	      BEGIN LCP := LCP2;
		WITH LCP2^ DO
		  BEGIN IDTYPE := LSP; vtype := ltype;
		    LCP2 := NEXT
		  END
	      END;
	    LCP^.NEXT := LCP1; LCP1 := LCP3;
	    INSYMBOL
	    END (* sy=ident *)
	  ELSE if (sy = arraysy) or (sy = packedsy) then
	    begin
	    lsp := NIL;
	    conformant_array(fsys,lsp);
	    lcp3 := lcp2;
	    while lcp2 <> NIL do
	      begin
	      lcp := lcp2;
	      with lcp2^ do
		begin
		idtype := lsp;
		if ltype = valparm then
		  begin
		  vtype := cvalparm;
		  if cantassign in lsp^.info then error(121);
		  end
		else if ltype = anyvarparm then error(733)
		else vtype := refparm;
		lcp2 := next;
		end
	      end;
	    lcp^.next := lcp1; lcp1 := lcp3;
	    insymbol;
	    { add a parameter to corespond to all boundparms }
	    new(dope_parameter,vars,dopeparm);
	    with dope_parameter^ do
	      begin
	      namep := nil;
	      {copy idtype} new(idtype); idtype^ := lsp^;
	      vtype := dopeparm;
	      next := lcp^.next; klass := vars;
	      firstparm := lcp1;
	      end;
	    lcp^.next := dope_parameter;
	    end
	  ELSE ERROR(2);
	  IF NOT (SY IN [SEMICOLON,RPARENT]) THEN
	    BEGIN ERROR(7); SKIP(FSYS + [SEMICOLON,RPARENT]) END;
	  END (* sy=colon *)
	ELSE ERROR(5);
	end; {ident,var}
      IF SY = SEMICOLON THEN
	BEGIN INSYMBOL;
	IF NOT (SY IN FSYS + [IDENT,VARSY,anyvarsy,funcsy,procsy]) THEN
	  BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END
	END;
      END; (*WHILE*)
    IF SY = RPARENT THEN
      BEGIN INSYMBOL;
	IF NOT (SY IN FSY + FSYS) THEN
	  BEGIN ERROR(6); SKIP(FSY + FSYS) END
      END
    ELSE ERROR(4);
{Reverse order of parameter list, allocate addresses}
    plc := lcaftermarkstack + fmarkstacksize;
    LCP3 := NIL; iplc := plc;
    WHILE LCP1 <> NIL DO
      WITH LCP1^ DO
	BEGIN LCP2 := NEXT; NEXT := LCP3;
	case vtype of
	  valparm:  vaddr := allocate(plc, idtype, true, parmalign);
	  funcparm,
	  procparm: vaddr := allocate(plc, proktype, true, parmalign);
	  anyvarparm,
	  refparm:  vaddr := allocate(plc, anyptrptr, true, parmalign);
	  strparm:  vaddr := allocate(plc, strgptr, true, parmalign);
	  cvalparm: begin     {Copied value parameter, VADDR=addr of copy}
		    vptraddr := allocate(plc, anyptrptr, true, parmalign);
		    if idtype <> NIL then
		      if idtype^.form <> cnfarrays then
			vaddr := allocate(LC, idtype, false, 1)
		      else {value conformant array parameter}
			vaddr := vptraddr;
		    end;
	  dopeparm: { Allocate space for the conformant array "dope vector" }
		    begin
		    lsp := idtype;
		    $PARTIAL_EVAL$
		    while (lsp <> NIL) and (lsp^.form = cnfarrays) do
		      begin
		      with lsp^.cnf_index^ do
			begin
			if (loboundid<>NIL) and (loboundid^.idtype<>NIL) then
			  with loboundid^ do
			    vaddr := allocate(plc, idtype, true, parmalign);
			if hiboundid <> NIL then
			  with hiboundid^ do
			    begin
			    vaddr := allocate(plc, idtype, true, parmalign);
			    if loboundid <> NIL then
			      { Allocate space to maintain a size }
			      t := allocate(plc, idtype, true, parmalign);
			    end; {with hiboundid^}
			end; { with lsp^.cnf_index^ }
		      lsp := lsp^.aeltype;
		      end; {while (lsp <> NIL) and (lsp^.form = cnfarrays)}
		    $IF NOT partialevaling$
		      $PARTIAL_EVAL OFF$
		    $END$

		    end;
	  end; {case}
	LCP3 := LCP1; LCP1 := LCP2
	END;
    FPAR := LCP3;
    plc := abs(plc-iplc);
    t := plc mod parmalign;
    if t <> 0 then plc := plc + (parmalign-t);
    flc := plc;
    END (* IF SY=LPARENT *)
  ELSE BEGIN FPAR := NIL; FLC := 0 END;    {no parameters}
  END; (*PARAMETERLIST*)

@


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


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

implement

procedure routinetype(fsys: setofsys;
	    var fsp: stp; fsy: symbols); forward;

PROCEDURE PARAMETERLIST (fsys,FSY: SETOFSYS; VAR FPAR: CTP;
	  var flc: addrrange; forw: boolean; fmarkstacksize: addrrange);
  { Process a parameter list. Returns FPAR = ptr to first parameter,
    FLC = # of address units needed for parameters.
    The global variable LC is used to allocate copied value parms. }
  VAR
    LCP,LCP1,LCP2,LCP3,dope_parameter: CTP;
    LSP: STP; ltype: vartype;
    t,plc,iplc: ADDRRANGE;
    TEST: BOOLEAN;
    lsy: symbols;
    lsys: setofsys;

  procedure conformant_array(fsys: setofsys; var fsp: stp);
    var
      lsize : integer;
      lcp : ctp;
      lsp, lsp1, lsp2 : stp;
      test, packit, packing : boolean;
      numbits : shortint;
    BEGIN
    if sy = packedsy then
      begin
      packing := true;
      insymbol;
      end
    else
      packing := false;
    if sy <> arraysy then
      begin
      error(6);
      skip(fsys + [semicolon,rparent]);
      end
    else INSYMBOL;
    IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
    LSP1 := fsp;
    REPEAT
      NEW(LSP,cnfarrays);
      WITH LSP^ DO
	BEGIN
	AELTYPE := LSP1; INXTYPE := NIL;
	ispackable := false; sizeoflo := false;
	unpacksize := 0; align := wordalign;
	AISPACKD := FALSE; aelsize := wordsize;
	FORM := cnfarrays; info := sysinfo;
	aisstrng := false; strucwaspackd := packing;
	{ look for <ident> .. <ident> : typeident }
	new(cnf_index);
	with cnf_index^ do
	  begin
	  if sy <> ident then begin error(2); loboundid := NIL; end
	      else
		begin
	    new(loboundid,vars);
	    with loboundid^ do
	      begin
	      newident(namep,id); idtype := NIL; next := NIL;
	      klass := vars; vlev := level; globalptr := NIL;
	      vtype := boundparm; info := sysinfo + [cantassign];
	      end;
	    if not forw then enterid(loboundid);
	    insymbol;
	    end;
	  if sy = rangesy then insymbol
	  else
	    begin
	    error(22);
	    skip(fsys+[ident,semicolon,rbrack,ofsy]);
	    end;
	  if sy <> ident then begin error(2); hiboundid := NIL; end
	  else
	    begin
	    new(hiboundid,vars);
	    with hiboundid^ do
	      begin
	      newident(namep,id); idtype := NIL; next := NIL;
	      klass := vars; vlev := level; globalptr := NIL;
	      vtype := boundparm; info := sysinfo + [cantassign];
	      end;
	    if not forw then enterid(hiboundid);
	    insymbol;
	    end;
	  if sy <> colon then
	    begin
	    error(5);
	    skip(fsys+[ident,semicolon,rbrack,ofsy]);
	    end
	  else insymbol;
	  if sy <> ident then
	    begin
	    error(2);
	    lcp := NIL;
	    skip(fsys+[ident,semicolon,rbrack,ofsy]);
	    end
	  else
	    searchid([types],lcp);
	  IF lcp <> NIL THEN
	    begin
	    if lcp^.idtype <> NIL then
	      IF lcp^.idtype^.FORM <= SUBRANGE THEN
		LSP^.INXTYPE := lcp^.idtype
	      ELSE ERROR(113);
	    if loboundid <> NIL then loboundid^.idtype := lcp^.idtype;
	    if hiboundid <> NIL then hiboundid^.idtype := lcp^.idtype;
	    end;
	  end;
	END;
      LSP1 := LSP;
      insymbol;
      TEST := SY <> semicolon;
      IF NOT TEST THEN
	begin
	if packing then error(142);
	INSYMBOL;
	end;
    UNTIL TEST;
    IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
    IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
    if (sy = arraysy) or (sy = packedsy) then
      begin
      if packing then error(142);
      conformant_array(fsys,lsp);
      end
    else if sy = ident then
      begin
      searchid([types],lcp);
      lsp := lcp^.idtype;

      REPEAT
	WITH LSP1^ DO
	  BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
	  IF LSP <> NIL THEN
	    info := sysinfo + (lsp^.info * [mustinitialize,cantassign]);
	  IF (INXTYPE <> NIL) and (AELTYPE <> NIL) THEN
	    BEGIN
    {***** Compute array element size *****}
	    packit := PACKING and aeltype^.ispackable;
	    IF packit THEN
	      BEGIN         {packable array}
	      numbits := aeltype^.bitsize;
	      if numbits+numbits > BITSPERWORD then packit := false
	      else
		begin
		{*** 1,2,4,8,16 bit arrays only ***}
		if numbits > 8 then numbits := 16
		else if numbits > 4 then numbits := 8
		else if numbits = 3 then numbits := 4;
		end
	      END;
	    if packit then
	      begin
	      AISPACKD := TRUE; AISSTRNG := FALSE;
	      aelbitsize := numbits;
	      align := wordalign;
	      end
	    else
	      begin
	      AISPACKD := FALSE;
	      with aeltype^ do
		begin
		if sizeoflo then error(675);
		lsize := ((unpacksize + align-1) div align) * align;
		end;
	      aelsize := lsize;
	      align := wordalign;
	      end;
	    unpacksize := 0;
	    END
	  END;
	LSP := LSP1; LSP1 := LSP2
      UNTIL LSP1 = NIL;
      end
    else error(2);
    FSP := LSP;
    if stdpasc then error(606);
    END; (* conformant_array *)

BEGIN
  IF NOT (SY IN FSY + [LPARENT]) THEN
    BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END;
  IF SY = LPARENT THEN
    BEGIN INSYMBOL;
    IF NOT (SY IN [IDENT,VARSY,anyvarsy,procsy,funcsy]) THEN
      BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END;
    LCP1 := NIL; LCP3 := NIL;
    WHILE SY IN [IDENT,VARSY,anyvarsy,procsy,funcsy] DO
      begin
      if (sy = procsy) or (sy = funcsy) then
	begin lsy := sy; insymbol;
	if sy <> ident then error(2)
	else
	  begin new(lcp,routineparm,procparm);
	  with lcp^ do
	    begin newident(namep,id); idtype := nil; info := sysinfo;
	    klass := routineparm; vlev := level; globalptr := nil;
	    if lsy = funcsy then vtype := funcparm
	    else vtype := procparm;
	    next := lcp1; lcp1 := lcp;  {i.e., push}
	    end;
	  if not forw then enterid(lcp);
	  insymbol;
	  if lsy = procsy then lsys := [lparent,rparent,semicolon]
	  else lsys := [lparent,rparent,semicolon,colon];
	  if not (sy in lsys) then
	    begin error(7); skip(lsys+fsys+fsy) end;
	  routinetype(fsys+[rparent],lcp^.proktype,lsy);
	  if lsy = funcsy then
	    begin lcp^.proktype^.form := funk;
	    if sy <> colon then error(123)
	    else
	      begin insymbol;
	      if sy <> ident then error(2)
	      else
		begin searchid([types],lcp2);
		lcp^.idtype := lcp2^.idtype;
		if lcp2^.idtype=strgptr then error(733);
		end;
	      insymbol;
	      end; {colon}
	    end;
	  end; {routine name ident}
	end {proc,func}
      else {var, anyvar, ident}
	BEGIN
	IF SY = VARSY THEN
	  BEGIN ltype := refparm; INSYMBOL; END
	else if sy = anyvarsy then
	  begin
	  ltype := anyvarparm;
	  insymbol;
	  end
	ELSE ltype := valparm;
	LCP2 := NIL;
	REPEAT
	  IF SY <> IDENT THEN ERROR(2)
	  ELSE
	    BEGIN
	    if (ltype = refparm) or (ltype = anyvarparm) then
	      new(lcp,vars,refparm)
	    else new(lcp,vars,cvalparm (*worst case*));
	    WITH LCP^ DO
	      BEGIN
	      newident(namep,ID); IDTYPE := NIL; NEXT := LCP2;
	      KLASS := VARS; VLEV := LEVEL; globalptr := NIL;
	      vtype := ltype; info := sysinfo;
	      END;
	    if not forw then ENTERID(LCP);
	    LCP2 := LCP;
	    INSYMBOL;
	    END;
	  IF NOT (SY IN FSYS + [COMMA,COLON]) THEN
	    BEGIN ERROR(7);
	      SKIP(FSYS + [COMMA,SEMICOLON,RPARENT,COLON])
	    END;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN
	  BEGIN INSYMBOL;
	  IF SY = IDENT THEN
	    BEGIN
	    SEARCHID([TYPES],LCP);
	    LSP := LCP^.IDTYPE;
	    if ltype = valparm then   {check for copied value parameter}
	      IF LSP <> NIL THEN
		begin
		IF cantassign in lsp^.info THEN ERROR(121);
		IF lsp = strgptr THEN ERROR(733);
		if lsp^.sizeoflo then error(653);
		if lsp <> nil then
		  with lsp^ do
		    IF ((unpacksize > wordsize) and (form <> prok)) OR
		       strgtype(lsp) THEN
		      ltype := cvalparm;            {pass copied value}
		end;
	    { Fill in IDTYPE, record value pass choice in current parms }
	    LCP3 := LCP2;
	    if (ltype=refparm) and
	      (lsp=strgptr) then ltype := strparm;
	    if (ltype = anyvarparm) and
	       (lsp = strgptr) then error(733);
	    WHILE LCP2 <> NIL DO
	      BEGIN LCP := LCP2;
		WITH LCP2^ DO
		  BEGIN IDTYPE := LSP; vtype := ltype;
		    LCP2 := NEXT
		  END
	      END;
	    LCP^.NEXT := LCP1; LCP1 := LCP3;
	    INSYMBOL
	    END (* sy=ident *)
	  ELSE if (sy = arraysy) or (sy = packedsy) then
	    begin
	    lsp := NIL;
	    conformant_array(fsys,lsp);
	    lcp3 := lcp2;
	    while lcp2 <> NIL do
	      begin
	      lcp := lcp2;
	      with lcp2^ do
		begin
		idtype := lsp;
		if ltype = valparm then
		  begin
		  vtype := cvalparm;
		  if cantassign in lsp^.info then error(121);
		  end
		else if ltype = anyvarparm then error(733)
		else vtype := refparm;
		lcp2 := next;
		end
	      end;
	    lcp^.next := lcp1; lcp1 := lcp3;
	    insymbol;
	    { add a parameter to corespond to all boundparms }
	    new(dope_parameter,vars,dopeparm);
	    with dope_parameter^ do
	      begin
	      namep := nil;
	      {copy idtype} new(idtype); idtype^ := lsp^;
	      vtype := dopeparm;
	      next := lcp^.next; klass := vars;
	      firstparm := lcp1;
	      end;
	    lcp^.next := dope_parameter;
	    end
	  ELSE ERROR(2);
	  IF NOT (SY IN [SEMICOLON,RPARENT]) THEN
	    BEGIN ERROR(7); SKIP(FSYS + [SEMICOLON,RPARENT]) END;
	  END (* sy=colon *)
	ELSE ERROR(5);
	end; {ident,var}
      IF SY = SEMICOLON THEN
	BEGIN INSYMBOL;
	IF NOT (SY IN FSYS + [IDENT,VARSY,anyvarsy,funcsy,procsy]) THEN
	  BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END
	END;
      END; (*WHILE*)
    IF SY = RPARENT THEN
      BEGIN INSYMBOL;
	IF NOT (SY IN FSY + FSYS) THEN
	  BEGIN ERROR(6); SKIP(FSY + FSYS) END
      END
    ELSE ERROR(4);
{Reverse order of parameter list, allocate addresses}
    plc := lcaftermarkstack + fmarkstacksize;
    LCP3 := NIL; iplc := plc;
    WHILE LCP1 <> NIL DO
      WITH LCP1^ DO
	BEGIN LCP2 := NEXT; NEXT := LCP3;
	case vtype of
	  valparm:  vaddr := allocate(plc, idtype, true, parmalign);
	  funcparm,
	  procparm: vaddr := allocate(plc, proktype, true, parmalign);
	  anyvarparm,
	  refparm:  vaddr := allocate(plc, anyptrptr, true, parmalign);
	  strparm:  vaddr := allocate(plc, strgptr, true, parmalign);
	  cvalparm: begin     {Copied value parameter, VADDR=addr of copy}
		    vptraddr := allocate(plc, anyptrptr, true, parmalign);
		    if idtype <> NIL then
		      if idtype^.form <> cnfarrays then
			vaddr := allocate(LC, idtype, false, 1)
		      else {value conformant array parameter}
			vaddr := vptraddr;
		    end;
	  dopeparm: { Allocate space for the conformant array "dope vector" }
		    begin
		    lsp := idtype;
		    $PARTIAL_EVAL$
		    while (lsp <> NIL) and (lsp^.form = cnfarrays) do
		      begin
		      with lsp^.cnf_index^ do
			begin
			if (loboundid<>NIL) and (loboundid^.idtype<>NIL) then
			  with loboundid^ do
			    vaddr := allocate(plc, idtype, true, parmalign);
			if hiboundid <> NIL then
			  with hiboundid^ do
			    begin
			    vaddr := allocate(plc, idtype, true, parmalign);
			    if loboundid <> NIL then
			      { Allocate space to maintain a size }
			      t := allocate(plc, idtype, true, parmalign);
			    end; {with hiboundid^}
			end; { with lsp^.cnf_index^ }
		      lsp := lsp^.aeltype;
		      end; {while (lsp <> NIL) and (lsp^.form = cnfarrays)}
		    $IF NOT partialevaling$
		      $PARTIAL_EVAL OFF$
		    $END$

		    end;
	  end; {case}
	LCP3 := LCP1; LCP1 := LCP2
	END;
    FPAR := LCP3;
    plc := abs(plc-iplc);
    t := plc mod parmalign;
    if t <> 0 then plc := plc + (parmalign-t);
    flc := plc;
    END (* IF SY=LPARENT *)
  ELSE BEGIN FPAR := NIL; FLC := 0 END;    {no parameters}
  END; (*PARAMETERLIST*)

@


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
@No changes actually make.
@
text
@@


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


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.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.2
log
@Changes from Scott Bayes.
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@d68 2
a69 1
	    enterid(loboundid); insymbol;
d87 1
a87 1
	    enterid(hiboundid);
d326 1
@


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


1.1
log
@Initial revision
@
text
@@
