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


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

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

56.1
date     91.11.05.09.31.48;  author jwh;  state Exp;
branches ;
next     55.2;

55.2
date     91.09.26.12.19.43;  author jwh;  state Exp;
branches ;
next     55.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

38.1
date     89.08.29.11.17.14;  author jwh;  state Exp;
branches ;
next     37.5;

37.5
date     89.08.24.10.17.50;  author jwh;  state Exp;
branches ;
next     37.4;

37.4
date     89.08.12.18.05.25;  author jwh;  state Exp;
branches ;
next     37.3;

37.3
date     89.08.12.17.20.20;  author jwh;  state Exp;
branches ;
next     37.2;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1.1
date     86.06.30.13.50.46;  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 STATEMENT}

function STATEMENT (FSYS: SETOFSYS): stptr; forward;

function newstmt (scls: stmts; bkptable: boolean): stptr;
  (* allocate a 'stmt' record of given class, do standard initialization *)
  (* 'bkptable' is true if stmt requires a bkpt at its beginning *)
  var ls: stptr;
  begin
    case scls of                        {get only needed amount of space}
      becomest: new(ls,becomest);
      pcallst:  new(ls,pcallst);
      casest:   new(ls,casest);
      compndst: new(ls,compndst);
      forst:    new(ls,forst);
      gotost:   new(ls,gotost);
      ifst:     new(ls,ifst);
      repst:    new(ls,repst);
      tryst:    new(ls,tryst);
      whilest:  new(ls,whilest);
      withst:   new(ls,withst);
      emptyst:  new(ls,emptyst);
      endofbodyst: new(ls,endofbodyst);
      end;
    with ls^ do
      begin
      sclass := scls; next := nil;
      try lineno := linenumber+1
      recover lineno := 1;
      with sflags do
	begin
	rangecheck := grangecheck; iocheck := giocheck;
	shortcircuit := gshortcircuit; callmode := gcallmode;
	ovflcheck := govflcheck;
	end;
      if debugging and bkptable then bptonline := true;
      $IF FULLDUMP$
      snum := sctr; sctr := sctr+1;
      $END$
      labp := nil;
      end;
    newstmt := ls
  end (*newstmt*);

procedure stmtlist (var lhead,llast: stptr; fsys: setofsys);
  (* Parse statement list in procedure body, or
     compound, repeat, or try statements.
     lhead,llast: pointers to head, tail of list.
     fsys:  error recovery symbols *)
  var lstmt: stptr; lquit: boolean;
  begin
    lhead := nil;
    repeat
      repeat
	lstmt := statement(fsys);
	if lhead=nil then lhead:=lstmt
	else llast^.next := lstmt;
	llast := lstmt;
      until not (sy in statbegsys);
      lquit := sy <> semicolon;
      if sy = semicolon then insymbol
    until lquit;
  end (*stmtlist*);

function STATEMENT (*FSYS: SETOFSYS): stptr*);
  label 1;
  var lcp: ctp; ttop: disprange; llp: labelp; curstmt: stptr;

  procedure assignment (fcp: ctp);

    procedure reptypecheck;
      (* type check for := operation *)
      var lltype,lrtype: stp;

      begin {reptypecheck}
      with curstmt^ do
	begin
	lltype := lhs^.etyptr; lrtype := rhs^.etyptr;
	if (lltype <> nil) and (lrtype <> nil) then
	  begin
	  if cantassign in lltype^.info then error(702);
	  if comptypes(lltype,lrtype) then
	    begin
	    if (rhs^.eclass = litnode) then
	      checkconst(lltype,rhs);
	    end
	  else {incompatible types}
	    if arithtype(lltype) and arithtype(lrtype) then
		begin if not trytowiden(rhs,lltype) then error(129) end
	    else if not paofcharcomp(rhs,lltype) then
	      error(129);
	  end; (*types <> nil*)
	end;
      end; (*reptypecheck*)

    begin (*assignment*)
      curstmt := newstmt(becomest,true);
      with curstmt^ do begin
	assignableid(fsys + [becomes],fcp);
	lhs := curexp;
	if curexp^.ekind <> vrbl then error(56);
	if sy <> becomes then error(51)
	else begin
	     insymbol;
	     expression(fsys);
	     rhs := curexp;
	     reptypecheck
	     end (*sy=becomes*)
	end (*with curstmt^*)
    end (*assignment*);

  procedure proccall (fsys: setofsys; fcp: ctp);
    var lkey: spkeys; waslparent: boolean;

    procedure pcall(isvar: boolean);
      { call(procedure variable [,parameters])
	or  procedure parameter[(parameters)]  }
      var ltype: stp;
      begin curstmt^.actualp := newexplist;
      with curstmt^.actualp^ do
	begin
	if isvar then expression(fsys+[comma,rparent])
	else identproc(fsys+[lparent,semicolon]);
	expptr := curexp; ltype := curexp^.etyptr;
	if ltype <> nil then
	  if (ltype^.form <> prok) or
	     (curexp^.ekind = cnst) then
	    error(718)
	  else if (sy = comma) and isvar
	    then actparmlist(fsys,nextptr,ltype^.params)
	  else if (sy = lparent) and not isvar then
	    begin actparmlist(fsys,nextptr,ltype^.params);
	    if sy=rparent then insymbol else error(4);
	    end
	  else if ltype^.params <> nil then error(126);
	end;
      end; {pcall}

    procedure move;
      (* parse calls to moveleft,moveright, or fillchar
	     move (left|right) (source,destination,length)
	     fillchar (destination,length,char)     *)
      var lexp: elistptr;
      begin
      lexp := anyparm(fsys,lkey=spfillchar);
      curstmt^.actualp := lexp;
      if sy = comma then insymbol else error(20);
      if lkey=spfillchar then lexp^.nextptr := integerparm(fsys)
      else lexp^.nextptr := anyparm(fsys,true);
      lexp := lexp^.nextptr;
      if sy = comma then insymbol else error(20);
      if lkey=spfillchar then lexp^.nextptr := charparm(fsys)
      else lexp^.nextptr := integerparm(fsys);
      end (*move*);

    procedure unitio;  (* parse calls to unitread, unitwrite
			   (unitnumber, buffer, length[, blocknum[, async]])  *)
      var lexp: elistptr;
      begin
      lexp := integerparm(fsys); curstmt^.actualp := lexp;
      if sy = comma then insymbol else error(20);
      lexp^.nextptr := anyparm(fsys,lkey=spunitread);
      lexp := lexp^.nextptr;
      if sy = comma then insymbol else error(20);
      lexp^.nextptr := integerparm(fsys); lexp := lexp^.nextptr;
      if sy <> comma then lexp^.nextptr := makeintparm(-1)
      else begin insymbol; lexp^.nextptr := integerparm(fsys) end;
      lexp := lexp^.nextptr;
      if sy <> comma then lexp^.nextptr := makeintparm(0)
      else begin insymbol; lexp^.nextptr := integerparm(fsys) end;
      end; {unitio}

$PARTIAL_EVAL ON$
    procedure makestringlit;
      { if parameter is a paoc literal or a char
	literal turn it into a string literal. }
      var
	lmin,lmax: integer;
      begin
      with curexp^ do
	begin
	if not (paofchar(etyptr) and
	       (isPAC(etyptr^.inxtype) or etyptr^.aisstrng)) and
	       ((etyptr <> char_ptr) or (eclass <> litnode)) then
{       if not paofchar(etyptr) and
	   ((etyptr <> char_ptr) or
	   (eclass <> litnode)) then } { Replaced 8/12/89 JWH }
	  error(125)
	else if (eclass = litnode) and
		(litval.intval or (litval.valp^.cclass <> strctconst)) then
{ and (litval.intval or (litval.valp^.cclass <> strctconst)) added
  8/12/89 JWH }
	  begin
	  if etyptr = char_ptr then
	    stretchpaofchar(etyptr,litval,1)
	  else
	    stretchpaofchar(etyptr,litval,litval.valp^.slgth);
	  etyptr^.aisstrng := true;
	  etyptr^.unpacksize := etyptr^.unpacksize+1;
	  litval.valp^.cclass := strng;
	  end;
	end;
      end;
