                    {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}

    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
          error(125)
        else if (eclass = litnode) and
            (litval.intval or (litval.valp^.cclass <> strctconst)) then
          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;

    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
                  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
      stmtlist(tbody,dummy,fsys+[semicolon,recoversy]);
      if sy = recoversy then begin
        insymbol;
        recov := statement(fsys)
        end
      else error(712)  (* 'recover' expected *)
      end
    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);
            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);
                  { writeln('in statement - dumping expr tree : ');
                  dumptree(curstmt,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*);

