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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

38.1
date     89.08.29.11.17.46;  author jwh;  state Exp;
branches ;
next     37.2;

37.2
date     89.08.12.17.23.33;  author jwh;  state Exp;
branches ;
next     37.1;

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

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

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

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

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

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

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

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

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

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

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

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

25.1
date     88.03.02.09.12.10;  author bayes;  state Exp;
branches ;
next     24.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1.1
date     86.06.30.13.56.59;  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 TYP}

procedure routinetype(*fsys: setofsys; var fsp: stp; fsy: symbol*);
  var lsp: stp; llc: addrrange; oldtop: disprange;
  begin
  new(lsp,prok);
  with lsp^ do
    begin form := prok; params := nil; info := sysinfo;
    ispackable := false; sizeoflo := false;
    unpacksize := PROKSIZE; align := PROKALIGN;
    parmlc := 0;
    if sy = lparent then
      begin
      llc := lc; lc := lcaftermarkstack;
      oldtop := top;
      if top < displimit then
	begin top := top + 1;
	with display[top] do
	  begin
	  fname := nil; occur := BLOCKscope;
	  fmodule := nil; ffile := nil;
	  flabel := nil; available_module := nil;
	  end;
	end
      else error(662);
      if fsy = procsy then
	parameterlist(fsys,[semicolon],params,parmlc,false,0)
      else parameterlist(fsys,[semicolon,colon],params,parmlc,false,0);
      lc := llc;
      top := oldtop;
      end;
    end;
  fsp := lsp;
  end;

