⟦51c6164c6⟧

TextFile

program platonpass1(input,output,spixtable='spixtoname',
codefile='pass1code',symbfile='pass1labels');

label 10; (*exit label*)
const
(* bobs-constants*)
stackmax=100; (*size of attstack and parsestack *)
stringmax=100; (* size of attribute string *)
chbufmax=200; (* size of array chbuf *)
minch=' '; maxch='ü'; (*first/last character in type char*)
linemax=150; (*max. length of lines*)
testoutput=false; (* do not output the steps in the parse *)

(*global constants used in code*)
higherror     = 105;      (* highest error number from code *)
version = 'pascal80     version 1980.09.24';
nill = -1;                       (* end of chain *)
alfalength=12;                  (*length of alfa variable*)
blank='          ';             (*to clear a variable of type alfa*)
maxnamelength = 255;  (* maximum length of a name *)
maxnamenodeindex = 1500;  (* maximum number of name chunks *)
maxnameheads = 1000;               (* maximum number of different names *)
maxspix       = 65000; (* maximum number of different spix'es *)
typebuffersize= 500;   (* maximum number of buffered codes *)
hashtablesize = 41;
maxinclude = 5;  (* maximum number of unsatisfied include names *)
stop3 = 3; (* option value to pass3 for stop.3 *)
stop4 = 5; (* option value to pass4 for stop.4 *)
stop5 = 5; (* option value to pass5 for stop.5 *)



type
(* bobs-types*)
chbufinx=0..chbufmax;
stackinx=0..stackmax;
string=packed arrayÆ1..stringmaxÅ of char;

(*types used in code*)
attributes=record
chbufp:chbufinx;
bufferstart : 1..typebuffersize; (* start index in type buffer 
for this element *)
oldlabelscope : integer;  

end;
hashindex = 0..hashtablesize;
namelength = 0.. maxnamelength;
spixrange = 0.. maxspix;

nameptr = nill .. maxnamenodeindex;
nameheadptr = nill .. maxnameheads;
 
namehead = packed record
length : namelength;
spix : spixrange;
start : nameptr; (* first chunk *)
next : nameheadptr;
end;

namenode = packed record
next : nameptr;
case boolean of
true: ( namepart : alfa );
false: ( integerpart : integer );
(* integerpart is only used by the hash function *)
end;

inclindex = 0..maxinclude;
includenamenode = record
next : inclindex;
namepart : alfa;
end;


declarekind = (decl, decllist); (* used by emitdeclare *)
codes =
(
cnocode,
cerror, cerrortext, cerrorno,
coption,
cnewline,
ceom,

cstandardname,
(* parameters to 'standardname' *)
canonymous, (* first std name *)
cboolean,
cchar,
cshadow,
creference,
csemaphore,
cson,
cexception,
cabs,
csucc,
cpred,
cord,       (* last std name *)

cinclude, cendinclude,
ccontext, cerrcontext, cendcontext,

cendprefix,

cbeginlevel, cendlevel,
cdeclaration, cdeclare, cdeclarelist,

cexternal, cforward,

cendformallist, cendformal,
cendprocdecl, cendfuncdecl, cendtypedecl,
cendconstantdecl,

cnoinit, cinit, cendvardecl,

cenddeclarations,

cstartlabelscope, cendlabelscope,

cbegincode, ccodeline, cendcode,

cendblock,

ctypeid,
cendtype,
cwithout_data,

cnewtype,
cendscalar, cendsubrange, cendarray, cendfield, cendrecord, cendset,
cendpool, cendpointer, cendreadonly,
cpacked,

cbegin, cend,

clabeldef,

ccasestat, ccaseexpr, ccaselabel, ccaselabelrange, ccaselist,
ccaseelement, cotherwise, cendcase,

cforstat, cforvar, cup, cdown, cendfor,

cifstat, cifexpr, celse, cendif,

crepeatstat, cuntil, cendrepeat,

cwhilestat, cwhileexpr, cendwhile,

clockstat, cwithstat, cwithvar,
cnolocaldecl, cendlocaldeclare,
cwithcomma, cdo, cendwith,

cgotostat, cendgoto,

cchannelstat, cchanvar, cendchannel,

cendassign, cendexchange,

ccallprocedure,

(* expression codes *)
cendexpression,
ceq, cne, clt, cle, cgt, cge, cin,
cuplus, cuminus, cplus, cminus, cor,
cstar, cslash, cdiv, cmod, cand,
cnot,
cgetvalue,
cindex, (* <<< used internally by pass3 *)

(* operand codes *)
csetlist, cs_element, cm_element, cendsetlist,
cliteral,
cid,
cskipparam,
cfield,
cuparrow,
crangefirst, (* <<< used internally by pass3 *)

cactualparam, cdoubleparam, cendactual,
(* the following few lines are all for internal pass3-use *)
cfunctrailer, cfunctemp, cerrorarg, cargument,
cfcall, cendproc,
cstrucrecord, cstrucarray, cendstruc,


(* namekinds i.e. parameters for 'declaration' *)
cprocess, cprocedure, cfunction, ctype,
cscalarelem, crecfield, cconstant, cvar,
cvarp, cvaluep, cfuncval (* <<< used internally by pass3 *),
clabel,
cprefix,
cundeclared (* <<< used internally by pass3 *),


(* typekinds *)
calias (* <<< used internally by pass3 *),
(* typekinds i.e. parameters for 'newtype' *)
cerrorkind (* <<< used internally by pass3 *),
cscalar, csubrange, carray, crecord, cset, cpool,
cpointer, creadonly,
(* standard types *)
cinteger, creal, cniltype,
ctext, (* used for string-literals *)

clastcode (* used internally by pass1/pass3 *)

);

codeindex = 0 .. 200; (* number of codes *)

\f



(* end pass 1 codes *)

var
i : integer;
inputfile : boolean;
systemparamno : integer;      (* reference to next fp-parameter
in the command stack *)
(* bobs-variables*)
attstack: arrayÆstackinxÅ of attributes;
chbuf: arrayÆchbufinxÅ of char;
chbufi: chbufinx;
ok: boolean;
(*chbuf, chbufi, field chbufp of attributes, tables and ok
(*should not be changed by the user *)
errormarks : packed array Æ0..higherrorÅ of boolean;
warningcount,
errorcount  : integer ;
line: arrayÆ1..linemaxÅ of char; (*contains current line*)
linenumber,                      (* current global line number *)
locallinenumber,                 (* current relative line number of current procedure *)
linelength,                      (*length of current line*)
errorinx,                        (*position in line of last error mark*)
indention,                       (*number of leading spaces on a line *)
lineinx: integer;                (*position in line of current ch*)
more_sources_allowed,        (* true until prefix or process met *)
call_pass_3,          (* option '$ 1 2 1 ' *)
programlist,                     (* option list.yes or  '$ 1 1 1' *)
printed: boolean;                (*true if current line has been printed*)
anonymousspix,    (* spix of '?' *)
lastspix,             (* highest spix in use *)
currentlabelscope,    (* the actual label level *)
lastlabelscope : integer; (* highest used scope nr *)



before_standard_defs ,
contextparsing,
nametable_dump : boolean;  (* option survey.yes or no *)
dimension_count,           (* count nested arrays, i.e. the number of dimensions *)


lastbuffered : integer;  (* last used element in typebuffer *)
typebuffer : array Æ0..typebuffersizeÅ of integer;
typebufferflag : boolean;  (* indicates whether the codes are to be buffered or not *)

lastnamehead,           (* last used name head *)
nameheadfreelist : nameheadptr;
lastnamenode,           (* last used name node *)
namenodefreelist : nameptr;

nameheads : array Æ nameheadptr Å of namehead;
namenodes : array Æ nameptr     Å of namenode;
  
namehashtable : array Æ hashindex Å of nameheadptr;




(* the global variables used in emit-procedures *)
symbfile, codefile : file of integer;
 spixtable : text;

\f


(* bobs-procedures*)
procedure stop(n: integer); forward;

procedure printline;
var i :integer;
begin
if programlist then
begin
write(linenumber:5,' ');
if locallinenumber < 0 then write(' ':5)
else write(locallinenumber : 4, ' ');
if indention>0 then write(' ':indention);
for i:=1 to linelength do write(lineÆiÅ);
writeln;
end;
printed:=true
end; (*printline*)

procedure warning(n: integer);
var i : integer;
prgrlst : boolean;
begin
warningcount := warningcount + 1;
errormarksÆnÅ := true;
if not printed then
begin
prgrlst := programlist;
programlist := true; (* force printing of erroneous line *)
printline;
programlist := prgrlst;
end;
if errorinx=0 then
begin
write(' *********');
if indention>0 then write(' ':indention);
end;
for i:=errorinx to lineinx-2 do write(' ');
write('^', n:1);
errorinx:=lineinx+3
end; (* warning *)
 
procedure markerror(n : integer);
var oldwarning : integer;
begin
errorcount := errorcount + 1;
oldwarning := warningcount;
warning(n);
warningcount := oldwarning;
end; (* markerror *)

procedure printerrors;
var
i, currenttextno : integer;
ch : char;
begin
page(output);
writeln(output,'number of errors  :', errorcount : 4);
writeln(output,'number of warnings:', warningcount : 4);
writeln(output);
writeln(output,'error  description');

open(input,'platonerror');
reset(input);

currenttextno := -1;

for i := currenttextno + 1 to higherror do
if errormarksÆiÅ then
begin

(* find the text *)
while i > currenttextno do
begin
if not eof(input) then readln(input);
if not eof(input) then read(currenttextno)
else currenttextno := higherror + 1; 
end;

write(output,i : 4, ': ');
if i <> currenttextno then 
write(output, ' (no text) ')
else
while not eoln(input) do
begin
read(ch);
write(output,ch);
end;
writeln(output);
end; (* for i := ....  *)
end; (* printerrors *)
  
  
procedure emit( code : codes;
param1, param2 : integer;
descriptor : codes );

begin

if not typebufferflag then
begin
if code <> cnocode then write(codefile, ord(code));
if param1 <> nill then write(codefile, param1);
if param2 <> nill then write(codefile, param2);
if descriptor <> cnocode then write(codefile, ord(descriptor));
end;

if typebufferflag then
begin
if typebuffersize - lastbuffered < 4 then stop(12); (*fatal error*)
if code <> cnocode then
begin
lastbuffered := lastbuffered + 1;
typebufferÆlastbufferedÅ := ord(code);
end;
if param1 <> nill then
begin
lastbuffered := lastbuffered + 1;
typebufferÆlastbufferedÅ := param1;
end;
if param2 <> nill then
begin
lastbuffered := lastbuffered + 1;
typebufferÆlastbufferedÅ := param2;
end;
if descriptor <> cnocode then
begin
lastbuffered := lastbuffered + 1;
typebufferÆlastbufferedÅ := ord(descriptor);
end;

end;  (* buffered mode *)


end;  (* emit *)



procedure emitcode(code : codes );
begin
emit(code, nill, nill, cnocode);
end;


procedure emitboth( code : codes ; param1, param2 : integer );
begin
emit(code, param1, param2, cnocode);
(* write the code on file for labels *)
write(symbfile, ord(code));
if param1 <> nill then write(symbfile, param1);
if param2 <> nill then write(symbfile, param2);
end;



procedure emitdeclare(kind : declarekind; spix : integer);
var
code : codes;

begin
case kind of
decl: code := cdeclare;
decllist: code := cdeclarelist;
end; (* case *)

emit(code, spix, nill, cnocode);

end; (* emitdeclare *)



procedure emitname(name : nameheadptr);
(* write the name and the corresponding spix on file spixtable *)

var
namep : nameptr;

begin
with nameheadsÆ name Å do
begin
write(spixtable, spix : 4, ' ');
namep := start;
end; (* with  name  *)
while namep <> nill do
with namenodesÆ namep Å do
begin
write(spixtable, namepart);
namep := next;
end; (* while *)
writeln(spixtable);

end;  (* emit name *)
 
  
procedure returnname(name : nameheadptr); forward;


 
function searchname( name : nameheadptr ) : spixrange;

(* search the name in the name structure, if not found then
insert the name; the function result is the spix which is associated
with the name  *)

var
current, former, result : nameheadptr;
found : boolean;
hashvalue : hashindex;
name1, name2 : nameptr;

begin
hashvalue := namenodesÆ nameheadsÆ name Å.start Å.integerpart mod hashtablesize;

current := namehashtableÆhashvalueÅ;
former := nill;
found := false;

while current <> nill do
with nameheadsÆ current Å do
begin
if length < nameheadsÆ name Å.length then
begin
former := current;
current := next;
end
else
if length = nameheadsÆ name Å.length then
begin (* compare names *)
name1 := start;
name2 := nameheadsÆ name Å.start;
while name1 <> nill do
with namenodesÆ name1 Å do
if namepart <> namenodesÆ name2 Å.namepart then
name1 := nill (* exit, different *)
else
begin
name1 := next;
name2 := namenodesÆ name2 Å.next;
end;

if name2 = nill then (*current = name *)
begin
found := true;
result := current;
current := nill;  (* exit *)
end
else
(* different *)
begin
former := current; current := next;
end;

end (* current length = name length *)

else
(* current length > name length, i.e. insert *)
current := nill;  (* exit while *)
end;  (* while current <> nil *)


if not found then (* insert *)
with nameheadsÆ name Å do
begin
result := name;
lastspix := lastspix + 1;
spix := lastspix;
if nametable_dump then
emitname(name);
if former = nill then (* insert name as the first name in the list *)
begin
next := namehashtableÆhashvalueÅ;
namehashtableÆhashvalueÅ := name;
end
else (* insert name after 'former'  *)
begin
next := nameheadsÆ former Å.next;
nameheadsÆ former Å.next := name;
end;
end (* not found *)
else
returnname(name);

(* now result points at the searched name *)
searchname := nameheadsÆ result Å.spix;

end; (* search name  *)





function getnamehead : nameheadptr;
var
nameheadp : nameheadptr;

begin
if nameheadfreelist = nill then
begin
if lastnamehead < maxnameheads then
lastnamehead := lastnamehead + 1
else
stop(11); (* fatal error *)
nameheadp := lastnamehead;
end
else
begin
nameheadp := nameheadfreelist;
nameheadfreelist := nameheadsÆ nameheadp Å.next; (* next keeps the chain of free elements *)
end;

with nameheadsÆ nameheadp Å do
begin  (* initialize the fields *)
length := 0;
start := nill;
next := nill;
spix := 0;
end;

getnamehead := nameheadp;

end; (* get name head *)




function getnamenode : nameptr;

var
name : nameptr;

begin
if namenodefreelist = nill then
begin
if lastnamenode < maxnamenodeindex then
lastnamenode := lastnamenode + 1
else stop(10); (* fatal error *)
name := lastnamenode;
end
else
begin
name := namenodefreelist;
namenodefreelist := namenodesÆ name Å.next;
end;

with namenodesÆ name Å do
begin
next := nill;
namepart := blank;
end;

getnamenode := name;

end;  (* get name node *)



procedure returnname(name : nameheadptr);

(* insert the name head and the name parts into the freelists *)

var
localnext, namelist : nameptr;

begin
(* return the head *)
nameheadsÆ name Å.next := nameheadfreelist;
nameheadfreelist := name;

(* return the name part *)

namelist := nameheadsÆ nameheadfreelist Å.start;
while namelist <> nill do
with namenodesÆ namelist Å do
begin
localnext := next;
next := namenodefreelist;
namenodefreelist := namelist;
namelist := localnext;
end;

end; (* return name *)



procedure read_and_parse_prefix(name : nameheadptr);
(* parse a prefix-file as a context, i.e. no code is
generated, only declarations *)
const
lookup_entry = 42;
var
lookupname : alfa;
tail : array Æ1..10Å of integer;

begin
lookupname := namenodesÆ nameheadsÆ name Å.start Å.namepart;
if monitor(lookup_entry, lookupname, tail) <> 0 then
begin
emitcode(cerrcontext);
emitcode(cendcontext);
end
else
begin
open(input, lookupname); (* stack zone *)
reset(input);



end;

end; (* read and parse prefix *)
 

 
procedure predef_environment;
(* generate code for standard names and standard types *)

type
double_alfa = packed array Æ 1 .. 24 (* 2 * alfalength *) Å of char;


var
codeword, kind : codes;
step, spix, length : integer;


function spix_of_name(name : double_alfa) : integer;
(* convert the name into internal representation and search
the name table for the spix *)
var
nameheadp : nameheadptr;
locallength : integer;

begin
nameheadp := getnamehead;

with nameheadsÆ nameheadp Å do
begin
start := getnamenode;
with namenodes Æ start Å do
begin
for locallength := 1 to alfalength do
namepart Æ locallength Å := name Æ locallength Å ;

if name Æ alfalength + 1 Å <> ' ' then
begin
next := getnamenode;
with namenodes Æ next Å do
for locallength := 1 to alfalength do
namepart Æ locallength Å := name Æ alfalength + locallength Å ;
end; (* if name Æ alfalength + 1 Å <> space *)

end; (* with namenodes Æ start Å  *)

locallength := alfalength * 2;
if name <> blank then
begin
while nameÆ locallength Å = ' ' do
locallength := locallength-1;
length := locallength;
spix_of_name := searchname(nameheadp);
end
else
begin
returnname(nameheadp);
spix_of_name := nill;
end;

end; (* with nameheadsÆ nameheadp Å ... *)
 
end; (* spix of name *)


procedure standardnames(name : double_alfa; namecode : codes);
(*insert the name into the name table and emit:
standardname(spix  stdname  *)
var
spix : integer;

begin
spix := spix_of_name(name);
if name = '?  ' then anonymousspix := spix;
emit( cstandardname, spix, nill, namecode);
end;



procedure standardtypes(name : double_alfa; typeflag : codes);
(* insert the name into the nametable and emit:
declaration( type ) declare( spix declnr )
newtype( typeflag )  endtypedecl    *)

var
spix : integer;

begin
spix := spix_of_name(name);
emit( cdeclaration, nill, nill, ctype);
emitdeclare(decl, spix);
emitcode(cendformal);
emit( cnewtype, nill, nill, typeflag);
emitcode(cendtypedecl);
end;


begin (* predef environment *)
(* generate code for the standard names and types (build in types) *)
(* note: the name-strings must be in upper case (internal representation)  *)
standardnames('?  ', canonymous);
standardnames('SUCC', csucc);
standardnames('PRED', cpred);
standardnames('ORD', cord);
standardnames('CHR', cchr);
standardnames('PROCESS_DESCRIPTOR', cson );
standardnames('PROCESSREC', cprocessrec);
standardnames('ABS', cabs);
standardnames('SHADOW', cshadow);
standardnames('REFERENCE', creference);
standardnames('CHAR', cchar);
standardnames('BOOLEAN', cboolean);
standardnames('SEMAPHORE', csemaphore);
standardnames('EXCEPTION', cexception);


standardtypes('INTEGER', cinteger);
standardtypes('REAL', creal);
standardtypes('NILTYPE', cniltype);

before_standard_defs := false;

end; (* predefine environment *)
\f




procedure readcall;
(* read the call of the compiler from current input *)
const
power12=4096;
equality=6;
point=8;
list = 'list        ';
yes   = 'yes         ';
no    = 'no          ';
survey= 'survey      ';
codesize   = 'codesize'; (* option for pass6, the size of a program page *)
stop  = 'stop';      (* option stop.<pass nr> *)
spacing = 'spacing';
includ= 'include     ';

var
i,j, int, stop_code, separator, length : integer;
a, codefilename, sourcefilename : alfa;
first : boolean;
read_env_flag : boolean; 
param : (list_program, filename, code_size, surveyinfo, stop_param, spacing_param);


procedure checkleftside;
(* check the call of the compiler, look for 'include'
and if found then read environment from the specified file,
else read standard environment, after the call systemparamno is
the number of the first input information parameter *)
begin
systemparamno := 1;
if system(systemparamno, int, a) div power12 = equality then
begin
(* left hand side present *)

i := system(0, int, codefilename);
for i := 1 to alfalength div 2 do
begin
emit(coption, 6, 80 + i, cnocode);
emit(cnocode, ord( codefilename Æ i * 2 - 1 Å ) * 256 +
ord( codefilename Æ i * 2 Å ), nill, cnocode );
end; (* output codefilename *)

systemparamno := systemparamno + 1; (* skip name platon *)
end;


end; (* checkcall *)



procedure error;
begin
writeln(' ??? error in call of pascal80 compiler');
goto 10;
end;

begin
read_env_flag := systemparamno = nill;
if read_env_flag then checkleftside;
if inputfile then
begin
close(input);
inputfile := false;
end;


j:=system(systemparamno,int,a);
first:=true;
param := pred(filename); (* param <> filename *)

while ((j mod power12) <> 0) and ((j div power12) <> 2) 
and (param <> filename) do
begin
separator:=j div power12;
length:=j mod power12;

if first then
begin
first:=false;
if separator = point then error
else
if a = list then param:=list_program
else if a = codesize then param := code_size
else if a = spacing then param := spacing_param
else if a = stop then param := stop_param
else if a = survey then param := surveyinfo
else
begin
param := filename;
sourcefilename := a;
end;
end
else
begin
first:=true;
if (separator <> point) and (param <> filename) then error
else
case param of
list_program:if length <> 10 then error
else
if (a=yes) or (a=no) then programlist := a=yes
else error;

stop_param:
if length <> 4 then error
else (* generate an option for the pass to stop after *)
if (int = 3) or (int = 4) or (int = 5) then
begin
case int of
3: stop_code := stop3;
4: stop_code := stop4;
5: stop_code := stop5;
end; (* case *)
emit(coption, int, nill, cnocode);
emit(cnocode, stop_code, 0, cnocode);
end (* 3, 4, 5 *)
else
if (int = 1) or (int = 2) then
call_pass_3 := false;


surveyinfo: if length <> 10 then error
else
if (a = yes) or (a = no) then
begin
if a = yes then
begin
emit( coption, 5, 3, cnocode ); (* generate statistics in pass 5 *)
emit( cnocode, 1, nill, cnocode );
emit( coption, 6, 10, cnocode ); (* generate statistics in pass 6 *)
emit( cnocode, 1, nill, cnocode );
end;
 nametable_dump := a = yes
end
else error;

code_size:
if length <> 4 then error
else
begin
emit(coption, 6, 3, cnocode); (* !!!! must be as defined by pass6 !!! *)
emit(cnocode, int, nill, cnocode);
end;



spacing_param:
if length <> 4 then error
else
begin
emit(coption, 6, 9, cnocode); (* must be as defined by pass6 !!! *)
emit(cnocode, int, nill, cnocode);
end;

filename: systemparamno := systemparamno - 1; (* make the next increment dummy *)

end; (* case *)
end; (* second *)
systemparamno := systemparamno + 1;
j:=system(systemparamno,int,a);
end;
if read_env_flag then
begin
sourcefilename := 'platonenv';
if param = filename then
systemparamno := systemparamno - 1 (* do not skip file name *)
else
param := filename; (* force open call *)
end;


if param = filename then
begin
open(input, sourcefilename);
reset(input);
inputfile := true;
end;


end; (* read call *)

procedure initialize;
var
ch:char;
step : integer;
dato, tim:alfa;
begin
date(dato);
time(tim);
writeln(dato,tim:15,version:50);
writeln;

(* initialize global variables and open files *)

systemparamno := nill;
more_sources_allowed := true;
inputfile := false; (* inputfile met in the call *)
programlist := false; (* list.no is default *)
call_pass_3 := true;  (* automatical call of pass3 if no errors detected *)
locallinenumber := -1;
linenumber := 0;
for step := 1 to higherror do
errormarksÆstepÅ := false;
errorcount := 0;
warningcount := 0;
 
lastspix := 0;
lastlabelscope := 0;
currentlabelscope := lastlabelscope;

nametable_dump := false; (* survey.no *)

lastbuffered := 0;
typebufferflag := false;

nameheadfreelist := nill;
lastnamehead := nill;
namenodefreelist := nill;
lastnamenode := nill;

for step := 0 to hashtablesize do
namehashtableÆstepÅ := nill;


rewrite(symbfile); rewrite(codefile);
rewrite(spixtable);

(* force generation of code for the predefined names and types *)
before_standard_defs := true;
 
end;

(* bobs procedure code*)
(*$r+*)
procedure code(oldtop,newtop: stackinx; prod: integer);
(*$r-*)

(* bobs local procedures*)
procedure getstring(sy,start: integer; var str:string; var length: integer);
var i,j,t:integer;
begin
if sy>=0 then t:=newtop+(sy-1)
else t:=oldtop+(sy-1);
length:=attstackÆtÅ.chbufp-attstackÆt-1Å.chbufp+start-1;
if length>stringmax-start+1 then  stop(5);
j:=start;
for i:=attstackÆt-1Å.chbufp to attstackÆtÅ.chbufp-1 do
begin
strÆjÅ:=chbufÆiÅ; j:=j+1
end
end; (*getstring*)


procedure outtest;
(*outtest produces a sequence of snaphots of the parse
(*outtest may be removed by the user *)
(*during the parse, snapshots are written on file output *)
(*program lines which writes snapshots contains the comment:*)
(***snapshot***)
var s: string;
i,j,l:integer; ch:char;
begin
writeln(output);
write(output,' production:',prod:3);
for i:=1 to oldtop-newtop+1 do
begin getstring(i,1,s,l);
if l>0 then
begin writeln(output);
write(output,'   symb',i:1,' ');
for j:=1 to l do write(output,sÆjÅ)
end
end
end; (*outtest*)



function readname : nameheadptr;
(* read the name from chbuf(oldtop) into a name structure
and return a reference to the head  *)

var
localhead : nameheadptr;
chbufindex, charcount : integer;
localname : nameptr;

begin
localhead := getnamehead; (* allocate a new name head *)
with nameheadsÆ localhead Å do
begin
length := attstackÆoldtopÅ.chbufp - attstackÆoldtop-1Å.chbufp;
start := getnamenode;
localname := start; charcount := 0; chbufindex := attstackÆoldtop-1Å.chbufp;

repeat
with namenodesÆ localname Å do
namepartÆ (charcount mod alfalength) + 1 Å := chbufÆ chbufindex Å;
charcount := charcount + 1;
chbufindex := chbufindex + 1;

if ((charcount mod alfalength) = 0) and (charcount < length) then
with namenodesÆ localname Å do
begin
(* get a new name node *)
next := getnamenode;
localname := next;
end;

until charcount = length;

end; (* with ...  *)

readname := localhead;

end;  (* read name *)
 
procedure errorsection;


begin
emitcode(cerror);
end;


procedure literals( prod : integer ; convert : boolean );
(* section 4 *)

var
length, stepvar : integer;
codekind : codes;
ord_char : integer;

begin
case prod of
401: (* <unsigned constant> ::= string *)
codekind := ctext;

402: (* <unsigned number> ::= <unsigned integer> *)
codekind := cinteger;
 
403: (* <unsigned number> ::= realkonst *)
codekind := creal;
404:  (* <unsigned integer> ::= # name *)
codekind := cinteger;

end; (* case *)

(* code: literal(length codekind) string *)

length := attstackÆoldtopÅ.chbufp - attstackÆoldtop-1Å.chbufp;
if prod = 404 then length := length + 1; (* '#' *)

emitcode(cliteral);
emit(codekind, length, nill, cnocode);
if prod = 404 then (* emit( '#' )  *)
emit(cnocode, ord('#'), nill, cnocode );
for stepvar := attstackÆoldtop-1Å.chbufp to attstackÆoldtopÅ.chbufp-1 do
begin
ord_char := ord( chbuf Æ stepvar Å );
if (convert or (prod <> 401)) and (ord_char >= ord('A')) and (ord_char <= ord('Z')) then
ord_char := ord_char + ord('a') - ord('A'); (* convert to lower case *)
emit(cnocode, ord_char, nill, cnocode);
end;

end; (* literals *)

\f


procedure constantdeclaration;
(* section 5 *)

var
name : nameheadptr;
namespix : integer;

begin
case prod of
 501:  (* <constant definition> ::= <constname> = <expression> <semicolons> *)
(*code: endconstantdecl *)
emitcode(cendconstantdecl);

502:  (* <constname> ::= name *)
(* declaration(constant) declare(spix)  *)
begin
name := readname;
namespix := searchname(name);
emit( cdeclaration, nill, nill, cconstant);
emitdeclare(decl, namespix);
end; (* 502 *)

503:  (* <constant definition> ::= <constname> error *)
(* code: id(anonymous) endexpression endconstantdecl *)
begin
emit(cid, anonymousspix, nill, cendexpression);
emitcode(cendconstantdecl);
end;

end; (* case *)

end; (* constant declaration *)

\f


procedure typedefinition;
(* section 6 *)

var
codeword : codes;
name : nameheadptr;
stepvar,
namespix : integer;

begin


if (prod >= 601) and (prod < 620) then
begin
case prod of
601:  (* <type definition> ::= <type name> <formal parameters> <eq>
   <type> <semicolons>   *)
(* code: endtypedecl endlevel  *)
begin
emitcode(cendtypedecl);
codeword := cendlevel;
end;

602:  (* <eq> ::=  = *)
(*  no code *)
codeword := cnocode;

603:  (* <type> ::= <variable> *)
(* code: endtype *)
begin
typebufferÆ attstackÆ newtop - 1 Å.bufferstartÅ := ord(ctypeid);
(* i.e. change the former generated id to typeid *)
codeword := cendtype;
end;

604:  (* <type> ::= <structured type> *)
(*    ! <pool type>    *)
(* no code *)
codeword := cnocode;

605:  (* <type> ::= <uparrow> <type> *)
(* code: endpointer *)
codeword := cendpointer;

606:  (* <type> ::= <read only> <type> *)
(* code: endreadonly *)
codeword := cendreadonly;

607:  (* <type> ::= <start scalar> <identifier list> )  *)
(* code: endscalar  *)
codeword := cendscalar;

608:  (* <type> ::= <expression> <end subrange>  *)
(* code: endsubrange *)
begin
with attstackÆ newtop - 1 Å do
begin
typebufferÆ bufferstart - 2 Å := ord(cnewtype);
typebufferÆ bufferstart - 1 Å := ord(csubrange);
end; (* with *)
codeword := cendsubrange;
end;

609:  (* <array type> ::= <array start> <type> <component type>  *)
(* code: endarray  *)
begin
for stepvar := 1 to dimension_count do
emitcode(cendarray);
codeword := cendarray;
end;

610:  (* <record type> ::= <record> <field list> end  *)
(* code: endlevel endrecord  *)
begin
emitcode(cendlevel);
codeword := cendrecord;
end;

611:  (* <record section> ::= <start section> <field identifier list> <type colon> <type>  *)
(* code: endfield  *)
codeword := cendfield;

612:  (* <set type> ::= <set of> <type>  *)
(* code: endset  *)
codeword := cendset;
 

613:  (* <pool type> ::= <pool> <expression> <type size>  *)
(* code: endpool  *)
codeword := cendpool;

614:  (* <structured type> ::= packed <unpacked structured type> *)
(* code: packed  *)
codeword := cpacked;

end; (* case 601..619 *)

if (prod >= 603) and (prod <= 608) then
if (lastbuffered > 0) and (attstackÆ newtop - 1 Å.bufferstart = 3) then
(* i.e. if anything buffered and <type> is the outermost incarnation *)
begin
typebufferflag := false;
for stepvar := 1 to lastbuffered do
emit( cnocode, typebufferÆstepvarÅ, nill, cnocode);
lastbuffered := 0;
end; (* if buffered *)

emitcode(codeword);

end; (* if .... *)

if (prod >= 620) and (prod < 630) then
begin
case prod of

620:  (* <uparrow> ::= ^  *)
(* code: newtype pointer  *)
codeword := cpointer;

621:  (* <startscalar> ::= ( name ,   *)
(* code: newtype scalar  *)
(*       declaration( scalarelem )   and  *)
(*   declarelist( name ) is generated after the case statement *)
codeword := cscalar;

622:  (* <read only> ::=  !  *)
(* code: newtype readonly *)
codeword := creadonly;

623:  (* <array> ::= array ( *)
(* code: newtype array  *)
codeword := carray;

624:  (* <record> ::= record  *)
(* code: newtype record beginlevel *)
codeword := crecord;

625:  (* <set of> ::= set <of type>  *)
(* code: newtype set  *)
codeword := cset;

626:  (* <pool> ::= pool  *)
(* code: newtype pool  *)
codeword := cpool;

end; (* case .. *)


emit(cnewtype, nill, nill, codeword);
if (* scalarlist start *) prod = 621 then
begin
emit(cdeclaration, nill, nill, cscalarelem );
 
oldtop := oldtop - 1 ; (* let oldtop denote name *)
name := readname;
oldtop := oldtop + 1; (* reset oldtop *)
namespix := searchname(name);
emitdeclare(decllist, namespix);
end (* start scalar *)
else if (* record *) prod = 624 then emitcode(cbeginlevel);

end; (* 620..629 *)

if (prod >= 630) and (prod <= 639) then
case prod of
630:  (* <scalar list> ::= <scalar list>, name *)
(*   ! name  *)
(* code: declarelist( spix ) *)
begin
name := readname;
namespix := searchname(name);
emitdeclare(decllist, namespix);
end;

631:  (* <field identifier list> ::= <field identifier list> , name *)
(*    !  name     *)
(* code: declarelist( spix )  *)
begin
name := readname;
namespix := searchname(name);
emitdeclare(decllist, namespix);
end;  (* 631 *)

632:  (* <start section> ::= empty  *)
(* code: declaration( recfield )  *)
emit(cdeclaration, nill, nill, crecfield);

633:  (* <name colon> ::= name :     *)
(* formal parameter of a parameterized type specification of a formal parameter *)
(* code: declaration( valuep )  declarelist( spix )  *)
begin
oldtop := oldtop - 1; (* let oldtop denote name  *)
name := readname;
oldtop := oldtop + 1; (* reset oldtop *)
emit(cdeclaration, nill, nill, cvaluep);
emitdeclare(decllist, searchname(name));
end;

635:  (* <type size> ::= empty *)
(* code: without_data *)
(* code for a pool of headers, i.e. without data parts *)
emitcode(cwithout_data);

636:  (* <component type> ::= ) <of type> <type> *)
(*         !  error    *)
(* action: initialize dimension count *)
begin
dimension_count := 0;
if newtop = oldtop (* i.e. error *) then
emitcode(cerror);
end;

637:  (* <component type> ::= <new dimension> <type> <component type> *)
(* action: increase dimension count *)
dimension_count := dimension_count + 1;


end; (* case  630..639 *)


if prod = 600 then
begin
(* <type name> ::= name   *)
(* code: declaration( type )  declare( spix )     *)
name := readname;
namespix := searchname(name);
emit( cdeclaration, nill, nill, ctype);
emitdeclare(decl, namespix);
end;  (* 600  *)

(* if before <type> then *)
if (prod=602) or (prod=620) or (prod=622) or (prod=623) or (prod=625) or (prod=633) or (prod=640) then
begin
if lastbuffered + 3 > typebuffersize then 
stop(12);

(* avoid destroying the buffermark because of newline, i.e. the newline
codes are generated in front of the marked codes in stead of the
(random) places where the newlines are met *)
emit(cnewline, linenumber, nill, cnocode);

typebufferflag := true;

typebufferÆ lastbuffered + 1 Å := nill;
typebufferÆ lastbuffered + 2 Å := nill; (* reserve room for a possible newtype .. *)
lastbuffered := lastbuffered + 2;
attstackÆ newtop Å . bufferstart := lastbuffered + 1;
end;


end;   (* section 6  *)

\f


procedure variabledefinition;
(* section 7 *)

var
name : nameheadptr;
namespix : integer;

begin
case prod of

700:  (* <start var> ::= empty  *)
(* code: declaration( var )  *)
emit(cdeclaration, nill, nill, cvar);

701,  (* <ident> ::= name  *)
704:  (*         !  ?      *)
(* code: declarelist( spix ) *)
begin
if prod = 701 then
begin
name := readname;
namespix := searchname(name);
end
else
namespix := anonymousspix;
emitdeclare(decllist, namespix);
end;

702:  (* <initialization> ::= <expression> *)
(* code: init   *)
emitcode(cinit);

703:  (* <var decl> ::= <start var> <identifier list> <type colon>
<type> <initialization> <semicolons>   *)
(* code:  endvardecl  *)
emitcode(cendvardecl);

705:  (* <initialization> ::= empty  *)
(* code: noinit  *)
emitcode(cnoinit);


end; (* case ... *)

end; (* section 7 *)

procedure expression;
(* section 8 *)

var
codeword1, codeword2 : codes;
var_or_field_spix : integer;
name : nameheadptr;

begin
if prod <= 808 then 
codeword2 := cendexpression
else
codeword2 := cnocode;
var_or_field_spix := nill;

case prod of
801:  (* <expression> ::= <simple expression> *)
(* code: endexpression  *)
codeword1 := cnocode;

802:  (* <expression> ::= <simple expression> = <simple expression> *)
(* code: eq endexpression  *)
codeword1 := ceq;

803:  (* <expression> ::= <simple expression> <> <simple expression> *)
(* code: ne endexpression *)
codeword1 := cne;

804:  (* <expression> ::= <simple expression> < <simple expression>  *)
(* code: lt endexpression  *)
codeword1 := clt;

805:  (* <expression> ::= <simple expression> <= <simple expression>  *)
(* code: le  endexpression  *)
codeword1 := cle;

806:  (* <expression> ::= <simple expression> > <simple expression>  *)
(* code: gt endexpression  *)
codeword1 := cgt;

807:  (* <expression> ::= <simple expression> >= <simple expression> *)
(* code: ge endexpression  *)
codeword1 := cge;

808:  (* <expression> ::= <simple expression> in <simple expression>  *)
(* code: in endexpression  *)
codeword1 := cin;

810:  (* <simple expression> ::= <simple expression> + <term>  *)
(* code: plus  *)
codeword1 := cplus;

811:  (* <simple expression> ::= <simple expression> - <term>  *)
(* code: minus  *)
codeword1 := cminus;

812:  (* <simple expression> ::= <simple expression> or <term>  *)
(* code: or  *)
codeword1 := cor;

813:  (* <simple expression> ::= + <term>  *)
(* code: uplus  *)
codeword1 := cuplus;

814:  (* <simple expression> ::= - <term>   *)
(* code: uminus  *)
codeword1 := cuminus;

816:  (* <term> ::= <term> * <factor>  *)
(* code: star  *)
codeword1 := cstar;

817:  (* <term> ::= <term> / <factor>  *)
(* code: slash  *)
codeword1 := cslash;

818:  (* <term> ::= <term> div <factor> *)
(* code: div  *)
codeword1 := cdiv;

819:  (* <term> ::= <term> mod <factor> *)
(* code: mod  *)
codeword1 := cmod;

820:  (* <term> ::= <term> and <factor>  *)
(* code: and  *)
codeword1 := cand;

825:  (* <factor> ::= <set>  *)
(* code: endsetlist *)
codeword1 := cendsetlist;

826:  (* <start set> ::= (.  *)
(* code: setlist  *)
codeword1 := csetlist;

827:  (* <element> ::= <expression>  *)
(* code: s_element  *)
codeword1 := cs_element;

828:  (* <element> ::= <expression> .. <expression>  *)
(* code: m_element  *)
codeword1 := cm_element;

830:  (* <factor> ::= <variable>  *)
(* code: endvariable  *)
codeword1 := cendvariable;

831:  (* <factor> ::= not <factor>  *)
(* code: not   *)
codeword1 := cnot;

835:  (* <variable> ::= name *)
(* code: id( spix ) may later on be changed to typeid(spix) *)
begin
codeword1 := cid;
name := readname;
var_or_field_spix := searchname(name);
end;

836:  (* <variable> ::= <variable> . name  *)
(* code: field( spix )  *)
begin
codeword1 := cfield;
name := readname;
var_or_field_spix := searchname(name);
end;

837:  (* <variable> ::= <variable> <begin actual> <actual parameter list> )  *)
(* code: endactual *)
codeword1 := cendactual;

838:  (* <variable> ::= <variable> ^   *)
(* code: uparrow  *)
codeword1 := cuparrow;

839:  (* <begin actual> ::= (  *)
(* code: beginactual   *)
codeword1 := cbeginactual;



end;  (* case ... *)


emit( codeword1, var_or_field_spix, nill, codeword2);

end;  (* section 8  *)

\f


procedure statement;
(* section 9 *)

var
codeword, codeword2 : codes;
param1 : integer;
name : nameheadptr;

begin
codeword2 := cnocode;
param1 := nill;

case prod of

901:  (* <compound statement> ::= <begin> <statement list> end *)
(* code: end  *)
codeword := cend;

902:  (* <begin> ::= begin  *)
(* code: begin  *)
codeword := cbegin;

903:  (* <procedure call> ::= <variable>  *)
(* code: callprocedure  *)
codeword := ccallprocedure;

904:  (* <actual parameter> ::= <expression>  *)
(* code: actualparam *)
begin
codeword := cactualparam;
end;

905:  (* <actual parameter> ::= <expression> *** <expression>  *)
(* code: doubleparam  *)
begin
codeword := cdoubleparam;
end;

906:  (* <assignment statement> ::= <variable> := <expression>  *)
(* code: endassign  *)
codeword := cendassign;

907:  (* <exchange statement> ::= <variable> :=: <variable>  *)
(* code: endexchange  *)
codeword := cendexchange;

 
 

909:  (* <case statement> ::= <selector part> <case list> <end case part>  *)
(* code: endcase  *)
codeword := cendcase;

910:  (* <selector part> ::= <case> <expression> of *)
(* code: caseexpr  *)
codeword := ccaseexpr;

911:  (* <case> ::= case  *)
(* code: casestat *)
codeword := ccasestat;

912:  (* <case list element> ::= <case label list> <end label list> <statement>  *)
(* <end case part> ::= <otherwise> <statement> end *)
(* code: caseelement  *)
codeword := ccaseelement;

913:  (* <label range> ::= <expression> .. <expression> *)
(* code: caselabelrange  *)
codeword := ccaselabelrange;

914:  (* <label range> ::= <expression> *)
(* code: caselabel *)
codeword := ccaselabel;

915:  (* <end label list> ::= :  *)
(* code: caselist  *)
codeword := ccaselist;

916:  (* <otherwise> ::= otherwise *)
(* code: otherwise caselist *)
begin
codeword := cotherwise;
codeword2 := ccaselist;
end;

917,  (* <statement> ::= <for do> <start labelscope> <statement> <end labelscope> *)
933,  (*              !  <while do> <start labelscope> <statement> <end labelscope>  *)
936,  (*              !  <with or lock> <start labelscope> <statement> <end labelscope>   *)
947:  (*              !  <channel do> <start labelscope> <statement> <end labelscope>  *)
(* <balanced statement> ::= <for do> <start labelscope> <balanced statement> <end labelscope>  *)
(*                       !  <while do> <start labelscope> <balanced statement> <end labelscope> *)
(*                       !  <with or lock> <start labelscope> <balanced statement> <end labelscope> *)
(*                       !  <channel do> <start labelscope> <balanced statement> <end labelscope>  *)

(* code:  endfor/endwhile/endwith/endchannel *)

begin

case prod of
917: codeword := cendfor;
933: codeword := cendwhile;
936: codeword := cendwith;
947: codeword := cendchannel;
end; (* case *)

end; (* 917, 933, 936, 947  *)

918:  (* <for do> ::= <for to> <expression> do *)
(* code: up *)
codeword := cup;
 
919:  (*           ! <for downto> <expression> do *)
(* code: down   *)
codeword := cdown;

920:  (* <for assign> ::= <for> <variable> :=  *)
(* code: forvar  *)
codeword := cforvar;

921:  (* <for> ::= for *)
(* code: forstat *)
codeword := cforstat;

922:  (* <goto statement> ::= <goto> <lab name> *)
(* code: endgoto  *)
codeword := cendgoto;

923:  (* <goto> ::= goto *)
(* code: gotostat  *)
codeword := cgotostat;

924:  (* <lab name> ::= name  *)
(*       ! konst  *)
(* code: id ( spix )  *)
begin
name := readname;
param1 := searchname(name);
codeword := cid;
end;

925:  (* <statement> ::= <if then> <statement>  *)
(*     ! <if then else> <statement>  *)
(* <balanced statement> ::= <if then else> <balanced statement>  *)
(* code: endif  *)
begin
codeword := cendif;
end;

926:  (* <if then> ::= <if part> <expression> then *)
(* code: ifexpr *)
codeword := cifexpr;

927:  (* <if part> ::= if  *)
(* code: ifstat  *)
codeword := cifstat;

928:  (* <if then else> ::= <if then> <balanced statement> else  *)
(* code: else *)
codeword := celse;

929:  (* <until> ::= until *)
(* code: until   *)
begin
codeword := cuntil;
end;

930:  (* <repeat statement> ::= <repeat until> <expression>  *)
(* code: endrepeat  *)
codeword := cendrepeat;

931:  (* <repeat until> ::= <repeat> <statement list> until *)
(* code: endlabelscope( scopenr )  *)
begin
codeword := cendlabelscope;
param1 := currentlabelscope;
currentlabelscope := attstackÆnewtopÅ.oldlabelscope;
end;

932:  (* <repeat> ::= repeat   *)
(* code: repeatstat  *)
codeword := crepeatstat;

934:  (* <while do> ::= <while> <expression> do *)
(* code: whileexpr   *)
codeword := cwhileexpr;

935:  (* <while> ::= while *)
(* code: whilestat  *)
codeword := cwhilestat;

937:  (* <with or lock part> ::= with  *)
(* code: withstat *)
codeword := cwithstat;

938:  (* <with comma> ::=   ,  *)
(* code: withcomma  *)
codeword := cwithcomma;

939:  (* <with variable> ::= <variable>  *)
(* code: withvar nolocaldeclare  *)
begin
codeword := cwithvar;
codeword2 := cnolocaldeclare;
end;

940:  (* <as> ::= as  *)
(* code: withvar  *)
codeword := cwithvar;

941:  (* <local name> ::= name *)
(* code: declaration( var ) declare( spix ) *)
begin
name := readname;
emit( cdeclaration, nill, nill, cvar);
emitdeclare(decl, searchname(name));
(* the code is generated here, and the general mechanism of
this section is not used ( codeword = nocode )  *)
codeword := cnocode;

end;  (* 941 *)

942:  (* <with variable> ::= <variable> <as> <local name> <type colon> < type> *)
(* code: endlocaldeclare *)
codeword := cendlocaldeclare;

948:  (* <channel do> ::= <channel> <variable> do *)
(* code: chanvar  *)
codeword := cchanvar;

949:  (* <channel> ::= channel  *)
(* code: channelstat *)
codeword := cchannelstat;
 
950:  (* <with do> ::= <with as> <local declaration> do  *)
(* code: do   *)
codeword := cdo;

955:  (* <actual parameter> ::= ? *)
(* code: skipparam *)
codeword := cskipparam;

965:  (* <with or lock part> ::= lock   *)
(* code: lockstat   *)
codeword := clockstat;


end;  (* case .... *)

(* now the parameters for the emit call has been set up *)
emit( codeword, param1, nill, codeword2);

end; (* section 9  *)
\f


procedure emitroutinedecl( routine_kind : codes; name : nameheadptr);
(* emit: declaration ( routine_kind )
.        literal( text length) 'name'
.        declare( spix )
*)
begin
emit(cdeclaration, nill, nill, routine_kind);
literals( 401 (* i.e. text *)  , true (* covnert to small letters *) );
emitdeclare(decl, searchname( name ) );
end; (* emitroutinedecl *)


procedure proceduredeclaration;
(* section 10 *)

(* this section covers - in addition to procedure declarations - the
parsing of <formal parameters> and <block> and <declarations> *)

var
name : nameheadptr;
codeword : codes;
step : integer;

begin
case prod of

1002:  (* <routine heading> ::= <procedure heading> *)
(* code: endprocdecl *)
begin
emitcode(cendprocdecl);
end;

1003:  (* <procedure name> ::= name  *)
(* code: declaration( procedure ) literal( text length) 'name'  declare( spix ) *)
begin
name := readname;
emitroutinedecl( cprocedure, name );
end;

1006:  (* <parameter description> ::= <var or value> <parameter group>
  <type colon> <type>  *)
(* code: endformallist *)
emitcode(cendformallist);

1007:  (* <formal parameters> ::= <init formal> *)
(*         ! <init formal> ( <formal list> )    *)
(* <actual parameter> ::= <name colon> <type>  *)
(* formal parameter of a parameterized type which is used as formal
type specification  *)
(* code: endformal  *)
emitcode(cendformal);

1008:  (* <parameter group> ::= name  *)
(*         ! <parameter group> , name  *)
(* code: declarelist( spix ) *)
begin
name := readname;
emitdeclare(decllist, searchname(name));
end;

1009:  (* <declarations> ::= <decl start> <decls>   *)
(* code: enddeclarations  *)
(* action: change input file if context parsing *)
begin
if contextparsing then
begin
linenumber := 0;
locallinenumber := -1; (* suppress local line numbering *)
end
else
locallinenumber := 0; 
emitcode(cenddeclarations);
end;

1010:  (* <decl start> ::= empty  *)
(* code: beginlevel *)
begin
emitcode(cbeginlevel);
end;

1011:  (* <block> ::= <declarations> <start labelscope> <compound statement>
<end labelscope>     *)
(* code: endblock endlevel endlevel  *)
(* action: stop local line numbering  *)
begin
emitboth(cendblock, nill, nill);
emit( cendlevel, nill, nill, cendlevel);
locallinenumber := -1; (* suppress printing of local line numbers *)
end;

1020,  (* <block> ::= external  *)
1021: (*      ! forward    *)
(* code: external/forward  endlevel *)
begin
if prod = 1020 then codeword := cexternal
else codeword := cforward;
emitcode(codeword);
emitcode(cendlevel);
locallinenumber := -1;
end;

1022:  (* <init formal> ::= empty  *)
(* code: beginlevel  *)
emitcode(cbeginlevel);

1023,  (* <var or value> ::= empty  *)
1024: (*      ! var                     *)
(* code: declaration( valuep/varp )  *)
begin
if prod = 1023 then codeword := cvaluep
else codeword := cvarp;
emit( cdeclaration, nill, nill, codeword);
end;


end; (* case *)

end; (* section 10 *)

\f


procedure functiondeclaration;
(* section 11  *)

begin

case prod of
1101:  (* <routine heading> ::= <function heading> *)
(* code: endfuncdecl  *)
begin
emitcode(cendfuncdecl);
end;

1102:  (* <function name> ::= name *)
(* code: declaration ( function )
.        literal ( text length ) 'name'
.        declare ( spix )
*)
begin
emitroutinedecl( cfunction, readname );
end;

end; (* case  *)

end; (* section 11  *)

\f


procedure labeldeclaration;
(* section 12 *)


begin
 case prod of
1201:   (* <label name> ::= name  *)
(*        ! konst *)
(* code: if declarations then 
declaration( label ) declare( spix )
else
labeldef( currentlabelscope spix),
labeldef( currentlabelscope spix )    *)
if locallinenumber = -1 then (* i.e. declaration of a label *)
begin
emit( cdeclaration, nill, nill, clabel);
emitdeclare(decl,searchname(readname));
end
else
begin
emitboth(clabeldef, currentlabelscope, searchname(readname));
end;

1202:  (* <start labelscope> ::= empty  *)
(* code: startlabelscope( scope )  *)
begin
attstackÆ newtop Å . oldlabelscope := currentlabelscope;
lastlabelscope := lastlabelscope + 1;
currentlabelscope := lastlabelscope;
emit(cstartlabelscope, currentlabelscope, nill, cnocode);
end;

1203:  (* <end labelscope> ::= empty  *)
(* code: endlabelscope( scope )  *)
begin
emit(cendlabelscope, currentlabelscope, nill, cnocode);
currentlabelscope := attstackÆ newtop - 2 Å . oldlabelscope;
(* i.e. get the scope stored in attstackÆ <start labelscope> Å  *)
end;

 end;  (* case *)

end; (* section 12 *)

\f


procedure processdeclaration;
(* section 13, process and prefix declaration *)

var
name : nameheadptr;
codeword : codes;

begin
case prod of

1301:  (* <context name> ::= name *)
(* code: context( spix )  *)
begin
if before_standard_defs then
predef_environment;
name := readname;
emit(ccontext, searchname(name), nill, cnocode);
contextparsing := true;
end;

1302:  (* <include list> ::= <include list> , name *)
(*         !  name   *)
(* pick up the name and store it into the includelist *)
(* not implemented yet *)
writeln(output,nl, nl,  '****** include not implemented yet ');

1303:  (* <body> ::= <process declaration>  *)
(*      ! <prefix declaration>  *)
(* code: eom  *)
begin
emitcode(ceom);
ok := false; (* stop parsing *)
if not printed then printline; (* print the last line *)
end;

1304:  (* <procsems> ::= <semicolons> *)
(* code: endprocdecl *)
begin
emitcode(cendprocdecl);

end;

1305,  (* <process name> ::= name  *)
1306:  (* <prefix name> ::= name  *)
(* code: declaraton( process/prefix ) declare( spix ) *)
begin
name := readname;
if prod = 1305 then codeword := cprocess
else
codeword := cprefix;
emitroutinedecl( codeword, name );
end;

1307:  (* <prefix declaration> ::= <prefex heading> <semicolons> <declarations> *)
(* code: endprefix *)
begin
emitcode(cendprefix);
end;

1310:  (* <external> ::= <context name> <semicolons> <declarations> . *)
(* code: endcontext   *)
(* action: contextparsing := false  *)
begin
contextparsing := false;
emitcode(cendcontext);
end;

1311:  (* <external part> ::= <externals>  *)
(* code: endinclude beginlevel     *)
begin
more_sources_allowed := false;
emit(cendinclude, nill, nill, cbeginlevel);
end;

end;  (* case *)

end; (* section 13 *)

\f




begin (* code *)
if testoutput then outtest;(***snapshot***)

case prod div 100 of

0:  ; (* nothing is done *)

1: errorsection; (*  ** ::= error *)

2, 3: ;  (* not used *)

4: literals( prod, false (* do not convert literals to small letters *) ); 

5: constantdeclaration;

6: typedefinition;

7: variabledefinition;

8: expression;

9: statement;

10: proceduredeclaration;

11: functiondeclaration;

12: labeldeclaration;

13: processdeclaration;

end;  (* case ... *)

end;(*code*)

(* bobs procedures continuated*)
procedure stop;
begin
markerror(0);
writeln(output);writeln(output);
case n of
1: writeln(output,' *** parse stack overflow. const ''stackmax'' too small');
2: writeln(output,' *** end of file encountered ');
3: writeln(output,' *** recovery abandoned ');
4: writeln(output,' *** reduction buffer overflow. const ''redumax'' too small');
5: writeln(output,' *** const ''stringmax'' too small ');
6: writeln(output,' *** const ''chbufmax'' too small ');
10: writeln(output,' *** const ''maxnamenodeindex'' too small ');
11: writeln(output, ' *** const ''maxnameheads'' too small ');
12: writeln(output, ' *** const ''typebuffersize'' too small ');
end;
goto 10; (*exit*)
end;(*stop*)

procedure parser;
const
(*BOBS, constants generated by the generator *)
symbmax = 223;
prodmax = 278;
lrmax = 1077;
lxmax = 185;
errorval = 47;
nameval = 46;
constval = 45;
stringval = 48;
stringch =
'''';
combegin = 77;
comlength = 2;
 (*BOBS) 
(*-end-of-generated-constants-*)
realkonst = 49;
skipch=' ';

(*-end-of-parser-constants-*)

type
symbol=0..symbmax;
errno=0..prodmax;
prodno=0..prodmax;
rslength=-1..symbmax;
mode=0..6;
lrinx=0..lrmax;
lrelm=packed record
chain: lrinx; (*next item in this state*)
next: lrinx; (*next state*)
case kind: mode of
1,2,4,6: (symb: symbol; err: errno);
0,3    : (rs: rslength; prod: prodno);
5:     (lb: lrinx)
end;
lxinx=0..lxmax;
lxelm=packed record
np,hp: lxinx;
tv: symbol; ch:char
end;
stackelm=packed record
link: stackinx;
table: lrinx
end;
(*-end-of-parser-types-*)

var
lr: arrayÆlrinxÅ of lrelm; (* lr-parse tables *)

parsestack: arrayÆstackinxÅ of stackelm; (*parse stack*)

entry: arrayÆcharÅ of lxelm;
lx: arrayÆlxinxÅ of lxelm; (*lexical tables*)
namech,                    (*chars used in names*)
digitch:set of char;       (*chars used for digits*)
newsymb: symbol;           (*current terminal symbol*)
ch: char;                  (*current char*)
stringescape: integer;     (*internal value of the stringescape terminal*)
oldbufi: chbufinx;         (*first char in chbuf of current lexical token *)
moreinput:boolean;         (*becomes false when input is exhausted*)
comend :  arrayÆ1..comlengthÅ of char ; (*string which ends a comment *)
prodtab : array ÆprodnoÅ of integer;

(*-end-of-parser-variables-*)


procedure dumplr;
var i:integer;
begin writeln('  i ',' chain next kind symb prod');
for i:=1 to lrmax do
with lrÆiÅ do
begin write(' ',i:3,chain:6,next:5,kind:5);
case kind of
1,2,4,6: writeln(symb:5,err:5);
0,3    : writeln(rs:5,prod:5);
5:     writeln(lb:5)
end
end
end;

(* procedures for input/output of characters*)
(*$r+*)
procedure readline;
label 102; (* skip lines longer than 'linemax' characters *)
var lgt : integer;
ch : char;
begin
102:   lineinx:=0; lgt:=-1; printed:=false; errorinx:=0;
if locallinenumber >= 0 then
locallinenumber := locallinenumber + 1;
linenumber:=linenumber+1;

(* avoid destroying the buffer mark in case of type buffering *)
if not typebufferflag then
emit(cnewline, linenumber, nill, cnocode);
if input^ = nl then readln(input);
if eof(input) then 
begin
if more_sources_allowed then
readcall; (* more sources ??? *)
if eof(input) then
moreinput := false;
end;
ch:=' ';
while (ch = ' ') and not eoln(input) do
begin
lgt:=lgt+1;
read(ch);
end;
indention:=lgt;
if not moreinput then ch := '.'; (* ch <> skipch *)
lineÆ1Å:=ch;
lgt:=2;
while (not eoln(input) or (input^ = ff)) and (lgt < linemax) do
(* let  ff  be blind *)
begin
read(lineÆlgtÅ); lgt:=lgt+1
end;
if eoln(input) then
begin
lineÆlgtÅ:=' ';
end
else
begin
markerror( 102 ); (* line too long *) writeln;
while not eoln(input) do
get(input); (* skip line *)
goto 102; (* try the next line *)
end;
linelength:=lgt;
end; (*readline*)

procedure inchar;
begin
if lineinx=linelength then
begin
if not printed and moreinput then printline;
if errorinx>0 then writeln;
readline;
end;
lineinx:=lineinx+1;
ch:=lineÆlineinxÅ;
if (ch>='a') and (ch <= 'z') then
ch := chr(ord(ch) - ord('a') + ord('A')); (* convert to upper case *)
end; (*inchar*)
(*$r-*)


(*end of input/output procedures*)

procedure initialize(var tables : text);
var cc,ch1:char;
a,b,c,d,e,i:integer;
firstlb : integer;
newlb : boolean;
begin
ok := true;
moreinput:=true; lineinx:=1; chbufi:=0;
linelength:=1; printed:=true; errorinx:=0;
parsestackÆ0Å.table:=0; attstackÆ0Å.chbufp:=chbufi;
ch:=' '; parsestackÆ0Å.link:=0;
digitch:=Æ'0'..'9'Å; namech:=Æ'A'..'Z','0'..'9','_'Å;
readln(tables,i); (* i := number of constants to skip *)
for i := i downto 1 do readln(tables);
for i:=1 to comlength do read(tables,comendÆiÅ) ;
readln(tables) ;
for ch1:=minch to maxch do
begin readln(tables,cc,cc,a,b,c);
with entryÆccÅ do
begin
ch:=cc; np:=a; hp:=b; tv:=c
end
end;
entryÆ'"'Å:=entryÆ''''Å;
for i:=0 to lxmax do
with lxÆiÅ do
begin readln(tables,cc,cc,a,b,c);
ch:=cc; np:=a; hp:=b; tv:=c
end;
if stringch=' ' then (*string facility is not used *) stringescape:=-2
else stringescape:= entryÆstringchÅ.tv;
newlb:=true;
for i:=0 to lrmax do
with lrÆiÅ do
begin read(tables,a,b,c,d);
if c <> 5 then readln(tables,e) else readln(tables) ;
chain:=a; next:=b; kind:=c;
case c of
1,2,4,6: begin symb:=d; err:=e end;
0,3    : begin rs:=d; prod:=e  end;
5      :begin lb:=d;
if newlb then
begin firstlb:=i; newlb:=false; end;
if a=0 then
begin
lrÆfirstlbÅ.chain:=i;
newlb:=true;
end;
end
end
end
;
prodtabÆ0Å := 0;
(* read the production labels *)
for i := 1 to prodmax do
readln(tables, a,  prodtabÆaÅ);
end;(*initialize*)

(*$r+*)
procedure lexical;
(*$r-*)
(* returns next terminal in newsymb*)
label 999; (* after skipcomment newsymb is empty and an extra turn is
needed, this is done by means of a  'goto start' *)

var
newi: integer;
oldch: char;
lxnode: lxelm;

procedure skipcomment;
(* read next char on input until comend is recognized *)
var
start_line, passnr, optnr, optvalue : integer;
commentend : char;
begin (* skip comment *)
start_line := linenumber; (* remember current line number in case of unterminated comment *)
if chbufÆ chbufi Å = '(' then commentend := ')'
else commentend := '>';
if ch = '$' then (* option *)
begin
(* the syntax of option is: $ passnr optnr optvalue  *)
while not (( ch >= '0') and (ch <= '9')) do inchar; (* skip *)
passnr := ord(ch) - ord('0');

repeat
inchar; (* skip delimiter *)
until (ch >= '0') and (ch <= '9');

optnr := 0;
while (ch >= '0') and (ch <= '9') do
begin
if optnr < 100 then
optnr := optnr * 10 + ord(ch) - ord('0');
inchar;
end; (*option number *)

while not ((ch >= '0') and (ch <= '9')) do
inchar; (* skip delimiter *)

optvalue := 0;
while (ch >= '0') and (ch <= '9') and (optvalue < 100 ) do
begin
optvalue := optvalue * 10 + ord(ch) - ord('0');
inchar;
end;
if passnr = 1 then
begin
case optnr of
1: programlist := optvalue = 1;
2: call_pass_3 := optvalue = 1;
end (* case *)
otherwise ; 
end
else
begin

(* emit the option *)
emit(coption, passnr, optnr, cnocode);
emit(cnocode, optvalue, nill, cnocode);
end;

end; (* option *)

repeat
while (ch <> '*') and moreinput do inchar;
inchar;
until (ch = commentend) or not moreinput;
if not moreinput then
begin
markerror( 103 ); (* comment did not terminate *)
write(output,'(* comment started in line ', start_line:1, ' *)');
end;
inchar;
end; (* skip comment *)


(*$r+*)
procedure pushch;
(*$r-*)
begin
chbufÆchbufiÅ:=ch;
if chbufi<chbufmax then chbufi:=chbufi+1
else stop(6);
if testoutput then write(output,ch); (***snapshot***)
end; (*pushch*)

procedure readstring;
var strch:char;
instring : boolean;
begin
strch:=oldch;
ch:=lineÆlineinxÅ; (* maybe ch was converted to upper case *)
instring := true;
while
( instring         (* preceding character was not a string delimiter *)
or ( ch = strch ) (* this character is a delim *)
) and ( lineinx <> linelength ) (* stop at eoln *)
do
begin
instring := (ch <> strch) or not instring;
(* false at first delim after character, else true *)
if instring then pushch;
lineinx := lineinx + 1;
ch := lineÆlineinxÅ; (* inchar without converting to upper case *)
end;
if instring or (ch=strch) then markerror(101);
(* string did not terminate within line *)
newsymb:=stringval
end; (*readstring*)

begin (*lexical*)
999:  

if testoutput then
begin
writeln(output); write(output,' lexical: '); (***snapshot***)
end;

while ch = skipch do inchar;
oldbufi:=chbufi;
if not moreinput then
begin
if newsymb=0 then (*third*) stop(2)
else
if newsymb=1 then (*second*) newsymb:=0
else (*first*) newsymb:=1
end
else
if ch in digitch then
begin (*konst*)
repeat
pushch; inchar;
until not (ch in digitch);
newsymb:=constval;
if (ch='.') and (lineÆlineinx+1Å<>'.') 
and (line Æ lineinx + 1 Å <> ')' ) then
begin (*decimal fraction*)
pushch; inchar;
if ch in digitch then
repeat
pushch; inchar;
until not (ch in digitch)
else markerror(100); (* error in realconstant: digit expected *)
newsymb:=realkonst;
end;

if ch='e' then
begin (*exponent*)
pushch; inchar;
if ch in Æ'+','-'Å then
begin
pushch; inchar;
end;

if ch in digitch then
repeat
pushch; inchar;
until not (ch in digitch)
else markerror(100);
newsymb:=realkonst;
end;
end
else (* not konst *)
begin (* search in termtree *)
pushch;
lxnode:=entryÆchÅ; newi:=lxnode.hp;
inchar;
if newi <> 0 then
repeat
if lxÆnewiÅ.ch=ch then
begin pushch;
lxnode:=lxÆnewiÅ;
newi:=lxnode.hp;
inchar
end
else newi:=lxÆnewiÅ.np;
until newi=0;
oldch:=chbufÆchbufi-1Å;
if (oldch in namech) and (ch in namech) then
begin
repeat pushch;
inchar;
until not(ch in namech);
newsymb:=nameval
end
else
if lxnode.tv > 0 then (*valid terminal*)
begin
if lxnode.tv=realkonst then newsymb:=nameval (* the name 'realkonst' is not a reserved word *)
else
begin newsymb:=lxnode.tv;
chbufi:=oldbufi;
if newsymb=stringescape then readstring
else
if newsymb=combegin then begin skipcomment ;  
goto 999; (* enter lexical once more  *)
  end
end
end
else
if oldch in namech then newsymb:=nameval
else markerror(0)
end
end; (*lexical*)


procedure special_code(oldtop, newtop : stackinx; prod : integer);

(* this procedure is only used for handling of open routines *)

(* handling of open routines by hand ( do not use parse ) *)

(* syntax:
beginbody  appetite :
pass5code
endbody

code:
.    literal  begincode
.    codeline( length ) .....
.       .
.       .
.       .
.     endcode

*)

var
stepvar : integer;

function not_endbody : boolean;
(* see if the next word is 'endbody', lineix is only changed
if succes  i.e. parsing may continue as if the routine body
only consisted of :   'beginbody appetite : '
*)

var
step, oldindex : integer;
endbody : alfa;
found : boolean; (* local result *)

begin
found := false;
while ch = skipch do inchar;
oldindex := lineinx; (* remember index of first character *)

if ch = 'E' then (* possibly endbody *)
begin
endbody := 'endbody';
step := 1;
while (endbody Æ step Å = line Æ lineinx Å ) and 
(endbody Æ step Å <> ' ') do
begin
step := step + 1; lineinx := lineinx + 1;
end;
found := (endbody Æ step Å = ' ') and not (line Æ lineinx Å in namech);

if not found then
lineinx := oldindex (* reset lineinx *)
else
ch := line Æ lineinx Å; (* prepare return to parse *)

end; (* maybe endbody *)

not_endbody := not found;


end; (* not_endbody *)

begin  (* special code *)
(* just read 'beginbody appetite' *)
while ch = skipch do inchar;
if ch = ':' then inchar;

emitcode(cbegincode);

while not_endbody and moreinput do
begin
emit(ccodeline, linelength - lineinx, nill, cnocode);
for stepvar := lineinx to linelength - 1 do
emit(cnocode, ord( line Æ stepvar Å ), nill, cnocode);
lineinx := linelength;  (* now current line is processed *)
inchar;
end; (* while *)
emitcode(cendcode);

end; (* special code *)


(*$r+*)
procedure parse;
const
redumax= 25; (* reduction buffer size *)

type
reduinx= 0..redumax;
reduelem=  record
oldtop,newtop: stackinx;
prod: prodno
end;
var
redubuf: arrayÆreduinxÅ of reduelem; (* reduction buffer *)
redutop: reduinx;
stacktop,pseudotop,validtop,top : stackinx;
startinx,lri,start: lrinx;

procedure advance;
var i: integer;
begin
(*perform reductions*)
for i:=1 to redutop do
with redubufÆiÅ do
begin
if prodtabÆprodÅ > 0 then code(oldtop,newtop,prodtabÆprodÅ)
else
if prodtab Æ prod Å <> 0 then 
special_code(oldtop, newtop, prodtab Æ prod Å );
attstackÆnewtopÅ.chbufp:=attstackÆnewtop-1Å.chbufp
end;
(*update stack*)
for i:=1 to stacktop-validtop do
parsestackÆvalidtop+iÅ:=parsestackÆtop+iÅ;
if redutop>0 then (* possible pop of chbuf *)
if oldbufi=chbufi then (* newsymb notin Æname,konst,stringÅ*)
chbufi:=attstackÆstacktop-1Å.chbufp
else (*newsymb in Æname,konst,stringÅ*)
attstackÆstacktopÅ.chbufp:=oldbufi;
(*shift*)
if stacktop=stackmax then stop(1);
stacktop:=stacktop+1;
parsestackÆstacktopÅ.table:=startinx;
attstackÆstacktopÅ.chbufp:=chbufi;
(* freeze new stack situation, ready for new lookahead *)
top:=stacktop; pseudotop:=stacktop; validtop:=stacktop;
start:=lri; redutop:=0
end; (*advance*)

procedure backtrack( btop: stackinx; bstart: lrinx);
begin
stacktop:= btop; validtop:= btop; pseudotop:= btop;
startinx:= bstart; lri:= bstart;
redutop:= 0
end; (* backtrack *)

procedure pseudoshift;
begin
if pseudotop=stackmax then stop(1);
stacktop:= stacktop+1;
pseudotop:= top+(stacktop-validtop);
parsestackÆpseudotopÅ.table:= startinx;
attstackÆpseudotopÅ.chbufp:=chbufi;
end; (* pseudoshift *)

function lookahead( lsymbol: symbol): boolean;
label 11,12;
var decided: boolean;
li,si,locallri,low,high,k,locallb: lrinx;

procedure queue( rs: rslength; p: prodno);
begin
if redutop=redumax then stop(4);
redutop:= redutop+1;
with redubufÆredutopÅ do
begin
oldtop:= stacktop; stacktop:= stacktop-rs; newtop:= stacktop;
if stacktop <= validtop then
begin
pseudotop:= stacktop; validtop:= stacktop
end else pseudotop:= pseudotop-rs;
prod:=p
end
end; (* queue *)

begin
decided:= false;
locallri:=lri;
repeat
startinx:= locallri;
case lrÆlocallriÅ.kind of
0: begin
decided:= true; lookahead:= true; ok:= false
end;
1: begin
while lrÆlocallriÅ.symb<>lsymbol do
begin li:= lrÆlocallriÅ.chain;
if li=0 then goto 11; (* exit loop *)
locallri:= li
end;
11: decided:= true; lookahead:= lrÆlocallriÅ.symb=lsymbol
end;
2,4,6:
begin
while lrÆlocallriÅ.symb<>lsymbol do
begin li:= lrÆlocallriÅ.chain;
if li=0 then goto 12; (* exit loop *)
locallri:= li
end;
12: if lrÆlocallriÅ.kind= 2 then
begin
decided:= true; lookahead:= true
end
else if lrÆlocallriÅ.kind= 6 then
begin
pseudoshift;
stacktop:=stacktop-1; pseudotop:=pseudotop-1;
queue(-1,lrÆlocallriÅ.err)
end
end;
3: begin
queue(lrÆlocallriÅ.rs,lrÆlocallriÅ.prod)
end;
5: begin
si:= parsestackÆpseudotopÅ.table;
low:=locallri;
locallri:=lrÆlocallriÅ.chain;
high:=locallri-1;
while low < high do
begin
k:=(low+high) div 2;
locallb:=lrÆkÅ.lb;
if locallb > si then high:=k-1
else
if locallb < si then low:=k+1
else
begin
high:=k;
low:=high;
end;
end;
k:=(low+high+1) div 2;
if lrÆkÅ.lb = si then locallri:=k;
end
end; (* case *)
locallri:= lrÆlocallriÅ.next;
until decided;
lri:=locallri;
end; (* lookahead *)

procedure syntaxerror;
var success: boolean;
s,s1: stackinx;
begin
if testoutput then write(output,' <---syntaxerror'); (***snapshot***)
markerror(lrÆstartinxÅ.err);
backtrack(top,start);
pseudoshift;
s:= 0;
for s1:= 0 to top do
begin
backtrack( top, start ) ; (* 80.03.21 *)
pseudoshift;

backtrack(s1,parsestackÆs1+1Å.table);
if lookahead(errorval) then
begin
parsestackÆs1Å.link:= s; s:= s1
end
end;
success:= false;
repeat
s1:= s;
repeat
backtrack( top, start ); (* 80.03.21 *)
pseudoshift;

backtrack(s1,parsestackÆs1+1Å.table);
if lookahead(errorval) then
begin
pseudoshift;
success:= lookahead(newsymb)
end;
s1:= parsestackÆs1Å.link;
until (s1=0) or success;
if not success then
begin
(* mark previous symbol skipped *)
if testoutput then write(output,' <---skipped'); (***snapshot***)
lexical
end;
until success or (not ok); 
if not ok then stop(3)
end; (* syntaxerror *)


begin (* parse *)
top:=0; start:=1;
backtrack(top,start);
while ok do
begin
lexical;
if not lookahead(newsymb) then syntaxerror;
advance;
end;
end; (*parse*)
(*$r-*)

begin (* parser *)
open(input,'platontable'); reset(input);
initialize(input);
close(input);
parse;
end; (*parser*)

begin
initialize;
readcall;
parser;
10:
if inputfile then close(input);
close(codefile);
close(symbfile);
close(spixtable);
if errorcount > 0 then printerrors
else
begin
if (warningcount > 0) and (errorcount = 0) then
(* no errors but warnings *)
printerrors;
if call_pass_3 then
replace('platonpass3');
end;
writeln('*** compilation terminated after pass1 ');
end. (*BOBS*)
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦51c6164c6⟧ TextFile

Derivation

TextFile