$PARTIAL_EVAL OFF$

    procedure closefile;
    {  parse calls to close(file [,option])
       option = (normal, lock, purge, crunch)  }
      begin
      curstmt^.actualp := fileparm(fsys,any);
      with curstmt^.actualp^ do
	if sy <> comma then
	  nextptr := makestrparm('NORMAL')
	else
	  begin
	  insymbol;
	  expression(fsys+[rparent]);
	  nextptr := newexplist;
	  nextptr^.expptr := curexp;
	  makestringlit;
	  end;
      end;

    procedure openfile;
     (* parse calls to append,reset,
		rewrite,open (file [, filenamestring]) *)
      begin
      if lkey = spopen then
	curstmt^.actualp := fileparm(fsys,directfile)
      else
	curstmt^.actualp := fileparm(fsys,any);
      if sy = comma then
	begin
	if (lkey in [spreset,sprewrite,spappend])
	   and stdpasc then error(606);
	insymbol;
	expression(fsys+[rparent,comma]);
	with curstmt^.actualp^ do
	  begin
	  nextptr := newexplist;
	  nextptr^.expptr := curexp;
	  end;
	makestringlit;
	if sy = comma then
	  begin
	  insymbol;
	  expression(fsys+[rparent]);
	  with curstmt^.actualp^.nextptr^ do
	    begin
	    nextptr := newexplist;
	    nextptr^.expptr := curexp;
	    end;
	  makestringlit;
	  end
	else { make null string param }
	  begin
	  with curstmt^.actualp^.nextptr^ do
	    begin
	    nextptr := newexplist;
	    nextptr^.expptr := newexpr;
	    with nextptr^.expptr^ do
	      begin
	      etyptr := strgptr;
	      ekind := cnst;
	      eclass := litnode;
	      litval.intval := false;
	      new(litval.valp);
	      with litval.valp^ do
		begin
		cclass := strng;
		slgth := 0;
		end; { with litval.valp^ }
	      end; { with nextptr^.expptr }
	    end; { with nextptr^ }
	  end; { make null string }
	end; { of second and third params }
      end;

    procedure seekit;
      begin
      curstmt^.actualp := fileparm(fsys,directfile);
      if sy <> comma then error(20);
      insymbol; curstmt^.actualp^.nextptr := integerparm(fsys);
      end;

    procedure newdispose;
      { parse calls to new and dispose }
      { new|dispose (pointer variable [,variant tags] ) }
      var lsp: stp; lsize: addrrange; lcp: ctp;
      begin
      lsp := nil; lsize := 0;
      if sy = ident then
	begin
	searchid([vars,field],lcp);
	assignableid(fsys+[comma,rparent],lcp);
	if curexp^.etyptr <> nil then
	  with curexp^.etyptr^ do
	    if form = pointer then
	      begin
	      if eltype <> nil then
		with eltype^ do
		  begin
		  lsize := unpacksize;
		  if sizeoflo then error(672);
		  if form = records then lsp := recvar;
		  end
	      end
	    else error(125);
	end
      else error(2);
      with curstmt^ do
	begin
	  new(actualp,false);
	  with actualp^ do
	    begin
	      expptr := curexp;     {first parm is pointer var}
	      getvariantsize(fsys,lsp,lsize);
	      nextptr := makeintparm(lsize); {second parm is size to allocate}
	    end
	end
      end; {newdispose}

    procedure packem;
      { analyze  pack(a,i,z) and unpack(a,i,z) }
      var a,i,z: elistptr; atype,ztype: stp;
	  amin,amax,zmin,zmax: integer;

      procedure getz(mustbevar: boolean);
	begin z := anyparm(fsys,mustbevar);
	ztype := z^.expptr^.etyptr;
	if ztype <> nil then
	  if ztype^.form <> arrays then
	     begin error(125); ztype := nil end
	  else if not ztype^.aispackd then error(696)
	  else if ztype^.aisstrng then
	    begin
	    error(125);
	    ztype := nil;
	    end;
	end;

      procedure geta(mustbevar: boolean);
	var lexp: exptr;
	begin a := anyparm(fsys,mustbevar);
	lexp := newexpr;
	with lexp^ do
	  begin eclass := subscrnode;
	  arayp := a^.expptr; a^.expptr := lexp;
	  ekind := arayp^.ekind; etyptr := nil;
	  atype := arayp^.etyptr;
	  if atype <> nil then
	    if atype^.form <> arrays then
	      begin error(125); atype := nil end
	    else etyptr := atype^.aeltype;
	  if sy = comma then insymbol else error(20);
	  expression(fsys+[comma,rparent]);
	  indxp := curexp;
	  if atype <> nil then
	    if not comptypes(atype^.inxtype,curexp^.etyptr) then
	      begin error(139); atype := nil end
	    else if indxp^.eclass = litnode then
	      if not indxp^.litval.intval then
		begin error(302); atype := nil end;
	  end;
	end; {geta}

      begin {packem}
      if lkey = sppack then geta(true) else getz(false);
      if sy = comma then insymbol else error(20);
      if lkey = spunpack then geta(false) else getz(true);
      curstmt^.actualp := a;
      a^.nextptr := z;
      if (atype <> nil) and (ztype <> nil) then
	if atype^.aeltype <> ztype^.aeltype then error(129)
	else if (atype^.inxtype <> nil) and (ztype^.inxtype <> nil) then
	  begin getbounds(atype^.inxtype,amin,amax);
	  getbounds(ztype^.inxtype,zmin,zmax);
	  with a^.expptr^.indxp^ do
	    if (eclass = litnode) and litval.intval then
	       if litval.ival < amin then
		 error(134)
	       else
		 amin := litval.ival;
	  if (amax-amin) < (zmax-zmin) then error(134);
	  end;
      end; {packem}

    procedure strsetlen;
      var destmax: integer;
      begin curstmt^.actualp := stringparm(fsys);
      destmax := 255;
      if curexp^.ekind <> vrbl then error(125)
      else if curexp^.etyptr <> nil then
	destmax := curexp^.etyptr^.maxleng;
      if sy = comma then insymbol
      else error(20);
      curstmt^.actualp^.nextptr:=integerparm(fsys);
      with curexp^ do
      if (eclass = litnode) and
	 (litval.intval) then
	if (litval.ival > destmax) or
	   (litval.ival < 0) then error(303);
      end;

    procedure pageit;
      {analyze page std proc}
      begin
      with curstmt^ do
	begin
	if waslparent then
	  actualp := fileparm(fsys,textphile)
	else
	  begin actualp := newexplist;
	  actualp^.expptr := makefileexp(outputptr);
	  end;
	end;
      end;

    procedure gotoxy;
      {analyze gotoxy std proc}
      var
	ptr: elistptr;
	lsp: stp;
      begin
      new(ptr);
      curstmt^.actualp := ptr;
      expression(fsys+[comma,rparent]);
      if curexp^.etyptr <> NIL then
	if curexp^.etyptr^.form = files then
	  begin
	  ptr^.expptr := curexp;
	  if curexp^.etyptr <> textptr then
	    error(184);
	  if sy=comma then insymbol
		      else error(20);
	  expression(fsys+[comma,rparent]);
	  end
	else { 1st parm not a file }
	  { outputptr will not be NIL }
	  ptr^.expptr := makefileexp(outputptr);
      if curexp^.etyptr <> NIL then
	begin
	new(ptr^.nextptr,false);
	ptr := ptr^.nextptr;
	ptr^.expptr := curexp;
	lsp := curexp^.etyptr;
	if lsp <> nil then
	  if lsp^.form = subrange then
	    lsp := lsp^.rangetype;
	if (lsp<>intptr) and
	     (lsp<>shortintptr) then error(125);
	if sy=comma then insymbol
		    else error(20);
	ptr^.nextptr := integerparm(fsys+[rparent]);
	end;
      end;

    procedure readwrite;
      {analyze write,writeln,read,readln,
       writedir,readdir,strwrite,strread,prompt}
      var oldvarparm,continue: boolean;
	  ptr: elistptr;
	  j,k: integer; stringmax: shortint;
	  lsp,filetype: stp;
      begin
      ptr := NIL;
      if not (lkey = spstrread) then
	begin
	new(ptr);  curstmt^.actualp := ptr;
	end;
      if not waslparent then
	begin
	if lkey=spreadln then
	  if inputptr <> nil then
	    ptr^.expptr := makefileexp(inputptr)
	  else
	    begin
	    error(185);
	    ptr^.expptr := nil;
	    end
	else if lkey in [spwriteln,spprompt,spoverprint] then
	  if outputptr <> nil then
	    ptr^.expptr := makefileexp(outputptr)
	  else
	    begin
	    error(185);
	    ptr^.expptr := nil;
	    end;
	end
      else
	begin
	varparm := (lkey = spread) or (lkey = spreadln);
	if lkey = spstrread then
	  begin
	  ptr := stringparm(fsys+[comma]);
	  curstmt^.actualp := ptr;
	  end
	else expression(fsys+[colon,comma,rparent]);
	if curexp^.etyptr<>nil then
	  if curexp^.etyptr^.form = files then
	    begin
	    ptr^.expptr := curexp;
	    if (lkey = spreaddir) or (lkey = spwritedir) then
	      begin
	      if (curexp^.etyptr = textptr)
		  or (curexp^.etyptr^.filtype = nil) then error(125);
	      if sy <> comma then error(20)
	      else
		begin insymbol;
		ptr^.nextptr := integerparm(fsys);
		ptr := ptr^.nextptr;
		varparm := lkey = spreaddir;
		end;
	      end
	    else if (lkey=spstrread)
		or (lkey=spstrwrite) then error(125)
	    else if (curexp^.etyptr<>textptr) and
		    (lkey in [spwriteln,spreadln,
			spoverprint,spprompt])
	      then error(184)
	    else if curexp^.etyptr^.filtype = nil then error(125);
	    continue := sy=comma;
	    if continue then
	      begin insymbol; expression(fsys+[colon,comma,rparent]) end
	    else if not (lkey in [spreadln,
		 spwriteln,spprompt,spoverprint])
	      then error(20);
	    end
	  else {1st param not a file}
	    begin continue := true;
	    if (lkey=spread) or (lkey=spreadln) then
	      if inputptr <> nil then
		ptr^.expptr := makefileexp(inputptr)
	      else
		begin
		error(185);
		ptr^.expptr := nil;
		end
	    else if (lkey=spreaddir) or (lkey=spwritedir) then
	      begin
	      error(125);
	      ptr^.expptr := nil;
	      end
	    else if (lkey=spstrread) or (lkey=spstrwrite) then
	      begin ptr^.expptr := curexp;
	      if not strgtype(curexp^.etyptr) then
		begin
		error(125);
		stringmax := 255;
		end
	      else
		with curexp^ do
		  begin
		  if (lkey=spstrwrite) and
		     (ekind<>vrbl) then
		    error(103);
		  if strgtype(etyptr) then
		    stringmax := etyptr^.maxleng
		  else
		    begin
		    getbounds(etyptr^.inxtype,j,k);
		    stringmax := k;
		    end;
		  end;
	      for k := 1 to 2 do
		begin
		if sy=comma then insymbol
		else error(20);
		ptr^.nextptr := integerparm(fsys);
		ptr := ptr^.nextptr;
		with ptr^.expptr^ do
		  if k = 1 then
		    begin
		    if (eclass=litnode) and
			litval.intval then
		      if (litval.ival <= 0) or
			 (litval.ival > stringmax) then
			error(302);
		    end
		  else
		    begin
		    if (etyptr <> nil) and
		       (etyptr <> intptr) then error(125);
		    if ekind <> vrbl then error(103);
		    end;
		end;
	      varparm := lkey = spstrread;
	      continue := sy=comma;
	      if continue then
		begin insymbol;
		expression(fsys+[colon,comma,rparent]);
		end
	      else error(20);
	      end
	    else
	      if outputptr <> nil then
		ptr^.expptr := makefileexp(outputptr)
	      else
		begin error(185); ptr^.expptr := nil;
		end;
	    end
	else
	  begin error(185); ptr^.expptr := nil end;
	if (lkey=spstrread) or (lkey=spstrwrite) then
	  filetype := textptr
	else if curstmt^.actualp^.expptr <> nil then
	  filetype := curstmt^.actualp^.expptr^.etyptr
	else filetype := nil;
	while continue do
	  begin
	  new(ptr^.nextptr,false); ptr := ptr^.nextptr;
	  ptr^.expptr:=curexp;
	  if filetype <> nil then
	    with curexp^ do
	      if filetype <> textptr then
		if comptypes(etyptr,filetype^.filtype) then
		  begin
		  if eclass=litnode then
		    checkconst(filetype^.filtype,curexp);
		  end
		else if (lkey=spwrite) or
			(lkey=spwritedir) then
		  begin
    { Following enhancement made 8/12/89 JWH }
		  { if not trytowiden(curexp,filetype^.filtype) then
		    if not paofcharcomp(curexp,filetype^.filtype)
		      then error(134); }
		   if not trytowiden(curexp,filetype^.filtype) then
		    begin
		     if not paofcharcomp(curexp,filetype^.filtype)
		      then error(134);
		    end
		   else
		     ptr^.expptr := curexp;
		  end
		else error(134)
	      else
		begin
		lsp := etyptr;
		if lsp <> nil then
		  if lsp^.form = subrange then
		    lsp := lsp^.rangetype;
		if (lsp<>intptr) and
		   (lsp<>shortintptr) and
		   (lsp<>char_ptr) and
		   (lsp<>boolptr) and
		   (lsp<>realptr) and
		   not enumtype(lsp) and
		   not paofchar(lsp) then error(125);
		if paofchar(lsp) then
		  if lsp^.unpacksize > 32767 then
		    error(685);
		if stdpasc then
		  if paofchar(lsp) and
		     (lkey in [spread,spreadln,spstrread]) then
		    error(606);
		end;
	  if (lkey=spread) or (lkey=spreadln)
	      or (lkey=spreaddir) or (lkey=spstrread) then
	    begin
	    if curexp^.ekind<>vrbl then error(125)
	    else { Check for FOR loop varible }
	      if curexp^.eclass = idnode then
		if cantassign in curexp^.symptr^.info then error(702);
	    end
	  else if filetype = textptr then
	    begin
	    oldvarparm := varparm;
	    varparm := false;
	    for k := 1 to 1+ord(curexp^.etyptr = realptr) do
	      begin
	      if sy = colon then
		begin insymbol;
		with ptr^ do
		  begin
		  nextptr := integerparm(fsys+[colon]);
		  with nextptr^.expptr^ do
		    if (eclass = litnode) and litval.intval then
		      if (litval.ival < 0) or
			 (litval.ival > 255) then
			error(686);
		  end;
		end
	      else ptr^.nextptr := newexplist;
	      ptr := ptr^.nextptr;
	      end;
	    varparm := oldvarparm;
	    end;
	  continue := sy=comma;
	  if continue then
	    begin insymbol; expression(fsys+[colon,comma,rparent]); end
	  end; {while continue};
	varparm := false;
	end; {if waslparent}
      if ptr <> NIL then
	ptr^.nextptr := nil;
      end {readwrite};

    procedure movestr;

      procedure checkpaoc(issource: boolean);
	var lmin,lmax: integer;
	begin
	with curexp^ do
	  begin
	  if not paofchar(etyptr) then
	    if issource and (etyptr=char_ptr)
		and (eclass=litnode) then
	      stretchpaofchar(etyptr,litval,1)
	    else error(125)
	  else if not etyptr^.aisstrng then
	    begin
	    getbounds(etyptr^.inxtype,lmin,lmax);
	    if lmin <> 1 then error(125);
	    end;
	  if not issource and (ekind<>vrbl) then
	    error(125);
	  end;
	end; {checkpaoc}

      begin {movestr}
      curstmt := newstmt(becomest,true);
      with curstmt^ do
	begin rhs := newexpr;
	with rhs^ do
	  begin
	  etyptr := strgptr;
	  eclass := substrnode;
	  expression(fsys+[comma]);
	  lengthp := curexp;
	  checkint;
	  if sy=comma then insymbol else error(20);
	  expression(fsys+[comma]);
	  arayp := curexp;
	  checkpaoc(true);
	  if sy=comma then insymbol else error(20);
	  expression(fsys+[comma]);
	  indxp := curexp;
	  checkint;
	  if sy=comma then insymbol else error(20);
	  end;
	lhs := newexpr;
	with lhs^ do
	  begin
	  etyptr := strgptr;
	  lengthp := nil;
	  eclass := substrnode;
	  expression(fsys+[comma]);
	  arayp := curexp;
	  checkpaoc(false);
	  if sy=comma then insymbol else error(20);
	  expression(fsys+[rparent]);
	  indxp := curexp;
	  checkint;
	  end;
	end;
      end; {movestr}

    begin (*proccall*)
    curstmt := newstmt(pcallst,true);
    with curstmt^ do
      begin psymptr := fcp; actualp := nil end;
    if fcp^.klass = routineparm then pcall(false)
    else {klass = prox}
      begin
      if fcp^.pfdeckind = special then
	begin
	lkey := fcp^.spkey;
	insymbol;
	if sy = lparent then begin insymbol; waslparent := true end
	else
	  begin waslparent := false;
	  if not (lkey in [spreadln,spwriteln,
	     sphalt,spprompt,sppage,spoverprint])
	    then error(9);
	  end;
	case lkey of
	  spsetstrlen: strsetlen;
	  spstrmove: movestr;
	  spcall: pcall(true);
	  spmoveleft,spmoveright,spfillchar: move;
	  spnew,spdispose: newdispose;
	  sppage: pageit;
	  spgotoxy: gotoxy;
	  spoverprint,spwrite,spwriteln,
	  spread,spreadln,spreaddir,spwritedir,
	  spprompt,spstrread,spstrwrite:
	    readwrite;
	  spunitread,spunitwrite: unitio;
	  spclose: closefile;
	  spreset,sprewrite,spopen,spappend:
	    openfile;
	  spseek: seekit;
	  sppack,spunpack: packem;
	  sphalt:
	    if waslparent then
	      begin
	      curstmt^.actualp := integerparm(fsys);
	      with curstmt^.actualp^.expptr^ do
		if (eclass = litnode) and
		   (litval.intval) then
		  if (litval.ival < -32768) or
		     (litval.ival > 32767) then
		    error(125);
	      end;
	  otherwise error(651)
	  end;
	if waslparent then if sy = rparent then insymbol else error(4)
	end
      else (* standard or declared proc *)
	begin
	insymbol;
	with curstmt^.psymptr^ do
	  if pfdeckind = declared then
	    if ismodulebody then
	      error(704)
	    else { trying to call main prog ? }
	      if curstmt^.psymptr = outerblock then
		error(103);
	if sy=lparent then
	  begin actparmlist(fsys,curstmt^.actualp,fcp^.next);
	  if sy = rparent then insymbol else error(4)
	  end
	else if fcp^.next <> nil then error(126);
	end;
      end;
    end (*proccall*);

  PROCEDURE GOTOSTATEMENT;
    VAR LLP: LABELP; FOUND: BOOLEAN; TTOP: DISPRANGE;
  BEGIN
  curstmt := newstmt(gotost,true);
  insymbol;
  with curstmt^ do
    begin target := nil;
    IF SY <> INTCONST THEN ERROR(15)
    else
      BEGIN
      FOUND := FALSE; TTOP := TOP;
      WHILE DISPLAY[TTOP].OCCUR in [RECORDscope,WITHscope] DO
	TTOP := TTOP - 1;
      LLP := DISPLAY[TTOP].FLABEL;
      WHILE (LLP <> nil) AND NOT FOUND DO
	WITH LLP^ DO
	  IF LABVAL = VAL.IVAL THEN
	    BEGIN
	    FOUND := TRUE; isrefed := true;
	    target := llp;
	    END
	  ELSE LLP := NEXTLAB;
      if not found and (ttop > 0) then
	repeat
	  repeat ttop := ttop - 1;
	  until not (display[ttop].occur in [RECORDscope,WITHscope]);
	  llp := display[ttop].flabel;
	  if not (display[ttop].occur=modulescope) then
	    while (llp <> nil) and not found do
	      with llp^ do
		if labval = val.ival then
		  begin
		  nonlocalref := true;
		  found := true; target := llp;
		  end
		else llp := nextlab;
	until found or (ttop = 0) or
	      (display[ttop].occur = modulescope);
      IF NOT FOUND THEN error(167);
      INSYMBOL
      END;
    end;
  END (*GOTOSTATEMENT*) ;

  procedure compoundstatement;
    var dummy: stptr;
    begin
      curstmt := newstmt(compndst,false);
      insymbol;
      stmtlist(curstmt^.cbody,dummy,fsys + [semicolon,endsy]);
      if sy = endsy then insymbol else error(13);
    end (*compoundstatement*) ;

  procedure ifstatement;
    begin
      curstmt := newstmt(ifst,true);
      insymbol;
      with curstmt^ do begin
	expression(fsys+[thensy]);
	ifcond := curexp;
	with curexp^ do
	  if (etyptr <> nil) and (etyptr <> boolptr) then error(135);
	if sy = thensy then insymbol else error(52);
	tru := statement(fsys+[elsesy]);
	if sy = elsesy then
	  begin insymbol; fals := statement(fsys) end
	else fals := nil
	end
    end (*ifstatement*) ;

  procedure casestatement;
    var lstp,lstp1,lstp2: stp;
	lcurrlab,ltemp: clabptr;
	ldonelabs, ldonecase: boolean;
	lcurrstmt,lastmt,dummy: stptr;
	lvalu: valu;

    procedure insortcaselabel (flabp: clabptr);
      (* insert case label into case label list ordered by ascending
	 lowval.
	 flabp           - pointer to label to be inserted
	 curstmt^.minlab - pointer to first entry in list, or nil if
			     list is empty
	 curstmt^.maxlab - pointer to last entry, or nil *)
      label 1;
      var lcurr,lprev: clabptr;
	  lval: integer;
      begin
      with curstmt^ do
	if minlab=nil then    {first label}
	  begin minlab := flabp; maxlab := flabp; flabp^.clabp := nil end
	else                  {sort it in}
	  begin
	  lval := flabp^.lowval;
	  lprev := nil;
	  lcurr := minlab;
	  while lcurr <> nil do
	    if lcurr^.lowval < lval then
	      begin lprev := lcurr; lcurr := lcurr^.clabp end
	    else goto 1;
       1: if lprev = nil then minlab := flabp
	  else begin
	       lprev^.clabp := flabp;
	       if lprev^.hival >= lval then error(156);
	       end;
	  flabp^.clabp := lcurr;
	  if lcurr = nil then maxlab := flabp
	  else if lcurr^.lowval <= flabp^.hival then error(156);
	  end;
      end (*insortcaselabel*);

    begin (*casestatement*)
      curstmt := newstmt(casest,true);
      insymbol;
      with curstmt^ do
	begin
	expression(fsys+[ofsy,comma,colon,rangesy]);
	selecter := curexp;
	lstp := selecter^.etyptr;
	if lstp <> nil then
	  if lstp^.form > subrange then error(144);
	if sy = ofsy then insymbol
	else begin error(8); skip(fsys+[rangesy,comma,colon]) end;
	maxlab := nil; minlab := nil;
	nrlabs := 0; nrstmts := 0;
	firstmt := nil; otherwyse := nil;
	repeat    (* for each case list element *)
	  ltemp := nil;  (* pts to unordered list of labels of current case,
			    linked by 'temptr' fields *)
	  if not (sy in [semicolon,othrwisesy,endsy]) then
	    begin
	    inbody := false; { used to detect non standard use }
	    repeat     (* for each case label *)
	      new(lcurrlab);
	      with lcurrlab^ do
		begin
		constant(fsys+[rangesy,comma,colon],lstp1,lvalu);
		if not comptypes(lstp,lstp1) then error(147);
		lowval := lvalu.ival;
		if sy=rangesy then
		  begin  (* label is subrange *)
		  insymbol;
		  if stdpasc then error(606);
		  constant(fsys+[comma,colon],lstp2,lvalu);
		  if not comptypes(lstp1,lstp2) then error(107);
		  hival := lvalu.ival;
		  if lowval > hival then
		    begin error(102); hival := lowval end;
		  end
		else
		  begin  (* label not a subrange *)
		  hival := lowval;
		  end;
		temptr := ltemp; ltemp := lcurrlab
		end (*with lcurrlab^*);
	      insortcaselabel(lcurrlab);
	      nrlabs := nrlabs+1;
	      ldonelabs := sy <> comma;
	      if sy = comma then insymbol
	    until ldonelabs;
	    inbody := true;
	    if sy = colon then insymbol else error(5);
	    lcurrstmt := statement(fsys+[semicolon,endsy,othrwisesy]);
	    nrstmts := nrstmts+1;
	    (* link statement into statement list *)
	    if firstmt = nil then firstmt := lcurrstmt
	    else lastmt^.next := lcurrstmt;
	    lastmt := lcurrstmt;
	    (* make all current lbls point to current statement *)
	    while ltemp <> nil do
	      with ltemp^ do
	       begin cstmt := lcurrstmt; ltemp := temptr end;
	    end (* if not (sy in [semicolon,othrwisesy,endsy]) *);
	  ldonecase := sy <> semicolon;
	  if sy = semicolon then insymbol
	until ldonecase;
	if sy = othrwisesy then
	  begin
	  if stdpasc then error(606);
	  insymbol;
	  stmtlist(otherwyse,dummy,fsys);
	  end;
	if sy = endsy then insymbol else error(13);
	if nrlabs = 0 then error(665);
	end (* with curstmt^ *)
    end (*casestatement*);

  procedure repeatstatement;
    var dummy: stptr;
    begin
    curstmt := newstmt(repst,false);
    insymbol;
    with curstmt^ do
      begin
      stmtlist(rbody,dummy,fsys+[semicolon,untilsy]);
      if sy = untilsy then
	begin
	lineno := linenumber+1;         {save line # of UNTIL symbol}
	if debugging then bptonline:=true;
	insymbol;
	expression(fsys);
	rcond := curexp;
	with curexp^ do
	  if (etyptr <> nil) and (etyptr <> boolptr) then error(135)
	end
      else error(53)
      end
    end (*repeatstatement*);

  procedure whilestatement;
    begin
    curstmt := newstmt(whilest,true);
    insymbol;
    with curstmt^ do
      begin
      expression(fsys+[dosy]);
      rcond := curexp;
      with curexp^ do
	if (etyptr <> nil) and (etyptr <> boolptr) then error(135);
      if sy = dosy then insymbol else error(54);
      rbody := statement(fsys)
      end
    end (*whilestatement*);

  procedure forstatement;
    var lcp: ctp;
    begin curstmt := newstmt(forst,true);
    insymbol;
    with curstmt^ do
      begin
      if sy <> ident then
	begin error(2);
	      skip(fsys+[becomes,tosy,downtosy,dosy]);
	      lcp := NIL;
	end
      else
	begin searchid([vars],lcp);
	ctrl := newexpr;
	with lcp^,ctrl^ do
	  begin eclass := idnode; etyptr := idtype;
	  ekind := vrbl; symptr := lcp;
	  if (vtype <> localvar) or
	     (vlev <> level) then error(657);
	  if etyptr <> nil then
	    begin
	    if etyptr^.form > subrange then error(143)
	    else if cantassign in info then
	      error(702)
	    else
	      info := info + [cantassign];
	    end;
	  end;
	insymbol;
	end (*sy=ident*);
      if sy <> becomes then
	begin error(51); skip(fsys+[tosy,downtosy,dosy]) end
      else
	begin insymbol; expression(fsys+[tosy,downtosy,dosy]);
	init := curexp;
	if not comptypes(init^.etyptr,ctrl^.etyptr) then
	  error(145)
	else if init^.eclass = litnode then
	  checkconst(ctrl^.etyptr,init);
	end;
      if not(sy in [tosy,downtosy]) then
	begin error(55); skip(fsys+[dosy]) end
      else
	begin if sy = tosy then incr := 1 else incr := -1;
	insymbol; expression(fsys+[dosy]); limit := curexp;
	if not comptypes(limit^.etyptr,ctrl^.etyptr) then
	  error(145)
	else if (limit^.eclass = litnode) then
	  checkconst(ctrl^.etyptr,limit);
	end;
      if sy = dosy then insymbol else error(54);
      fbody := statement(fsys);
      end; (*with curstmt^*)
    if lcp <> NIL then
      lcp^.info := lcp^.info - [cantassign];
    end; (*forstatement*)

  procedure withstatement;
    var oldtop: disprange; lquit: boolean;
	lstmt: stptr; lrectype: stp;
	lcp: ctp;
    begin curstmt := newstmt(withst,true);
    insymbol; oldtop := top;
    lstmt := curstmt;
    repeat
      if sy <> ident then begin error(2); skip(fsys+[comma,dosy]) end
      else
	begin
	searchid([types,vars,field,konst,func,routineparm],lcp);
	identproc(fsys+[comma,dosy]);
	lrectype := curexp^.etyptr;
	if lrectype <> nil then
	  if lrectype^.form <> records then error(140)
	  else if top >= displimit then error(662)
	  else
	    begin     {open scope containing field names}
	    top := top+1;
	    with display[top] do begin
	      fname := lrectype^.fstfld;
	      occur := WITHscope;
	      wnodeptr := lstmt;
	      end;
	    lstmt^.refexpr := curexp;
	    end;      {open scope}
	end;  (* sy=ident *)
      lquit := sy <> comma;
      if not lquit then begin
	insymbol;
	lstmt^.wbody := newstmt(withst,false);
	lstmt := lstmt^.wbody;
	end;
    until lquit;
    if sy = dosy then insymbol else error(54);
    lstmt^.wbody := statement(fsys);
    top := oldtop;
    end (*withstatement*);

  procedure trystatement;
    var dummy: stptr;
    begin
    curstmt := newstmt(tryst,true);
    insymbol;
    with curstmt^ do
     begin
      parsing_try_level := parsing_try_level + 1; { JWH 9/26/91 }
      stmtlist(tbody,dummy,fsys+[semicolon,recoversy]);
      parsing_try_level := parsing_try_level - 1; { JWH 9/26/91 }
      if sy = recoversy then begin
	insymbol;
	recov := statement(fsys)
	end
      else error(712);  (* 'recover' expected *)
   end; { with }
 end; (*trystatement*)

  BEGIN (*STATEMENT*)
  LLP := nil;           {mark no label for this stmt}
  IF SY = INTCONST THEN (*LABEL*)
    BEGIN
    if val.ival > 9999 then error(163);
    TTOP := TOP;
    WHILE DISPLAY[TTOP].OCCUR in [RECORDscope,WITHscope] DO
      TTOP := TTOP-1;
    LLP := DISPLAY[TTOP].FLABEL;
    WHILE LLP <> NIL DO
      WITH LLP^ DO
	IF LABVAL = VAL.IVAL THEN
	  BEGIN
	  IF DEFINED THEN begin ERROR(165); LLP := nil end
	  ELSE
	    begin
	    DEFINED := TRUE;
	    if (linelevel <> 0) and nonlocalref then error(164);
	    try_level := parsing_try_level; { JWH 9/26/91 }
	    end;
	  GOTO 1
	  END
	ELSE LLP := NEXTLAB;
    ERROR(167);    (* undeclared label *)
  1:INSYMBOL;
    IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
    END; (*label*)
  IF NOT (SY IN FSYS + [IDENT]) THEN
    BEGIN ERROR(6); SKIP(FSYS) END;
  if sy=period then {kluge} insymbol;
  IF SY IN STATBEGSYS + [IDENT] THEN
    BEGIN
      CASE SY OF
	IDENT:    BEGIN SEARCHID([types,VARS,FIELD,FUNC,PROX,routineparm],LCP);
		  with lcp^ do
		    IF (KLASS = prox)
			or (klass = routineparm) and (vtype = procparm)
		      THEN proccall(FSYS,LCP)
		      ELSE ASSIGNMENT(lcp);
		  END;
	BEGINSY:  COMPOUNDSTATEMENT;
	CASESY:   begin
		  linelevel := linelevel + 1;
		  CASESTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	FORSY:    begin
		  linelevel := linelevel + 1;
		  FORSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	GOTOSY:   GOTOSTATEMENT;
	IFSY:     begin
		  linelevel := linelevel + 1;
		  IFSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	REPEATSY: begin
		  linelevel := linelevel + 1;
		  REPEATSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	trysy:    begin
		  linelevel := linelevel + 1;
		  trystatement;
		  linelevel := linelevel - 1;
		  end;
	WHILESY:  begin
		  linelevel := linelevel + 1;
		  WHILESTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	WITHSY:   begin
		  linelevel := linelevel + 1;
		  WITHSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	END; {case}
      IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY,recoversy,othrwisesy])
	THEN BEGIN ERROR(6); SKIP(FSYS) END
    END
  else curstmt := newstmt(emptyst,false);
  curstmt^.labp := LLP;         {mark it with saved label}
  statement := curstmt
  END (*STATEMENT*);

