|
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: 55926 (0xda76)
Types: TextFile
Names: »P1CODE.PAS«
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\P1CODE.PAS«
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\P1CODE.PAS«
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
└─⟦this⟧ »RTP\P1CODE.PAS«
{$O+,F+}\r
unit p1code;\r
interface\r
uses pscplm, files, mpaunit, sthunit, sthcom, sthp1, rtp86mpa;\r
\r
\r
const\r
(* bobs-constants*)\r
stackmax=100; (*size of attstack and parsestack *)\r
chbufmax=300; (* size of array chbuf *)\r
minch=' '; maxch='~'; (*first/last character in type char*)\r
linemax=150; (*max. length of lines*)\r
\r
varprod0 = 834;\r
first_varprod = 835; last_varprod = 842;\r
first_stdprod = 650;\r
(*global constants used in code*)\r
pass1_version = 500;\r
nill = -1; (* end of chain *)\r
blank=' '; (*to clear a variable of type alfa*)\r
maxbyte = 255;\r
typebuffersize= 650; (* maximum number of buffered codes *) (*! hha *)\r
\r
\r
type\r
alfa = string[alfalength];\r
(** type used for transfer between the types: word and integer **)\r
\r
iw = record\r
case b : boolean of\r
true: ( i: integer );\r
false: ( w: word );\r
end;\r
\r
onof_ptr = ^on_of;\r
\r
on_of = record\r
former : onof_ptr;\r
inc_state,\r
txton : boolean;\r
end;\r
\r
(* bobs-types*)\r
chbufinx=0..chbufmax;\r
stackinx=0..stackmax;\r
\r
(*types used in code*)\r
attributes=record\r
chbufp:chbufinx;\r
bufferstart : 1..typebuffersize; (* start index in type buffer\r
for this element *)\r
var_state,\r
oldlabelscope: integer;\r
save_typespix : spixrange;\r
protect_type : st_protect_type;\r
virt_addr: st_address; (**#BBP#**)\r
comma_counter: integer; (**#BBP#**) (*multidim arrays and with *)\r
\r
end;\r
\r
em_out_type = ( em_none, em_is_code, em_is_param );\r
\r
emit_type=record\r
em_out : em_out_type;\r
em_code: word;\r
end;\r
\r
var\r
\r
iwparam : iw;\r
\r
txton_ptr, former_ptr : onof_ptr;\r
opt_ptr : ^optiontype;\r
\r
\r
(* bobs-variables*)\r
attstack: array[stackinx] of attributes;\r
chbuf: array[chbufinx] of char;\r
chbufi: chbufinx;\r
source_start, in_comment, ok, liston, p1list : boolean;\r
(*chbuf, chbufi, field chbufp of attributes, tables and ok\r
(*should not be changed by the user *)\r
convch : array [ char ] of char;\r
\r
line: string; (* contains current line *)\r
\r
local_specs, temp_specs, typespecs : set of protect_spec;\r
save_mode : st_declaremode;\r
last_code,\r
old_source,\r
last_line : word;\r
\r
niv_count,\r
linelength, (*length of current line*)\r
lineinx: integer; (*position in line of current ch*)\r
\r
more_sources_allowed, (* true until source-text is met *)\r
moreinput, (* becomes false when input is exhausted *)\r
incl_condition,\r
include_txt,\r
type_decl,\r
type_colon,\r
program_type: boolean;\r
\r
array_ix,\r
ord_scalar,\r
currentlabelscope, (* the actual label level *)\r
lastlabelscope : word; (* highest used scope nr *)\r
\r
\r
alarm,\r
contextparsing,\r
scalar_decl,\r
region_stat,\r
link_param,\r
in_family,\r
first_colon,\r
renaming, (**$BBP$**)\r
xtestpass1,\r
make_packed:boolean;\r
\r
var_or_shared, (* used by "code" *)\r
char_or_text, (*set by lexical according to kind of KONST *)\r
int_or_real : codes; (* set by lexical according to the kind of KONST *)\r
\r
dimension_count, (* count nested arrays, i.e. the number of dimensions *)\r
\r
\r
lastbuffered : integer; (* last used element in typebuffer *)\r
typebuffer : array [0..typebuffersize] of emit_type;\r
typebufferflag : boolean; (* indicates whether the codes are to be buffered or not *)\r
\r
str_and, str_or, str_xor, str_not : string;\r
\r
ext_string: record length: byte; name:array[1..255] of char end;\r
alias_name: string; (* remember name node for alias name *)\r
\r
numberconv: array [ char ] of integer;\r
\r
accept_segment: integer;\r
\r
\r
\r
(*** variables for communication with STH ***)\r
p1st_currptr: st_elemptr;\r
(** holds pointer to latest accessedd ST-element **)\r
\r
p1st_varaddr, p1st_praddr, first_typeaddr, pr_first_typeaddr, scalar_addr,\r
p1st_hlpaddr,\r
p1st_curraddr, st_recordaddr : st_address;\r
(** holds virtual address of latest accessed ST-element **)\r
\r
\r
\r
(*** ROUTINES ***)\r
procedure emitaddress(addr: st_address);\r
\r
procedure outcode(code: codes; addr: st_address);\r
\r
procedure emit(code: codes; param0 : integer;\r
b1 : boolean; param1 : word;\r
b2 : boolean; param2: word; descriptor: codes);\r
procedure emitcode(code: codes);\r
\r
procedure code(oldtop,newtop:stackinx; prod: integer);\r
\r
implementation\r
\r
(* bobs procedure code*)\r
\r
procedure emit( code : codes; param0 : integer;\r
b1 : boolean; param1: word; b2 : boolean; param2 : word;\r
descriptor : codes );\r
\r
begin\r
\r
if not typebufferflag then\r
begin (*** write onto CODEFILE! **)\r
if code <> cnocode then\r
begin\r
if last_line<linenumber then\r
begin\r
last_line:= linenumber;\r
put_byte(ord(cnewline)); put_2_byte(linenumber)\r
end;\r
put_byte(ord(code));\r
end;\r
if param0 <> nill then\r
begin\r
iwparam.i:= param0;\r
put_2_byte(iwparam.w);\r
end;\r
if b1 then put_2_byte(param1);\r
if b2 then put_2_byte(param2);\r
if descriptor <> cnocode then\r
put_byte(ord(descriptor));\r
end;\r
\r
if typebufferflag then\r
begin\r
if typebuffersize - lastbuffered < 4 then fatal_error( pass1,212);\r
(*fatal error*)\r
if code <> cnocode then\r
begin\r
lastbuffered := lastbuffered + 1;\r
with typebuffer[lastbuffered] do\r
begin\r
em_out:= em_is_code;\r
em_code:= ord(code);\r
end;\r
end;\r
if param0 <> nill then\r
begin\r
lastbuffered := lastbuffered + 1;\r
iwparam.i:= param0;\r
with typebuffer[lastbuffered] do\r
begin\r
em_out:= em_is_param;\r
em_code:= iwparam.w;\r
end;\r
end;\r
if b1 then\r
begin\r
lastbuffered := lastbuffered + 1;\r
with typebuffer[lastbuffered] do\r
begin\r
em_out:= em_is_param;\r
em_code:= param1;\r
end;\r
end;\r
if b2 then\r
begin\r
lastbuffered := lastbuffered + 1;\r
with typebuffer[lastbuffered] do\r
begin\r
em_out:= em_is_param;\r
em_code:= param2;\r
end;\r
end;\r
if descriptor <> cnocode then\r
begin\r
lastbuffered := lastbuffered + 1;\r
with typebuffer[lastbuffered] do\r
begin\r
em_out:= em_is_code;\r
em_code:= ord(descriptor);\r
end;\r
end;\r
\r
end; (* buffered mode *)\r
\r
\r
end; (* emit *)\r
\r
\r
\r
procedure emitcode(code : codes );\r
begin\r
emit(code, nill, false, 0, false, 0, cnocode);\r
end;\r
\r
\r
procedure outcode(code: codes; addr:st_address);\r
begin\r
emit(code, nill, true,addr.va_low, true,addr.va_high,cnocode);\r
end; (*outcode*)\r
\r
procedure emitaddress(addr: st_address);\r
begin\r
emit(cnocode, nill, true,addr.va_low, true,addr.va_high,cnocode);\r
end; (*emitaddress*)\r
\r
\r
procedure code(oldtop,newtop: stackinx; prod: integer);\r
\r
(* bobs local procedures*)\r
procedure getstring(sy,start: integer; var stringx:alfa; var length: integer);\r
var i,j,t:integer;\r
begin\r
stringx := 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>alfalength-start+1 then fatal_error( pass1,205);\r
j:=start;\r
for i:=attstack[t-1].chbufp to attstack[t].chbufp-1 do\r
begin\r
stringx[j]:= convch [chbuf[i] ] ; j:=j+1\r
end\r
end; (*getstring*)\r
\r
procedure getstring1(sy: integer; var stringx:alfa; var length: integer);\r
var i,j,last,t:integer;\r
begin\r
stringx := blank;\r
t:= newtop+(sy-1);\r
length:=attstack[t].chbufp-attstack[t-1].chbufp;\r
if length > alfalength then length:= alfalength;\r
last:= attstack[t-1].chbufp + length -1;\r
j:=1;\r
for i:=attstack[t-1].chbufp to last do\r
begin\r
stringx[j]:= convch [chbuf[i] ] ; j:=j+1\r
end\r
end; (*getstring1*)\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 testoutput *)\r
(*program lines which writes snapshots contains the comment:*)\r
(***snapshot***)\r
var s: alfa;\r
i,j,l:integer; ch:char;\r
begin\r
writeln(testoutput);\r
(*****)\r
writeln(testoutput,'oldtop: ',oldtop);\r
writeln(testoutput,'newtop: ',newtop);\r
(*****)\r
write(testoutput,' production:',prod:3);\r
for i:=1 to oldtop-newtop+1 do\r
begin getstring1(i,s,l);\r
if l>0 then\r
begin writeln(testoutput);\r
write(testoutput,' symb',i:1,' ');\r
for j:=1 to l do write(testoutput,s[j])\r
end\r
end\r
end; (*outtest*)\r
\r
procedure outstruc;\r
begin\r
writeln(testoutput);\r
if xpackedtype in typespecs then write(testoutput,' packed');\r
if pointertype in typespecs then write(testoutput,' pointer');\r
if mailboxtype in typespecs then write(testoutput,' mailbox');\r
if referencetype in typespecs then write( testoutput,' reference');\r
if pooltype in typespecs then write( testoutput,' pool');\r
if processtype in typespecs then write( testoutput,' process');\r
if porttype in typespecs then write( testoutput,' port');\r
if mailboxpointer in typespecs then write(testoutput,' mailboxpointer');\r
if chaintype in typespecs then write( testoutput,' chain');\r
if programtype in typespecs then write( testoutput,' program'); \r
writeln(testoutput);\r
end;\r
\r
\r
\r
procedure readname(var namestring: string);\r
(* read the name from chbuf[oldtop] into\r
a rtp-stringvariable ****************)\r
var\r
lgth, chbufindex, charcount: integer;\r
begin\r
namestring := '';\r
chbufindex := attstack[oldtop - 1].chbufp;\r
lgth := attstack[oldtop].chbufp - attstack[oldtop - 1].chbufp;\r
if lgth > rtpstringmax then lgth:= rtpstringmax;\r
(** cutting off string **)\r
\r
(*with namestring do*)\r
begin\r
\r
for charcount:= 1 to lgth do\r
begin\r
namestring := concat(namestring, convch[chbuf[chbufindex]]);\r
chbufindex := chbufindex + 1;\r
end;\r
\r
(*length := lgth;*)\r
end; (* with -- *)\r
\r
(** TEST **)\r
(**\r
writestring(namestring);\r
**)\r
\r
end; (** readname **)\r
\r
procedure dump_segment;\r
begin\r
if (accept_segment=0) AND (Computer <> RC5000) AND (Computer <> RC3502) then\r
begin\r
make_segmentation:=false;\r
last_segment:=last_segment+1;\r
segment_info[last_segment].line:=linenumber;\r
emitcode(csegment);\r
end;\r
end;\r
\r
procedure errorsection;\r
\r
\r
begin\r
emitcode(cerror);\r
end;\r
\r
procedure type_end;\r
var\r
stepvar : word;\r
\r
begin\r
if not program_type then\r
begin\r
\r
(*\r
writeln(testoutput,'lastbuf ',lastbuffered, 'bufferstart ',\r
attstack[newtop-1].bufferstart);\r
*)\r
\r
\r
if (lastbuffered > 0) and (attstack[ newtop - 1 ].bufferstart = 4) then\r
(* i.e. if anything buffered and <type> is the outermost incarnation *)\r
begin\r
if (typespecs <> []) and not first_colon then\r
begin\r
st_get( first_typeaddr, p1st_currptr );\r
if p1st_currptr^.st_kind = ctype then\r
begin\r
p1st_currptr^.spec_struct:= typespecs;\r
typespecs:= [];\r
end;\r
end;\r
type_colon:= false;\r
first_colon:= true;\r
in_family:= false;\r
typebufferflag := false;\r
for stepvar := 1 to lastbuffered do with typebuffer[stepvar] do\r
if em_out=em_is_code then\r
emit(codes(em_code),nill,false,0,false,0,cnocode)\r
else if em_out=em_is_param then\r
emit(cnocode,nill,true,em_code,false,0,cnocode);\r
lastbuffered := 0;\r
end; (* if buffered *)\r
\r
end;\r
\r
end;\r
\r
\r
procedure literals;\r
(* section 4 *)\r
\r
var\r
base, val, lgth, strlgth, stepvar,\r
ord_char : integer;\r
codekind : codes;\r
spix : spixrange;\r
char_name: string;\r
\r
\r
begin\r
if prod = 401 then (* <value denotation> ::= string or char *)\r
begin\r
with ext_string do\r
begin\r
emit( cliteral, nill, false, 0, false, 0, cnocode );\r
emit(char_or_text, length, false, 0, false, 0, cnocode );\r
for stepvar:= 1 to length do\r
emit( cnocode, nill, true, ord( name[ stepvar ] ), false, 0, cnocode );\r
end;\r
(*** end 401 ***)\r
end else\r
begin\r
(* prod > 401 *)\r
\r
(* code: literal(codekind lgth) string *)\r
lgth := attstack[oldtop].chbufp - attstack[oldtop-1].chbufp;\r
\r
case prod of\r
\r
402: (* <unsigned integer> ::= <KONST> *)\r
codekind := int_or_real; (* set by lexical *)\r
\r
404: (* <unsigned integer> ::= # name *)\r
(* codekind := word or byte, see below *) \r
begin\r
lgth := lgth + 1; (* '#' *)\r
(* detect whether kind is word or byte *)\r
case chbuf [ attstack [ oldtop - 1 ] . chbufp ] of\r
'b', 'B': base := 2;\r
'o', 'O': base := 8;\r
'd', 'D': base := 10;\r
'h', 'H': base := 16\r
else (*otherwise*)\r
begin\r
errormsg( pass1,115); (* base: b, o, d, or h expected *)\r
base := 0; (* error *)\r
val:= 0;\r
end\r
end; (* case *)\r
if base <> 0 then\r
for stepvar := attstack [ oldtop - 1 ] . chbufp + 1 to\r
attstack [ oldtop ] . chbufp - 1 do\r
if numberconv[chbuf[stepvar]] >= base then errormsg( pass1,115 );\r
if base=2 then val:= 10 else val:= 4;\r
\r
if lgth <= val then\r
codekind := cbyte\r
else\r
codekind := cword;\r
end; (* word or byte *)\r
(* end 404 *)\r
\r
405: (** string **)\r
begin\r
ext_string.length:= 0;\r
alarm:= false;\r
end;\r
\r
408: (*** name ***)\r
begin\r
readname( char_name );\r
lgth:= 1;\r
spix:= st_spixofname( char_name );\r
\r
(*** check that spix is in the range of charspix's ***)\r
if (spix >= first_charspix) and (spix <= first_charspix + 33) then\r
val:= spix - first_charspix else\r
begin\r
errormsg( pass1, 114 );\r
val:= 127;\r
end;\r
if val = 33 then val := 127;\r
end\r
\r
else (*otherwise*) (* 406 *) ;\r
\r
end; (* case *)\r
\r
if prod < 405 then\r
(*** 402, 404 ***)\r
(*** unsigned integer ***)\r
begin\r
\r
emit(cliteral, nill, false, 0, false, 0, cnocode);\r
emit(codekind, lgth, false,0,false,0,cnocode );\r
if prod = 404 then (* emit( '#' ) *)\r
emit(cnocode, nill, true, ord('#'), false, 0, 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 = 404) and ((ord_char >= ord('A')) and (ord_char <= ord('Z'))) then\r
ord_char := ord_char + ord('a') - ord('A'); (* convert to lower case *)\r
emit(cnocode, nill, true, ord_char, false, 0, cnocode);\r
end;\r
\r
end (* prod < 405 *) else\r
with ext_string do\r
begin\r
if length + lgth > rtpstringmax then\r
begin\r
if not alarm then\r
warning( pass1, 131 );\r
lgth:= rtpstringmax - length;\r
alarm:= true;\r
end;\r
strlgth:= attstack[oldtop-1].chbufp + lgth -1;\r
if prod < 407 then\r
begin\r
(*** string ***)\r
for stepvar := attstack[oldtop-1].chbufp to strlgth do\r
begin\r
length:= length + 1;\r
name[ length ]:= chr( ord( chbuf[ stepvar ] ) mod 128);\r
end;\r
end else\r
begin (** name **)\r
length:= length + lgth;\r
name[ length ]:= chr(val mod 128);\r
end; (* name *)\r
end; (* with *)\r
end; (** prod > 401 **)\r
end; (* literals *)\r
\r
\r
procedure constantdeclaration;\r
(* section 5 *)\r
\r
var\r
name : string;\r
symb : st_elemptr;\r
\r
begin\r
case prod of\r
501: (* <constant definition> ::= <constname> = <expression> ; *)\r
(*code: endconstdecl *)\r
emitcode(cendconstdecl);\r
\r
502: (* <constname> ::= name *)\r
(* ST: declaration(constant,name) *)\r
(* code: constdecl(symbol) *)\r
begin\r
readname(name);\r
with attstack [ newtop ] do\r
begin\r
st_declaration(cconstant,name,virt_addr,symb);\r
outcode(cconstdecl, virt_addr);\r
end;\r
end; (* 502 *)\r
\r
503: (* <constant definition> ::= <constname> error *)\r
(* code: id(anonymous) endexpression endconstdecl *)\r
begin\r
emit(cid, nill, true, anonymousspix, false, 0, cendconstdecl);\r
(* ????????????????????????????? *)\r
end;\r
\r
end; (* case *)\r
\r
end; (* constant declaration *)\r
\r
procedure typedefinition;\r
(* section 6 *)\r
\r
var\r
codeword : codes;\r
name : string;\r
ptr: st_elemptr;\r
stepvar,\r
namespix : word;\r
\r
begin\r
\r
\r
if (prod >= 601) and (prod < 620) then\r
begin\r
case prod of\r
601: (* <single type declaration> ::= <type name> <formal type parameters> <eq>\r
<def type spec> ; *)\r
(* ST: endtypedecl endlevel *)\r
(* code: endtypedecl, endlevel *)\r
begin\r
if typespecs <> [] then\r
with attstack[ newtop ] do\r
begin\r
st_get( virt_addr, p1st_currptr );\r
if p1st_currptr^.st_kind = ctype then\r
p1st_currptr^.spec_struct:= typespecs;\r
end;\r
typespecs:= [];\r
(* st_endtypedecl; *)\r
if scalar_decl then scalar_decl:= false else st_endlevel1;\r
codeword := cendlevel;\r
emitcode(cendtypedecl);\r
first_colon:=true;\r
end;\r
\r
602: (* <eq> ::= = *)\r
(* no code *)\r
codeword := cnocode;\r
\r
603: (* <def type spec> ::= <variable> *)\r
(* code: endtype *)\r
begin\r
with attstack[ newtop ] do\r
begin\r
if (var_state > 2) and (var_state<>5) then errormsg( pass1, 118 );\r
end;\r
with typebuffer[ attstack[ newtop - 1 ].bufferstart] do\r
begin\r
em_out:= em_is_code;\r
if in_family then em_code:= ord(cfamilytype) else em_code:= ord(ctypeid);\r
in_family:=false;\r
end;\r
(* i.e. change the former generated id to typeid1 *)\r
codeword := cendtype;\r
type_kind := false; (* hha bliver ikke sat ved alis og familie bindinger*)\r
end;\r
\r
604: (* <type definition> ::= <structured type> *)\r
(* no code *)\r
codeword := cnocode;\r
\r
605: (* <type definition> ::= <uparrow> <common type spec> *)\r
(* code: endpointer *)\r
begin\r
codeword := cendpointer;\r
typespecs := [];\r
(* hha\r
if typespecs = [mailboxtype] then typespecs:= [mailboxpointer]\r
else\r
begin\r
(* JABA 850424 !!!!!!!!!!!!!!!!!!!!!!!!!!!\r
if mailboxpointer in typespecs then\r
temp_specs:= [mailboxpointer] else temp_specs:= [];\r
if referencetype in typespecs then\r
temp_specs:= [referencetype] + temp_specs;\r
typespecs:= typespecs + [pointertype] - temp_specs;\r
!!!!!!!!!!!!!!!!! end JABA 850424 *)\r
(* hha\r
if programtype in typespecs then typespecs := [pointertype, programtype]\r
else typespecs:= [pointertype];\r
end;\r
*)\r
end;\r
\r
606: (* <single type declaration> ::= <type name> ; *)\r
(* ST: forwardtype *)\r
begin\r
codeword:= cforward;\r
with p1st_currptr^ do\r
begin\r
st_specs := st_forward;\r
st_size := pointersize;\r
spec_struct:= [pointertype];\r
end;\r
first_colon:=true;\r
end;\r
\r
607: (* <type definition> ::= <start scalar> <identifier list> ) *)\r
(* ST: endscalar *)\r
begin\r
st_gettype(scalar_addr, p1st_currptr);\r
p1st_currptr^.scalar_no:= st_endscalar;\r
codeword := cnocode;\r
end;\r
\r
608: (* <type definition> ::= <expression> <end subrange> *)\r
(* code: endsubrange *)\r
begin\r
in_family := false;\r
codeword := cendsubrange;\r
with attstack[newtop-1] do\r
begin\r
st_newtype(csubrange,p1st_curraddr,p1st_currptr);\r
typebuffer[ bufferstart - 1 ].em_out:= em_is_param;\r
typebuffer[ bufferstart - 1 ].em_code:= p1st_curraddr.va_high;\r
typebuffer[ bufferstart - 2 ].em_out:= em_is_param;\r
typebuffer[ bufferstart - 2 ].em_code:= p1st_curraddr.va_low;\r
typebuffer[ bufferstart - 3 ].em_out:= em_is_code;\r
typebuffer[ bufferstart - 3 ].em_code:= ord( csubrangetype );\r
end;\r
end;\r
\r
609: (* end defined type *)\r
begin\r
codeword:= cnocode;\r
namespix:= attstack[ newtop ].save_typespix;\r
(* code: typeid1(spix) endtype1 *)\r
emit(ctypeid, nill, true,namespix,false, 0,cendtype);\r
end;\r
\r
\r
610: (* <record type> ::= <record> <field list> end *)\r
(* ST: endrecord *)\r
(* code: endrecord *)\r
begin\r
st_endrecord;\r
codeword := cendrecord;\r
end;\r
\r
611: (* <record section> ::= <start section> <identifier list> <type colon> <common type spec> *)\r
(* ST: endfieldlist *)\r
(* code: endfieldlist *)\r
begin\r
st_endfieldlist;\r
codeword := cendfieldlist;\r
end;\r
\r
612: (* <set type> ::= <set of> <common type spec> *)\r
(* ST: endset *)\r
(* code: endset *)\r
begin\r
(* st_endset; *)\r
codeword := cendset;\r
type_end;\r
end;\r
\r
\r
614,618: (* <st_packed> ::= packed/packed3502 *)\r
(* ST: packed *)\r
begin\r
if not make_packed then\r
(* defauld is not make_packed, and we want make_packed *)\r
begin\r
typespecs:= typespecs + [xpackedtype];\r
IF (prod = 618) or (computer = RC3502) THEN\r
pack_info := packed3502\r
else\r
pack_info:= ispacked;\r
end;\r
codeword := cnocode;\r
end;\r
\r
615: (* <array type> ::= <array start> <common type spec> <component type> *)\r
(* code: endarray *)\r
begin\r
for stepvar := 1 to attstack [ newtop ] . comma_counter do\r
emitcode(cendarray);\r
codeword := cendarray;\r
end;\r
\r
616: (* <external program> ::= external program *)\r
(* code: progdecl *)\r
begin\r
codeword := cnocode;\r
st_newtype(cprogram, p1st_praddr, p1st_currptr);\r
p1st_currptr^.st_seg_nr:=last_segment;\r
outcode(cprogdecl, p1st_praddr);\r
p1st_currptr^.st_spix:=anonymousspix;\r
p1st_currptr^.st_seg_nr:=last_segment;\r
st_get(p1st_praddr, p1st_currptr); \r
if p1st_currptr^.st_kind=ctype then\r
begin\r
p1st_curraddr:=p1st_currptr^.typeref;\r
p1st_currptr^.spec_struct:=[programtype];\r
end else p1st_curraddr := p1st_praddr;\r
link_param:= true;\r
attstack[newtop].virt_addr:= p1st_curraddr;\r
if not first_colon then begin\r
(* TOG by st_newtype st_get(first_typeaddr, p1st_currptr);\r
p1st_currptr^.typeref:= p1st_praddr;\r
*)\r
pr_first_typeaddr:= first_typeaddr;\r
first_colon:= true;\r
end else pr_first_typeaddr:= p1st_praddr;\r
program_type:= true;\r
end;\r
\r
617: (* <type definition> ::= <external program> <formal parameters> *)\r
(* code: endprogdecl *)\r
(* external *)\r
(* endlevel *)\r
begin\r
emitcode(cendprogdecl);\r
st_gettype(p1st_praddr, ptr);\r
ptr^.st_specs:= st_extern;\r
emitcode(cexternal);\r
codeword:= cendlevel;\r
st_endlevel1;\r
typespecs:= typespecs + [ programtype ];\r
first_colon:=false;\r
first_typeaddr:= pr_first_typeaddr;\r
program_type:=false;\r
type_end;\r
end;\r
\r
end; (* case 601..619 *)\r
\r
if (prod=605) or (prod=610) or (prod=615) then\r
with attstack[ newtop ] do\r
begin\r
if typespecs <> [] then\r
begin\r
if xtestpass1 then outstruc;\r
st_get( virt_addr, p1st_currptr );\r
if p1st_currptr^.st_kind = ctype then\r
p1st_currptr^.spec_struct:= typespecs;\r
end;\r
typespecs:= typespecs + protect_type;\r
if xtestpass1 then outstruc;\r
end;\r
\r
if (prod >= 603) and (prod < 610) then type_end;\r
\r
emitcode(codeword);\r
\r
\r
\r
end; (* if .... *)\r
\r
if (prod >= 620) and (prod < 630) then\r
begin\r
\r
temp_specs:= typespecs;\r
case prod of\r
\r
620: (* <uparrow> ::= ^ *)\r
(* ST: newtype pointertype *)\r
(* code: pointertype *)\r
begin\r
temp_specs:= [];\r
codeword := cpointertype;\r
end;\r
\r
621,622: (* <startscalar> ::= ( name , *)\r
(* ! ? , *)\r
(* ST: newtype scalar *)\r
(* startlist( scalarelem ) and *)\r
(* declarelist( name ) is generated after the case statement *)\r
(* not emitted as code !! *)\r
codeword := cscalartype;\r
\r
623: (* <array> ::= array ( *)\r
(* <new dimension> ::= , *)\r
(* ST: newtype arraytype *)\r
(* code: arraytype *)\r
begin\r
if newtop <> oldtop then \r
(* <array start> ::= ... *)\r
begin\r
array_ix:= 0;\r
temp_specs:= [];\r
attstack [ newtop ] . comma_counter := 0\r
end else\r
begin (* new dimension *)\r
array_ix:= array_ix + 2;\r
with attstack [ newtop - array_ix (* ARRAY *) ] do\r
comma_counter := comma_counter + 1;\r
end;\r
codeword := carraytype;\r
end;\r
\r
624: (* <record> ::= record *)\r
(* ST: newtype recordtype *)\r
(* code: recordtype *)\r
begin\r
temp_specs:= [];\r
codeword := crecordtype;\r
end;\r
\r
625: (* <set of> ::= set <of type> *)\r
(* ST: newtype settype *)\r
(* code: settype *)\r
begin\r
codeword := csettype;\r
make_set:= true;\r
end;\r
\r
\r
end; (* case .. *)\r
\r
\r
with attstack [ newtop ] do\r
begin\r
if (* not scalar list start *) (prod <> 621) and (prod <>622) then\r
begin\r
protect_type:= typespecs;\r
typespecs:= temp_specs;\r
st_newtype(codeword,virt_addr,p1st_currptr);\r
if (pack_info <> notpacked) then p1st_currptr^.st_packed:= pack_info;\r
pack_info:= notpacked;\r
end else\r
begin\r
if not type_colon then\r
begin\r
st_endlevel1;\r
scalar_decl:= true;\r
end;\r
st_newtype(cscalar,virt_addr,p1st_currptr);\r
(** is 'p1st_curraddr' ok??? **)\r
p1st_curraddr:= virt_addr;\r
scalar_addr:= p1st_curraddr;\r
st_startlist( cscalarelem, p1st_curraddr );\r
if prod=621 then\r
begin\r
oldtop := oldtop - 1 ; (* let oldtop denote name *)\r
readname(name);\r
oldtop := oldtop + 1; (* reset oldtop *)\r
end else name:=anonymousname;\r
st_declarelist(name);\r
end; (* start scalar *)\r
if first_colon then\r
begin\r
first_colon:= false;\r
first_typeaddr:= virt_addr;\r
end;\r
outcode( codeword, virt_addr );\r
end; (* with *)\r
\r
end; (* 620..629 *)\r
\r
if (prod >= 630) and (prod <= 640) then\r
case prod of\r
\r
\r
632: (* <start section> ::= empty *)\r
(* ST: startlist recfield *)\r
(* code: recfield(symbol) *)\r
with attstack[newtop] do\r
begin\r
st_start_reclist( virt_addr );\r
outcode(crecfield, virt_addr);\r
end;\r
\r
640: (* type colon *)\r
type_colon:= true;\r
\r
end; (* case 630..640 *)\r
\r
\r
if prod = 600 then\r
begin\r
(* <type name> ::= name *)\r
(* ST: declaration( type name ) *)\r
(* code: typedecl(symbol) *)\r
link_param:= true;\r
type_decl:= true;\r
readname(name);\r
with attstack [ newtop ] do\r
begin\r
st_declaration(ctype,name,virt_addr,p1st_currptr);\r
(* TOG !!! *)\r
first_typeaddr:= virt_addr;\r
first_colon:=false;\r
(* only family, remove when from here when ctype-node not contain family *)\r
p1st_currptr^.st_t_seg_nr:=last_segment;\r
p1st_curraddr:= virt_addr;\r
if p1st_currptr^.st_listend (*** forward exist ***) then\r
begin\r
p1st_currptr^.st_listend:= false;\r
outcode(ctypedecl, p1st_currptr^.listref ); (* forward node *)\r
p1st_currptr^.listref:= st_stopaddr;\r
outcode(cforwardtype, p1st_curraddr );\r
end else\r
outcode(ctypedecl, p1st_curraddr);\r
end;\r
typespecs:= [];\r
save_mode:= no_specs;\r
\r
end; (* 600 *)\r
\r
(* if before <type> then *)\r
if (prod=602) or (prod=616) or (prod=620) or (prod=623) or\r
(prod=624) or (prod=625) or (prod=640) then\r
begin\r
if lastbuffered + 4 > typebuffersize then \r
fatal_error( pass1,212);\r
\r
\r
typebufferflag := true;\r
\r
for stepvar:= 1 to 3 do\r
typebuffer[lastbuffered+stepvar].em_out:= em_none; (* reserve room for a possible newtype .. *)\r
lastbuffered := lastbuffered + 3;\r
attstack[ newtop ] . bufferstart := lastbuffered + 1;\r
end;\r
\r
\r
if ((prod >= 650) and (prod <= 662)) or (prod = 665) then\r
begin\r
\r
case prod of\r
665: (* <formal typespec> ::= name *)\r
begin\r
readname(name);\r
namespix := st_spixofname(name);\r
end\r
else (*otherwise*)\r
begin\r
namespix:= stdspix_to_symbol_table[ prod - first_stdprod+1 ].spix;\r
if (prod > 655) and (prod <= 661) then\r
begin\r
case prod-655 of\r
1: temp_specs:= [mailboxtype];\r
2: temp_specs:= [referencetype];\r
3: temp_specs:= [pooltype];\r
4: temp_specs:= [processtype];\r
5: temp_specs:= [porttype];\r
6: temp_specs:= [chaintype];\r
end;\r
typespecs:= typespecs + temp_specs;\r
end;\r
end;\r
end (*case*);\r
attstack[ newtop ].save_typespix:= namespix;\r
\r
end; (* prod >= 650 ...*)\r
\r
end; (* section 6 *)\r
\r
procedure variabledefinition;\r
(* section 7 *)\r
\r
var\r
name : string;\r
(**symb_ptr : symbol_table_start_list;**)\r
\r
begin\r
case prod of\r
\r
700: (* <start var> ::= empty *)\r
(* ST: startlist var or shared *)\r
(* code: vardecl(symbol) or shareddecl(symbol) *)\r
begin\r
typespecs:= [];\r
p1st_curraddr:= st_nilladdr;\r
st_startlist(var_or_shared, p1st_curraddr);\r
if var_or_shared = cvar then\r
outcode(cvardecl, p1st_curraddr)\r
else\r
outcode(cshareddecl, p1st_curraddr);\r
end;\r
\r
701: (* <ident> ::= name *)\r
(* ST: declarelist( spix ) *)\r
begin\r
readname(name);\r
st_declarelist( name );\r
attstack[newtop].var_state:= 1;\r
end;\r
\r
704: (* ! ? *)\r
begin\r
name := anonymousname;\r
st_declarelist(name);\r
end;\r
\r
702: (* <initialization> ::= <assign> <expression> *)\r
(* code: endinit *)\r
begin\r
emitcode(cendinit);\r
typespecs:= [];\r
end;\r
\r
705: (* <initialization> ::= empty *)\r
(* code: endvar or endshared (symbol) *)\r
begin\r
if var_or_shared = cvar then\r
emitcode(cendvar)\r
else\r
emitcode(cendshared);\r
typespecs:= [];\r
end;\r
\r
706: (* <var> ::= var *)\r
var_or_shared := cvar;\r
\r
707: (* <shared> ::= shared *)\r
var_or_shared := cshared;\r
\r
708: (* <assign> ::= := *)\r
(* code: init(symbol) *)\r
outcode(cinit, p1st_curraddr);\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
outspix : boolean;\r
var_or_field_spix : spixrange;\r
name : string;\r
helpint : integer;\r
\r
begin\r
codeword2 := cnocode;\r
outspix:= false;\r
var_or_field_spix := 0;\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 := cadd;\r
\r
811: (* <simple expression> ::= <simple expression> - <term> *)\r
(* code: minus *)\r
codeword1 := csub;\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 := cnocode;\r
\r
814: (* <simple expression> ::= - <term> *)\r
(* code: uminus *)\r
codeword1 := cusub;\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 := cmul;\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: shift *)\r
codeword1 := cshift;\r
\r
824: (* <startset><elementlist> .) *)\r
begin\r
codeword1 := cnocode;\r
st_newtype(csettype, p1st_curraddr, p1st_currptr);\r
st_get(p1st_hlpaddr, p1st_currptr);\r
(* i.e. access startset-node -- address is kept in "p1st_hlpaddr" *)\r
p1st_currptr^.typeref := p1st_curraddr;\r
end; (* 824 *)\r
\r
825: (* <value denotation> ::= <set denotation> *)\r
(* code: endsetlist *)\r
codeword1 := cendsetlist;\r
\r
826: (* <start set> ::= (. *)\r
(* code: setlist *)\r
begin\r
codeword1 := cnocode;\r
st_declaration(cstrucconst, anonymousname, p1st_hlpaddr, p1st_currptr);\r
p1st_currptr^.typeref := st_emptyset_addr;\r
outcode(csetlist, p1st_hlpaddr);\r
make_set:=true;\r
end; (* 826 *)\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
832: (* getswitch( name) *)\r
begin\r
\r
{$IFDEF rtp86}\r
(* typesize(defined type ) *)\r
codeword1:= ctypesizecall;\r
var_or_field_spix:= attstack[ oldtop - 1 ].save_typespix;\r
outspix:= true;\r
{$ELSE}\r
oldtop:= oldtop - 1;\r
readname( name );\r
oldtop:= oldtop + 1;\r
IF not search_switch(name,helpint) THEN ErrorMsg(pass1,129)\r
ELSE\r
BEGIN\r
str(helpint,name);\r
\r
(* Dump the unsign integer *)\r
emit(cliteral, nill, false, 0, false, 0, cnocode);\r
emit(cInteger, length(name), false,0,false,0,cnocode );\r
for helpint := 1 To length(name) DO\r
emit(cnocode, nill, true, ord(name[helpint]), false, 0, cnocode);\r
END;\r
codeword1 := cnocode;\r
{$ENDIF}\r
end;\r
\r
833, (* varsize *)\r
834: (* typesize *)\r
begin\r
if prod=833 then codeword1:= cvarsizecall else codeword1:= ctypesizecall;\r
oldtop:= oldtop - 1;\r
readname( name );\r
oldtop:= oldtop + 1;\r
outspix:= true;\r
var_or_field_spix:= st_spixofname( name );\r
end;\r
\r
835: (* <variable> ::= name *)\r
(* code: id( spix ) may later on be changed to typeid(spix) *)\r
begin\r
if region_stat then\r
begin\r
codeword1:= cnocode;\r
region_stat:= false\r
end else codeword1 := cid;\r
readname(name);\r
outspix:= true;\r
var_or_field_spix := st_spixofname(name);\r
attstack[newtop].var_state:= 1;\r
end;\r
\r
836: (* <variable> ::= <variable> . name *)\r
(* code: field( spix ) *)\r
begin\r
codeword1 := cfield;\r
readname(name);\r
outspix:= true;\r
var_or_field_spix := st_spixofname(name);\r
if attstack[ newtop ].var_state = 4 then\r
begin\r
attstack[ newtop ].var_state:= 5;\r
errormsg(pass1,117)\r
end else\r
attstack[ newtop ].var_state:= 3;\r
end;\r
\r
\r
\r
837: (* <variable> ::= <variable> <begin actual> <actual parameter list> ) *)\r
(* code: endactual *)\r
begin\r
if typebufferflag then in_family:= true;\r
codeword1 := cendactual;\r
with attstack[ newtop ] do\r
begin\r
if var_state = 4 then\r
begin\r
var_state:= 5;\r
errormsg(pass1,117)\r
end else\r
if var_state = 1 then var_state:= 2 else var_state:= 3;\r
end;\r
end;\r
\r
838: (* <variable> ::= <variable> ^ *)\r
(* code: uparrow *)\r
begin\r
codeword1 := cuparrow;\r
if attstack[ newtop ].var_state = 4 then\r
begin\r
attstack[ newtop ].var_state:= 5;\r
errormsg(pass1,117)\r
end else\r
attstack[ newtop ].var_state:= 3;\r
end;\r
\r
839: (* <begin actual> ::= ( *)\r
(* code: beginactual *)\r
codeword1 := cbeginactual;\r
\r
840: (* <paramname> ::= name *)\r
(* code: typeselect *)\r
begin\r
codeword1 := ctypeselect;\r
readname(name);\r
outspix:= true;\r
var_or_field_spix := st_spixofname(name);\r
end;\r
\r
\r
841: (* <start struc val> ::= (: *)\r
(* code: beginstruc1 *)\r
codeword1 := cbeginstruc;\r
\r
\r
842: (* <struc value denotation> ::= <start struc val> <struc value list> :) *)\r
(* code: endstruc *)\r
codeword1 := cendstruc;\r
\r
\r
843: (* <struc value> ::= <unit> *)\r
(* code: strucelem *)\r
codeword1 := cstrucelem;\r
\r
844: (* <struc value> ::= <expression> *** <unit> *)\r
(* code: repstruc *)\r
codeword1 := crepstruc;\r
\r
846 : (* struct end *)\r
begin\r
codeword1 := cnocode;\r
if attstack[ newtop ].var_state > 2 then\r
begin\r
attstack[ newtop ].var_state:= 5;\r
errormsg(pass1,121)\r
end else\r
attstack [ newtop ].var_state:= 4;\r
end;\r
\r
847 : (* end typeselect *)\r
begin\r
codeword1 := cnocode;\r
if attstack[ newtop ].var_state = 4 then\r
begin\r
attstack[ newtop ].var_state:= 5;\r
errormsg(pass1,117)\r
end else\r
attstack[ newtop ].var_state:= 3;\r
end;\r
\r
end; (* case ... *)\r
\r
\r
emit( codeword1, nill, outspix, var_or_field_spix, false, 0, codeword2);\r
\r
end; (* section 8 *)\r
\r
procedure statement;\r
(* section 9 *)\r
\r
var\r
step: integer; (**$BBP$**)\r
codeword, codeword2 : codes;\r
b : boolean;\r
param1 : spixrange;\r
param2 : integer;\r
name : string;\r
\r
\r
begin\r
codeword2 := cnocode;\r
b:= false;\r
param1:= 0;\r
param2 := nill;\r
\r
case prod of\r
\r
900: (* finis statement *)\r
codeword := cnocode;\r
\r
901: (* <compound statement> ::= <begin> <statement list> end *)\r
(* code: end *)\r
codeword := cnocode;\r
\r
902: (* <begin> ::= begin *)\r
(* code: begin *)\r
codeword := cnocode;\r
\r
903: (* <procedure call> ::= <variable> *)\r
(* code: endproccall *)\r
begin\r
codeword := cendproccall;\r
if (attstack[ newtop ].var_state <> 5) and (attstack[ newtop ].var_state > 2)\r
then errormsg(pass1,120);\r
end;\r
\r
904: (* <actual parameter list> ::= <unit> *)\r
(* ! <actual parameter list> , <unit> *)\r
(* code: actualparam *)\r
begin\r
codeword := cactualparam;\r
end;\r
\r
905: (* <unit> ::= ? *)\r
(* code: null *)\r
codeword := cnull;\r
\r
906: (* <assignment statement> ::= <variable> := <expression> *)\r
(* code: endassign *)\r
begin\r
codeword := cendassign;\r
if attstack[ newtop ].var_state = 4 then errormsg(pass1,119);\r
end;\r
\r
907: (* <exchange statement> ::= <variable> :=: <variable> *)\r
(* code: endexchange *)\r
begin\r
codeword := cendexchange;\r
if (attstack[ newtop ].var_state = 4) or\r
(attstack[ oldtop ].var_state = 4) then errormsg( pass1, 119 );\r
end;\r
\r
\r
\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
(* <balanced statement> ::= <for do> <start labelscope> <balanced statement> <end labelscope> *)\r
(* ST: endlevel *)\r
(* code: endlevel endfor1 *)\r
begin\r
codeword := cendlevel;\r
codeword2 := cendfor;\r
st_endlevel1;\r
end;\r
\r
918: (* <for do> ::= <for to> <expression> do *)\r
(* code: endsubrange beginlevel up(symbol) *)\r
begin\r
emit(cendsubrange, nill, false,0, false,0, cbeginlevel);\r
outcode(cup,p1st_varaddr);\r
codeword := cnocode;\r
end;\r
\r
919: (* ! <for downto> <expression> do *)\r
(* code: endsubrange beginlevel down(symbol) *)\r
begin\r
emit(cendsubrange, nill, false,0, false,0, cbeginlevel );\r
outcode(cdown, p1st_varaddr);\r
codeword := cnocode;\r
end;\r
\r
920: (* <for assign> ::= for name := *)\r
(* ST: beginlevel declaration newtype subrange *)\r
(* code: forstat forvar(symbol) subrangetype(symbol) *)\r
begin\r
st_beginlevel1;\r
(* juster oldtop !!!!!!!!??????????????????? *)\r
oldtop:= oldtop - 1;\r
readname(name);\r
oldtop:= oldtop + 1;\r
st_declaration(cforstat,name,p1st_varaddr,p1st_currptr);\r
codeword:= cnocode;\r
outcode(cforstat,p1st_varaddr);\r
st_newtype(csubrange,p1st_curraddr,p1st_currptr);\r
outcode(csubrangetype, p1st_curraddr);\r
end;\r
\r
921: (* <for> ::= for *)\r
(* code: forstat *)\r
codeword := cforstat;\r
\r
922: (* <goto statement> ::= <goto> <lab name> *)\r
(* code: endgoto *)\r
codeword := cnocode;\r
\r
923: (* <goto> ::= goto *)\r
(* code: goto *)\r
codeword := cgoto;\r
\r
924: (* <lab name> ::= name *)\r
(* code: ( spix ) *)\r
begin\r
readname(name);\r
b:= true;\r
param1 := st_spixofname(name);\r
codeword := cnocode;\r
end;\r
\r
925: (* <statement> ::= <if then> <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
end;\r
\r
930: (* <repeat statement> ::= <repeat until> <expression> *)\r
(* code: endrepeat *)\r
codeword := cendrepeat;\r
\r
931: (* <repeat until> ::= <repeat> <statement list> until *)\r
(* code: endlabelscope( scopenr ) *)\r
begin\r
codeword := cchangelabelscope;\r
param2 := currentlabelscope;\r
currentlabelscope := attstack[newtop].oldlabelscope;\r
end;\r
\r
932: (* <repeat> ::= repeat *)\r
(* code: repeatstat *)\r
codeword := crepeatstat;\r
\r
933: (* <statement> ::= <while do> <start labelscope> <statement> <end labelscope> *)\r
(* <balanced statement> ::= <while do> <start labelscope> <balanced statement> <end labelscope> *)\r
(* code: endwhile *)\r
codeword := cendwhile;\r
\r
934: (* <while do> ::= <while> <expression> do *)\r
(* code: whileexpr *)\r
codeword := cwhileexpr;\r
\r
935: (* <while> ::= while *)\r
(* code: whilestat *)\r
codeword := cwhilestat;\r
\r
936: (* <statement> ::= <with do> <start labelscope> <statement> <end labelscope> *)\r
(* <balanced statement> ::= <with do> <start labelscope> <balanced statement> <end labelscope> *)\r
(* ST: endlevel *)\r
(* code: endwith endlevel *)\r
begin\r
for step := 0 to attstack [ newtop (* WITH *) ] . comma_counter mod 100 do\r
begin\r
emitcode(cendwith);\r
emitcode(cendlevel);\r
st_endlevel1;\r
end;\r
codeword := cnocode;\r
end;\r
\r
937: (* <with> ::= with *)\r
(* ST: beginlevel *)\r
(* code: withstat beginlevel *)\r
begin\r
renaming := false;\r
attstack [ newtop ] . comma_counter := 0;\r
codeword := cwithstat;\r
codeword2 := cbeginlevel;\r
st_beginlevel1;\r
end;\r
\r
938: (* <with comma> ::= , *)\r
(* ST: beginlevel *)\r
(* code: withcomma beginlevel *)\r
begin\r
with attstack [ newtop - 2 (* WITH *) ] do\r
if comma_counter < 100 then comma_counter := comma_counter + 1\r
else errormsg( pass1, 111 ); (* list not allowed *)\r
codeword := cwithstat;\r
codeword2 := cbeginlevel;\r
st_beginlevel1;\r
end;\r
\r
939, (* <with variable> ::= <variable> *)\r
940: (* <as> ::= as *)\r
(* ST: declaration(withvar, '?') *)\r
(* code: withvar(symbol) if 939 then nolocaldeclare *)\r
begin\r
codeword:= cnocode;\r
st_declaration(cwithvar,anonymousname,p1st_curraddr,p1st_currptr);\r
outcode(cwithvar, p1st_curraddr);\r
if prod=939 then\r
begin\r
codeword := cnolocaldecl;\r
if attstack[ newtop ].var_state = 4 then errormsg( pass1, 116 );\r
end else\r
with attstack[ newtop - 2 ] do\r
begin\r
if comma_counter = 0 then comma_counter:= 100 else\r
errormsg( pass1, 112 ); (* as not allowed *)\r
end;\r
end;\r
\r
941: (* <local name> ::= name *)\r
(* ST: rename(name) *)\r
begin\r
renaming := true;\r
readname(name);\r
st_rename(name);\r
codeword := cnocode;\r
\r
end; (* 941 *)\r
\r
942: (* <with variable> ::= <variable> <as> <local name> <type colon> <common type spec> *)\r
(* code: endlocaldecl *)\r
begin\r
codeword := cendlocaldecl;\r
if attstack[ newtop ].var_state = 4 then errormsg( pass1, 116 );\r
end;\r
\r
943: (* <with variable> ::= <variable> <as> <local name> *)\r
(* code: nolocaltype *)\r
begin\r
codeword := cnolocaldecl;\r
if attstack[ newtop ].var_state = 4 then errormsg( pass1, 116 );\r
end;\r
\r
944: (* <with do> ::= <with> <with variable list> do *)\r
(* code: do *)\r
begin\r
codeword := cdo;\r
if renaming and (attstack [ newtop ] . comma_counter mod 100 <> 0) then\r
errormsg( pass1, 113 );\r
(* short hand and renaming in same with clause not allowed *)\r
end;\r
\r
\r
945, (* <lock> ::= lock *)\r
946: (* ! lockbuf *)\r
(* ST: beginlevel *)\r
(* code: lockstat/lockbufstat beginlevel *)\r
begin\r
if prod = 945 then\r
codeword := clockstat\r
else\r
codeword := clockbufstat;\r
codeword2 := cbeginlevel;\r
st_beginlevel1;\r
end;\r
\r
947: (* <lock do> ::= <lock> <variable> <to> <ident> do *)\r
(* code: do *)\r
begin\r
(* !!!!!!!!!! TOG !!!!!!!!, to be changed when new gram *)\r
codeword := cdo;\r
(* !!!!!!!!!! TOG !!!!!!!!, to be changed when old gram *)\r
{$IFDEF RTP86}\r
codeword := cnolocaldecl;\r
codeword2 := cdo;\r
{$ENDIF}\r
(* !!!!!!!!!!! END TOG !!!!!!!!!!!!!!!!!!!!!!!!!*)\r
if attstack[ newtop + 1 ].var_state = 4 then errormsg( pass1, 116 );\r
end;\r
\r
948: (* <to> ::= to *)\r
(* ST: startlist(lockvar) *)\r
(* code: lockvar(symbol) endlockdecl *)\r
begin\r
p1st_curraddr:= st_nilladdr;\r
st_startlist(clockvar, p1st_curraddr);\r
outcode(clockvar, p1st_curraddr);\r
codeword := cnocode;\r
end;\r
\r
949: (* <statement> ::= <lock do> <start labelscope> <statement> <end labelscope> *)\r
(* <balanced statement> ::= <lock do> <start labelscope> <balanced statement> <end labelscope> *)\r
(* ST: endlevel *)\r
(* code: endlock endlevel *)\r
begin\r
codeword := cendlock;\r
codeword2 := cendlevel;\r
st_endlevel1;\r
end;\r
\r
950: (* <statement> ::= exitloop *)\r
(* <balanced statement> ::= exitloop *)\r
(* code: exitloop *)\r
codeword := cexitloop;\r
\r
951: (* <statement> ::= continueloop *)\r
(* <balanced statement> ::= continueloop *)\r
(* code: contloop *)\r
codeword := ccontloop;\r
\r
952: (* <statement> ::= exit *)\r
(* <balanced statement> ::= exit *)\r
(* code: exitstat *)\r
codeword := cexitstat;\r
\r
953: (* <statement> ::= <region do> <start labelscope> <statement>\r
* <end labelscope> *)\r
(* <balanced statement> ::= <region do> <start labelscope>\r
* <balanced statement> <end labelscope> *)\r
(* code: endregion *)\r
codeword := cendregion;\r
\r
954: (* <region> ::= region *)\r
(* code: regionstat *)\r
begin\r
region_stat:= true;\r
codeword := cregionstat;\r
end;\r
\r
955: (* <region do> ::= <region> <variable> do *)\r
(* code: nocode *)\r
begin\r
codeword := cnocode;\r
if attstack[ newtop + 1 ].var_state = 4 then errormsg( pass1, 116 );\r
end;\r
\r
956: (* <loop> ::= loop *)\r
(* code: loopstat *)\r
codeword := cloopstat;\r
\r
957: (* <loop statement> ::= <loop> <start labelscope>\r
* <statement list> <end labelscope> endloop *)\r
(* code: endloop *)\r
codeword := cendloop;\r
\r
958: (* <if then else> <statement> *)\r
codeword:= cendelse;\r
\r
960: (* <compound statement> ::= <begin> <statement list> end *)\r
(* code: end *)\r
codeword := cnocode;\r
\r
961: (* <compound statement> ::= <begin> <statement list> end *)\r
(* code: end *)\r
codeword := cnocode;\r
\r
\r
\r
end; (* case .... *)\r
\r
(* now the parameters for the emit call has been set up *)\r
emit( codeword, param2, b, param1, false, 0, codeword2);\r
\r
end; (* section 9 *)\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 : string;\r
ptr : st_elemptr;\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
readname(alias_name);\r
\r
\r
1002: (* <routine heading> ::= <procedure heading> *)\r
(* code: endprocdecl *)\r
begin\r
emitcode(cendprocdecl);\r
save_mode:= st_local;\r
end;\r
\r
\r
1003, (* <procedure name> ::= name *)\r
1004: (* ! <spixname> = name *)\r
(* ST: declaration(procedure) *)\r
(* code: procdecl(symbol) *)\r
begin\r
if make_segmentation then dump_segment;\r
accept_segment:=accept_segment+1;\r
if niv_count = 0 then\r
emit( coption, ord(pass4), true, last_code, true, 0, cnocode );\r
if niv_count > -1 then niv_count:= niv_count + 1;\r
link_param:= true;\r
readname(name);\r
with attstack [ newtop - 1 (* PROCEDURE *) ] do\r
begin\r
if prod = 1004 THEN\r
BEGIN\r
st_declaration(cprocedure,alias_name,virt_addr,p1st_currptr);\r
p1st_currptr^.st_size:= st_spixofname(name);\r
END\r
else\r
BEGIN\r
st_declaration(cprocedure,name,virt_addr,p1st_currptr);\r
p1st_currptr^.st_size:=0;\r
END;\r
\r
p1st_currptr^.st_seg_nr:=last_segment;\r
outcode(cprocdecl, virt_addr);\r
p1st_curraddr:= virt_addr;\r
end;\r
p1st_praddr:= attstack[newtop-1].virt_addr;\r
end;\r
\r
(*1004: (* <procedure name> ::= <spix name> = name *)\r
(* ST: declaration(procedure) *)\r
(* code: procdecl(symbol) *)\r
(*begin\r
with attstack [ newtop - 1 (* PROCEDURE *)(** ] do\r
begin\r
(*\r
st_declaration(cprocedure,alias_name,virt_addr,p1st_currptr);\r
p1st_curraddr:= virt_addr;\r
p1st_praddr := virt_addr;\r
*)\r
(*with symb_ptr^ do\r
overloadreadname(name);*) (**$BBP$**)\r
(*outcode(cprocdecl, virt_addr);\r
end;\r
end;*)\r
\r
1006: (* <parameter description> ::= <param kind> <parameter group>\r
<type colon> <formal type spec> *)\r
(* code: endformallist *)\r
emitcode(cendformallist);\r
\r
1007: (* <formal parameters> ::= <init formal> *)\r
(* ! <init formal> ( <formal list> ) *)\r
(* <formal type parameters> ::= <beginlevel>\r
* ! <beginlevel> ( <type formal list> ) *)\r
(* code: endformal *)\r
begin\r
emitcode(cendformal);\r
link_param:= false;\r
type_decl := false;\r
st_endformal;\r
end;\r
\r
1008: (* <parameter group> ::= name *)\r
(* ! <parameter group> , name *)\r
(* ST: declarelist *)\r
begin\r
readname(name);\r
st_declarelist(name);\r
end;\r
\r
1009: (* <prog declarations> ::= <beginlevel> <decls> *)\r
(* <declarations> ::= <begin level> <decls> *)\r
(* code: enddeclarations *)\r
(* action: change input file if context parsing *)\r
begin\r
(*\r
if contextparsing then\r
linenumber := 0;\r
*)\r
emitcode(cenddeclarations);\r
typespecs:= [];\r
end;\r
\r
\r
(*1010 is pt unused! *)\r
1010: (* <firstbegin > ::= empty *)\r
;\r
\r
1012,\r
1011: (* <program block> ::= <program declarations> <start labelscope> <compound statement>\r
<end labelscope> *)\r
(* <routine block> ::= d.o. *)\r
(* ST: endlevel endlevel *)\r
(* code: endblock endlevel endlevel *)\r
begin\r
accept_segment:=accept_segment-1;\r
if niv_count > 0 then niv_count:= niv_count - 1;\r
emitcode(cendblock);\r
st_endlevel1; st_endlevel1;\r
st_restore_proglevel;\r
emit( cendlevel, nill, false, 0, false, 0, cendlevel);\r
(* TOG *) if prod=1012 then emitcode(cendvar);\r
end;\r
\r
1028, (* <block> ::= external / program *)\r
1020, (* <block> ::= external *)\r
1021: (* ! forward *)\r
(* ST: endlevel *)\r
(* code: external/forward endlevel *)\r
begin\r
accept_segment:=accept_segment-1;\r
save_mode:= no_specs;\r
if prod <> 1021 then\r
begin\r
st_gettype( p1st_praddr, ptr );\r
ptr^.st_specs:= st_extern;\r
codeword:= cexternal;\r
end else\r
begin\r
codeword := cforward;\r
st_routine_label( p1st_praddr, st_forward );\r
end;\r
if niv_count > 0 then niv_count:= niv_count - 1;\r
emitcode(codeword);\r
emitcode(cendlevel);\r
(* TOG *) if prod = 1028 then emitcode(cendvar);\r
st_endlevel1;\r
end;\r
\r
1022: (* <init formal> ::= empty *)\r
(* <beginlevel> ::= empty -- tidligere 1010! *)\r
(* ST: beginlevel *)\r
(* code: beginlevel *)\r
begin\r
if save_mode <> no_specs then st_routine_label(p1st_praddr, save_mode );\r
save_mode:= no_specs;\r
if ok then begin\r
st_beginlevel1;\r
emitcode(cbeginlevel);\r
end else\r
(*if call_options.savecode then warning( pass1,134 ) hha *);\r
end;\r
\r
1023, (* <paramkind> ::= empty *)\r
1024, (* ! var *)\r
1025, (* ! inspect *)\r
1026: (* ! shared *)\r
(* ST: startlist(kind) *)\r
(* code: formalparamlist(symbol) *)\r
begin\r
\r
if not link_param then p1st_curraddr:= st_nilladdr;\r
case prod of\r
1023:\r
begin\r
codeword := cvalueparam;\r
if type_decl then\r
begin\r
type_decl:= false;\r
st_routine_label( p1st_curraddr, no_specs);\r
end;\r
end;\r
1024: codeword := cvarparam;\r
1025: codeword := cinspectparam;\r
1026: codeword := csharedparam;\r
end; (* case *)\r
st_startlist(codeword, p1st_curraddr);\r
outcode(cformalparamlist, p1st_curraddr);\r
link_param:= false;\r
end;\r
1027: (* <block>::=openroutine *)\r
(* ST: endlevel *)\r
(* code: openroutine endlevel *)\r
begin\r
accept_segment:=accept_segment-1;\r
save_mode:= no_specs;\r
st_get(p1st_praddr, ptr);\r
ptr^.st_specs:= st_open;\r
emitcode(copenroutine);\r
emitcode(cendlevel);\r
st_endlevel1;\r
end; (*1027*)\r
\r
\r
\r
end; (* case *)\r
\r
end; (* section 10 *)\r
\r
procedure functiondeclaration;\r
(* section 11 *)\r
var\r
name: string;\r
\r
begin\r
\r
case prod of\r
1101: (* <routine heading> ::= <function heading> *)\r
(* code: endfuncdecl *)\r
begin\r
emitcode(cendfuncdecl);\r
save_mode:= st_local;\r
end;\r
\r
\r
1102, (* <function name> ::= name *)\r
1103: (* ! <spixname> = name *)\r
(* ST: declartion(function) *)\r
(* code: funcdecl(symbol) *)\r
begin\r
if make_segmentation then dump_segment;\r
accept_segment:=accept_segment+1;\r
if niv_count = 0 then\r
emit( coption, ord(pass4), true, last_code, true, 0, cnocode );\r
if niv_count > -1 then niv_count:= niv_count + 1;\r
link_param:= true;\r
with attstack [ newtop - 1 (* FUNCTION *) ] do\r
begin\r
readname(name);\r
IF prod = 1103 THEN\r
BEGIN\r
st_declaration(cfunction,alias_name,virt_addr,p1st_currptr);\r
P1st_currptr^.st_size:= st_spixofname(name);\r
END\r
ELSE\r
BEGIN\r
st_declaration(cfunction,name,virt_addr,p1st_currptr);\r
p1st_currptr^.st_size:=0;\r
END;\r
p1st_currptr^.st_seg_nr:=last_segment;\r
outcode(cfuncdecl, virt_addr);\r
p1st_curraddr:= virt_addr;\r
end;\r
p1st_praddr := attstack[newtop-1].virt_addr;\r
end;\r
\r
(*1103: (* <function name> ::= <spix name> = name *)\r
(* ST: declaration(function) *)\r
(* code: funcdecl *)\r
(**begin\r
if niv_count = 0 then\r
emit( coption, ord(pass4), true, last_code, true, 0, cnocode );\r
if niv_count > -1 then niv_count:= niv_count + 1;\r
with attstack [ newtop -1 (* FUNCTION *)(** ] do\r
(*\r
st_declaration(cfunction,alias_name,virt_addr,p1st_currptr);\r
p1st_curraddr:= virt_addr; p1st_praddr:= virt_addr;\r
(*with symb_ptr^ do\r
overloadreadname(name);*) (**$BBP$**)\r
(**emitcode(cfuncdecl);\r
end;**)\r
\r
\r
end; (* case *)\r
\r
end; (* section 11 *)\r
\r
procedure labeldeclaration;\r
(* section 12 *)\r
var\r
name: string;\r
\r
\r
begin\r
case prod of\r
1201: (* <label name> ::= name *)\r
(* ST: declaration(label) labeldeclare *)\r
(* code: labeldef(symbol) *)\r
begin\r
readname(name);\r
st_declaration(clabel,name,p1st_curraddr,p1st_currptr);\r
st_labeldeclare( currentlabelscope ); (* ??????????????? *)\r
outcode(clabeldef, p1st_curraddr);\r
end;\r
\r
1202: (* <start labelscope> ::= empty *)\r
(* code: startlabelscope( scope ) *)\r
begin\r
if make_segmentation then dump_segment;\r
accept_segment:=accept_segment+1;\r
attstack[ newtop ] . oldlabelscope := currentlabelscope;\r
lastlabelscope := lastlabelscope + 1;\r
currentlabelscope := lastlabelscope;\r
emit(cchangelabelscope, currentlabelscope, false, 0, false, 0, cnocode);\r
end;\r
\r
1203: (* <end labelscope> ::= empty *)\r
(* code: endlabelscope( scope ) *)\r
begin\r
accept_segment:=accept_segment-1;\r
currentlabelscope := attstack[ newtop - 2 ] . oldlabelscope;\r
(* i.e. get the scope stored in attstack[ <start labelscope> ] *)\r
emit(cchangelabelscope, currentlabelscope, false, 0, false, 0, cnocode);\r
end;\r
\r
end; (* case *)\r
\r
end; (* section 12 *)\r
\r
procedure programdeclaration;\r
(* section 13, program and prefix declaration *)\r
\r
var\r
name : string;\r
codeword : codes;\r
spix : word;\r
\r
begin\r
\r
case prod of\r
\r
1301: (* <context name> ::= name *)\r
(* ST: declaration(context) *)\r
(* code: context(symbol) *)\r
begin\r
\r
with attstack [ newtop ] do\r
begin\r
readname(name);\r
st_declaration(ccontext,name,virt_addr,p1st_currptr);\r
outcode(ccontext, virt_addr);\r
p1st_curraddr:= virt_addr;\r
end;\r
contextparsing := true;\r
end;\r
\r
\r
1302: (* <body> ::= <empty body> *)\r
begin\r
if not call_options.savecode then errormsg( pass1, 127 );\r
st_lastend;\r
ok := false; (* stop parsing *)\r
end;\r
\r
1303: (* <body> ::= <body list> *)\r
(* code: eom *)\r
begin\r
if call_options.savecode then warning( pass1,134 );\r
st_lastend;\r
emitcode(ceom);\r
ok := false; (* stop parsing *)\r
end;\r
\r
1304: (* <progsems> ::= ; *)\r
(* code: endprogdecl *)\r
begin\r
emitcode(cendprogdecl);\r
save_mode:= st_local;\r
end;\r
\r
1305: (* <program name> ::= name *)\r
(* ST: declaration(program) *)\r
(* code: progdecl(symbol) *)\r
begin\r
if make_segmentation then dump_segment;\r
accept_segment:=accept_segment+1;\r
with attstack [ newtop ] do\r
begin\r
if niv_count = 0 then\r
emit( coption, ord(pass4), true, last_code, true, 0, cnocode );\r
if niv_count > -1 then niv_count:= niv_count + 1;\r
link_param:= true;\r
readname(name);\r
st_declaration(cvar,name,p1st_curraddr, p1st_currptr);\r
spix:=p1st_currptr^.st_spix;\r
outcode(cvardecl, p1st_curraddr);\r
st_newtype(cprogram,p1st_praddr,p1st_currptr);\r
outcode(cprogdecl, p1st_praddr);\r
p1st_currptr^.st_spix:=spix;\r
p1st_currptr^.st_seg_nr:=last_segment;\r
(* TOG ??? p1st_curraddr:= virt_addr; *)\r
st_get(p1st_praddr, p1st_currptr);\r
if p1st_currptr^.st_kind=ctype then\r
begin\r
p1st_currptr^.spec_struct:=[ programtype ];\r
p1st_praddr:=p1st_currptr^.typeref;\r
end;\r
virt_addr := p1st_praddr;\r
(* TOG !!!! *) p1st_curraddr:=p1st_praddr;\r
end;\r
end;\r
\r
1310: (* <external> ::= <context name> ; <routine decl part> . *)\r
(* code: endcontext *)\r
(* action: contextparsing := false *)\r
begin\r
contextparsing := false;\r
emitcode(cendcontext);\r
end;\r
\r
1311: (* <external part> ::= <externals> *)\r
(* code: endinclude *)\r
begin\r
more_sources_allowed := false;\r
if call_options.savecode then\r
begin\r
emitcode(ceos);\r
st_lastend;\r
ok:=false; (* stop parsing *)\r
end else\r
begin\r
niv_count:= 0;\r
emitcode( cendinclude );\r
emit( coption, ord(allpass), true, ord(sourceno_), true, sourcenumber,\r
cnocode);\r
accept_segment:=-1; (* after program or routine then accept *)\r
st_endinclude;\r
end;\r
end;\r
\r
1312: (* <body elem> ::= <begin level> <program declaration> *)\r
(* ! <begin level> <routine declaration > *)\r
(* ST: endlevel *)\r
(* code: endlevel *)\r
begin\r
emitcode(cendlevel);\r
st_endlevel1;\r
end;\r
\r
end; (* case *)\r
\r
end; (* section 13 *)\r
\r
\r
\r
begin (* code *)\r
if xtestpass1 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: (* not used *) ;\r
\r
4: literals; \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: programdeclaration;\r
\r
end; (* case ... *)\r
\r
\r
end;\r
\r
end.\r
\r
«eof»