DataMuseum.dk

top - download

    Length: 42659 (0xa6a3)
    Types: TextFile
    Names: »P3EXPR.PAS«

└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
    └─⟦this⟧ »P3EXPR.PAS« 

TextFile

\r
\r
function alloc_string: stringptr;\r
(* deliver a stringnode *)\r
\r
var strr: stringptr;\r
\r
begin\r
\r
strr:= freestrings;\r
if strr = nilstring then\r
begin\r
new(strr);\r
maxstrings:= maxstrings+1;\r
strr^.nextstr:= nilstring;\r
end;\r
\r
with  strr ^ do\r
begin\r
alloc_string:= strr;\r
freestrings := nextstr;\r
nextstr     := nilstring;\r
end;\r
\r
end;\r
\r
\r
\r
procedure release_string (xstring: stringptr);\r
(* releases a whole list, constituting a literal *)\r
\r
var strr: stringptr;\r
\r
begin\r
\r
strr:= xstring;\r
\r
(* scan the list to find the termination *)\r
repeat\r
with  strr ^ do\r
begin\r
strr:= nextstr;\r
if strr = nilstring then\r
nextstr:= freestrings; (* insert in front of free nodes *)\r
end;\r
until strr = nilstring;\r
\r
freestrings:= xstring;  (* first free in the list *)\r
\r
end;\r
\r
\r
\r
function alloc_opand: opandptr;\r
(* delivers an opand node, initialized with cur_lineno *)\r
\r
var opand: opandptr;\r
\r
begin\r
\r
opand:= freeopands;\r
if opand = nilopand then\r
begin\r
new(opand);\r
maxopands:= maxopands+1;\r
with opand^ do\r
begin\r
next:= nilopand;\r
opcode:= cerrorarg;\r
(* initialized because it is used as 'working location' by 'testindex' *)\r
end;\r
end;\r
\r
with  opand ^ do\r
begin\r
alloc_opand:= opand;\r
freeopands := next;\r
next       := nilopand;\r
op_lineno  := cur_lineno;\r
op_name    := nilname;\r
op_value   := nilstring;\r
op_packflag:= false;\r
end;\r
\r
end;\r
\r
\r
\r
procedure release_expr (expr: opandptr);\r
(* works as 'emitexpr', but does only the releasing *)\r
\r
begin\r
\r
while expr <> nilopand do\r
with  expr ^ do\r
begin\r
if left <> nilopand then\r
release_expr (left);\r
if op_value <> nilstring then\r
release_string (op_value);\r
next:= freeopands;\r
freeopands:= expr;\r
expr:= rigth;\r
end;\r
\r
end; (* procedure release-expr *)\r
\r
\r
\r
function alloc_namenode: nameptr;\r
(* delivers a namenode, initialized as dummy *)\r
\r
var name: nameptr;\r
begin\r
name:= freenames;\r
if name = nilname then\r
begin\r
new(name);\r
with name ^ do\r
begin\r
nextname:= nilname;\r
maxnix:= maxnix+1;\r
nix:= maxnix;\r
end;\r
end;\r
\r
(* initialize *)\r
with  name ^ do\r
begin\r
alloc_namenode:= name;\r
freenames:= nextname; (* unlink from free-chain *)\r
nextname := nilname;\r
\r
forward_decl := false;\r
external_decl:= false;\r
func_assigned:= false;\r
usedlevel:= nil_namestack_ptr; (* i.e. not used *)\r
params:= nilname;\r
typ:= dummy_typenode;\r
end;\r
\r
end;\r
\r
\r
\r
procedure release_typenode (xtype: typeptr); forward;\r
\r
procedure releasenames (xnamelist : nameptr);\r
(* releases all namenodes in the list *)\r
(* if a namenode is a typename, the corresponding typenode *)\r
(*   will be released too *)\r
\r
var name: nameptr;\r
\r
begin\r
\r
while xnamelist <> nilname do\r
with  xnamelist ^ do\r
begin\r
if params <> nilname then\r
releasenames (params); (* release paramlists of inner routines *)\r
if typ <> dummy_typenode then\r
if (namekind <> cundeclared) and (namekind<>cextprocess (* do not release son type *)) then\r
release_typenode (typ); (* release typenode of local type *)\r
\r
(* insert in free-chain *)\r
name:= nextname;\r
nextname:= freenames;\r
freenames:= xnamelist;\r
\r
xnamelist:= name;\r
\r
end; (* with xnamelist *)\r
\r
end;\r
\r
\r
\r
function alloc_typenode : typeptr;\r
(* delivers a typenode, initialized as dummy *)\r
\r
var name : nameptr;\r
local_type: typeptr;\r
begin\r
\r
name:= freetypename;\r
if name = nilname then\r
begin\r
new(local_type);\r
maxtypes:= maxtypes+1;\r
with local_type^ do\r
begin\r
typekind:= cnocode;\r
subexpr:= nilopand;\r
end;\r
release_typenode(local_type);\r
name:= freetypename;\r
if compilertest then\r
if name=nilname then \r
comp_error(too_many_types);\r
end;\r
\r
with  name ^ do\r
with  typ ^ do\r
\r
begin\r
alloc_typenode:= typ;\r
freetypename:= nextname;\r
nextname:= nilname;\r
typ:= dummy_typenode;\r
releasenames (name);\r
\r
(* initialize typenode *)\r
element:= nilname;\r
index  := nilname;\r
subexpr:= nilopand;\r
typekind:= cnocode;\r
contents:= [ t_simple ];  (* default *)\r
packflag:= false;\r
emitted:= false;\r
\r
end; (* with typenode *)\r
\r
end;\r
\r
\r
\r
procedure release_typenode (xtype: typeptr);\r
\r
var name: nameptr;\r
\r
begin\r
with  xtype ^ do\r
begin\r
if typekind = crecord then\r
releasenames (element); (* release field-list of record *)\r
if subexpr <> nilopand then\r
release_expr (subexpr);\r
end; (* with xtype *)\r
name:= alloc_namenode;\r
with  name ^ do\r
begin\r
namekind:= ctype;\r
typ:= xtype;\r
nextname:= freetypename;\r
freetypename:= name;\r
end;\r
\r
end;\r
\r
\r
\r
function alloc_label: labelptr;\r
(* delivers a labelnode *)\r
\r
var lab: labelptr;\r
\r
begin\r
\r
lab:= freelabels;\r
if lab = nillabel then\r
begin\r
new(lab);\r
maxlabels:= maxlabels+1;\r
lab^.prevlabel:= nillabel;\r
end;\r
\r
with  lab ^ do\r
begin\r
alloc_label:= lab;\r
freelabels := prevlabel;\r
prevlabel  := nillabel;\r
end;\r
\r
end;\r
\r
\f

