Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/misc/volume23/pascal/part02

Text File | 1991-09-27 | 55.4 KB | 1,991 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Steven Pemberton)
Subject:  v23i026:  pascal - Public domain Pascal Compiler and Interpreter, Part02/03
Message-ID: <[e-mail]>
X-Md4-Signature: 7631e6c5630aff576b3785529c06f66c
Date: Fri, 27 Sep 1991 04:12:14 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Steven Pemberton)
Posting-number: Volume 23, Issue 26
Archive-name: pascal/part02
Environment: pascal

#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file pcom.p continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 2; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping pcom.p'
else
echo 'x - continuing file pcom.p'
sed 's/^X//' << 'SHAR_EOF' >> 'pcom.p' &&
X                end
X            until sy <> comma;
X            if sy = colon then
X              begin insymbol;
X                if sy = ident then
X                  begin searchid([types],lcp);
X                lsp := lcp^.idtype;
X                if lsp <> nil then
X                 if not(lsp^.form in[scalar,subrange,pointer])
X                    then begin error(120); lsp := nil end;
X                lcp3 := lcp2;
X                while lcp2 <> nil do
X                  begin lcp2^.idtype := lsp; lcp := lcp2;
X                    lcp2 := lcp2^.next
X                  end;
X                lcp^.next := lcp1; lcp1 := lcp3;
X                insymbol
X                  end
X                else error(2);
X                if not (sy in fsys + [semicolon,rparent]) then
X                  begin error(7);skip(fsys+[semicolon,rparent])end
X              end
X            else error(5)
X              end
X            else
X              begin
X            if sy = varsy then
X              begin lkind := formal; insymbol end
X            else lkind := actual;
X            lcp2 := nil;
X            count := 0;
X            repeat
X              if sy = ident then
X                begin new(lcp,vars);
X                  with lcp^ do
X                begin name:=id; idtype:=nil; klass:=vars;
X                  vkind := lkind; next := lcp2; vlev := level;
X                end;
X                  enterid(lcp);
X                  lcp2 := lcp; count := count+1;
X                  insymbol;
X                end;
X              if not (sy in [comma,colon] + fsys) then
X                begin error(7);skip(fsys+[comma,semicolon,rparent])
X                end;
X              test := sy <> comma;
X              if not test then insymbol
X            until test;
X            if sy = colon then
X              begin insymbol;
X                if sy = ident then
X                  begin searchid([types],lcp);
X                lsp := lcp^.idtype;
X                lsize := ptrsize;
X                if lsp <> nil then
X                  if lkind=actual then
X                    if lsp^.form<=power then lsize := lsp^.size
X                    else if lsp^.form=files then error(121);
X                align(parmptr,lsize);
X                lcp3 := lcp2;
X                align(parmptr,lc);
X                lc := lc+count*lsize;
X                llc := lc;
X                while lcp2 <> nil do
X                  begin lcp := lcp2;
X                    with lcp2^ do
X                      begin idtype := lsp;
X                    llc := llc-lsize;
X                    vaddr := llc;
X                      end;
X                    lcp2 := lcp2^.next
X                  end;
X                lcp^.next := lcp1; lcp1 := lcp3;
X                insymbol
X                  end
X                else error(2);
X                if not (sy in fsys + [semicolon,rparent]) then
X                  begin error(7);skip(fsys+[semicolon,rparent])end
X              end
X            else error(5);
X              end;
X          end;
X        if sy = semicolon then
X          begin insymbol;
X            if not (sy in fsys + [ident,varsy,procsy,funcsy]) then
X              begin error(7); skip(fsys + [ident,rparent]) end
X          end
X          end (*while*) ;
X        if sy = rparent then
X          begin insymbol;
X        if not (sy in fsy + fsys) then
X          begin error(6); skip(fsy + fsys) end
X          end
X        else error(4);
X        lcp3 := nil;
X        (*reverse pointers and reserve local cells for copies of multiple
X         values*)
X        while lcp1 <> nil do
X          with lcp1^ do
X        begin lcp2 := next; next := lcp3;
X          if klass = vars then
X            if idtype <> nil then
X              if (vkind=actual)and(idtype^.form>power) then
X            begin align(idtype,lc);
X              vaddr := lc;
X              lc := lc+idtype^.size;
X            end;
X          lcp3 := lcp1; lcp1 := lcp2
X        end;
X        fpar := lcp3
X      end
X        else fpar := nil
X    end (*parameterlist*) ;
X
X    begin (*procdeclaration*)
X      llc := lc; lc := lcaftermarkstack; forw := false;
X      if sy = ident then
X    begin searchsection(display[top].fname,lcp); (*decide whether forw.*)
X      if lcp <> nil then
X        begin
X          if lcp^.klass = proc then
X        forw := lcp^.forwdecl and(fsy=procsy)and(lcp^.pfkind=actual)
X          else
X        if lcp^.klass = func then
X          forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual)
X        else forw := false;
X          if not forw then error(160)
X        end;
X      if not forw then
X        begin
X          if fsy = procsy then new(lcp,proc,declared,actual)
X          else new(lcp,func,declared,actual);
X          with lcp^ do
X        begin name := id; idtype := nil;
X          extern := false; pflev := level; genlabel(lbname);
X          pfdeckind := declared; pfkind := actual; pfname := lbname;
X          if fsy = procsy then klass := proc
X          else klass := func
X        end;
X          enterid(lcp)
X        end
X      else
X        begin lcp1 := lcp^.next;
X          while lcp1 <> nil do
X        begin
X          with lcp1^ do
X            if klass = vars then
X              if idtype <> nil then
X            begin lcm := vaddr + idtype^.size;
X              if lcm > lc then lc := lcm
X            end;
X          lcp1 := lcp1^.next
X        end
X        end;
X      insymbol
X    end
X      else
X    begin error(2); lcp := ufctptr end;
X      oldlev := level; oldtop := top;
X      if level < maxlevel then level := level + 1 else error(251);
X      if top < displimit then
X    begin top := top + 1;
X      with display[top] do
X        begin
X          if forw then fname := lcp^.next
X          else fname := nil;
X          flabel := nil;
X          occur := blck
X        end
X    end
X      else error(250);
X      if fsy = procsy then
X    begin parameterlist([semicolon],lcp1);
X      if not forw then lcp^.next := lcp1
X    end
X      else
X    begin parameterlist([semicolon,colon],lcp1);
X      if not forw then lcp^.next := lcp1;
X      if sy = colon then
X        begin insymbol;
X          if sy = ident then
X        begin if forw then error(122);
X          searchid([types],lcp1);
X          lsp := lcp1^.idtype;
X          lcp^.idtype := lsp;
X          if lsp <> nil then
X            if not (lsp^.form in [scalar,subrange,pointer]) then
X              begin error(120); lcp^.idtype := nil end;
X          insymbol
X        end
X          else begin error(2); skip(fsys + [semicolon]) end
X        end
X      else
X        if not forw then error(123)
X    end;
X      if sy = semicolon then insymbol else error(14);
X      if sy = forwardsy then
X    begin
X      if forw then error(161)
X      else lcp^.forwdecl := true;
X      insymbol;
X      if sy = semicolon then insymbol else error(14);
X      if not (sy in fsys) then
X        begin error(6); skip(fsys) end
X    end
X      else
X    begin lcp^.forwdecl := false; mark(markp);
X      repeat block(fsys,semicolon,lcp);
X        if sy = semicolon then
X          begin if prtables then printtables(false); insymbol;
X        if not (sy in [beginsy,procsy,funcsy]) then
X          begin error(6); skip(fsys) end
X          end
X        else error(14)
X      until (sy in [beginsy,procsy,funcsy]) or eof(input);
X      release(markp); (* return local entries on runtime heap *)
X    end;
X      level := oldlev; top := oldtop; lc := llc;
X    end (*procdeclaration*) ;
X
X    procedure body(fsys: setofsys);
X      const cstoccmax=65; cixmax=1000;
X      type oprange = 0..63;
X      var
X      llcp:ctp; saveid:alpha;
X      cstptr: array [1..cstoccmax] of csp;
X      cstptrix: 0..cstoccmax;
X      (*allows referencing of noninteger constants by an index
X       (instead of a pointer), which can be stored in the p2-field
X       of the instruction record until writeout.
X       --> procedure load, procedure writeout*)
X      entname, segsize: integer;
X      stacktop, topnew, topmax: integer;
X      lcmax,llc1: addrrange; lcp: ctp;
X      llp: lbp;
X
X
X      procedure mes(i: integer);
X      begin topnew := topnew + cdx[i]*maxstack;
X    if topnew > topmax then topmax := topnew
X      end;
X
X      procedure putic;
X      begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end;
X
X      procedure gen0(fop: oprange);
X      begin
X    if prcode then begin putic; writeln(prr,mn[fop]:4) end;
X    ic := ic + 1; mes(fop)
X      end (*gen0*) ;
X
X      procedure gen1(fop: oprange; fp2: integer);
X    var k: integer;
X      begin
X    if prcode then
X      begin putic; write(prr,mn[fop]:4);
X        if fop = 30 then
X          begin writeln(prr,sna[fp2]:12);
X        topnew := topnew + pdx[fp2]*maxstack;
X        if topnew > topmax then topmax := topnew
X          end
X        else
X          begin
X        if fop = 38 then
X           begin write(prr,'''');
X             with cstptr[fp2]^ do
X             begin
X               for k := 1 to slgth do write(prr,sval[k]:1);
X               for k := slgth+1 to strglgth do write(prr,' ');
X             end;
X             writeln(prr,'''')
X           end
X        else if fop = 42 then writeln(prr,chr(fp2))
X             else writeln(prr,fp2:12);
X        mes(fop)
X          end
X      end;
X    ic := ic + 1
X      end (*gen1*) ;
X
X      procedure gen2(fop: oprange; fp1,fp2: integer);
X    var k : integer;
X      begin
X    if prcode then
X      begin putic; write(prr,mn[fop]:4);
X        case fop of
X          45,50,54,56:
X        writeln(prr,' ',fp1:3,fp2:8);
X          47,48,49,52,53,55:
X        begin write(prr,chr(fp1));
X          if chr(fp1) = 'm' then write(prr,fp2:11);
X          writeln(prr)
X        end;
X          51:
X        case fp1 of
X          1: writeln(prr,'i ',fp2);
X          2: begin write(prr,'r ');
X               with cstptr[fp2]^ do
X             for k := 1 to strglgth do write(prr,rval[k]);
X               writeln(prr)
X             end;
X          3: writeln(prr,'b ',fp2);
X          4: writeln(prr,'n');
X          6: writeln(prr,'c ''':3,chr(fp2),'''');
X          5: begin write(prr,'(');
X               with cstptr[fp2]^ do
X             for k := setlow to sethigh do
X               if k in pval then write(prr,k:3);
X               writeln(prr,')')
X             end
X        end
X        end;
X      end;
X    ic := ic + 1; mes(fop)
X      end (*gen2*) ;
X
X      procedure gentypindicator(fsp: stp);
X      begin
X    if fsp<>nil then
X      with fsp^ do
X        case form of
X         scalar: if fsp=intptr then write(prr,'i')
X             else
X               if fsp=boolptr then write(prr,'b')
X               else
X             if fsp=charptr then write(prr,'c')
X             else
X               if scalkind = declared then write(prr,'i')
X               else write(prr,'r');
X         subrange: gentypindicator(rangetype);
X         pointer:  write(prr,'a');
X         power:    write(prr,'s');
X         records,arrays: write(prr,'m');
X         files,tagfld,variant: error(500)
X        end
X      end (*typindicator*);
X
X      procedure gen0t(fop: oprange; fsp: stp);
X      begin
X    if prcode then
X      begin putic;
X        write(prr,mn[fop]:4);
X        gentypindicator(fsp);
X        writeln(prr);
X      end;
X    ic := ic + 1; mes(fop)
X      end (*gen0t*);
X
X      procedure gen1t(fop: oprange; fp2: integer; fsp: stp);
X      begin
X    if prcode then
X      begin putic;
X        write(prr,mn[fop]:4);
X        gentypindicator(fsp);
X        writeln(prr,fp2:11)
X      end;
X    ic := ic + 1; mes(fop)
X      end (*gen1t*);
X
X      procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp);
X      begin
X    if prcode then
X      begin putic;
X        write(prr,mn[fop]: 4);
X        gentypindicator(fsp);
X        writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:8);
X      end;
X    ic := ic + 1; mes(fop)
X      end (*gen2t*);
X
X      procedure load;
X      begin
X    with gattr do
X      if typtr <> nil then
X        begin
X          case kind of
X        cst:   if (typtr^.form = scalar) and (typtr <> realptr) then
X             if typtr = boolptr then gen2(51(*ldc*),3,cval.ival)
X             else
X               if typtr=charptr then
X                 gen2(51(*ldc*),6,cval.ival)
X               else gen2(51(*ldc*),1,cval.ival)
X               else
X             if typtr = nilptr then gen2(51(*ldc*),4,0)
X             else
X               if cstptrix >= cstoccmax then error(254)
X               else
X                 begin cstptrix := cstptrix + 1;
X                   cstptr[cstptrix] := cval.valp;
X                   if typtr = realptr then
X                 gen2(51(*ldc*),2,cstptrix)
X                   else
X                 gen2(51(*ldc*),5,cstptrix)
X                 end;
X        varbl: case access of
X             drct:   if vlevel<=1 then
X                   gen1t(39(*ldo*),dplmt,typtr)
X                 else gen2t(54(*lod*),level-vlevel,dplmt,typtr);
X             indrct: gen1t(35(*ind*),idplmt,typtr);
X             inxd:   error(400)
X               end;
X        expr:
X          end;
X          kind := expr
X        end
X      end (*load*) ;
X
X      procedure store(var fattr: attr);
X      begin
X    with fattr do
X      if typtr <> nil then
X        case access of
X          drct:   if vlevel <= 1 then gen1t(43(*sro*),dplmt,typtr)
X              else gen2t(56(*str*),level-vlevel,dplmt,typtr);
X          indrct: if idplmt <> 0 then error(400)
X              else gen0t(26(*sto*),typtr);
X          inxd:   error(400)
X        end
X      end (*store*) ;
X
X      procedure loadaddress;
X      begin
X    with gattr do
X      if typtr <> nil then
X        begin
X          case kind of
X        cst:   if string(typtr) then
X             if cstptrix >= cstoccmax then error(254)
X             else
X               begin cstptrix := cstptrix + 1;
X                 cstptr[cstptrix] := cval.valp;
X                 gen1(38(*lca*),cstptrix)
X               end
X               else error(400);
X        varbl: case access of
X             drct:   if vlevel <= 1 then gen1(37(*lao*),dplmt)
X                 else gen2(50(*lda*),level-vlevel,dplmt);
X             indrct: if idplmt <> 0 then
X                   gen1t(34(*inc*),idplmt,nilptr);
X             inxd:   error(400)
X               end;
X        expr:  error(400)
X          end;
X          kind := varbl; access := indrct; idplmt := 0
X        end
X      end (*loadaddress*) ;
X
X
X      procedure genfjp(faddr: integer);
X      begin load;
X    if gattr.typtr <> nil then
X      if gattr.typtr <> boolptr then error(144);
X    if prcode then begin putic; writeln(prr,mn[33]:4,' l':8,faddr:4) end;
X    ic := ic + 1; mes(33)
X      end (*genfjp*) ;
X
X      procedure genujpxjp(fop: oprange; fp2: integer);
X      begin
X       if prcode then
X      begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end;
X    ic := ic + 1; mes(fop)
X      end (*genujpxjp*);
X
X
X      procedure gencupent(fop: oprange; fp1,fp2: integer);
X      begin
X    if prcode then
X      begin putic;
X        writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4)
X      end;
X    ic := ic + 1; mes(fop)
X      end;
X
X
X      procedure checkbnds(fsp: stp);
X    var lmin,lmax: integer;
X      begin
X    if fsp <> nil then
X      if fsp <> intptr then
X        if fsp <> realptr then
X          if fsp^.form <= subrange then
X        begin
X          getbounds(fsp,lmin,lmax);
X          gen2t(45(*chk*),lmin,lmax,fsp)
X        end
X      end (*checkbnds*);
X
X
X      procedure putlabel(labname: integer);
X      begin if prcode then writeln(prr, 'l', labname:4)
X      end (*putlabel*);
X
X      procedure statement(fsys: setofsys);
X    label 1;
X    var lcp: ctp; llp: lbp;
X
X    procedure expression(fsys: setofsys); forward;
X
X    procedure selector(fsys: setofsys; fcp: ctp);
X    var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer;
X    begin
X      with fcp^, gattr do
X        begin typtr := idtype; kind := varbl;
X          case klass of
X        vars:
X          if vkind = actual then
X            begin access := drct; vlevel := vlev;
X              dplmt := vaddr
X            end
X          else
X            begin gen2t(54(*lod*),level-vlev,vaddr,nilptr);
X              access := indrct; idplmt := 0
X            end;
X        field:
X          with display[disx] do
X            if occur = crec then
X              begin access := drct; vlevel := clev;
X            dplmt := cdspl + fldaddr
X              end
X            else
X              begin
X            if level = 1 then gen1t(39(*ldo*),vdspl,nilptr)
X            else gen2t(54(*lod*),0,vdspl,nilptr);
X            access := indrct; idplmt := fldaddr
X              end;
X        func:
X          if pfdeckind = standard then
X            begin error(150); typtr := nil end
X          else
X            begin
X              if pfkind = formal then error(151)
X              else
X            if (pflev+1<>level)or(fprocp<>fcp) then error(177);
X            begin access := drct; vlevel := pflev + 1;
X              dplmt := 0   (*impl. relat. addr. of fct. result*)
X            end
X            end
X          end (*case*)
X        end (*with*);
X      if not (sy in selectsys + fsys) then
X        begin error(59); skip(selectsys + fsys) end;
X      while sy in selectsys do
X        begin
X    (*[*) if sy = lbrack then
X        begin
X          repeat lattr := gattr;
X            with lattr do
X              if typtr <> nil then
X            if typtr^.form <> arrays then
X              begin error(138); typtr := nil end;
X            loadaddress;
X            insymbol; expression(fsys + [comma,rbrack]);
X            load;
X            if gattr.typtr <> nil then
X              if gattr.typtr^.form<>scalar then error(113)
X              else if not comptypes(gattr.typtr,intptr) then
X                 gen0t(58(*ord*),gattr.typtr);
X            if lattr.typtr <> nil then
X              with lattr.typtr^ do
X            begin
X              if comptypes(inxtype,gattr.typtr) then
X                begin
X                  if inxtype <> nil then
X                begin getbounds(inxtype,lmin,lmax);
X                  if debug then
X                    gen2t(45(*chk*),lmin,lmax,intptr);
X                  if lmin>0 then gen1t(31(*dec*),lmin,intptr)
X                  else if lmin<0 then
X                    gen1t(34(*inc*),-lmin,intptr);
X                  (*or simply gen1(31,lmin)*)
X                end
X                end
X              else error(139);
X              with gattr do
X                begin typtr := aeltype; kind := varbl;
X                  access := indrct; idplmt := 0
X                end;
X              if gattr.typtr <> nil then
X                begin
X                  lsize := gattr.typtr^.size;
X                  align(gattr.typtr,lsize);
X                  gen1(36(*ixa*),lsize)
X                end
X            end
X          until sy <> comma;
X          if sy = rbrack then insymbol else error(12)
X        end (*if sy = lbrack*)
X          else
X    (*.*)   if sy = period then
X          begin
X            with gattr do
X              begin
X            if typtr <> nil then
X              if typtr^.form <> records then
X                begin error(140); typtr := nil end;
X            insymbol;
X            if sy = ident then
X              begin
X                if typtr <> nil then
X                  begin searchsection(typtr^.fstfld,lcp);
X                if lcp = nil then
X                  begin error(152); typtr := nil end
X                else
X                  with lcp^ do
X                    begin typtr := idtype;
X                      case access of
X                    drct:   dplmt := dplmt + fldaddr;
X                    indrct: idplmt := idplmt + fldaddr;
X                    inxd:   error(400)
X                      end
X                    end
X                  end;
X                insymbol
X              end (*sy = ident*)
X            else error(2)
X              end (*with gattr*)
X          end (*if sy = period*)
X        else
X    (*^*)     begin
X            if gattr.typtr <> nil then
X              with gattr,typtr^ do
X            if form = pointer then
X              begin load; typtr := eltype;
X                if debug then gen2t(45(*chk*),1,maxaddr,nilptr);
X                with gattr do
X                  begin kind := varbl; access := indrct;
X                idplmt := 0
X                  end
X              end
X            else
X              if form = files then typtr := filtype
X              else error(141);
X            insymbol
X          end;
X          if not (sy in fsys + selectsys) then
X        begin error(6); skip(fsys + selectsys) end
X        end (*while*)
X    end (*selector*) ;
X
X    procedure call(fsys: setofsys; fcp: ctp);
X      var lkey: 1..15;
X
X      procedure variable(fsys: setofsys);
X        var lcp: ctp;
X      begin
X        if sy = ident then
X          begin searchid([vars,field],lcp); insymbol end
X        else begin error(2); lcp := uvarptr end;
X        selector(fsys,lcp)
X      end (*variable*) ;
X
X      procedure getputresetrewrite;
X      begin variable(fsys + [rparent]); loadaddress;
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form <> files then error(116);
X        if lkey <= 2 then gen1(30(*csp*),lkey(*get,put*))
X        else error(399)
X      end (*getputresetrewrite*) ;
X
X      procedure read;
X        var llev:levrange; laddr:addrrange;
X        lsp : stp;
X      begin
X        llev := 1; laddr := lcaftermarkstack;
X        if sy = lparent then
X          begin insymbol;
X        variable(fsys + [comma,rparent]);
X        lsp := gattr.typtr; test := false;
X        if lsp <> nil then
X          if lsp^.form = files then
X            with gattr, lsp^ do
X              begin
X            if filtype = charptr then
X              begin llev := vlevel; laddr := dplmt end
X            else error(399);
X            if sy = rparent then
X              begin if lkey = 5 then error(116);
X                test := true
X              end
X            else
X              if sy <> comma then
X                begin error(116); skip(fsys + [comma,rparent]) end;
X            if sy = comma then
X              begin insymbol; variable(fsys + [comma,rparent])
X              end
X            else test := true
X              end;
X           if not test then
X        repeat loadaddress;
X          gen2(50(*lda*),level-llev,laddr);
X          if gattr.typtr <> nil then
X            if gattr.typtr^.form <= subrange then
X              if comptypes(intptr,gattr.typtr) then
X            gen1(30(*csp*),3(*rdi*))
X              else
X            if comptypes(realptr,gattr.typtr) then
X              gen1(30(*csp*),4(*rdr*))
X            else
X              if comptypes(charptr,gattr.typtr) then
X                gen1(30(*csp*),5(*rdc*))
X              else error(399)
X            else error(116);
X          test := sy <> comma;
X          if not test then
X            begin insymbol; variable(fsys + [comma,rparent])
X            end
X        until test;
X        if sy = rparent then insymbol else error(4)
X          end
X        else if lkey = 5 then error(116);
X        if lkey = 11 then
X          begin gen2(50(*lda*),level-llev,laddr);
X        gen1(30(*csp*),21(*rln*))
X          end
X      end (*read*) ;
X
X      procedure write;
X        var lsp: stp; default : boolean; llkey: 1..15;
X        llev:levrange; laddr,len:addrrange;
X      begin llkey := lkey;
X        llev := 1; laddr := lcaftermarkstack + charmax;
X        if sy = lparent then
X        begin insymbol;
X        expression(fsys + [comma,colon,rparent]);
X        lsp := gattr.typtr; test := false;
X        if lsp <> nil then
X          if lsp^.form = files then
X        with gattr, lsp^ do
X          begin
X            if filtype = charptr then
X              begin llev := vlevel; laddr := dplmt end
X            else error(399);
X            if sy = rparent then
X              begin if llkey = 6 then error(116);
X            test := true
X              end
X            else
X              if sy <> comma then
X            begin error(116); skip(fsys+[comma,rparent]) end;
X            if sy = comma then
X              begin insymbol; expression(fsys+[comma,colon,rparent])
X              end
X            else test := true
X          end;
X       if not test then
X        repeat
X          lsp := gattr.typtr;
X          if lsp <> nil then
X        if lsp^.form <= subrange then load else loadaddress;
X          if sy = colon then
X        begin insymbol; expression(fsys + [comma,colon,rparent]);
X          if gattr.typtr <> nil then
X            if gattr.typtr <> intptr then error(116);
X          load; default := false
X        end
X          else default := true;
X          if sy = colon then
X        begin insymbol; expression(fsys + [comma,rparent]);
X          if gattr.typtr <> nil then
X            if gattr.typtr <> intptr then error(116);
X          if lsp <> realptr then error(124);
X          load; error(399);
X        end
X          else
X        if lsp = intptr then
X          begin if default then gen2(51(*ldc*),1,10);
X            gen2(50(*lda*),level-llev,laddr);
X            gen1(30(*csp*),6(*wri*))
X          end
X        else
X          if lsp = realptr then
X            begin if default then gen2(51(*ldc*),1,20);
X              gen2(50(*lda*),level-llev,laddr);
X              gen1(30(*csp*),8(*wrr*))
X            end
X          else
X            if lsp = charptr then
X              begin if default then gen2(51(*ldc*),1,1);
X            gen2(50(*lda*),level-llev,laddr);
X            gen1(30(*csp*),9(*wrc*))
X              end
X            else
X              if lsp <> nil then
X            begin
X              if lsp^.form = scalar then error(399)
X              else
X                if string(lsp) then
X                  begin len := lsp^.size div charmax;
X                if default then
X                      gen2(51(*ldc*),1,len);
X                gen2(51(*ldc*),1,len);
X                gen2(50(*lda*),level-llev,laddr);
X                gen1(30(*csp*),10(*wrs*))
X                  end
X                else error(116)
X            end;
X          test := sy <> comma;
X          if not test then
X        begin insymbol; expression(fsys + [comma,colon,rparent])
X        end
X        until test;
X        if sy = rparent then insymbol else error(4)
X        end
X          else if lkey = 6 then error(116);
X        if llkey = 12 then (*writeln*)
X          begin gen2(50(*lda*),level-llev,laddr);
X        gen1(30(*csp*),22(*wln*))
X          end
X      end (*write*) ;
X
X      procedure pack;
X        var lsp,lsp1: stp;
X      begin error(399); variable(fsys + [comma,rparent]);
X        lsp := nil; lsp1 := nil;
X        if gattr.typtr <> nil then
X          with gattr.typtr^ do
X        if form = arrays then
X          begin lsp := inxtype; lsp1 := aeltype end
X        else error(116);
X        if sy = comma then insymbol else error(20);
X        expression(fsys + [comma,rparent]);
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form <> scalar then error(116)
X          else
X        if not comptypes(lsp,gattr.typtr) then error(116);
X        if sy = comma then insymbol else error(20);
X        variable(fsys + [rparent]);
X        if gattr.typtr <> nil then
X          with gattr.typtr^ do
X        if form = arrays then
X          begin
X            if not comptypes(aeltype,lsp1)
X              or not comptypes(inxtype,lsp) then
X              error(116)
X          end
X        else error(116)
X      end (*pack*) ;
X
X      procedure unpack;
X        var lsp,lsp1: stp;
X      begin error(399); variable(fsys + [comma,rparent]);
X        lsp := nil; lsp1 := nil;
X        if gattr.typtr <> nil then
X          with gattr.typtr^ do
X        if form = arrays then
X          begin lsp := inxtype; lsp1 := aeltype end
X        else error(116);
X        if sy = comma then insymbol else error(20);
X        variable(fsys + [comma,rparent]);
X        if gattr.typtr <> nil then
X          with gattr.typtr^ do
X        if form = arrays then
X          begin
X            if not comptypes(aeltype,lsp1)
X              or not comptypes(inxtype,lsp) then
X              error(116)
X          end
X        else error(116);
X        if sy = comma then insymbol else error(20);
X        expression(fsys + [rparent]);
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form <> scalar then error(116)
X          else
X        if not comptypes(lsp,gattr.typtr) then error(116);
X      end (*unpack*) ;
X
X      procedure new;
X        label 1;
X        var lsp,lsp1: stp; varts: integer;
X        lsize: addrrange; lval: valu;
X      begin variable(fsys + [comma,rparent]); loadaddress;
X        lsp := nil; varts := 0; lsize := 0;
X        if gattr.typtr <> nil then
X          with gattr.typtr^ do
X        if form = pointer then
X          begin
X            if eltype <> nil then
X              begin lsize := eltype^.size;
X            if eltype^.form = records then lsp := eltype^.recvar
X              end
X          end
X        else error(116);
X        while sy = comma do
X          begin insymbol;constant(fsys + [comma,rparent],lsp1,lval);
X        varts := varts + 1;
X        (*check to insert here: is constant in tagfieldtype range*)
X        if lsp = nil then error(158)
X        else
X          if lsp^.form <> tagfld then error(162)
X          else
X            if lsp^.tagfieldp <> nil then
X              if string(lsp1) or (lsp1 = realptr) then error(159)
X              else
X            if comptypes(lsp^.tagfieldp^.idtype,lsp1) then
X              begin
X                lsp1 := lsp^.fstvar;
X                while lsp1 <> nil do
X                  with lsp1^ do
X                if varval.ival = lval.ival then
X                  begin lsize := size; lsp := subvar;
X                    goto 1
X                  end
X                else lsp1 := nxtvar;
X                lsize := lsp^.size; lsp := nil;
X              end
X            else error(116);
X      1:  end (*while*) ;
X        gen2(51(*ldc*),1,lsize);
X        gen1(30(*csp*),12(*new*));
X      end (*new*) ;
X
X      procedure mark;
X      begin variable(fsys+[rparent]);
X         if gattr.typtr <> nil then
X           if gattr.typtr^.form = pointer then
X         begin loadaddress; gen1(30(*csp*),23(*sav*)) end
X           else error(116)
X      end(*mark*);
X
X      procedure release;
X      begin variable(fsys+[rparent]);
X        if gattr.typtr <> nil then
X           if gattr.typtr^.form = pointer then
X              begin load; gen1(30(*csp*),13(*rst*)) end
X           else error(116)
X      end (*release*);
X
X
X
X      procedure abs;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr = intptr then gen0(0(*abi*))
X          else
X        if gattr.typtr = realptr then gen0(1(*abr*))
X        else begin error(125); gattr.typtr := intptr end
X      end (*abs*) ;
X
X      procedure sqr;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr = intptr then gen0(24(*sqi*))
X          else
X        if gattr.typtr = realptr then gen0(25(*sqr*))
X        else begin error(125); gattr.typtr := intptr end
X      end (*sqr*) ;
X
X      procedure trunc;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr <> realptr then error(125);
X        gen0(27(*trc*));
X        gattr.typtr := intptr
X      end (*trunc*) ;
X
X      procedure odd;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr <> intptr then error(125);
X        gen0(20(*odd*));
X        gattr.typtr := boolptr
X      end (*odd*) ;
X
X      procedure ord;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form >= power then error(125);
X        gen0t(58(*ord*),gattr.typtr);
X        gattr.typtr := intptr
X      end (*ord*) ;
X
X      procedure chr;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr <> intptr then error(125);
X        gen0(59(*chr*));
X        gattr.typtr := charptr
X      end (*chr*) ;
X
X      procedure predsucc;
X      begin
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form <> scalar then error(125);
X        if lkey = 7 then gen1t(31(*dec*),1,gattr.typtr)
X        else gen1t(34(*inc*),1,gattr.typtr)
X      end (*predsucc*) ;
X
X      procedure eof;
X      begin
X        if sy = lparent then
X          begin insymbol; variable(fsys + [rparent]);
X        if sy = rparent then insymbol else error(4)
X          end
X        else
X          with gattr do
X        begin typtr := textptr; kind := varbl; access := drct;
X          vlevel := 1; dplmt := lcaftermarkstack
X        end;
X        loadaddress;
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form <> files then error(125);
X        if lkey = 9 then gen0(8(*eof*)) else gen1(30(*csp*),14(*eln*));
X          gattr.typtr := boolptr
X      end (*eof*) ;
X
X
X
X      procedure callnonstandard;
X        var nxt,lcp: ctp; lsp: stp; lkind: idkind; lb: boolean;
X        locpar, llc: addrrange;
X      begin locpar := 0;
X        with fcp^ do
X          begin nxt := next; lkind := pfkind;
X        if not extern then gen1(41(*mst*),level-pflev)
X          end;
X        if sy = lparent then
X          begin llc := lc;
X        repeat lb := false; (*decide whether proc/func must be passed*)
X          if lkind = actual then
X            begin
X              if nxt = nil then error(126)
X              else lb := nxt^.klass in [proc,func]
X            end else error(399);
X          (*For formal proc/func, lb is false and expression
X           will be called, which will always interpret a proc/func id
X           at its beginning as a call rather than a parameter passing.
X           In this implementation, parameter procedures/functions
X           are therefore not allowed to have procedure/function
X           parameters*)
X          insymbol;
X          if lb then   (*pass function or procedure*)
X            begin error(399);
X              if sy <> ident then
X            begin error(2); skip(fsys + [comma,rparent]) end
X              else
X            begin
X              if nxt^.klass = proc then searchid([proc],lcp)
X              else
X                begin searchid([func],lcp);
X                  if not comptypes(lcp^.idtype,nxt^.idtype) then
X                error(128)
X                end;
X              insymbol;
X              if not (sy in fsys + [comma,rparent]) then
X                begin error(6); skip(fsys + [comma,rparent]) end
X            end
X            end (*if lb*)
X          else
X            begin expression(fsys + [comma,rparent]);
X              if gattr.typtr <> nil then
X            if lkind = actual then
X              begin
X                if nxt <> nil then
X                  begin lsp := nxt^.idtype;
X                if lsp <> nil then
X                  begin
X                    if (nxt^.vkind = actual) then
X                      if lsp^.form <= power then
X                    begin load;
X                      if debug then checkbnds(lsp);
X                      if comptypes(realptr,lsp)
X                         and (gattr.typtr = intptr) then
X                        begin gen0(10(*flt*));
X                          gattr.typtr := realptr
X                        end;
X                      locpar := locpar+lsp^.size;
X                      align(parmptr,locpar);
X                    end
X                      else
X                    begin
X                      loadaddress;
X                      locpar := locpar+ptrsize;
X                      align(parmptr,locpar)
X                    end
X                    else
X                      if gattr.kind = varbl then
X                    begin loadaddress;
X                      locpar := locpar+ptrsize;
X                      align(parmptr,locpar);
X                    end
X                      else error(154);
X                    if not comptypes(lsp,gattr.typtr) then
X                      error(142)
X                  end
X                  end
X              end
X              else (*lkind = formal*)
X            begin (*pass formal param*)
X            end
X            end;
X          if (lkind = actual) and (nxt <> nil) then nxt := nxt^.next
X        until sy <> comma;
X        lc := llc;
X        if sy = rparent then insymbol else error(4)
X          end (*if lparent*);
X        if lkind = actual then
X          begin if nxt <> nil then error(126);
X        with fcp^ do
X          begin
X            if extern then gen1(30(*csp*),pfname)
X            else gencupent(46(*cup*),locpar,pfname);
X          end
X          end;
X        gattr.typtr := fcp^.idtype
X      end (*callnonstandard*) ;
X
X    begin (*call*)
X      if fcp^.pfdeckind = standard then
X        begin lkey := fcp^.key;
X          if fcp^.klass = proc then
X           begin
X        if not(lkey in [5,6,11,12]) then
X          if sy = lparent then insymbol else error(9);
X        case lkey of
X          1,2,
X          3,4:  getputresetrewrite;
X          5,11: read;
X          6,12: write;
X          7:    pack;
X          8:    unpack;
X          9:    new;
X          10:   release;
X          13:   mark
X        end;
X        if not(lkey in [5,6,11,12]) then
X          if sy = rparent then insymbol else error(4)
X           end
X          else
X        begin
X          if lkey <= 8 then
X            begin
X              if sy = lparent then insymbol else error(9);
X              expression(fsys+[rparent]); load
X            end;
X          case lkey of
X            1:    abs;
X            2:    sqr;
X            3:    trunc;
X            4:    odd;
X            5:    ord;
X            6:    chr;
X            7,8:  predsucc;
X            9,10: eof
X          end;
X          if lkey <= 8 then
X            if sy = rparent then insymbol else error(4)
X        end;
X        end (*standard procedures and functions*)
X      else callnonstandard
X    end (*call*) ;
X
X    procedure expression;
X      var lattr: attr; lop: operator; typind: char; lsize: addrrange;
X
X      procedure simpleexpression(fsys: setofsys);
X        var lattr: attr; lop: operator; signed: boolean;
X
X        procedure term(fsys: setofsys);
X          var lattr: attr; lop: operator;
X
X          procedure factor(fsys: setofsys);
X        var lcp: ctp; lvp: csp; varpart: boolean;
X            cstpart: setty; lsp: stp;
X          begin
X        if not (sy in facbegsys) then
X          begin error(58); skip(fsys + facbegsys);
X            gattr.typtr := nil
X          end;
X        while sy in facbegsys do
X          begin
X            case sy of
X          (*id*)    ident:
X            begin searchid([konst,vars,field,func],lcp);
X              insymbol;
X              if lcp^.klass = func then
X                begin call(fsys,lcp);
X                  with gattr do
X                begin kind := expr;
X                  if typtr <> nil then
X                    if typtr^.form=subrange then
X                      typtr := typtr^.rangetype
X                end
X                end
X              else
X                if lcp^.klass = konst then
X                  with gattr, lcp^ do
X                begin typtr := idtype; kind := cst;
X                  cval := values
X                end
X                else
X                  begin selector(fsys,lcp);
X                if gattr.typtr<>nil then(*elim.subr.types to*)
X                  with gattr,typtr^ do(*simplify later tests*)
X                    if form = subrange then
X                      typtr := rangetype
X                  end
X            end;
X          (*cst*)   intconst:
X            begin
X              with gattr do
X                begin typtr := intptr; kind := cst;
X                  cval := val
X                end;
X              insymbol
X            end;
X              realconst:
X            begin
X              with gattr do
X                begin typtr := realptr; kind := cst;
X                  cval := val
X                end;
X              insymbol
X            end;
X              stringconst:
X            begin
X              with gattr do
X                begin
X                  if lgth = 1 then typtr := charptr
X                  else
X                begin new(lsp,arrays);
X                  with lsp^ do
X                    begin aeltype := charptr; form:=arrays;
X                      inxtype := nil; size := lgth*charsize
X                    end;
X                  typtr := lsp
X                end;
X                  kind := cst; cval := val
X                end;
X              insymbol
X            end;
X          (* ( *)   lparent:
X            begin insymbol; expression(fsys + [rparent]);
X              if sy = rparent then insymbol else error(4)
X            end;
X          (*not*)   notsy:
X            begin insymbol; factor(fsys);
X              load; gen0(19(*not*));
X              if gattr.typtr <> nil then
X                if gattr.typtr <> boolptr then
X                  begin error(135); gattr.typtr := nil end;
X            end;
X          (*[*)     lbrack:
X            begin insymbol; cstpart := [ ]; varpart := false;
X              new(lsp,power);
X              with lsp^ do
X                begin elset:=nil;size:=setsize;form:=power end;
X              if sy = rbrack then
X                begin
X                  with gattr do
X                begin typtr := lsp; kind := cst end;
X                  insymbol
X                end
X              else
X                begin
X                  repeat expression(fsys + [comma,rbrack]);
X                if gattr.typtr <> nil then
X                  if gattr.typtr^.form <> scalar then
X                    begin error(136); gattr.typtr := nil end
X                  else
X                    if comptypes(lsp^.elset,gattr.typtr) then
X                      begin
X                    if gattr.kind = cst then
X                      if (gattr.cval.ival < setlow) or
X                        (gattr.cval.ival > sethigh) then
X                        error(304)
X                      else
X                        cstpart := cstpart+[gattr.cval.ival]
X                    else
X                      begin load;
X                        if not comptypes(gattr.typtr,intptr)
X                        then gen0t(58(*ord*),gattr.typtr);
X                        gen0(23(*sgs*));
X                        if varpart then gen0(28(*uni*))
X                        else varpart := true
X                      end;
X                    lsp^.elset := gattr.typtr;
X                    gattr.typtr := lsp
X                      end
X                    else error(137);
X                test := sy <> comma;
X                if not test then insymbol
X                  until test;
X                  if sy = rbrack then insymbol else error(12)
X                end;
X              if varpart then
X                begin
X                  if cstpart <> [ ] then
X                begin new(lvp,pset); lvp^.pval := cstpart;
X                  lvp^.cclass := pset;
X                  if cstptrix = cstoccmax then error(254)
X                  else
X                    begin cstptrix := cstptrix + 1;
X                      cstptr[cstptrix] := lvp;
X                      gen2(51(*ldc*),5,cstptrix);
X                      gen0(28(*uni*)); gattr.kind := expr
X                    end
X                end
X                end
X              else
X                begin new(lvp,pset); lvp^.pval := cstpart;
X                  lvp^.cclass := pset;
X                  gattr.cval.valp := lvp
X                end
X            end
X            end (*case*) ;
X            if not (sy in fsys) then
X              begin error(6); skip(fsys + facbegsys) end
X          end (*while*)
X          end (*factor*) ;
X
X        begin (*term*)
X          factor(fsys + [mulop]);
X          while sy = mulop do
X        begin load; lattr := gattr; lop := op;
X          insymbol; factor(fsys + [mulop]); load;
X          if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
X            case lop of
X        (***)     mul:  if (lattr.typtr=intptr)and(gattr.typtr=intptr)
X                then gen0(15(*mpi*))
X                else
X                  begin
X                if lattr.typtr = intptr then
X                  begin gen0(9(*flo*));
X                    lattr.typtr := realptr
X                  end
X                else
X                  if gattr.typtr = intptr then
X                    begin gen0(10(*flt*));
X                      gattr.typtr := realptr
X                    end;
X                if (lattr.typtr = realptr)
X                  and(gattr.typtr=realptr)then gen0(16(*mpr*))
X                else
X                  if(lattr.typtr^.form=power)
X                    and comptypes(lattr.typtr,gattr.typtr)then
X                    gen0(12(*int*))
X                  else begin error(134); gattr.typtr:=nil end
X                  end;
X        (* / *)   rdiv: begin
X                  if gattr.typtr = intptr then
X                begin gen0(10(*flt*));
X                  gattr.typtr := realptr
X                end;
X                  if lattr.typtr = intptr then
X                begin gen0(9(*flo*));
X                  lattr.typtr := realptr
X                end;
X                  if (lattr.typtr = realptr)
X                and (gattr.typtr=realptr)then gen0(7(*dvr*))
X                  else begin error(134); gattr.typtr := nil end
X                end;
X        (*div*)   idiv: if (lattr.typtr = intptr)
X                  and (gattr.typtr = intptr) then gen0(6(*dvi*))
X                else begin error(134); gattr.typtr := nil end;
X        (*mod*)   imod: if (lattr.typtr = intptr)
X                  and (gattr.typtr = intptr) then gen0(14(*mod*))
X                else begin error(134); gattr.typtr := nil end;
X        (*and*)   andop:if (lattr.typtr = boolptr)
X                  and (gattr.typtr = boolptr) then gen0(4(*and*))
X                else begin error(134); gattr.typtr := nil end
X            end (*case*)
X          else gattr.typtr := nil
X        end (*while*)
X        end (*term*) ;
X
X      begin (*simpleexpression*)
X        signed := false;
X        if (sy = addop) and (op in [plus,minus]) then
X          begin signed := op = minus; insymbol end;
X        term(fsys + [addop]);
X        if signed then
X          begin load;
X        if gattr.typtr = intptr then gen0(17(*ngi*))
X        else
X          if gattr.typtr = realptr then gen0(18(*ngr*))
X          else begin error(134); gattr.typtr := nil end
X          end;
X        while sy = addop do
X          begin load; lattr := gattr; lop := op;
X        insymbol; term(fsys + [addop]); load;
X        if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
X          case lop of
X      (*+*)       plus:
X              if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
X            gen0(2(*adi*))
X              else
X            begin
X              if lattr.typtr = intptr then
X                begin gen0(9(*flo*));
X                  lattr.typtr := realptr
X                end
X              else
X                if gattr.typtr = intptr then
X                  begin gen0(10(*flt*));
X                gattr.typtr := realptr
X                  end;
X              if (lattr.typtr = realptr)and(gattr.typtr = realptr)
X                then gen0(3(*adr*))
X              else if(lattr.typtr^.form=power)
X                 and comptypes(lattr.typtr,gattr.typtr) then
X                 gen0(28(*uni*))
X                   else begin error(134); gattr.typtr:=nil end
X            end;
X      (*-*)       minus:
X              if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
X            gen0(21(*sbi*))
X              else
X            begin
X              if lattr.typtr = intptr then
X                begin gen0(9(*flo*));
X                  lattr.typtr := realptr
X                end
X              else
X                if gattr.typtr = intptr then
X                  begin gen0(10(*flt*));
X                gattr.typtr := realptr
X                  end;
X              if (lattr.typtr = realptr)and(gattr.typtr = realptr)
X                then gen0(22(*sbr*))
X              else
X                if (lattr.typtr^.form = power)
X                  and comptypes(lattr.typtr,gattr.typtr) then
X                  gen0(5(*dif*))
X                else begin error(134); gattr.typtr := nil end
X            end;
X      (*or*)      orop:
X              if(lattr.typtr=boolptr)and(gattr.typtr=boolptr)then
X            gen0(13(*ior*))
X              else begin error(134); gattr.typtr := nil end
X          end (*case*)
X        else gattr.typtr := nil
X          end (*while*)
X      end (*simpleexpression*) ;
X
X    begin (*expression*)
X      simpleexpression(fsys + [relop]);
X      if sy = relop then
X        begin
X          if gattr.typtr <> nil then
X        if gattr.typtr^.form <= power then load
X        else loadaddress;
X          lattr := gattr; lop := op;
X          if lop = inop then
X        if not comptypes(gattr.typtr,intptr) then
X          gen0t(58(*ord*),gattr.typtr);
X          insymbol; simpleexpression(fsys);
X          if gattr.typtr <> nil then
X        if gattr.typtr^.form <= power then load
X        else loadaddress;
X          if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
X        if lop = inop then
X          if gattr.typtr^.form = power then
X            if comptypes(lattr.typtr,gattr.typtr^.elset) then
X              gen0(11(*inn*))
X            else begin error(129); gattr.typtr := nil end
X          else begin error(130); gattr.typtr := nil end
X        else
X          begin
X            if lattr.typtr <> gattr.typtr then
X              if lattr.typtr = intptr then
X            begin gen0(9(*flo*));
X              lattr.typtr := realptr
X            end
X              else
X            if gattr.typtr = intptr then
X              begin gen0(10(*flt*));
X                gattr.typtr := realptr
X              end;
X            if comptypes(lattr.typtr,gattr.typtr) then
X              begin lsize := lattr.typtr^.size;
X            case lattr.typtr^.form of
X              scalar:
X                if lattr.typtr = realptr then typind := 'r'
X                else
X                  if lattr.typtr = boolptr then typind := 'b'
X                  else
X                if lattr.typtr = charptr then typind := 'c'
X                else typind := 'i';
X              pointer:
X                begin
X                  if lop in [ltop,leop,gtop,geop] then error(131);
X                  typind := 'a'
X                end;
X              power:
X                begin if lop in [ltop,gtop] then error(132);
X                  typind := 's'
X                end;
X              arrays:
X                begin
X                  if not string(lattr.typtr)
X                then error(134);
X                  typind := 'm'
X                end;
X              records:
X                begin
X                  error(134);
X                  typind := 'm'
X                end;
X              files:
X                begin error(133); typind := 'f' end
X            end;
X            case lop of
X              ltop: gen2(53(*les*),ord(typind),lsize);
X              leop: gen2(52(*leq*),ord(typind),lsize);
X              gtop: gen2(49(*grt*),ord(typind),lsize);
X              geop: gen2(48(*geq*),ord(typind),lsize);
X              neop: gen2(55(*neq*),ord(typind),lsize);
X              eqop: gen2(47(*equ*),ord(typind),lsize)
X            end
X              end
X            else error(129)
X          end;
X          gattr.typtr := boolptr; gattr.kind := expr
X        end (*sy = relop*)
X    end (*expression*) ;
X
X    procedure assignment(fcp: ctp);
X      var lattr: attr;
X    begin selector(fsys + [becomes],fcp);
X      if sy = becomes then
X        begin
X          if gattr.typtr <> nil then
X        if (gattr.access<>drct) or (gattr.typtr^.form>power) then
X          loadaddress;
X          lattr := gattr;
X          insymbol; expression(fsys);
X          if gattr.typtr <> nil then
X        if gattr.typtr^.form <= power then load
X        else loadaddress;
X          if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
X        begin
X          if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then
X            begin gen0(10(*flt*));
X              gattr.typtr := realptr
X            end;
X          if comptypes(lattr.typtr,gattr.typtr) then
X            case lattr.typtr^.form of
X              scalar,
X              subrange: begin
X                  if debug then checkbnds(lattr.typtr);
X                  store(lattr)
X                end;
X              pointer: begin
X                 if debug then
X                   gen2t(45(*chk*),0,maxaddr,nilptr);
X                 store(lattr)
X                   end;
X              power:   store(lattr);
X              arrays,
X              records: gen1(40(*mov*),lattr.typtr^.size);
X              files: error(146)
X            end
X          else error(129)
X        end
X        end (*sy = becomes*)
X      else error(51)
X    end (*assignment*) ;
X
X    procedure gotostatement;
X      var llp: lbp; found: boolean; ttop,ttop1: disprange;
X    begin
X      if sy = intconst then
X        begin
X          found := false;
X          ttop := top;
X          while display[ttop].occur <> blck do ttop := ttop - 1;
X          ttop1 := ttop;
X          repeat
X        llp := display[ttop].flabel;
X        while (llp <> nil) and not found do
X          with llp^ do
X            if labval = val.ival then
X              begin found := true;
X            if ttop = ttop1 then
X              genujpxjp(57(*ujp*),labname)
X            else (*goto leads out of procedure*) error(399)
X              end
X            else llp := nextlab;
X        ttop := ttop - 1
X          until found or (ttop = 0);
X          if not found then error(167);
X          insymbol
X        end
X      else error(15)
X    end (*gotostatement*) ;
X
X    procedure compoundstatement;
X    begin
X      repeat
X        repeat statement(fsys + [semicolon,endsy])
X        until not (sy in statbegsys);
X        test := sy <> semicolon;
X        if not test then insymbol
X      until test;
X      if sy = endsy then insymbol else error(13)
X    end (*compoundstatemenet*) ;
X
X    procedure ifstatement;
X      var lcix1,lcix2: integer;
X    begin expression(fsys + [thensy]);
X      genlabel(lcix1); genfjp(lcix1);
X      if sy = thensy then insymbol else error(52);
X      statement(fsys + [elsesy]);
X      if sy = elsesy then
X        begin genlabel(lcix2); genujpxjp(57(*ujp*),lcix2);
X          putlabel(lcix1);
X          insymbol; statement(fsys);
X          putlabel(lcix2)
X        end
X      else putlabel(lcix1)
X    end (*ifstatement*) ;
X
X    procedure casestatement;
X      label 1;
X      type cip = ^caseinfo;
X           caseinfo = packed
X              record next: cip;
X                csstart: integer;
X                cslab: integer
X              end;
X      var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu;
X          laddr, lcix, lcix1, lmin, lmax: integer;
X    begin expression(fsys + [ofsy,comma,colon]);
X      load; genlabel(lcix);
X      lsp := gattr.typtr;
X      if lsp <> nil then
X        if (lsp^.form <> scalar) or (lsp = realptr) then
X          begin error(144); lsp := nil end
X        else if not comptypes(lsp,intptr) then gen0t(58(*ord*),lsp);
X      genujpxjp(57(*ujp*),lcix);
X      if sy = ofsy then insymbol else error(8);
X      fstptr := nil; genlabel(laddr);
X      repeat
X        lpt3 := nil; genlabel(lcix1);
X        if not(sy in [semicolon,endsy]) then
X          begin
X        repeat constant(fsys + [comma,colon],lsp1,lval);
X          if lsp <> nil then
X            if comptypes(lsp,lsp1) then
X              begin lpt1 := fstptr; lpt2 := nil;
X            while lpt1 <> nil do
X              with lpt1^ do
X                begin
X                  if cslab <= lval.ival then
X                begin if cslab = lval.ival then error(156);
X                  goto 1
X                end;
X                  lpt2 := lpt1; lpt1 := next
X                end;
X        1:      new(lpt3);
X            with lpt3^ do
X              begin next := lpt1; cslab := lval.ival;
X                csstart := lcix1
X              end;
X            if lpt2 = nil then fstptr := lpt3
X            else lpt2^.next := lpt3
X              end
X            else error(147);
X          test := sy <> comma;
X          if not test then insymbol
X        until test;
X        if sy = colon then insymbol else error(5);
X        putlabel(lcix1);
X        repeat statement(fsys + [semicolon])
X        until not (sy in statbegsys);
X        if lpt3 <> nil then
X          genujpxjp(57(*ujp*),laddr);
X          end;
X        test := sy <> semicolon;
X        if not test then insymbol
X      until test;
X      putlabel(lcix);
X      if fstptr <> nil then
X        begin lmax := fstptr^.cslab;
X          (*reverse pointers*)
X          lpt1 := fstptr; fstptr := nil;
X          repeat lpt2 := lpt1^.next; lpt1^.next := fstptr;
X        fstptr := lpt1; lpt1 := lpt2
X          until lpt1 = nil;
X          lmin := fstptr^.cslab;
X          if lmax - lmin < cixmax then
X        begin
X          gen2t(45(*chk*),lmin,lmax,intptr);
X          gen2(51(*ldc*),1,lmin); gen0(21(*sbi*)); genlabel(lcix);
X          genujpxjp(44(*xjp*),lcix); putlabel(lcix);
X          repeat
X            with fstptr^ do
X              begin
X            while cslab > lmin do
X               begin gen0(60(*ujc error*));
X                 lmin := lmin+1
X               end;
X            genujpxjp(57(*ujp*),csstart);
X            fstptr := next; lmin := lmin + 1
X              end
X          until fstptr = nil;
X          putlabel(laddr)
X        end
X          else error(157)
X        end;
X        if sy = endsy then insymbol else error(13)
X    end (*casestatement*) ;
X
X    procedure repeatstatement;
X      var laddr: integer;
X    begin genlabel(laddr); putlabel(laddr);
X      repeat statement(fsys + [semicolon,untilsy]);
X        if sy in statbegsys then error(14)
X      until not(sy in statbegsys);
X      while sy = semicolon do
X        begin insymbol;
X          repeat statement(fsys + [semicolon,untilsy]);
X        if sy in statbegsys then error(14)
X          until not (sy in statbegsys);
X        end;
X      if sy = untilsy then
X        begin insymbol; expression(fsys); genfjp(laddr)
X        end
X      else error(53)
X    end (*repeatstatement*) ;
X
X    procedure whilestatement;
X      var laddr, lcix: integer;
X    begin genlabel(laddr); putlabel(laddr);
X      expression(fsys + [dosy]); genlabel(lcix); genfjp(lcix);
X      if sy = dosy then insymbol else error(54);
X      statement(fsys); genujpxjp(57(*ujp*),laddr); putlabel(lcix)
X    end (*whilestatement*) ;
X
X    procedure forstatement;
X      var lattr: attr;  lsy: symbol;
X          lcix, laddr: integer;
X            llc: addrrange;
X    begin llc := lc;
X      with lattr do
X        begin typtr := nil; kind := varbl;
X          access := drct; vlevel := level; dplmt := 0
X        end;
X      if sy = ident then
X        begin searchid([vars],lcp);
X          with lcp^, lattr do
X        begin typtr := idtype; kind := varbl;
X          if vkind = actual then
X            begin access := drct; vlevel := vlev;
X              dplmt := vaddr
X            end
X          else begin error(155); typtr := nil end
X        end;
X          if lattr.typtr <> nil then
X        if (lattr.typtr^.form > subrange)
X           or comptypes(realptr,lattr.typtr) then
X          begin error(143); lattr.typtr := nil end;
X          insymbol
X        end
X      else
X        begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end;
X      if sy = becomes then
X        begin insymbol; expression(fsys + [tosy,downtosy,dosy]);
X          if gattr.typtr <> nil then
X          if gattr.typtr^.form <> scalar then error(144)
X          else
X            if comptypes(lattr.typtr,gattr.typtr) then
X              begin load; store(lattr) end
X            else error(145)
X        end
X      else
X        begin error(51); skip(fsys + [tosy,downtosy,dosy]) end;
X      if sy in [tosy,downtosy] then
X        begin lsy := sy; insymbol; expression(fsys + [dosy]);
X          if gattr.typtr <> nil then
X          if gattr.typtr^.form <> scalar then error(144)
X        else
X          if comptypes(lattr.typtr,gattr.typtr) then
X            begin load;
X              if not comptypes(lattr.typtr,intptr) then
X            gen0t(58(*ord*),gattr.typtr);
X              align(intptr,lc);
X              gen2t(56(*str*),0,lc,intptr);
X              genlabel(laddr); putlabel(laddr);
X              gattr := lattr; load;
X              if not comptypes(gattr.typtr,intptr) then
X            gen0t(58(*ord*),gattr.typtr);
X              gen2t(54(*lod*),0,lc,intptr);
X              lc := lc + intsize;
X              if lc > lcmax then lcmax := lc;
X              if lsy = tosy then gen2(52(*leq*),ord('i'),1)
X              else gen2(48(*geq*),ord('i'),1);
X            end
X          else error(145)
X        end
X      else begin error(55); skip(fsys + [dosy]) end;
X      genlabel(lcix); genujpxjp(33(*fjp*),lcix);
X      if sy = dosy then insymbol else error(54);
X      statement(fsys);
X      gattr := lattr; load;
X      if lsy=tosy then gen1t(34(*inc*),1,gattr.typtr)
X      else  gen1t(31(*dec*),1,gattr.typtr);
X      store(lattr); genujpxjp(57(*ujp*),laddr); putlabel(lcix);
X      lc := llc;
X    end (*forstatement*) ;
X
X
X    procedure withstatement;
X      var lcp: ctp; lcnt1: disprange; llc: addrrange;
X    begin lcnt1 := 0; llc := lc;
X      repeat
X        if sy = ident then
X          begin searchid([vars,field],lcp); insymbol end
X        else begin error(2); lcp := uvarptr end;
X        selector(fsys + [comma,dosy],lcp);
X        if gattr.typtr <> nil then
X          if gattr.typtr^.form = records then
X        if top < displimit then
X          begin top := top + 1; lcnt1 := lcnt1 + 1;
X            with display[top] do
X              begin fname := gattr.typtr^.fstfld;
X            flabel := nil
X              end;
X            if gattr.access = drct then
X              with display[top] do
X            begin occur := crec; clev := gattr.vlevel;
X              cdspl := gattr.dplmt
X            end
X            else
X              begin loadaddress;
X            align(nilptr,lc);
X            gen2t(56(*str*),0,lc,nilptr);
X            with display[top] do
X              begin occur := vrec; vdspl := lc end;
X            lc := lc+ptrsize;
X            if lc > lcmax then lcmax := lc
X              end
X          end
X        else error(250)
X          else error(140);
X        test := sy <> comma;
X        if not test then insymbol
X      until test;
X      if sy = dosy then insymbol else error(54);
X      statement(fsys);
X      top := top-lcnt1; lc := llc;
X    end (*withstatement*) ;
X
X      begin (*statement*)
X    if sy = intconst then (*label*)
X      begin llp := display[level].flabel;
X        while llp <> nil do
X          with llp^ do
X        if labval = val.ival then
X          begin if defined then error(165);
X            putlabel(labname); defined := true;
X            goto 1
X          end
X        else llp := nextlab;
X        error(167);
X      1:    insymbol;
X        if sy = colon then insymbol else error(5)
X      end;
X    if not (sy in fsys + [ident]) then
X      begin error(6); skip(fsys) end;
X    if sy in statbegsys + [ident] then
X      begin
X        case sy of
X          ident:    begin searchid([vars,field,func,proc],lcp); insymbol;
X              if lcp^.klass = proc then call(fsys,lcp)
X              else assignment(lcp)
X            end;
X          beginsy:  begin insymbol; compoundstatement end;
X          gotosy:   begin insymbol; gotostatement end;
X          ifsy:     begin insymbol; ifstatement end;
X          casesy:   begin insymbol; casestatement end;
X          whilesy:  begin insymbol; whilestatement end;
X          repeatsy: begin insymbol; repeatstatement end;
X          forsy:    begin insymbol; forstatement end;
X          withsy:   begin insymbol; withstatement end
X        end;
X        if not (sy in [semicolon,endsy,elsesy,untilsy]) then
X          begin error(6); skip(fsys) end
X      end
X      end (*statement*) ;
X
X    begin (*body*)
X      if fprocp <> nil then entname := fprocp^.pfname
X      else genlabel(entname);
X      cstptrix := 0; topnew := lcaftermarkstack; topmax := lcaftermarkstack;
X      putlabel(entname); genlabel(segsize); genlabel(stacktop);
X      gencupent(32(*ent1*),1,segsize); gencupent(32(*ent2*),2,stacktop);
X      if fprocp <> nil then (*copy multiple values into local cells*)
X    begin llc1 := lcaftermarkstack;
X      lcp := fprocp^.next;
X      while lcp <> nil do
X        with lcp^ do
X          begin
X        align(parmptr,llc1);
X        if klass = vars then
X          if idtype <> nil then
X            if idtype^.form > power then
X              begin
X            if vkind = actual then
X              begin
X                gen2(50(*lda*),0,vaddr);
X                gen2t(54(*lod*),0,llc1,nilptr);
X                gen1(40(*mov*),idtype^.size);
X              end;
X            llc1 := llc1 + ptrsize
X              end
X            else llc1 := llc1 + idtype^.size;
X        lcp := lcp^.next;
X          end;
X    end;
X      lcmax := lc;
X      repeat
X    repeat statement(fsys + [semicolon,endsy])
X    until not (sy in statbegsys);
X    test := sy <> semicolon;
X    if not test then insymbol
X      until test;
X      if sy = endsy then insymbol else error(13);
X      llp := display[top].flabel; (*test for undefined labels*)
X      while llp <> nil do
X    with llp^ do
X      begin
X        if not defined then
X          begin error(168);
X        writeln(output); writeln(output,' label ',labval);
X        write(output,' ':chcnt+16)
X          end;
X        llp := nextlab
X      end;
X      if fprocp <> nil then
X    begin
X      if fprocp^.idtype = nil then gen1(42(*ret*),ord('p'))
X      else gen0t(42(*ret*),fprocp^.idtype);
X      align(parmptr,lcmax);
X      if prcode then
X        begin writeln(prr,'l',segsize:4,'=',lcmax);
X          writeln(prr,'l',stacktop:4,'=',topmax)
X        end
X    end
X      else
X    begin gen1(42(*ret*),ord('p'));
X      align(parmptr,lcmax);
X      if prcode then
SHAR_EOF
true || echo 'restore of pcom.p failed'
fi
echo 'End of  part 2'
echo 'File pcom.p is continued in part 3'
echo 3 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].