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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

41.1
date     89.12.22.11.15.41;  author jwh;  state Exp;
branches ;
next     40.2;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1.1
date     86.06.30.13.13.09;  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 BLOCK}

  procedure checkmodulefwptr(end_of_module: boolean);
    {Check pointer element types on the module's
     forward pointer list (from export section).}
    var
      tempid: alpha;
      lcp, nextfwdptr,tempmodulefwptr: ctp;

    begin
    tempid := id; prterr := false; {save - restore}
    tempmodulefwptr := display[top].fmodule^.modinfo^.modulefwptr;
    while tempmodulefwptr <> NIL do
      begin
      if tempmodulefwptr^.idtype^.eltype = cant_deref then
	begin
	id := tempmodulefwptr^.namep^;
	searchid([types],lcp);
	if lcp=NIL then
	  begin
	  if end_of_module then
	    errorwithinfo(117,'Undefined type ' + tempmodulefwptr^.namep^);;
	  end
	else
	  tempmodulefwptr^.idtype^.eltype := lcp^.idtype;
	end
      else
	if end_of_module then
	  tempmodulefwptr^.idtype^.eltype := cant_deref;
      tempmodulefwptr := tempmodulefwptr^.next;
      end;
    id := tempid; prterr := true;
    end; {checkmodulefwptr}

  procedure checkfwptr(not_in_export: boolean);
    {Fix up pointer element types on forward
     pointer list.  N.B: all pointers are forward
     till end of ctv declarations ala ISO.}
    var
      tempid: alpha;
      lcp, nextfwptr: ctp;

    begin
    tempid := id; prterr := false; {save - restore}
    while fwptr <> NIL do
      begin id := fwptr^.namep^;
      searchid([types],lcp);
      if lcp=NIL then
	if not_in_export then
	  begin
	  errorwithinfo(117,'Undefined type ' + fwptr^.namep^);
	  fwptr := fwptr^.next;
	  end
	else
	  begin
	  fwptr^.idtype^.eltype := cant_deref;
	  nextfwptr := fwptr^.next;
	  fwptr^.next := display[top].fmodule^.modinfo^.modulefwptr;
	  display[top].fmodule^.modinfo^.modulefwptr := fwptr;
	  fwptr := nextfwptr;
	  end
      else
	begin
	fwptr^.idtype^.eltype := lcp^.idtype;
	fwptr := fwptr^.next;
	end;
      end;
    id := tempid; prterr := true;
    end; {checkfwptr}

  PROCEDURE LABELDECLARATION (fsys: setofsys);
    VAR LLP: LABELP; TEST,REDEF: BOOLEAN;
  BEGIN
    INSYMBOL;
    REPEAT
      IF SY <> INTCONST THEN ERROR(15)
      else
	begin
	WITH DISPLAY[TOP] DO
	  BEGIN LLP := FLABEL; REDEF := FALSE;
	  WHILE (LLP <> NIL) AND NOT REDEF DO
	    IF LLP^.LABVAL <> VAL.IVAL THEN
	      LLP := LLP^.NEXTLAB
	    ELSE BEGIN REDEF := TRUE; ERROR(166) END;
	  IF NOT REDEF THEN
	    BEGIN NEW(LLP);
	    if val.ival > 9999 then error(163);
	    WITH LLP^ DO
	      BEGIN
	      LABVAL := VAL.IVAL; NEXTLAB := FLABEL;
	      defined := false; isrefed := false;
	      nonlocalref := false; staticlevel := level;
	      isnlrefed := false;
	      END;
	    FLABEL := LLP
	    END;
	  END; {with}
	INSYMBOL
	end;
      IF NOT (SY IN FSYS + [COMMA, SEMICOLON]) THEN
	BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END;
      TEST := SY <> COMMA;
      IF NOT TEST THEN INSYMBOL
    UNTIL TEST;
    IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
  END (* LABELDECLARATION *) ;

  PROCEDURE CONSTDECLARATION (fsys: setofsys;
			      allowstructconst,
			      externalmodule: boolean);
    VAR
      LCP: CTP;
      LSP: STP;
      LVALU: VALU;
      structconstnode: structnodeptr;
  BEGIN
  INSYMBOL;
  IF SY <> IDENT THEN
    BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
  WHILE SY = IDENT DO
    BEGIN NEW(LCP,KONST);
      WITH LCP^ DO
	BEGIN
	newident(namep,ID); gnamep := namep; IDTYPE := NIL;
	NEXT := NIL; KLASS := KONST; info := sysinfo
	END;
      INSYMBOL;
      IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
      CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
      if lsp <> NIL then
	begin
	if stdpasc then
	  if not modcal and (lsp = anyptrptr) then
	    error(606);
	if lsp^.form in [arrays,records,power] then
	  with lvalu.valp^ do
	    begin
	    if stdpasc then
	      if cclass <> paofch then error(606);
	    if cclass = strctconst then
	      begin
	      isdumped := false;
	      if not allowstructconst then
		error(688);
	      if importexportext then
		begin { Can't dump const now }
		new(structconstnode);
		with structconstnode^ do
		  begin
		  sp := lsp;
		  val := lvalu;
		  next := structconstlist;
		  structconstlist := structconstnode;
		  end;
		end
	      else
		begin
		if not hasbeenoutput then
		  begin
		  if not externalmodule then
		    dumpstconst(lsp,lvalu);
		  hasbeenoutput := true;
		  end;
		if not saveconst then
		  begin release(kstruc); kstruc := NIL end;
		end;
	      end;
	    end;
	end;
      ENTERID(LCP);
      LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
      IF SY = SEMICOLON THEN
	BEGIN INSYMBOL;
	  IF NOT (SY IN FSYS + [IDENT]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	END
      ELSE ERROR(14)
    END; (*WHILE*)
  END (*CONSTDECLARATION*) ;

  PROCEDURE TYPEDECLARATION (fsys: setofsys);
    VAR LCP: CTP; LSP: STP;

    BEGIN
    INSYMBOL;
    IF SY <> IDENT THEN
      BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
    disdef.level := top;
    WHILE SY = IDENT DO
      BEGIN NEW(LCP,TYPES);
	WITH LCP^ DO
	  BEGIN newident(namep,ID); IDTYPE := NIL; KLASS := TYPES;
	  info := sysinfo; disdef.id := namep;
	  END;
	INSYMBOL;
	IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
	ENTERID(LCP);
	TYP(FSYS + [SEMICOLON],LSP);
	LCP^.IDTYPE := LSP;
	IF SY = SEMICOLON THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN FSYS + [IDENT]) THEN
	      BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	  END
	ELSE ERROR(14)
      END; (*while sy=ident*)
    disdef.level := -1; {restore}
    END (*TYPEDECLARATION*) ;

  PROCEDURE VARDECLARATION (fsys: setofsys);
    VAR LCP,NXT,IDLIST,previousid: CTP; LSP: STP; lvalu: valu;
	TEST: BOOLEAN;
    BEGIN
    INSYMBOL;
    REPEAT
      NXT := NIL;
      REPEAT
	IF SY = IDENT THEN
	  BEGIN
	    NEW(LCP,VARS);
	    WITH LCP^ DO
	      BEGIN newident(namep,ID); NEXT := NXT;
	      KLASS := VARS; IDTYPE := NIL; vtype := localvar;
	      VLEV := LEVEL; info := sysinfo;
	      if level = 1 then
		globalptr := curglobalname
	      else globalptr := NIL;
	      $PARTIAL_EVAL ON$
	      if ((sawkeyboard and (namep^ = 'KEYBOARD')) or
		 (sawlisting and (namep^ = 'LISTING'))) and
		 (top = 1) {main program} then
	      else ENTERID(LCP);
	      $IF not partialevaling$
		$PARTIAL_EVAL OFF$
	      $END$
	      END;
	    NXT := LCP;
	    INSYMBOL;
	    if sy = lbrack then       (* var x[absolute address]: ... *)
	      begin
	      if not (modcal or sysprog) then
		error(612);
	      insymbol;
	      constant(fsys+[rbrack,comma,colon],lsp,lvalu);
	      if lsp = char_ptr then stretchpaofchar(lsp,lvalu,1);
	      if (lsp <> intptr) and not paofchar(lsp) then error(50);
	      lcp^.vtype := longvar;
	      lcp^.absaddr := lvalu;
	      if lsp <> intptr then
		begin (*symbolic address*)
		if sy = comma then
		  begin insymbol;
		  constant(fsys+[rbrack,comma,colon],lsp,lvalu);
		  if lsp <> char_ptr then error(50)
		  else
		    case chr(lvalu.ival) of
		      'L','l': ;
		      'S','s': lcp^.vtype := shortvar;
		      'R','r': lcp^.vtype := relvar;
		      otherwise error(50);
		      end;
		  end; (*sy=comma*)
		end; (*symbolic address*)
	      if sy = rbrack then insymbol else error(12);
	      end (*sy=lbrack*)
	  END
	ELSE ERROR(2);
	IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN
	  BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END;
	TEST := SY <> COMMA;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
      IDLIST := NXT;
      previousid := NIL;
      TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP);
      WHILE NXT <> NIL DO
	WITH NXT^ DO
	  BEGIN IDTYPE := LSP;
	  if vtype = localvar then
	    $PARTIAL_EVAL ON$
	    if top = 1 {main program} then
	      begin
	      if sawkeyboard and (namep^ = 'KEYBOARD') then
		if lsp <> textptr then error(184)
		else
		  begin
		  if idlist = nxt then idlist := next
				  else previousid^.next := next;
		  nxt := previousid;
		  if not ucsd then
		    enterid(keyboardptr);
		  end
	      else if sawlisting and (namep^ = 'LISTING') then
		if lsp <> textptr then error(184)
		else
		  begin
		  if idlist = nxt then idlist := next
				  else previousid^.next := next;
		  nxt := previousid;
		  if not ucsd then
		    enterid(listingptr);
		  end
	      else
		begin
		vaddr := allocate(LC,lsp,false,1);
		previousid := nxt;
		end;
	      end
	    else
	      VADDR := allocate(LC,lsp,false,1);
	    $IF not partialevaling$
	      $PARTIAL_EVAL OFF$
	    $END$
	  IF NEXT = NIL THEN
	    begin
	    IF LSP <> NIL THEN
	      IF (idlist <> NIL) and
		 (mustinitialize in lsp^.info) THEN
		BEGIN (*PUT IDLIST INTO LOCAL FILE LIST*)
		nxt^.NEXT := DISPLAY[TOP].FFILE;
		DISPLAY[TOP].FFILE := IDLIST;
		END;
	    nxt := NIL;
	    end
	  else
	    NXT := NEXT;
	  END;
      if $IF MC68020$ (level = 1) and $END$ (lc < LClimit) then
	error(683);
      IF SY = SEMICOLON THEN
	BEGIN INSYMBOL;
	  IF NOT (SY IN FSYS + [IDENT]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	END
      ELSE ERROR(14)
    UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS);
    END (*VARDECLARATION*) ;

  PROCEDURE PROCDECLARATION (fsys: setofsys);
    VAR FSY: SYMBOLS; OLDLEV,plsave: LEVRANGE; LCP: CTP;
	FORW,ipssave: BOOLEAN; OLDTOP: DISPRANGE;
	LLC: ADDRRANGE;  MARKP: ^INTEGER; infosave: infobits;

  procedure procheader;
    label 1;
    var LCP1: CTP; LSP: STP; dummy,
    plc, llc: addrrange; lstate: modstateptr;
	lmarkstacksize: addrrange; waslparent: boolean;
    BEGIN
    IF SY = IDENT THEN
      BEGIN
      with display[top] do            {Look for 'forward' declaration}
	if occur = MODULEscope then
	  begin
	  lstate := fmodule;
	  repeat
	    searchsection(lstate^.defineids,lcp);
	    lstate := lstate^.contmodule;
	  until (lstate=NIL) or (lcp<>NIL);
	  if lcp = NIL then searchsection(fname,lcp)
	  end
	else searchsection(fname,lcp);
      FORW := FALSE;  {default}
      IF LCP <> NIL THEN
	BEGIN         (* name already declared, check for FORWARD *)
	IF LCP^.FORWDECL THEN
	  IF LCP^.KLASS = prox THEN
	    FORW := ((FSY = PROCSY) and not lcp^.ismodulebody)
	  ELSE IF LCP^.KLASS = FUNC THEN
	    FORW := (FSY = FUNCSY);
	IF NOT FORW THEN
	  if ((fsy = procsy) and (lcp^.klass = prox)) or
	     ((fsy = funcsy) and (lcp^.klass = func)) then
	    ERROR(160)
	END;
      IF NOT FORW THEN
	BEGIN
	IF FSY = PROCSY THEN
	  begin NEW(LCP,prox,DECLARED);
	    lcp^.klass := prox; lcp^.ismodulebody := false;
	  end
	else (* function *)
	  begin
	  NEW(LCP,FUNC,DECLARED);
	  with lcp^ do
	    begin
	    klass := func;
	    pfaddr := 0;
	    assignedto := false;
	    end;
	  end;
	WITH LCP^ DO
	  BEGIN
	  newident(namep,ID); IDTYPE := NIL;
	  paramlc := 0; PFDECKIND := DECLARED;
	  forwdecl := false; extdecl := false;
	  isexported := indefinesection;
	  isdumped := false; isrefed := false;
	  inscope := false; next := NIL;
	  PFLEV := OLDLEV; info := infosave;
	  END;
	ENTERID(LCP);
	END
      ELSE  (* forward; must update LC for copied value parms *)
	BEGIN LCP1 := LCP^.NEXT;
	WHILE LCP1 <> NIL DO
	  BEGIN
	  WITH LCP1^ DO
	    if vtype=cvalparm then
	      dummy := allocate(LC, idtype, false, 1);
	  LCP1 := LCP1^.NEXT;
	  END;
	END;
      insymbol;
      END (* SY = IDENT *)
    ELSE
      BEGIN ERROR(2); LCP := UPRCPTR END;
    IF TOP < DISPLIMIT THEN
      BEGIN TOP := TOP + 1;
      with DISPLAY[TOP] do
	begin
	if FORW then
	  begin                 (* skip conformant array dope vector parm(s) *)
	    LCP1 := LCP^.next;  (*   and get to first explicit parm, which *)
	    while LCP1 <> nil do (*  will then also be top of sym tbl tree *)
	      begin
		if LCP1^.namep <> NIL then
		  goto 1;
		LCP1 := LCP1^.next;
	      end;