\r
\r
\r
function readstring: stringptr;\r
(* reads: length, char [ 1 .. length ] from pass1file *)\r
(*  and packs into stringnodes *)\r
\r
var\r
length: integer;\r
curstr: stringptr;\r
i, portion: str_index;\r
\r
begin\r
\r
length:= passin; (* get length of string *)\r
\r
curstr:= alloc_string;\r
readstring:= curstr; (* result is (first) stringnode *)\r
curstr^.stringlgt := length;\r
\r
portion:= maxstring;\r
\r
curstr^.stringlgt := length;\r
\r
while length > 0 do\r
with  curstr ^ do\r
begin\r
\r
(* read a portion of the string *)\r
stringlgt:= length;\r
if length < portion then portion:= length;\r
length:= length - portion;\r
for i:= 1 to portion do\r
str [ i ]:= chr (passin);\r
\r
if length > 0 then\r
nextstr:= alloc_string;\r
\r
curstr:= nextstr;\r
\r
end; (* with curstr *)\r
\r
end; (* procedure readstring *)\r
\r
\r
\r
procedure emitstring (strr: stringptr);\r
\r
var\r
length: integer;\r
curstr: stringptr;\r
i, portion: str_index;\r
\r
begin\r
\r
curstr:= strr;\r
portion:= maxstring;\r
\r
with  curstr ^ do\r
length:= stringlgt;\r
\r
emitin (length);\r
\r
if length > 0 then\r
repeat\r
with  curstr ^ do\r
begin\r
if portion > stringlgt then portion:= stringlgt;\r
\r
for i:= 1 to portion do\r
emitin ( ord ( str [ i ] ) );\r
\r
curstr:= nextstr;\r
end; (* with curstr *)\r
\r
until curstr = nilstring;\r
\r
end; (* procedure emitstring *)\r
\r
\r
\r
procedure emit_extname (opand: opandptr);\r
\r
begin\r
\r
emit (xname);\r
with  opand ^ do\r
emitstring (op_value);\r
release_expr (opand);\r
\r
end;\r
\r
\r
\r
procedure stdspix (xspix: integer; xstdname: stdname_range);\r
\r
(* inserts the value 'xspix' in stdspix-table *)\r
(* ... the value -1 is <dummy-value> *)\r
\r
var i: stdname_range;\r
\r
begin\r
\r
stdspix_table [ xstdname ]:= xspix;\r
\r
maxstdspix:= -1; (* assume all entries are dummy *)\r
(* maxstdspix is used when determining a spix to be 'special' *)\r
\r
for i:= canonymous to cord do\r
if maxstdspix < stdspix_table [ i ] then\r
maxstdspix:= stdspix_table [ i ];\r
\r
end;\r
\r
\r
\r
procedure standardname;\r
(* called from initialization and mainloop *)\r
(*   it will read: (spix,stdname) , and insert in tabel *)\r
\r
begin\r
stdspix (passin (* = spix *), password (* = stdname *) );\r
\r
anonymous_spix:= stdspix_table [ canonymous ];\r
exception_spix:= stdspix_table [ cexception ];\r
end;\r
\r
\r
\r
procedure specialspix (xname: nameptr);\r
(* called from mainloop, when a 'special'-spix has been defined *)\r
(*   the action depends on the spix *)\r
\r
label 99;\r
var i: stdname_range;\r
\r
begin\r
\r
with  xname ^ do    (* namenode of special interest *)\r
with  typ ^ do    (* the corresponding typenode (in case of type...) *)\r
for i:= canonymous to cord do\r
(* scan the stdspix-table to find the rigth spix *)\r
if stdspix_table [ i ] = spix (* of namenode *) then\r
begin\r
\r
(* remove it from table (... optimalization ...) *)\r
stdspix (-1, i);\r
\r
case i of\r
\r
canonymous: ; (* empty *)\r
\r
cboolean:\r
begin\r
boolean_typename:= xname;\r
emitid (xboolean, xname);\r
end;\r
\r
cchar:\r
begin\r
char_typename   := xname;\r
emitid (xchar, xname);\r
end;\r
\r
cshadow:\r
begin\r
shadow_typename:= xname;\r
contents        := [ t_shadow ];  (* force this special content *)\r
emitid (xshadow, xname);\r
end;\r
\r
creference:\r
begin\r
reference_typename:= xname;\r
contents        := [ t_reference ];  (* force this special content *)\r
emitid (xreference, xname);\r
end;\r
\r
csemaphore:\r
begin\r
contents        := [ t_semaphore ];  (* force this special content *)\r
emitid (xsemaphore, xname);\r
end;\r
\r
cson:\r
begin\r
contents:= [ t_extprocess ];\r
son_typename    := xname;\r
end;\r
\r
cprocessrec:\r
processrec_typename:= xname;\r
\r
cexception:\r
exception_procname:= xname;\r
\r
cabs:\r
abs_procname    := xname;\r
\r
csucc:\r
begin\r
succ_procname   := xname;\r
emitid (xsucc, xname);\r
end;\r
\r
cpred:\r
begin\r
pred_procname   := xname;\r
emitid (xpred, xname);\r
end;\r
\r
cnew:\r
begin\r
emitid(xnew, xname);\r
end;\r
\r
cnil:\r
begin\r
nil_procname    := xname;\r
emitid (xnil, xname);\r
end;\r
\r
cnilref:\r
begin\r
nilref_procname := xname;\r
emitid(xnilref, xname);\r
end;\r
\r
cchr:\r
emitid (xchr, xname);\r
\r
cord:\r
begin\r
ord_procname    := xname;\r
emitid (xord, xname);\r
end;\r
\r
else\r
if compilertest then\r
comp_error (unknown_stdtype_name);\r
end;\r
\r
goto 99; (* goto found *)\r
\r
end; (* for i in stdspix_range *)\r
\r
(* in case the loop terminates: severe error *)\r
if compilertest then\r
comp_error (unknown_spix);\r
\r
99: ; (* found: *)\r
\r
end; (* procedure specialspix *)\r
\r
\r
\r
procedure set_error_type;\r
(* if the current type was an implicit type definition,    *)\r
(*   it will be released at block-end                      *)\r
\r
begin\r
cur_typename:= error_typename;\r
cur_typenode:= error_typenode;\r
end;\r
\r
(* procedures for inserting/retrieving names *)\r
\r
\r
\r
procedure searchspix (xspix: spixrange; firstlevel, lastlevel: namestackptr);\r
(* searches among all names in the levels to find 'xspix' *)\r
\r
(* the global variables 'retrieved_name'/'retrieved_level' *)\r
(*   describe the result of the procedure: *)\r
\r
(* xspix not found: 'retrieved_name' = nilname (-level undef) *)\r
(* xspix found:     'retrieved_name/level' identifies the namenode *)\r
\r
label 99;\r
var\r
name: nameptr;\r
level: namestackptr;\r
\r
begin\r
if lastlevel<>nil_namestack_ptr then\r
begin\r
level:= lastlevel;\r
repeat\r
with  level^ do\r
begin\r
name:= firstname;\r
while name <> nilname do\r
with  name ^ do\r
begin\r
if spix (* of name *) = xspix then\r
goto 99; (* found *)\r
name:= nextname; (* follow chain *)\r
end;\r
level:= former_level;\r
end; (* with level^ do *)\r
until level^.next_level=firstlevel;\r
end; (* if lastlevel<>stack bottom *)\r
name:= nilname; (* name not found *)\r
\r
99:; (* found *)\r
retrieved_level:= level; (* undef, if not found *)\r
retrieved_name := name;  (* nilname, if not found *)\r
\r
end; (* procedure searchspix *)\r
\r
\r
\r
function findname (xspix: spixrange) : nameptr;\r
(* delivers the namenode with the searched spix *)\r
(* if the spix was'nt found, the result is 'nilname' *)\r
\r
begin\r
searchspix (xspix, processparamlevel, namelevel);\r
if retrieved_name = nilname then\r
searchspix (xspix, lowestlevel, lastgloballevel);\r
findname:= retrieved_name;\r
end;\r
\r
\r
\r
function newname (xspix: spixrange) : nameptr;\r
(* a new namenode is inserted at current namelevel *)\r
(* the namenode is initialized as dummy *)\r
\r
label 99;\r
var name : nameptr;\r
\r
begin\r
\r
if xspix <> anonymous_spix then\r
begin\r
(* explicit spix'es may not exist already at current namelevel *)\r
(*   ... except forward declared routine-names ... *)\r
\r
name:= findname (xspix);\r
if name <> nilname then\r
begin\r
(* the name already existed at some level *)\r
(* check the consistency *)\r
with  name ^ do  (* namenode of just found name *)\r
if retrieved_level = namelevel then\r
begin\r
(* double-declaration is suppressed, in case the previous decl was forward *)\r
if forward_decl then\r
(* it was really forward declared *)\r
(* now test that it is similar to the new one *)\r
if namekind = cur_namekind then\r
goto 99; (* skip initialization etc *)\r
\r
(* otherwise it will be flagged as error *)\r
errorspix:= xspix;\r
error (double_declaration);\r
xspix:= anonymous_spix; (* i.e. this name can never be retrieved *)\r
\r
end (* if already on namelevel *)\r
else\r
begin\r
(* test that this (global) name has'nt been used previously on this level *)\r
if usedlevel (* of name *) = namelevel then\r
begin\r
errorspix:= xspix;\r
error (inconsistent_use);\r
end else\r
if (cur_context_no <> -1) (* in context *) and\r
(cur_namekind <> crecfield) and (cur_namekind <> cvarp)\r
and (cur_namekind <> cvaluep) then\r
begin\r
(* redefinition of name from surrounding context *)\r
errorspix := xspix;\r
warning(redefinition_of_context_name);\r
end;\r
end;\r
end; (* if existing name *)\r
\r
end; (* if explicit spix *)\r
\r
(* allocate and initialize a new namenode *)\r
\r
name:= alloc_namenode;\r
\r
with  name ^ do\r
begin\r
spix    := xspix;\r
namekind:= cur_namekind;\r
typename:= nil_typename;\r
\r
(* insert in list of names of same level *)\r
with  namelevel^ do\r
if insert_in_front then\r
begin (* only function-return-value are inserted in front ... *)\r
with  name ^ do\r
nextname:= firstname; (* insert in front of existing list *)\r
if firstname = nilname then\r
lastname:= name;\r
firstname:= name;\r
end\r
else\r
begin\r
if firstname = nilname then\r
firstname:= name\r
else\r
with  lastname ^ do\r
nextname:= name; (* insert in rear of existing list *)\r
lastname:= name;\r
end; (* with namelevel *)\r
\r
end; (* with name *)\r
\r
99:; (* after init of namenode *)\r
newname:= name;\r
\r
end; (* procedure newname *)\r
\r
\r
\r
function new_undecl (xspix: spixrange): nameptr;\r
(* the routine creates a new namenode with the spix given *)\r
(* and marks it as undeclared *)\r
\r
var name: nameptr;\r
\r
begin\r
\r
name:= newname (xspix);\r
with  name ^ do\r
begin\r
namekind:= cundeclared;\r
typename:= error_typename;\r
typ     := error_typenode;\r
end;\r
\r
(* nbnbnb: make a 'pseudo'-declaration of the name *)\r
emitid (xundeclid, name);\r
\r
new_undecl:= name;\r
\r
end; (* procedure new-undecl *)\r
\r
\r
\r
function usename (xspix: spixrange) : nameptr;\r
(* the routine will search for the given spix, and mark the namenode *)\r
(*   as being used on current namelevel *)\r
\r
(* if the name doesn't exist, a new namenode will be created *)\r
\r
var name: nameptr;\r
\r
begin\r
\r
cur_opandno:= cur_opandno + 1;\r
\r
name:= findname (xspix);\r
\r
if name = nilname then\r
begin\r
(* the name did'nt exist, create e new namenode *)\r
errorspix:= xspix; (* print undeclared name *)\r
error (undeclared);\r
name:= new_undecl (xspix);\r
\r
end; (* if undeclared *)\r
\r
(* test for recursive use of constants, i.e. using before defining *)\r
with  name ^ do\r
if namekind = cconstant then\r
if usedlevel = nil_namestack_ptr (* i.e. just after declaration *) then\r
begin\r
errorspix:= spix; (* of name *)\r
error (recursive_constant_use);\r
name:= new_undecl (xspix);\r
end;\r
\r
(* mark the name as being used on current level *)\r
with  name ^ do\r
usedlevel:= namelevel;\r
\r
usename:= name; (* deliver the used name node *)\r
\r
end; (* procedure usename *)\r
\r
\r
\r
procedure end_level_use (firstlevel, lastlevel: namestackptr);\r
(* all names in the outpointed namelevels are tested for use *)\r
(* on current namelevel *)\r
\r
(* if a name was used on current namelevel, it will be flagged *)\r
(*   as if it had been used on preceding namelevel *)\r
\r
var\r
name: nameptr;\r
level: namestackptr;\r
\r
begin\r
if lastlevel<>nil_namestack_ptr then\r
begin\r
level:= lastlevel;\r
repeat\r
with  level^ do\r
begin\r
name:= firstname;\r
while name <> nilname do\r
with  name ^ do\r
begin\r
if usedlevel = namelevel then\r
if namelevel = processparamlevel then\r
usedlevel:= lastgloballevel\r
else\r
usedlevel:= usedlevel^.former_level;\r
name:= nextname;  (* follow chain *)\r
end; (* with name ^ *)\r
level:= former_level;\r
end; (* with level ^ do *)\r
until level^.next_level=firstlevel;\r
end;\r
end; (* procedure end_level_use *)\r
\r
\r
\r
procedure end_global_use;\r
(* called when terminating a namelevel *)\r
(* if global variables have been used at this namelevel *)\r
(*   their uselevel will be decreased as is they were used at *)\r
(*   preceding namelevel *)\r
\r
begin\r
end_level_use (processparamlevel, namelevel^.former_level);\r
end_level_use (lowestlevel, lastgloballevel);\r
end;\r
\r
\f

\r
(* procedures for handling push/pop of names *)\r
\r
procedure pushname (xname: nameptr);\r
begin\r
if curpushname^.push_chain=nil then (* end of list, add one more *)\r
begin\r
maxpushnames:= maxpushnames+1;\r
new(curpushname^.push_chain);\r
with curpushname^.push_chain^ do\r
begin\r
pop_chain:= curpushname;\r
push_chain:= nil;\r
end; (* with *)\r
end; (* add new element to list *)\r
curpushname:= curpushname^.push_chain;\r
curpushname^.pushed_name:= xname;\r
end;\r
\r
\r
\r
function popname : nameptr;\r
begin\r
popname:= curpushname^.pushed_name;\r
curpushname:= curpushname^.pop_chain;\r
end;\r
\r
\r
\r
(* pushlist/poplist are used for handling of nested namelists *)\r
\r
procedure pushlist;\r
begin\r
pushname (listfirst);\r
pushname (listlast);\r
listfirst:= nilname;\r
listlast := nilname;\r
end;\r
\r
procedure poplist;\r
begin\r
listlast := popname;\r
listfirst:= popname;\r
end;\r
\r
\r
\r
(* pushtype/poptype are used for handling of nested types *)\r
\r
procedure pushtype;\r
begin\r
pushname (cur_typename);\r
end;\r
\r
procedure poptype;\r
begin\r
cur_typename:= popname;\r
with  cur_typename ^ do\r
cur_typenode:= typ;\r
\r
if compilertest then\r
if cur_typenode = dummy_typenode then\r
begin\r
comp_error (unstack_nontype);\r
set_error_type;\r
end;\r
end;\r
\r
\r
\r
(* procedures for handling of nested procedure calls (or indexing etc) *)\r
\r
procedure pushcall;\r
begin\r
if callindex = max_nested_calls then\r
stop (too_many_nested_calls);\r
\r
with calls [ callindex ] do\r
begin\r
callkind     := argkind;\r
callformal   := curformal;\r
callowner    := arglist_owner;\r
call_afterfunc:= after_funccall;\r
call_functemp:= functempvar;\r
call_countprocess:= count_processparam;\r
end;\r
\r
after_funccall:= false; (* assume not function call *)\r
\r
count_processparam:= 0;\r
\r
callindex:= callindex + 1;\r
\r
end; (* procedure pushcall *)\r
\r
\r
\r
procedure popcall;\r
(* works opposite of pushcall *)\r
\r
begin\r
\r
callindex:= callindex - 1;\r
\r
with calls [ callindex ] do\r
begin\r
argkind      := callkind;\r
curformal    := callformal;\r
arglist_owner:= callowner;\r
after_funccall:= call_afterfunc;\r
functempvar  := call_functemp;\r
count_processparam:= call_countprocess;\r
end;\r
\r
end; (* procedure popcall *)\r
\r
\r
(* procedures for creating new opand-nodes, whether operators or operands *)\r
\r
procedure oper (mode: opmodes; xopcode: codes; xtypename: nameptr);\r
(* inserts an opandnode as unary or binary operator *)\r
\r
var\r
oldtop: opandptr;\r
\r
begin\r
\r
(* move stacktop to another opand, and use the stacktop for the new one *)\r
(* this makes it possible to 'insert' in the middle of the opand-tree   *)\r
oldtop:= alloc_opand;\r
 oldtop ^:=  stacktop ^;\r
\r
with  stacktop ^ do  (* new opand node *)\r
begin\r
\r
opcode:= xopcode;\r
\r
if mode = unary then\r
begin\r
left  := nilopand;\r
rigth := oldtop;\r
next  := nexttop;\r
end\r
else\r
begin (* binary*)\r
left  := nexttop;\r
rigth := oldtop;\r
next  :=  left ^ . next;\r
\r
nexttop:= next;\r
\r
end;\r
\r
op_lineno  := 0;  (* dummy *)\r
op_name    := nilname;\r
op_value   := nilstring;\r
op_typename:= xtypename;\r
\r
end; (* with (new) stacktop *)\r
\r
end; (* procedure oper *)\r
\r
\r
\r
procedure newopand (xcode: codes; xtypename: nameptr);\r
(* insert an operand at stacktop *)\r
\r
var\r
oldtop: opandptr;\r
\r
begin\r
\r
if retain_top then\r
begin\r
(* if insertion in middle of list then don't 'move' stacktop *)\r
oldtop:= alloc_opand;\r
 oldtop ^:=  stacktop ^;\r
with  stacktop ^ do\r
begin\r
op_lineno:= 0;\r
op_name  := nilname;\r
op_value := nilstring;\r
end;\r
end\r
else\r
begin\r
\r
oldtop:= stacktop;\r
stacktop:= alloc_opand;\r
\r
end;\r
\r
with  stacktop ^ do  (* new opand node *)\r
begin\r
\r
opcode     := xcode;\r
left       := nilopand;\r
rigth      := nilopand;\r
next       := oldtop;\r
op_typename:= xtypename;\r
\r
end;\r
\r
nexttop:= oldtop;\r
\r
end; (* procedure newopand *)\r
\r
\r
\r
function take_stacktop : opandptr;\r
(* used when the top-expression is to be saved a while *)\r
begin\r
take_stacktop:= stacktop;\r
stacktop     := nexttop;\r
nexttop      :=  stacktop ^ . next;\r
end;\r
\r
\r
\r
procedure insert_functype (xtypename: nameptr);\r
begin\r
with  functempvar ^ do\r
typename:= xtypename;\r
end;\r
\r
\r
\r
procedure prepare_call (opand: opandptr);\r
(* used to prepare a routine-call *)\r
(* nb: 'pushcall' must have been called previously *)\r
\r
var\r
saved_stacktop : opandptr;\r
saved_nexttop  : opandptr;\r
\r
begin\r
\r
with  opand ^ do   (* opand contains id, holding routine *)\r
with  op_name ^ do   (* namenode of routine *)\r
\r
begin\r
(* initialize global variables, describing arguments to this routine *)\r
\r
argkind    := cargument;\r
curformal  := params;     (* first of formal list *)\r
arglist_owner:= op_name;    (* set this routine as owner of formal list *)\r
\r
if namekind (* of routine *) = cfunction then\r
begin\r
(* save stacktop etc and restore later *)\r
(* simulate that 'opand' is stacktop *)\r
saved_stacktop:= stacktop;\r
saved_nexttop := nexttop;\r
stacktop      := opand;\r
nexttop       :=  stacktop ^ . next;\r
\r
retain_top:= true;\r
\r
(* reserve temp name, for identifying temp-return-value *)\r
functempvar:= alloc_namenode;\r
insert_functype (typename (* of function *) );\r
\r
(* insert opand, pointing at this temp-name *)\r
oper (unary, cfunctrailer, nilname (* irrell typename *) );\r
with  stacktop ^ do\r
op_name:= functempvar;\r
\r
(* insert operand, to be used as actual argument for the return-value *)\r
newopand (cfunctemp, nilname (* irrell typename *) );\r
with  stacktop ^ do\r
op_name:= functempvar;\r
\r
(* bind this actual-argument onto the function *)\r
(* ... see also 'actparam' ... *)\r
oper (binary, argkind, nilname (* irrell typename *) );\r
with  stacktop ^ do\r
op_name:= curformal;  (* let opname point at first formal name, i.e. 'funcval' *)\r
\r
if compilertest then\r
if (stacktop <> opand) or (nexttop <>  opand ^ . next) then\r
begin\r
write(seg(stacktop), ofs(stacktop),\r
      seg(opand),    ofs(opand),\r
      seg(nexttop),  ofs(nexttop),\r
      seg(opand^.next),ofs(opand^.next));\r
break;\r
end;\r
\r
retain_top:= false;\r
\r
stacktop      := saved_stacktop;\r
nexttop       := saved_nexttop;\r
end;\r
\r
end; (* with namenode of routine *)\r
\r
end; (* procedure prepare-call *)\r
\r
\r
\r
procedure terminate_call (opand: opandptr);\r
(* used by 'endactual' to test total match of formal lists etc *)\r
\r
label 10;\r
\r
var\r
saved_stacktop : opandptr;\r
saved_nexttop  : opandptr;\r
\r
begin\r
\r
(* save stacktop etc and restore later *)\r
(* simulate that 'opand' is stacktop   *)\r
saved_stacktop:= stacktop;\r
saved_nexttop := nexttop;\r
stacktop      := opand;\r
nexttop       :=  stacktop ^ . next;\r
\r
case argkind of\r
\r
cstrucrecord,\r
cargument:\r
begin\r
(* test that all recfields (respectively all formals) have been matched *)\r
while curformal <> nilname do\r
with  curformal ^ do\r
case namekind (* of curformal *) of\r
crecfield,\r
cvarp,\r
cvaluep:\r
begin\r
errorspix:= arglist_owner^.spix;\r
error (too_few_parameters);\r
goto 10;\r
end;\r
cfuncval,\r
cundeclared,  (* undeclared typename *)\r
cscalarelem,\r
ctype:\r
curformal:= nextname;  (* i.e. skip in formal-list *)\r
else\r
if compilertest then\r
comp_error (unknown_namekind);\r
end;\r
\r
10:;\r
end; (* argkind = strucrecord or argument *)\r
\r
else; (* no check *)\r
end; (* case argkind *)\r
\r
(* insert opands, describing the proper end-list *)\r
case argkind of\r
\r
cindex: ; (* nothing *)\r
\r
cstrucarray,\r
cstrucrecord:\r
oper (unary, cendstruc, arglist_owner);\r
\r
cargument:\r
with  arglist_owner ^ do\r
case namekind of\r
cextprocess:\r
oper(unary, ccallprocess, nilname (* no type *));\r
cprocess:\r
begin\r
oper (unary, ccallprocess, nilname (* no type *) );\r
with  stacktop ^ do\r
op_name:= nextname (* of process *);  (* remember the sonvar-name, for later use *)\r
end;\r
cprocedure,\r
cfunction:\r
begin\r
(* first insert operators for later counting in opand-stack *)\r
while count_processparam > 0 do\r
begin\r
count_processparam:= count_processparam - 1;\r
oper (unary, cendprocessparam, nilname (* irrell typename *) );\r
end;\r
case namekind (* of arglist-owner *) of\r
cprocedure:\r
oper (unary, cendproc, nilname (* irrell typename *) );\r
cfunction:\r
begin\r
with  functempvar ^ do  (* namenode, containing function-type *)\r
oper (unary, cfcall, typename (* of function-type *) );\r
with calls [ callindex - 1 ] do  (* i.e. determine the value to be unstacked *)\r
call_afterfunc:= true;\r
end;\r
else (* not possible *);\r
end; (* case procedure or function *)\r
end;\r
else;\r
end; (* case namekind *)\r
\r
cerrorarg: ; (* don't care anyway *)\r
\r
\r
else\r
if compilertest then\r
comp_error (unknown_argkind);\r
end; (* case argkind *)\r
\r
(* unstack nested call *)\r
popcall;\r
\r
if compilertest then\r
if (opand <> stacktop) or (nexttop <> opand^.next) then\r
begin\r
write(seg(stacktop), ofs(stacktop),\r
      seg(opand),    ofs(opand),\r
      seg(nexttop),  ofs(nexttop),\r
      seg(opand^.next),ofs(opand^.next));\r
break;\r
end;\r
(* restore thereal stacktop and nexttop *)\r
stacktop:= saved_stacktop;\r
nexttop := saved_nexttop;\r
\r
end; (* procedure terminate-call *)\r
\r
\r
\r
procedure terminate_funccall (opand: opandptr);\r
(* ensures that the 'endfunccall' is emitted (as late as possible) after a function call *)\r
\r
var\r
saved_stacktop : opandptr;\r
saved_nexttop  : opandptr;\r
\r
begin\r
if after_funccall then\r
begin\r
(* save stacktop etc and restore later *)\r
(* simulate that 'opand' is stacktop   *)\r
saved_stacktop:= stacktop;\r
saved_nexttop := nexttop;\r
stacktop      := opand;\r
nexttop       :=  stacktop ^ . next;\r
with  stacktop ^ do\r
oper (unary, cendvariable, op_typename (* continue with op-type *) );\r
(* unstack from call-stack *)\r
after_funccall:= false;\r
if compilertest then\r
if (opand <> stacktop) or (nexttop <> opand^.next) then\r
begin\r
write(seg(stacktop), ofs(stacktop),\r
     seg(opand),     ofs(opand),\r
     seg(nexttop),   ofs(nexttop),\r
     seg(opand^.next),ofs(opand^.next));\r
break;\r
end;\r
(* restore the real stacktop and nexttop *)\r
stacktop:= saved_stacktop;\r
nexttop := saved_nexttop;\r
end;\r
\r
end; (* terminate func call *)\r
\r
\r
\r
procedure make_call (opand: opandptr);\r
(* if the operand is a routine-ident, a (parameter-less) call will be made *)\r
\r
begin\r
with  opand ^ do\r
if opcode = cid then\r
with  op_name ^ do\r
case namekind of\r
cprocess,\r
cprocedure,\r
cfunction:\r
begin\r
pushcall;\r
prepare_call (opand);\r
terminate_call (opand);\r
terminate_funccall (opand);\r
end;\r
else; (* other namekinds are not routine-calls *)\r
end;\r
end; (* procedure make-call *)\r
\r
\f

\r
(* procedures for handling level-change etc *)\r
\r
procedure newnamelevel;\r
(* initializes a new namelevel, with an empty namelist *)\r
begin\r
if namelevel (* current level *)^.next_level=nil then\r
begin\r
new(namelevel^.next_level);\r
maxnamestacklevels:= maxnamestacklevels+1;\r
with namelevel^.next_level^ do\r
begin\r
level_number:= maxnamestacklevels;\r
next_level:= nil;\r
former_level:= namelevel;\r
end; (* with ... *)\r
end; (* extend the stack *)\r
namelevel:= namelevel^.next_level;\r
with  namelevel^ do\r
begin\r
firstname:= nilname;\r
namelistkind:= levelkind;\r
withname:= nilname;  (* assume normal level *)\r
if namelistkind = processlevel then\r
processparamlevel:= namelevel;\r
end;\r
levelkind:= irrell_level;  (* prepare for next level to be normal *)\r
\r
end;\r
\r
\r
procedure insert_namelist (first: nameptr);\r
(* initializes current namelevel with the namelist given *)\r
begin\r
with  namelevel^ do\r
begin\r
firstname:= first;\r
lastname:= first;\r
while  lastname ^ . nextname <> nilname do\r
lastname:=  lastname ^ . nextname;\r
end;\r
end;\r
\r
\r
procedure endnamelevel;\r
begin\r
(* the variable 'processparamlevel' must be reinitialized, when *)\r
(*   leaving a process. *)\r
if namelevel = processparamlevel then\r
repeat\r
processparamlevel:= processparamlevel^.former_level;\r
until\r
( processparamlevel^ . namelistkind = processlevel)\r
or\r
(processparamlevel = lastgloballevel^.former_level);\r
end_global_use;\r
namelevel:= namelevel^.former_level;\r
end;\r
\r
procedure test_recursive_type;\r
(* will test that 'cur_typename' is a defined type *)\r
begin\r
with  cur_typename ^ do\r
if (spix (* of typename *)<>anonymous_spix) and not forward_decl then\r
(* recursion only possible with named types *)\r
(* and forward pointers are allowed to be recursive *)\r
with  typ ^ do\r
if not emitted then\r
begin\r
errorspix:= spix; (* of typename *)\r
error (recursive_use_of_type);\r
set_error_type;\r
end;\r
end;\r
\r
\f

\r
\r
\r
function empty_paramlist (paramlist: nameptr): boolean;\r
(* returns false, if the paramlist contains 'varparam' or 'valueparam' *)\r
\r
label 99;\r
\r
begin\r
while paramlist <> nilname do\r
with  paramlist ^ do\r
if (namekind = cvarp) or (namekind = cvaluep) then\r
begin\r
empty_paramlist:= false;\r
goto 99;\r
end\r
else\r
paramlist:= nextname;  (* follow chain *)\r
\r
(* the list did'nt contain var- or valueparam *)\r
empty_paramlist:= true;\r
99: ;\r
\r
end; (* procedure empty-paramlist *)\r
\r
procedure compare_paramlists;\r
(* compares the previous paramlist of 'cur_routine' *)\r
(*   with param-list in current namelevel *)\r
\r
(* the new paramlist may be empty or exactly the same *)\r
\r
(* the new paramlist is released and replaced by the original list *)\r
\r
var\r
newparam, oldparam: nameptr;\r
errorflag: boolean;\r
\r
begin\r
errorflag:= false; (* suppose no errors *)\r
with  namelevel^ do\r
with  cur_routine ^ do\r
begin\r
\r
newparam:= firstname; (* first of new parameter list *)\r
\r
if not empty_paramlist (newparam) then\r
begin\r
oldparam:= params; (* first of old parameter list (of cur_routine) *)\r
\r
(* compare the two lists *)\r
(* they both terminate with nilname *)\r
\r
while oldparam <> newparam do\r
with  oldparam ^ do\r
begin\r
\r
if\r
(* they must have identical names *)\r
(spix     <>  newparam ^ . spix)\r
or\r
(* both must be 'cvarp' or 'cvaluep' *)\r
(namekind <>  newparam ^ . namekind)\r
or\r
(* they must have same type *)\r
(typename<>newparam^.typename) and\r
((typename^.typ^.typekind<>creadonly) or\r
(newparam^.typename^.typ^.typekind<>creadonly) or\r
(typename^.typ^.element<>newparam^.typename^.typ^.element)) \r
then\r
errorflag:= true;\r
\r
oldparam:= nextname;\r
newparam:=  newparam ^ . nextname;\r
\r
end; (* with/while more params *)\r
\r
if errorflag then\r
error (paramlist_changed_since_forwarddecl);\r
\r
end; (* if new paramlist not empty *)\r
\r
(* release the new paramlist and replace it by the old one *)\r
\r
releasenames (firstname (* of namelevel *) );\r
insert_namelist (params (* of cur-routine *) );\r
\r
end; (* with cur_routine *)\r
\r
end; (* procedure compare_paramlists *)\r
\r
\f

\r
procedure begin_block;\r
(* called before first local declaration in a routine *)\r
begin\r
expecting_block:= false; (* indicate that the procedure has been called *)\r
\r
with  cur_routine ^ do\r
begin\r
if namekind <> cprocess then\r
cur_blockno:= cur_blockno + 1;\r
forward_decl:= false; (* because here comes the body *)\r
end;\r
\r
emit (xblock);\r
emitin (cur_blockno);\r
\r
end;\r
\r
\f

\r
(* procedures for emitting identifiers and types *)\r
\r
\r
\r
procedure emitexpr (expr: opandptr);\r
(* the expression is emitted, and maybe released (depending on 'expr-release') *)\r
\r
procedure emitboth;\r
begin\r
with  expr ^ do\r
begin\r
emitexpr (left);\r
emitexpr (rigth);\r
end;\r
end;\r
\r
procedure emit_arith (outcode: pass3codes);\r
begin\r
with  expr ^ do\r
begin\r
if left <> nilopand then\r
begin\r
emitexpr (left);\r
emit (xgetvalue);\r
end;\r
emitexpr (rigth);\r
emit (outcode);\r
end;\r
end;\r
\r
begin\r
\r
if expr <> nilopand then\r
with  expr ^ do\r
begin\r
\r
(* note: only 'newopand' inserts proper lineno in opands *)\r
if op_lineno <> 0 then\r
if op_lineno <> emit_lineno then\r
begin\r
emit (xnewline);\r
emitin (op_lineno);\r
emit_lineno:= op_lineno;\r
end;\r
\r
\r
expr_level:= expr_level + 1;\r
if expr_level = 1 then\r
begin\r
emit (xexpr);      (* this is the start of a whole expression *)\r
if testoutput then continue_line;\r
end;\r
\r
if opcode = cnocode then\r
emitboth\r
else\r
case opcode (* of opand *) of\r
\r
ctypeid, (* implicit type name in front of structured constant *)\r
cid:\r
begin\r
(* identifier: action depends on namekind *)\r
\r
if (opcode=ctypeid) and (op_name^.namekind<>ctype) and (op_name^.namekind<>cundeclared) then\r
error(type_name_missing);\r
\r
with  op_name ^ do  (* namenode of identifier *)\r
\r
case namekind (* of namenode *) of\r
\r
cundeclared,\r
cscalarelem,\r
cconstant,\r
cvar,\r
cvarp,\r
cvaluep,\r
cfuncval:\r
begin\r
emitid (xvar, op_name);\r
emitin (typename^.nix);\r
end;\r
\r
cprocess: \r
begin\r
emitid(xvar, nextname); (* son var *)\r
emitin(nextname^.typename^.nix);\r
emit(xtempointer);\r
end;\r
(* start of process param sequence *)\r
\r
cprocedure:\r
begin\r
(* start of procedure call-sequence *)\r
emitid (xproccall, op_name);\r
end;\r
\r
cfunction:\r
begin\r
(* start of function call sequence *)\r
emitid (xfunccall, op_name);\r
(* the temp-return-value and the type are emitted by 'functrailer' *)\r
end;\r
\r
cerrorkind: ; (* nothing *)\r
\r
ctype:\r
begin\r
(* start of structured constant sequence *)\r
emitid (xstrucconst, op_name (* name of type itself *));\r
end;\r
\r
else\r
if true then write (output, '*** id: namekind = ', ord(namekind):1)\r
else\r
if compilertest then\r
comp_error (unknown_namekind);\r
end; (* case namekind *)\r
\r
end; (* opcode = 'id' *)\r
\r
cliteral:\r
begin\r
emit (xliteral);\r
with  op_typename ^ do    (* namenode of opand-type *)\r
with  typ ^ do          (* corresponding typenode *)\r
if typekind (* of opand-typenode *) = cinteger then\r
emitin ( ord(lit_integer) )\r
else\r
with  op_value ^ do\r
if stringlgt = 1 then\r
emitin ( ord(lit_char) )\r
else\r
emitin ( ord(lit_string_or_empty) );\r
emitstring (op_value);\r
end;\r
\r
\r
ctypesizecall:\r
begin\r
emit(xtypesizecall);\r
emitin(op_name^.nix);\r
end; (* typesizecall *)\r
\r
cskipparam:\r
emit (xnull);\r
\r
\r
cfunctrailer:\r
begin\r
emitexpr (rigth);  (* emit funccall etc *)\r
emitin (op_name^.nix);  (* name of temp-return-value *)\r
with  op_name ^ do  (* namenode of functemp var *)\r
emitin (typename^.nix );  (* typename of function *)\r
end;\r
\r
\r
cfunctemp:\r
begin\r
(* this is almost an 'id', but the namenode doesn't contain typename *)\r
(* used for actual argment, to match 'funcval' *)\r
emitid (xvar, op_name);\r
with  op_name ^ do  (* namenode of functemp var *)\r
emitin (typename^.nix  );\r
if expr_release then\r
releasenames (op_name); (* because it was a temporary *)\r
end;\r
\r
\r
cfcall:\r
begin\r
emitexpr (rigth);  (* note: it is an unary operator *)\r
emit (xfcall);\r
emitin (count_processparam); count_processparam:= 0;\r
(* note: the 'endfunccall' is emitted after any indexing,uparrow etc *)\r
end;\r
\r
\r
cendproc:\r
begin\r
emitexpr (rigth);  (* note: it is an unary operator *)\r
emit (xendproc);\r
emitin (count_processparam); count_processparam:= 0;\r
end;\r
\r
\r
ccallprocess:\r
emitexpr (rigth);  (* note: it is an unary operator *)\r
\r
\r
cendprocessparam:\r
begin\r
emitexpr (rigth);  (* note: it is an unary operator *)\r
count_processparam:= count_processparam + 1;\r
end;\r
\r
\r
(* emission of set_values *)\r
csetlist:\r
emit (xset);\r
cs_element:\r
begin\r
emitboth;\r
emit (xinclude);\r
end;\r
cm_element:\r
begin\r
emitexpr (left);\r
emit (xsetexpr);\r
emitexpr (rigth);\r
emit (xincluderange);\r
end;\r
cendsetlist:\r
begin\r
emitexpr (rigth);  (* note: unary operator *)\r
(* note: pass4 will generate its own type description, using this type-nix *)\r
emitid (xendset, op_typename);\r
if expr_release then\r
if not const_decl then  (* dont't release, when const-declaration *)\r
releasenames (op_typename); (* because it was a temporary *)\r
end;\r
\r
\r
cfield:\r
begin\r
emitexpr (rigth);  (* nb: field is unary operator *)\r
emit (xfield);\r
emitin (op_name^.nix );     (* field name *)\r
emitin (op_typename^.nix); (* field type name *)\r
end;\r
\r
\r
cuparrow:\r
begin\r
emitexpr (rigth); (* nb: uparrow is unary operator *)\r
emitid (xarrow, op_typename);\r
end;\r
\r
crange:\r
begin\r
emitexpr (rigth);  (* note: unary operator *)\r
emitid (xrange, op_typename);\r
end;\r
\r
\r
cerrorarg, (* midlertidig ************************************** *)\r
cindex:\r
begin\r
emitexpr (left); (* array name etc *)\r
emit (xindexexpr);\r
emitexpr (rigth); (* index expression *)\r
emit (xindex);\r
emitin (op_name^.nix);     (* array type name *)\r
emitin (op_typename^.nix); (* element type name *)\r
end;\r
\r
\r
cprocessargument:\r
begin\r
(* parameter, describing a process-'call' *)\r
(* emit the argument-expression at once (i.e. the process-params) *)\r
(* and then later simulate a normal argument *)\r
emit (xprocessparam);\r
emit (xvarpointer);\r
emitin (op_typename^.nix);  (* temp var, for addressing the 'processrec' *)\r
emitexpr (rigth);  (* emit the process-params *)\r
\r
emit (xarglistsize);\r
emitexpr (left);  (* previous routine-ident and arguments *)\r
end;\r
\r
\r
cargument:\r
begin\r
(* argument-list of routine call *)\r
emitexpr (left);  (* previous routine-ident and arguments *)\r
emitid (xactual, op_name);\r
emitexpr (rigth); (* argument expression *)\r
emit (xendactual);\r
end;\r
\r
\r
cdoubleparam:\r
begin\r
(* used for repetition in structured array-values *)\r
emitexpr (left);  (* emit repeat-value *)\r
emit (xtimes);\r
emitexpr (rigth); (* emit the struc-value *)\r
end;\r
\r
\r
cendvariable:\r
begin (* made by 'cendvariable', if after function call *)\r
emitexpr (rigth);  (* note: unary operator *)\r
emit (xendfunccall);\r
end;\r
\r
\r
cstrucarray,\r
cstrucrecord:\r
begin\r
emitboth;  (* emit previous struc-elements and value component *)\r
emitid (xstruc, op_typename);\r
end;\r
\r
\r
cendstruc:\r
begin\r
emitexpr (rigth);  (* note: it is an unary operator *)\r
emit (xendstruc);\r
end;\r
\r
cendassign:\r
begin\r
emit (xassignstat);\r
emitexpr (left);   (* variable *)\r
emit (xbecomes);\r
emitexpr (rigth);  (* expression *)\r
emit (xassign);\r
end;\r
\r
cendexchange:\r
begin\r
emit (xexchangestat);\r
emitexpr (left);   (* lefthand variable *)\r
emit (xbecomes);\r
emitexpr (rigth);  (* rigthhand variable *)\r
emit (xexchange);\r
end;\r
\r
crangefirst:\r
begin\r
emitexpr (left);  (* first range *)\r
emit (xgetexpr);\r
emitexpr (rigth); (* last range *)\r
end;\r
\r
cplus:   emit_arith (xadd);\r
cminus:  emit_arith (xsub);\r
cstar:   emit_arith (xmul);\r
cslash,                    (* until further same as div... *)\r
cdiv:    emit_arith (xdiv);\r
cmod:    emit_arith (xmod);\r
cshift:  emit_arith (xshift);\r
ceq:     emit_arith (xeq);\r
cne:     emit_arith (xne);\r
clt:     emit_arith (xlt);\r
cle:     emit_arith (xle);\r
cgt:     emit_arith (xgt);\r
cge:     emit_arith (xge);\r
cin:     emit_arith (xin);\r
cor:     emit_arith (xor_);\r
cxor:    begin\r
if target_machine = targetz80 then error( not_implemented_on_z80 );\r
emit_arith (xxor);\r
end;\r
cand:    emit_arith (xand);\r
cnot:    emit_arith (xnot);\r
cuminus: emit_arith (xneg);\r
cuplus:  emitexpr (rigth);  (* blind operator *)\r
\r
\r
else\r
if compilertest then\r
comp_error (unknown_opcode);\r
end; (* case opcode of opand *)\r
\r
if op_typename^.namekind=cextprocess then\r
emit(xtempointer);\r
\r
if testoutput then continue_line;\r
\r
if expr_release then\r
begin\r
if op_value <> nilstring then\r
release_string (op_value);\r
if expr = stacktop then\r
stacktop:= next;\r
next:= freeopands;\r
freeopands:= expr;\r
end;\r
\r
expr_level:= expr_level - 1;\r
\r
end; (* with expr *)\r
\r
end; (* procedure emitexpr *)\r
\r
\r
\r
procedure emit_and_release (expr: opandptr);\r
(* emits - and releases - the expression *)\r
begin\r
expr_release:= true;\r
emitexpr (expr);\r
expr_release:= false;\r
\r
(* in case stacktop has been updated, now update nexttop *)\r
if stacktop=nil then\r
begin\r
stacktop:= nilopand;\r
nexttop:= nilopand;\r
end\r
else\r
nexttop:= stacktop ^ . next;\r
\r
end;\r
\r
\r
\r
procedure prepare_statement;\r
(* the procedure will emit all pending expressions  *)\r
(* .... but maybe it should rather test for pending expressions ? *)\r
(**)\r
(* furthermore it will set a flag, used to determine how *)\r
(*   a function-identifier should be interpreted         *)\r
\r
begin\r
while stacktop <> nilopand do\r
emit_and_release (stacktop);\r
before_assign:= true;\r
end;\r
\r
\r
\r
procedure prepare_expression;\r
(* works in coorporation with prepare-statement *)\r
\r
begin\r
before_assign:= false;\r
end;\r
\r
\r
\r
procedure emittype (xtypename: nameptr);\r
label 10; (* loop in cscalar *)\r
var name: nameptr;\r
begin\r
\r
with  xtypename ^ do\r
with  typ ^ do\r
begin \r
\r
if emitted then\r
emitid (xtype, xtypename)\r
else\r
if forward_decl then (* forward pointer declaration *)\r
emitid(xforwardpointer, xtypename)\r
(* emitted is not set to true because the real definition must be\r
emitted in total when defined *)\r
else\r
begin\r
(* this is the first time the typename is emitted *)\r
(*   emit the whole definition *)\r
emitted:= true;\r
\r
case typekind of\r
\r
calias:\r
begin\r
(* output:  <type>  redeftype(nix) *)\r
emittype (element);\r
emitid (xredeftype, xtypename);\r
end;\r
\r
\r
\r
cscalar:\r
begin\r
(* output:  ( scalarid(nix) )*  scalardef(nix)   *)\r
name:= element; (* first scalar name of scalartype *)\r
\r
10: (* loop *)\r
with  name ^ do\r
if namekind = cscalarelem then\r
(* the scalar names are in the common namelist *)\r
if typename = xtypename then\r
begin\r
emitid (xscalarid, name);\r
name:= nextname;  (* follow chain *)\r
if testoutput then continue_line;\r
goto 10;  (* goto loop *)\r
end;\r
\r
emitid (xscalardef, xtypename);\r
end;\r
\r
\r
\r
csubrange:\r
begin\r
(* output:  <expr> <expr> subdef(typenix, elementnix) *)\r
emit_and_release (subexpr);  (* emit both expressions *)\r
subexpr:= nilopand;\r
emitid (xsubdef, xtypename);\r
emitin (index^.nix);  (* nix of element type *)\r
end;\r
\r
\r
\r
cpointer:\r
begin\r
(* output:  <type>  pointerdef(nix)  *)\r
emittype (element);\r
emitid (xpointerdef, xtypename);\r
end;\r
\r
\r
\r
creadonly:\r
begin\r
(* output:  <type>  frozendef(nix)  *)\r
emittype (element);\r
emitid (xfrozendef, xtypename);\r
end;\r
\r
\r
\r
carray:\r
begin\r
(* output:  <indextype> <elementtype> (packed) arraydef(nix)  *)\r
emittype (index);\r
emittype (element);\r
if packflag (* of array type *) then\r
emitid (xpackedarraydef, xtypename)\r
else\r
emitid (xarraydef, xtypename);\r
end;\r
\r
\r
\r
crecord:\r
begin\r
(* output:                                   *)\r
(*   packedrecord/record                     *)\r
(*     ( fieldid(nix)  <type>  fielddef )*   *)\r
(*   recdef(nix)                             *)\r
if packflag (* of record type *) then\r
emit (xpackedrecord)\r
else\r
emit (xrecord);\r
\r
name:= element;  (* first name in field list *)\r
while name <> nilname do\r
with  name ^ do\r
begin\r
if namekind (* of fieldname/local typedef *) = crecfield then\r
begin\r
if testoutput then continue_line;\r
emitid (xfieldid, name);\r
emittype (typename);\r
emit (xfielddef);\r
end;\r
name:= nextname;  (* follow chain *)\r
end;\r
\r
emitid (xrecdef, xtypename);\r
\r
end;\r
\r
\r
\r
cset:\r
begin\r
(* output:  <type>  setdef(nix)  *)\r
emittype (element);\r
emitid (xsetdef, xtypename);\r
end;\r
\r
\r
\r
cpool:\r
begin\r
(* output:  <expr> <type> pooldef(nix)  *)\r
emit_and_release (subexpr);\r
subexpr:= nilopand;\r
emittype (element);\r
emitid (xpooldef, xtypename);\r
end;\r
\r
\r
\r
cinteger:\r
emitid (xinteger, xtypename);\r
\r
\r
\r
creal:\r
emitid (xreal, xtypename);\r
\r
\r
\r
cniltype:\r
emitid (xniltype,xtypename);\r
\r
\r
\r
cerrorkind:\r
emitid (xerrortype, xtypename);\r
\r
\r
\r
ctext:\r
emitid (xstringtype, xtypename);\r
\r
\r
\r
else\r
if true then write(' unknown typekind = ', ord (typekind)) else\r
comp_error(unknown_typekind);\r
end; (* case typekind *)\r
\r
end; (* if not emitted yet *)\r
\r
end; (* with typ/typename *)\r
\r
end; (* procedure emittype *)\r
\r
\f

\r
«eof»