@


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


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

function STATEMENT (FSYS: SETOFSYS): stptr; forward;

function newstmt (scls: stmts; bkptable: boolean): stptr;
  (* allocate a 'stmt' record of given class, do standard initialization *)
  (* 'bkptable' is true if stmt requires a bkpt at its beginning *)
  var ls: stptr;
  begin
    case scls of                        {get only needed amount of space}
      becomest: new(ls,becomest);
      pcallst:  new(ls,pcallst);
      casest:   new(ls,casest);
      compndst: new(ls,compndst);
      forst:    new(ls,forst);
      gotost:   new(ls,gotost);
      ifst:     new(ls,ifst);
      repst:    new(ls,repst);
      tryst:    new(ls,tryst);
      whilest:  new(ls,whilest);
      withst:   new(ls,withst);
      emptyst:  new(ls,emptyst);
      endofbodyst: new(ls,endofbodyst);
      end;
    with ls^ do
      begin
      sclass := scls; next := nil;
      try lineno := linenumber+1
      recover lineno := 1;
      with sflags do
	begin
	rangecheck := grangecheck; iocheck := giocheck;
	shortcircuit := gshortcircuit; callmode := gcallmode;
	ovflcheck := govflcheck;
	end;
      if debugging and bkptable then bptonline := true;
      $IF FULLDUMP$
      snum := sctr; sctr := sctr+1;
      $END$
      labp := nil;
      end;
    newstmt := ls
  end (*newstmt*);