PROCEDURE TYP (FSYS: SETOFSYS; VAR FSP: STP);
  VAR LSP,LSP1: STP; OLDTOP: DISPRANGE; llc: addrrange;
      DISPL: ADDRRANGE; NEXTBIT,maxfldalign: shortint;
      PACKING: BOOLEAN; LMIN,LMAX: integer; linfo: infobits;
      lcproot: ctp;

  PROCEDURE SIMPLETYPE (FSYS: SETOFSYS; VAR FSP: STP);
    VAR LSP,LSP1: STP;
	LCP,LCP1: CTP;
	TTOP: DISPRANGE;
	LVALU: VALU;
	LCNT,minbits,maxbits: shortint;
	minsign,maxsign,test: boolean;
    BEGIN
    IF NOT (SY IN SIMPTYPEBEGSYS) THEN
      BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END;
    IF SY IN SIMPTYPEBEGSYS THEN
      BEGIN
      IF SY = LPARENT THEN
	BEGIN                                 {Enumerated type}
	TTOP := TOP;
	WHILE DISPLAY[TOP].OCCUR in [RECORDscope,WITHscope] DO TOP := TOP - 1;
	NEW(LSP,SCALAR,DECLARED);
	WITH LSP^ DO
	  BEGIN FORM := SCALAR;
	  unpacksize := SCALARSIZE; align := SCALARALIGN; sizeoflo := false;
	  ispackable := true; signbit := false;
	  SCALKIND := DECLARED; info := linfo
	  END;
	LCP1 := NIL; LCNT := 0;
	REPEAT INSYMBOL;
	  IF SY = IDENT THEN
	    BEGIN NEW(LCP,KONST);
	      WITH LCP^ DO
		BEGIN newident(namep,ID); IDTYPE := LSP; NEXT := LCP1;
		   KLASS := KONST; info := linfo;
		   values.intval := true; values.IVAL := LCNT;
		END;
	      ENTERID(LCP);
	      LCNT := LCNT + 1;
	      LCP1 := LCP; INSYMBOL
	    END
	  ELSE ERROR(2);
	  IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
	UNTIL SY <> COMMA;
	LSP^.FCONST := LCP1;
	countbits(lcnt-1,lcnt,maxsign);
	LSP^.bitsize := lcnt;
	TOP := TTOP;
	IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
	END (*SY=LPARENT*)
      ELSE
	BEGIN
	IF SY = IDENT THEN    {Is it type name or subrange declaration?}
	  { Added FUNC as a class to search 8/12/89 JWH }
	  begin SEARCHID([TYPES,KONST,FUNC],LCP);
	  test:=(LCP^.KLASS = TYPES);
	  end
	else test:=false;
	if test then
	  BEGIN                               {Type name}
	  if disx = disdef.level then
	    if lcp^.namep^ = disdef.id^ then
	      error(190);
	  INSYMBOL;
	  LSP := LCP^.IDTYPE;
	  IF LSP = STRGPTR then
	    if SY <> LBRACK THEN error(732)
	    else
	      BEGIN INSYMBOL;
	      CONSTANT(FSYS + [RBRACK],LSP1,LVALU);
	      IF LSP1 = INTPTR THEN
		BEGIN
		IF (LVALU.IVAL <= 0) OR
		   (LVALU.IVAL > STRGLGTH) THEN
		  BEGIN ERROR(678); LVALU.IVAL := STRGLGTH END;
		NEW(LSP);
		LSP^ := STRGPTR^;
		WITH LSP^ DO
		  BEGIN
		  MAXLENG := LVALU.IVAL; info := linfo;
		  unpacksize := LVALU.IVAL+1                  {*********}
		  END;
		END
	      ELSE ERROR(15);
	      IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
	      END; (*string length*)
	  END (*if test*)
	ELSE
	  BEGIN                               {Subrange}
	  CONSTANT(FSYS + [rangesy],LSP1,LVALU);
	  if lsp1 <> nil then
	    if lsp1^.form <> scalar then
	      BEGIN ERROR(107); LSP1 := NIL END;
	  NEW(LSP,SUBRANGE);
	  WITH LSP^ DO
	    BEGIN
	    FORM := SUBRANGE;
	    info := linfo;
	    sizeoflo:=false;
	    if lsp1<>nil then
	      begin
	      unpacksize := lsp1^.unpacksize;
	      align:=lsp1^.align;
	      min := lvalu.ival;
	      end
	    else
	      begin
	      unpacksize:=wordsize;
	      align:=wordalign;
	      min := 0;
	      end;
	    RANGETYPE := LSP1;
	    END;
	  IF SY = rangesy THEN INSYMBOL ELSE ERROR(22);
	  CONSTANT(FSYS,LSP1,LVALU);
	  WITH LSP^ DO
	    begin
	    if lsp1 <> NIL then
	      begin
	      MAX := LVALU.ival;
	      if (rangetype <> NIL) and
		 (RANGETYPE <> LSP1) THEN ERROR(107);
	      end
	    else
	      max := min;
	    IF MIN > MAX THEN
	      BEGIN ERROR(102); MAX := MIN END;
	    countbits(min,minbits,minsign);             {Size it}
	    countbits(max,maxbits,maxsign);
	    if minbits>maxbits then maxbits:=minbits;
{*** For machines without sign extension, change next line to
			      ... then maxbits:=bitsperword;          ***}
	    if minsign or maxsign then maxbits:=maxbits+1;
	    if maxbits<bitsperword then
	      begin           {packable!}
	      ispackable := true; bitsize := maxbits;
	      signbit := (minsign or maxsign);
	      if (maxbits+ord(not signbit) <=  bitsperaddr*shortintsize)
		   and (rangetype = intptr) then
		begin unpacksize := shortintsize; rangetype := shortintptr end;
	      end
	    else
	      ispackable := false;     {not packable}
	    end;
	  END;  (*subrange*)
	END;
      FSP := LSP;
      IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END
      END (*SY IN SIMPTYPEBEGSYS*)
    ELSE FSP := NIL
    END (*SIMPLETYPE*) ;

  procedure setrecordsize (fsp: stp);
    { set the size fields in a record or variant node }
    { Uses DISPL, MAXFLDALIGN, and NEXTBIT variables }
    begin
    with fsp^ do
      begin
      if nextbit>0 then
	unpacksize := displ + (nextbit+bitsperaddr-1) div bitsperaddr
      else unpacksize := displ;
      sizeoflo := false;
      if (unpacksize = 1) and (maxfldalign = 1) then
	align := 1
      else align := wordalign;
      if (displ=0) and (nextbit<bitsperword) and not packing then
	begin
	ispackable := true; signbit := false;
	bitsize := nextbit;
	end
      else
	ispackable := false;
      end
    end;

  PROCEDURE FIELDLIST (FSYS: SETOFSYS; VAR FRECVAR: STP;
		       var finfo: infobits; var lcproot: ctp);
    VAR lcproot1,LCP,LCP1,PREVLCP: CTP; LSP: STP; TEST: BOOLEAN;
	foundfixedpart: boolean;

    PROCEDURE FLDALLOC (FCP: CTP);
      { allocate the given field in current record }
      VAR t: shortint;
      BEGIN
      WITH FCP^ DO
	if idtype = nil then          {punt}
	  begin fldaddr:=0; fispackd:=false end
	ELSE IF PACKING AND (idtype^.ispackable) THEN
	  BEGIN                       {Allocate packed field}
	  if nextbit=0 then
	    begin                     {ensure DISPL is word aligned}
	    t := DISPL mod wordalign;
	    if t<>0 then
	      begin DISPL := DISPL-t;   {back up to previous word boundary}
	      nextbit := t*bitsperaddr; {set NEXTBIT to skip used part}
	      end;
	    end;
	  try
	    $ovflcheck on$
	    while (idtype^.bitsize + NEXTBIT) > BITSPERWORD do {** B.R. 4/80 **}
	      BEGIN DISPL := DISPL + 2; NEXTBIT := nextbit-16;
	      if nextbit < 0 then nextbit := 0;
	      END;
	    $if not ovflchecking$
	      $ovflcheck off$
	    $end$
	  recover
	    if escapecode = -4 { integer ovfl } then
	      begin
	      error(672);
	      displ := 0;
	      nextbit := 0;
	      end
	    else escape(escapecode);
	  FLDADDR := DISPL; FISPACKD := TRUE;
	  FLDFBIT := NEXTBIT;
	  NEXTBIT := NEXTBIT + idtype^.bitsize;
	  if ((fldfbit = 0) or (fldfbit = 16)) and
	     (idtype^.bitsize = 16) and idtype^.signbit then
	     begin
	     fldaddr := fldaddr + fldfbit DIV 8;
	     fispackd := false;
	     strucwaspackd := true;
	     end;
	  if maxfldalign < wordalign then maxfldalign := wordalign;
	  END
	ELSE
	  BEGIN                       {Allocate unpacked field}
	  if nextbit>0 then
	    begin
	    try
	      $ovflcheck on$
	      DISPL := DISPL + (nextbit+bitsperaddr-1) div bitsperaddr;
	      $if not ovflchecking$
		$ovflcheck off$
	      $end$
	    recover
	      if escapecode = -4 { integer ovfl } then
		begin error(672); displ := 0; end
	      else escape(escapecode);
	    NEXTBIT := 0;
	    end;
	  FISPACKD := FALSE;
	  strucwaspackd := packing;
	  FLDADDR := allocate(DISPL, idtype, true,1);
	  if maxfldalign < idtype^.align then maxfldalign := idtype^.align;
	  END
      END (*FLDALLOC*) ;

    PROCEDURE VARIANTLIST;
      label 1,2;
      VAR GOTTAGNAME,TEST: BOOLEAN;
	  linfo: infobits;
	  LCP,LCP1: CTP;
	  LSP,LSP1,LSP2,LSP3,LSP4,lspt: STP;
	  MINSIZE,MAXSIZE: ADDRRANGE;
	  testval: varlab;
	  LVALU: VALU;
	  MAXBIT,MINBIT: BITRANGE;
	  t1, t2 : addrrange;

      BEGIN NEW(LSP,TAGFLD); linfo := sysinfo;
      WITH LSP^ DO
	BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM := TAGFLD;
	  info := linfo;
	END;
      FRECVAR := LSP;
      INSYMBOL;
      IF SY = IDENT THEN
	BEGIN
	IF PACKING THEN NEW(LCP,FIELD,TRUE)
	ELSE NEW(LCP,FIELD,FALSE);
	WITH LCP^ DO
	  BEGIN namep := nil; IDTYPE := NIL; KLASS:=FIELD;
	    NEXT := NIL; FISPACKD := FALSE; info := linfo
	  END;
	GOTTAGNAME := FALSE; PRTERR := FALSE;
	SEARCHID([TYPES],LCP1); PRTERR := TRUE;
	INSYMBOL;
	IF (LCP1 = NIL) or (sy = colon) THEN
	  BEGIN
	  GOTTAGNAME := TRUE; foundfixedpart := true;
	  if prevlcp <> nil then prevlcp^.next := lcp;
	  prevlcp := lcp;
	  if lcproot = nil then lcproot := lcp;
	  newident(LCP^.NAMEP,ID); ENTERID(LCP);
	  IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	  IF SY = IDENT THEN
	    BEGIN
	    SEARCHID([TYPES],LCP1);
	    INSYMBOL;
	    END
	  ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END
	  END;
	if lcp1 <> NIL then
	  LSP1 := LCP1^.IDTYPE
	else
	  lsp1 := NIL;
	IF LSP1 <> NIL THEN
	  IF LSP1^.FORM <= SUBRANGE THEN
	    BEGIN
	    LCP^.IDTYPE := LSP1; LSP^.TAGFIELDP := LCP;
	    IF GOTTAGNAME THEN FLDALLOC(LCP)
	    END
	  ELSE ERROR(110);
	END
      ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END;
      lsp^.hasfixedpart := foundfixedpart; setrecordsize(LSP);
      IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
      LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
      MINBIT := NEXTBIT; MAXBIT := NEXTBIT;
      REPEAT LSP2 := NIL;
	REPEAT CONSTANT(FSYS + [COMMA,rangesy,COLON,LPARENT],LSP3,LVALU);
	  IF LSP^.TAGFIELDP <> NIL THEN
	    IF NOT COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP3) THEN
	      ERROR(111);
	  NEW(LSP3,VARIANT);
	  WITH LSP3^ DO
	    BEGIN NXTVAR := LSP1; SUBVAR := LSP2; vflds := nil;
	      VARVAL.lo := LVALU.ival; FORM := VARIANT; info := linfo;
	    END;
	  if sy = rangesy then
	    begin
	    if stdpasc then error(606);
	    insymbol;
	    CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP2,LVALU);
	    if lsp^.tagfieldp <> NIL then
	      if not comptypes(lsp^.tagfieldp^.idtype,lsp2) then
		error(111);
	    end;
	  lsp3^.varval.hi := lvalu.ival;
	  if lsp3^.varval.lo > lvalu.ival then
	    error(102);
	  LSP1 := LSP3; LSP2 := LSP3;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
	IF SY = RPARENT THEN LSP2 := NIL
	ELSE { link a particular variant with its associated fields.
	       The fields are linked together through their NEXT field }
	  begin lcproot1 := nil;
	  linfo := sysinfo;
	  FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,linfo,lcproot1);
	  lspt := lsp1;
	  while lspt <> nil do
	    if lspt^.vflds = nil then
	      begin lspt^.vflds := lcproot1; lspt := lspt^.nxtvar end
	    else goto 2;
       2: if mustinitialize in linfo then error(707);
	  finfo := finfo + (linfo * [cantassign]);
	  end;
	t1 := displ + (nextbit div bitsperaddr);
	t2 := maxsize + (maxbit div bitsperaddr);
	if (t1 > t2) or
		((t1 = t2) and ( (nextbit mod bitsperaddr) >
				  (maxbit mod bitsperaddr) ) ) then
	  begin
	    maxsize := displ;
	    maxbit := nextbit;
	  end;
	WHILE LSP3 <> NIL DO
	  BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2;
	    setrecordsize(LSP3);
	    LSP3 := LSP4
	  END;
	IF SY = RPARENT THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN FSYS + [SEMICOLON]) THEN
	      BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END
	  END
	ELSE ERROR(4);
	TEST := SY <> SEMICOLON;
	IF NOT TEST THEN
	  BEGIN INSYMBOL;
	    DISPL := MINSIZE; NEXTBIT := MINBIT
	  END
      UNTIL TEST OR (SY=ENDSY);
      DISPL := MAXSIZE; NEXTBIT := MAXBIT;
      LSP^.FSTVAR := LSP1;
      while lsp1 <> nil do
	begin testval := lsp1^.varval;
	lsp2 := lsp1^.nxtvar;
	while lsp2 <> nil do
	  with lsp2^.varval do
	    if ((testval.lo >= lo) and (testval.lo <= hi)) or
	       ((testval.hi >= lo) and (testval.hi <= hi)) or
	       ((testval.lo <  lo) and (testval.hi >  hi)) then
	      begin error(156); goto 1 end
	    else lsp2 := lsp2^.nxtvar;
	lsp1 := lsp1^.nxtvar;
	end;
   1: END (*VARIANTLIST*) ;

    BEGIN (*FIELDLIST*)
    foundfixedpart := false;
    prevlcp := nil;
    IF NOT (SY IN [IDENT,CASESY,endsy]) THEN
      BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END;
    WHILE SY = IDENT DO
      BEGIN
	foundfixedpart := true;
	lcp1 := nil;
	REPEAT
	  IF SY = IDENT THEN
	    BEGIN
	      IF PACKING THEN NEW(LCP,FIELD,TRUE)
	      ELSE NEW(LCP,FIELD,FALSE);
	      WITH LCP^ DO
		BEGIN newident(namep,ID); IDTYPE := NIL; NEXT := NIL;
		  KLASS := FIELD; FISPACKD := FALSE; info := linfo
		END;
	      if lcproot = nil then lcproot := lcp;
	      if prevlcp <> nil then prevlcp^.next:=lcp;
	      prevlcp := lcp;
	      if lcp1=nil then lcp1 := lcp;
	      ENTERID(LCP);
	      INSYMBOL
	    END
	  ELSE ERROR(2);
	  IF NOT (SY IN [COMMA,COLON]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY]) END;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	TYP(FSYS + [CASESY,SEMICOLON],LSP);
	IF LSP <> NIL THEN
	  finfo := finfo + (lsp^.info * [mustinitialize,cantassign]);
	WHILE LCP1 <> NIL DO      {attach type ptr & allocate space}
	  WITH LCP1^ DO
	    BEGIN IDTYPE := LSP; FLDALLOC(LCP1); LCP1 := NEXT END;
	IF SY = SEMICOLON THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN [IDENT,ENDSY,CASESY,rparent]) THEN
	      BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END
	  END
      END (*WHILE*);
    IF SY = CASESY THEN VARIANTLIST
    ELSE FRECVAR := NIL
    END (*FIELDLIST*) ;

  PROCEDURE POINTERTYPE;
    VAR LSP: STP; LCP: CTP;
    BEGIN NEW(LSP,POINTER); FSP := LSP;
    WITH LSP^ DO
      BEGIN ELTYPE := NIL; FORM := POINTER;
      ispackable := false; sizeoflo := false;
      unpacksize := PTRSIZE; align := PTRALIGN;
      info := linfo;
      END;
    INSYMBOL;
    IF SY = IDENT THEN
      BEGIN NEW(LCP,TYPES);
      WITH LCP^ DO
	BEGIN newident(namep,ID); IDTYPE := LSP;
	NEXT := FWPTR; KLASS := TYPES;
	END;
      FWPTR := LCP;
      INSYMBOL;
      END
    ELSE ERROR(2)
    END (*POINTERTYPE*) ;

  procedure arraytype;
    var LSP,LSP1,LSP2: STP;
	LSIZE: addrrange;
	TEST,packit,itfits: BOOLEAN;
	numbits,elsperbyte: shortint;
	numelements,lmin,lmax: integer;

    procedure checkarray(aelsize: addrrange; inxtype: stp);
      { check if aelsize*lowerbound will overflow}
      var dummy: integer;
      begin
      try
      $ovflcheck on$
	dummy := lmin*aelsize;
      $if not ovflchecking$
	$ovflcheck off$
      $end$
      recover
	if escapecode = -4 {integer overflow} then
	  begin error(697);
	  if inxtype <> nil then
	    if inxtype^.form = subrange then
	      inxtype^.min := 0;
	  end;
      end; {checkarray}

    BEGIN INSYMBOL;
    IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
    LSP1 := NIL;
    REPEAT
      NEW(LSP,ARRAYS);
      WITH LSP^ DO
	BEGIN AELTYPE := LSP1; INXTYPE := NIL;
	  strucwaspackd := packing;
	  ispackable := false; sizeoflo := false;
	  unpacksize := wordsize; align := wordalign;
	  AISPACKD := FALSE; aelsize := wordsize;
	  FORM := ARRAYS; info := linfo; aisstrng := false;
	END;
      LSP1 := LSP;
      SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2);
      IF LSP2 <> NIL THEN
	IF LSP2^.FORM <= SUBRANGE THEN
	  IF LSP2 = INTPTR THEN ERROR(149)
	  ELSE LSP^.INXTYPE := LSP2
	ELSE ERROR(113);
      TEST := SY <> COMMA;
      IF NOT TEST THEN INSYMBOL
    UNTIL TEST;
    IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
    IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
    TYP(FSYS,LSP);
    REPEAT
      WITH LSP1^ DO
	BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
	IF LSP <> NIL THEN
	  info := linfo + (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;
{***** Compute size of whole array *****}
	  sizeoflo := true;      {assume the worst}
	  GETBOUNDS(INXTYPE,LMIN,LMAX);
	  if lmax < 0 then itfits := (lmax<lmin+maxint)
	  else itfits := (lmax-maxint<lmin);
	  if itfits then    {number of elements is computable}
	    begin
	    numelements := LMAX-LMIN+1;
	    if AISPACKD then
	      if aelbitsize = 16 then
		begin             {HALF ARRAY}
		itfits := numelements < (maxint DIV 2);
		if itfits then lsize := numelements*2;
		checkarray(2,inxtype);
		end
	      else
		begin
		itfits := true;
		if aelbitsize = 0 then
		  lsize := 0
		else
		  begin
		  elsperbyte := bitsperaddr DIV aelbitsize;
		  lsize := (numelements + (elsperbyte-1)) DIV elsperbyte;
		  end;
		end
	    else
	      begin         {unpacked array}
	      if aeltype^.sizeoflo then itfits := false
	      else itfits := (aelsize <= (maxint div numelements));
	      if itfits then lsize := numelements * aelsize;
	      checkarray(aelsize,inxtype);
	      end;
	    if itfits then
	      begin unpacksize := lsize; sizeoflo := false end;
	    end
	  END
	END;
      LSP := LSP1; LSP1 := LSP2
    UNTIL LSP1 = NIL;
    FSP := LSP;
    END; (* arraytype *)

  BEGIN (*TYP*)
    PACKING := FALSE; linfo := sysinfo;
    IF NOT (SY IN TYPEBEGSYS) THEN
      BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END;
    IF SY IN TYPEBEGSYS THEN
      BEGIN
      IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP)
{ ^ } ELSE IF SY = ARROW THEN POINTERTYPE
      ELSE
	BEGIN
	  IF SY = PACKEDSY THEN
	    BEGIN INSYMBOL; PACKING := TRUE;
	    IF NOT (SY IN TYPEDELS) THEN
	      BEGIN ERROR(10); SKIP(FSYS+TYPEDELS) END
	    END;
{ARRAY}   IF SY = ARRAYSY THEN arraytype
{RECORD}  ELSE IF SY = RECORDSY THEN
	    BEGIN INSYMBOL;
	      OLDTOP := TOP;
	      IF TOP < DISPLIMIT THEN
		BEGIN TOP := TOP + 1;
		  WITH DISPLAY[TOP] DO
		    BEGIN FNAME := NIL; OCCUR := RECORDscope END
		END
	      ELSE ERROR(662);
	      DISPL := 0; NEXTBIT := 0; maxfldalign := 1;
	      lcproot := nil;
	      FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,linfo,lcproot);
	      NEW(LSP,RECORDS);
	      WITH LSP^ DO
		BEGIN FSTFLD := DISPLAY[TOP].FNAME;
		  RECVAR := LSP1; setrecordsize(LSP);
		  FORM := RECORDS; info := linfo
		END;
	      TOP := OLDTOP;
	      IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13);
	      FSP := LSP
	    END
{SET}     ELSE IF SY = SETSY THEN
	    BEGIN INSYMBOL;
	      IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
	      SIMPLETYPE(FSYS,LSP1);
	      IF LSP1 <> NIL THEN
		IF LSP1^.FORM > SUBRANGE THEN
		  BEGIN ERROR(115); LSP1 := NIL END
		ELSE IF LSP1=INTPTR THEN
		  BEGIN ERROR(169); LSP1 := NIL END;
	      NEW(LSP,POWER);
	      WITH LSP^ DO
		BEGIN ELSET := LSP1; FORM := POWER;
		info := linfo;
		ispackable := false; sizeoflo := false;
		unpacksize := 0 {SETSIZE}; align := SETALIGN;
		setmin := SETLOW; setmax := SETHIGH;
		IF LSP1 <> NIL THEN
		  BEGIN GETBOUNDS(LSP1,LMIN,LMAX);
		  if (lmin<SETLOW) or (lmax>SETHIGH) then
		    error(658)
		  else
		    begin                          {Compute set size}
		    setmax := LMAX;
		    setmin := LMIN;
		    unpacksize := setlensize + SETELEMSIZE *
			   ((LMAX + SETELEMBITS) DIV SETELEMBITS)
		    end;
		  END
		END;
	      FSP := LSP
	    END
{FILE}    ELSE IF SY = FILESY THEN
	    BEGIN
	    INSYMBOL; NEW(LSP,FILES);
	    WITH LSP^ DO
	      BEGIN
	      ispackable := false; sizeoflo := false;
	      align := wordalign; FORM := FILES;
	      info := linfo + [mustinitialize, cantassign];
	      IF SY = OFSY THEN
		BEGIN
		INSYMBOL;
		TYP(FSYS,FILTYPE);
		if filtype <> NIL then
		  if (filtype^.unpacksize <= 0) or
		     (filtype^.unpacksize > 32766) then
		    error(673)
		  else if mustinitialize in filtype^.info
		    then error(183);
		END
	      ELSE
		begin
		if not ucsd then error(607);
		FILTYPE := NIL;
		end;
	      if filtype = nil then unpacksize := nilfilesize
	      else unpacksize := filesize + filtype^.unpacksize;
	      END;
	    FSP := LSP;
	    END
{PROC}    else if sy = procsy then
	    begin
	    if not (modcal or sysprog) then
	      error(612);
	    insymbol;
	    routinetype(fsys,fsp,procsy);
	    end;
	END;
      IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END
      END (* sy in typebegsys *)
    ELSE FSP := NIL;
  END; (*TYP*)