1:          FNAME := LCP1;
	  end
	else
	  FNAME := NIL;
	FLABEL := NIL;
	FFILE := NIL;
	FMODULE := NIL;
	OCCUR := BLOCKscope;
	available_module := NIL;
	end;
      END
    ELSE ERROR(662);
    if oldlev = 1 then lmarkstacksize := level1markstacksize
    else lmarkstacksize := markstacksize;
    waslparent := sy = lparent;
    llc := lc; lc := lcaftermarkstack;
    IF FSY <> funcsy THEN
      PARAMETERLIST(fsys,[SEMICOLON],LCP1,plc,forw,lmarkstacksize)
    ELSE
      PARAMETERLIST(fsys,[SEMICOLON,COLON],LCP1,plc,forw,lmarkstacksize);
    IF NOT FORW THEN
      begin LCP^.NEXT := LCP1; LCP^.paramlc := plc end
    else if waslparent then  { paramlist was respecified }
      begin
      if stdpasc then error(606);
      if (plc <> lcp^.paramlc) or (llc <> lc) then error(171)
      else if not compparmlists(lcp^.next,lcp1,true,true) then error(171);
      end;
    if forw then lc := llc;
    if fsy = funcsy then
      IF SY = COLON THEN
	BEGIN INSYMBOL;
	IF SY = IDENT THEN
	  BEGIN
	  SEARCHID([TYPES],LCP1);
	  if lcp1 <> NIL then
	    begin
	    LSP := LCP1^.IDTYPE;
	    if lsp = strgptr then error(733)
	    else if lsp <> NIL then
	      begin
	      if cantassign in lsp^.info then
		error(751);
	      if forw and (lsp <> lcp^.idtype) then error(171);
	      end;
	    LCP^.IDTYPE := LSP;
	    IF LSP <> NIL THEN
	      IF lsp^.form >= prok then
		begin
		lsp := anyptrptr;
		if stdpasc then error(606);
		end;
  {***** Machine dependent addr of function result area *****}
	    plc := lcaftermarkstack+lmarkstacksize+LCP^.paramlc;
	    LCP^.pfaddr := allocate(plc, lsp, true, parmalign);
	    end;
	  INSYMBOL;
	  END
	ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END
	END
      ELSE IF NOT FORW THEN ERROR(123)
    END; (* procheader *)

  BEGIN (*PROCDECLARATION*)
    FSY := SY; aliasptr := NIL; aliasok := true;
    INSYMBOL; LLC := LC; LC := LCAFTERMARKSTACK;
    DP := TRUE; oldDP := true;
    infosave := sysinfo; sysinfo := [];
    OLDLEV := LEVEL; OLDTOP := TOP;
    IF LEVEL < MAXPLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(663);
    procheader;
    with lcp^ do
      begin
      alias := aliasptr <> NIL;
      if alias and forw then error(620);
      if alias then othername := aliasptr
      else othername := curglobalname;
      end;
    if not indefinesection then
      IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
    aliasok := false;
    IF indefinesection then
      begin
      if forw then error(667) else lcp^.forwdecl := true;
      end
    else if (sy=forwardsy) or
	   ((sy=ident) and (id='FORWARD')) then
      begin
      IF FORW THEN ERROR(667)
      ELSE
	begin
	LCP^.FORWDECL := TRUE;
	lcp^.forwid := uniquenumber;
	end;
      insymbol;
      end
    else if (sy=externlsy) OR
	   ((sy=ident) and (id='EXTERNAL')) then
      with lcp^ do     (* EXTERNAL declaration *)
	begin
	if forwdecl then
	  begin
	  forwdecl:=false;
	  if pflev<>1 then error(666)
	  else if not isexported then error(668);
	  end;
	extdecl:=true; pflev := 1;
	if level <> 2 then
	  warning(linenumber+1,'External declarations will be treated as global');
	if not isexported then
	  if not alias then othername := NIL;
	insymbol;
	end
    ELSE {not declared FORWARD, process procedure body}
      BEGIN MARK(MARKP);
      with lcp^ do
	begin FORWDECL := FALSE; INSCOPE := true; end;
      BLOCK(FSYS,SEMICOLON,LCP);
      if(lcp^.klass = func) and
	not lcp^.assignedto then
	error(181);
      LCP^.INSCOPE := FALSE;
      RELEASE(MARKP);
      END;
    LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; sysinfo := infosave;
    DP := TRUE;
    IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
    IF NOT (SY IN FSYS) THEN
      BEGIN ERROR(6); SKIP(FSYS) END;
  END (*PROCDECLARATION*);

PROCEDURE FINDFORW (FCP: CTP);
  {Report missing forward procedures in tree rooted at fcp}
  BEGIN
  IF FCP <> NIL THEN
    WITH FCP^ DO
      BEGIN
      IF KLASS IN [prox,FUNC] THEN
	IF PFDECKIND = DECLARED THEN
	  IF FORWDECL and not ismodulebody THEN
	    errorwithinfo(117,'Missing procedure ' + namep^);
      FINDFORW(RLINK); FINDFORW(LLINK)
      END
  END (*FINDFORW*);

