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

Text File | 1991-09-27 | 48.8 KB | 1,557 lines

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

Submitted-by: [e-mail] (Steven Pemberton)
Posting-number: Volume 23, Issue 27
Archive-name: pascal/part03
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" != 3; 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        begin writeln(prr,'l',segsize:4,'=',lcmax);
X          writeln(prr,'l',stacktop:4,'=',topmax);
X          writeln(prr,'q')
X        end;
X      ic := 0;
X      (*generate call of main program; note that this call must be loaded
X        at absolute address zero*)
X      gen1(41(*mst*),0); gencupent(46(*cup*),0,entname); gen0(29(*stp*));
X      if prcode then
X        writeln(prr,'q');
X      saveid := id;
X      while fextfilep <> nil do
X        begin
X          with fextfilep^ do
X        if not ((filename = 'input   ') or (filename = 'output  ') or
X            (filename = 'prd     ') or (filename = 'prr     '))
X        then begin id := filename;
X               searchid([vars],llcp);
X               if llcp^.idtype<>nil then
X             if llcp^.idtype^.form<>files then
X               begin writeln(output);
X                 writeln(output,' ':8,'undeclared ','external ',
X                   'file',fextfilep^.filename:8);
X                 write(output,' ':chcnt+16)
X               end
X             end;
X        fextfilep := fextfilep^.nextfile
X        end;
X      id := saveid;
X      if prtables then
X        begin writeln(output); printtables(true)
X        end
X    end;
X    end (*body*) ;
X
X  begin (*block*)
X    dp := true;
X    repeat
X      if sy = labelsy then
X    begin insymbol; labeldeclaration end;
X      if sy = constsy then
X    begin insymbol; constdeclaration end;
X      if sy = typesy then
X    begin insymbol; typedeclaration end;
X      if sy = varsy then
X    begin insymbol; vardeclaration end;
X      while sy in [procsy,funcsy] do
X    begin lsy := sy; insymbol; procdeclaration(lsy) end;
X      if sy <> beginsy then
X    begin error(18); skip(fsys) end
X    until (sy in statbegsys) or eof(input);
X    dp := false;
X    if sy = beginsy then insymbol else error(17);
X    repeat body(fsys + [casesy]);
X      if sy <> fsy then
X    begin error(6); skip(fsys) end
X    until ((sy = fsy) or (sy in blockbegsys)) or eof(input);
X  end (*block*) ;
X
X  procedure programme(fsys:setofsys);
X    var extfp:extfilep;
X  begin
X    if sy = progsy then
X      begin insymbol; if sy <> ident then error(2); insymbol;
X    if not (sy in [lparent,semicolon]) then error(14);
X    if sy = lparent  then
X      begin
X        repeat insymbol;
X          if sy = ident then
X        begin new(extfp);
X          with extfp^ do
X            begin filename := id; nextfile := fextfilep end;
X          fextfilep := extfp;
X          insymbol;
X          if not ( sy in [comma,rparent] ) then error(20)
X        end
X          else error(2)
X        until sy <> comma;
X        if sy <> rparent then error(4);
X        insymbol
X      end;
X    if sy <> semicolon then error(14)
X    else insymbol;
X      end;
X    repeat block(fsys,period,nil);
X      if sy <> period then error(21)
X    until (sy = period) or eof(input);
X    if list then writeln(output);
X    if errinx <> 0 then
X      begin list := false; endofline end
X  end (*programme*) ;
X
X
X  procedure stdnames;
X  begin
X    na[ 1] := 'false   '; na[ 2] := 'true    '; na[ 3] := 'input   ';
X    na[ 4] := 'output  '; na[ 5] := 'get     '; na[ 6] := 'put     ';
X    na[ 7] := 'reset   '; na[ 8] := 'rewrite '; na[ 9] := 'read    ';
X    na[10] := 'write   '; na[11] := 'pack    '; na[12] := 'unpack  ';
X    na[13] := 'new     '; na[14] := 'release '; na[15] := 'readln  ';
X    na[16] := 'writeln ';
X    na[17] := 'abs     '; na[18] := 'sqr     '; na[19] := 'trunc   ';
X    na[20] := 'odd     '; na[21] := 'ord     '; na[22] := 'chr     ';
X    na[23] := 'pred    '; na[24] := 'succ    '; na[25] := 'eof     ';
X    na[26] := 'eoln    ';
X    na[27] := 'sin     '; na[28] := 'cos     '; na[29] := 'exp     ';
X    na[30] := 'sqrt    '; na[31] := 'ln      '; na[32] := 'arctan  ';
X    na[33] := 'prd     '; na[34] := 'prr     '; na[35] := 'mark    ';
X  end (*stdnames*) ;
X
X  procedure enterstdtypes;
X
X  begin                         (*type underlying:*)
X                            (******************)
X
X    new(intptr,scalar,standard);                  (*integer*)
X    with intptr^ do
X      begin size := intsize; form := scalar; scalkind := standard end;
X    new(realptr,scalar,standard);                 (*real*)
X    with realptr^ do
X      begin size := realsize; form := scalar; scalkind := standard end;
X    new(charptr,scalar,standard);                 (*char*)
X    with charptr^ do
X      begin size := charsize; form := scalar; scalkind := standard end;
X    new(boolptr,scalar,declared);                 (*boolean*)
X    with boolptr^ do
X      begin size := boolsize; form := scalar; scalkind := declared end;
X    new(nilptr,pointer);                      (*nil*)
X    with nilptr^ do
X      begin eltype := nil; size := ptrsize; form := pointer end;
X    new(parmptr,scalar,standard); (*for alignment of parameters*)
X    with parmptr^ do
X      begin size := parmsize; form := scalar; scalkind := standard end ;
X    new(textptr,files);                       (*text*)
X    with textptr^ do
X      begin filtype := charptr; size := charsize; form := files end
X  end (*enterstdtypes*) ;
X
X  procedure entstdnames;
X    var cp,cp1: ctp; i: integer;
X  begin                               (*name:*)
X                                  (*******)
X
X    new(cp,types);                        (*integer*)
X    with cp^ do
X      begin name := 'integer '; idtype := intptr; klass := types end;
X    enterid(cp);
X    new(cp,types);                        (*real*)
X    with cp^ do
X      begin name := 'real    '; idtype := realptr; klass := types end;
X    enterid(cp);
X    new(cp,types);                        (*char*)
X    with cp^ do
X      begin name := 'char    '; idtype := charptr; klass := types end;
X    enterid(cp);
X    new(cp,types);                        (*boolean*)
X    with cp^ do
X      begin name := 'boolean '; idtype := boolptr; klass := types end;
X    enterid(cp);
X    cp1 := nil;
X    for i := 1 to 2 do
X      begin new(cp,konst);                    (*false,true*)
X    with cp^ do
X      begin name := na[i]; idtype := boolptr;
X        next := cp1; values.ival := i - 1; klass := konst
X      end;
X    enterid(cp); cp1 := cp
X      end;
X    boolptr^.fconst := cp;
X    new(cp,konst);                        (*nil*)
X    with cp^ do
X      begin name := 'nil     '; idtype := nilptr;
X    next := nil; values.ival := 0; klass := konst
X      end;
X    enterid(cp);
X    for i := 3 to 4 do
X      begin new(cp,vars);                     (*input,output*)
X    with cp^ do
X      begin name := na[i]; idtype := textptr; klass := vars;
X        vkind := actual; next := nil; vlev := 1;
X        vaddr := lcaftermarkstack+(i-3)*charmax;
X      end;
X    enterid(cp)
X      end;
X    for i:=33 to 34 do
X      begin new(cp,vars);                     (*prd,prr files*)
X     with cp^ do
X       begin name := na[i]; idtype := textptr; klass := vars;
X          vkind := actual; next := nil; vlev := 1;
X          vaddr := lcaftermarkstack+(i-31)*charmax;
X       end;
X     enterid(cp)
X      end;
X    for i := 5 to 16 do
X      begin new(cp,proc,standard);                (*get,put,reset*)
X    with cp^ do                       (*rewrite,read*)
X      begin name := na[i]; idtype := nil;         (*write,pack*)
X        next := nil; key := i - 4;            (*unpack,pack*)
X        klass := proc; pfdeckind := standard
X      end;
X    enterid(cp)
X      end;
X    new(cp,proc,standard);
X    with cp^ do
X      begin name:=na[35]; idtype:=nil;
X        next:= nil; key:=13;
X        klass:=proc; pfdeckind:= standard
X      end; enterid(cp);
X    for i := 17 to 26 do
X      begin new(cp,func,standard);                (*abs,sqr,trunc*)
X    with cp^ do                       (*odd,ord,chr*)
X      begin name := na[i]; idtype := nil;         (*pred,succ,eof*)
X        next := nil; key := i - 16;
X        klass := func; pfdeckind := standard
X      end;
X    enterid(cp)
X      end;
X    new(cp,vars);              (*parameter of predeclared functions*)
X    with cp^ do
X      begin name := '        '; idtype := realptr; klass := vars;
X    vkind := actual; next := nil; vlev := 1; vaddr := 0
X      end;
X    for i := 27 to 32 do
X      begin new(cp1,func,declared,actual);            (*sin,cos,exp*)
X    with cp1^ do                      (*sqrt,ln,arctan*)
X      begin name := na[i]; idtype := realptr; next := cp;
X        forwdecl := false; extern := true; pflev := 0; pfname := i - 12;
X        klass := func; pfdeckind := declared; pfkind := actual
X      end;
X    enterid(cp1)
X      end
X  end (*entstdnames*) ;
X
X  procedure enterundecl;
X  begin
X    new(utypptr,types);
X    with utypptr^ do
X      begin name := '        '; idtype := nil; klass := types end;
X    new(ucstptr,konst);
X    with ucstptr^ do
X      begin name := '        '; idtype := nil; next := nil;
X    values.ival := 0; klass := konst
X      end;
X    new(uvarptr,vars);
X    with uvarptr^ do
X      begin name := '        '; idtype := nil; vkind := actual;
X    next := nil; vlev := 0; vaddr := 0; klass := vars
X      end;
X    new(ufldptr,field);
X    with ufldptr^ do
X      begin name := '        '; idtype := nil; next := nil; fldaddr := 0;
X    klass := field
X      end;
X    new(uprcptr,proc,declared,actual);
X    with uprcptr^ do
X      begin name := '        '; idtype := nil; forwdecl := false;
X    next := nil; extern := false; pflev := 0; genlabel(pfname);
X    klass := proc; pfdeckind := declared; pfkind := actual
X      end;
X    new(ufctptr,func,declared,actual);
X    with ufctptr^ do
X      begin name := '        '; idtype := nil; next := nil;
X    forwdecl := false; extern := false; pflev := 0; genlabel(pfname);
X    klass := func; pfdeckind := declared; pfkind := actual
X      end
X  end (*enterundecl*) ;
X
X  procedure initscalars;
X  begin fwptr := nil;
X    prtables := false; list := true; prcode := true; debug := true;
X    dp := true; prterr := true; errinx := 0;
X    intlabel := 0; kk := 8; fextfilep := nil;
X    lc := lcaftermarkstack+filebuffer*charmax;
X    (* note in the above reservation of buffer store for 2 text files *)
X    ic := 3; eol := true; linecount := 0;
X    ch := ' '; chcnt := 0;
X    globtestp := nil;
X    mxint10 := maxint div 10; digmax := strglgth - 1;
X  end (*initscalars*) ;
X
X  procedure initsets;
X  begin
X    constbegsys := [addop,intconst,realconst,stringconst,ident];
X    simptypebegsys := [lparent] + constbegsys;
X    typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys;
X    typedels := [arraysy,recordsy,setsy,filesy];
X    blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
X    selectsys := [arrow,period,lbrack];
X    facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
X    statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy];
X  end (*initsets*) ;
X
X  procedure inittables;
X    procedure reswords;
X    begin
X      rw[ 1] := 'if      '; rw[ 2] := 'do      '; rw[ 3] := 'of      ';
X      rw[ 4] := 'to      '; rw[ 5] := 'in      '; rw[ 6] := 'or      ';
X      rw[ 7] := 'end     '; rw[ 8] := 'for     '; rw[ 9] := 'var     ';
X      rw[10] := 'div     '; rw[11] := 'mod     '; rw[12] := 'set     ';
X      rw[13] := 'and     '; rw[14] := 'not     '; rw[15] := 'then    ';
X      rw[16] := 'else    '; rw[17] := 'with    '; rw[18] := 'goto    ';
X      rw[19] := 'case    '; rw[20] := 'type    ';
X      rw[21] := 'file    '; rw[22] := 'begin   ';
X      rw[23] := 'until   '; rw[24] := 'while   '; rw[25] := 'array   ';
X      rw[26] := 'const   '; rw[27] := 'label   ';
X      rw[28] := 'repeat  '; rw[29] := 'record  '; rw[30] := 'downto  ';
X      rw[31] := 'packed  '; rw[32] := 'forward '; rw[33] := 'program ';
X      rw[34] := 'function'; rw[35] := 'procedur';
X      frw[1] :=  1; frw[2] :=  1; frw[3] :=  7; frw[4] := 15; frw[5] := 22;
X      frw[6] := 28; frw[7] := 32; frw[8] := 34; frw[9] := 36;
X    end (*reswords*) ;
X
X    procedure symbols;
X    begin
X      rsy[ 1] := ifsy;      rsy[ 2] := dosy;      rsy[ 3] := ofsy;
X      rsy[ 4] := tosy;      rsy[ 5] := relop;     rsy[ 6] := addop;
X      rsy[ 7] := endsy;     rsy[ 8] := forsy;     rsy[ 9] := varsy;
X      rsy[10] := mulop;     rsy[11] := mulop;     rsy[12] := setsy;
X      rsy[13] := mulop;     rsy[14] := notsy;     rsy[15] := thensy;
X      rsy[16] := elsesy;    rsy[17] := withsy;    rsy[18] := gotosy;
X      rsy[19] := casesy;    rsy[20] := typesy;
X      rsy[21] := filesy;    rsy[22] := beginsy;
X      rsy[23] := untilsy;   rsy[24] := whilesy;   rsy[25] := arraysy;
X      rsy[26] := constsy;   rsy[27] := labelsy;
X      rsy[28] := repeatsy;  rsy[29] := recordsy;  rsy[30] := downtosy;
X      rsy[31] := packedsy;  rsy[32] := forwardsy; rsy[33] := progsy;
X      rsy[34] := funcsy;    rsy[35] := procsy;
X      ssy['+'] := addop ;   ssy['-'] := addop;    ssy['*'] := mulop;
X      ssy['/'] := mulop ;   ssy['('] := lparent;  ssy[')'] := rparent;
X      ssy['$'] := othersy ; ssy['='] := relop;    ssy[' '] := othersy;
X      ssy[','] := comma ;   ssy['.'] := period;   ssy['''']:= othersy;
X      ssy['['] := lbrack ;  ssy[']'] := rbrack;   ssy[':'] := colon;
X      ssy['^'] := arrow ;   ssy['<'] := relop;    ssy['>'] := relop;
X      ssy[';'] := semicolon;
X    end (*symbols*) ;
X
X    procedure rators;
X      var i: integer;
X    begin
X      for i := 1 to 35 (*nr of res words*) do rop[i] := noop;
X      rop[5] := inop; rop[10] := idiv; rop[11] := imod;
X      rop[6] := orop; rop[13] := andop;
X      for i := ordminchar to ordmaxchar do sop[chr(i)] := noop;
X      sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
X      sop['='] := eqop; sop['<'] := ltop;  sop['>'] := gtop;
X    end (*rators*) ;
X
X    procedure procmnemonics;
X    begin
X      sna[ 1] :=' get'; sna[ 2] :=' put'; sna[ 3] :=' rdi'; sna[ 4] :=' rdr';
X      sna[ 5] :=' rdc'; sna[ 6] :=' wri'; sna[ 7] :=' wro'; sna[ 8] :=' wrr';
X      sna[ 9] :=' wrc'; sna[10] :=' wrs'; sna[11] :=' pak'; sna[12] :=' new';
X      sna[13] :=' rst'; sna[14] :=' eln'; sna[15] :=' sin'; sna[16] :=' cos';
X      sna[17] :=' exp'; sna[18] :=' sqt'; sna[19] :=' log'; sna[20] :=' atn';
X      sna[21] :=' rln'; sna[22] :=' wln'; sna[23] :=' sav';
X    end (*procmnemonics*) ;
X
X    procedure instrmnemonics;
X    begin
X      mn[ 0] :=' abi'; mn[ 1] :=' abr'; mn[ 2] :=' adi'; mn[ 3] :=' adr';
X      mn[ 4] :=' and'; mn[ 5] :=' dif'; mn[ 6] :=' dvi'; mn[ 7] :=' dvr';
X      mn[ 8] :=' eof'; mn[ 9] :=' flo'; mn[10] :=' flt'; mn[11] :=' inn';
X      mn[12] :=' int'; mn[13] :=' ior'; mn[14] :=' mod'; mn[15] :=' mpi';
X      mn[16] :=' mpr'; mn[17] :=' ngi'; mn[18] :=' ngr'; mn[19] :=' not';
X      mn[20] :=' odd'; mn[21] :=' sbi'; mn[22] :=' sbr'; mn[23] :=' sgs';
X      mn[24] :=' sqi'; mn[25] :=' sqr'; mn[26] :=' sto'; mn[27] :=' trc';
X      mn[28] :=' uni'; mn[29] :=' stp'; mn[30] :=' csp'; mn[31] :=' dec';
X      mn[32] :=' ent'; mn[33] :=' fjp'; mn[34] :=' inc'; mn[35] :=' ind';
X      mn[36] :=' ixa'; mn[37] :=' lao'; mn[38] :=' lca'; mn[39] :=' ldo';
X      mn[40] :=' mov'; mn[41] :=' mst'; mn[42] :=' ret'; mn[43] :=' sro';
X      mn[44] :=' xjp'; mn[45] :=' chk'; mn[46] :=' cup'; mn[47] :=' equ';
X      mn[48] :=' geq'; mn[49] :=' grt'; mn[50] :=' lda'; mn[51] :=' ldc';
X      mn[52] :=' leq'; mn[53] :=' les'; mn[54] :=' lod'; mn[55] :=' neq';
X      mn[56] :=' str'; mn[57] :=' ujp'; mn[58] :=' ord'; mn[59] :=' chr';
X      mn[60] :=' ujc';
X    end (*instrmnemonics*) ;
X
X    procedure chartypes;
X    var i : integer;
X    begin
X      for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal;
X      chartp['a'] := letter  ;
X      chartp['b'] := letter  ; chartp['c'] := letter  ;
X      chartp['d'] := letter  ; chartp['e'] := letter  ;
X      chartp['f'] := letter  ; chartp['g'] := letter  ;
X      chartp['h'] := letter  ; chartp['i'] := letter  ;
X      chartp['j'] := letter  ; chartp['k'] := letter  ;
X      chartp['l'] := letter  ; chartp['m'] := letter  ;
X      chartp['n'] := letter  ; chartp['o'] := letter  ;
X      chartp['p'] := letter  ; chartp['q'] := letter  ;
X      chartp['r'] := letter  ; chartp['s'] := letter  ;
X      chartp['t'] := letter  ; chartp['u'] := letter  ;
X      chartp['v'] := letter  ; chartp['w'] := letter  ;
X      chartp['x'] := letter  ; chartp['y'] := letter  ;
X      chartp['z'] := letter  ; chartp['0'] := number  ;
X      chartp['1'] := number  ; chartp['2'] := number  ;
X      chartp['3'] := number  ; chartp['4'] := number  ;
X      chartp['5'] := number  ; chartp['6'] := number  ;
X      chartp['7'] := number  ; chartp['8'] := number  ;
X      chartp['9'] := number  ; chartp['+'] := special ;
X      chartp['-'] := special ; chartp['*'] := special ;
X      chartp['/'] := special ; chartp['('] := chlparen;
X      chartp[')'] := special ; chartp['$'] := special ;
X      chartp['='] := special ; chartp[' '] := chspace ;
X      chartp[','] := special ; chartp['.'] := chperiod;
X      chartp['''']:= chstrquo; chartp['['] := special ;
X      chartp[']'] := special ; chartp[':'] := chcolon ;
X      chartp['^'] := special ; chartp[';'] := special ;
X      chartp['<'] := chlt    ; chartp['>'] := chgt    ;
X      ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2;
X      ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5;
X      ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8;
X      ordint['9'] := 9;
X    end;
X
X    procedure initdx;
X    begin
X      cdx[ 0] :=  0; cdx[ 1] :=  0; cdx[ 2] := -1; cdx[ 3] := -1;
X      cdx[ 4] := -1; cdx[ 5] := -1; cdx[ 6] := -1; cdx[ 7] := -1;
X      cdx[ 8] :=  0; cdx[ 9] :=  0; cdx[10] :=  0; cdx[11] := -1;
X      cdx[12] := -1; cdx[13] := -1; cdx[14] := -1; cdx[15] := -1;
X      cdx[16] := -1; cdx[17] :=  0; cdx[18] :=  0; cdx[19] :=  0;
X      cdx[20] :=  0; cdx[21] := -1; cdx[22] := -1; cdx[23] :=  0;
X      cdx[24] :=  0; cdx[25] :=  0; cdx[26] := -2; cdx[27] :=  0;
X      cdx[28] := -1; cdx[29] :=  0; cdx[30] :=  0; cdx[31] :=  0;
X      cdx[32] :=  0; cdx[33] := -1; cdx[34] :=  0; cdx[35] :=  0;
X      cdx[36] := -1; cdx[37] := +1; cdx[38] := +1; cdx[39] := +1;
X      cdx[40] := -2; cdx[41] :=  0; cdx[42] :=  0; cdx[43] := -1;
X      cdx[44] := -1; cdx[45] :=  0; cdx[46] :=  0; cdx[47] := -1;
X      cdx[48] := -1; cdx[49] := -1; cdx[50] := +1; cdx[51] := +1;
X      cdx[52] := -1; cdx[53] := -1; cdx[54] := +1; cdx[55] := -1;
X      cdx[56] := -1; cdx[57] :=  0; cdx[58] :=  0; cdx[59] :=  0;
X      cdx[60] :=  0;
X      pdx[ 1] := -1; pdx[ 2] := -1; pdx[ 3] := -2; pdx[ 4] := -2;
X      pdx[ 5] := -2; pdx[ 6] := -3; pdx[ 7] := -3; pdx[ 8] := -3;
X      pdx[ 9] := -3; pdx[10] := -4; pdx[11] :=  0; pdx[12] := -2;
X      pdx[13] := -1; pdx[14] :=  0; pdx[15] :=  0; pdx[16] :=  0;
X      pdx[17] :=  0; pdx[18] :=  0; pdx[19] :=  0; pdx[20] :=  0;
X      pdx[21] := -1; pdx[22] := -1; pdx[23] := -1;
X    end;
X
X  begin (*inittables*)
X    reswords; symbols; rators;
X    instrmnemonics; procmnemonics;
X    chartypes; initdx;
X  end (*inittables*) ;
X
begin
X  (*initialize*)
X  (************)
X  initscalars; initsets; inittables;
X
X
X  (*enter standard names and standard types:*)
X  (******************************************)
X  level := 0; top := 0;
X  with display[0] do
X    begin fname := nil; flabel := nil; occur := blck end;
X  enterstdtypes;   stdnames; entstdnames;   enterundecl;
X  top := 1; level := 1;
X  with display[1] do
X    begin fname := nil; flabel := nil; occur := blck end;
X
X
X  (*compile:*) (*rewrite(prr); (*comment this out when compiling with pcom *)
X  (**********)
X  insymbol;
X  programme(blockbegsys+statbegsys-[casesy]);
X
end.
SHAR_EOF
echo 'File pcom.p is complete' &&
chmod 0644 pcom.p ||
echo 'restore of pcom.p failed'
Wc_c="`wc -c < 'pcom.p'`"
test 117626 -eq "$Wc_c" ||
    echo 'pcom.p: original size 117626, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= pint.p ==============
if test -f 'pint.p' -a X"$1" != X"-c"; then
    echo 'x - skipping pint.p (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting pint.p (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'pint.p' &&
(*Assembler and interpreter of Pascal code*)
(*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)
X
program pcode(input,output,prd,prr);
X
(* Note for the implementation.
X   ===========================
This interpreter is written for the case where all the fundamental types
take one storage unit.
In an actual implementation, the handling of the sp pointer has to take
into account the fact that the types may have lengths different from one:
in push and pop operations the sp has to be increased and decreased not
by 1, but by a number depending on the type concerned.
However, where the number of units of storage has been computed by the
compiler, the value must not be corrected, since the lengths of the types
involved have already been taken into account.
X                                 *)
X
X
X
X
label 1;
const codemax     = 8650;
X      pcmax       = 17500;
X      maxstk      = 13650; (* size of variable store *)
X      overi       = 13655; (* size of integer constant table = 5 *)
X      overr       = 13660; (* size of real constant table = 5 *)
X      overs       = 13730; (* size of set constant table = 70 *)
X      overb       = 13820;
X      overm       = 18000;
X      maxstr      = 18001;
X      largeint    = 26144;
X      begincode   = 3;
X      inputadr    = 5;
X      outputadr   = 6;
X      prdadr      = 7;
X      prradr      = 8;
X      duminst     = 62;
X
type  bit4    = 0..15;
X      bit6    = 0..127;
X      bit20       = -26143..26143;
X      datatype    = (undef,int,reel,bool,sett,adr,mark,car);
X      address     = -1..maxstr;
X      beta    = packed array[1..25] of char; (*error message*)
X      settype     = set of 0..58;
X
var   code    : array[0..codemax] of   (* the program *)
X              packed record  op1    :bit6;
X                     p1     :bit4;
X                     q1     :bit20;
X                     op2    :bit6;
X                     p2     :bit4;
X                     q2     :bit20
X                 end;
X      pc       : 0..pcmax;     (*program address register*)
X      op : bit6; p : bit4; q : bit20;  (*instruction register*)
X
X      store    : array [0..overm] of
X               record case datatype of
X                int    :(vi :integer);
X                reel       :(vr :real);
X                bool       :(vb :boolean);
X                sett       :(vs :settype);
X                car    :(vc :char);
X                adr    :(va :address);
X                         (*address in store*)
X                mark       :(vm :integer)
X            end;
X       mp,sp,np,ep : address;  (* address registers *)
X       (*mp  points to beginning of a data segment
X     sp  points to top of the stack
X     ep  points to the maximum extent of the stack
X     np  points to top of the dynamically allocated area*)
X
X       interpreting: boolean;
X       prd,prr     : text;(*prd for read only, prr for write only *)
X
X       instr       : array[bit6] of alfa; (* mnemonic instruction codes *)
X       cop     : array[bit6] of integer;
X       sptable     : array[0..20] of alfa; (*standard functions and procedures*)
X
X      (*locally used for interpreting one instruction*)
X       ad,ad1      : address;
X       b       : boolean;
X       i,j,i1,i2   : integer;
X       c       : char;
X
(*--------------------------------------------------------------------*)
X
procedure load;
X   const maxlabel = 1850;
X   type  labelst  = (entered,defined); (*label situation*)
X     labelrg  = 0..maxlabel;       (*label range*)
X     labelrec = record
X              val: address;
X               st: labelst
X            end;
X   var  icp,rcp,scp,bcp,mcp  : address;  (*pointers to next free position*)
X    word : array[1..10] of char; i  : integer;  ch  : char;
X    labeltab: array[labelrg] of labelrec;
X    labelvalue: address;
X
X   procedure init;
X      var i: integer;
X   begin instr[ 0]:='lod       ';       instr[ 1]:='ldo       ';
X     instr[ 2]:='str       ';       instr[ 3]:='sro       ';
X     instr[ 4]:='lda       ';       instr[ 5]:='lao       ';
X     instr[ 6]:='sto       ';       instr[ 7]:='ldc       ';
X     instr[ 8]:='...       ';       instr[ 9]:='ind       ';
X     instr[10]:='inc       ';       instr[11]:='mst       ';
X     instr[12]:='cup       ';       instr[13]:='ent       ';
X     instr[14]:='ret       ';       instr[15]:='csp       ';
X     instr[16]:='ixa       ';       instr[17]:='equ       ';
X     instr[18]:='neq       ';       instr[19]:='geq       ';
X     instr[20]:='grt       ';       instr[21]:='leq       ';
X     instr[22]:='les       ';       instr[23]:='ujp       ';
X     instr[24]:='fjp       ';       instr[25]:='xjp       ';
X     instr[26]:='chk       ';       instr[27]:='eof       ';
X     instr[28]:='adi       ';       instr[29]:='adr       ';
X     instr[30]:='sbi       ';       instr[31]:='sbr       ';
X     instr[32]:='sgs       ';       instr[33]:='flt       ';
X     instr[34]:='flo       ';       instr[35]:='trc       ';
X     instr[36]:='ngi       ';       instr[37]:='ngr       ';
X     instr[38]:='sqi       ';       instr[39]:='sqr       ';
X     instr[40]:='abi       ';       instr[41]:='abr       ';
X     instr[42]:='not       ';       instr[43]:='and       ';
X     instr[44]:='ior       ';       instr[45]:='dif       ';
X     instr[46]:='int       ';       instr[47]:='uni       ';
X     instr[48]:='inn       ';       instr[49]:='mod       ';
X     instr[50]:='odd       ';       instr[51]:='mpi       ';
X     instr[52]:='mpr       ';       instr[53]:='dvi       ';
X     instr[54]:='dvr       ';       instr[55]:='mov       ';
X     instr[56]:='lca       ';       instr[57]:='dec       ';
X     instr[58]:='stp       ';       instr[59]:='ord       ';
X     instr[60]:='chr       ';       instr[61]:='ujc       ';
X
X     sptable[ 0]:='get       ';     sptable[ 1]:='put       ';
X     sptable[ 2]:='rst       ';     sptable[ 3]:='rln       ';
X     sptable[ 4]:='new       ';     sptable[ 5]:='wln       ';
X     sptable[ 6]:='wrs       ';     sptable[ 7]:='eln       ';
X     sptable[ 8]:='wri       ';     sptable[ 9]:='wrr       ';
X     sptable[10]:='wrc       ';     sptable[11]:='rdi       ';
X     sptable[12]:='rdr       ';     sptable[13]:='rdc       ';
X     sptable[14]:='sin       ';     sptable[15]:='cos       ';
X     sptable[16]:='exp       ';     sptable[17]:='log       ';
X     sptable[18]:='sqt       ';     sptable[19]:='atn       ';
X     sptable[20]:='sav       ';
X
X     cop[ 0] := 105;  cop[ 1] :=  65;
X     cop[ 2] :=  70;  cop[ 3] :=  75;
X     cop[ 6] :=  80;  cop[ 9] :=  85;
X     cop[10] :=  90;  cop[26] :=  95;
X     cop[57] := 100;
X
X     pc  := begincode;
X     icp := maxstk + 1;
X     rcp := overi + 1;
X     scp := overr + 1;
X     bcp := overs + 2;
X     mcp := overb + 1;
X     for i:= 1 to 10 do word[i]:= ' ';
X     for i:= 0 to maxlabel do
X         with labeltab[i] do begin val:=-1; st:= entered end;
X     reset(prd);
X   end;(*init*)
X
X   procedure errorl(string: beta); (*error in loading*)
X   begin writeln;
X      write(string);
X      halt
X   end; (*errorl*)
X
X   procedure update(x: labelrg); (*when a label definition lx is found*)
X      var curr,succ: -1..pcmax;  (*resp. current element and successor element
X                   of a list of future references*)
X      endlist: boolean;
X   begin
X      if labeltab[x].st=defined then errorl(' duplicated label    ')
X      else begin
X         if labeltab[x].val<>-1 then (*forward reference(s)*)
X         begin curr:= labeltab[x].val; endlist:= false;
X        while not endlist do
X              with code[curr div 2] do
X              begin
X             if odd(curr) then begin succ:= q2;
X                         q2:= labelvalue
X                       end
X                      else begin succ:= q1;
X                         q1:= labelvalue
X                       end;
X             if succ=-1 then endlist:= true
X                    else curr:= succ
X              end;
X          end;
X          labeltab[x].st := defined;
X          labeltab[x].val:= labelvalue;
X       end
X   end;(*update*)
X
X   procedure assemble; forward;
X
X   procedure generate;(*generate segment of code*)
X      var x: integer; (* label number *)
X      again: boolean;
X   begin
X      again := true;
X      while again do
X        begin read(prd,ch);(* first character of line*)
X          case ch of
X               'i': readln(prd);
X               'l': begin read(prd,x);
X                  if not eoln(prd) then read(prd,ch);
X                  if ch='=' then read(prd,labelvalue)
X                        else labelvalue:= pc;
X                  update(x); readln(prd);
X                end;
X               'q': begin again := false; readln(prd) end;
X               ' ': begin read(prd,ch); assemble end
X          end;
X        end
X   end; (*generate*)
X
X   procedure assemble; (*translate symbolic code into machine code and store*)
X      label 1;     (*goto 1 for instructions without code generation*)
X      var name :alfa;  b :boolean;  r :real;  s :settype;
X      c1 :char;  i,s1,lb,ub :integer;
X
X      procedure lookup(x: labelrg); (* search in label table*)
X      begin case labeltab[x].st of
X        entered: begin q := labeltab[x].val;
X               labeltab[x].val := pc
X             end;
X        defined: q:= labeltab[x].val
X        end(*case label..*)
X      end;(*lookup*)
X
X      procedure labelsearch;
X     var x: labelrg;
X      begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
X        read(prd,x); lookup(x)
X      end;(*labelsearch*)
X
X      procedure getname;
X      begin  word[1] := ch;
X     read(prd,word[2],word[3]);
X     if not eoln(prd) then read(prd,ch) (*next character*);
X     pack(word,1,name)
X      end; (*getname*)
X
X      procedure typesymbol;
X    var i: integer;
X      begin
X    if ch <> 'i' then
X      begin
X        case ch of
X          'a': i := 0;
X          'r': i := 1;
X          's': i := 2;
X          'b': i := 3;
X          'c': i := 4;
X        end;
X        op := cop[op]+i;
X      end;
X      end (*typesymbol*) ;
X
X   begin  p := 0;  q := 0;  op := 0;
X      getname;
X      instr[duminst] := name;
X      while instr[op]<>name do op := op+1;
X      if op = duminst then errorl(' illegal instruction     ');
X
X      case op of  (* get parameters p,q *)
X
X      (*equ,neq,geq,grt,leq,les*)
X      17,18,19,
X      20,21,22: begin case ch of
X                  'a': ; (*p = 0*)
X                  'i': p := 1;
X                  'r': p := 2;
X                  'b': p := 3;
X                  's': p := 4;
X                  'c': p := 6;
X                  'm': begin p := 5;
X                     read(prd,q)
X                   end
X              end
X            end;
X
X      (*lod,str*)
X      0,2: begin typesymbol; read(prd,p,q)
X           end;
X
X      4  (*lda*): read(prd,p,q);
X
X      12 (*cup*): begin read(prd,p); labelsearch end;
X
X      11 (*mst*): read(prd,p);
X
X      14 (*ret*): case ch of
X                'p': p:=0;
X                'i': p:=1;
X                'r': p:=2;
X                'c': p:=3;
X                'b': p:=4;
X                'a': p:=5
X              end;
X
X      (*lao,ixa,mov*)
X      5,16,55: read(prd,q);
X
X      (*ldo,sro,ind,inc,dec*)
X      1,3,9,10,57: begin typesymbol; read(prd,q)
X               end;
X
X      (*ujp,fjp,xjp*)
X      23,24,25: labelsearch;
X
X      13 (*ent*): begin read(prd,p); labelsearch end;
X
X      15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname;
X               while name<>sptable[q] do  q := q+1
X              end;
X
X      7 (*ldc*): begin case ch of  (*get q*)
X               'i': begin  p := 1;  read(prd,i);
X                   if abs(i)>=largeint then
X                   begin  op := 8;
X                      store[icp].vi := i;  q := maxstk;
X                      repeat  q := q+1  until store[q].vi=i;
X                      if q=icp then
X                      begin  icp := icp+1;
X                    if icp=overi then
X                      errorl(' integer table overflow  ');
X                      end
X                   end  else q := i
X                end;
X
X               'r': begin  op := 8; p := 2;
X                   read(prd,r);
X                   store[rcp].vr := r;  q := overi;
X                   repeat  q := q+1  until store[q].vr=r;
X                   if q=rcp then
X                   begin  rcp := rcp+1;
X                     if rcp = overr then
X                       errorl(' real table overflow     ');
X                   end
X                end;
X
X               'n': ; (*p,q = 0*)
X
X               'b': begin p := 3;  read(prd,q)  end;
X
X               'c': begin p := 6;
X                  repeat read(prd,ch); until ch <> ' ';
X                  if ch <> '''' then
X                    errorl(' illegal character       ');
X                  read(prd,ch);  q := ord(ch);
X                  read(prd,ch);
X                  if ch <> '''' then
X                    errorl(' illegal character       ');
X                end;
X               '(': begin  op := 8;  p := 4;
X                   s := [ ];  read(prd,ch);
X                   while ch<>')' do
X                   begin read(prd,s1,ch); s := s + [s1]
X                   end;
X                   store[scp].vs := s;  q := overr;
X                   repeat  q := q+1  until store[q].vs=s;
X                   if q=scp then
X                   begin  scp := scp+1;
X                      if scp=overs then
X                    errorl(' set table overflow      ');
X                   end
X                end
X               end (*case*)
X             end;
X
X       26 (*chk*): begin typesymbol;
X             read(prd,lb,ub);
X             if op = 95 then q := lb
X             else
X             begin
X               store[bcp-1].vi := lb; store[bcp].vi := ub;
X               q := overs;
X               repeat  q := q+2
X               until (store[q-1].vi=lb)and (store[q].vi=ub);
X               if q=bcp then
X               begin  bcp := bcp+2;
X                  if bcp=overb then
X                errorl(' boundary table overflow ');
X               end
X             end
X               end;
X
X       56 (*lca*): begin
X             if mcp + 16 >= overm then
X               errorl(' multiple table overflow ');
X             mcp := mcp+16;
X             q := mcp;
X             for i := 0 to 15 (*stringlgth*) do
X             begin read(prd,ch);
X               store[q+i].vc := ch
X             end;
X               end;
X
X      6 (*sto*): typesymbol;
X
X      27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
X      48,49,50,51,52,53,54,58:  ;
X
X      (*ord,chr*)
X      59,60: goto 1;
X
X      61 (*ujc*): ; (*must have same length as ujp*)
X
X      end; (*case*)
X
X      (* store instruction *)
X      with code[pc div 2] do
X     if odd(pc) then
X     begin  op2 := op; p2 := p; q2 := q
X     end  else
X     begin  op1 := op; p1 := p; q1 := q
X     end;
X      pc := pc+1;
X      1: readln(prd);
X   end; (*assemble*)
X
begin (*load*)
X   init;
X   generate;
X   pc := 0;
X   generate;
end; (*load*)
X
(*------------------------------------------------------------------------*)
X
procedure pmd;
X   var s :integer; i: integer;
X
X   procedure pt;
X   begin  write(s:6);
X      if abs(store[s].vi) < maxint then write(store[s].vi)
X      else write('too big ');
X      s := s - 1;
X      i := i + 1;
X      if i = 4 then
X     begin writeln(output); i := 0 end;
X   end; (*pt*)
X
begin
X   write(' pc =',pc-1:5,' op =',op:3,'  sp =',sp:5,'  mp =',mp:5,
X    '  np =',np:5);
X   writeln; writeln('--------------------------------------');
X
X   s := sp; i := 0;
X   while s>=0 do pt;
X   s := maxstk;
X   while s>=np do pt;
end; (*pmd*)
X
procedure errori(string: beta);
begin writeln; writeln(string);
X      pmd; goto 1
end;(*errori*)
X
function base(ld :integer):address;
X   var ad :address;
begin  ad := mp;
X   while ld>0 do
X   begin  ad := store[ad+1].vm;  ld := ld-1
X   end;
X   base := ad
end; (*base*)
X
procedure compare;
(*comparing is only correct if result by comparing integers will be*)
begin
X  i1 := store[sp].va;
X  i2 := store[sp+1].va;
X  i := 0; b := true;
X  while b and (i<>q) do
X    if store[i1+i].vi = store[i2+i].vi then i := i+1
X    else b := false
end; (*compare*)
X
procedure callsp;
X   var line: boolean; adptr,adelnt: address;
X       i: integer;
X
X   procedure readi(var f:text);
X      var ad: address;
X   begin ad:= store[sp-1].va;
X     read(f,store[ad].vi);
X     store[store[sp].va].vc := f^;
X     sp:= sp-2
X   end;(*readi*)
X
X   procedure readr(var f: text);
X      var ad: address;
X   begin ad:= store[sp-1].va;
X     read(f,store[ad].vr);
X     store[store[sp].va].vc := f^;
X     sp:= sp-2
X   end;(*readr*)
X
X   procedure readc(var f: text);
X      var c: char; ad: address;
X   begin read(f,c);
X     ad:= store[sp-1].va;
X     store[ad].vc := c;
X     store[store[sp].va].vc := f^;
X     store[store[sp].va].vi := ord(f^);
X     sp:= sp-2
X   end;(*readc*)
X
X   procedure writestr(var f: text);
X      var i,j,k: integer;
X      ad: address;
X   begin ad:= store[sp-3].va;
X     k := store[sp-2].vi; j := store[sp-1].vi;
X     (* j and k are numbers of characters *)
X     if k>j then for i:=1 to k-j do write(f,' ')
X        else j:= k;
X     for i := 0 to j-1 do write(f,store[ad+i].vc);
X     sp:= sp-4
X   end;(*writestr*)
X
X   procedure getfile(var f: text);
X      var ad: address;
X   begin ad:=store[sp].va;
X     get(f); store[ad].vc := f^;
X     sp:=sp-1
X   end;(*getfile*)
X
X   procedure putfile(var f: text);
X      var ad: address;
X   begin ad:= store[sp].va;
X     f^:= store[ad].vc; put(f);
X     sp:= sp-1;
X   end;(*putfile*)
X
begin (*callsp*)
X      case q of
X       0 (*get*): case store[sp].va of
X               5: getfile(input);
X               6: errori(' get on output file      ');
X               7: getfile(prd);
X               8: errori(' get on prr file     ')
X              end;
X       1 (*put*): case store[sp].va of
X               5: errori(' put on read file    ');
X               6: putfile(output);
X               7: errori(' put on prd file     ');
X               8: putfile(prr)
X              end;
X       2 (*rst*): begin
X            (*for testphase*)
X            np := store[sp].va; sp := sp-1
X              end;
X       3 (*rln*): begin case store[sp].va of
X                 5: begin readln(input);
X                      store[inputadr].vc := input^
X                    end;
X                 6: errori(' readln on output file   ');
X                 7: begin readln(input);
X                      store[inputadr].vc := input^
X                    end;
X                 8: errori(' readln on prr file      ')
X                end;
X                sp:= sp-1
X              end;
X       4 (*new*): begin ad:= np-store[sp].va;
X              (*top of stack gives the length in units of storage *)
X                if ad <= ep then
X                  errori(' store overflow      ');
X                np:= ad; ad:= store[sp-1].va;
X                store[ad].va := np;
X                sp:=sp-2
X              end;
X       5 (*wln*): begin case store[sp].va of
X                 5: errori(' writeln on input file   ');
X                 6: writeln(output);
X                 7: errori(' writeln on prd file     ');
X                 8: writeln(prr)
X                end;
X                sp:= sp-1
X              end;
X       6 (*wrs*): case store[sp].va of
X               5: errori(' write on input file     ');
X               6: writestr(output);
X               7: errori(' write on prd file       ');
X               8: writestr(prr)
X              end;
X       7 (*eln*): begin case store[sp].va of
X                 5: line:= eoln(input);
X                 6: errori(' eoln output file    ');
X                 7: line:=eoln(prd);
X                 8: errori(' eoln on prr file    ')
X                end;
X                store[sp].vb := line
X              end;
X       8 (*wri*): begin case store[sp].va of
X                 5: errori(' write on input file     ');
X                 6: write(output,
X                      store[sp-2].vi: store[sp-1].vi);
X                 7: errori(' write on prd file       ');
X                 8: write(prr,
X                      store[sp-2].vi: store[sp-1].vi)
X                end;
X                sp:=sp-3
X              end;
X       9 (*wrr*): begin case store[sp].va of
X                 5: errori(' write on input file     ');
X                 6: write(output,
X                      store[sp-2].vr: store[sp-1].vi);
X                 7: errori(' write on prd file       ');
X                 8: write(prr,
X                      store[sp-2].vr: store[sp-1].vi)
X                end;
X                sp:=sp-3
X              end;
X       10(*wrc*): begin case store[sp].va of
X                 5: errori(' write on input file     ');
X                 6: write(output,store[sp-2].vc:
X                      store[sp-1].vi);
X                 7: errori(' write on prd file       ');
X                 8: write(prr,chr(store[sp-2].vi):
X                      store[sp-1].vi);
X                end;
X                sp:=sp-3
X              end;
X       11(*rdi*): case store[sp].va of
X               5: readi(input);
X               6: errori(' read on output file     ');
X               7: readi(prd);
X               8: errori(' read on prr file    ')
X              end;
X       12(*rdr*): case store[sp].va of
X               5: readr(input);
X               6: errori(' read on output file     ');
X               7: readr(prd);
X               8: errori(' read on prr file    ')
X              end;
X       13(*rdc*): case store[sp].va of
X               5: readc(input);
X               6: errori(' read on output file     ');
X               7: readc(prd);
X               8: errori(' read on prr file    ')
X              end;
X       14(*sin*): store[sp].vr:= sin(store[sp].vr);
X       15(*cos*): store[sp].vr:= cos(store[sp].vr);
X       16(*exp*): store[sp].vr:= exp(store[sp].vr);
X       17(*log*): store[sp].vr:= ln(store[sp].vr);
X       18(*sqt*): store[sp].vr:= sqrt(store[sp].vr);
X       19(*atn*): store[sp].vr:= arctan(store[sp].vr);
X       20(*sav*): begin ad:=store[sp].va;
X             store[ad].va := np;
X             sp:= sp-1
X              end;
X      end;(*case q*)
end;(*callsp*)
X
begin (* main *)
X  rewrite(prr);
X  load; (* assembles and stores code *)
X  writeln(output); (* for testing *)
X  pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5;
X  store[inputadr].vc := input^;
X  store[prdadr].vc := prd^;
X  interpreting := true;
X
X  while interpreting do
X  begin
X    (*fetch*)
X    with code[pc div 2] do
X      if odd(pc) then
X      begin op := op2; p := p2; q := q2
X      end else
X      begin op := op1; p := p1; q := q1
X      end;
X    pc := pc+1;
X
X    (*execute*)
X    case op of
X
X      105,106,107,108,109,
X      0 (*lod*): begin  ad := base(p) + q;
X              sp := sp+1;
X              store[sp] := store[ad]
X             end;
X
X      65,66,67,68,69,
X      1 (*ldo*): begin
X              sp := sp+1;
X              store[sp] := store[q]
X             end;
X
X      70,71,72,73,74,
X      2 (*str*): begin  store[base(p)+q] := store[sp];
X              sp := sp-1
X             end;
X
X      75,76,77,78,79,
X      3 (*sro*): begin  store[q] := store[sp];
X              sp := sp-1
X             end;
X
X      4 (*lda*): begin sp := sp+1;
X              store[sp].va := base(p) + q
X             end;
X
X      5 (*lao*): begin sp := sp+1;
X              store[sp].va := q
X             end;
X
X      80,81,82,83,84,
X      6 (*sto*): begin
X              store[store[sp-1].va] := store[sp];
X              sp := sp-2;
X             end;
X
X      7 (*ldc*): begin sp := sp+1;
X              if p=1 then
X              begin store[sp].vi := q;
X              end else
X              if p = 6 then store[sp].vc := chr(q)
X              else
X                if p = 3 then store[sp].vb := q = 1
X                else (* load nil *) store[sp].va := maxstr
X             end;
X
X      8 (*lci*): begin sp := sp+1;
X              store[sp] := store[q]
X             end;
X
X      85,86,87,88,89,
X      9 (*ind*): begin ad := store[sp].va + q;
X              (* q is a number of storage units *)
X              store[sp] := store[ad]
X             end;
X
X      90,91,92,93,94,
X      10 (*inc*): store[sp].vi := store[sp].vi+q;
X
X      11 (*mst*): begin (*p=level of calling procedure minus level of called
X                  procedure + 1;  set dl and sl, increment sp*)
X               (* then length of this element is
X              max(intsize,realsize,boolsize,charsize,ptrsize *)
X               store[sp+2].vm := base(p);
X               (* the length of this element is ptrsize *)
X               store[sp+3].vm := mp;
X               (* idem *)
X               store[sp+4].vm := ep;
X               (* idem *)
X               sp := sp+5
X              end;
X
X      12 (*cup*): begin (*p=no of locations for parameters, q=entry point*)
X               mp := sp-(p+4);
X               store[mp+4].vm := pc;
X               pc := q
X              end;
X
X      13 (*ent*): if p = 1 then
X            begin sp := mp + q; (*q = length of dataseg*)
X              if sp > np then errori(' store overflow      ');
X            end
X              else
X            begin ep := sp+q;
X              if ep > np then errori(' store overflow      ');
X            end;
X            (*q = max space required on stack*)
X
X      14 (*ret*): begin case p of
X                 0: sp:= mp-1;
X                 1,2,3,4,5: sp:= mp
X                end;
X                pc := store[mp+4].vm;
X                ep := store[mp+3].vm;
X                mp:= store[mp+2].vm;
X              end;
X
X      15 (*csp*): callsp;
X
X      16 (*ixa*): begin
X               i := store[sp].vi;
X               sp := sp-1;
X               store[sp].va := q*i+store[sp].va;
X              end;
X
X      17 (*equ*): begin  sp := sp-1;
X               case p of
X             1: store[sp].vb := store[sp].vi = store[sp+1].vi;
X             0: store[sp].vb := store[sp].va = store[sp+1].va;
X             6: store[sp].vb := store[sp].vc = store[sp+1].vc;
X             2: store[sp].vb := store[sp].vr = store[sp+1].vr;
X             3: store[sp].vb := store[sp].vb = store[sp+1].vb;
X             4: store[sp].vb := store[sp].vs = store[sp+1].vs;
X             5: begin  compare;
X                   store[sp].vb := b;
X                end;
X               end; (*case p*)
X              end;
X
X      18 (*neq*): begin  sp := sp-1;
X               case p of
X             0: store[sp].vb := store[sp].va <> store[sp+1].va;
X             1: store[sp].vb := store[sp].vi <> store[sp+1].vi;
X             6: store[sp].vb := store[sp].vc <> store[sp+1].vc;
X             2: store[sp].vb := store[sp].vr <> store[sp+1].vr;
X             3: store[sp].vb := store[sp].vb <> store[sp+1].vb;
X             4: store[sp].vb := store[sp].vs <> store[sp+1].vs;
X             5: begin  compare;
X                   store[sp].vb := not b;
X                end
X               end; (*case p*)
X              end;
X
X      19 (*geq*): begin  sp := sp-1;
X               case p of
X             0: errori(' <,<=,>,>= for address   ');
X             1: store[sp].vb := store[sp].vi >= store[sp+1].vi;
X             6: store[sp].vb := store[sp].vc >= store[sp+1].vc;
X             2: store[sp].vb := store[sp].vr >= store[sp+1].vr;
X             3: store[sp].vb := store[sp].vb >= store[sp+1].vb;
X             4: store[sp].vb := store[sp].vs >= store[sp+1].vs;
X             5: begin compare;
X                  store[sp].vb := b or
X                (store[i1+i].vi >= store[i2+i].vi)
X                end
X               end; (*case p*)
X              end;
X
X      20 (*grt*): begin  sp := sp-1;
X               case p of
X             0: errori(' <,<=,>,>= for address   ');
X             1: store[sp].vb := store[sp].vi > store[sp+1].vi;
X             6: store[sp].vb := store[sp].vc > store[sp+1].vc;
X             2: store[sp].vb := store[sp].vr > store[sp+1].vr;
X             3: store[sp].vb := store[sp].vb > store[sp+1].vb;
X             4: errori(' set inclusion       ');
X             5: begin  compare;
X                  store[sp].vb := not b and
X                (store[i1+i].vi > store[i2+i].vi)
X                end
X               end; (*case p*)
X              end;
X
X      21 (*leq*): begin  sp := sp-1;
X               case p of
X             0: errori(' <,<=,>,>= for address   ');
X             1: store[sp].vb := store[sp].vi <= store[sp+1].vi;
X             6: store[sp].vb := store[sp].vc <= store[sp+1].vc;
X             2: store[sp].vb := store[sp].vr <= store[sp+1].vr;
X             3: store[sp].vb := store[sp].vb <= store[sp+1].vb;
X             4: store[sp].vb := store[sp].vs <= store[sp+1].vs;
X             5: begin  compare;
X                  store[sp].vb := b or
X                (store[i1+i].vi <= store[i2+i].vi)
X                end;
X               end; (*case p*)
X              end;
X
X      22 (*les*): begin  sp := sp-1;
X               case p of
X             0: errori(' <,<=,>,>= for address   ');
X             1: store[sp].vb := store[sp].vi < store[sp+1].vi;
X             6: store[sp].vb := store[sp].vc < store[sp+1].vc;
X             2: store[sp].vb := store[sp].vr < store[sp+1].vr;
X             3: store[sp].vb := store[sp].vb < store[sp+1].vb;
X             5: begin  compare;
X                  store[sp].vb := not b and
X                (store[i1+i].vi < store[i2+i].vi)
X                end
X               end; (*case p*)
X              end;
X
X      23 (*ujp*): pc := q;
X
X      24 (*fjp*): begin  if not store[sp].vb then pc := q;
X               sp := sp-1
X              end;
X
X      25 (*xjp*): begin
X               pc := store[sp].vi + q;
X               sp := sp-1
X              end;
X
X      95 (*chka*): if (store[sp].va < np) or
X              (store[sp].va > (maxstr-q)) then
X             errori(' bad pointer value       ');
X
X      96,97,98,99,
X      26 (*chk*): if (store[sp].vi < store[q-1].vi) or
X             (store[sp].vi > store[q].vi) then
X            errori(' value out of range      ');
X
X      27 (*eof*): begin  i := store[sp].vi;
X               if i=inputadr then
X               begin store[sp].vb := eof(input);
X               end else errori(' code in error       ')
X              end;
X
X      28 (*adi*): begin  sp := sp-1;
X               store[sp].vi := store[sp].vi + store[sp+1].vi
X              end;
X
X      29 (*adr*): begin  sp := sp-1;
X               store[sp].vr := store[sp].vr + store[sp+1].vr
X              end;
X
X      30 (*sbi*): begin sp := sp-1;
X               store[sp].vi := store[sp].vi - store[sp+1].vi
X              end;
X
X      31 (*sbr*): begin  sp := sp-1;
X               store[sp].vr := store[sp].vr - store[sp+1].vr
X              end;
X
X      32 (*sgs*): store[sp].vs := [store[sp].vi];
X
X      33 (*flt*): store[sp].vr := store[sp].vi;
X
X      34 (*flo*): store[sp-1].vr := store[sp-1].vi;
X
X      35 (*trc*): store[sp].vi := trunc(store[sp].vr);
X
X      36 (*ngi*): store[sp].vi := -store[sp].vi;
X
X      37 (*ngr*): store[sp].vr := -store[sp].vr;
X
X      38 (*sqi*): store[sp].vi := sqr(store[sp].vi);
X
X      39 (*sqr*): store[sp].vr := sqr(store[sp].vr);
X
X      40 (*abi*): store[sp].vi := abs(store[sp].vi);
X
X      41 (*abr*): store[sp].vr := abs(store[sp].vr);
X
X      42 (*not*): store[sp].vb := not store[sp].vb;
X
X      43 (*and*): begin  sp := sp-1;
X               store[sp].vb := store[sp].vb and store[sp+1].vb
X              end;
X
X      44 (*ior*): begin  sp := sp-1;
X               store[sp].vb := store[sp].vb or store[sp+1].vb
X              end;
X
X      45 (*dif*): begin  sp := sp-1;
X               store[sp].vs := store[sp].vs - store[sp+1].vs
X              end;
X
X      46 (*int*): begin  sp := sp-1;
X               store[sp].vs := store[sp].vs * store[sp+1].vs
X              end;
X
X      47 (*uni*): begin  sp := sp-1;
X               store[sp].vs := store[sp].vs + store[sp+1].vs
X              end;
X
X      48 (*inn*): begin
X               sp := sp - 1; i := store[sp].vi;
X               store[sp].vb := i in store[sp+1].vs;
X              end;
X
X      49 (*mod*): begin  sp := sp-1;
X               store[sp].vi := store[sp].vi mod store[sp+1].vi
X              end;
X
X      50 (*odd*): store[sp].vb := odd(store[sp].vi);
X
X      51 (*mpi*): begin  sp := sp-1;
X               store[sp].vi := store[sp].vi * store[sp+1].vi
X              end;
X
X      52 (*mpr*): begin  sp := sp-1;
X               store[sp].vr := store[sp].vr * store[sp+1].vr
X              end;
X
X      53 (*dvi*): begin  sp := sp-1;
X               store[sp].vi := store[sp].vi div store[sp+1].vi
X              end;
X
X      54 (*dvr*): begin  sp := sp-1;
X               store[sp].vr := store[sp].vr / store[sp+1].vr
X              end;
X
X      55 (*mov*): begin i1 := store[sp-1].va;
X               i2 := store[sp].va; sp := sp-2;
X               for i := 0 to q-1 do store[i1+i] := store[i2+i]
X               (* q is a number of storage units *)
X              end;
X
X      56 (*lca*): begin  sp := sp+1;
X               store[sp].va := q;
X              end;
X
X      100,101,102,103,104,
X      57 (*dec*): store[sp].vi := store[sp].vi-q;
X
X      58 (*stp*): interpreting := false;
X
X      59 (*ord*): (*only used to change the tagfield*)
X              begin
X              end;
X
X      60 (*chr*): begin
X              end;
X
X      61 (*ujc*): errori(' case - error        ');
X    end
X  end; (*while interpreting*)
X
1 :
end.
SHAR_EOF
chmod 0644 pint.p ||
echo 'restore of pint.p failed'
Wc_c="`wc -c < 'pint.p'`"
test 28139 -eq "$Wc_c" ||
    echo 'pint.p: original size 28139, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
rm -f _shar_seq_.tmp
echo You have unpacked the last part
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].