(*$c+,t-,d-,l-*) {******************************************************************************* * * * Portable Pascal compiler * * ************************ * * * * Pascal P5 * * * * ETH May 76 * * * * Authors: * * * * Urs Ammann * * Kesav Nori * * Christian Jacobi * * K. Jensen * * N. Wirth * * Ch. Jacobi * * * * Address: * * * * Institut Fuer Informatik * * Eidg. Technische Hochschule * * CH-8096 Zuerich * * * * This code is fully documented in the book * * "Pascal Implementation" * * by Steven Pemberton and Martin Daniels * * published by Ellis Horwood, Chichester, UK * * ISBN: 0-13-653-0311 * * (also available in Japanese) * * * * Steven Pemberton, CWI/AA, * * Kruislaan 413, 1098 SJ Amsterdam, NL * * Steven.Pemberton@cwi.nl * * * * Adaption from P4 to P5 by: * * * * Scott A. Moore * * samiam@moorecad.com * * * * Note for the implementation. * * =========================== * * 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. * * * * P5 is an extended version of P4 with the following goals: * * * * 1. The remaining unimplemented functions of Pascal are implemented, so that * * P5 is no longer a "subset" of full Pascal. This was done because it is * * no longer necessary to produce a minimum size implementation, and it * * allows any standard program to be used with P5. * * * * 2. The P5 compiler is brought up to ISO 7185 level 0 standards, both in the * * language it compiles for, and the language it is implemented in. * * * * 3. The internal storage efficiency is increased. For example, character * * strings no longer take as much space per character as integers and other * * data. Sets are placed in their own space so that the minimum stack size * * not determined by set size. * * * * 4. The remaining limitations and dependencies on the CDC 6000 version are * * removed. For example, the instruction store no longer is packed 2 * * instructions to a 60 bit word. * * * * 5. General clean up. Longstanding bugs and issues are addressed. Constants * * that were buried in the source (magic numbers) were made constants. The * * type 'alpha' (specific to CDC 6000) was replaced with idstr, etc. * * * * The idea of P5 is to obtain a compiler that is ISO 7185 compliant, can * * compile itself, can compile any reasonable standard program, and is * * efficient enough to be used as a normal compiler for some certain uses. * * Finally, it can serve as a starting implementation for native compilers. * * * * P5 machine instructions added: * * * * rnd round: expects a float on stack, performs round() and places the * * result back on the stack as an integer. * * * * pck ln pack: Expects a packed array on stack top, followed by the * * starting subscript, then the unpacked array. The parameter * * contains the length of packed array in elements. Performs * * pack(upa, ss, pa) and removes all from stack. The starting * * subscript is zero based and scaled to the element size. * * * * upk ln pack: Expects the starting subscript on stack top, followed by the * * unpacked array, then the packed array. The parameter * * contains the length of packed array in elements. Performs * * unpack(pa, upa, ss) and removes all from stack. The starting * * subscript is zero based and scaled to the element size. * * * * rgs set rng: Expects a set range specification on stack, with the last * * value on the top, and the first value next. The two values * * are replaced with a set with all of the values between and * * including the first and last values. * * * * fbv ad buf val: Validates a file buffer variable. Expects a file address on * * stack. The buffer is "validated" for lazy I/O, which means * * that if the associated file is in read mode, the delayed * * read to the buffer variable occurs. The file address remains * * on the stack. * * * * ipj v l ip jmp: Interprocedure jump. Contains the level of the target * * procedure, and the label to jump to. The stack is adjusted * * to remove all nested procedures/functions, then the label is * * unconditionally jumped to. * * * * cip p Call indirect procedure/function. The top of stack has the * * address of a mp/address pair pushed by lpa. The dl of the * * current mark is replaced by the mp, and the address replaces * * the current pc. The mp/ad address is removed from stack. * * * * lpa p l q Load procedure address. The current mark pointer is loaded * * onto the stack, followed by the target procedure or function * * address. This puts enough information on the stack to call * * it with the callers environment. * * * * efb eof: Find eof for binary file. The top of stack is a logical file * * number. The eof boolean vale replaces it. * * * * fvb ad buf val: Expects the length of the file buffer on stack, and the file * * address under that. The buffer is "validated" for lazy I/O, * * which means that if the associated file is in read mode, the * * delayed read to the buffer variable occurs. The buffer * * length is removed only. * * * * dmp q Subtracts the value from the stack top. Used to dump the top * * of the stack. * * * * swp q Pulls the second on stack to the top, swapping the top to * * elements. The size of the top is specified, but the second * * on stack is implied as a pointer. * * * * tjp q Expects a boolean on stack. Jumps to the address if the * * value is true. Removes the value from the stack. * * * * P5 machine built in procedures/functions added: * * * * pag page: Expects a logical file number on stack top. Performs page(). * * * * rsf reset: Expects a logical file number on stack top. Performs * * reset(). * * * * rwf rewrite: Expects a logical file number on stack top. Performs * * reset(). * * * * wrb write: Expects a logical file number on stack top, followed by a * * field number, then a boolean to print. The boolean is output * * as per ISO 7185. * * * * rgs set rng: Expects a set range specification on stack, with the last * * value on the top, and the first value next. The two values * * are replaced with a set with all of the values between and * * including the first and last values. * * * * wrf write: Expects a logical file number on stack top, followed by a * * field number, then a fraction, then a real to print. The * * real is output in r:f:f (fraction) format. All but the file * * are removed from stack. * * * * wbf write: Expects a file address on stack top, followed by the length * * of the type to write, then the variable address to write * * from. Writes binary store to the file. * * * * wbi write: Expects a file address on stack top, followed by an integer. * * Writes the integer to the file in binary format. * * * * wbr write: Expects a file address on stack top, followed by a real. * * Writes the real to the file in binary format. * * * * wbc write: Expects a file address on stack top, followed by a * * character. Writes the character to the file in binary * * format. * * * * wbb write: Expects a file address on stack top, followed by a boolean. * * Writes the boolean to the file in binary format. * * * * rbf read: Expects a file address on stack top, followed by the length * * of the type to read, then the variable address to read * * from. Reads binary store from the file. * * * * rsb reset: Expects a logical file number on stack top. Performs * * reset() and sets the file to binary mode read. * * * * rwb rewrite: Expects a logical file number on stack top. Performs * * rewrite() and sets the file to binary mode write. * * * * gbf get: Get file binary. Expects the length of a file element on * * stack top, followed by a pointer to the file. The next file * * element is loaded to the file buffer. * * * * pbf put: Put file binary. Expects the length of a file element on * * stack top, followed by a pointer to the file. Writes the * * file buffer to thr file. * * * * Note that the previous version of P4 added some type specified instructions * * that used to be unified, typeless instructions. * * * * P5 errors added: * * * * 182 identifier too long * * 183 For index variable must be local to this block * * 184 Interprocedure goto does not reference outter block of destination * * * * P5 instructions modified: * * * * lca'string' ' * * * * was changed to * * * * lca 'string''' * * * * That is, lca has a space before the opening quote, no longer pads to the * * right, and represents single quotes with a quote image. pint converts quote * * images back to single quotes, and pads out strings to their full length. * * * * In addition, the way files work was extensively modified. Original P5 could * * not represent files as full1y expressed variables, such as within an array * * or record, and were effectively treated as constants. To treat them as true * * variable accesses, the stacking order of the file in all file subroutines * * was changed so that the file is on the bottom. This matches the source * * order of the file in write(f, ...) or read(f, ...). Also, the file * * operations now leave the file on the stack for the duration of a write or * * read, then dump them using a specific new instruction "dmp". This allows * * multiparameter writes and reads to be effectively a chain of single * * operations using one file reference. Finally, files were tied to the type * * ending 'a', because files are now full variable references. * * * * Bugs/issues: * * * * 1. Change type matching to ISO 7185 standard. * * * * 2. Pack and unpack don't check for array access beyond end. * * * * 3. Implement the underlying method for dispose. * * * * 4. If we make the length of constant strings a parameter of them, we can * * remove blanks from the right side of them. * * * * 5. Include function result type in congruence check for function parameters. * * * * 6. Commenting out the header parameters like * * * * program test(output); * * * * causes errors. * * * *******************************************************************************} program pcode(input,output,prd,prr); label 1; const maxstr = 524287; { maximum size of addressing for program/var } codemax = maxstr; { set size of code store to maximum possible } pcmax = codemax; { set size of pc as same } maxstk = 30000; { size of variable store = 30,000 } overi = 40000; { size of integer constant table = 10,000 } overr = 50000; { size of real constant table = 10,000 } overs = 60000; { size of set constant table = 10,000 } overb = 70000; { size of bounds check template area = 10,000 } overm = maxstr; { total size of variable store } largeint = 26144; begincode = 3; { the header files have a logical no. followed by a buffer var } inputadr = 5; { 'input' file number } outputadr = 7; { 'output' file number } prdadr = 9; { 'prd' file number } prradr = 11; { 'prr' file number } stringlgth = 80; maxsp = 36; { number of predefined procedures/functions } sethigh = 255; { set is 256 values } setlow = 0; maxins = 255; { maximum instruction code, 0-255 or byte } maxfil = 100; { maximum number of general (temp) files } filesize = 1; { required runtime space for file (logical no.) } type { These equates define the instruction layout. I have choosen a 32 bit layout for the instructions defined by (4 bit) digit: 76543210 ======== iipaaaaa This means that there are 256 instructions, 16 procedure levels, and 512k of total addressing. This could be 1m if we get rid of the need for negatives. } lvltyp = 0..15; { procedure/function level } instyp = 0..maxins; { instruction } adrtyp = -maxstr..maxstr; { address } datatype = (undef,int,reel,bool,sett,adr,mark,car); address = -1..maxstr; beta = packed array[1..25] of char; (*error message*) settype = set of setlow..sethigh; alfa = packed array[1..10] of char; storeelm = record case datatype of undef: (); int :(vi :integer); reel :(vr :real); bool :(vb :boolean); sett :(vs :settype); car :(vc :char); adr :(va :address); (*address in store*) mark :(vm :integer) end; var code : array[0..codemax] of (* the program *) packed record op :instyp; p :lvltyp; q :adrtyp; end; pc : 0..pcmax; (*program address register*) op : instyp; p : lvltyp; q : adrtyp; (*instruction register*) store : array [0..overm] of storeelm; mp,sp,np,ep : address; (* address registers *) (*mp points to beginning of a data segment sp points to top of the stack ep points to the maximum extent of the stack np points to top of the dynamically allocated area*) interpreting: boolean; prd,prr : text;(*prd for read only, prr for write only *) instr : array[instyp] of alfa; (* mnemonic instruction codes *) cop : array[instyp] of integer; sptable : array[0..maxsp] of alfa; (*standard functions and procedures*) filtable : array [1..maxfil] of text; { general (temp) text file holders } { general (temp) binary file holders } bfiltable : array [1..maxfil] of file of storeelm; { file state holding } filstate : array [1..maxfil] of (fclosed, fread, fwrite); { file buffer full status } filbuff : array [1..maxfil] of boolean; (*locally used for interpreting one instruction*) ad,ad1 : address; b : boolean; i,j,i1,i2 : integer; c : char; i3, i4 : integer; pa : integer; stores : storeelm; { used to swap top of stack } (*--------------------------------------------------------------------*) procedure load; const maxlabel = 1850; type labelst = (entered,defined); (*label situation*) labelrg = 0..maxlabel; (*label range*) labelrec = record val: address; st: labelst end; var icp,rcp,scp,bcp,mcp : address; (*pointers to next free position*) word : array[1..10] of char; ch : char; labeltab: array[labelrg] of labelrec; labelvalue: address; procedure init; var i: integer; begin for i := 0 to maxins do instr[i] := ' '; instr[ 0]:='lod '; instr[ 1]:='ldo '; instr[ 2]:='str '; instr[ 3]:='sro '; instr[ 4]:='lda '; instr[ 5]:='lao '; instr[ 6]:='sto '; instr[ 7]:='ldc '; instr[ 8]:='... '; instr[ 9]:='ind '; instr[ 10]:='inc '; instr[ 11]:='mst '; instr[ 12]:='cup '; instr[ 13]:='ent '; instr[ 14]:='ret '; instr[ 15]:='csp '; instr[ 16]:='ixa '; instr[ 17]:='equ '; instr[ 18]:='neq '; instr[ 19]:='geq '; instr[ 20]:='grt '; instr[ 21]:='leq '; instr[ 22]:='les '; instr[ 23]:='ujp '; instr[ 24]:='fjp '; instr[ 25]:='xjp '; instr[ 26]:='chk '; instr[ 27]:='eof '; instr[ 28]:='adi '; instr[ 29]:='adr '; instr[ 30]:='sbi '; instr[ 31]:='sbr '; instr[ 32]:='sgs '; instr[ 33]:='flt '; instr[ 34]:='flo '; instr[ 35]:='trc '; instr[ 36]:='ngi '; instr[ 37]:='ngr '; instr[ 38]:='sqi '; instr[ 39]:='sqr '; instr[ 40]:='abi '; instr[ 41]:='abr '; instr[ 42]:='not '; instr[ 43]:='and '; instr[ 44]:='ior '; instr[ 45]:='dif '; instr[ 46]:='int '; instr[ 47]:='uni '; instr[ 48]:='inn '; instr[ 49]:='mod '; instr[ 50]:='odd '; instr[ 51]:='mpi '; instr[ 52]:='mpr '; instr[ 53]:='dvi '; instr[ 54]:='dvr '; instr[ 55]:='mov '; instr[ 56]:='lca '; instr[ 57]:='dec '; instr[ 58]:='stp '; instr[ 59]:='ord '; instr[ 60]:='chr '; instr[ 61]:='ujc '; { These instructions were added for p5. Note that only 62-64 are available for new instructions, the numbers from 65 to 109 are used for typed instructions. To preserve the original numbering, we restart new instructions at 110 and up. Typed instructions from 65 to 109 were added to allow listings, but don't match anything because they are 4 characters. Not all of the typed instructions make sense, and you will find that they usually go to a single statement. } instr[ 62]:='rnd '; instr[ 63]:='pck '; instr[ 64]:='upk '; instr[ 65]:='ldoa '; instr[ 66]:='ldor '; instr[ 67]:='ldos '; instr[ 68]:='ldob '; instr[ 69]:='ldoc '; instr[ 70]:='stra '; instr[ 71]:='strr '; instr[ 72]:='strs '; instr[ 73]:='strb '; instr[ 74]:='strc '; instr[ 75]:='sroa '; instr[ 76]:='sror '; instr[ 77]:='sros '; instr[ 78]:='srob '; instr[ 79]:='sroc '; instr[ 80]:='stoa '; instr[ 81]:='stor '; instr[ 82]:='stos '; instr[ 83]:='stob '; instr[ 84]:='stoc '; instr[ 85]:='inda '; instr[ 86]:='indr '; instr[ 87]:='inds '; instr[ 88]:='indb '; instr[ 89]:='indc '; instr[ 90]:='inca '; instr[ 91]:='incr '; instr[ 92]:='incs '; instr[ 93]:='incb '; instr[ 94]:='incc '; instr[ 95]:='chka '; instr[ 96]:='chkr '; instr[ 97]:='chks '; instr[ 98]:='chkb '; instr[ 99]:='chkc '; instr[100]:='deca '; instr[101]:='decr '; instr[102]:='decs '; instr[103]:='decb '; instr[104]:='decc '; instr[105]:='loda '; instr[106]:='lodr '; instr[107]:='lods '; instr[108]:='lodb '; instr[109]:='lodc '; instr[110]:='rgs '; instr[111]:='fbv '; instr[112]:='ipj '; instr[113]:='cip '; instr[114]:='lpa '; instr[115]:='efb '; instr[116]:='fvb '; instr[117]:='dmp '; instr[118]:='swp '; instr[119]:='tjp '; instr[120]:='lip '; { sav (mark) and rst (release) were removed } sptable[ 0]:='get '; sptable[ 1]:='put '; sptable[ 2]:='--- '; sptable[ 3]:='rln '; sptable[ 4]:='new '; sptable[ 5]:='wln '; sptable[ 6]:='wrs '; sptable[ 7]:='eln '; sptable[ 8]:='wri '; sptable[ 9]:='wrr '; sptable[10]:='wrc '; sptable[11]:='rdi '; sptable[12]:='rdr '; sptable[13]:='rdc '; sptable[14]:='sin '; sptable[15]:='cos '; sptable[16]:='exp '; sptable[17]:='log '; sptable[18]:='sqt '; sptable[19]:='atn '; sptable[20]:='--- '; { These special routine handlers were added for p5 } sptable[21]:='pag '; sptable[22]:='rsf '; sptable[23]:='rwf '; sptable[24]:='wrb '; sptable[25]:='wrf '; sptable[26]:='dsp '; sptable[27]:='wbf '; sptable[28]:='wbi '; sptable[29]:='wbr '; sptable[30]:='wbc '; sptable[31]:='wbb '; sptable[32]:='rbf '; sptable[33]:='rsb '; sptable[34]:='rwb '; sptable[35]:='gbf '; sptable[36]:='pbf '; cop[ 0] := 105; cop[ 1] := 65; cop[ 2] := 70; cop[ 3] := 75; cop[ 6] := 80; cop[ 9] := 85; cop[10] := 90; cop[26] := 95; cop[57] := 100; pc := begincode; icp := maxstk + 1; rcp := overi + 1; scp := overr + 1; bcp := overs + 2; mcp := overb + 1; for i:= 1 to 10 do word[i]:= ' '; for i:= 0 to maxlabel do with labeltab[i] do begin val:=-1; st:= entered end; { initalize file state } for i := 1 to maxfil do filstate[i] := fclosed; reset(prd); end;(*init*) procedure errorl(string: beta); (*error in loading*) begin writeln; write(string); goto 1 end; (*errorl*) procedure update(x: labelrg); (*when a label definition lx is found*) var curr,succ: -1..pcmax; (*resp. current element and successor element of a list of future references*) endlist: boolean; begin if labeltab[x].st=defined then errorl('duplicated label ') else begin if labeltab[x].val<>-1 then (*forward reference(s)*) begin curr:= labeltab[x].val; endlist:= false; while not endlist do with code[curr] do begin succ:= q; q:= labelvalue; if succ=-1 then endlist:= true else curr:= succ end; end; labeltab[x].st := defined; labeltab[x].val:= labelvalue; end end;(*update*) procedure assemble; forward; procedure generate;(*generate segment of code*) var x: integer; (* label number *) again: boolean; begin again := true; while again do begin read(prd,ch);(* first character of line*) case ch of 'i': readln(prd); 'l': begin read(prd,x); if not eoln(prd) then read(prd,ch); if ch='=' then read(prd,labelvalue) else labelvalue:= pc; update(x); readln(prd); end; 'q': begin again := false; readln(prd) end; ' ': begin read(prd,ch); assemble end end; end end; (*generate*) procedure assemble; (*translate symbolic code into machine code and store*) var name :alfa; r :real; s :settype; i,s1,lb,ub :integer; c: char; procedure lookup(x: labelrg); (* search in label table*) begin case labeltab[x].st of entered: begin q := labeltab[x].val; labeltab[x].val := pc end; defined: q:= labeltab[x].val end(*case label..*) end;(*lookup*) procedure labelsearch; var x: labelrg; begin while (ch<>'l') and not eoln(prd) do read(prd,ch); read(prd,x); lookup(x) end;(*labelsearch*) procedure getname; begin word[1] := ch; read(prd,word[2],word[3]); if not eoln(prd) then read(prd,ch) (*next character*); pack(word,1,name) end; (*getname*) procedure typesymbol; var i: integer; begin if ch <> 'i' then begin case ch of 'a': i := 0; 'r': i := 1; 's': i := 2; 'b': i := 3; 'c': i := 4; end; op := cop[op]+i; end; end (*typesymbol*) ; begin p := 0; q := 0; op := 0; getname; while (instr[op]<>name) and (op < maxins) do op := op+1; if op = maxins then errorl('illegal instruction '); { uncomment next to get an assembler trace } { writeln('assemble: op: ', name:0, ' fc: ', ch, ' (', op:1, ')'); } case op of (* get parameters p,q *) (*equ,neq,geq,grt,leq,les*) 17,18,19, 20,21,22: begin case ch of 'a': ; (*p = 0*) 'i': p := 1; 'r': p := 2; 'b': p := 3; 's': p := 4; 'c': p := 6; 'm': begin p := 5; read(prd,q) end end end; (*lod,str*) 0,2: begin typesymbol; read(prd,p,q) end; 4,120(*lda,lip*): read(prd,p,q); 12(*cup*): begin read(prd,p); labelsearch end; 11,113(*mst,cip*): read(prd,p); 14 (*ret*): case ch of 'p': p:=0; 'i': p:=1; 'r': p:=2; 'c': p:=3; 'b': p:=4; 'a': p:=5 end; (*lao,ixa,mov,pck,upk,fbv,fvb,dmp,swp*) 5,16,55, 63, 64,111,116,117,118: read(prd,q); (*ldo,sro,ind,inc,dec*) 1,3,9,10,57: begin typesymbol; read(prd,q) end; (*ujp,fjp,xjp,lpa,tjp*) 23,24,25,119: labelsearch; (*ent,ipj*) 13,112,114: begin read(prd,p); labelsearch end; 15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname; while name<>sptable[q] do begin q := q+1; if q > maxsp then errorl('std proc/func not found ') end end; 7 (*ldc*): begin case ch of (*get q*) 'i': begin p := 1; read(prd,i); if abs(i)>=largeint then begin op := 8; store[icp].vi := i; q := maxstk; repeat q := q+1 until store[q].vi=i; if q=icp then begin icp := icp+1; if icp=overi then errorl('integer table overflow '); end end else q := i end; 'r': begin op := 8; p := 2; read(prd,r); store[rcp].vr := r; q := overi; repeat q := q+1 until store[q].vr=r; if q=rcp then begin rcp := rcp+1; if rcp = overr then errorl('real table overflow '); end end; 'n': ; (*p,q = 0*) 'b': begin p := 3; read(prd,q) end; 'c': begin p := 6; repeat read(prd,ch); until ch <> ' '; if ch <> '''' then errorl('illegal character '); read(prd,ch); q := ord(ch); read(prd,ch); if ch <> '''' then errorl('illegal character '); end; '(': begin op := 8; p := 4; s := [ ]; read(prd,ch); while ch<>')' do begin read(prd,s1,ch); s := s + [s1] end; store[scp].vs := s; q := overr; repeat q := q+1 until store[q].vs=s; if q=scp then begin scp := scp+1; if scp=overs then errorl('set table overflow '); end end end (*case*) end; 26 (*chk*): begin typesymbol; read(prd,lb,ub); if op = 95 then q := lb else begin store[bcp-1].vi := lb; store[bcp].vi := ub; q := overs; repeat q := q+2 until (store[q-1].vi=lb)and (store[q].vi=ub); if q=bcp then begin bcp := bcp+2; if bcp=overb then errorl('boundary table overflow '); end end end; 56 (*lca*): begin while (ch <> '''') and not eoln(prd) do read(prd,ch); if ch <> '''' then errorl('bad string format '); if mcp + stringlgth >= overm then errorl('multiple table overflow '); mcp := mcp+stringlgth; q := mcp; for i := 0 to stringlgth-1 do store[q+i].vc := ' '; i := 0; repeat if eoln(prd) then errorl('unterminated string '); read(prd,ch); c := ch; if (ch = '''') and (prd^ = '''') then begin read(prd,ch); c := ' ' end; if c <> '''' then begin if i >= stringlgth then errorl('string overflow '); store[q+i].vc := ch; i := i+1 end until c = '''' end; 6 (*sto*): typesymbol; 27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,58,60,62,110,115: ; 59 (*ord*): begin case ch of 'i': p := 1; 'r': p := 2; 'b': p := 3; 's': p := 4; 'c': p := 6; end end; 61 (*ujc*): ; (*must have same length as ujp*) end; (*case*) (* store instruction *) code[pc].op := op; code[pc].p := p; code[pc].q := q; pc := pc+1; readln(prd); end; (*assemble*) begin (*load*) init; generate; pc := 0; generate; end; (*load*) (*------------------------------------------------------------------------*) procedure pmd; var s :integer; i: integer; procedure pt; begin write(s:6); if abs(store[s].vi) < maxint then write(store[s].vi) else write('too big '); s := s - 1; i := i + 1; if i = 4 then begin writeln(output); i := 0 end; end; (*pt*) begin write(' pc =',pc-1:5,' op =',op:3,' sp =',sp:5,' mp =',mp:5, ' np =',np:5); writeln; writeln('--------------------------------------'); s := sp; i := 0; while s>=0 do pt; s := maxstk; while s>=np do pt; end; (*pmd*) procedure errori(string: beta); begin writeln; writeln('*** Runtime error: ', string); pmd; goto 1 end;(*errori*) function base(ld :integer):address; var ad :address; begin ad := mp; while ld>0 do begin ad := store[ad+1].vm; ld := ld-1 end; base := ad end; (*base*) procedure compare; (*comparing is only correct if result by comparing integers will be*) begin i1 := store[sp].va; i2 := store[sp+1].va; i := 0; b := true; while b and (i<>q) do if store[i1+i].vi = store[i2+i].vi then i := i+1 else b := false end; (*compare*) procedure valfil(fa: address); { attach file to file entry } var i,ff: integer; begin if store[fa].vi = 0 then begin { no file } i := 1; ff := 0; while i <= maxfil do begin if filstate[i] = fclosed then begin ff := i; i := maxfil end; i := i+1 end; if ff = 0 then errori('To many files '); store[fa].vi := ff end end; procedure callsp; var line: boolean; i,j: integer; ad,ad1: address; procedure readi(var f:text); var ad: address; begin if eof(f) then errori('End of file '); ad:= store[sp].va; read(f,store[ad].vi); sp:= sp-1 end;(*readi*) procedure readr(var f: text); var ad: address; begin if eof(f) then errori('End of file '); ad:= store[sp].va; read(f,store[ad].vr); sp:= sp-1 end;(*readr*) procedure readc(var f: text); var c: char; ad: address; begin if eof(f) then errori('End of file '); read(f,c); ad:= store[sp].va; store[ad].vc := c; sp:= sp-1 end;(*readc*) procedure writestr(var f: text); var i,j,k: integer; ad: address; begin ad:= store[sp-2].va; k := store[sp-1].vi; j := store[sp].vi; (* j and k are numbers of characters *) if k>j then for i:=1 to k-j do write(f,' ') else j:= k; for i := 0 to j-1 do write(f,store[ad+i].vc); sp:= sp-3 end;(*writestr*) procedure getfile(var f: text); begin if eof(f) then errori('End of file '); get(f); sp:=sp-1 end;(*getfile*) procedure putfile(var f: text); var ad: address; begin ad:= store[sp].va; f^:= store[ad+1].vc; put(f); sp:= sp-1; end;(*putfile*) begin (*callsp*) if q > maxsp then errori('invalid std proc/func '); { uncomment this next for a standard routine trace } { writeln(pc:6, '/', sp:6, '-> ', q:2); } case q of 0 (*get*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: getfile(input); outputadr: errori('get on output file '); prdadr: getfile(prd); prradr: errori('get on prr file ') end else begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); getfile(filtable[store[ad].vi]) end end; 1 (*put*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: errori('put on read file '); outputadr: putfile(output); prdadr: errori('put on prd file '); prradr: putfile(prr) end else begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); putfile(filtable[store[ad].vi]) end end; { unused placeholder for "release" } 2 (*rst*): errori('invalid std proc/func '); 3 (*rln*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: begin if eof(input) then errori('End of file '); readln(input) end; outputadr: errori('readln on output file '); prdadr: begin if eof(prd) then errori('End of file '); readln(prd) end; prradr: errori('readln on prr file ') end else begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); if eof(filtable[store[ad].vi]) then errori('End of file '); readln(filtable[store[ad].vi]) end end; 4 (*new*): begin ad:= np-store[sp].va; (*top of stack gives the length in units of storage *) if ad <= ep then errori('store overflow '); np:= ad; ad:= store[sp-1].va; store[ad].va := np; sp:=sp-2 end; 5 (*wln*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: errori('writeln on input file '); outputadr: writeln(output); prdadr: errori('writeln on prd file '); prradr: writeln(prr) end else begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); writeln(filtable[store[ad].vi]) end end; 6 (*wrs*): begin if (store[sp-3].va >= inputadr) and (store[sp-3].va <= prradr) then case store[sp-3].va of inputadr: errori('write on input file '); outputadr: writestr(output); prdadr: errori('write on prd file '); prradr: writestr(prr) end else begin ad := store[sp-3].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); writestr(filtable[store[ad].vi]) end; end; 7 (*eln*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: line:= eoln(input); outputadr: errori('eoln output file '); prdadr: line:=eoln(prd); prradr: errori('eoln on prr file ') end else begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); line:=eoln(filtable[store[ad].vi]) end; store[sp].vb := line end; 8 (*wri*): begin if (store[sp-2].va >= inputadr) and (store[sp-2].va <= prradr) then case store[sp-2].va of inputadr: errori('write on input file '); outputadr: write(output, store[sp-1].vi: store[sp].vi); prdadr: errori('write on prd file '); prradr: write(prr, store[sp-1].vi: store[sp].vi) end else begin ad := store[sp-2].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); write(filtable[store[ad].vi], store[sp-1].vi: store[sp].vi) end; sp:=sp-2 end; 9 (*wrr*): begin if (store[sp-2].va >= inputadr) and (store[sp-2].va <= prradr) then case store[sp-2].va of inputadr: errori('write on input file '); outputadr: write(output, store[sp-1].vr: store[sp].vi); prdadr: errori('write on prd file '); prradr: write(prr, store[sp-1].vr: store[sp].vi) end else begin ad := store[sp-2].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); write(filtable[store[ad].vi], store[sp-1].vr: store[sp].vi) end; sp:=sp-2 end; 10(*wrc*): begin if (store[sp-2].va >= inputadr) and (store[sp-2].va <= prradr) then case store[sp-2].va of inputadr: errori('write on input file '); outputadr: write(output,store[sp-1].vc: store[sp].vi); prdadr: errori('write on prd file '); prradr: write(prr,store[sp-1].vc: store[sp].vi); end else begin ad := store[sp-2].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); write(filtable[store[ad].vi], store[sp-1].vc: store[sp].vi) end; sp:=sp-2 end; 11(*rdi*): begin if (store[sp-1].va >= inputadr) and (store[sp-1].va <= prradr) then case store[sp-1].va of inputadr: readi(input); outputadr: errori('read on output file '); prdadr: readi(prd); prradr: errori('read on prr file ') end else begin ad := store[sp-1].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); readi(filtable[store[ad].vi]) end end; 12(*rdr*): begin if (store[sp-1].va >= inputadr) and (store[sp-1].va <= prradr) then case store[sp-1].va of inputadr: readr(input); outputadr: errori('read on output file '); prdadr: readr(prd); prradr: errori('read on prr file ') end else begin ad := store[sp-1].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); readr(filtable[store[ad].vi]) end end; 13(*rdc*): begin if (store[sp-1].va >= inputadr) and (store[sp-1].va <= prradr) then case store[sp-1].va of inputadr: readc(input); outputadr: errori('read on output file '); prdadr: readc(prd); prradr: errori('read on prr file ') end else begin ad := store[sp-1].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); readc(filtable[store[ad].vi]) end end; 14(*sin*): store[sp].vr:= sin(store[sp].vr); 15(*cos*): store[sp].vr:= cos(store[sp].vr); 16(*exp*): store[sp].vr:= exp(store[sp].vr); 17(*log*): store[sp].vr:= ln(store[sp].vr); 18(*sqt*): store[sp].vr:= sqrt(store[sp].vr); 19(*atn*): store[sp].vr:= arctan(store[sp].vr); { placeholder for "mark" } 20(*sav*): errori('invalid std proc/func '); 21(*pag*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: errori('page on read file '); outputadr: page(output); prdadr: errori('page on prd file '); prradr: page(prr) end else begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); page(filtable[store[ad].vi]) end; sp:= sp-1 end; 22(*rsf*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: errori('reset on input file '); outputadr: errori('reset on output file '); prdadr: reset(prd); prradr: errori('reset on prr file ') end else begin ad := store[sp].va; valfil(ad); filstate[store[ad].vi] := fread; reset(filtable[store[ad].vi]); end; sp:= sp-1 end; 23(*rwf*): begin if (store[sp].va >= inputadr) and (store[sp].va <= prradr) then case store[sp].va of inputadr: errori('rewrite on input file '); outputadr: errori('rewrite on output file '); prdadr: errori('rewrite on prd file '); prradr: rewrite(prr) end else begin ad := store[sp].va; valfil(ad); filstate[store[ad].vi] := fwrite; rewrite(filtable[store[ad].vi]); end; sp:= sp-1 end; 24(*wrb*): begin if (store[sp-2].va >= inputadr) and (store[sp-2].va <= prradr) then case store[sp-2].va of inputadr: errori('write on input file '); outputadr: write(output,store[sp-1].vb: store[sp].vi); prdadr: errori('write on prd file '); prradr: write(prr,store[sp-1].vb: store[sp].vi); end else begin ad := store[sp-2].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); write(filtable[store[ad].vi], store[sp-1].vb: store[sp].vi) end; sp:=sp-2 end; 25(*wrf*): begin if (store[sp-3].va >= inputadr) and (store[sp-3].va <= prradr) then case store[sp-3].va of inputadr: errori('write on input file '); outputadr: write(output, store[sp-2].vr: store[sp-1].vi: store[sp].vi); prdadr: errori('write on prd file '); prradr: write(prr, store[sp-2].vr: store[sp-1].vi: store[sp].vi) end else begin ad := store[sp-3].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); write(filtable[store[ad].vi], store[sp-2].vr: store[sp-1].vi: store[sp].vi) end; sp:=sp-3 end; 26(*dsp*): begin { dispose is a no-op for now } sp:=sp-2 end; 27(*wbf*): begin ad1 := store[sp-2].va; valfil(ad1); if filstate[store[ad1].vi] <> fwrite then errori('File not in write mode '); ad := store[sp-1].va; for i := 1 to store[sp].vi do begin write(bfiltable[store[ad1].vi], store[ad]); ad := ad+1 end; sp:= sp-2 end; 28,29,30,31(*wbi,wbr,wbc,wbb*): begin ad := store[sp-1].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); write(bfiltable[store[ad].vi], store[sp]); sp:= sp-1 end; 32(*rbf*): begin ad1 := store[sp-2].va; valfil(ad1); if filstate[store[ad1].vi] <> fread then errori('File not in read mode '); if eof(bfiltable[store[ad1].vi]) then errori('End of file '); ad := store[sp-1].va; for i := 1 to store[sp].vi do begin read(bfiltable[store[ad1].vi], store[ad]); ad := ad+1 end; sp:= sp-2 end; 33(*rsb*): begin ad := store[sp].va; valfil(ad); filstate[store[ad].vi] := fread; reset(bfiltable[store[ad].vi]); filbuff[store[ad].vi] := false; sp:= sp-1 end; 34(*rwb*): begin ad := store[sp].va; valfil(ad); filstate[store[ad].vi] := fwrite; rewrite(bfiltable[store[ad].vi]); sp:= sp-1 end; 35(*gbf*): begin i := store[sp].vi; ad := store[sp-1].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); if filbuff[store[ad].vi] then filbuff[store[ad].vi] := false else for j := 1 to i do read(bfiltable[store[ad].vi], store[q+filesize+j-1]); sp:= sp-2 end; 36(*pbf*): begin i := store[sp].vi; ad := store[sp-1].va; valfil(ad); if filstate[store[ad].vi] <> fwrite then errori('File not in write mode '); for j := 1 to i do write(bfiltable[store[ad].vi], store[ad+filesize+j-1]); end; end;(*case q*) end;(*callsp*) begin (* main *) writeln('P5 Pascal intepreter vs. 0.1'); writeln; rewrite(prr); writeln('Assembling/loading program'); load; (* assembles and stores code *) pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5; interpreting := true; writeln('Running program'); writeln; while interpreting do begin (*fetch*) op := code[pc].op; p := code[pc].p; q := code[pc].q; pc := pc+1; (*execute*) { uncomment this next for an instruction trace } { writeln(pc:6, '/', sp:6, ': ', op:3, '[', instr[op]:4, ']', ' (', p:2, ',', q:6, ')'); } case op of 105,106,107,108,109, 0 (*lod*): begin ad := base(p) + q; sp := sp+1; store[sp] := store[ad] end; 65,66,67,68,69, 1 (*ldo*): begin sp := sp+1; store[sp] := store[q] end; 70,71,72,73,74, 2 (*str*): begin store[base(p)+q] := store[sp]; sp := sp-1 end; 75,76,77,78,79, 3 (*sro*): begin store[q] := store[sp]; sp := sp-1 end; 4 (*lda*): begin sp := sp+1; store[sp].va := base(p) + q end; 5 (*lao*): begin sp := sp+1; store[sp].va := q end; 80,81,82,83,84, 6 (*sto*): begin store[store[sp-1].va] := store[sp]; sp := sp-2; end; 7 (*ldc*): begin sp := sp+1; if p=1 then begin store[sp].vi := q; end else if p = 6 then store[sp].vc := chr(q) else if p = 3 then store[sp].vb := q = 1 else (* load nil *) store[sp].va := maxstr end; 8 (*lci*): begin sp := sp+1; store[sp] := store[q] end; 85,86,87,88,89, 9 (*ind*): begin ad := store[sp].va + q; (* q is a number of storage units *) store[sp] := store[ad] end; 10 (*inc*): store[sp].vi := store[sp].vi+q; 90 (*inc*): store[sp].va := store[sp].va+q; 91,92: errori('Instruction error '); 93 (*incb*): store[sp].vb := succ(store[sp].vb); 94 (*incc*): store[sp].vc := chr(ord(store[sp].vc)+q); 11 (*mst*): begin (*p=level of calling procedure minus level of called procedure + 1; set dl and sl, increment sp*) (* then length of this element is max(intsize,realsize,boolsize,charsize,ptrsize *) store[sp+2].vm := base(p); (* the length of this element is ptrsize *) store[sp+3].vm := mp; (* idem *) store[sp+4].vm := ep; (* idem *) sp := sp+5 end; 12 (*cup*): begin (*p=no of locations for parameters, q=entry point*) mp := sp-(p+4); store[mp+4].vm := pc; pc := q end; 13 (*ent*): if p = 1 then begin ad := mp + q; (*q = length of dataseg*) if sp > np then errori('store overflow '); { clear allocated memory } while sp < ad do begin sp := sp+1; store[sp].vi := 0 end end else begin ep := sp+q; if ep > np then errori('store overflow '); end; (*q = max space required on stack*) 14 (*ret*): begin case p of 0: sp:= mp-1; 1,2,3,4,5: sp:= mp end; pc := store[mp+4].vm; ep := store[mp+3].vm; mp:= store[mp+2].vm; end; 15 (*csp*): callsp; 16 (*ixa*): begin i := store[sp].vi; sp := sp-1; store[sp].va := q*i+store[sp].va; end; 17 (*equ*): begin sp := sp-1; case p of 1: store[sp].vb := store[sp].vi = store[sp+1].vi; 0: store[sp].vb := store[sp].va = store[sp+1].va; 6: store[sp].vb := store[sp].vc = store[sp+1].vc; 2: store[sp].vb := store[sp].vr = store[sp+1].vr; 3: store[sp].vb := store[sp].vb = store[sp+1].vb; 4: store[sp].vb := store[sp].vs = store[sp+1].vs; 5: begin compare; store[sp].vb := b; end; end; (*case p*) end; 18 (*neq*): begin sp := sp-1; case p of 0: store[sp].vb := store[sp].va <> store[sp+1].va; 1: store[sp].vb := store[sp].vi <> store[sp+1].vi; 6: store[sp].vb := store[sp].vc <> store[sp+1].vc; 2: store[sp].vb := store[sp].vr <> store[sp+1].vr; 3: store[sp].vb := store[sp].vb <> store[sp+1].vb; 4: store[sp].vb := store[sp].vs <> store[sp+1].vs; 5: begin compare; store[sp].vb := not b; end end; (*case p*) end; 19 (*geq*): begin sp := sp-1; case p of 0: errori('<,<=,>,>= for address '); 1: store[sp].vb := store[sp].vi >= store[sp+1].vi; 6: store[sp].vb := store[sp].vc >= store[sp+1].vc; 2: store[sp].vb := store[sp].vr >= store[sp+1].vr; 3: store[sp].vb := store[sp].vb >= store[sp+1].vb; 4: store[sp].vb := store[sp].vs >= store[sp+1].vs; 5: begin compare; store[sp].vb := b or (store[i1+i].vi >= store[i2+i].vi) end end; (*case p*) end; 20 (*grt*): begin sp := sp-1; case p of 0: errori('<,<=,>,>= for address '); 1: store[sp].vb := store[sp].vi > store[sp+1].vi; 6: store[sp].vb := store[sp].vc > store[sp+1].vc; 2: store[sp].vb := store[sp].vr > store[sp+1].vr; 3: store[sp].vb := store[sp].vb > store[sp+1].vb; 4: errori('set inclusion '); 5: begin compare; store[sp].vb := not b and (store[i1+i].vi > store[i2+i].vi) end end; (*case p*) end; 21 (*leq*): begin sp := sp-1; case p of 0: errori('<,<=,>,>= for address '); 1: store[sp].vb := store[sp].vi <= store[sp+1].vi; 6: store[sp].vb := store[sp].vc <= store[sp+1].vc; 2: store[sp].vb := store[sp].vr <= store[sp+1].vr; 3: store[sp].vb := store[sp].vb <= store[sp+1].vb; 4: store[sp].vb := store[sp].vs <= store[sp+1].vs; 5: begin compare; store[sp].vb := b or (store[i1+i].vi <= store[i2+i].vi) end; end; (*case p*) end; 22 (*les*): begin sp := sp-1; case p of 0: errori('<,<=,>,>= for address '); 1: store[sp].vb := store[sp].vi < store[sp+1].vi; 6: store[sp].vb := store[sp].vc < store[sp+1].vc; 2: store[sp].vb := store[sp].vr < store[sp+1].vr; 3: store[sp].vb := store[sp].vb < store[sp+1].vb; 5: begin compare; store[sp].vb := not b and (store[i1+i].vi < store[i2+i].vi) end end; (*case p*) end; 23 (*ujp*): pc := q; 24 (*fjp*): begin if not store[sp].vb then pc := q; sp := sp-1 end; 25 (*xjp*): begin pc := store[sp].vi + q; sp := sp-1 end; 95 (*chka*): if (store[sp].va < np) or (store[sp].va > (maxstr-q)) then errori('bad pointer value '); (* expanded these cases per type *) 96,97, 26 (*chk*): if (store[sp].vi < store[q-1].vi) or (store[sp].vi > store[q].vi) then errori('value out of range '); 98 (*chkb*): if (store[sp].vb < store[q-1].vb) or (store[sp].vb > store[q].vb) then errori('value out of range '); 99 (*chkc*): if (store[sp].vc < store[q-1].vc) or (store[sp].vc > store[q].vc) then errori('value out of range '); 27 (*eof*): begin ad := store[sp].vi; if ad=inputadr then store[sp].vb := eof(input) else if ad=prdadr then store[sp].vb := eof(prd) else if (ad=outputadr) or (ad=prradr) then errori('eof test on output file ') else begin valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); store[sp].vb := eof(filtable[store[ad].vi]) end end; 28 (*adi*): begin sp := sp-1; store[sp].vi := store[sp].vi + store[sp+1].vi end; 29 (*adr*): begin sp := sp-1; store[sp].vr := store[sp].vr + store[sp+1].vr end; 30 (*sbi*): begin sp := sp-1; store[sp].vi := store[sp].vi - store[sp+1].vi end; 31 (*sbr*): begin sp := sp-1; store[sp].vr := store[sp].vr - store[sp+1].vr end; 32 (*sgs*): store[sp].vs := [store[sp].vi]; 33 (*flt*): store[sp].vr := store[sp].vi; 34 (*flo*): store[sp-1].vr := store[sp-1].vi; 35 (*trc*): store[sp].vi := trunc(store[sp].vr); 36 (*ngi*): store[sp].vi := -store[sp].vi; 37 (*ngr*): store[sp].vr := -store[sp].vr; 38 (*sqi*): store[sp].vi := sqr(store[sp].vi); 39 (*sqr*): store[sp].vr := sqr(store[sp].vr); 40 (*abi*): store[sp].vi := abs(store[sp].vi); 41 (*abr*): store[sp].vr := abs(store[sp].vr); 42 (*not*): store[sp].vb := not store[sp].vb; 43 (*and*): begin sp := sp-1; store[sp].vb := store[sp].vb and store[sp+1].vb end; 44 (*ior*): begin sp := sp-1; store[sp].vb := store[sp].vb or store[sp+1].vb end; 45 (*dif*): begin sp := sp-1; store[sp].vs := store[sp].vs - store[sp+1].vs end; 46 (*int*): begin sp := sp-1; store[sp].vs := store[sp].vs * store[sp+1].vs end; 47 (*uni*): begin sp := sp-1; store[sp].vs := store[sp].vs + store[sp+1].vs end; 48 (*inn*): begin sp := sp - 1; i := store[sp].vi; store[sp].vb := i in store[sp+1].vs; end; 49 (*mod*): begin sp := sp-1; store[sp].vi := store[sp].vi mod store[sp+1].vi end; 50 (*odd*): store[sp].vb := odd(store[sp].vi); 51 (*mpi*): begin sp := sp-1; store[sp].vi := store[sp].vi * store[sp+1].vi end; 52 (*mpr*): begin sp := sp-1; store[sp].vr := store[sp].vr * store[sp+1].vr end; 53 (*dvi*): begin sp := sp-1; store[sp].vi := store[sp].vi div store[sp+1].vi end; 54 (*dvr*): begin sp := sp-1; store[sp].vr := store[sp].vr / store[sp+1].vr end; 55 (*mov*): begin i1 := store[sp-1].va; i2 := store[sp].va; sp := sp-2; for i3 := 0 to q-1 do store[i1+i3] := store[i2+i3] (* q is a number of storage units *) end; 56 (*lca*): begin sp := sp+1; store[sp].va := q; end; 100,101,102, 57 (*dec*): store[sp].vi := store[sp].vi-q; 103 (*decb*): store[sp].vb := pred(store[sp].vb); 104 (*decc*): store[sp].vc := chr(ord(store[sp].vc)-q); 58 (*stp*): interpreting := false; 59 (*ord*): begin if p = 3 then store[sp].vi := ord(store[sp].vb) else if p = 6 then store[sp].vi := ord(store[sp].vc) end; 60 (*chr*): store[sp].vc := chr(store[sp].vi); 61 (*ujc*): errori('case - error '); 62 (*rnd*): store[sp].vi := round(store[sp].vr); 63 (*pck*): begin i1 := store[sp-2].va; i2 := store[sp-1].va; i3 := store[sp].va; for i4 := 0 to q-1 do begin store[i3+i4] := store[i1+i2]; i2 := i2+1 end; sp := sp-3 end; 64 (*upk*): begin i1 := store[sp-2].va; i2 := store[sp-1].va; i3 := store[sp].va; for i4 := 0 to q-1 do begin store[i2+i3] := store[i1+i4]; i3 := i3+1 end; sp := sp-3 end; 110(*rgs*): begin store[sp-1].vs := [store[sp-1].vi..store[sp].vi]; sp := sp-1 end; 111(*fbv*): begin ad := store[sp].va; if ad = inputadr then store[q+filesize].vc := input^ else if ad = prdadr then store[q+filesize].vc := prd^ else begin valfil(ad); if filstate[store[ad].vi] = fread then store[ad+filesize].vc := filtable[store[ad].vi]^ end end; 112(*ipj*): begin pc := q; i := p; { restore marks until we reach the destination level } while i>0 do begin sp := mp; ep := store[mp+3].vm; mp := store[mp+2].vm; i := i-1 end end; 113(*cip*): begin ad := store[sp].va; sp := sp-1; mp := sp-(p+4); { replace next link mp with the one for the target } store[mp+1].vm := store[ad].vm; store[mp+4].vm := pc; pc := store[ad+1].vm end; 114(*lpa*): begin { place procedure address on stack } sp := sp+2; store[sp-1].vm := base(p); store[sp].vm := q end; 115(*efb*): begin ad := store[sp].va; valfil(ad); if filstate[store[ad].vi] <> fread then errori('File not in read mode '); store[sp].vb := eof(bfiltable[store[ad].vi]) end; 116(*fvb*): begin i := store[sp].vi; ad := store[sp-1].va; valfil(ad); if (filstate[store[ad].vi] = fread) and not filbuff[store[ad].vi] then begin for j := 1 to i do read(bfiltable[store[ad].vi], store[ad+filesize+j-1]); filbuff[store[ad].vi] := true end; sp := sp-1 end; 117(*dmp*): sp := sp-q; { remove top of stack } 118(*swp*): begin stores := store[sp]; store[sp] := store[sp-1]; store[sp-1] := stores end; 119(*tjp*): begin if store[sp].vb then pc := q; sp := sp-1 end; 120(*lip*): begin ad := base(p) + q; sp := sp+2; store[sp-1] := store[ad]; store[sp] := store[ad+1] end; end end; (*while interpreting*) 1 : writeln; writeln('program complete'); end.