procedure searchfiles(fsys: setofsys;
		      var lcp: ctp;
		      inimplmntsection: boolean);
  { search files to satisfy an 'import' item }
  var
    libfile1: file of direntry;
    libentry: direntry;
    libfile2: file;
    tempwidth,templine: integer;
    tempdisplay: displayframe;
    templist: listswitch;
    tempfwptr: ctp;
    found,readerror,savedisplay,tempstdpasc,
    tempcode,tempmodcal,errorinimport,tempucsd: boolean;
    { Added for FSDdt04001. }
    prev_temp : boolean;
    p,i,libsize,blkno: shortint;
    buf: record case integer of
	   1: (modulentry: module_directory);
	   2: (pad: packed array[1..512] of byt);
	 end;
  begin
  lcp := NIL;
  if strlen(id) <= fnlength then
    with buf do
      begin
      found := false;
      p := 0;
      repeat
	p := p + 1;
	close(libfile1);
	reset(libfile1,searchlistptr^[p],'SHARED');
	if IORESULT <> 0 then
	  begin { don't give error for *syslib }
	  if p <> searchfilestop then
	    errorwithinfo(611,'Can''t open ' +
				    searchlistptr^[p]);
	  end
	else { read in library header }
	  begin
	  read(libfile1,libentry);
	  if ioresult <> 0 then
	    errorwithinfo(611,'Can''t access ' +
				     searchlistptr^[p])
	  else
	    begin
	    readerror := false;
	    libsize := libentry.dnumfiles;
	    i := 1;
	    while (i <= libsize) and
		     not found and not readerror do
	      begin
	      read(libfile1,libentry);
	      if ioresult <> 0 then
		begin
		readerror := true;
		errorwithinfo(611,'Can''t read ' +
				    searchlistptr^[p]);
		end
	      else
		if libentry.dtid = id then
		  found := true;
	      i := i + 1;
	      end;
	    end;
	  end;
      until (p = searchfilestop) or found;
      close(libfile1);
      if found then
	begin
	blkno := libentry.dfirstblk;
	reset(libfile2,searchlistptr^[p],'SHARED');
	if blockread(libfile2,modulentry,1,blkno) <> 1 then
	  begin
	  found := false;
	  errorwithinfo(611,'Can''t open ' +
				    searchlistptr^[p]);
	  end
	else if srcindex >= maxinfiles then
	  begin found := false; error(610); end
	else if modulentry.source_size = 0 then
	  errorwithinfo(613,'Module '+id+' in '+
	  searchlistptr^[p]+' does not have interface text')
	else if modulentry .system_id <> (ord(crevno[1])-ord('0')) then
	  errorwithinfo(611,'Module '+ searchlistptr^[p] +
	  ': Improper revision number')
	else
	  begin
	  with sourceinfoptr^[srcindex] do
	    begin
	    oldsymcursor := symcursor;
	    oldlinestart := linestart;
	    oldfilepos := filepos;
	    oldsymblk := symblk;
	    oldrelinum := relinum;
	    oldftype := ftype;
	    end;
	  srcindex := srcindex + 1;
	  sourceinfoptr^[srcindex].filename := searchlistptr^[p];
	  filepos := (pagesize *
	    (blkno + modulentry.source_block)) DIV 2;
	  close(source);
	  reset(source,searchlistptr^[p],'SHARED');
	  with fibp(addr(source))^ do
	    begin
	    am := amtable^[untypedfile];
	    fpos := filepos;
	    end;
	  relinum := 0;
	  ftype := specil;
	  symblk := 0; { not really used }
	  getnextpage;
	  templist := gtemplist;
	  gtemplist := list;
	  list := listnone;
	  templine := gtemplinenumber;
	  gtemplinenumber := linenumber;
	  tempwidth := gtempwidth;
	  gtempwidth := width;
	  width := 120;
	  { FSDdt04001 : }
	  prev_temp := temp_put;
	  temp_put := putcode;
	  tempcode := putcode;
	  putcode := false;
	  tempmodcal := modcal;
	  modcal := true;
	  tempucsd := ucsd;
	  ucsd := true;
	  tempstdpasc := stdpasc;
	  stdpasc := false;
	  tempfwptr := fwptr;
	  fwptr := NIL;
	  savedisplay := not inimplmntsection and
		(display[top].occur = modulescope);
	  if savedisplay then
	    begin
	    tempdisplay := display[top];
	    top := top - 1;
	    end;
	  insymbol;
	  moduledeclaration(fsys,true,false,
	      display[top].available_module,false);
	  if savedisplay then
	    begin
	    top := top + 1;
	    display[top] := tempdisplay;
	    end;
	  { These are restored in checkend }
	  (************************************)
	  (*  list := gtemplist;              *)
	  (*  linenumber := gtemplinenumber;  *)
	  (*  width := gtempwidth;            *)
	  (************************************)
	  gtemplist := templist;
	  fwptr := tempfwptr;
	  gtemplinenumber := templine;
	  gtempwidth := tempwidth;
	  { FSDdt04001 : }
	  temp_put := prev_temp;
	  putcode := tempcode;
	  modcal := tempmodcal;
	  ucsd := tempucsd;
	  stdpasc := tempstdpasc;
	  { Removed for FSDdt04001 : }
	  { if importexportext then outputsymbol; }
	  lcp := modulectp;
	  gstate := gcurstate;
	  end;
	end;
	close(libfile2);
      end; { with buf }
  end; { searchfiles }

procedure  importsection(fsys: setofsys;
	      var wheretolinkstate: modstateptr;
	      inimplmntsection: boolean);
  label 1;
  var
    lcp,lcp1: ctp;
    lstate,lstate1,lmodstate: modstateptr;
    savedisplay,lmoreids,
    insymboldone,errorinimport: boolean;
  begin
  if sy <> ident then
    begin error(2); skip(fsys + [ident,exportsy,implmtsy,endsy]) end;
  lmoreids := sy = ident;
  while lmoreids do
    begin
    insymboldone := false;
    prterr := false;
    savedisplay :=
		display[top].occur = modulescope;
    if savedisplay then
      top := top - 1;    (* search outside this module *)
    searchid([types,konst,vars,prox,func],lcp1);
    errorinimport := false;
    prterr := true;
    if savedisplay then
      top := top + 1;
    if lcp1 <> NIL then
      if (lcp1^.klass = prox) and
	  lcp1^.ismodulebody then
	lcp1 := NIL; { find it another way }
    if lcp1 = NIL then
      begin
      searchavailablemodules(lcp1);
      if lcp1 <> NIL then
1:      if (lcp1^.klass = prox) and
	   lcp1^.ismodulebody then
	  begin
	  lstate := gstate^.defmodule;
	  while lstate <> NIL do
	    begin
	    new(lmodstate);
	    lmodstate^ := lstate^;
	    with lmodstate^ do
	      begin
	      modinfo^.needscall := false;
	      nextmodule :=
		    display[top].available_module;
	      end;
	    display[top].available_module :=
					 lmodstate;
	    lstate := lstate^.nextmodule;
	    end;
	  lstate1 := gstate; { save gstate }
	  if checkdefineconflicts(lcp1) then
	    errorinimport := true;
	  gstate := lstate1; { restore gstate }
	  end;
      end;
    if lcp1 = NIL then
      begin
      searchfiles(fsys,lcp1,inimplmntsection);
      if (lcp1 <> NIL) and
	 ((level <> 1) or
	  (top > display_ok_to_import)) then
	error(717);
      if lcp1 <> NIL then
	begin
	insymboldone := true;
	goto 1;
	end;
      end
    else if lcp1^.idtype=strgptr then error(104);
    if lcp1 = NIL then error(104)
    else if not errorinimport then
      begin
      if (lcp1^.klass = prox) and lcp1^.ismodulebody then
	if gstate=NIL then error(687)
	else
	  begin                       {Import module}
	  lstate := gstate^.modinfo^.laststate;       {Find newest instance}
	  while lstate <> NIL do      {Copy all instances into my USE list}
	    begin
	    new(lstate1); lstate1^ := lstate^;
	    with lstate1^ do
	      begin
	      contmodule := NIL;
	      nextmodule := wheretolinkstate;
	      end;
	    wheretolinkstate := lstate1;
	    lstate := lstate^.contmodule;
	    end;
	  end
      else
	begin                       {Import identfier}
	if not modcal then error(612);
	new(lcp); lcp^ := lcp1^;
	enterid(lcp);               (* add object to this module *)
	if (lcp^.klass = types) and (lcp^.idtype <> NIL) then
	  with lcp^.idtype^ do
	    if (form = scalar) and (scalkind = declared) then
	      begin           (* add konsts *)
	      lcp1 := fconst;
	      while lcp1 <> NIL do begin
		new(lcp); lcp^ := lcp1^;
		enterid(lcp);
		lcp1 := lcp1^.next
		end;
	      end;
	{ do not put an id out in interface text }
	if importexportext and putcode then
	  begin
	  moduleinit(curglobalname);
	  importexportext := false;
	  idinimport := true;
	  end;
	end;
      end; {lcp1<>NIL}
    if not insymboldone then insymbol;
    lmoreids := sy=comma;
    if sy in [comma,semicolon] then insymbol else error(14);
    if lmoreids and (sy <> ident) then
      begin
      error(2);
      if sy = semicolon then
	begin
	insymbol;
	lmoreids := false;
	end;
      end;
  end; (*while moreids*)
  if not (sy in (fsys + [exportsy,implmtsy,endsy])) then
    begin error(6); skip(fsys + [exportsy,implmtsy,endsy]) end
  end;  (* importsection *)

procedure checkbintree(id: ctp);
  begin
  with id^ do
    begin
    if (klass = prox) or (klass = func) then
      isdumped := false
    else if (klass = konst) and not values.intval then
      with values.valp^ do
	if cclass = strctconst then
	  isdumped := false;
    if llink <> NIL then checkbintree(llink);
    if rlink <> NIL then checkbintree(rlink);
    end;
  end;

procedure moduledeclaration(fsys: setofsys;
	   mustbeabstract,forwardmodule: boolean;
	   var wheretolinkstate: modstateptr;
	   modulelist: boolean);
  var
    curmodinfo: modinfoptr;
    lstate,lstate1,curmodstate: modstateptr;
    modinit1,modinit2: ctp; lsp: stp;
    newmodule,oldindefine: boolean;
    labsaddr: valu; oldtop: disprange;
    oldinfo: infobits;
    oldlc: addrrange;
    oldglobalname: alphaptr;
    oldstructconstlist: structnodeptr;

  procedure exportsection (fsys: setofsys);
    begin
    indefinesection := true;
    if not (sy in [constsy,typesy,varsy,procsy,funcsy,
		   modulesy,endsy,implmtsy])
      then begin error(710); skip(fsys) end;
    while sy in [constsy,typesy,varsy,
		 procsy,funcsy,modulesy] do
      begin
      case sy of
	constsy:  constdeclaration(fsys,not forwardmodule,
					not forwardmodule and
					mustbeabstract);
	typesy:   typedeclaration(fsys);
	varsy:    vardeclaration(fsys);
	modulesy:
	  begin
	  if not modcal then error(612);
	  moduledeclaration(fsys,true,true,curmodstate^.defmodule,false);
	  end;
	procsy,funcsy: procdeclaration(fsys);
	end; {case}
      if not (sy in [constsy,typesy,varsy,procsy,funcsy,
		     modulesy,endsy,implmtsy])
	then begin error(710); skip(fsys) end;
      end;
    indefinesection := false;
    end;  (* exportsection *)

  procedure undump(p: modstateptr);
    { after module codegen set the isdumped field to false
      for defined proxs, funcs, and structured consts }
    var
      modstatetemp: modstateptr;
    begin
    while p <> NIL do
      with p^ do
	begin
	if defineids <> NIL then
	  checkbintree(defineids);
	modstatetemp := p^.defmodule;
	while modstatetemp <> NIL do
	  begin
	  undump(modstatetemp);
	  modstatetemp := modstatetemp^.nextmodule;
	  end;
	p := p^.contmodule;
	end;
    end; {undump}

  procedure implmtsection;
    var heapsv: ^integer; lstate,msp: modstateptr;
	oldlev: levrange; oldlc: addrrange;
	old_display_ok_to_import: disprange;

    begin
    old_display_ok_to_import := display_ok_to_import;
    display_ok_to_import := top + 1;
    mark(heapsv);
    if sy = labelsy then
      begin error(6); labeldeclaration(fsys) end;
    while sy in [constsy,typesy,varsy,modulesy,
		 importsy,forwardsy,externlsy] do
      case sy of
	CONSTSY: CONSTDECLARATION(fsys+[endsy],true,false);
	TYPESY:  TYPEDECLARATION(fsys+[endsy]);
	VARSY:   VARDECLARATION(fsys+[endsy]);
	forwardsy,externlsy,modulesy:
	  begin
	  if not modcal then error(612);
	  checkfwptr(true);
	  checkmodulefwptr(false);
	  case sy of
	    modulesy:
	      moduledeclaration(fsys,false,false,
		    display[top].available_module,false);
	    forwardsy:
	      begin;
	      insymbol;
	      moduledeclaration(fsys,true,true,
		    display[top].available_module,false);
	      end;
	    externlsy:
	      begin
	      insymbol;
	      moduledeclaration(fsys,true,false,
		    display[top].available_module,false);
	      end;
	  end;
	  end;
	importsy:
	  begin
	  if not modcal then error(612);
	  insymbol;
	  importsection(fsys,display[top].fmodule^.modinfo^.impmodule,true);
	  end;
	end; {case}
    while sy in [constsy,typesy,varsy,procsy,importsy,
	 funcsy,externlsy,forwardsy,modulesy] do
      case sy of
	CONSTSY: begin
		 error(653);
		 CONSTDECLARATION(fsys,true,false);
		 end;
	TYPESY:  begin
		 error(653);
		 TYPEDECLARATION(fsys);
		 end;
	VARSY:   begin
		 error(653);
		 VARDECLARATION(fsys);
		 end;
	procsy,funcsy:
	  begin
	  checkfwptr(true);
	  checkmodulefwptr(false);
	  procdeclaration(fsys+[endsy]);
	  end;
	forwardsy,externlsy,modulesy:
	  begin
	  checkfwptr(true);
	  error(653);
	  if sy = modulesy then
	    moduledeclaration(fsys,false,false,
		    display[top].available_module,false)
	  else
	    begin
	    insymbol;
	    moduledeclaration(fsys,true,false,
		    display[top].available_module,false);
	    end;
	  end;
	importsy:
	  begin
	  error(653);
	  insymbol;
	  importsection(fsys,display[top].fmodule^.modinfo^.impmodule,true);
	  end;
	end; {case}
    checkfwptr(true);
    checkmodulefwptr(true);
    IF SY <> endsy THEN
      BEGIN
      ERROR(13);
      if sy = beginsy then insymbol
      else SKIP(fsys+[endsy]);
      END;
    (* Mark module body not forward *)
    with modinit1^ do
      begin forwdecl := false; inscope := true end;
    if newmodule then
      with modinit2^ do
	begin forwdecl := false; inscope := true end;
    (* Find missing forward procedures *)
    findforw(display[top].fname); lstate := curmodstate;
    while lstate <> NIL do
      begin findforw(lstate^.defineids); lstate := lstate^.contmodule end;
    (* handle initialization body *)
    oldlev := level;
    if level < maxplevel then level:=level+1 else error(663);
    oldlc := lc; lc := lcaftermarkstack;
    dp := false; olddp := false; linelevel := 0;
    display[top].flabel := NIL; { avoid additional errors }
    inbody := true;
    repeat
      body(fsys + [casesy],modinit1);
      if (sy <> semicolon) and (sy <> period) then
	begin error(14);  skip(fsys + [semicolon,period]) end
    until sy in blockbegsys+[semicolon,period];
    modinit1^.inscope := false;
    if newmodule then
      modinit2^.inscope := false;
    level := oldlev; lc := oldlc;
    if top = 2 then
      begin
      modulewrapup(true);
      undump(curmodstate);
      end;
    msp := display[top].available_module;
    while msp <> NIL do
      with msp^ do
	begin
	while (modinfo^.laststate <> NIL) and
	      (integer(modinfo^.laststate) >=
	      integer(heapsv)) do
	  modinfo^.laststate:= modinfo^.laststate^.contmodule;
	msp := nextmodule;
	end;
    release(heapsv);
    old_display_ok_to_import := display_ok_to_import;
    end;  (* implmtsection *)

  procedure findmodule (fstate: modstateptr);
    {Search fstate chain for module with name = id}
    label 1;
    begin
    while fstate <> NIL do
      if fstate^.modinfo^.modinitbody^.namep^ = id then
	begin gstate := fstate; goto 1 end
      else fstate := fstate^.nextmodule;
    gstate := NIL;            {Report failure}
  1:end;

  begin  (* moduledeclaration *)
  if stdpasc then error(606);
  oldlc := LC;
  oldtop := top; oldinfo := sysinfo;
  oldindefine := indefinesection; indefinesection := false;
  oldstructconstlist := structconstlist;
  structconstlist := NIL;
  sysinfo := [];
  LC := initmodLC;
  aliasptr := NIL;
  if sy = modulesy then insymbol else error(715);
  if sy <> ident then
    begin error(2); id := '**undefmodule**' end
  else if strlen(id) > fnlength then
    error(689);
  (* Look for previous occurence of same module *)
  with display[top] do
    if occur = BLOCKscope then
      findmodule(available_module)
    else {occur = MODULEscope}
      begin
      findmodule(available_module);
      lstate := fmodule;
      while (gstate = NIL) and (lstate <> NIL) do
	begin
	findmodule(lstate^.defmodule);
	lstate := lstate^.contmodule;
	end;
      end;
  newmodule := (gstate = NIL);        {Did I find one?}
  if top < displimit then             {and new scope}
    begin
    top := top + 1;
    with display[top] do
      begin
      fname := NIL; ffile := NIL; flabel := NIL;
      fmodule := NIL; occur := MODULEscope;
      available_module := NIL;
      end
    end
  else error(662);
  new(curmodstate);                   {Always create new instance}
  if newmodule then
    begin                             {Create new module}
    new(curmodinfo);
    new(modinit1,prox,declared);
    with modinit1^ do
      begin
      newident(namep,id); idtype := NIL; next := NIL;
      info := [];
      klass := prox; pfdeckind := declared;
      isexported := true; alias := false;
      paramlc := 0; extdecl := false;
      inscope := false; forwdecl :=  true;
      isdumped := false; isrefed := false;
      ismodulebody := true; pflev := level;
      end;
    with curmodinfo^ do
      begin
      modinitbody := modinit1; laststate := NIL;
      needscall := true;  isimplemented := false;
      impmodule := NIL; usemodule := NIL;
      useids := NIL; curindefine := false;
      modulefwptr := NIL;
      end;
    end
  else
    begin                     {Found new instance of old module}
    curmodinfo := gstate^.modinfo;
    modinit1 := curmodinfo^.modinitbody;
    with curmodinfo^ do
      begin
      if isimplemented then error(719);
      (* Restore state *)
      display[top].ffile := svffile;
      LC := svLC;
      DP := true; oldDP := true;
      end;
    end;
  if level = 1 then
    begin
    oldglobalname := curglobalname;
    curglobalname := modinit1^.namep;
    end;
  if newmodule then
    modinit1^.othername := curglobalname;
  with curmodstate^ do        {Init new module state}
    begin
    modinfo := curmodinfo; defineids := NIL;
    nextmodule := NIL; defmodule := NIL;
    contmodule := curmodinfo^.laststate;
    end;
  with curmodinfo^, display[top] do
    begin
    laststate := curmodstate;
    fmodule := curmodstate;
    if sy = ident then insymbol;
    if sy = semicolon then insymbol else error(14);
    if (top = 2) and not mustbeabstract then
      begin
      modulewrapup(false);
      moduleinit(curglobalname);
      idinimport := false;
      end;
    if sy = importsy then
      begin
      if (top = 2) and newmodule and
	 not mustbeabstract then
	begin
	importexportext := true;
	importexportstart(curglobalname);
	symbolstart := symcursor - 6;
	outputsymbol;
	end;
      insymbol;
      fname := useids;
      importsection(fsys,curmodinfo^.usemodule,false);
      useids := fname;
      end;
    fname := NIL;
    curindefine := true;
    (******************************************
    * Module name is added at 1 level of the  *
    * display greater than is expected for    *
    * purposes of the import search mechanism *
    ******************************************)
    if newmodule then
      begin
      enterid(modinit1);
      top := top - 1;
      new(modinit2,prox,declared);
      modinit2^ := modinit1^;
      enterid(modinit2); { For syntactic reasons }
      top := top + 1;
      end;
    if sy = exportsy then
      begin
      if (top = 2) and not importexportext and
	 newmodule and not mustbeabstract
	 and not idinimport then
	begin
	importexportext := true;
	importexportstart(curglobalname);
	symbolstart := symcursor - 6;
	outputsymbol;
	end;
      insymbol;
      exportsection(fsys+[implmtsy,endsy]);
      end
    else if newmodule then error(714);
    curindefine := false;
    curmodstate^.defineids := fname;
    fname := NIL;
    if importexportext and not mustbeabstract and
       (top = 2) then
      begin
      importexportwrapup;
      importexportext := false;
      end;
    if not mustbeabstract and (top = 2) then
      while structconstlist <> NIL do
	with structconstlist^ do
	  begin
	  if not val.valp^.hasbeenoutput then
	     begin
	     dumpstconst(sp,val);
	     val.valp^.hasbeenoutput := true;
	     end;
	  structconstlist := next;
	  end;
    checkfwptr(false);
    checkmodulefwptr(false);
    if sy = implmtsy then {Concrete module}
      begin
      if mustbeabstract then error(720);
      insymbol;
      implmtsection;
      if (top <> 2) and (level = 1) then
	begin
	{Define symbol for this module's globals}
	if odd(oldlc) then
	  oldlc := oldlc - 1;
	outputextdef(curglobalname^,oldlc,oldglobalname^);
	{Add globals to enclosing module's globals}
	oldlc := oldlc + LC;
	end;
      end
    else
      begin                {Abstract module}
      if not mustbeabstract then error(711);
      if sy = endsy then insymbol else error(13);
      end;
    (* Save state in modinforec & restore previous state *)
    svffile := ffile;
    svLC := LC;
    LC := oldlc;
    structconstlist := oldstructconstlist;
    end; {with curmodinfo^, display[top]}
  top := oldtop;
  sysinfo := oldinfo;
  indefinesection := oldindefine;
  if level = 1 then
    begin
    curglobalname := oldglobalname;
    if not mustbeabstract and (top = 1) then
      moduleinit(curglobalname);
    end;
  dp := true;
  if not forwardmodule then
    curmodinfo^.isimplemented := true;
  curmodstate^.nextmodule := wheretolinkstate;        {Add instance to list}
  wheretolinkstate := curmodstate;
  lstate1 := curmodstate;
  while lstate1 <> NIL do
    begin
    lstate := lstate1^.defmodule;
    while lstate <> NIL do
      with lstate^, modinfo^ do
	begin
	if not mustbeabstract then
	  begin { make sure defined modules were implemented }
	  if not isimplemented then
	    begin
	    errorwithinfo(706,
	      (modinitbody^.namep^ +
	      ': needs concrete instance'));
	    isimplemented := true;
	    end;
	  end
	else if not forwardmodule then
	  isimplemented := true;
	lstate := nextmodule;
	end;
    lstate1 := lstate1^.contmodule;
    end;
  if modulelist then
    if sy = semicolon then
      begin
      insymbol;
      if not (sy in [modulesy,forwardsy,externlsy]) then
	error(715);
      end
    else begin if sy <> period then error(14); end
  else { not modulelist }
    if sy = semicolon then insymbol
    else error(14);
  gcurstate := curmodstate;
  modulectp := curmodinfo^.modinitbody;
  end;  (* moduledeclaration *)


PROCEDURE BLOCK (*FSYS: SETOFSYS; FSY: SYMBOLS; FPROCP: CTP*);
  var
    lstate1,lstate2: modstateptr;

  BEGIN (*BLOCK*)
  if sy = labelsy then labeldeclaration(fsys);
  if level = 1 then
    moduleinit(curglobalname);
  if stdpasc then
    begin
    if sy = constsy then
      CONSTDECLARATION(fsys,true,false);
    if sy = typesy then
      TYPEDECLARATION(fsys);
    if sy = varsy then
      VARDECLARATION(fsys);
    while (sy = procsy) or (sy = funcsy) do
      begin
      checkfwptr(true);
      procdeclaration(fsys);
      end;
    if sy in [constsy,typesy,varsy] then
      error(606);
    end;
  while sy in [constsy,typesy,varsy,importsy,
	       forwardsy,externlsy,modulesy] do
    case sy of
      CONSTSY: CONSTDECLARATION(fsys,true,false);
      TYPESY:  TYPEDECLARATION(fsys);
      VARSY:   VARDECLARATION(fsys);
      forwardsy,externlsy,modulesy:
	begin
	checkfwptr(true);
	if level = 1 then {undump global id's}
	  checkbintree(display[top].fname);
	case sy of
	  modulesy:
	    moduledeclaration(fsys,false,false,
	      display[top].available_module,false);
	  forwardsy:
	    begin
	    insymbol;
	    moduledeclaration(fsys,true,true,
	      display[top].available_module,false);
	    end;
	  externlsy:
	    begin
	    insymbol;
	    moduledeclaration(fsys,true,false,
	      display[top].available_module,false);
	    end;
	end;
	end;
      importsy:
	begin
	if (level <> 1) and not modcal then
	  error(612)
	else if stdpasc then error(606);
	insymbol;
	importsection(fsys,display[top].fmodule,false);
	end;
      end; {case}
  while sy in [constsy,typesy,varsy,procsy,
    funcsy,importsy,forwardsy,externlsy,modulesy] do
    case sy of
      CONSTSY: begin
	       error(653);
	       CONSTDECLARATION(fsys,true,false);
	       end;
      TYPESY:  begin
	       error(653);
	       TYPEDECLARATION(fsys);
	       end;
      VARSY:   begin
	       error(653);
	       VARDECLARATION(fsys);
	       end;
      procsy,funcsy:
	begin
	checkfwptr(true);
	procdeclaration(fsys);
	end;
      importsy:
	begin
	error(653);
	insymbol;
	importsection(fsys,display[top].fmodule,false);
	end;
      forwardsy,externlsy,modulesy:
	begin
	checkfwptr(true);
	error(653);
	if sy = modulesy then
	  moduledeclaration(fsys,false,false,
	    display[top].available_module,false)
	else
	  begin
	  insymbol;
	  moduledeclaration(fsys,true,false,
	    display[top].available_module,false);
	  end;
	end;
      end; {case}
  checkfwptr(true);
  IF SY <> BEGINSY THEN
    BEGIN ERROR(17); SKIP(FSYS) END;
  DP := FALSE; oldDP := false; linelevel := 0;
  FINDFORW(DISPLAY[TOP].FNAME);
  lstate1 := display[top].available_module;
  while lstate1 <> NIL do
    begin
    if not lstate1^.modinfo^.isimplemented then
      begin
      errorwithinfo(706,
	lstate1^.modinfo^.modinitbody^.namep^ +
	': needs concrete instance');
      lstate1^.modinfo^.isimplemented := true;
      end;
    lstate1 := lstate1^.nextmodule;
    end;
  inbody := true;
  REPEAT
    if sy = beginsy then insymbol; { eat up the begin symbol }
    BODY(FSYS + [CASESY],fprocp);
    IF SY <> FSY THEN
      BEGIN ERROR(6); SKIP(FSYS + [FSY]) END
  UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS);
  if level = 1 then modulewrapup(true);
  END (*BLOCK*) ;


@


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


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

  procedure checkmodulefwptr(end_of_module: boolean);
    {Check pointer element types on the module's
     forward pointer list (from export section).}
    var
      tempid: alpha;
      lcp, nextfwdptr,tempmodulefwptr: ctp;

    begin
    tempid := id; prterr := false; {save - restore}
    tempmodulefwptr := display[top].fmodule^.modinfo^.modulefwptr;
    while tempmodulefwptr <> NIL do
      begin
      if tempmodulefwptr^.idtype^.eltype = cant_deref then
	begin
	id := tempmodulefwptr^.namep^;
	searchid([types],lcp);
	if lcp=NIL then
	  begin
	  if end_of_module then
	    errorwithinfo(117,'Undefined type ' + tempmodulefwptr^.namep^);;
	  end
	else
	  tempmodulefwptr^.idtype^.eltype := lcp^.idtype;
	end
      else
	if end_of_module then
	  tempmodulefwptr^.idtype^.eltype := cant_deref;
      tempmodulefwptr := tempmodulefwptr^.next;
      end;
    id := tempid; prterr := true;
    end; {checkmodulefwptr}

  procedure checkfwptr(not_in_export: boolean);
    {Fix up pointer element types on forward
     pointer list.  N.B: all pointers are forward
     till end of ctv declarations ala ISO.}
    var
      tempid: alpha;
      lcp, nextfwptr: ctp;

    begin
    tempid := id; prterr := false; {save - restore}
    while fwptr <> NIL do
      begin id := fwptr^.namep^;
      searchid([types],lcp);
      if lcp=NIL then
	if not_in_export then
	  begin
	  errorwithinfo(117,'Undefined type ' + fwptr^.namep^);
	  fwptr := fwptr^.next;
	  end
	else
	  begin
	  fwptr^.idtype^.eltype := cant_deref;
	  nextfwptr := fwptr^.next;
	  fwptr^.next := display[top].fmodule^.modinfo^.modulefwptr;
	  display[top].fmodule^.modinfo^.modulefwptr := fwptr;
	  fwptr := nextfwptr;
	  end
      else
	begin
	fwptr^.idtype^.eltype := lcp^.idtype;
	fwptr := fwptr^.next;
	end;
      end;
    id := tempid; prterr := true;
    end; {checkfwptr}

  PROCEDURE LABELDECLARATION (fsys: setofsys);
    VAR LLP: LABELP; TEST,REDEF: BOOLEAN;
  BEGIN
    INSYMBOL;
    REPEAT
      IF SY <> INTCONST THEN ERROR(15)
      else
	begin
	WITH DISPLAY[TOP] DO
	  BEGIN LLP := FLABEL; REDEF := FALSE;
	  WHILE (LLP <> NIL) AND NOT REDEF DO
	    IF LLP^.LABVAL <> VAL.IVAL THEN
	      LLP := LLP^.NEXTLAB
	    ELSE BEGIN REDEF := TRUE; ERROR(166) END;
	  IF NOT REDEF THEN
	    BEGIN NEW(LLP);
	    if val.ival > 9999 then error(163);
	    WITH LLP^ DO
	      BEGIN
	      LABVAL := VAL.IVAL; NEXTLAB := FLABEL;
	      defined := false; isrefed := false;
	      nonlocalref := false; staticlevel := level;
	      isnlrefed := false;
	      END;
	    FLABEL := LLP
	    END;
	  END; {with}
	INSYMBOL
	end;
      IF NOT (SY IN FSYS + [COMMA, SEMICOLON]) THEN
	BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END;
      TEST := SY <> COMMA;
      IF NOT TEST THEN INSYMBOL
    UNTIL TEST;
    IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
  END (* LABELDECLARATION *) ;

  PROCEDURE CONSTDECLARATION (fsys: setofsys;
			      allowstructconst,
			      externalmodule: boolean);
    VAR
      LCP: CTP;
      LSP: STP;
      LVALU: VALU;
      structconstnode: structnodeptr;
  BEGIN
  INSYMBOL;
  IF SY <> IDENT THEN
    BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
  WHILE SY = IDENT DO
    BEGIN NEW(LCP,KONST);
      WITH LCP^ DO
	BEGIN
	newident(namep,ID); gnamep := namep; IDTYPE := NIL;
	NEXT := NIL; KLASS := KONST; info := sysinfo
	END;
      INSYMBOL;
      IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
      CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
      if lsp <> NIL then
	begin
	if stdpasc then
	  if not modcal and (lsp = anyptrptr) then
	    error(606);
	if lsp^.form in [arrays,records,power] then
	  with lvalu.valp^ do
	    begin
	    if stdpasc then
	      if cclass <> paofch then error(606);
	    if cclass = strctconst then
	      begin
	      isdumped := false;
	      if not allowstructconst then
		error(688);
	      if importexportext then
		begin { Can't dump const now }
		new(structconstnode);
		with structconstnode^ do
		  begin
		  sp := lsp;
		  val := lvalu;
		  next := structconstlist;
		  structconstlist := structconstnode;
		  end;
		end
	      else
		begin
		if not hasbeenoutput then
		  begin
		  if not externalmodule then
		    dumpstconst(lsp,lvalu);
		  hasbeenoutput := true;
		  end;
		if not saveconst then
		  begin release(kstruc); kstruc := NIL end;
		end;
	      end;
	    end;
	end;
      ENTERID(LCP);
      LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
      IF SY = SEMICOLON THEN
	BEGIN INSYMBOL;
	  IF NOT (SY IN FSYS + [IDENT]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	END
      ELSE ERROR(14)
    END; (*WHILE*)
  END (*CONSTDECLARATION*) ;

  PROCEDURE TYPEDECLARATION (fsys: setofsys);
    VAR LCP: CTP; LSP: STP;

    BEGIN
    INSYMBOL;
    IF SY <> IDENT THEN
      BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
    disdef.level := top;
    WHILE SY = IDENT DO
      BEGIN NEW(LCP,TYPES);
	WITH LCP^ DO
	  BEGIN newident(namep,ID); IDTYPE := NIL; KLASS := TYPES;
	  info := sysinfo; disdef.id := namep;
	  END;
	INSYMBOL;
	IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
	ENTERID(LCP);
	TYP(FSYS + [SEMICOLON],LSP);
	LCP^.IDTYPE := LSP;
	IF SY = SEMICOLON THEN
	  BEGIN INSYMBOL;
	    IF NOT (SY IN FSYS + [IDENT]) THEN
	      BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	  END
	ELSE ERROR(14)
      END; (*while sy=ident*)
    disdef.level := -1; {restore}
    END (*TYPEDECLARATION*) ;

  PROCEDURE VARDECLARATION (fsys: setofsys);
    VAR LCP,NXT,IDLIST,previousid: CTP; LSP: STP; lvalu: valu;
	TEST: BOOLEAN;
    BEGIN
    INSYMBOL;
    REPEAT
      NXT := NIL;
      REPEAT
	IF SY = IDENT THEN
	  BEGIN
	    NEW(LCP,VARS);
	    WITH LCP^ DO
	      BEGIN newident(namep,ID); NEXT := NXT;
	      KLASS := VARS; IDTYPE := NIL; vtype := localvar;
	      VLEV := LEVEL; info := sysinfo;
	      if level = 1 then
		globalptr := curglobalname
	      else globalptr := NIL;
	      $PARTIAL_EVAL ON$
	      if ((sawkeyboard and (namep^ = 'KEYBOARD')) or
		 (sawlisting and (namep^ = 'LISTING'))) and
		 (top = 1) {main program} then
	      else ENTERID(LCP);
	      $IF not partialevaling$
		$PARTIAL_EVAL OFF$
	      $END$
	      END;
	    NXT := LCP;
	    INSYMBOL;
	    if sy = lbrack then       (* var x[absolute address]: ... *)
	      begin
	      if not (modcal or sysprog) then
		error(612);
	      insymbol;
	      constant(fsys+[rbrack,comma,colon],lsp,lvalu);
	      if lsp = char_ptr then stretchpaofchar(lsp,lvalu,1);
	      if (lsp <> intptr) and not paofchar(lsp) then error(50);
	      lcp^.vtype := longvar;
	      lcp^.absaddr := lvalu;
	      if lsp <> intptr then
		begin (*symbolic address*)
		if sy = comma then
		  begin insymbol;
		  constant(fsys+[rbrack,comma,colon],lsp,lvalu);
		  if lsp <> char_ptr then error(50)
		  else
		    case chr(lvalu.ival) of
		      'L','l': ;
		      'S','s': lcp^.vtype := shortvar;
		      'R','r': lcp^.vtype := relvar;
		      otherwise error(50);
		      end;
		  end; (*sy=comma*)
		end; (*symbolic address*)
	      if sy = rbrack then insymbol else error(12);
	      end (*sy=lbrack*)
	  END
	ELSE ERROR(2);
	IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN
	  BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END;
	TEST := SY <> COMMA;
	IF NOT TEST THEN INSYMBOL
      UNTIL TEST;
      IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
      IDLIST := NXT;
      previousid := NIL;
      TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP);
      WHILE NXT <> NIL DO
	WITH NXT^ DO
	  BEGIN IDTYPE := LSP;
	  if vtype = localvar then
	    $PARTIAL_EVAL ON$
	    if top = 1 {main program} then
	      begin
	      if sawkeyboard and (namep^ = 'KEYBOARD') then
		if lsp <> textptr then error(184)
		else
		  begin
		  if idlist = nxt then idlist := next
				  else previousid^.next := next;
		  nxt := previousid;
		  if not ucsd then
		    enterid(keyboardptr);
		  end
	      else if sawlisting and (namep^ = 'LISTING') then
		if lsp <> textptr then error(184)
		else
		  begin
		  if idlist = nxt then idlist := next
				  else previousid^.next := next;
		  nxt := previousid;
		  if not ucsd then
		    enterid(listingptr);
		  end
	      else
		begin
		vaddr := allocate(LC,lsp,false,1);
		previousid := nxt;
		end;
	      end
	    else
	      VADDR := allocate(LC,lsp,false,1);
	    $IF not partialevaling$
	      $PARTIAL_EVAL OFF$
	    $END$
	  IF NEXT = NIL THEN
	    begin
	    IF LSP <> NIL THEN
	      IF (idlist <> NIL) and
		 (mustinitialize in lsp^.info) THEN
		BEGIN (*PUT IDLIST INTO LOCAL FILE LIST*)
		nxt^.NEXT := DISPLAY[TOP].FFILE;
		DISPLAY[TOP].FFILE := IDLIST;
		END;
	    nxt := NIL;
	    end
	  else
	    NXT := NEXT;
	  END;
      if $IF MC68020$ (level = 1) and $END$ (lc < LClimit) then
	error(683);
      IF SY = SEMICOLON THEN
	BEGIN INSYMBOL;
	  IF NOT (SY IN FSYS + [IDENT]) THEN
	    BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
	END
      ELSE ERROR(14)
    UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS);
    END (*VARDECLARATION*) ;

  PROCEDURE PROCDECLARATION (fsys: setofsys);
    VAR FSY: SYMBOLS; OLDLEV,plsave: LEVRANGE; LCP: CTP;
	FORW,ipssave: BOOLEAN; OLDTOP: DISPRANGE;
	LLC: ADDRRANGE;  MARKP: ^INTEGER; infosave: infobits;

  procedure procheader;
    label 1;
    var LCP1: CTP; LSP: STP; dummy,
    plc, llc: addrrange; lstate: modstateptr;
	lmarkstacksize: addrrange; waslparent: boolean;
    BEGIN
    IF SY = IDENT THEN
      BEGIN
      with display[top] do            {Look for 'forward' declaration}
	if occur = MODULEscope then
	  begin
	  lstate := fmodule;
	  repeat
	    searchsection(lstate^.defineids,lcp);
	    lstate := lstate^.contmodule;
	  until (lstate=NIL) or (lcp<>NIL);
	  if lcp = NIL then searchsection(fname,lcp)
	  end
	else searchsection(fname,lcp);
      FORW := FALSE;  {default}
      IF LCP <> NIL THEN
	BEGIN         (* name already declared, check for FORWARD *)
	IF LCP^.FORWDECL THEN
	  IF LCP^.KLASS = prox THEN
	    FORW := ((FSY = PROCSY) and not lcp^.ismodulebody)
	  ELSE IF LCP^.KLASS = FUNC THEN
	    FORW := (FSY = FUNCSY);
	IF NOT FORW THEN
	  if ((fsy = procsy) and (lcp^.klass = prox)) or
	     ((fsy = funcsy) and (lcp^.klass = func)) then
	    ERROR(160)
	END;
      IF NOT FORW THEN
	BEGIN
	IF FSY = PROCSY THEN
	  begin NEW(LCP,prox,DECLARED);
	    lcp^.klass := prox; lcp^.ismodulebody := false;
	  end
	else (* function *)
	  begin
	  NEW(LCP,FUNC,DECLARED);
	  with lcp^ do
	    begin
	    klass := func;
	    pfaddr := 0;
	    assignedto := false;
	    end;
	  end;
	WITH LCP^ DO
	  BEGIN
	  newident(namep,ID); IDTYPE := NIL;
	  paramlc := 0; PFDECKIND := DECLARED;
	  forwdecl := false; extdecl := false;
	  isexported := indefinesection;
	  isdumped := false; isrefed := false;
	  inscope := false; next := NIL;
	  PFLEV := OLDLEV; info := infosave;
	  END;
	ENTERID(LCP);
	END
      ELSE  (* forward; must update LC for copied value parms *)
	BEGIN LCP1 := LCP^.NEXT;
	WHILE LCP1 <> NIL DO
	  BEGIN
	  WITH LCP1^ DO
	    if vtype=cvalparm then
	      dummy := allocate(LC, idtype, false, 1);
	  LCP1 := LCP1^.NEXT;
	  END;
	END;
      insymbol;
      END (* SY = IDENT *)
    ELSE
      BEGIN ERROR(2); LCP := UPRCPTR END;
    IF TOP < DISPLIMIT THEN
      BEGIN TOP := TOP + 1;
      with DISPLAY[TOP] do
	begin
	if FORW then
	  begin                 (* skip conformant array dope vector parm(s) *)
	    LCP1 := LCP^.next;  (*   and get to first explicit parm, which *)
	    while LCP1 <> nil do (*  will then also be top of sym tbl tree *)
	      begin
		if LCP1^.namep <> NIL then
		  goto 1;
		LCP1 := LCP1^.next;
	      end;
1:          FNAME := LCP1;
	  end
	else
	  FNAME := NIL;
	FLABEL := NIL;
	FFILE := NIL;
	FMODULE := NIL;
	OCCUR := BLOCKscope;
	available_module := NIL;
	end;
      END
    ELSE ERROR(662);
    if oldlev = 1 then lmarkstacksize := level1markstacksize
    else lmarkstacksize := markstacksize;
    waslparent := sy = lparent;
    llc := lc; lc := lcaftermarkstack;
    IF FSY <> funcsy THEN
      PARAMETERLIST(fsys,[SEMICOLON],LCP1,plc,forw,lmarkstacksize)
    ELSE
      PARAMETERLIST(fsys,[SEMICOLON,COLON],LCP1,plc,forw,lmarkstacksize);
    IF NOT FORW THEN
      begin LCP^.NEXT := LCP1; LCP^.paramlc := plc end
    else if waslparent then  { paramlist was respecified }
      begin
      if stdpasc then error(606);
      if (plc <> lcp^.paramlc) or (llc <> lc) then error(171)
      else if not compparmlists(lcp^.next,lcp1,true,true) then error(171);
      end;
    if forw then lc := llc;
    if fsy = funcsy then
      IF SY = COLON THEN
	BEGIN INSYMBOL;
	IF SY = IDENT THEN
	  BEGIN
	  SEARCHID([TYPES],LCP1);
	  if lcp1 <> NIL then
	    begin
	    LSP := LCP1^.IDTYPE;
	    if lsp = strgptr then error(733)
	    else if lsp <> NIL then
	      begin
	      if cantassign in lsp^.info then
		error(751);
	      if forw and (lsp <> lcp^.idtype) then error(171);
	      end;
	    LCP^.IDTYPE := LSP;
	    IF LSP <> NIL THEN
	      IF lsp^.form >= prok then
		begin
		lsp := anyptrptr;
		if stdpasc then error(606);
		end;
  {***** Machine dependent addr of function result area *****}
	    plc := lcaftermarkstack+lmarkstacksize+LCP^.paramlc;
	    LCP^.pfaddr := allocate(plc, lsp, true, parmalign);
	    end;
	  INSYMBOL;
	  END
	ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END
	END
      ELSE IF NOT FORW THEN ERROR(123)
    END; (* procheader *)

  BEGIN (*PROCDECLARATION*)
    FSY := SY; aliasptr := NIL; aliasok := true;
    INSYMBOL; LLC := LC; LC := LCAFTERMARKSTACK;
    DP := TRUE; oldDP := true;
    infosave := sysinfo; sysinfo := [];
    OLDLEV := LEVEL; OLDTOP := TOP;
    IF LEVEL < MAXPLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(663);
    procheader;
    with lcp^ do
      begin
      alias := aliasptr <> NIL;
      if alias and forw then error(620);
      if alias then othername := aliasptr
      else othername := curglobalname;
      end;
    if not indefinesection then
      IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
    aliasok := false;
    IF indefinesection then
      begin
      if forw then error(667) else lcp^.forwdecl := true;
      end
    else if (sy=forwardsy) or
	   ((sy=ident) and (id='FORWARD')) then
      begin
      IF FORW THEN ERROR(667)
      ELSE
	begin
	LCP^.FORWDECL := TRUE;
	lcp^.forwid := uniquenumber;
	end;
      insymbol;
      end
    else if (sy=externlsy) OR
	   ((sy=ident) and (id='EXTERNAL')) then
      with lcp^ do     (* EXTERNAL declaration *)
	begin
	if forwdecl then
	  begin
	  forwdecl:=false;
	  if pflev<>1 then error(666)
	  else if not isexported then error(668);
	  end;
	extdecl:=true; pflev := 1;
	if level <> 2 then
	  warning(linenumber+1,'External declarations will be treated as global');
	if not isexported then
	  if not alias then othername := NIL;
	insymbol;
	end
    ELSE {not declared FORWARD, process procedure body}
      BEGIN MARK(MARKP);
      with lcp^ do
	begin FORWDECL := FALSE; INSCOPE := true; end;
      BLOCK(FSYS,SEMICOLON,LCP);
      if(lcp^.klass = func) and
	not lcp^.assignedto then
	error(181);
      LCP^.INSCOPE := FALSE;
      RELEASE(MARKP);
      END;
    LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; sysinfo := infosave;
    DP := TRUE;
    IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
    IF NOT (SY IN FSYS) THEN
      BEGIN ERROR(6); SKIP(FSYS) END;
  END (*PROCDECLARATION*);

PROCEDURE FINDFORW (FCP: CTP);
  {Report missing forward procedures in tree rooted at fcp}
  BEGIN
  IF FCP <> NIL THEN
    WITH FCP^ DO
      BEGIN
      IF KLASS IN [prox,FUNC] THEN
	IF PFDECKIND = DECLARED THEN
	  IF FORWDECL and not ismodulebody THEN
	    errorwithinfo(117,'Missing procedure ' + namep^);
      FINDFORW(RLINK); FINDFORW(LLINK)
      END
  END (*FINDFORW*);

procedure searchfiles(fsys: setofsys;
		      var lcp: ctp;
		      inimplmntsection: boolean);
  { search files to satisfy an 'import' item }
  var
    libfile1: file of direntry;
    libentry: direntry;
    libfile2: file;
    tempwidth,templine: integer;
    tempdisplay: displayframe;
    templist: listswitch;
    tempfwptr: ctp;
    found,readerror,savedisplay,tempstdpasc,
    tempcode,tempmodcal,errorinimport,tempucsd: boolean;
    { Added for FSDdt04001. }
    prev_temp : boolean;
    p,i,libsize,blkno: shortint;
    buf: record case integer of
	   1: (modulentry: module_directory);
	   2: (pad: packed array[1..512] of byt);
	 end;
  begin
  lcp := NIL;
  if strlen(id) <= fnlength then
    with buf do
      begin
      found := false;
      p := 0;
      repeat
	p := p + 1;
	close(libfile1);
	reset(libfile1,searchlistptr^[p],'SHARED');
	if IORESULT <> 0 then
	  begin { don't give error for *syslib }
	  if p <> searchfilestop then
	    errorwithinfo(611,'Can''t open ' +
				    searchlistptr^[p]);
	  end
	else { read in library header }
	  begin
	  read(libfile1,libentry);
	  if ioresult <> 0 then
	    errorwithinfo(611,'Can''t access ' +
				     searchlistptr^[p])
	  else
	    begin
	    readerror := false;
	    libsize := libentry.dnumfiles;
	    i := 1;
	    while (i <= libsize) and
		     not found and not readerror do
	      begin
	      read(libfile1,libentry);
	      if ioresult <> 0 then
		begin
		readerror := true;
		errorwithinfo(611,'Can''t read ' +
				    searchlistptr^[p]);
		end
	      else
		if libentry.dtid = id then
		  found := true;
	      i := i + 1;
	      end;
	    end;
	  end;
      until (p = searchfilestop) or found;
      close(libfile1);
      if found then
	begin
	blkno := libentry.dfirstblk;
	reset(libfile2,searchlistptr^[p],'SHARED');
	if blockread(libfile2,modulentry,1,blkno) <> 1 then
	  begin
	  found := false;
	  errorwithinfo(611,'Can''t open ' +
				    searchlistptr^[p]);
	  end
	else if srcindex >= maxinfiles then
	  begin found := false; error(610); end
	else if modulentry.source_size = 0 then
	  errorwithinfo(613,'Module '+id+' in '+
	  searchlistptr^[p]+' does not have interface text')
	else if modulentry .system_id <> (ord(crevno[1])-ord('0')) then
	  errorwithinfo(611,'Module '+ searchlistptr^[p] +
	  ': Improper revision number')
	else
	  begin
	  with sourceinfoptr^[srcindex] do
	    begin
	    oldsymcursor := symcursor;
	    oldlinestart := linestart;
	    oldfilepos := filepos;
	    oldsymblk := symblk;
	    oldrelinum := relinum;
	    oldftype := ftype;
	    end;
	  srcindex := srcindex + 1;
	  sourceinfoptr^[srcindex].filename := searchlistptr^[p];
	  filepos := (pagesize *
	    (blkno + modulentry.source_block)) DIV 2;
	  close(source);
	  reset(source,searchlistptr^[p],'SHARED');
	  with fibp(addr(source))^ do
	    begin
	    am := amtable^[untypedfile];
	    fpos := filepos;
	    end;
	  relinum := 0;
	  ftype := specil;
	  symblk := 0; { not really used }
	  getnextpage;
	  templist := gtemplist;
	  gtemplist := list;
	  list := listnone;
	  templine := gtemplinenumber;
	  gtemplinenumber := linenumber;
	  tempwidth := gtempwidth;
	  gtempwidth := width;
	  width := 120;
	  { FSDdt04001 : }
	  prev_temp := temp_put;
	  temp_put := putcode;
	  tempcode := putcode;
	  putcode := false;
	  tempmodcal := modcal;
	  modcal := true;
	  tempucsd := ucsd;
	  ucsd := true;
	  tempstdpasc := stdpasc;
	  stdpasc := false;
	  tempfwptr := fwptr;
	  fwptr := NIL;
	  savedisplay := not inimplmntsection and
		(display[top].occur = modulescope);
	  if savedisplay then
	    begin
	    tempdisplay := display[top];
	    top := top - 1;
	    end;
	  insymbol;
	  moduledeclaration(fsys,true,false,
	      display[top].available_module,false);
	  if savedisplay then
	    begin
	    top := top + 1;
	    display[top] := tempdisplay;
	    end;
	  { These are restored in checkend }
	  (************************************)
	  (*  list := gtemplist;              *)
	  (*  linenumber := gtemplinenumber;  *)
	  (*  width := gtempwidth;            *)
	  (************************************)
	  gtemplist := templist;
	  fwptr := tempfwptr;
	  gtemplinenumber := templine;
	  gtempwidth := tempwidth;
	  { FSDdt04001 : }
	  temp_put := prev_temp;
	  putcode := tempcode;
	  modcal := tempmodcal;
	  ucsd := tempucsd;
	  stdpasc := tempstdpasc;
	  { Removed for FSDdt04001 : }
	  { if importexportext then outputsymbol; }
	  lcp := modulectp;
	  gstate := gcurstate;
	  end;
	end;
	close(libfile2);
      end; { with buf }
  end; { searchfiles }

procedure  importsection(fsys: setofsys;
	      var wheretolinkstate: modstateptr;
	      inimplmntsection: boolean);
  label 1;
  var
    lcp,lcp1: ctp;
    lstate,lstate1,lmodstate: modstateptr;
    savedisplay,lmoreids,
    insymboldone,errorinimport: boolean;
  begin
  if sy <> ident then
    begin error(2); skip(fsys + [ident,exportsy,implmtsy,endsy]) end;
  lmoreids := sy = ident;
  while lmoreids do
    begin
    insymboldone := false;
    prterr := false;
    savedisplay :=
		display[top].occur = modulescope;
    if savedisplay then
      top := top - 1;    (* search outside this module *)
    searchid([types,konst,vars,prox,func],lcp1);
    errorinimport := false;
    prterr := true;
    if savedisplay then
      top := top + 1;
    if lcp1 <> NIL then
      if (lcp1^.klass = prox) and
	  lcp1^.ismodulebody then
	lcp1 := NIL; { find it another way }
    if lcp1 = NIL then
      begin
      searchavailablemodules(lcp1);
      if lcp1 <> NIL then
1:      if (lcp1^.klass = prox) and
	   lcp1^.ismodulebody then
	  begin
	  lstate := gstate^.defmodule;
	  while lstate <> NIL do
	    begin
	    new(lmodstate);
	    lmodstate^ := lstate^;
	    with lmodstate^ do
	      begin
	      modinfo^.needscall := false;
	      nextmodule :=
		    display[top].available_module;
	      end;
	    display[top].available_module :=
					 lmodstate;
	    lstate := lstate^.nextmodule;
	    end;
	  lstate1 := gstate; { save gstate }
	  if checkdefineconflicts(lcp1) then
	    errorinimport := true;
	  gstate := lstate1; { restore gstate }
	  end;
      end;
    if lcp1 = NIL then
      begin
      searchfiles(fsys,lcp1,inimplmntsection);
      if (lcp1 <> NIL) and
	 ((level <> 1) or
	  (top > display_ok_to_import)) then
	error(717);
      if lcp1 <> NIL then
	begin
	insymboldone := true;
	goto 1;
	end;
      end
    else if lcp1^.idtype=strgptr then error(104);
    if lcp1 = NIL then error(104)
    else if not errorinimport then
      begin
      if (lcp1^.klass = prox) and lcp1^.ismodulebody then
	if gstate=NIL then error(687)
	else
	  begin                       {Import module}
	  lstate := gstate^.modinfo^.laststate;       {Find newest instance}
	  while lstate <> NIL do      {Copy all instances into my USE list}
	    begin
	    new(lstate1); lstate1^ := lstate^;
	    with lstate1^ do
	      begin
	      contmodule := NIL;
	      nextmodule := wheretolinkstate;
	      end;
	    wheretolinkstate := lstate1;
	    lstate := lstate^.contmodule;
	    end;
	  end
      else
	begin                       {Import identfier}
	if not modcal then error(612);
	new(lcp); lcp^ := lcp1^;
	enterid(lcp);               (* add object to this module *)
	if (lcp^.klass = types) and (lcp^.idtype <> NIL) then
	  with lcp^.idtype^ do
	    if (form = scalar) and (scalkind = declared) then
	      begin           (* add konsts *)
	      lcp1 := fconst;
	      while lcp1 <> NIL do begin
		new(lcp); lcp^ := lcp1^;
		enterid(lcp);
		lcp1 := lcp1^.next
		end;
	      end;
	{ do not put an id out in interface text }
	if importexportext and putcode then
	  begin
	  moduleinit(curglobalname);
	  importexportext := false;
	  idinimport := true;
	  end;
	end;
      end; {lcp1<>NIL}
    if not insymboldone then insymbol;
    lmoreids := sy=comma;
    if sy in [comma,semicolon] then insymbol else error(14);
    if lmoreids and (sy <> ident) then
      begin
      error(2);
      if sy = semicolon then
	begin
	insymbol;
	lmoreids := false;
	end;
      end;
  end; (*while moreids*)
  if not (sy in (fsys + [exportsy,implmtsy,endsy])) then
    begin error(6); skip(fsys + [exportsy,implmtsy,endsy]) end
  end;  (* importsection *)

procedure checkbintree(id: ctp);
  begin
  with id^ do
    begin
    if (klass = prox) or (klass = func) then
      isdumped := false
    else if (klass = konst) and not values.intval then
      with values.valp^ do
	if cclass = strctconst then
	  isdumped := false;
    if llink <> NIL then checkbintree(llink);
    if rlink <> NIL then checkbintree(rlink);
    end;
  end;

procedure moduledeclaration(fsys: setofsys;
	   mustbeabstract,forwardmodule: boolean;
	   var wheretolinkstate: modstateptr;
	   modulelist: boolean);
  var
    curmodinfo: modinfoptr;
    lstate,lstate1,curmodstate: modstateptr;
    modinit1,modinit2: ctp; lsp: stp;
    newmodule,oldindefine: boolean;
    labsaddr: valu; oldtop: disprange;
    oldinfo: infobits;
    oldlc: addrrange;
    oldglobalname: alphaptr;
    oldstructconstlist: structnodeptr;

  procedure exportsection (fsys: setofsys);
    begin
    indefinesection := true;
    if not (sy in [constsy,typesy,varsy,procsy,funcsy,
		   modulesy,endsy,implmtsy])
      then begin error(710); skip(fsys) end;
    while sy in [constsy,typesy,varsy,
		 procsy,funcsy,modulesy] do
      begin
      case sy of
	constsy:  constdeclaration(fsys,not forwardmodule,
					not forwardmodule and
					mustbeabstract);
	typesy:   typedeclaration(fsys);
	varsy:    vardeclaration(fsys);
	modulesy:
	  begin
	  if not modcal then error(612);
	  moduledeclaration(fsys,true,true,curmodstate^.defmodule,false);
	  end;
	procsy,funcsy: procdeclaration(fsys);
	end; {case}
      if not (sy in [constsy,typesy,varsy,procsy,funcsy,
		     modulesy,endsy,implmtsy])
	then begin error(710); skip(fsys) end;
      end;
    indefinesection := false;
    end;  (* exportsection *)

  procedure undump(p: modstateptr);
    { after module codegen set the isdumped field to false
      for defined proxs, funcs, and structured consts }
    var
      modstatetemp: modstateptr;
    begin
    while p <> NIL do
      with p^ do
	begin
	if defineids <> NIL then
	  checkbintree(defineids);
	modstatetemp := p^.defmodule;
	while modstatetemp <> NIL do
	  begin
	  undump(modstatetemp);
	  modstatetemp := modstatetemp^.nextmodule;
	  end;
	p := p^.contmodule;
	end;
    end; {undump}

  procedure implmtsection;
    var heapsv: ^integer; lstate,msp: modstateptr;
	oldlev: levrange; oldlc: addrrange;
	old_display_ok_to_import: disprange;

    begin
    old_display_ok_to_import := display_ok_to_import;
    display_ok_to_import := top + 1;
    mark(heapsv);
    if sy = labelsy then
      begin error(6); labeldeclaration(fsys) end;
    while sy in [constsy,typesy,varsy,modulesy,
		 importsy,forwardsy,externlsy] do
      case sy of
	CONSTSY: CONSTDECLARATION(fsys+[endsy],true,false);
	TYPESY:  TYPEDECLARATION(fsys+[endsy]);
	VARSY:   VARDECLARATION(fsys+[endsy]);
	forwardsy,externlsy,modulesy:
	  begin
	  if not modcal then error(612);
	  checkfwptr(true);
	  checkmodulefwptr(false);
	  case sy of
	    modulesy:
	      moduledeclaration(fsys,false,false,
		    display[top].available_module,false);
	    forwardsy:
	      begin;
	      insymbol;
	      moduledeclaration(fsys,true,true,
		    display[top].available_module,false);
	      end;
	    externlsy:
	      begin
	      insymbol;
	      moduledeclaration(fsys,true,false,
		    display[top].available_module,false);
	      end;
	  end;
	  end;
	importsy:
	  begin
	  if not modcal then error(612);
	  insymbol;
	  importsection(fsys,display[top].fmodule^.modinfo^.impmodule,true);
	  end;
	end; {case}
    while sy in [constsy,typesy,varsy,procsy,importsy,
	 funcsy,externlsy,forwardsy,modulesy] do
      case sy of
	CONSTSY: begin
		 error(653);
		 CONSTDECLARATION(fsys,true,false);
		 end;
	TYPESY:  begin
		 error(653);
		 TYPEDECLARATION(fsys);
		 end;
	VARSY:   begin
		 error(653);
		 VARDECLARATION(fsys);
		 end;
	procsy,funcsy:
	  begin
	  checkfwptr(true);
	  checkmodulefwptr(false);
	  procdeclaration(fsys+[endsy]);
	  end;
	forwardsy,externlsy,modulesy:
	  begin
	  checkfwptr(true);
	  error(653);
	  if sy = modulesy then
	    moduledeclaration(fsys,false,false,
		    display[top].available_module,false)
	  else
	    begin
	    insymbol;
	    moduledeclaration(fsys,true,false,
		    display[top].available_module,false);
	    end;
	  end;
	importsy:
	  begin
	  error(653);
	  insymbol;
	  importsection(fsys,display[top].fmodule^.modinfo^.impmodule,true);
	  end;
	end; {case}
    checkfwptr(true);
    checkmodulefwptr(true);
    IF SY <> endsy THEN
      BEGIN
      ERROR(13);
      if sy = beginsy then insymbol
      else SKIP(fsys+[endsy]);
      END;
    (* Mark module body not forward *)
    with modinit1^ do
      begin forwdecl := false; inscope := true end;
    if newmodule then
      with modinit2^ do
	begin forwdecl := false; inscope := true end;
    (* Find missing forward procedures *)
    findforw(display[top].fname); lstate := curmodstate;
    while lstate <> NIL do
      begin findforw(lstate^.defineids); lstate := lstate^.contmodule end;
    (* handle initialization body *)
    oldlev := level;
    if level < maxplevel then level:=level+1 else error(663);
    oldlc := lc; lc := lcaftermarkstack;
    dp := false; olddp := false; linelevel := 0;
    display[top].flabel := NIL; { avoid additional errors }
    inbody := true;
    repeat
      body(fsys + [casesy],modinit1);
      if (sy <> semicolon) and (sy <> period) then
	begin error(14);  skip(fsys + [semicolon,period]) end
    until sy in blockbegsys+[semicolon,period];
    modinit1^.inscope := false;
    if newmodule then
      modinit2^.inscope := false;
    level := oldlev; lc := oldlc;
    if top = 2 then
      begin
      modulewrapup(true);
      undump(curmodstate);
      end;
    msp := display[top].available_module;
    while msp <> NIL do
      with msp^ do
	begin
	while (modinfo^.laststate <> NIL) and
	      (integer(modinfo^.laststate) >=
	      integer(heapsv)) do
	  modinfo^.laststate:= modinfo^.laststate^.contmodule;
	msp := nextmodule;
	end;
    release(heapsv);
    old_display_ok_to_import := display_ok_to_import;
    end;  (* implmtsection *)

  procedure findmodule (fstate: modstateptr);
    {Search fstate chain for module with name = id}
    label 1;
    begin
    while fstate <> NIL do
      if fstate^.modinfo^.modinitbody^.namep^ = id then
	begin gstate := fstate; goto 1 end
      else fstate := fstate^.nextmodule;
    gstate := NIL;            {Report failure}
  1:end;

  begin  (* moduledeclaration *)
  if stdpasc then error(606);
  oldlc := LC;
  oldtop := top; oldinfo := sysinfo;
  oldindefine := indefinesection; indefinesection := false;
  oldstructconstlist := structconstlist;
  structconstlist := NIL;
  sysinfo := [];
  LC := initmodLC;
  aliasptr := NIL;
  if sy = modulesy then insymbol else error(715);
  if sy <> ident then
    begin error(2); id := '**undefmodule**' end
  else if strlen(id) > fnlength then
    error(689);
  (* Look for previous occurence of same module *)
  with display[top] do
    if occur = BLOCKscope then
      findmodule(available_module)
    else {occur = MODULEscope}
      begin
      findmodule(available_module);
      lstate := fmodule;
      while (gstate = NIL) and (lstate <> NIL) do
	begin
	findmodule(lstate^.defmodule);
	lstate := lstate^.contmodule;
	end;
      end;
  newmodule := (gstate = NIL);        {Did I find one?}
  if top < displimit then             {and new scope}
    begin
    top := top + 1;
    with display[top] do
      begin
      fname := NIL; ffile := NIL; flabel := NIL;
      fmodule := NIL; occur := MODULEscope;
      available_module := NIL;
      end
    end
  else error(662);
  new(curmodstate);                   {Always create new instance}
  if newmodule then
    begin                             {Create new module}
    new(curmodinfo);
    new(modinit1,prox,declared);
    with modinit1^ do
      begin
      newident(namep,id); idtype := NIL; next := NIL;
      info := [];
      klass := prox; pfdeckind := declared;
      isexported := true; alias := false;
      paramlc := 0; extdecl := false;
      inscope := false; forwdecl :=  true;
      isdumped := false; isrefed := false;
      ismodulebody := true; pflev := level;
      end;
    with curmodinfo^ do
      begin
      modinitbody := modinit1; laststate := NIL;
      needscall := true;  isimplemented := false;
      impmodule := NIL; usemodule := NIL;
      useids := NIL; curindefine := false;
      modulefwptr := NIL;
      end;
    end
  else
    begin                     {Found new instance of old module}
    curmodinfo := gstate^.modinfo;
    modinit1 := curmodinfo^.modinitbody;
    with curmodinfo^ do
      begin
      if isimplemented then error(719);
      (* Restore state *)
      display[top].ffile := svffile;
      LC := svLC;
      DP := true; oldDP := true;
      end;
    end;
  if level = 1 then
    begin
    oldglobalname := curglobalname;
    curglobalname := modinit1^.namep;
    end;
  if newmodule then
    modinit1^.othername := curglobalname;
  with curmodstate^ do        {Init new module state}
    begin
    modinfo := curmodinfo; defineids := NIL;
    nextmodule := NIL; defmodule := NIL;
    contmodule := curmodinfo^.laststate;
    end;
  with curmodinfo^, display[top] do
    begin
    laststate := curmodstate;
    fmodule := curmodstate;
    if sy = ident then insymbol;
    if sy = semicolon then insymbol else error(14);
    if (top = 2) and not mustbeabstract then
      begin
      modulewrapup(false);
      moduleinit(curglobalname);
      idinimport := false;
      end;
    if sy = importsy then
      begin
      if (top = 2) and newmodule and
	 not mustbeabstract then
	begin
	importexportext := true;
	importexportstart(curglobalname);
	symbolstart := symcursor - 6;
	outputsymbol;
	end;
      insymbol;
      fname := useids;
      importsection(fsys,curmodinfo^.usemodule,false);
      useids := fname;
      end;
    fname := NIL;
    curindefine := true;
    (******************************************
    * Module name is added at 1 level of the  *
    * display greater than is expected for    *
    * purposes of the import search mechanism *
    ******************************************)
    if newmodule then
      begin
      enterid(modinit1);
      top := top - 1;
      new(modinit2,prox,declared);
      modinit2^ := modinit1^;
      enterid(modinit2); { For syntactic reasons }
      top := top + 1;
      end;
    if sy = exportsy then
      begin
      if (top = 2) and not importexportext and
	 newmodule and not mustbeabstract
	 and not idinimport then
	begin
	importexportext := true;
	importexportstart(curglobalname);
	symbolstart := symcursor - 6;
	outputsymbol;
	end;
      insymbol;
      exportsection(fsys+[implmtsy,endsy]);
      end
    else if newmodule then error(714);
    curindefine := false;
    curmodstate^.defineids := fname;
    fname := NIL;
    if importexportext and not mustbeabstract and
       (top = 2) then
      begin
      importexportwrapup;
      importexportext := false;
      end;
    if not mustbeabstract and (top = 2) then
      while structconstlist <> NIL do
	with structconstlist^ do
	  begin
	  if not val.valp^.hasbeenoutput then
	     begin
	     dumpstconst(sp,val);
	     val.valp^.hasbeenoutput := true;
	     end;
	  structconstlist := next;
	  end;
    checkfwptr(false);
    checkmodulefwptr(false);
    if sy = implmtsy then {Concrete module}
      begin
      if mustbeabstract then error(720);
      insymbol;
      implmtsection;
      if (top <> 2) and (level = 1) then
	begin
	{Define symbol for this module's globals}
	if odd(oldlc) then
	  oldlc := oldlc - 1;
	outputextdef(curglobalname^,oldlc,oldglobalname^);
	{Add globals to enclosing module's globals}
	oldlc := oldlc + LC;
	end;
      end
    else
      begin                {Abstract module}
      if not mustbeabstract then error(711);
      if sy = endsy then insymbol else error(13);
      end;
    (* Save state in modinforec & restore previous state *)
    svffile := ffile;
    svLC := LC;
    LC := oldlc;
    structconstlist := oldstructconstlist;
    end; {with curmodinfo^, display[top]}
  top := oldtop;
  sysinfo := oldinfo;
  indefinesection := oldindefine;
  if level = 1 then
    begin
    curglobalname := oldglobalname;
    if not mustbeabstract and (top = 1) then
      moduleinit(curglobalname);
    end;
  dp := true;
  if not forwardmodule then
    curmodinfo^.isimplemented := true;
  curmodstate^.nextmodule := wheretolinkstate;        {Add instance to list}
  wheretolinkstate := curmodstate;
  lstate1 := curmodstate;
  while lstate1 <> NIL do
    begin
    lstate := lstate1^.defmodule;
    while lstate <> NIL do
      with lstate^, modinfo^ do
	begin
	if not mustbeabstract then
	  begin { make sure defined modules were implemented }
	  if not isimplemented then
	    begin
	    errorwithinfo(706,
	      (modinitbody^.namep^ +
	      ': needs concrete instance'));
	    isimplemented := true;
	    end;
	  end
	else if not forwardmodule then
	  isimplemented := true;
	lstate := nextmodule;
	end;
    lstate1 := lstate1^.contmodule;
    end;
  if modulelist then
    if sy = semicolon then
      begin
      insymbol;
      if not (sy in [modulesy,forwardsy,externlsy]) then
	error(715);
      end
    else begin if sy <> period then error(14); end
  else { not modulelist }
    if sy = semicolon then insymbol
    else error(14);
  gcurstate := curmodstate;
  modulectp := curmodinfo^.modinitbody;
  end;  (* moduledeclaration *)


PROCEDURE BLOCK (*FSYS: SETOFSYS; FSY: SYMBOLS; FPROCP: CTP*);
  var
    lstate1,lstate2: modstateptr;

  BEGIN (*BLOCK*)
  if sy = labelsy then labeldeclaration(fsys);
  if level = 1 then
    moduleinit(curglobalname);
  if stdpasc then
    begin
    if sy = constsy then
      CONSTDECLARATION(fsys,true,false);
    if sy = typesy then
      TYPEDECLARATION(fsys);
    if sy = varsy then
      VARDECLARATION(fsys);
    while (sy = procsy) or (sy = funcsy) do
      begin
      checkfwptr(true);
      procdeclaration(fsys);
      end;
    if sy in [constsy,typesy,varsy] then
      error(606);
    end;
  while sy in [constsy,typesy,varsy,importsy,
	       forwardsy,externlsy,modulesy] do
    case sy of
      CONSTSY: CONSTDECLARATION(fsys,true,false);
      TYPESY:  TYPEDECLARATION(fsys);
      VARSY:   VARDECLARATION(fsys);
      forwardsy,externlsy,modulesy:
	begin
	checkfwptr(true);
	if level = 1 then {undump global id's}
	  checkbintree(display[top].fname);
	case sy of
	  modulesy:
	    moduledeclaration(fsys,false,false,
	      display[top].available_module,false);
	  forwardsy:
	    begin
	    insymbol;
	    moduledeclaration(fsys,true,true,
	      display[top].available_module,false);
	    end;
	  externlsy:
	    begin
	    insymbol;
	    moduledeclaration(fsys,true,false,
	      display[top].available_module,false);
	    end;
	end;
	end;
      importsy:
	begin
	if (level <> 1) and not modcal then
	  error(612)
	else if stdpasc then error(606);
	insymbol;
	importsection(fsys,display[top].fmodule,false);
	end;
      end; {case}
  while sy in [constsy,typesy,varsy,procsy,
    funcsy,importsy,forwardsy,externlsy,modulesy] do
    case sy of
      CONSTSY: begin
	       error(653);
	       CONSTDECLARATION(fsys,true,false);
	       end;
      TYPESY:  begin
	       error(653);
	       TYPEDECLARATION(fsys);
	       end;
      VARSY:   begin
	       error(653);
	       VARDECLARATION(fsys);
	       end;
      procsy,funcsy:
	begin
	checkfwptr(true);
	procdeclaration(fsys);
	end;
      importsy:
	begin
	error(653);
	insymbol;
	importsection(fsys,display[top].fmodule,false);
	end;
      forwardsy,externlsy,modulesy:
	begin
	checkfwptr(true);
	error(653);
	if sy = modulesy then
	  moduledeclaration(fsys,false,false,
	    display[top].available_module,false)
	else
	  begin
	  insymbol;
	  moduledeclaration(fsys,true,false,
	    display[top].available_module,false);
	  end;
	end;
      end; {case}
  checkfwptr(true);
  IF SY <> BEGINSY THEN
    BEGIN ERROR(17); SKIP(FSYS) END;
  DP := FALSE; oldDP := false; linelevel := 0;
  FINDFORW(DISPLAY[TOP].FNAME);
  lstate1 := display[top].available_module;
  while lstate1 <> NIL do
    begin
    if not lstate1^.modinfo^.isimplemented then
      begin
      errorwithinfo(706,
	lstate1^.modinfo^.modinitbody^.namep^ +
	': needs concrete instance');
      lstate1^.modinfo^.isimplemented := true;
      end;
    lstate1 := lstate1^.nextmodule;
    end;
  inbody := true;
  REPEAT
    if sy = beginsy then insymbol; { eat up the begin symbol }
    BODY(FSYS + [CASESY],fprocp);
    IF SY <> FSY THEN
      BEGIN ERROR(6); SKIP(FSYS + [FSY]) END
  UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS);
  if level = 1 then modulewrapup(true);
  END (*BLOCK*) ;


@


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.2
log
@

           Made changes in routine searchfiles for repair of
        FSDdt04001.
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d591 2
d697 3
d735 2
d741 2
a742 1
	  if importexportext then outputsymbol;
@


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.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.2
log
@Misc. fixes for STARS and bugs found in HP-UX -- see BAR/JWS for detail
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d329 1
a329 1
      if $IF MC68020$ (level = 0) and $END$ (lc < LClimit) then
@


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
@d598 1
a598 1
  if strlen(id) <= tidleng then
d1123 1
a1123 1
  else if strlen(id) > tidleng{15} then
@


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
@d346 1
d423 13
a435 1
	if FORW then FNAME := LCP^.NEXT else FNAME := NIL;
@


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


1.1
log
@Initial revision
@
text
@@