procedure stmtlist (var lhead,llast: stptr; fsys: setofsys);
  (* Parse statement list in procedure body, or
     compound, repeat, or try statements.
     lhead,llast: pointers to head, tail of list.
     fsys:  error recovery symbols *)
  var lstmt: stptr; lquit: boolean;
  begin
    lhead := nil;
    repeat
      repeat
	lstmt := statement(fsys);
	if lhead=nil then lhead:=lstmt
	else llast^.next := lstmt;
	llast := lstmt;
      until not (sy in statbegsys);
      lquit := sy <> semicolon;
      if sy = semicolon then insymbol
    until lquit;
  end (*stmtlist*);

function STATEMENT (*FSYS: SETOFSYS): stptr*);
  label 1;
  var lcp: ctp; ttop: disprange; llp: labelp; curstmt: stptr;

  procedure assignment (fcp: ctp);

    procedure reptypecheck;
      (* type check for := operation *)
      var lltype,lrtype: stp;

      begin {reptypecheck}
      with curstmt^ do
	begin
	lltype := lhs^.etyptr; lrtype := rhs^.etyptr;
	if (lltype <> nil) and (lrtype <> nil) then
	  begin
	  if cantassign in lltype^.info then error(702);
	  if comptypes(lltype,lrtype) then
	    begin
	    if (rhs^.eclass = litnode) then
	      checkconst(lltype,rhs);
	    end
	  else {incompatible types}
	    if arithtype(lltype) and arithtype(lrtype) then
		begin if not trytowiden(rhs,lltype) then error(129) end
	    else if not paofcharcomp(rhs,lltype) then
	      error(129);
	  end; (*types <> nil*)
	end;
      end; (*reptypecheck*)

    begin (*assignment*)
      curstmt := newstmt(becomest,true);
      with curstmt^ do begin
	assignableid(fsys + [becomes],fcp);
	lhs := curexp;
	if curexp^.ekind <> vrbl then error(56);
	if sy <> becomes then error(51)
	else begin
	     insymbol;
	     expression(fsys);
	     rhs := curexp;
	     reptypecheck
	     end (*sy=becomes*)
	end (*with curstmt^*)
    end (*assignment*);

  procedure proccall (fsys: setofsys; fcp: ctp);
    var lkey: spkeys; waslparent: boolean;

    procedure pcall(isvar: boolean);
      { call(procedure variable [,parameters])
	or  procedure parameter[(parameters)]  }
      var ltype: stp;
      begin curstmt^.actualp := newexplist;
      with curstmt^.actualp^ do
	begin
	if isvar then expression(fsys+[comma,rparent])
	else identproc(fsys+[lparent,semicolon]);
	expptr := curexp; ltype := curexp^.etyptr;
	if ltype <> nil then
	  if (ltype^.form <> prok) or
	     (curexp^.ekind = cnst) then
	    error(718)
	  else if (sy = comma) and isvar
	    then actparmlist(fsys,nextptr,ltype^.params)
	  else if (sy = lparent) and not isvar then
	    begin actparmlist(fsys,nextptr,ltype^.params);
	    if sy=rparent then insymbol else error(4);
	    end
	  else if ltype^.params <> nil then error(126);
	end;
      end; {pcall}

    procedure move;
      (* parse calls to moveleft,moveright, or fillchar
	     move (left|right) (source,destination,length)
	     fillchar (destination,length,char)     *)
      var lexp: elistptr;
      begin
      lexp := anyparm(fsys,lkey=spfillchar);
      curstmt^.actualp := lexp;
      if sy = comma then insymbol else error(20);
      if lkey=spfillchar then lexp^.nextptr := integerparm(fsys)
      else lexp^.nextptr := anyparm(fsys,true);
      lexp := lexp^.nextptr;
      if sy = comma then insymbol else error(20);
      if lkey=spfillchar then lexp^.nextptr := charparm(fsys)
      else lexp^.nextptr := integerparm(fsys);
      end (*move*);

    procedure unitio;  (* parse calls to unitread, unitwrite
			   (unitnumber, buffer, length[, blocknum[, async]])  *)
      var lexp: elistptr;
      begin
      lexp := integerparm(fsys); curstmt^.actualp := lexp;
      if sy = comma then insymbol else error(20);
      lexp^.nextptr := anyparm(fsys,lkey=spunitread);
      lexp := lexp^.nextptr;
      if sy = comma then insymbol else error(20);
      lexp^.nextptr := integerparm(fsys); lexp := lexp^.nextptr;
      if sy <> comma then lexp^.nextptr := makeintparm(-1)
      else begin insymbol; lexp^.nextptr := integerparm(fsys) end;
      lexp := lexp^.nextptr;
      if sy <> comma then lexp^.nextptr := makeintparm(0)
      else begin insymbol; lexp^.nextptr := integerparm(fsys) end;
      end; {unitio}