@


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


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

procedure routinetype(*fsys: setofsys; var fsp: stp; fsy: symbol*);
  var lsp: stp; llc: addrrange; oldtop: disprange;
  begin
  new(lsp,prok);
  with lsp^ do
    begin form := prok; params := nil; info := sysinfo;
    ispackable := false; sizeoflo := false;
    unpacksize := PROKSIZE; align := PROKALIGN;
    parmlc := 0;
    if sy = lparent then
      begin
      llc := lc; lc := lcaftermarkstack;
      oldtop := top;
      if top < displimit then
	begin top := top + 1;
	with display[top] do
	  begin
	  fname := nil; occur := BLOCKscope;
	  fmodule := nil; ffile := nil;
	  flabel := nil; available_module := nil;
	  end;
	end
      else error(662);
      if fsy = procsy then
	parameterlist(fsys,[semicolon],params,parmlc,false,0)
      else parameterlist(fsys,[semicolon,colon],params,parmlc,false,0);
      lc := llc;
      top := oldtop;
      end;
    end;
  fsp := lsp;
  end;

PROCEDURE TYP (FSYS: SETOFSYS; VAR FSP: STP);
  VAR LSP,LSP1: STP; OLDTOP: DISPRANGE; llc: addrrange;
      DISPL: ADDRRANGE; NEXTBIT,maxfldalign: shortint;
      PACKING: BOOLEAN; LMIN,LMAX: integer; linfo: infobits;
      lcproot: ctp;

  PROCEDURE SIMPLETYPE (FSYS: SETOFSYS; VAR FSP: STP);
    VAR LSP,LSP1: STP;
	LCP,LCP1: CTP;
	TTOP: DISPRANGE;
	LVALU: VALU;
	LCNT,minbits,maxbits: shortint;
	minsign,maxsign,test: boolean;
    BEGIN
    IF NOT (SY IN SIMPTYPEBEGSYS) THEN
      BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END;
    IF SY IN SIMPTYPEBEGSYS THEN
      BEGIN
      IF SY = LPARENT THEN
	BEGIN                                 {Enumerated type}
	TTOP := TOP;
	WHILE DISPLAY[TOP].OCCUR in [RECORDscope,WITHscope] DO TOP := TOP - 1;
	NEW(LSP,SCALAR,DECLARED);
	WITH LSP^ DO
	  BEGIN FORM := SCALAR;
	  unpacksize := SCALARSIZE; align := SCALARALIGN; sizeoflo := false;
	  ispackable := true; signbit := false;
	  SCALKIND := DECLARED; info := linfo
	  END;
	LCP1 := NIL; LCNT := 0;
	REPEAT INSYMBOL;
	  IF SY = IDENT THEN
	    BEGIN NEW(LCP,KONST);
	      WITH LCP^ DO
		BEGIN newident(namep,ID); IDTYPE := LSP; NEXT := LCP1;
		   KLASS := KONST; info := linfo;
		   values.intval := true; values.IVAL := LCNT;
		END;
	      ENTERID(LCP);
	      LCNT := LCNT + 1;
	      LCP1 := LCP; INSYMBOL
	    END
	  ELSE ERROR(2);
	  IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
	UNTIL SY <> COMMA;
	LSP^.FCONST := LCP1;
	countbits(lcnt-1,lcnt,maxsign);
	LSP^.bitsize := lcnt;
	TOP := TTOP;
	IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
	END (*SY=LPARENT*)
      ELSE
	BEGIN
	IF SY = IDENT THEN    {Is it type name or subrange declaration?}
	  { Added FUNC as a class to search 8/12/89 JWH }
	  begin SEARCHID([TYPES,KONST,FUNC],LCP);
	  test:=(LCP^.KLASS = TYPES);
	  end
	else test:=false;
	if test then
	  BEGIN                               {Type name}
	  if disx = disdef.level then
	    if lcp^.namep^ = disdef.id^ then
	      error(190);
	  INSYMBOL;
	  LSP := LCP^.IDTYPE;
	  IF LSP = STRGPTR then
	    if SY <> LBRACK THEN error(732)
	    else
	      BEGIN INSYMBOL;
	      CONSTANT(FSYS + [RBRACK],LSP1,LVALU);
	      IF LSP1 = INTPTR THEN
		BEGIN
		IF (LVALU.IVAL <= 0) OR
		   (LVALU.IVAL > STRGLGTH) THEN
		  BEGIN ERROR(678); LVALU.IVAL := STRGLGTH END;
		NEW(LSP);
		LSP^ := STRGPTR^;
		WITH LSP^ DO
		  BEGIN
		  MAXLENG := LVALU.IVAL; info := linfo;
		  unpacksize := LVALU.IVAL+1                  {*********}
		  END;
		END
	      ELSE ERROR(15);
	      IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
	      END; (*string length*)
	  END (*if test*)
	ELSE
	  BEGIN                               {Subrange}
	  CONSTANT(FSYS + [rangesy],LSP1,LVALU);
	  if lsp1 <> nil then
	    if lsp1^.form <> scalar then
	      BEGIN ERROR(107); LSP1 := NIL END;
	  NEW(LSP,SUBRANGE);
	  WITH LSP^ DO
	    BEGIN
	    FORM := SUBRANGE;
	    info := linfo;
	    sizeoflo:=false;
	    if lsp1<>nil then
	      begin
	      unpacksize := lsp1^.unpacksize;
	      align:=lsp1^.align;
	      min := lvalu.ival;
	      end
	    else
	      begin
	      unpacksize:=wordsize;
	      align:=wordalign;
	      min := 0;
	      end;
	    RANGETYPE := LSP1;
	    END;
	  IF SY = rangesy THEN INSYMBOL ELSE ERROR(22);
	  CONSTANT(FSYS,LSP1,LVALU);
	  WITH LSP^ DO
	    begin
	    if lsp1 <> NIL then
	      begin
	      MAX := LVALU.ival;
	      if (rangetype <> NIL) and
		 (RANGETYPE <> LSP1) THEN ERROR(107);
	      end
	    else
	      max := min;
	    IF MIN > MAX THEN
	      BEGIN ERROR(102); MAX := MIN END;
	    countbits(min,minbits,minsign);             {Size it}
	    countbits(max,maxbits,maxsign);
	    if minbits>maxbits then maxbits:=minbits;
{*** For machines without sign extension, change next line to
			      ... then maxbits:=bitsperword;          ***}
	    if minsign or maxsign then maxbits:=maxbits+1;
	    if maxbits<bitsperword then
	      begin           {packable!}
	      ispackable := true; bitsize := maxbits;
	      signbit := (minsign or maxsign);
	      if (maxbits+ord(not signbit) <=  bitsperaddr*shortintsize)
		   and (rangetype = intptr) then
		begin unpacksize := shortintsize; rangetype := shortintptr end;
	      end
	    else
	      ispackable := false;     {not packable}
	    end;
	  END;  (*subrange*)
	END;
      FSP := LSP;
      IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END
      END (*SY IN SIMPTYPEBEGSYS*)
    ELSE FSP := NIL
    END (*SIMPLETYPE*) ;

  procedure setrecordsize (fsp: stp);
    { set the size fields in a record or variant node }
    { Uses DISPL, MAXFLDALIGN, and NEXTBIT variables }
    begin
    with fsp^ do
      begin
      if nextbit>0 then
	unpacksize := displ + (nextbit+bitsperaddr-1) div bitsperaddr
      else unpacksize := displ;
      sizeoflo := false;
      if (unpacksize = 1) and (maxfldalign = 1) then
	align := 1
      else align := wordalign;
      if (displ=0) and (nextbit<bitsperword) and not packing then
	begin
	ispackable := true; signbit := false;
	bitsize := nextbit;
	end
      else
	ispackable := false;
      end
    end;

  PROCEDURE FIELDLIST (FSYS: SETOFSYS; VAR FRECVAR: STP;
		       var finfo: infobits; var lcproot: ctp);
    VAR lcproot1,LCP,LCP1,PREVLCP: CTP; LSP: STP; TEST: BOOLEAN;
	foundfixedpart: boolean;

    PROCEDURE FLDALLOC (FCP: CTP);
      { allocate the given field in current record }
      VAR t: shortint;
      BEGIN
      WITH FCP^ DO
	if idtype = nil then          {punt}
	  begin fldaddr:=0; fispackd:=false end
	ELSE IF PACKING AND (idtype^.ispackable) THEN
	  BEGIN                       {Allocate packed field}
	  if nextbit=0 then
	    begin                     {ensure DISPL is word aligned}
	    t := DISPL mod wordalign;
	    if t<>0 then
	      begin DISPL := DISPL-t;   {back up to previous word boundary}
	      nextbit := t*bitsperaddr; {set NEXTBIT to skip used part}
	      end;
	    end;
	  try
	    $ovflcheck on$
	    while (idtype^.bitsize + NEXTBIT) > BITSPERWORD do {** B.R. 4/80 **}
	      BEGIN DISPL := DISPL + 2; NEXTBIT := nextbit-16;
	      if nextbit < 0 then nextbit := 0;
	      END;
	    $if not ovflchecking$
	      $ovflcheck off$
	    $end$
	  recover
	    if escapecode = -4 { integer ovfl } then
	      begin
	      error(672);
	      displ := 0;
	      nextbit := 0;
	      end
	    else escape(escapecode);
	  FLDADDR := DISPL; FISPACKD := TRUE;
	  FLDFBIT := NEXTBIT;
	  NEXTBIT := NEXTBIT + idtype^.bitsize;
	  if ((fldfbit = 0) or (fldfbit = 16)) and
	     (idtype^.bitsize = 16) and idtype^.signbit then
	     begin
	     fldaddr := fldaddr + fldfbit DIV 8;
	     fispackd := false;
	     strucwaspackd := true;
	     end;
	  if maxfldalign < wordalign then maxfldalign := wordalign;
	  END
	ELSE
	  BEGIN                       {Allocate unpacked field}
	  if nextbit>0 then
	    begin
	    try
	      $ovflcheck on$
	      DISPL := DISPL + (nextbit+bitsperaddr-1) div bitsperaddr;
	      $if not ovflchecking$
		$ovflcheck off$
	      $end$
	    recover
	      if escapecode = -4 { integer ovfl } then
		begin error(672); displ := 0; end
	      else escape(escapecode);
	    NEXTBIT := 0;
	    end;
	  FISPACKD := FALSE;
	  strucwaspackd := packing;
	  FLDADDR := allocate(DISPL, idtype, true,1);
	  if maxfldalign < idtype^.align then maxfldalign := idtype^.align;
	  END
      END (*FLDALLOC*) ;

    PROCEDURE VARIANTLIST;
      label 1,2;
      VAR GOTTAGNAME,TEST: BOOLEAN;
	  linfo: infobits;
	  LCP,LCP1: CTP;
	  LSP,LSP1,LSP2,LSP3,LSP4,lspt: STP;
	  MINSIZE,MAXSIZE: ADDRRANGE;
	  testval: varlab;
	  LVALU: VALU;
	  MAXBIT,MINBIT: BITRANGE;
	  t1, t2 : addrrange;

      BEGIN NEW(LSP,TAGFLD); linfo := sysinfo;
      WITH LSP^ DO
	BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM := TAGFLD;
	  info := linfo;
	END;
      FRECVAR := LSP;
      INSYMBOL;
      IF SY = IDENT THEN
	BEGIN
	IF PACKING THEN NEW(LCP,FIELD,TRUE)
	ELSE NEW(LCP,FIELD,FALSE);
	WITH LCP^ DO
	  BEGIN namep := nil; IDTYPE := NIL; KLASS:=FIELD;
	    NEXT := NIL; FISPACKD := FALSE; info := linfo
	  END;
	GOTTAGNAME := FALSE; PRTERR := FALSE;
	SEARCHID([TYPES],LCP1); PRTERR := TRUE;
	INSYMBOL;
	IF (LCP1 = NIL) or (sy = colon) THEN
	  BEGIN
	  GOTTAGNAME := TRUE; foundfixedpart := true;
	  if prevlcp <> nil then prevlcp^.next := lcp;
	  prevlcp := lcp;
	  if lcproot = nil then lcproot := lcp;
	  newident(LCP^.NAMEP,ID); ENTERID(LCP);
	  IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	  IF SY = IDENT THEN
	    BEGIN
	    SEARCHID([TYPES],LCP1);
	    INSYMBOL;
	    END
	  ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END
	  END;
	if lcp1 <> NIL then
	  LSP1 := LCP1^.IDTYPE
	else
	  lsp1 := NIL;
	IF LSP1 <> NIL THEN
	  IF LSP1^.FORM <= SUBRANGE THEN
	    BEGIN
	    LCP^.IDTYPE := LSP1; LSP^.TAGFIELDP := LCP;
	    IF GOTTAGNAME THEN FLDALLOC(LCP)
	    END
	  ELSE ERROR(110);
	END
      ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END;
      lsp^.hasfixedpart := foundfixedpart; setrecordsize(LSP);
      IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
      LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
      MINBIT := NEXTBIT; MAXBIT := NEXTBIT;
      REPEAT LSP2 := NIL;
	REPEAT CONSTANT(FSYS + [COMMA,rangesy,COLON,LPARENT],LSP3,LVALU);
	  IF LSP^.TAGFIELDP <> NIL THEN
	    IF NOT COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP3) THEN
	      ERROR(111);
	  NEW(LSP3,VARIANT);
	  WITH LSP3^ DO
	    BEGIN NXTVAR := LSP1; SUBVAR := LSP2; vflds := nil;
	      VARVAL.lo := LVALU.ival; FORM := VARIANT; info := linfo;
	    END;
	  if sy = rangesy then
	    begin
	    if stdpasc then error(606);
	    insymbol;
	    CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP2,LVALU);
	    if lsp^.tagfieldp <> NIL then
	      if not comptypes(lsp^.tagfieldp^.idtype,lsp2) then
		error(111);
	    end;
	  lsp3^.varval.hi := lvalu.ival;
	  if lsp3^.varval.lo > lvalu.ival then
	    error(102);
	  LSP1 := LSP3; LSP2 := LSP3;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
	IF SY = RPARENT THEN LSP2 := NIL
	ELSE { link a particular variant with its associated fields.
	       The fields are linked together through their NEXT field }
	  begin lcproot1 := nil;
	  linfo := sysinfo;
	  FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,linfo,lcproot1);
	  lspt := lsp1;
	  while lspt <> nil do
	    if lspt^.vflds = nil then
	      begin lspt^.vflds := lcproot1; lspt := lspt^.nxtvar end
	    else goto 2;
       2: if mustinitialize in linfo then error(707);
	  finfo := finfo + (linfo * [cantassign]);
	  end;
	t1 := displ + (nextbit div bitsperaddr);
	t2 := maxsize + (maxbit div bitsperaddr);
	if (t1 > t2) or
		((t1 = t2) and ( (nextbit mod bitsperaddr) >
				  (maxbit mod bitsperaddr) ) ) then
	  begin
	    maxsize := displ;
	    maxbit := nextbit;
	  end;
	WHILE LSP3 <> NIL DO
	  BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2;
	    setrecordsize(LSP3);
	    LSP3 := LSP4
	  END;
	IF SY = RPARENT THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN FSYS + [SEMICOLON]) THEN
	      BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END
	  END
	ELSE ERROR(4);
	TEST := SY <> SEMICOLON;
	IF NOT TEST THEN
	  BEGIN INSYMBOL;
	    DISPL := MINSIZE; NEXTBIT := MINBIT
	  END
      UNTIL TEST OR (SY=ENDSY);
      DISPL := MAXSIZE; NEXTBIT := MAXBIT;
      LSP^.FSTVAR := LSP1;
      while lsp1 <> nil do
	begin testval := lsp1^.varval;
	lsp2 := lsp1^.nxtvar;
	while lsp2 <> nil do
	  with lsp2^.varval do
	    if ((testval.lo >= lo) and (testval.lo <= hi)) or
	       ((testval.hi >= lo) and (testval.hi <= hi)) or
	       ((testval.lo <  lo) and (testval.hi >  hi)) then
	      begin error(156); goto 1 end
	    else lsp2 := lsp2^.nxtvar;
	lsp1 := lsp1^.nxtvar;
	end;
   1: END (*VARIANTLIST*) ;

    BEGIN (*FIELDLIST*)
    foundfixedpart := false;
    prevlcp := nil;
    IF NOT (SY IN [IDENT,CASESY,endsy]) THEN
      BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END;
    WHILE SY = IDENT DO
      BEGIN
	foundfixedpart := true;
	lcp1 := nil;
	REPEAT
	  IF SY = IDENT THEN
	    BEGIN
	      IF PACKING THEN NEW(LCP,FIELD,TRUE)
	      ELSE NEW(LCP,FIELD,FALSE);
	      WITH LCP^ DO
		BEGIN newident(namep,ID); IDTYPE := NIL; NEXT := NIL;
		  KLASS := FIELD; FISPACKD := FALSE; info := linfo
		END;
	      if lcproot = nil then lcproot := lcp;
	      if prevlcp <> nil then prevlcp^.next:=lcp;
	      prevlcp := lcp;
	      if lcp1=nil then lcp1 := lcp;
	      ENTERID(LCP);
	      INSYMBOL
	    END
	  ELSE ERROR(2);
	  IF NOT (SY IN [COMMA,COLON]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY]) END;
	  TEST := SY <> COMMA;
	  IF NOT TEST THEN INSYMBOL
	UNTIL TEST;
	IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
	TYP(FSYS + [CASESY,SEMICOLON],LSP);
	IF LSP <> NIL THEN
	  finfo := finfo + (lsp^.info * [mustinitialize,cantassign]);
	WHILE LCP1 <> NIL DO      {attach type ptr & allocate space}
	  WITH LCP1^ DO
	    BEGIN IDTYPE := LSP; FLDALLOC(LCP1); LCP1 := NEXT END;
	IF SY = SEMICOLON THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN [IDENT,ENDSY,CASESY,rparent]) THEN
	      BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END
	  END
      END (*WHILE*);
    IF SY = CASESY THEN VARIANTLIST
    ELSE FRECVAR := NIL
    END (*FIELDLIST*) ;

  PROCEDURE POINTERTYPE;
    VAR LSP: STP; LCP: CTP;
    BEGIN NEW(LSP,POINTER); FSP := LSP;
    WITH LSP^ DO
      BEGIN ELTYPE := NIL; FORM := POINTER;
      ispackable := false; sizeoflo := false;
      unpacksize := PTRSIZE; align := PTRALIGN;
      info := linfo;
      END;
    INSYMBOL;
    IF SY = IDENT THEN
      BEGIN NEW(LCP,TYPES);
      WITH LCP^ DO
	BEGIN newident(namep,ID); IDTYPE := LSP;
	NEXT := FWPTR; KLASS := TYPES;
	END;
      FWPTR := LCP;
      INSYMBOL;
      END
    ELSE ERROR(2)
    END (*POINTERTYPE*) ;

  procedure arraytype;
    var LSP,LSP1,LSP2: STP;
	LSIZE: addrrange;
	TEST,packit,itfits: BOOLEAN;
	numbits,elsperbyte: shortint;
	numelements,lmin,lmax: integer;

    procedure checkarray(aelsize: addrrange; inxtype: stp);
      { check if aelsize*lowerbound will overflow}
      var dummy: integer;
      begin
      try
      $ovflcheck on$
	dummy := lmin*aelsize;
      $if not ovflchecking$
	$ovflcheck off$
      $end$
      recover
	if escapecode = -4 {integer overflow} then
	  begin error(697);
	  if inxtype <> nil then
	    if inxtype^.form = subrange then
	      inxtype^.min := 0;
	  end;
      end; {checkarray}

    BEGIN INSYMBOL;
    IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
    LSP1 := NIL;
    REPEAT
      NEW(LSP,ARRAYS);
      WITH LSP^ DO
	BEGIN AELTYPE := LSP1; INXTYPE := NIL;
	  strucwaspackd := packing;
	  ispackable := false; sizeoflo := false;
	  unpacksize := wordsize; align := wordalign;
	  AISPACKD := FALSE; aelsize := wordsize;
	  FORM := ARRAYS; info := linfo; aisstrng := false;
	END;
      LSP1 := LSP;
      SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2);
      IF LSP2 <> NIL THEN
	IF LSP2^.FORM <= SUBRANGE THEN
	  IF LSP2 = INTPTR THEN ERROR(149)
	  ELSE LSP^.INXTYPE := LSP2
	ELSE ERROR(113);
      TEST := SY <> COMMA;
      IF NOT TEST THEN INSYMBOL
    UNTIL TEST;
    IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
    IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
    TYP(FSYS,LSP);
    REPEAT
      WITH LSP1^ DO
	BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
	IF LSP <> NIL THEN
	  info := linfo + (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;
{***** Compute size of whole array *****}
	  sizeoflo := true;      {assume the worst}
	  GETBOUNDS(INXTYPE,LMIN,LMAX);
	  if lmax < 0 then itfits := (lmax<lmin+maxint)
	  else itfits := (lmax-maxint<lmin);
	  if itfits then    {number of elements is computable}
	    begin
	    numelements := LMAX-LMIN+1;
	    if AISPACKD then
	      if aelbitsize = 16 then
		begin             {HALF ARRAY}
		itfits := numelements < (maxint DIV 2);
		if itfits then lsize := numelements*2;
		checkarray(2,inxtype);
		end
	      else
		begin
		itfits := true;
		if aelbitsize = 0 then
		  lsize := 0
		else
		  begin
		  elsperbyte := bitsperaddr DIV aelbitsize;
		  lsize := (numelements + (elsperbyte-1)) DIV elsperbyte;
		  end;
		end
	    else
	      begin         {unpacked array}
	      if aeltype^.sizeoflo then itfits := false
	      else itfits := (aelsize <= (maxint div numelements));
	      if itfits then lsize := numelements * aelsize;
	      checkarray(aelsize,inxtype);
	      end;
	    if itfits then
	      begin unpacksize := lsize; sizeoflo := false end;
	    end
	  END
	END;
      LSP := LSP1; LSP1 := LSP2
    UNTIL LSP1 = NIL;
    FSP := LSP;
    END; (* arraytype *)

  BEGIN (*TYP*)
    PACKING := FALSE; linfo := sysinfo;
    IF NOT (SY IN TYPEBEGSYS) THEN
      BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END;
    IF SY IN TYPEBEGSYS THEN
      BEGIN
      IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP)
{ ^ } ELSE IF SY = ARROW THEN POINTERTYPE
      ELSE
	BEGIN
	  IF SY = PACKEDSY THEN
	    BEGIN INSYMBOL; PACKING := TRUE;
	    IF NOT (SY IN TYPEDELS) THEN
	      BEGIN ERROR(10); SKIP(FSYS+TYPEDELS) END
	    END;
{ARRAY}   IF SY = ARRAYSY THEN arraytype
{RECORD}  ELSE IF SY = RECORDSY THEN
	    BEGIN INSYMBOL;
	      OLDTOP := TOP;
	      IF TOP < DISPLIMIT THEN
		BEGIN TOP := TOP + 1;
		  WITH DISPLAY[TOP] DO
		    BEGIN FNAME := NIL; OCCUR := RECORDscope END
		END
	      ELSE ERROR(662);
	      DISPL := 0; NEXTBIT := 0; maxfldalign := 1;
	      lcproot := nil;
	      FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,linfo,lcproot);
	      NEW(LSP,RECORDS);
	      WITH LSP^ DO
		BEGIN FSTFLD := DISPLAY[TOP].FNAME;
		  RECVAR := LSP1; setrecordsize(LSP);
		  FORM := RECORDS; info := linfo
		END;
	      TOP := OLDTOP;
	      IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13);
	      FSP := LSP
	    END
{SET}     ELSE IF SY = SETSY THEN
	    BEGIN INSYMBOL;
	      IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
	      SIMPLETYPE(FSYS,LSP1);
	      IF LSP1 <> NIL THEN
		IF LSP1^.FORM > SUBRANGE THEN
		  BEGIN ERROR(115); LSP1 := NIL END
		ELSE IF LSP1=INTPTR THEN
		  BEGIN ERROR(169); LSP1 := NIL END;
	      NEW(LSP,POWER);
	      WITH LSP^ DO
		BEGIN ELSET := LSP1; FORM := POWER;
		info := linfo;
		ispackable := false; sizeoflo := false;
		unpacksize := 0 {SETSIZE}; align := SETALIGN;
		setmin := SETLOW; setmax := SETHIGH;
		IF LSP1 <> NIL THEN
		  BEGIN GETBOUNDS(LSP1,LMIN,LMAX);
		  if (lmin<SETLOW) or (lmax>SETHIGH) then
		    error(658)
		  else
		    begin                          {Compute set size}
		    setmax := LMAX;
		    setmin := LMIN;
		    unpacksize := setlensize + SETELEMSIZE *
			   ((LMAX + SETELEMBITS) DIV SETELEMBITS)
		    end;
		  END
		END;
	      FSP := LSP
	    END
{FILE}    ELSE IF SY = FILESY THEN
	    BEGIN
	    INSYMBOL; NEW(LSP,FILES);
	    WITH LSP^ DO
	      BEGIN
	      ispackable := false; sizeoflo := false;
	      align := wordalign; FORM := FILES;
	      info := linfo + [mustinitialize, cantassign];
	      IF SY = OFSY THEN
		BEGIN
		INSYMBOL;
		TYP(FSYS,FILTYPE);
		if filtype <> NIL then
		  if (filtype^.unpacksize <= 0) or
		     (filtype^.unpacksize > 32766) then
		    error(673)
		  else if mustinitialize in filtype^.info
		    then error(183);
		END
	      ELSE
		begin
		if not ucsd then error(607);
		FILTYPE := NIL;
		end;
	      if filtype = nil then unpacksize := nilfilesize
	      else unpacksize := filesize + filtype^.unpacksize;
	      END;
	    FSP := LSP;
	    END
{PROC}    else if sy = procsy then
	    begin
	    if not (modcal or sysprog) then
	      error(612);
	    insymbol;
	    routinetype(fsys,fsp,procsy);
	    end;
	END;
      IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END
      END (* sy in typebegsys *)
    ELSE FSP := NIL;
  END; (*TYP*)


@


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.2
log
@ Modified file TYP at line 61 to repair FSDdt01561 - 
 'Hex('0') within array declarations will not compile'.
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d91 2
a92 1
	  begin SEARCHID([TYPES,KONST],LCP);
@


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.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
@d296 2
d390 9
a398 5
	IF DISPL > MAXSIZE THEN
	  BEGIN MAXSIZE := DISPL; MAXBIT := NEXTBIT END
	ELSE
	  IF (DISPL = MAXSIZE) AND (NEXTBIT > MAXBIT) THEN
	    MAXBIT := NEXTBIT;
@


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


1.1
log
@Initial revision
@
text
@@
