|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 40205 (0x9d0d)
Types: TextFile
Names: »P1CODE.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P1CODE.PAS«
(* bobs procedure code *)\r
(*$r+*)\r
procedure code(oldtop,newtop: stackinx; prod: integer);\r
(*$r-*)\r
\r
(* bobs local procedures*)\r
procedure getstring(sy,start: integer; var str:string; var length: integer);\r
var i,j,t:integer;\r
begin\r
str:= blank;\r
if sy>=0 then t:= newtop+(sy-1)\r
else t:= oldtop+(sy-1);\r
length:= attstack[t].chbufp-attstack[t-1].chbufp+start-1;\r
if length>stringmax-start+1 then stop(5);\r
j:= start;\r
for i:= attstack[t-1].chbufp to attstack[t].chbufp-1 do\r
begin\r
str[j]:= convch [chbuf[i] ] ; j:= j+1\r
end\r
end; (*getstring*)\r
\r
\r
procedure outtest;\r
(*outtest produces a sequence of snaphots of the parse\r
(*outtest may be removed by the user *)\r
(*during the parse, snapshots are written on file output *)\r
(*program lines which writes snapshots contains the comment:*)\r
(***snapshot***)\r
var s: string;\r
i,j,l:integer; ch:char;\r
begin\r
writeln(output);\r
write(output,' production:',prod:3);\r
for i:= 1 to oldtop-newtop+1 do\r
begin getstring(i,1,s,l);\r
if l>0 then\r
begin writeln(output);\r
write(output,' symb',i:1,' ');\r
for j:= 1 to l do write(output,s[j])\r
end\r
end\r
end; (*outtest*)\r
\r
\r
\r
function readname : nameheadptr;\r
(* read the name from chbuf(oldtop) into a name structure\r
and return a reference to the head *)\r
\r
var\r
localhead : nameheadptr;\r
chbufindex, charcount : integer;\r
localname : nameptr;\r
\r
begin\r
localhead:= getnamehead; (* allocate a new name head *)\r
with localhead ^ do\r
begin\r
length:= attstack[oldtop].chbufp-attstack[oldtop-1].chbufp;\r
start:= getnamenode;\r
localname:= start; charcount:= 0; chbufindex:= attstack[oldtop-1].chbufp;\r
\r
repeat\r
with localname ^ do\r
namepart[ (charcount mod alfalength)+1 ]:= convch [ chbuf[ chbufindex ] ] ;\r
charcount:= charcount+1;\r
chbufindex:= chbufindex+1;\r
\r
if ((charcount mod alfalength)=0) and (charcount<length) then\r
with localname ^ do\r
begin\r
(* get a new name node *)\r
next:= getnamenode;\r
localname:= next;\r
end;\r
\r
until charcount=length;\r
\r
end; (* with ... *)\r
\r
readname:= localhead;\r
\r
end; (* read name *)\r
\r
procedure errorsection;\r
\r
\r
begin\r
emitcode(cerror);\r
end;\r
\f
\r
procedure export_section;\r
(* section 3 *)\r
\r
var\r
length : integer;\r
str : string; (* pack the export kind into str *)\r
\r
begin\r
case prod of\r
301: (* <export def> ::= <export name>=<export kind> <simple variable>\r
<semicolons> *)\r
(* code: export(kind) *)\r
emitcode( current_export_kind );\r
\r
302: (* <export kind> ::= name *)\r
(* code: export *)\r
(* action : remember the kind *)\r
begin\r
\r
emitcode( cexport );\r
\r
getstring ( 1, 1, str, length );\r
\r
if str='VALUE' then current_export_kind:= cexportvalue\r
else\r
if str='DISP' then current_export_kind:= cexportdisp\r
else\r
if str='SIZE' then current_export_kind:= cexportsize\r
else\r
if str='ADDRESS' then current_export_kind:= cexportaddr\r
else\r
if str='OFFSET' then current_export_kind:= cexportoffset\r
else\r
begin\r
markerror( 104 ); (* export kind expected (value, disp, size, address, or offset ) *)\r
current_export_kind:= cexportsize;\r
end;\r
\r
end; (* 302 *)\r
\r
end; (* case *)\r
\r
end; (* export section *)\r
\r
\f
\r
procedure literals( prod : integer );\r
(* section 4 *)\r
\r
var\r
inx, length, stepvar : integer;\r
codekind : codes;\r
ord_char : integer;\r
char_name: alfa; (* for name of control character *)\r
\r
function get_char_const(char_name: alfa): integer;\r
(* search the table of char constants and return the ordinal\r
value of the character constant *)\r
const\r
no_of_char_names= 34;\r
type\r
char_nametype = array [ 0..no_of_char_names ] of alfa;\r
const\r
(* 0 1 2 3 4 5 6 7 8 9 *)\r
char_names: char_nametype = (\r
(* 0 *) 'NUL ', 'SOH ', 'STX ',\r
(* 3 *) 'ETX ', 'EOT ', 'ENQ ',\r
(* 6 *) 'ACK ', 'BEL ', 'BS ',\r
(* 9 *) 'HT ', 'NL ', 'VT ',\r
(* 12 *) 'FF ', 'CR ', 'SO ',\r
(* 15 *) 'SI ', 'DLE ', 'DC1 ',\r
(* 18 *) 'DC2 ', 'DC3 ', 'DC4 ',\r
(* 21 *) 'NAK ', 'SYN ', 'ETB ',\r
(* 24 *) 'CAN ', 'EM ', 'SUB ',\r
(* 27 *) 'ESC ', 'FS ', 'GS ',\r
(* 30 *) 'RS ', 'US ', 'SP ',\r
(* alternative nl *) 'LF ',\r
(* 127 *) 'DEL ');\r
\r
var\r
step: integer;\r
\r
begin\r
step:= -1;\r
\r
repeat\r
step:= step+1;\r
until (char_name=char_names[ step ]) or (step>ord(sp));\r
\r
if step<=ord(sp) then\r
get_char_const:= step\r
else\r
if char_name='LF ' then\r
get_char_const:= 10\r
else\r
if char_name='DEL ' then\r
get_char_const:= 127\r
else\r
begin\r
markerror(108); (* not name of char constant *)\r
get_char_const:= 0;\r
end; (* unknown char constant *)\r
end; (* get char const *)\r
\r
\r
begin (* literals *)\r
case prod of\r
401: (* called from emitroutinedecl, emit the name as a literal text *)\r
codekind:= ctext;\r
\r
402: (* <unsigned number> ::= <unsigned integer> *)\r
codekind:= cinteger;\r
\r
403: (* <unsigned number> ::= realkonst *)\r
codekind:= creal;\r
404: (* <unsigned integer> ::= # name *)\r
codekind:= cinteger;\r
\r
405: (* <export name> ::= name *)\r
codekind:= ctext;\r
\r
406, (* <string> ::= string *)\r
407: (* ! <string> & string *)\r
(* build string constant *)\r
begin\r
length:= attstack[ oldtop ].chbufp-attstack[ oldtop-1 ].chbufp;\r
if prod=406 then (* start of new string *)\r
str_const_top:= 1;\r
for stepvar:= attstack[ oldtop-1 ].chbufp to attstack[ oldtop ].chbufp-1 do\r
begin\r
string_const[ str_const_top ]:= ord(chbuf[ stepvar ]);\r
if str_const_top=maxnamelength then\r
begin\r
warning(107); (* remaining part of string skipped *)\r
stepvar:= attstack[ oldtop ].chbufp; (* exit pickup string *)\r
end\r
else\r
str_const_top:= str_const_top+1;\r
end; (* for stepvar ... *)\r
end; (* 406, 407 *)\r
\r
408: (* <string> ::= <string> & name (of control character) *)\r
(* pickup name of control character and insert value as next character of the string *)\r
begin\r
inx:= 1;\r
for stepvar:= attstack[ oldtop-1 ].chbufp to attstack[ oldtop ].chbufp-1 do\r
begin\r
char_name[ inx ]:= convch[ chbuf[ stepvar ]];\r
inx:= inx+1;\r
if inx>alfalength then\r
begin\r
markerror(108); (* not name of char constant *)\r
stepvar:= attstack[ oldtop ].chbufp; (* exit pickup string *)\r
end;\r
end; (* for stepvar ... *)\r
\r
for inx:= inx to alfalength do\r
char_name[ inx ]:= ' ';\r
char_name[0] := chr(alfalength);\r
string_const[ str_const_top ]:= get_char_const(char_name);\r
if str_const_top=maxnamelength then\r
warning(107) (* remaining part of string skipped *)\r
else\r
str_const_top:= str_const_top+1;\r
end; (* 408 *)\r
\r
409: (* <value denotation> ::= <string> *)\r
(* code: literal(text length) string *)\r
begin\r
emitcode(cliteral);\r
emit(ctext, str_const_top-1, nill, cnocode);\r
for stepvar:= 1 to str_const_top-1 do\r
emit(cnocode, string_const[ stepvar ], nill, cnocode);\r
end; (* 409 *)\r
\r
end; (* case *)\r
\r
if prod<=405 then\r
begin\r
(* code: literal(length codekind) string *)\r
\r
length:= attstack[oldtop].chbufp-attstack[oldtop-1].chbufp;\r
if prod=404 then length:= length+1; (* '#' *)\r
\r
emitcode(cliteral);\r
emit(codekind, length, nill, cnocode);\r
if prod=404 then (* emit( '#' ) *)\r
emit(cnocode, ord('#'), nill, cnocode );\r
for stepvar:= attstack[oldtop-1].chbufp to attstack[oldtop].chbufp-1 do\r
begin\r
ord_char:= ord( chbuf [ stepvar ] );\r
if ((prod=401) or (prod=404)) and ((ord_char>=ord('A')) and (ord_char<=ord(']'))) then\r
ord_char:= ord_char+ord('a')-ord('A'); (* convert to lower case *)\r
emit(cnocode, ord_char, nill, cnocode);\r
end;\r
end; (* prod<=405 *)\r
end; (* literals *)\r
\r
\f
\r
procedure constantdeclaration;\r
(* section 5 *)\r
\r
var\r
name : nameheadptr;\r
namespix : integer;\r
\r
begin\r
case prod of\r
501: (* <constant definition> ::= <constname>=<expression> <semicolons> *)\r
(*code: endconstantdecl *)\r
emitcode(cendconstantdecl);\r
\r
502: (* <constname> ::= name *)\r
(* declaration(constant) declare(spix) *)\r
begin\r
name:= readname;\r
namespix:= searchname(name);\r
emit( cdeclaration, nill, nill, cconstant);\r
emitdeclare(decl, namespix);\r
end; (* 502 *)\r
\r
503: (* <constant definition> ::= <constname> error *)\r
(* code: id(anonymous) endexpression endconstantdecl *)\r
begin\r
if reduced_intermediate_language then\r
emit(cid, anonymousspix, nill, cnocode)\r
else\r
emit(cid, anonymousspix, nill, cendexpression);\r
emitcode(cendconstantdecl);\r
end;\r
\r
end; (* case *)\r
\r
end; (* constant declaration *)\r
\r
\f
\r
procedure typedefinition;\r
(* section 6 *)\r
\r
var\r
codeword : codes;\r
name : nameheadptr;\r
stepvar,\r
namespix : integer;\r
\r
begin\r
\r
\r
if (prod>=601) and (prod<620) then\r
begin\r
case prod of\r
601: (* <type definition> ::= <type name> <formal parameters> <eq type> *)\r
(* code: endtypedecl endlevel *)\r
begin\r
emitcode(cendtypedecl);\r
codeword:= cendlevel;\r
end;\r
\r
602, (* <eq> ::= =*)\r
616: (* ! : *)\r
(* no code *)\r
begin\r
if prod=616 then\r
begin\r
warning(106);\r
prod:= 602;\r
end;\r
codeword:= cnocode;\r
end; (* 602, 616 *)\r
\r
603: (* <type> ::= <variable> *)\r
(* code: endtype *)\r
begin\r
typebuffer[ attstack[ newtop-1 ].bufferstart]:= ord(ctypeid);\r
(* i.e. change the former generated id to typeid *)\r
if reduced_intermediate_language then\r
codeword:= cnocode\r
else\r
codeword:= cendtype;\r
end;\r
\r
604: (* <type> ::= <structured type> *)\r
(* ! <pool type> *)\r
(* no code *)\r
codeword:= cnocode;\r
\r
605: (* <type> ::= <uparrow> <type> *)\r
(* code: endpointer *)\r
codeword:= cendpointer;\r
\r
606: (* <type> ::= <read only> <type> *)\r
(* code: endreadonly *)\r
codeword:= cendreadonly;\r
\r
607: (* <type> ::= <start scalar> <identifier list> ) *)\r
(* code: endscalar *)\r
codeword:= cendscalar;\r
\r
608: (* <type> ::= <expression> <end subrange> *)\r
(* code: endsubrange *)\r
begin\r
with attstack[ newtop-1 ] do\r
begin\r
typebuffer[ bufferstart-2 ]:= ord(cnewtype);\r
typebuffer[ bufferstart-1 ]:= ord(csubrange);\r
end; (* with *)\r
codeword:= cendsubrange;\r
end;\r
\r
609: (* <type> ::= <external process> <formal parameters> *)\r
(* code: endextprocess endlevel *)\r
begin\r
emitcode(cendextprocess);\r
codeword:= cendlevel;\r
end; (* 609: *)\r
\r
610: (* <record type> ::= <record> <field list> end *)\r
(* code: endrecord *)\r
begin\r
codeword:= cendrecord;\r
end;\r
\r
611: (* <record section> ::= <start section> <identifier list> <type colon> <type> *)\r
(* code: endfield *)\r
codeword:= cendfield;\r
\r
612: (* <set type> ::= <set of> <type> *)\r
(* code: endset *)\r
codeword:= cendset;\r
\r
613: (* <pool type> ::= <pool> <expression> <type size> *)\r
(* code: endpool *)\r
codeword:= cendpool;\r
\r
614: (* <structured type> ::= <packed> <unpacked structured type> *)\r
(* code: packed *)\r
codeword:= cpacked;\r
\r
615: (* <array type> ::= <array start> <type> <component type> *)\r
(* code: endarray *)\r
begin\r
for stepvar:= 1 to dimension_count do\r
emitcode(cendarray);\r
codeword:= cendarray;\r
end;\r
\r
617: (* <type definition> ::= <type name> ; *)\r
(* code: newtype forwardpointer endtypedecl *)\r
begin\r
emit(cnewtype, nill, nill, cforwardpointer);\r
codeword:= cendtypedecl;\r
end;\r
\r
end; (* case 601..619 *)\r
\r
if (prod>=603) and (prod<610) then\r
if (lastbuffered>0) and (attstack[ newtop-1 ].bufferstart=3) then\r
(* i.e. if anything buffered and <type> is the outermost incarnation *)\r
emit_typebuffer;\r
\r
emitcode(codeword);\r
\r
end; (* if .... *)\r
\r
if (prod>=620) and (prod<630) then\r
begin\r
case prod of\r
\r
620: (* <uparrow> ::= ^ *)\r
(* code: newtype pointer *)\r
codeword:= cpointer;\r
\r
621: (* <startscalar> ::= ( name , *)\r
(* code: newtype scalar *)\r
(* declaration( scalarelem ) and *)\r
(* declarelist( name ) is generated after the case statement *)\r
codeword:= cscalar;\r
\r
622: (* <read only> ::= ! *)\r
(* code: newtype readonly *)\r
codeword:= creadonly;\r
\r
623: (* <array> ::= array ( *)\r
(* <new dimension> ::= , *)\r
(* code: newtype array *)\r
codeword:= carray;\r
\r
624: (* <record> ::= record *)\r
(* code: newtype record *)\r
codeword:= crecord;\r
\r
625: (* <set of> ::= set <of> *)\r
(* code: newtype set *)\r
with attstack[ newtop-1 ] (* attstack( =/: ) *) do\r
begin\r
typebuffer[ bufferstart-2 ]:= ord(cnewtype);\r
typebuffer[ bufferstart-1 ]:= ord(cset);\r
end; (* with *)\r
\r
626: (* <pool> ::= pool *)\r
(* code: newtype pool *)\r
codeword:= cpool;\r
\r
627: (* <external type> ::= external process *)\r
(* code: newtype extprocess *)\r
codeword:= cextprocess;\r
\r
628: (* <packed> ::= packed *)\r
(* no code action, stop type buffering *)\r
;\r
\r
end; (* case .. *)\r
\r
if (* <set of> ::= set <of> *) prod=625 then\r
(* move buffer start from attstack(<of>) to attstack<set of>) *)\r
attstack[ newtop ].bufferstart:= attstack[ oldtop ].bufferstart\r
else\r
if (lastbuffered>0) and (attstack[ newtop-1 ].bufferstart=3) then\r
(* i.e. if anything buffered and <type> is known not to be subrange *)\r
(* then stop buffering *)\r
emit_typebuffer;\r
\r
if ((* not <packed> ::= packed *) prod<>628) and\r
((* not <set of>::= set <of> *) prod<>625) then\r
emit(cnewtype, nill, nill, codeword);\r
\r
if (* scalarlist start *) prod=621 then\r
begin\r
emit(cdeclaration, nill, nill, cscalarelem );\r
oldtop:= oldtop-1 ; (* let oldtop denote name *)\r
name:= readname;\r
oldtop:= oldtop+1; (* reset oldtop *)\r
namespix:= searchname(name);\r
emitdeclare(decllist, namespix);\r
end; (* start scalar *)\r
\r
end; (* 620..629 *)\r
\r
if (prod>=630) and (prod<=639) then\r
case prod of\r
632: (* <start section> ::= empty *)\r
(* code: declaration( recfield ) *)\r
emit(cdeclaration, nill, nill, crecfield);\r
\r
635: (* <type size> ::= empty *)\r
(* code: without_data *)\r
(* code for a pool of headers, i.e. without data parts *)\r
emitcode(cwithout_data);\r
\r
636: (* <component type> ::= ) <of type> <type> *)\r
(* action: initialize dimension count *)\r
begin\r
dimension_count:= 0;\r
end;\r
\r
637: (* <component type> ::= <new dimension> <type> <component type> *)\r
(* action: increase dimension count *)\r
dimension_count:= dimension_count+1;\r
\r
\r
end; (* case 630..639 *)\r
\r
\r
if prod=600 then\r
begin\r
(* <type name> ::= name *)\r
(* code: declaration( type ) declare( spix ) *)\r
name:= readname;\r
namespix:= searchname(name);\r
emit( cdeclaration, nill, nill, ctype);\r
emitdeclare(decl, namespix);\r
end; (* 600 *)\r
\r
(* if before <type> then *)\r
if (prod=602) or (prod=620) or (prod=622) or (prod=623) or (prod=640) then\r
begin\r
\r
(* avoid destroying the buffermark because of newline, i.e. the newline\r
codes are generated in front of the marked codes in stead of the\r
(random) places where the newlines are met *)\r
emit(cnewline, linenumber, nill, cnocode);\r
\r
typebufferflag:= true;\r
if lastbuffered+3>typebuffersize then\r
stop( 12 );\r
\r
typebuffer[ lastbuffered+1 ]:= nill;\r
typebuffer[ lastbuffered+2 ]:= nill; (* reserve room for a possible newtype .. *)\r
lastbuffered:= lastbuffered+2;\r
attstack[ newtop ] . bufferstart:= lastbuffered+1;\r
end;\r
\r
\r
end; (* section 6 *)\r
\r
\f
\r
procedure variabledefinition;\r
(* section 7 *)\r
\r
var\r
name : nameheadptr;\r
namespix : integer;\r
\r
begin\r
case prod of\r
\r
700: (* <start var> ::= empty *)\r
(* code: declaration( var ) *)\r
emit(cdeclaration, nill, nill, cvar);\r
\r
701, (* <ident> ::= name *)\r
704: (* ! ? *)\r
(* code: declarelist( spix ) *)\r
begin\r
if prod=701 then\r
begin\r
name:= readname;\r
namespix:= searchname(name);\r
end\r
else\r
namespix:= anonymousspix;\r
emitdeclare(decllist, namespix);\r
end;\r
\r
702: (* <initialization> ::= := <expression> *)\r
(* code: init *)\r
emitcode(cinit);\r
\r
703: (* <var decl> ::= <start var> <identifier list> <type and init> *)\r
(* code: endvardecl *)\r
emitcode(cendvardecl);\r
\r
705: (* <initialization> ::= empty *)\r
(* code: noinit *)\r
emitcode(cnoinit);\r
\r
\r
end; (* case ... *)\r
\r
end; (* section 7 *)\r
\r
procedure expression;\r
(* section 8 *)\r
\r
var\r
codeword1, codeword2 : codes;\r
var_or_field_spix : integer;\r
name : nameheadptr;\r
\r
begin\r
if not reduced_intermediate_language and (prod<=808) then \r
codeword2:= cendexpression\r
else\r
codeword2:= cnocode;\r
var_or_field_spix:= nill;\r
\r
case prod of\r
801: (* <expression> ::= <simple expression> *)\r
(* code: endexpression *)\r
codeword1:= cnocode;\r
\r
802: (* <expression> ::= <simple expression>=<simple expression> *)\r
(* code: eq endexpression *)\r
codeword1:= ceq;\r
\r
803: (* <expression> ::= <simple expression><><simple expression> *)\r
(* code: ne endexpression *)\r
codeword1:= cne;\r
\r
804: (* <expression> ::= <simple expression><<simple expression> *)\r
(* code: lt endexpression *)\r
codeword1:= clt;\r
\r
805: (* <expression> ::= <simple expression><=<simple expression> *)\r
(* code: le endexpression *)\r
codeword1:= cle;\r
\r
806: (* <expression> ::= <simple expression>><simple expression> *)\r
(* code: gt endexpression *)\r
codeword1:= cgt;\r
\r
807: (* <expression> ::= <simple expression>>=<simple expression> *)\r
(* code: ge endexpression *)\r
codeword1:= cge;\r
\r
808: (* <expression> ::= <simple expression> in <simple expression> *)\r
(* code: in endexpression *)\r
codeword1:= cin;\r
\r
810: (* <simple expression> ::= <simple expression>+<term> *)\r
(* code: plus *)\r
codeword1:= cplus;\r
\r
811: (* <simple expression> ::= <simple expression>-<term> *)\r
(* code: minus *)\r
codeword1:= cminus;\r
\r
812: (* <simple expression> ::= <simple expression> or <term> *)\r
(* code: or *)\r
codeword1:= cor;\r
\r
813: (* <simple expression> ::= +<term> *)\r
(* code: uplus *)\r
codeword1:= cuplus;\r
\r
814: (* <simple expression> ::= -<term> *)\r
(* code: uminus *)\r
codeword1:= cuminus;\r
\r
815: (* <simple expression> ::= <simple expression> xor <term> *)\r
(* code: xor *)\r
codeword1:= cxor;\r
\r
816: (* <term> ::= <term> * <factor> *)\r
(* code: star *)\r
codeword1:= cstar;\r
\r
817: (* <term> ::= <term> / <factor> *)\r
(* code: slash *)\r
codeword1:= cslash;\r
\r
818: (* <term> ::= <term> div <factor> *)\r
(* code: div *)\r
codeword1:= cdiv;\r
\r
819: (* <term> ::= <term> mod <factor> *)\r
(* code: mod *)\r
codeword1:= cmod;\r
\r
820: (* <term> ::= <term> and <factor> *)\r
(* code: and *)\r
codeword1:= cand;\r
\r
821: (* <term> ::= <term> shift <factor> *)\r
(* code: and *)\r
codeword1:= cshift;\r
\r
825: (* <factor> ::= <set> *)\r
(* code: endsetlist *)\r
codeword1:= cendsetlist;\r
\r
826: (* <start set> ::= (. *)\r
(* code: setlist *)\r
codeword1:= csetlist;\r
\r
827: (* <element> ::= <expression> *)\r
(* code: s_element *)\r
codeword1:= cs_element;\r
\r
828: (* <element> ::= <expression> .. <expression> *)\r
(* code: m_element *)\r
codeword1:= cm_element;\r
\r
830: (* <factor> ::= <variable> *)\r
(* code: endvariable *)\r
codeword1:= cendvariable;\r
\r
831: (* <factor> ::= not <factor> *)\r
(* code: not *)\r
codeword1:= cnot;\r
\r
835: (* <variable> ::= name *)\r
(* code: id( spix ) may later on be changed to typeid(spix) *)\r
begin\r
codeword1:= cid;\r
name:= readname;\r
var_or_field_spix:= searchname(name);\r
end;\r
\r
836: (* <variable> ::= <variable> . name *)\r
(* code: field( spix ) *)\r
begin\r
codeword1:= cfield;\r
name:= readname;\r
var_or_field_spix:= searchname(name);\r
end;\r
\r
837: (* <variable> ::= <variable> <begin actual> <actual parameter list> ) *)\r
(* code: endactual *)\r
codeword1:= cendactual;\r
\r
838: (* <variable> ::= <variable> ^ *)\r
(* code: uparrow *)\r
codeword1:= cuparrow;\r
\r
839: (* <begin actual> ::= ( *)\r
(* code: beginactual *)\r
codeword1:= cbeginactual;\r
\r
840, (* <factor> ::= typesize(name) *)\r
841: (* ! varsize(name) *)\r
(* code: typesize/varsize (spix) *)\r
begin\r
oldtop:= oldtop-1; (* point at NAME *)\r
var_or_field_spix:= searchname(readname);\r
oldtop:= oldtop+1; (* reestablish *)\r
if prod=840 then\r
codeword1:= ctypesizecall\r
else\r
codeword1:= cvarsizecall;\r
end; (* 840, 841 *)\r
\r
846: (* <start struc val> ::= (: *)\r
codeword1:= cbeginstruc;\r
\r
847: (* <struc value denotation> ::= <start struc val> <actual parameter list> :) *)\r
(* ! <start struc val> :) *)\r
(* code: endstruc *)\r
codeword1:= cendstruc;\r
\r
\r
end; (* case ... *)\r
\r
\r
emit( codeword1, var_or_field_spix, nill, codeword2);\r
\r
end; (* section 8 *)\r
\r
\f
\r
procedure statement;\r
(* section 9 *)\r
\r
var\r
codeword, codeword2 : codes;\r
step, param1 : integer;\r
name : nameheadptr;\r
stat_stack: t_stat_stack;\r
\r
procedure push_repetitive_statement(statement_kind: codes);\r
(* push statement for proper handling of EXITLOOP, CONTINUELOOP and EXIT *)\r
begin\r
if statement_stack_top^.next_stat=nil then\r
begin\r
new(statement_stack_top^.next_stat);\r
with statement_stack_top^.next_stat^ do\r
begin\r
next_stat:= nil;\r
former_stat:= statement_stack_top;\r
end;\r
end; (* add new statement stack node *)\r
statement_stack_top:= statement_stack_top^.next_stat;\r
with statement_stack_top^ do\r
stat_kind:= statement_kind;\r
end; (* push repetitive statement *)\r
\r
\r
begin (* statement *)\r
codeword2:= cnocode;\r
param1:= nill;\r
\r
case prod of\r
\r
901: (* <compound statement> ::= <begin> <statement list> end *)\r
(* code: end *)\r
if reduced_intermediate_language then\r
codeword:= cnocode\r
else\r
codeword:= cend;\r
\r
902: (* <begin> ::= begin *)\r
(* code: begin *)\r
codeword:= cbegin;\r
\r
903: (* <procedure call> ::= <variable> *)\r
(* code: callprocedure *)\r
codeword:= ccallprocedure;\r
\r
904: (* <actual parameter> ::= <unit> *)\r
(* code: actualparam *)\r
begin\r
codeword:= cactualparam;\r
end;\r
\r
905: (* <actual parameter> ::= <expression> *** <unit> *)\r
(* code: doubleparam *)\r
begin\r
codeword:= cdoubleparam;\r
end;\r
\r
906: (* <assignment statement> ::= <variable>:= <expression> *)\r
(* code: endassign *)\r
codeword:= cendassign;\r
\r
907: (* <exchange statement> ::= <variable>:= : <variable> *)\r
(* code: endexchange *)\r
codeword:= cendexchange;\r
\r
909: (* <case statement> ::= <selector part> <case list> <end case part> *)\r
(* code: endcase *)\r
codeword:= cendcase;\r
\r
910: (* <selector part> ::= <case> <expression> of *)\r
(* code: caseexpr *)\r
codeword:= ccaseexpr;\r
\r
911: (* <case> ::= case *)\r
(* code: casestat *)\r
codeword:= ccasestat;\r
\r
912: (* <case list element> ::= <case label list> <end label list> <statement> *)\r
(* <end case part> ::= <otherwise> <statement> end *)\r
(* code: caseelement *)\r
codeword:= ccaseelement;\r
\r
913: (* <label range> ::= <expression> .. <expression> *)\r
(* code: caselabelrange *)\r
codeword:= ccaselabelrange;\r
\r
914: (* <label range> ::= <expression> *)\r
(* code: caselabel *)\r
codeword:= ccaselabel;\r
\r
915: (* <end label list> ::= : *)\r
(* code: caselist *)\r
codeword:= ccaselist;\r
\r
916: (* <otherwise> ::= otherwise *)\r
(* code: otherwise caselist *)\r
begin\r
codeword:= cotherwise;\r
codeword2:= ccaselist;\r
end;\r
\r
917, (* <statement> ::= <for do> <start labelscope> <statement> <end labelscope> *)\r
933, (* ! <while do> <start labelscope> <statement> <end labelscope> *)\r
936, (* ! <lock start> <start labelscope> <statement> <end labelscope> *)\r
947: (* ! <channel do> <start labelscope> <statement> <end labelscope> *)\r
(* <balanced statement> ::= <for do> <start labelscope> <balanced statement> <end labelscope> *)\r
(* ! <while do> <start labelscope> <balanced statement> <end labelscope> *)\r
(* ! <lock start> <start labelscope> <balanced statement> <end labelscope> *)\r
(* ! <channel do> <start labelscope> <balanced statement> <end labelscope> *)\r
\r
(* code: endfor/endwhile/endlock/endchannel *)\r
\r
begin\r
(* pop_repetitive_statement *)\r
statement_stack_top:= statement_stack_top^.former_stat;\r
case prod of\r
917: codeword:= cendfor;\r
933: codeword:= cendwhile;\r
936: codeword:= cendlock;\r
947: codeword:= cendchannel;\r
end; (* case *)\r
\r
end; (* 917, 933, 936, 947 *)\r
\r
918: (* <for do> ::= <for to> <expression> do *)\r
(* code: up *)\r
codeword:= cup;\r
\r
919: (* ! <for downto> <expression> do *)\r
(* code: down *)\r
codeword:= cdown;\r
\r
920: (* <for assign> ::= <for> <variable>:= *)\r
(* code: forvar *)\r
codeword:= cforvar;\r
\r
921: (* <for> ::= for *)\r
(* code: forstat *)\r
begin\r
codeword:= cforstat;\r
push_repetitive_statement(codeword);\r
end;\r
\r
922: (* <goto statement> ::= <goto> <lab name> *)\r
(* code: endgoto *)\r
codeword:= cendgoto;\r
\r
923: (* <goto> ::= goto *)\r
(* code: gotostat *)\r
codeword:= cgotostat;\r
\r
924: (* <lab name> ::= name *)\r
(* ! konst *)\r
(* code: id ( spix ) *)\r
begin\r
name:= readname;\r
param1:= searchname(name);\r
codeword:= cid;\r
end;\r
\r
925: (* <statement> ::= <if then> <statement> *)\r
(* ! <if then else> <statement> *)\r
(* <balanced statement> ::= <if then else> <balanced statement> *)\r
(* code: endif *)\r
begin\r
codeword:= cendif;\r
end;\r
\r
926: (* <if then> ::= <if part> <expression> then *)\r
(* code: ifexpr *)\r
codeword:= cifexpr;\r
\r
927: (* <if part> ::= if *)\r
(* code: ifstat *)\r
codeword:= cifstat;\r
\r
928: (* <if then else> ::= <if then> <balanced statement> else *)\r
(* code: else *)\r
codeword:= celse;\r
\r
929: (* <until> ::= until *)\r
(* code: until *)\r
begin\r
codeword:= cuntil;\r
(* pop_repetitive_statement *)\r
statement_stack_top:= statement_stack_top^.former_stat;\r
end;\r
\r
930: (* <repeat statement> ::= <repeat> <start labelscope> <statement list>\r
<end labelscope> <until> <expression> *)\r
(* code: endrepeat *)\r
codeword:= cendrepeat;\r
\r
932: (* <repeat> ::= repeat *)\r
(* code: repeatstat *)\r
begin\r
codeword:= crepeatstat;\r
push_repetitive_statement(codeword);\r
end;\r
\r
934: (* <while do> ::= <while> <expression> do *)\r
(* code: whileexpr *)\r
codeword:= cwhileexpr;\r
\r
935: (* <while> ::= while *)\r
(* code: whilestat *)\r
begin\r
codeword:= cwhilestat;\r
push_repetitive_statement(codeword);\r
end;\r
\r
937: (* <with> ::= with *)\r
(* code: withstat *)\r
codeword:= cwithstat;\r
\r
938: (* <with comma> ::= , *)\r
(* code: withcomma *)\r
codeword:= cwithcomma;\r
\r
939: (* <with variable> ::= <variable> *)\r
(* code: withvar nolocaldecl *)\r
begin\r
codeword:= cwithvar;\r
codeword2:= cnolocaldecl;\r
if typebufferflag then\r
emit_typebuffer;\r
end;\r
\r
940: (* <as> ::= as *)\r
(* code: withvar *)\r
begin\r
codeword:= cwithvar;\r
if typebufferflag then\r
begin\r
saved_lastbuffered:= lastbuffered;\r
emit_typebuffer;\r
end;\r
end; (* 940 *)\r
\r
941: (* <local name> ::= name *)\r
(* code: declaration( var ) declare( spix ) *)\r
begin\r
name:= readname;\r
emit( cdeclaration, nill, nill, cvar);\r
emitdeclare(decl, searchname(name));\r
(* the code is generated here, and the general mechanism of\r
this section is not used ( codeword=nocode ) *)\r
codeword:= cnocode;\r
\r
end; (* 941 *)\r
\r
942: (* <with variable> ::= <variable> <as> <local name> <type colon><type> *)\r
(* code: endlocaldeclare *)\r
codeword:= cendlocaldeclare;\r
\r
943: (* <with variable> ::= <variable> <as> <local name> *)\r
(* code: nolocaltype *)\r
(* or if part of lock/lockmes statement simulate an implicit buffer type\r
followed by code: endlocaldeclare *)\r
if saved_lastbuffered<>0 then\r
(* lock or lockmes without retyping, produce code as if the apropriate\r
implicit type had been used as retype specification *)\r
begin\r
if typebuffer[1]=ord(clockstat) then\r
begin\r
emit(cnewtype, nill, nill, carray);\r
emit(cnewtype, nill, nill, csubrange);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 1 (* stringlength *), ord('0'), cnocode);\r
emit(cid, bufsize_spix, nill, cbeginactual);\r
for step:= 2 to saved_lastbuffered do\r
emit(cnocode, typebuffer[step], nill, cnocode);\r
emit(cendvariable, nill, nill, cactualparam);\r
emit(cendactual, nill, nill, cendvariable);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 1 (* stringlength *), ord('2'), cnocode);\r
emit(cstar, nill, nill, cnocode);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 1 (* stringlength *), ord('1'), cnocode);\r
emit(cminus, nill, nill, cendsubrange);\r
emit(cnewtype, nill, nill, csubrange);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 1 (* stringlength *), ord('0'), cnocode);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 3 (* stringlength *), ord('2'), cnocode);\r
emit(cnocode, ord('5'), ord('5'), cendsubrange);\r
emit(cendarray, nill, nill, cnocode);\r
end (* lock *)\r
else\r
if typebuffer[1]=ord(clockmesstat) then\r
begin\r
emit(cnewtype, nill, nill, carray);\r
emit(cnewtype, nill, nill, csubrange);\r
emit(cid, first_spix, nill, cbeginactual);\r
for step:= 2 to saved_lastbuffered do\r
emit(cnocode, typebuffer[step], nill, cnocode);\r
emit(cendvariable, nill, nill, cactualparam);\r
emit(cendactual, nill, nill, cendvariable);\r
emit(cid, last_spix, nill, cbeginactual);\r
for step:= 2 to saved_lastbuffered do\r
emit(cnocode, typebuffer[step], nill, cnocode);\r
emit(cendvariable, nill, nill, cactualparam);\r
emit(cendactual, nill, nill, cendvariable);\r
emit(cendsubrange, nill, nill, cnocode);\r
emit(cnewtype, nill, nill, csubrange);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 1 (* stringlength *), ord('0'), cnocode);\r
emit(cliteral, nill, nill, cinteger);\r
emit(cnocode, 3 (* stringlength *), ord('2'), cnocode);\r
emit(cnocode, ord('5'), ord('5'), cendsubrange);\r
emit(cendarray, nill, nill, cnocode);\r
end; (* lockmes *)\r
codeword:= cendlocaldeclare;\r
end (* lock or lockmes without retyping *)\r
else\r
codeword:= cnolocaltype;\r
\r
944: (* <statement> ::= <with start> <start labelscope> <statement> <end labelscope> *)\r
(* <balanced statement> ::= <with start> <start labelscope> <balanced statement> <end labelscope> *)\r
(* code: endwith *)\r
codeword:= cendwith;\r
\r
948: (* <channel do> ::= <channel> <variable> do *)\r
(* code: chanvar *)\r
codeword:= cchanvar;\r
\r
949: (* <channel> ::= channel *)\r
(* code: channelstat *)\r
begin\r
codeword:= cchannelstat;\r
push_repetitive_statement(codeword);\r
end;\r
\r
950: (* <with start> ::= <with> <with variable list> do *)\r
(* <lock start> ::= <lock> <with variable> do *)\r
(* code: do *)\r
begin\r
saved_lastbuffered:= 0;\r
codeword:= cdo;\r
end;\r
\r
951, (* <statement> ::= continueloop *)\r
953: (* ! exitloop *)\r
(* <balancde statement> ::= continueloop *)\r
(* ! exitloop *)\r
(* code: continue/exit-loopstat, possibly preceeded by exit of lock and or channel *)\r
begin\r
if prod=951 then\r
codeword:= ccontloopstat\r
else\r
codeword:= cexitloopstat;\r
stat_stack:= statement_stack_top;\r
while (stat_stack^.stat_kind=clockstat) or (stat_stack^.stat_kind=cchannelstat) do\r
begin\r
emit(cexitlock, nill, nill, stat_stack^.stat_kind);\r
stat_stack:= stat_stack^.former_stat;\r
end;\r
if stat_stack^.former_stat=nil (* bottom element, i.e. not inside repetitive statement *) then\r
markerror(109); (* not inside repetitive statement *)\r
codeword2:= stat_stack^.stat_kind;\r
end; (* continue-/exit-loopstat *)\r
\r
952: (* <statement> ::= exit *)\r
(* <balanced statement> ::= exit *)\r
(* code: exitstat , possibly preceeded by exitlock/exitchannel *)\r
begin\r
codeword:= cexitstat;\r
stat_stack:= statement_stack_top;\r
while stat_stack<>nil do\r
with stat_stack^ do\r
begin\r
if (stat_kind=clockstat) or (stat_kind=cchannelstat) then\r
emit(cexitlock, nill, nill, stat_kind);\r
stat_stack:= former_stat;\r
end;\r
end; (* exit *)\r
\r
955: (* <unit> ::= ? *)\r
(* code: skipparam *)\r
codeword:= cskipparam;\r
\r
956: (* <loop> ::= loop *)\r
(* code: loopstat *)\r
begin\r
codeword:= cloopstat;\r
push_repetitive_statement(codeword);\r
end;\r
\r
957: (* <loop statement> ::= <loop> <statement list> endloop *)\r
(* code: endloopstat *)\r
begin\r
codeword:= cendloopstat;\r
(* pop_repetitive_statement *)\r
statement_stack_top:= statement_stack_top^.former_stat;\r
end;\r
\r
965, (* <lock> ::= lock *)\r
966: (* ! lockmes *)\r
(* code: lockstat/lockmesstat *)\r
begin\r
typebufferflag:= true; (* use the typebuffer to save the code for the reference\r
variable of the lock statement, used for simulation of an implicit type in\r
case of lock/lockmes without retyping *)\r
if prod=965 then\r
codeword:= clockstat\r
else\r
codeword:= clockmesstat;\r
push_repetitive_statement(clockstat); (* pushed with same kind *)\r
end;\r
\r
end; (* case .... *)\r
\r
(* now the parameters for the emit call has been set up *)\r
emit( codeword, param1, nill, codeword2);\r
\r
end; (* section 9 *)\r
\f
\r
procedure emitroutinedecl( routine_kind : codes; name : nameheadptr);\r
(* emit: declaration ( routine_kind )\r
. literal( text length) 'name'\r
. declare( spix )\r
*)\r
begin\r
emit(cdeclaration, nill, nill, routine_kind);\r
literals( 401 (* i.e. text *) );\r
emitdeclare(decl, searchname( name ) );\r
end; (* emitroutinedecl *)\r
\r
\r
procedure proceduredeclaration;\r
(* section 10 *)\r
\r
(* this section covers-in addition to procedure declarations-the\r
parsing of <formal parameters> and <block> and <declarations> *)\r
\r
var\r
name : nameheadptr;\r
codeword : codes;\r
step : integer;\r
\r
begin\r
case prod of\r
1001: (* <spix name> ::= name *)\r
(* action: pick up name and remember name head in alias name *)\r
alias_name:= readname;\r
\r
\r
1002: (* <routine heading> ::= <procedure heading> *)\r
(* code: endprocdecl *)\r
begin\r
emitcode(cendprocdecl);\r
end;\r
\r
1003: (* <procedure name> ::= name *)\r
(* code: declaration( procedure ) literal( text length) 'name' declare( spix ) *)\r
begin\r
name:= readname;\r
emitroutinedecl( cprocedure, name );\r
end;\r
\r
1004: (* <procedure name> ::= <spix name>=name *)\r
(* code: declaration declare, nb: name literal is name but spix is\r
from spix name !! *)\r
emitroutinedecl( cprocedure, alias_name );\r
\r
1006: (* <parameter description> ::= <var or value> <parameter group>\r
<type colon> <type> *)\r
(* code: endformallist *)\r
emitcode(cendformallist);\r
\r
1007: (* <formal parameters> ::= <init formal> *)\r
(* ! <init formal> ( <formal list> ) *)\r
(* code: endformal *)\r
if not reduced_intermediate_language then\r
emitcode(cendformal);\r
\r
1008: (* <parameter group> ::= name *)\r
(* ! <parameter group> , name *)\r
(* code: declarelist( spix ) *)\r
begin\r
name:= readname;\r
emitdeclare(decllist, searchname(name));\r
end;\r
\r
1009: (* <declarations> ::= <begin level> <decls> *)\r
(* code: enddeclarations *)\r
begin\r
if contextparsing then Locallinenumber := -1 else LocallineNumber := 0;\r
emitcode(cenddeclarations);\r
end;\r
\r
1010: (* <begin level> ::= empty *)\r
(* code: beginlevel *)\r
begin\r
emitcode(cbeginlevel);\r
end;\r
\r
1011: (* <block> ::= <declarations> <start labelscope> <compound statement>\r
<end labelscope> *)\r
(* code: endblock endlevel endlevel *)\r
(* action: stop local line numbering *)\r
begin\r
emitboth(cendblock, nill, nill);\r
emit( cendlevel, nill, nill, cendlevel);\r
locallinenumber:= -1; (* suppress printing of local line numbers *)\r
if contextparsing then\r
markerror(110 (* Routines in environment must be EXTERNAL declarations *));\r
end;\r
\r
1020, (* <block> ::= external *)\r
1021: (* ! forward *)\r
(* code: external/forward endlevel *)\r
begin\r
if prod=1020 then codeword:= cexternal\r
else codeword:= cforward;\r
emitcode(codeword);\r
emitcode(cendlevel);\r
locallinenumber:= -1;\r
end;\r
\r
1022: (* <init formal> ::= empty *)\r
(* code: beginlevel *)\r
emitcode(cbeginlevel);\r
\r
1023, (* <var or value> ::= empty *)\r
1024: (* ! var *)\r
(* code: declaration( valuep/varp ) *)\r
begin\r
if prod=1023 then codeword:= cvaluep\r
else codeword:= cvarp;\r
emit( cdeclaration, nill, nill, codeword);\r
end;\r
\r
\r
end; (* case *)\r
\r
end; (* section 10 *)\r
\r
\f
\r
procedure functiondeclaration;\r
(* section 11 *)\r
\r
begin\r
\r
case prod of\r
1101: (* <routine heading> ::= <function heading> *)\r
(* code: endfuncdecl *)\r
begin\r
emitcode(cendfuncdecl);\r
end;\r
\r
1102: (* <function name> ::= name *)\r
(* code: declaration ( function )\r
. literal ( text length ) 'name'\r
. declare ( spix )\r
*)\r
begin\r
emitroutinedecl( cfunction, readname );\r
end;\r
1103: (* <function name> ::= <spix name>=name *)\r
(* code: declaration declare, nb: the literal is name but the\r
spix is that of spix name !! *)\r
emitroutinedecl( cfunction, alias_name );\r
\r
\r
end; (* case *)\r
\r
end; (* section 11 *)\r
\r
\f
\r
procedure labeldeclaration;\r
(* section 12 *)\r
\r
\r
begin\r
case prod of\r
1201: (* <label name> ::= name *)\r
(* ! konst *)\r
(* code: if declarations then \r
declaration( label ) declare( spix )\r
else\r
labeldef( currentlabelscope spix),\r
labeldef( currentlabelscope spix ) *)\r
if locallinenumber=-1 then (* i.e. declaration of a label *)\r
begin\r
emit( cdeclaration, nill, nill, clabel);\r
emitdeclare(decl,searchname(readname));\r
end\r
else\r
begin\r
emitboth(clabeldef, currentlabelscope, searchname(readname));\r
end;\r
\r
1202: (* <start labelscope> ::= empty *)\r
(* code: startlabelscope( scope ) *)\r
begin\r
attstack[ newtop ] . oldlabelscope:= currentlabelscope;\r
lastlabelscope:= lastlabelscope+1;\r
currentlabelscope:= lastlabelscope;\r
emit(cstartlabelscope, currentlabelscope, nill, cnocode);\r
end;\r
\r
1203: (* <end labelscope> ::= empty *)\r
(* code: endlabelscope( scope ) *)\r
begin\r
emit(cendlabelscope, currentlabelscope, nill, cnocode);\r
currentlabelscope:= attstack[ newtop-2 ] . oldlabelscope;\r
(* i.e. get the scope stored in attstack[ <start labelscope> ] *)\r
end;\r
\r
end; (* case *)\r
\r
end; (* section 12 *)\r
\r
\f
\r
procedure processdeclaration;\r
(* section 13, process and prefix declaration *)\r
\r
var\r
name : nameheadptr;\r
codeword : codes;\r
\r
begin\r
case prod of\r
\r
1301: (* <context name> ::= name *)\r
(* code: context( spix ) *)\r
begin\r
if before_standard_defs then\r
predef_environment;\r
name:= readname;\r
emit(ccontext, searchname(name), nill, cnocode);\r
contextparsing:= true;\r
end;\r
\r
1303: (* <body> ::= <body list> *)\r
(* code: eom *)\r
begin\r
emitcode(ceom);\r
ok:= false; (* stop parsing *)\r
if not printed then printline; (* print the last line *)\r
end;\r
\r
1304: (* <procsems> ::= <semicolons> *)\r
(* code: endprocdecl *)\r
begin\r
emitcode(cendprocdecl);\r
\r
end;\r
\r
1305, (* <process name> ::= name *)\r
1306: (* <prefix name> ::= name *)\r
(* code: declaraton( process/prefix ) declare( spix ) *)\r
begin\r
name:= readname;\r
if prod=1305 then codeword:= cprocess\r
else\r
codeword:= cprefix;\r
emitroutinedecl( codeword, name );\r
end;\r
\r
1307: (* <prefix declaration> ::= <prefex heading> <semicolons> \r
<begin level> <routine declaration> *)\r
(* code: endlevel endprefix *)\r
begin\r
emit(cendlevel, nill, nill, cendprefix);\r
end;\r
\r
1310: (* <external> ::= <context name> <semicolons> <declarations> . *)\r
(* code: endcontext *)\r
(* action: contextparsing:= false *)\r
begin\r
contextparsing:= false;\r
if not reduced_intermediate_language then\r
emitcode(cendcontext);\r
end;\r
\r
1311: (* <external part> ::= <externals> *)\r
(* code: endinclude *)\r
begin\r
more_sources_allowed:= false;\r
emitcode( cendinclude );\r
end;\r
\r
1312: (* <body elem> ::= <begin level> <process declaration> *)\r
(* ! <begin level> <prefix declaration> *)\r
(* ! <begin level> <process declaration> <semicolons> *)\r
(* ! <begin level> <prefix declaration> <semicolons> *)\r
(* code: endlevel *)\r
emitcode(cendlevel);\r
\r
end; (* case *)\r
\r
end; (* section 13 *)\r
\r
\f
\r
\r
\r
begin (* code *)\r
if testoutput then outtest;(***snapshot***)\r
\r
case prod div 100 of\r
\r
0: ; (* nothing is done *)\r
\r
1: errorsection; (* ** ::= error *)\r
\r
2 : ; (* not used *)\r
\r
3: export_section;\r
\r
4: literals( prod ); \r
\r
5: constantdeclaration;\r
\r
6: typedefinition;\r
\r
7: variabledefinition;\r
\r
8: expression;\r
\r
9: statement;\r
\r
10: proceduredeclaration;\r
\r
11: functiondeclaration;\r
\r
12: labeldeclaration;\r
\r
13: processdeclaration;\r
\r
end; (* case ... *)\r
\r
end;(*code*)\r
\r
(* bobs procedures continuated*)\r
procedure stop;\r
begin\r
markerror(0);\r
writeln(output);writeln(output);\r
case n of\r
1: writeln(output,' *** parse stack overflow. const ''stackmax'' too small');\r
2: writeln(output,' *** end of file encountered ');\r
3: writeln(output,' *** recovery abandoned ');\r
4: writeln(output,' *** reduction buffer overflow. const ''redumax'' too small');\r
5: writeln(output,' *** const ''stringmax'' too small ');\r
6: if errorcount>1 then writeln(output,' *** recovery abandoned ');\r
7: writeln(output,' *** premature end of file, missing $ENDIF ');\r
12: writeln(output, ' *** const ''typebuffersize'' too small ');\r
else\r
writeln(output,' *** const ''chbufmax'' too small ');\r
end;\r
myexit;\r
end;(*stop*)\r
\r
«eof»