$PARTIAL_EVAL ON$
    procedure makestringlit;
      { if parameter is a paoc literal or a char
	literal turn it into a string literal. }
      var
	lmin,lmax: integer;
      begin
      with curexp^ do
	begin
	if not (paofchar(etyptr) and
	       (isPAC(etyptr^.inxtype) or etyptr^.aisstrng)) and
	       ((etyptr <> char_ptr) or (eclass <> litnode)) then
{       if not paofchar(etyptr) and
	   ((etyptr <> char_ptr) or
	   (eclass <> litnode)) then } { Replaced 8/12/89 JWH }
	  error(125)
	else if (eclass = litnode) and
		(litval.intval or (litval.valp^.cclass <> strctconst)) then
{ and (litval.intval or (litval.valp^.cclass <> strctconst)) added
  8/12/89 JWH }
	  begin
	  if etyptr = char_ptr then
	    stretchpaofchar(etyptr,litval,1)
	  else
	    stretchpaofchar(etyptr,litval,litval.valp^.slgth);
	  etyptr^.aisstrng := true;
	  etyptr^.unpacksize := etyptr^.unpacksize+1;
	  litval.valp^.cclass := strng;
	  end;
	end;
      end;
$PARTIAL_EVAL OFF$

    procedure closefile;
    {  parse calls to close(file [,option])
       option = (normal, lock, purge, crunch)  }
      begin
      curstmt^.actualp := fileparm(fsys,any);
      with curstmt^.actualp^ do
	if sy <> comma then
	  nextptr := makestrparm('NORMAL')
	else
	  begin
	  insymbol;
	  expression(fsys+[rparent]);
	  nextptr := newexplist;
	  nextptr^.expptr := curexp;
	  makestringlit;
	  end;
      end;

    procedure openfile;
     (* parse calls to append,reset,
		rewrite,open (file [, filenamestring]) *)
      begin
      if lkey = spopen then
	curstmt^.actualp := fileparm(fsys,directfile)
      else
	curstmt^.actualp := fileparm(fsys,any);
      if sy = comma then
	begin
	if (lkey in [spreset,sprewrite,spappend])
	   and stdpasc then error(606);
	insymbol;
	expression(fsys+[rparent,comma]);
	with curstmt^.actualp^ do
	  begin
	  nextptr := newexplist;
	  nextptr^.expptr := curexp;
	  end;
	makestringlit;
	if sy = comma then
	  begin
	  insymbol;
	  expression(fsys+[rparent]);
	  with curstmt^.actualp^.nextptr^ do
	    begin
	    nextptr := newexplist;
	    nextptr^.expptr := curexp;
	    end;
	  makestringlit;
	  end
	else { make null string param }
	  begin
	  with curstmt^.actualp^.nextptr^ do
	    begin
	    nextptr := newexplist;
	    nextptr^.expptr := newexpr;
	    with nextptr^.expptr^ do
	      begin
	      etyptr := strgptr;
	      ekind := cnst;
	      eclass := litnode;
	      litval.intval := false;
	      new(litval.valp);
	      with litval.valp^ do
		begin
		cclass := strng;
		slgth := 0;
		end; { with litval.valp^ }
	      end; { with nextptr^.expptr }
	    end; { with nextptr^ }
	  end; { make null string }
	end; { of second and third params }
      end;

    procedure seekit;
      begin
      curstmt^.actualp := fileparm(fsys,directfile);
      if sy <> comma then error(20);
      insymbol; curstmt^.actualp^.nextptr := integerparm(fsys);
      end;

    procedure newdispose;
      { parse calls to new and dispose }
      { new|dispose (pointer variable [,variant tags] ) }
      var lsp: stp; lsize: addrrange; lcp: ctp;
      begin
      lsp := nil; lsize := 0;
      if sy = ident then
	begin
	searchid([vars,field],lcp);
	assignableid(fsys+[comma,rparent],lcp);
	if curexp^.etyptr <> nil then
	  with curexp^.etyptr^ do
	    if form = pointer then
	      begin
	      if eltype <> nil then
		with eltype^ do
		  begin
		  lsize := unpacksize;
		  if sizeoflo then error(672);
		  if form = records then lsp := recvar;
		  end
	      end
	    else error(125);
	end
      else error(2);
      with curstmt^ do
	begin
	  new(actualp,false);
	  with actualp^ do
	    begin
	      expptr := curexp;     {first parm is pointer var}
	      getvariantsize(fsys,lsp,lsize);
	      nextptr := makeintparm(lsize); {second parm is size to allocate}
	    end
	end
      end; {newdispose}

    procedure packem;
      { analyze  pack(a,i,z) and unpack(a,i,z) }
      var a,i,z: elistptr; atype,ztype: stp;
	  amin,amax,zmin,zmax: integer;

      procedure getz(mustbevar: boolean);
	begin z := anyparm(fsys,mustbevar);
	ztype := z^.expptr^.etyptr;
	if ztype <> nil then
	  if ztype^.form <> arrays then
	     begin error(125); ztype := nil end
	  else if not ztype^.aispackd then error(696)
	  else if ztype^.aisstrng then
	    begin
	    error(125);
	    ztype := nil;
	    end;
	end;

      procedure geta(mustbevar: boolean);
	var lexp: exptr;
	begin a := anyparm(fsys,mustbevar);
	lexp := newexpr;
	with lexp^ do
	  begin eclass := subscrnode;
	  arayp := a^.expptr; a^.expptr := lexp;
	  ekind := arayp^.ekind; etyptr := nil;
	  atype := arayp^.etyptr;
	  if atype <> nil then
	    if atype^.form <> arrays then
	      begin error(125); atype := nil end
	    else etyptr := atype^.aeltype;
	  if sy = comma then insymbol else error(20);
	  expression(fsys+[comma,rparent]);
	  indxp := curexp;
	  if atype <> nil then
	    if not comptypes(atype^.inxtype,curexp^.etyptr) then
	      begin error(139); atype := nil end
	    else if indxp^.eclass = litnode then
	      if not indxp^.litval.intval then
		begin error(302); atype := nil end;
	  end;
	end; {geta}

      begin {packem}
      if lkey = sppack then geta(true) else getz(false);
      if sy = comma then insymbol else error(20);
      if lkey = spunpack then geta(false) else getz(true);
      curstmt^.actualp := a;
      a^.nextptr := z;
      if (atype <> nil) and (ztype <> nil) then
	if atype^.aeltype <> ztype^.aeltype then error(129)
	else if (atype^.inxtype <> nil) and (ztype^.inxtype <> nil) then
	  begin getbounds(atype^.inxtype,amin,amax);
	  getbounds(ztype^.inxtype,zmin,zmax);
	  with a^.expptr^.indxp^ do
	    if (eclass = litnode) and litval.intval then
	       if litval.ival < amin then
		 error(134)
	       else
		 amin := litval.ival;
	  if (amax-amin) < (zmax-zmin) then error(134);
	  end;
      end; {packem}

    procedure strsetlen;
      var destmax: integer;
      begin curstmt^.actualp := stringparm(fsys);
      destmax := 255;
      if curexp^.ekind <> vrbl then error(125)
      else if curexp^.etyptr <> nil then
	destmax := curexp^.etyptr^.maxleng;
      if sy = comma then insymbol
      else error(20);
      curstmt^.actualp^.nextptr:=integerparm(fsys);
      with curexp^ do
      if (eclass = litnode) and
	 (litval.intval) then
	if (litval.ival > destmax) or
	   (litval.ival < 0) then error(303);
      end;

    procedure pageit;
      {analyze page std proc}
      begin
      with curstmt^ do
	begin
	if waslparent then
	  actualp := fileparm(fsys,textphile)
	else
	  begin actualp := newexplist;
	  actualp^.expptr := makefileexp(outputptr);
	  end;
	end;
      end;

    procedure gotoxy;
      {analyze gotoxy std proc}
      var
	ptr: elistptr;
	lsp: stp;
      begin
      new(ptr);
      curstmt^.actualp := ptr;
      expression(fsys+[comma,rparent]);
      if curexp^.etyptr <> NIL then
	if curexp^.etyptr^.form = files then
	  begin
	  ptr^.expptr := curexp;
	  if curexp^.etyptr <> textptr then
	    error(184);
	  if sy=comma then insymbol
		      else error(20);
	  expression(fsys+[comma,rparent]);
	  end
	else { 1st parm not a file }
	  { outputptr will not be NIL }
	  ptr^.expptr := makefileexp(outputptr);
      if curexp^.etyptr <> NIL then
	begin
	new(ptr^.nextptr,false);
	ptr := ptr^.nextptr;
	ptr^.expptr := curexp;
	lsp := curexp^.etyptr;
	if lsp <> nil then
	  if lsp^.form = subrange then
	    lsp := lsp^.rangetype;
	if (lsp<>intptr) and
	     (lsp<>shortintptr) then error(125);
	if sy=comma then insymbol
		    else error(20);
	ptr^.nextptr := integerparm(fsys+[rparent]);
	end;
      end;

    procedure readwrite;
      {analyze write,writeln,read,readln,
       writedir,readdir,strwrite,strread,prompt}
      var oldvarparm,continue: boolean;
	  ptr: elistptr;
	  j,k: integer; stringmax: shortint;
	  lsp,filetype: stp;
      begin
      ptr := NIL;
      if not (lkey = spstrread) then
	begin
	new(ptr);  curstmt^.actualp := ptr;
	end;
      if not waslparent then
	begin
	if lkey=spreadln then
	  if inputptr <> nil then
	    ptr^.expptr := makefileexp(inputptr)
	  else
	    begin
	    error(185);
	    ptr^.expptr := nil;
	    end
	else if lkey in [spwriteln,spprompt,spoverprint] then
	  if outputptr <> nil then
	    ptr^.expptr := makefileexp(outputptr)
	  else
	    begin
	    error(185);
	    ptr^.expptr := nil;
	    end;
	end
      else
	begin
	varparm := (lkey = spread) or (lkey = spreadln);
	if lkey = spstrread then
	  begin
	  ptr := stringparm(fsys+[comma]);
	  curstmt^.actualp := ptr;
	  end
	else expression(fsys+[colon,comma,rparent]);
	if curexp^.etyptr<>nil then
	  if curexp^.etyptr^.form = files then
	    begin
	    ptr^.expptr := curexp;
	    if (lkey = spreaddir) or (lkey = spwritedir) then
	      begin
	      if (curexp^.etyptr = textptr)
		  or (curexp^.etyptr^.filtype = nil) then error(125);
	      if sy <> comma then error(20)
	      else
		begin insymbol;
		ptr^.nextptr := integerparm(fsys);
		ptr := ptr^.nextptr;
		varparm := lkey = spreaddir;
		end;
	      end
	    else if (lkey=spstrread)
		or (lkey=spstrwrite) then error(125)
	    else if (curexp^.etyptr<>textptr) and
		    (lkey in [spwriteln,spreadln,
			spoverprint,spprompt])
	      then error(184)
	    else if curexp^.etyptr^.filtype = nil then error(125);
	    continue := sy=comma;
	    if continue then
	      begin insymbol; expression(fsys+[colon,comma,rparent]) end
	    else if not (lkey in [spreadln,
		 spwriteln,spprompt,spoverprint])
	      then error(20);
	    end
	  else {1st param not a file}
	    begin continue := true;
	    if (lkey=spread) or (lkey=spreadln) then
	      if inputptr <> nil then
		ptr^.expptr := makefileexp(inputptr)
	      else
		begin
		error(185);
		ptr^.expptr := nil;
		end
	    else if (lkey=spreaddir) or (lkey=spwritedir) then
	      begin
	      error(125);
	      ptr^.expptr := nil;
	      end
	    else if (lkey=spstrread) or (lkey=spstrwrite) then
	      begin ptr^.expptr := curexp;
	      if not strgtype(curexp^.etyptr) then
		begin
		error(125);
		stringmax := 255;
		end
	      else
		with curexp^ do
		  begin
		  if (lkey=spstrwrite) and
		     (ekind<>vrbl) then
		    error(103);
		  if strgtype(etyptr) then
		    stringmax := etyptr^.maxleng
		  else
		    begin
		    getbounds(etyptr^.inxtype,j,k);
		    stringmax := k;
		    end;
		  end;
	      for k := 1 to 2 do
		begin
		if sy=comma then insymbol
		else error(20);
		ptr^.nextptr := integerparm(fsys);
		ptr := ptr^.nextptr;
		with ptr^.expptr^ do
		  if k = 1 then
		    begin
		    if (eclass=litnode) and
			litval.intval then
		      if (litval.ival <= 0) or
			 (litval.ival > stringmax) then
			error(302);
		    end
		  else
		    begin
		    if (etyptr <> nil) and
		       (etyptr <> intptr) then error(125);
		    if ekind <> vrbl then error(103);
		    end;
		end;
	      varparm := lkey = spstrread;
	      continue := sy=comma;
	      if continue then
		begin insymbol;
		expression(fsys+[colon,comma,rparent]);
		end
	      else error(20);
	      end
	    else
	      if outputptr <> nil then
		ptr^.expptr := makefileexp(outputptr)
	      else
		begin error(185); ptr^.expptr := nil;
		end;
	    end
	else
	  begin error(185); ptr^.expptr := nil end;
	if (lkey=spstrread) or (lkey=spstrwrite) then
	  filetype := textptr
	else if curstmt^.actualp^.expptr <> nil then
	  filetype := curstmt^.actualp^.expptr^.etyptr
	else filetype := nil;
	while continue do
	  begin
	  new(ptr^.nextptr,false); ptr := ptr^.nextptr;
	  ptr^.expptr:=curexp;
	  if filetype <> nil then
	    with curexp^ do
	      if filetype <> textptr then
		if comptypes(etyptr,filetype^.filtype) then
		  begin
		  if eclass=litnode then
		    checkconst(filetype^.filtype,curexp);
		  end
		else if (lkey=spwrite) or
			(lkey=spwritedir) then
		  begin
    { Following enhancement made 8/12/89 JWH }
		  { if not trytowiden(curexp,filetype^.filtype) then
		    if not paofcharcomp(curexp,filetype^.filtype)
		      then error(134); }
		   if not trytowiden(curexp,filetype^.filtype) then
		    begin
		     if not paofcharcomp(curexp,filetype^.filtype)
		      then error(134);
		    end
		   else
		     ptr^.expptr := curexp;
		  end
		else error(134)
	      else
		begin
		lsp := etyptr;
		if lsp <> nil then
		  if lsp^.form = subrange then
		    lsp := lsp^.rangetype;
		if (lsp<>intptr) and
		   (lsp<>shortintptr) and
		   (lsp<>char_ptr) and
		   (lsp<>boolptr) and
		   (lsp<>realptr) and
		   not enumtype(lsp) and
		   not paofchar(lsp) then error(125);
		if paofchar(lsp) then
		  if lsp^.unpacksize > 32767 then
		    error(685);
		if stdpasc then
		  if paofchar(lsp) and
		     (lkey in [spread,spreadln,spstrread]) then
		    error(606);
		end;
	  if (lkey=spread) or (lkey=spreadln)
	      or (lkey=spreaddir) or (lkey=spstrread) then
	    begin
	    if curexp^.ekind<>vrbl then error(125)
	    else { Check for FOR loop varible }
	      if curexp^.eclass = idnode then
		if cantassign in curexp^.symptr^.info then error(702);
	    end
	  else if filetype = textptr then
	    begin
	    oldvarparm := varparm;
	    varparm := false;
	    for k := 1 to 1+ord(curexp^.etyptr = realptr) do
	      begin
	      if sy = colon then
		begin insymbol;
		with ptr^ do
		  begin
		  nextptr := integerparm(fsys+[colon]);
		  with nextptr^.expptr^ do
		    if (eclass = litnode) and litval.intval then
		      if (litval.ival < 0) or
			 (litval.ival > 255) then
			error(686);
		  end;
		end
	      else ptr^.nextptr := newexplist;
	      ptr := ptr^.nextptr;
	      end;
	    varparm := oldvarparm;
	    end;
	  continue := sy=comma;
	  if continue then
	    begin insymbol; expression(fsys+[colon,comma,rparent]); end
	  end; {while continue};
	varparm := false;
	end; {if waslparent}
      if ptr <> NIL then
	ptr^.nextptr := nil;
      end {readwrite};

    procedure movestr;

      procedure checkpaoc(issource: boolean);
	var lmin,lmax: integer;
	begin
	with curexp^ do
	  begin
	  if not paofchar(etyptr) then
	    if issource and (etyptr=char_ptr)
		and (eclass=litnode) then
	      stretchpaofchar(etyptr,litval,1)
	    else error(125)
	  else if not etyptr^.aisstrng then
	    begin
	    getbounds(etyptr^.inxtype,lmin,lmax);
	    if lmin <> 1 then error(125);
	    end;
	  if not issource and (ekind<>vrbl) then
	    error(125);
	  end;
	end; {checkpaoc}

      begin {movestr}
      curstmt := newstmt(becomest,true);
      with curstmt^ do
	begin rhs := newexpr;
	with rhs^ do
	  begin
	  etyptr := strgptr;
	  eclass := substrnode;
	  expression(fsys+[comma]);
	  lengthp := curexp;
	  checkint;
	  if sy=comma then insymbol else error(20);
	  expression(fsys+[comma]);
	  arayp := curexp;
	  checkpaoc(true);
	  if sy=comma then insymbol else error(20);
	  expression(fsys+[comma]);
	  indxp := curexp;
	  checkint;
	  if sy=comma then insymbol else error(20);
	  end;
	lhs := newexpr;
	with lhs^ do
	  begin
	  etyptr := strgptr;
	  lengthp := nil;
	  eclass := substrnode;
	  expression(fsys+[comma]);
	  arayp := curexp;
	  checkpaoc(false);
	  if sy=comma then insymbol else error(20);
	  expression(fsys+[rparent]);
	  indxp := curexp;
	  checkint;
	  end;
	end;
      end; {movestr}

    begin (*proccall*)
    curstmt := newstmt(pcallst,true);
    with curstmt^ do
      begin psymptr := fcp; actualp := nil end;
    if fcp^.klass = routineparm then pcall(false)
    else {klass = prox}
      begin
      if fcp^.pfdeckind = special then
	begin
	lkey := fcp^.spkey;
	insymbol;
	if sy = lparent then begin insymbol; waslparent := true end
	else
	  begin waslparent := false;
	  if not (lkey in [spreadln,spwriteln,
	     sphalt,spprompt,sppage,spoverprint])
	    then error(9);
	  end;
	case lkey of
	  spsetstrlen: strsetlen;
	  spstrmove: movestr;
	  spcall: pcall(true);
	  spmoveleft,spmoveright,spfillchar: move;
	  spnew,spdispose: newdispose;
	  sppage: pageit;
	  spgotoxy: gotoxy;
	  spoverprint,spwrite,spwriteln,
	  spread,spreadln,spreaddir,spwritedir,
	  spprompt,spstrread,spstrwrite:
	    readwrite;
	  spunitread,spunitwrite: unitio;
	  spclose: closefile;
	  spreset,sprewrite,spopen,spappend:
	    openfile;
	  spseek: seekit;
	  sppack,spunpack: packem;
	  sphalt:
	    if waslparent then
	      begin
	      curstmt^.actualp := integerparm(fsys);
	      with curstmt^.actualp^.expptr^ do
		if (eclass = litnode) and
		   (litval.intval) then
		  if (litval.ival < -32768) or
		     (litval.ival > 32767) then
		    error(125);
	      end;
	  otherwise error(651)
	  end;
	if waslparent then if sy = rparent then insymbol else error(4)
	end
      else (* standard or declared proc *)
	begin
	insymbol;
	with curstmt^.psymptr^ do
	  if pfdeckind = declared then
	    if ismodulebody then
	      error(704)
	    else { trying to call main prog ? }
	      if curstmt^.psymptr = outerblock then
		error(103);
	if sy=lparent then
	  begin actparmlist(fsys,curstmt^.actualp,fcp^.next);
	  if sy = rparent then insymbol else error(4)
	  end
	else if fcp^.next <> nil then error(126);
	end;
      end;
    end (*proccall*);

  PROCEDURE GOTOSTATEMENT;
    VAR LLP: LABELP; FOUND: BOOLEAN; TTOP: DISPRANGE;
  BEGIN
  curstmt := newstmt(gotost,true);
  insymbol;
  with curstmt^ do
    begin target := nil;
    IF SY <> INTCONST THEN ERROR(15)
    else
      BEGIN
      FOUND := FALSE; TTOP := TOP;
      WHILE DISPLAY[TTOP].OCCUR in [RECORDscope,WITHscope] DO
	TTOP := TTOP - 1;
      LLP := DISPLAY[TTOP].FLABEL;
      WHILE (LLP <> nil) AND NOT FOUND DO
	WITH LLP^ DO
	  IF LABVAL = VAL.IVAL THEN
	    BEGIN
	    FOUND := TRUE; isrefed := true;
	    target := llp;
	    END
	  ELSE LLP := NEXTLAB;
      if not found and (ttop > 0) then
	repeat
	  repeat ttop := ttop - 1;
	  until not (display[ttop].occur in [RECORDscope,WITHscope]);
	  llp := display[ttop].flabel;
	  if not (display[ttop].occur=modulescope) then
	    while (llp <> nil) and not found do
	      with llp^ do
		if labval = val.ival then
		  begin
		  nonlocalref := true;
		  found := true; target := llp;
		  end
		else llp := nextlab;
	until found or (ttop = 0) or
	      (display[ttop].occur = modulescope);
      IF NOT FOUND THEN error(167);
      INSYMBOL
      END;
    end;
  END (*GOTOSTATEMENT*) ;

  procedure compoundstatement;
    var dummy: stptr;
    begin
      curstmt := newstmt(compndst,false);
      insymbol;
      stmtlist(curstmt^.cbody,dummy,fsys + [semicolon,endsy]);
      if sy = endsy then insymbol else error(13);
    end (*compoundstatement*) ;

  procedure ifstatement;
    begin
      curstmt := newstmt(ifst,true);
      insymbol;
      with curstmt^ do begin
	expression(fsys+[thensy]);
	ifcond := curexp;
	with curexp^ do
	  if (etyptr <> nil) and (etyptr <> boolptr) then error(135);
	if sy = thensy then insymbol else error(52);
	tru := statement(fsys+[elsesy]);
	if sy = elsesy then
	  begin insymbol; fals := statement(fsys) end
	else fals := nil
	end
    end (*ifstatement*) ;

  procedure casestatement;
    var lstp,lstp1,lstp2: stp;
	lcurrlab,ltemp: clabptr;
	ldonelabs, ldonecase: boolean;
	lcurrstmt,lastmt,dummy: stptr;
	lvalu: valu;

    procedure insortcaselabel (flabp: clabptr);
      (* insert case label into case label list ordered by ascending
	 lowval.
	 flabp           - pointer to label to be inserted
	 curstmt^.minlab - pointer to first entry in list, or nil if
			     list is empty
	 curstmt^.maxlab - pointer to last entry, or nil *)
      label 1;
      var lcurr,lprev: clabptr;
	  lval: integer;
      begin
      with curstmt^ do
	if minlab=nil then    {first label}
	  begin minlab := flabp; maxlab := flabp; flabp^.clabp := nil end
	else                  {sort it in}
	  begin
	  lval := flabp^.lowval;
	  lprev := nil;
	  lcurr := minlab;
	  while lcurr <> nil do
	    if lcurr^.lowval < lval then
	      begin lprev := lcurr; lcurr := lcurr^.clabp end
	    else goto 1;
       1: if lprev = nil then minlab := flabp
	  else begin
	       lprev^.clabp := flabp;
	       if lprev^.hival >= lval then error(156);
	       end;
	  flabp^.clabp := lcurr;
	  if lcurr = nil then maxlab := flabp
	  else if lcurr^.lowval <= flabp^.hival then error(156);
	  end;
      end (*insortcaselabel*);

    begin (*casestatement*)
      curstmt := newstmt(casest,true);
      insymbol;
      with curstmt^ do
	begin
	expression(fsys+[ofsy,comma,colon,rangesy]);
	selecter := curexp;
	lstp := selecter^.etyptr;
	if lstp <> nil then
	  if lstp^.form > subrange then error(144);
	if sy = ofsy then insymbol
	else begin error(8); skip(fsys+[rangesy,comma,colon]) end;
	maxlab := nil; minlab := nil;
	nrlabs := 0; nrstmts := 0;
	firstmt := nil; otherwyse := nil;
	repeat    (* for each case list element *)
	  ltemp := nil;  (* pts to unordered list of labels of current case,
			    linked by 'temptr' fields *)
	  if not (sy in [semicolon,othrwisesy,endsy]) then
	    begin
	    inbody := false; { used to detect non standard use }
	    repeat     (* for each case label *)
	      new(lcurrlab);
	      with lcurrlab^ do
		begin
		constant(fsys+[rangesy,comma,colon],lstp1,lvalu);
		if not comptypes(lstp,lstp1) then error(147);
		lowval := lvalu.ival;
		if sy=rangesy then
		  begin  (* label is subrange *)
		  insymbol;
		  if stdpasc then error(606);
		  constant(fsys+[comma,colon],lstp2,lvalu);
		  if not comptypes(lstp1,lstp2) then error(107);
		  hival := lvalu.ival;
		  if lowval > hival then
		    begin error(102); hival := lowval end;
		  end
		else
		  begin  (* label not a subrange *)
		  hival := lowval;
		  end;
		temptr := ltemp; ltemp := lcurrlab
		end (*with lcurrlab^*);
	      insortcaselabel(lcurrlab);
	      nrlabs := nrlabs+1;
	      ldonelabs := sy <> comma;
	      if sy = comma then insymbol
	    until ldonelabs;
	    inbody := true;
	    if sy = colon then insymbol else error(5);
	    lcurrstmt := statement(fsys+[semicolon,endsy,othrwisesy]);
	    nrstmts := nrstmts+1;
	    (* link statement into statement list *)
	    if firstmt = nil then firstmt := lcurrstmt
	    else lastmt^.next := lcurrstmt;
	    lastmt := lcurrstmt;
	    (* make all current lbls point to current statement *)
	    while ltemp <> nil do
	      with ltemp^ do
	       begin cstmt := lcurrstmt; ltemp := temptr end;
	    end (* if not (sy in [semicolon,othrwisesy,endsy]) *);
	  ldonecase := sy <> semicolon;
	  if sy = semicolon then insymbol
	until ldonecase;
	if sy = othrwisesy then
	  begin
	  if stdpasc then error(606);
	  insymbol;
	  stmtlist(otherwyse,dummy,fsys);
	  end;
	if sy = endsy then insymbol else error(13);
	if nrlabs = 0 then error(665);
	end (* with curstmt^ *)
    end (*casestatement*);

  procedure repeatstatement;
    var dummy: stptr;
    begin
    curstmt := newstmt(repst,false);
    insymbol;
    with curstmt^ do
      begin
      stmtlist(rbody,dummy,fsys+[semicolon,untilsy]);
      if sy = untilsy then
	begin
	lineno := linenumber+1;         {save line # of UNTIL symbol}
	if debugging then bptonline:=true;
	insymbol;
	expression(fsys);
	rcond := curexp;
	with curexp^ do
	  if (etyptr <> nil) and (etyptr <> boolptr) then error(135)
	end
      else error(53)
      end
    end (*repeatstatement*);

  procedure whilestatement;
    begin
    curstmt := newstmt(whilest,true);
    insymbol;
    with curstmt^ do
      begin
      expression(fsys+[dosy]);
      rcond := curexp;
      with curexp^ do
	if (etyptr <> nil) and (etyptr <> boolptr) then error(135);
      if sy = dosy then insymbol else error(54);
      rbody := statement(fsys)
      end
    end (*whilestatement*);

  procedure forstatement;
    var lcp: ctp;
    begin curstmt := newstmt(forst,true);
    insymbol;
    with curstmt^ do
      begin
      if sy <> ident then
	begin error(2);
	      skip(fsys+[becomes,tosy,downtosy,dosy]);
	      lcp := NIL;
	end
      else
	begin searchid([vars],lcp);
	ctrl := newexpr;
	with lcp^,ctrl^ do
	  begin eclass := idnode; etyptr := idtype;
	  ekind := vrbl; symptr := lcp;
	  if (vtype <> localvar) or
	     (vlev <> level) then error(657);
	  if etyptr <> nil then
	    begin
	    if etyptr^.form > subrange then error(143)
	    else if cantassign in info then
	      error(702)
	    else
	      info := info + [cantassign];
	    end;
	  end;
	insymbol;
	end (*sy=ident*);
      if sy <> becomes then
	begin error(51); skip(fsys+[tosy,downtosy,dosy]) end
      else
	begin insymbol; expression(fsys+[tosy,downtosy,dosy]);
	init := curexp;
	if not comptypes(init^.etyptr,ctrl^.etyptr) then
	  error(145)
	else if init^.eclass = litnode then
	  checkconst(ctrl^.etyptr,init);
	end;
      if not(sy in [tosy,downtosy]) then
	begin error(55); skip(fsys+[dosy]) end
      else
	begin if sy = tosy then incr := 1 else incr := -1;
	insymbol; expression(fsys+[dosy]); limit := curexp;
	if not comptypes(limit^.etyptr,ctrl^.etyptr) then
	  error(145)
	else if (limit^.eclass = litnode) then
	  checkconst(ctrl^.etyptr,limit);
	end;
      if sy = dosy then insymbol else error(54);
      fbody := statement(fsys);
      end; (*with curstmt^*)
    if lcp <> NIL then
      lcp^.info := lcp^.info - [cantassign];
    end; (*forstatement*)

  procedure withstatement;
    var oldtop: disprange; lquit: boolean;
	lstmt: stptr; lrectype: stp;
	lcp: ctp;
    begin curstmt := newstmt(withst,true);
    insymbol; oldtop := top;
    lstmt := curstmt;
    repeat
      if sy <> ident then begin error(2); skip(fsys+[comma,dosy]) end
      else
	begin
	searchid([types,vars,field,konst,func,routineparm],lcp);
	identproc(fsys+[comma,dosy]);
	lrectype := curexp^.etyptr;
	if lrectype <> nil then
	  if lrectype^.form <> records then error(140)
	  else if top >= displimit then error(662)
	  else
	    begin     {open scope containing field names}
	    top := top+1;
	    with display[top] do begin
	      fname := lrectype^.fstfld;
	      occur := WITHscope;
	      wnodeptr := lstmt;
	      end;
	    lstmt^.refexpr := curexp;
	    end;      {open scope}
	end;  (* sy=ident *)
      lquit := sy <> comma;
      if not lquit then begin
	insymbol;
	lstmt^.wbody := newstmt(withst,false);
	lstmt := lstmt^.wbody;
	end;
    until lquit;
    if sy = dosy then insymbol else error(54);
    lstmt^.wbody := statement(fsys);
    top := oldtop;
    end (*withstatement*);

  procedure trystatement;
    var dummy: stptr;
    begin
    curstmt := newstmt(tryst,true);
    insymbol;
    with curstmt^ do
     begin
      parsing_try_level := parsing_try_level + 1; { JWH 9/26/91 }
      stmtlist(tbody,dummy,fsys+[semicolon,recoversy]);
      parsing_try_level := parsing_try_level - 1; { JWH 9/26/91 }
      if sy = recoversy then begin
	insymbol;
	recov := statement(fsys)
	end
      else error(712);  (* 'recover' expected *)
   end; { with }
 end; (*trystatement*)

  BEGIN (*STATEMENT*)
  LLP := nil;           {mark no label for this stmt}
  IF SY = INTCONST THEN (*LABEL*)
    BEGIN
    if val.ival > 9999 then error(163);
    TTOP := TOP;
    WHILE DISPLAY[TTOP].OCCUR in [RECORDscope,WITHscope] DO
      TTOP := TTOP-1;
    LLP := DISPLAY[TTOP].FLABEL;
    WHILE LLP <> NIL DO
      WITH LLP^ DO
	IF LABVAL = VAL.IVAL THEN
	  BEGIN
	  IF DEFINED THEN begin ERROR(165); LLP := nil end
	  ELSE
	    begin
	    DEFINED := TRUE;
	    if (linelevel <> 0) and nonlocalref then error(164);
	    try_level := parsing_try_level; { JWH 9/26/91 }
	    end;
	  GOTO 1
	  END
	ELSE LLP := NEXTLAB;
    ERROR(167);    (* undeclared label *)
  1:INSYMBOL;
    IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
    END; (*label*)
  IF NOT (SY IN FSYS + [IDENT]) THEN
    BEGIN ERROR(6); SKIP(FSYS) END;
  if sy=period then {kluge} insymbol;
  IF SY IN STATBEGSYS + [IDENT] THEN
    BEGIN
      CASE SY OF
	IDENT:    BEGIN SEARCHID([types,VARS,FIELD,FUNC,PROX,routineparm],LCP);
		  with lcp^ do
		    IF (KLASS = prox)
			or (klass = routineparm) and (vtype = procparm)
		      THEN proccall(FSYS,LCP)
		      ELSE ASSIGNMENT(lcp);
		  END;
	BEGINSY:  COMPOUNDSTATEMENT;
	CASESY:   begin
		  linelevel := linelevel + 1;
		  CASESTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	FORSY:    begin
		  linelevel := linelevel + 1;
		  FORSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	GOTOSY:   GOTOSTATEMENT;
	IFSY:     begin
		  linelevel := linelevel + 1;
		  IFSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	REPEATSY: begin
		  linelevel := linelevel + 1;
		  REPEATSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	trysy:    begin
		  linelevel := linelevel + 1;
		  trystatement;
		  linelevel := linelevel - 1;
		  end;
	WHILESY:  begin
		  linelevel := linelevel + 1;
		  WHILESTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	WITHSY:   begin
		  linelevel := linelevel + 1;
		  WITHSTATEMENT;
		  linelevel := linelevel - 1;
		  end;
	END; {case}
      IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY,recoversy,othrwisesy])
	THEN BEGIN ERROR(6); SKIP(FSYS) END
    END
  else curstmt := newstmt(emptyst,false);
  curstmt^.labp := LLP;         {mark it with saved label}
  statement := curstmt
  END (*STATEMENT*);

@


55.2
log
@Changes to fix FSDdt07193.
@
text
@@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@d1156 2
a1157 1
      begin
d1159 1
d1164 3
a1166 3
      else error(712)  (* 'recover' expected *)
      end
    end (*trystatement*);
d1186 1
@


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

         Added PARTIAL_EVAL around makestringlit.
@
text
@@


37.4
log
@ Corrected typing error made during previous change.
@
text
@d173 1
d204 1
@


37.3
log
@
  Modified STATEMENT at about line 620 to repair FSDdt02154 -
  'Illegal CPU instruction when write integer to file of reals'.
@
text
@d182 1
a182 1
	       (isPAC(etptr^.inxtype) or etyptr^.aisstrng)) and
@


37.2
log
@
Enhanced the routine makestringlit in file STATEMENT to
repair the bug present when using structured constants
to declare a file name. I'm not sure if this has an associated
defect number or not.
@
text
@d622 2
a623 1
		  if not trytowiden(curexp,filetype^.filtype) then
d625 4
d630 3
@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d181 4
a184 1
	if not paofchar(etyptr) and
d186 1
a186 1
	   (eclass <> litnode)) then
d188 4
a191 1
	else if eclass = litnode then
@


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


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


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


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


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


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


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


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


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


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


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


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


24.2
log
@Do not range check structured constant field width parameters at compile
time.
.,
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d662 1
a662 1
		    if ekind = cnst then
@


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
@d372 4
a375 1
		amin := litval.ival;
@


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


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


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


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


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


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


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


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


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


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


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


1.1
log
@Initial revision
@
text
@@
