|
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: 61806 (0xf16e)
Types: TextFile
Names: »P5INIT.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P5INIT.PAS«
const\r
filrec_max = 256;\r
\r
default_lambda_version = 5; (* determines micro-program version *)\r
version_date= '90.03.01';\r
\r
(* const. global for pass5: *)\r
compiler_test = true; (*used for testing rc3502c changes*)\r
\r
ownpassno = 5; (* pass number of this pass *)\r
versionpass4 = 600;\r
versionpass5 = 200; (* version * 100 + subversion *) (* 860908 *)\r
\r
const_niv_0 = 0;\r
size_of_return_point = 8; (* room for activation record *)\r
(* max hw stack size *)\r
max_hw_stack = 16 ; (*bytes*)\r
\r
\r
ext_descr_size= 24; (* size of one element in the external description table in half words *)\r
\r
ext_max_routine = 150; (* max no of words (of 2 chars each) pr inline routine *)\r
ext_max_charbuf = 5000; (* number of words in charbuf *)\r
descr_max_param= 30; (* max number of parameters of a module *)\r
\r
c_size_identifier= 12;\r
\r
type\r
filrec = array[1..filrec_max] of integer;\r
\r
identifier= packed array [ 1..c_size_identifier ] of char;\r
(* type definitions from modules: *)\r
\r
usemodes = (sys_use, general_use);\r
ext_states = (ext_unused, ext_declared, ext_open, ext_closed);\r
\r
param_ptr= ^ param_descr;\r
\r
param_descr = record\r
next_param: param_ptr;\r
kind,\r
size : integer;\r
end;\r
\r
\r
ext_descr = record\r
state : ext_states;\r
mode : usemodes;\r
id : identifier;\r
\r
(* parameter description *)\r
no_of_param : integer;\r
paramptr : param_ptr; (* chain of parameters *)\r
\r
(* special variables for open routines *)\r
appetite : integer;\r
wordcount : integer; (* no of words (of 2 chars each) in open routine *)\r
firstword : integer; (* < 0: file position, > 0: index in char buf *)\r
\r
(* special variables for closed routines *)\r
no_of_uses : integer;\r
\r
(* link through ext_declared entries *)\r
decl_link : integer;\r
end; (* ext descr *)\r
\r
\r
(* case table descriptor *)\r
case_table_ptr= ^ case_table_entry;\r
case_table_entry= record\r
next_entry,\r
former_entry: case_table_ptr; (* couble chained list of case table entry descriptors *)\r
first, (* lower range value *)\r
last, (* upper range value *)\r
x_index: integer; (* label sequence number *)\r
end;\r
\r
universal_ptr= ^integer;\r
var\r
incode_filptr : ^ filrec;\r
incode_fileix : integer;\r
extcode_filptr: ^ filrec;\r
extcode_fileix: integer;\r
\r
pass5_ok : boolean;\r
in_pass5 : file of filrec;\r
out_pass5 : text;\r
ext_pass5 : file of filrec;\r
\r
lambda_version : integer;\r
\r
ext_tab_max: integer;\r
\r
case_tab_freelist: case_table_ptr;\r
\r
\r
procedure alloc_ext_tab_and_call_pass5;\r
\r
const\r
max_ext_names = 65521 div sizeof(ext_descr);\r
type\r
t_ext_tab= array [1..max_ext_names] of ext_descr;\r
var\r
needed_size : word;\r
p_ext_tab : ^ t_ext_tab;\r
\r
procedure pass5( var ext_tab: t_ext_tab; var pass5_ok : boolean );\r
\r
label\r
\r
1 ; (* exit on fatal error *)\r
\r
const\r
\r
(* repr. of standard values in Real-Time Pascal : *)\r
const_nil_var = 1; (*nilvalue for reference, pointer and shadowvariables.*)\r
(* passive value for semaphorevariables too .*)\r
jump_across_first = 4; (* used for jumping across the first instruction of a *)\r
(* routine i. e. reaad rlinetab because of conventions*)\r
value_false = 0;\r
value_true = 1;\r
(* nil field in reference and shadow variables *)\r
c_ref_field_nil = 3855 ; (* the field [15 .. 15], i.e. 256 X 15 + 15 *)\r
c_shadow_field_nil = 1799; (* 7*256 + 7 *)\r
descr_free_words = 4; (*number of unused words in descr*)\r
\r
(* definition of pass6-tokens *)\r
zbegin = 'b';\r
zendlist = '.'; (* end of declaration-list *)\r
zconst = 'c';\r
zend = 'e';\r
zline = 'l';\r
zoption= 'o';\r
zname = 'z';\r
dollar_a = '1'; (* => $a *)\r
dollar_b = '2'; (* => $b *)\r
dollar_i = '3'; (* => $i *)\r
\r
(* definition of identifiers for pass6 *)\r
c_name = 'c'; (* long constants, dope vectors *)\r
e_name = 'e'; (* external routines *)\r
l_name = 'l'; (* labels *)\r
r_name = 'r'; (* internal routine entries *)\r
x_name = 'x'; (* case labels *)\r
c12_name= 'c ';\r
e12_name= 'e ';\r
r12_name= 'r ';\r
l12_name= 'l ';\r
x12_name= 'x ';\r
\r
(* definition of used identifiers *)\r
id_entry = 'entry ';\r
id_exit = 'exit ';\r
id_exception = 'exception ';\r
id_param = 'param ';\r
id_procinf = 'procinf ';\r
id_name = 'name ';\r
id_except= 'exception ';\r
id_appeval = 'appeval ';\r
id_appstat = 'appstat ';\r
id_default_appetite = 'defapp ';\r
id_work = 'work ';\r
id_linetab = 'linetab ';\r
id_continue= 'continue ';\r
id_rep = 'rep ';\r
id_endrep = 'endrep ';\r
id_blockexit= 'blkexit '; (* destination of exit statement *)\r
(* stdcall *)\r
id_sucpred = 'sucpred ';\r
(* while *)\r
id_whrep = 'whrep ';\r
id_whexit= 'whexit ';\r
(* lock *)\r
id_size_ok= 'size_ok ';\r
id_cont = 'cont ';\r
id_exc = 'exc ';\r
(* jump across initialization of pointers in a heap object, *)\r
(* if NEW returns nil *)\r
id_nil_element = 'nilelem ';\r
id_end_nil_test= 'endnil ';\r
(* the following m-names are declared in outermost code environment *)\r
id_mstart= 'mstart '; (* offset into reference variable *)\r
id_mfirst= 'mfirst ';(* offset into buffer, first-attribute *)\r
(* if *)\r
id_ifelse = 'ifelse ';\r
id_ifexit = 'ifexit ';\r
(* repeat *)\r
id_rprep = 'rprep ';\r
id_rpcont= 'rpcont ';\r
id_rpexit= 'rpexit ';\r
(* loop *)\r
id_loop= 'loop ';\r
id_loopexit= 'loopexit ';\r
(* for *)\r
id_forrep = 'forrep ';\r
id_forstore = 'forstore ';\r
id_forcont= 'forcont ';\r
id_forexit = 'forexit ';\r
(* case *)\r
id_casetab = 'casetab ';\r
id_otherwise= 'otherwise ';\r
id_caseexit= 'caseexit ';\r
(* array-init *)\r
id_arrayrep = 'arrayrep ';\r
id_rep_exit= 'repexit ';\r
id_index_store = 'ixstore ';\r
(* name for initialization of dope vector of dynamic array *)\r
id_elems_ready = 'elemsready ';\r
(* names from lambda-environment *)\r
id_alfalength = 'alfalength ';\r
id_level = 'level ';\r
id_excode = 'excode ';\r
id_expoint = 'expoint ';\r
id_exopcode = 'exopcode ';\r
id_exic = 'exic ';\r
id_semchain = 'semchain ';\r
id_refchain = 'refchain ';\r
id_shadowchain = 'shadowchain ';\r
id_processchain = 'processchain';\r
id_osem = 'osem ';\r
id_oref = 'oref ';\r
id_oshadow = 'oshadow ';\r
id_cpexcfirst = 'cpexcfirst ';\r
id_exappetite = 'exappetite ';\r
id_exitappetite= 'exitappetite';\r
id_maxstack = 'maxstack ';\r
id_bonappetite = 'bonappetite ';\r
id_plinetab = 'plinetab ';\r
(* offsets in the processdescriptor *)\r
id_opd_count = 'opdcount ';\r
id_opd_param = 'opdparam ';\r
id_opd_linked = 'opdlinked ';\r
id_opd_procinf = 'opdprinf ';\r
id_opd_name = 'opdname ';\r
id_opd_process = 'opdprocess ';\r
(* misc *)\r
id_hardset = 'hardset ';\r
\r
\r
c_size_opcode = 6;\r
c_size_identifier = 12;\r
c_size_option_list = 10;\r
\r
\r
(* exception no. , relative to the symbol cpexcfirst ( see: lambdaenv ) : *)\r
c_exc_case = 0; (* label not found and no otherwise *)\r
c_exc_succ = 1; (* succ exceeds upper value *)\r
c_exc_pred = 2; (* pred exceeds lower value *)\r
c_exc_with = 3; (* size error, new type greater than original type *)\r
c_exc_lock = 4; (* size error, new type greater than actual buffer(first..top) *)\r
c_exc_ref = 5; (* reference variable not nil at routine exit *)\r
c_exc_shadow = 6; (* shadow variable not nil at routine exit *)\r
c_exc_new= 7; (* not enough memory to satisfiy the request *)\r
\r
c_exc_max = 47;\r
\r
(* constants in pass 4 code *)\r
\r
(* value of type_v in pass 4 code *)\r
\r
byte_typ = 1; field_typ = 5;\r
word_typ = 2; addr_typ = 6;\r
point_typ= 3; set_typ = 7;\r
double_typ = 4; dyn_typ = 8;\r
\r
(* values of type_o in pass 4 code *)\r
\r
bool_typ = 1; int_typ = 2; real_typ = 3; setof_typ = 4;\r
pointer_typ = 5; sem_typ = 6; ref_typ = 7; shadow_typ = 8;\r
scalar_typ = 9;\r
\r
(* compare function number in pass 4 code *)\r
\r
xeq = 2; xne = 3; xlt = 4; \r
xgt = 5; xle = 6; xge = 7;\r
xeq_set = 8; xne_set = 9; xle_set = 10;\r
xge_set = 11; xin = 12; xeq_struc = 13;\r
xne_struc = 14; \r
\r
(* std function number in pass 4 code *)\r
\r
xord= 1; xsucc= 2; xpred= 3; xchr= 4; xnil= 5; xnilref (* only used in rev c *)= 6;\r
xnew = 7;\r
\r
(* mode for for statement *)\r
\r
xup = 1; xdown = 2;\r
\r
(* export name type *)\r
\r
offset_type = 1; value_type = 2;\r
\r
(* end pass 4 code constants *)\r
\r
\r
\r
\r
\r
(* const. local to modules: *)\r
\r
byte_length = 1;\r
word_length = 2; (* length of integer and word = 2 bytes *)\r
pointer_length = 3; (*length of pointer = 3 bytes *)\r
trapenter = 1; (*parameter for mtrh instruction*)\r
trapreturn = 2;(*parameter for mtrh instruction*)\r
\r
(* offsets in anonymous object created in conjunction with lockmes statement *)\r
(* offsets are pointer_length+0, 2, and 4 *)\r
lockmes_first_offset= 3; (* the object is a record with the buffer pointer as first field *)\r
lockmes_last_offset= 5; (* followed by first and last+1, the values from the attribute part of the buffer *)\r
lockmes_top_offset= 7; (* and the computed top value (first + size of new type) *)\r
\r
\r
\r
(* type definitions global for pass5: *)\r
\r
type\r
\r
option_list = record\r
no_of_options : integer;\r
options : array [ 1 .. c_size_option_list ] of\r
record\r
pno, p1, p2 : integer;\r
end;\r
end;\r
\r
opcode = (op_aaaaa ,op_abs ,op_add ,op_and ,\r
op_cexch ,op_cgreg ,op_compl ,op_coutwq,\r
op_crget ,op_crput ,op_csell ,op_div ,\r
op_eq ,op_ge ,op_gt ,op_index ,\r
op_indh0 ,op_indh01,op_indh02,op_indh1 ,\r
op_indh11,op_indh12,op_inpdv ,op_inth0 ,\r
op_intpa ,op_intrs ,op_iocda ,op_iorsc ,\r
op_jmcht ,op_jmpga ,op_jmprw ,op_jmzeq ,\r
op_jmzge ,op_jmzgt ,op_jmzle ,op_jmzlt ,\r
op_jmzne ,op_le ,op_llock ,op_lrele ,\r
op_lrese ,op_lt ,op_madd ,op_mod ,\r
op_moveb ,op_movebs,op_moveg ,op_msub ,\r
op_mtrh ,op_mtrs ,op_mul ,op_ne ,\r
op_neg ,op_not ,op_or ,op_pcals ,\r
op_pcals0,op_pcals1,op_pexit ,op_reaad ,\r
op_readb ,op_readw ,op_reagd ,op_reaid ,\r
op_reaisd,op_reald ,op_reard ,op_reasd ,\r
op_reaxd ,op_rechd ,op_rechw ,op_renhb ,\r
op_renpb ,op_restc ,op_revga ,op_revgb ,\r
op_revgd ,op_revgw ,op_revla ,op_revlb ,\r
op_revld ,op_revlw ,op_revpd ,op_revpw ,\r
op_revsa ,op_revsb ,op_revsd ,op_revsf ,\r
op_revsm ,op_revsw ,op_setad ,op_setatm,\r
op_setcr ,op_setdi ,op_seteq ,op_setin ,\r
op_setre ,op_setsb ,op_setsp ,op_setst ,\r
op_settm ,op_setun ,op_shc ,op_stcea ,op_stnhb ,\r
op_ststc ,op_stvga ,op_stvgb ,op_stvgd ,\r
op_stvgw ,op_stvla ,op_stvlb ,op_stvld ,\r
op_stvlw ,op_stvsa ,op_stvsb ,op_stvsd ,\r
op_stvsf ,op_stvsw ,op_sub ,op_teqad ,\r
op_tnill ,op_uadd ,op_uadhw ,op_udiv ,\r
op_ult ,op_umod ,op_umul ,op_usub ,\r
op_xor ,op_xxxxx);\r
opcode_range = op_aaaaa .. op_xxxxx;\r
\r
\r
exc_code = 0 .. c_exc_max;\r
\r
\r
context = record\r
niv : integer;\r
stack_size : integer;\r
max_stack_size : integer;\r
end;\r
\r
frame_kind = (g_frame, l_frame, i_frame, s_frame);\r
\r
addr_kind_type = ( addr, stack_addr, packed_arr );\r
\r
varvalue_descr = record\r
kind : integer;\r
size : integer;\r
val : integer;\r
end;\r
\r
varaddr_descr = record\r
kind : addr_kind_type;\r
access : frame_kind;\r
niv : integer;\r
offset : integer;\r
size : integer\r
end;\r
\r
instruction_type =(normal,\r
empty_stack, (*emties the stack after execution*)\r
open_instr , (*requires 2 extra stack elements not allowed in pass5 *)\r
hw_instr , (* hw instruction not allowed in pass5 *)\r
set_instr , (* only simple operands on stack *)\r
set_only_sw, (*only swstack shall be manipulated*)\r
set_hw_word ); (* only simple operands on stack.Move one word on stack after instruction *)\r
\r
\r
opcode_def = record\r
opname : array [ 1 .. c_size_opcode ] of char;\r
opappetite, (* stack movement *)\r
min_hw_stack: (* required elements on stack before execution *) integer;\r
op_type : instruction_type;\r
end;\r
\r
pass4codes =\r
( xfirstcode,\r
\r
xmodule, xeom,\r
xoption, xnewline,\r
\r
xprocess, xextprocess,\r
xblock, xlength, xendblock,\r
\r
xbegincode, xcodeline, xendcode,\r
\r
xsubdef,\r
xarray1template, xarray2template, xarray3template,\r
xrecordtemplate, xfieldsize, xdynfieldsize, xincfield,\r
xendtemplate,\r
xenddecl,\r
\r
xallocdynvar,\r
\r
xinitialize, xstrucinit, xsimpleinit, xsetinit,\r
xexception, xextexception,\r
xsysinit, xsysdyninit,\r
xsysnewinit,\r
xfieldinit, xdynfieldinit,\r
xendinitfields,\r
xarrayinit, xarraydyninit,\r
xpoolinit,\r
xvarinit,\r
\r
xexport,\r
\r
xproc, xextproc,\r
xfunc, xextfunc,\r
xparamtype,\r
\r
xdeflix,\r
\r
xproccall, xendpcall,\r
xextproccall, xstdproccall,\r
xprocessparam, xendprocessparam,\r
xstdfunccall, xfcall, xendfunccall,\r
xfunccall, xextfunccall,\r
xendnewcall,\r
\r
xvarpointer, xtempointer, xarglistsize,\r
\r
xvarparam, xvalueparam, xreturnparam,\r
\r
xassignstat, xleft, xassign,\r
\r
xcasestat, xcase, xendcaselist, xendcasestat, xendcase,\r
xcaserange, xcaselabel, xotherwise,\r
\r
xforstat, xleftfor, xforstore, xdo, xendfor,\r
\r
xgoto,\r
\r
xifstat, xifexpr, xelse, xif,\r
\r
xrepeat, xuntil, xendrepeat,\r
\r
xloopstat, xendloopstat, xcontloopstat, xexitloopstat,\r
xexitstat,\r
\r
xwhile, xwhileexpr, xendwhile,\r
\r
xwithstat, xwithvar, xwithdynvar, xendwith, xnoretype, xretype, xdynretype,\r
\r
xlockstat, xlockvar, xlockdynvar, xendlock,\r
\r
xlockmesstat, xexitlock,\r
\r
xchannel, xchanvar, xendchannel,\r
\r
xexchstat, xexchange,\r
\r
xnot, xneg, xcompare, xcompstruc, xcompdynstruc, xdiv,\r
xmul, xshift, xrotate, xmod, xor_, xxor,\r
xadd, xsub, xand, xrangetest,\r
xdynrangetest,\r
\r
xconst, xlconst, xsetconst,\r
xset, xinclude, xsetexpr, xincludeint, xendset,\r
\r
xinitconst,\r
\r
xindvar, \r
\r
xaddr, xcaddr, xindaddr, \r
xpackedarr,\r
\r
xfield, xdynfield,\r
\r
xindexexpr, xcindex, xindex,\r
\r
xerror, xerrorno, xerrortext,\r
xrangemax, xhindex,\r
xlastcode\r
\r
);\r
pass4codeindex = 0..160;\r
\r
\f
\r
\r
(* end pass 4 codes *)\r
\r
\r
\r
\r
pass5errors = (\r
ext_table_size, (* ext_tab_max too small *)\r
ext_param_number, (* error in user program *)\r
param_number, (* error in user program *)\r
v_stack_size, (* max_v_stack too small *)\r
case_label_error, (* error in user program *)\r
compiler_error, (* error in this pass *)\r
overflow, (* hw stack overflow*)\r
wrong_version, (* wrong pass4-pass5 combination *)\r
inconsistent_use, (* error in user program *)\r
param_error, (* inconsistent params in open routine *)\r
param_table_full, (* max_param_table too small *)\r
pass4code_error, (* error in input data from pass4 *)\r
moveg_warning (* WARNING about use of open procedure 'moveg' *)\r
);\r
hw_errors = (open_routine, (*hwstack inconsistence in code for open routine*)\r
set_instruction, (*hwstack inconsistence before set instruction*)\r
simple_open_function,(* as open_routine*)\r
array_init, (*inconsistence at jump to label in code_array_init*)\r
shadow_removal, (*inconsistence at jump to label in code_shadow_remove*)\r
ref_removal (*inconsistence at jump to label in code_ref_remove*)\r
);\r
\r
\r
\r
callmodes = (int_call, ext_call, open_call, std_call);\r
\r
\r
stat_acc_rec =\r
record\r
\r
assign :\r
record\r
\r
kind_type : array [ addr_kind_type, 0 .. 6 ] of integer;\r
size : array [ 0 .. 15 ] of integer\r
\r
end;\r
\r
end;\r
\r
trap_table_type = record\r
trap_entry : array [ 0 .. 255 ] of integer\r
end;\r
(*index types for op_stv, and op_rev tables*)\r
\r
frames = (g, (*global*)\r
l, (*local*)\r
s);(*stack*)\r
\r
types = (b, (*byte*)\r
w, (*word*)\r
a, (*pointer i.e. address*)\r
d);(*double*)\r
\r
base_types = byte_typ..double_typ;\r
\r
\r
\r
(* var. declarations global for pass5: *)\r
\r
\r
var\r
heapfree: longint;\r
\r
preserve_option,\r
prolog_yes, epilog_yes, compress_yes, callpass6_yes, statacc_yes, summary_yes,\r
measurement_yes, trap_code,\r
dyn_eval_stack,\r
heap_init, (* true during sys init call in conjunction with new-call *)\r
openroutine_yes: boolean;\r
\r
hw_stack_size : integer; (* hw stack pointer to top *)\r
old_hw : integer; (*used for storing hw_stack_size before entrance to open routines*)\r
\r
\r
trap_nr_table : ^ trap_table_type;\r
current_trap_nr,\r
no_of_measure_recs : integer;\r
\r
\r
\r
descr : record\r
\r
(* in this variable the Descriptor Segment, part 1 is accumulated. *)\r
\r
kind : integer;\r
name : identifier;\r
(*process inf*)\r
\r
entry_point,\r
exception_point : identifier;\r
\r
default_appetite : integer;\r
\r
last_param_offset: integer;\r
free_words : array [1..descr_free_words] of integer;\r
\r
no_of_params : integer;\r
param : array [ 1 .. descr_max_param ] of param_descr;\r
\r
end (* descr *);\r
\r
enforced_create_size : integer;\r
(* if defined (option 10) then suppress computed default appetite *)\r
enforced_exception_app : integer;\r
\r
\r
\r
exc_hard : set of exc_code;\r
\r
exc_descr : record\r
\r
state : integer;\r
internal : boolean;\r
key : integer;\r
niv,\r
lix : integer\r
\r
end;\r
\r
c : context;\r
in_kind : (setatm,settm); (*used to choose right instruction*)\r
\r
operand_situation: ( before_opands, after_short_const, after_opands );\r
\r
\r
\r
\r
\r
\r
(* var. declarations from the modules: *)\r
\r
in_item_count, in_line_no : integer;\r
in_options : option_list;\r
token: pass4codes;\r
convert_in_code : array [ pass4codeindex ] of pass4codes;\r
\r
\r
mess_summ_state : integer;\r
\r
out_state, out_pos : integer;\r
\r
out_line_state : boolean;\r
out_special : boolean;\r
\r
not_resolved : integer; (* links through all ext_declared *)\r
\r
file_position: integer; (* < 0: before reset, else position in library file *)\r
\r
ext_open_codes:\r
record\r
cur_word_ptr : integer; (* points at first free word in charbuf *)\r
charbuf : array [ 1 .. ext_max_charbuf ] of integer;\r
end;\r
\r
\r
stat_acc : stat_acc_rec;\r
\r
\r
type\r
t_op_table = array[opcode_range] of opcode_def;\r
const\r
op_table : t_op_table = (\r
(opname:'aaaaa '; opappetite: 0; min_hw_stack: 0; op_type: normal ),\r
(opname:'abs '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'add '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'and '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'cexch '; opappetite: -8; min_hw_stack: 8; op_type: normal ),\r
(opname:'cgreg '; opappetite: 2; min_hw_stack: 0; op_type: normal ),\r
(opname:'compl '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'coutwq'; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'crget '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'crput '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'csell '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'div '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'eq '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'ge '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'gt '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'index '; opappetite: -6; min_hw_stack: 10; op_type: normal ),\r
(opname:'indh0 '; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'indh01'; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'indh02'; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'indh1 '; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'indh11'; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'indh12'; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'inpdv '; opappetite: -2; min_hw_stack: 8; op_type: normal ),\r
(opname:'inth0 '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'intpa '; opappetite: -2; min_hw_stack: 10; op_type: normal ),\r
(opname:'intrs '; opappetite: -4; min_hw_stack: 6; op_type: normal ),\r
(opname:'iocda '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'iorsc '; opappetite: -4; min_hw_stack: 6; op_type: normal ),\r
(opname:'jmcht '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'jmpga '; opappetite: 0; min_hw_stack: 0; op_type: normal ),\r
(opname:'jmprw '; opappetite: 0; min_hw_stack: 0; op_type: normal ),\r
(opname:'jmzeq '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'jmzge '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'jmzgt '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'jmzle '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'jmzlt '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'jmzne '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'le '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'llock '; opappetite: -2; min_hw_stack: 6; op_type: normal ),\r
(opname:'lrele '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'lrese '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'lt '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'madd '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'mod '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'moveb '; opappetite:-10; min_hw_stack: 10; op_type: normal ),\r
(opname:'movebs'; opappetite:-10; min_hw_stack: 10; op_type: normal ),\r
(opname:'moveg '; opappetite:-10; min_hw_stack: 10; op_type: normal ),\r
(opname:'msub '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'mtrh '; opappetite: 0; min_hw_stack: 0; op_type: normal ),\r
(opname:'mtrs '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'mul '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'ne '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'neg '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'not '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'or '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'pcals '; opappetite: -4; min_hw_stack: 4; op_type:empty_stack),\r
(opname:'pcals0'; opappetite: 0; min_hw_stack: 0; op_type:empty_stack),\r
(opname:'pcals1'; opappetite: 0; min_hw_stack: 0; op_type:empty_stack),\r
(opname:'pexit '; opappetite: 0; min_hw_stack: 0; op_type: normal ),\r
(opname:'reaad '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'readb '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'readw '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'reagd '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'reaid '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'reaisd'; opappetite: 0; min_hw_stack: 4; op_type: normal ),\r
(opname:'reald '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'reard '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'reasd '; opappetite: 0; min_hw_stack: 4; op_type: normal ),\r
(opname:'reaxd '; opappetite: 4; min_hw_stack: 0; op_type:empty_stack),\r
(opname:'rechd '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'rechw '; opappetite: 2; min_hw_stack: 0; op_type: normal ),\r
(opname:'renhb '; opappetite: 0; min_hw_stack: 0; op_type:empty_stack),\r
(opname:'renpb '; opappetite: -2; min_hw_stack: 2; op_type:empty_stack),\r
(opname:'restc '; opappetite: 0; min_hw_stack: 0; op_type:hw_instr),\r
(opname:'revga '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'revgb '; opappetite: 2; min_hw_stack: 0; op_type: normal ),\r
(opname:'revgd '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'revgw '; opappetite: 2; min_hw_stack: 0; op_type: normal ),\r
(opname:'revla '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'revlb '; opappetite: 2; min_hw_stack: 0; op_type: normal ),\r
(opname:'revld '; opappetite: 4; min_hw_stack: 0; op_type: normal ),\r
(opname:'revlw '; opappetite: 2; min_hw_stack: 0; op_type: normal ),\r
(opname:'revpd '; opappetite: 4; min_hw_stack: 4; op_type: normal ),\r
(opname:'revpw '; opappetite: 2; min_hw_stack: 2; op_type: normal ),\r
(opname:'revsa '; opappetite: 0; min_hw_stack: 4; op_type: normal ),\r
(opname:'revsb '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'revsd '; opappetite: 0; min_hw_stack: 4; op_type: normal ),\r
(opname:'revsf '; opappetite: -4; min_hw_stack: 6; op_type: normal ),\r
(opname:'revsm '; opappetite: -6; min_hw_stack: 6; op_type:empty_stack),\r
(opname:'revsw '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'setad '; opappetite: -2; min_hw_stack: 2; op_type:set_instr),\r
(opname:'setatm'; opappetite: -6; min_hw_stack: 8; op_type: normal ),\r
(opname:'setcr '; opappetite: -4; min_hw_stack: 4; op_type:empty_stack),\r
(opname:'setdi '; opappetite: 0; min_hw_stack: 0; op_type:set_instr),\r
(opname:'seteq '; opappetite: 2; min_hw_stack: 0; op_type:set_instr),\r
(opname:'setin '; opappetite: 0; min_hw_stack: 0; op_type:set_instr),\r
(opname:'setre '; opappetite: -4; min_hw_stack: 6; op_type:empty_stack),\r
(opname:'setsb '; opappetite: 2; min_hw_stack: 0; op_type:set_instr),\r
(opname:'setsp '; opappetite: 2; min_hw_stack: 0; op_type:set_instr),\r
(opname:'setst '; opappetite: -6; min_hw_stack: 0; op_type:set_only_sw),\r
(opname:'settm '; opappetite: 0; min_hw_stack: 0; op_type:set_hw_word),\r
(opname:'setun '; opappetite: 0; min_hw_stack: 0; op_type:set_instr),\r
(opname:'shc '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'stcea '; opappetite: -8; min_hw_stack: 10; op_type: normal ),\r
(opname:'stnhb '; opappetite: 0; min_hw_stack: 0; op_type:empty_stack),\r
(opname:'ststc '; opappetite: 0; min_hw_stack: 0; op_type:hw_instr),\r
(opname:'stvga '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'stvgb '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'stvgd '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'stvgw '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'stvla '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'stvlb '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'stvld '; opappetite: -4; min_hw_stack: 4; op_type: normal ),\r
(opname:'stvlw '; opappetite: -2; min_hw_stack: 2; op_type: normal ),\r
(opname:'stvsa '; opappetite: -8; min_hw_stack: 8; op_type: normal ),\r
(opname:'stvsb '; opappetite: -6; min_hw_stack: 6; op_type: normal ),\r
(opname:'stvsd '; opappetite: -8; min_hw_stack: 8; op_type: normal ),\r
(opname:'stvsf '; opappetite: -8; min_hw_stack: 8; op_type: normal ),\r
(opname:'stvsw '; opappetite: -6; min_hw_stack: 6; op_type: normal ),\r
(opname:'sub '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'teqad '; opappetite: -6; min_hw_stack: 8; op_type: normal ),\r
(opname:'tnill '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'uadd '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'uadhw '; opappetite: 0; min_hw_stack: 2; op_type: normal ),\r
(opname:'udiv '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'ult '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'umod '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'umul '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'usub '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'xor '; opappetite: -2; min_hw_stack: 4; op_type: normal ),\r
(opname:'xxxxx '; opappetite: 0; min_hw_stack: 0; op_type: normal ) );\r
type\r
fr_type = array[frame_kind] of frames;\r
const\r
conv_frame : fr_type = (\r
g(*g_frame*),\r
l(*l_frame*),\r
s(*i_frame*), (*not used*)\r
s(*s_frame*));\r
\r
type\r
mc_type = array[base_types] of types;\r
const\r
conv_type : mc_type = (\r
b(*byte_typ*),\r
w(*word_typ*),\r
a(*point_typ*),\r
d(*double_typ*));\r
\r
type\r
stv_rev_type = array[g..s,b..d] of opcode;\r
(*op_stv and op_rev contains the instructions rev.. and stv..*)\r
const\r
op_stv : stv_rev_type = (\r
(op_stvgb,op_stvgw,op_stvga,op_stvgd),\r
(op_stvlb,op_stvlw,op_stvla,op_stvld),\r
(op_stvsb,op_stvsw,op_stvsa,op_stvsd) );\r
\r
op_rev : stv_rev_type = (\r
(op_revgb,op_revgw,op_revga,op_revgd),\r
(op_revlb,op_revlw,op_revla,op_revld),\r
(op_revsb,op_revsw,op_revsa,op_revsd) );\r
\r
type\r
op_comp_type = array[1..11] of opcode;\r
const\r
op_comp : op_comp_type = (\r
op_ult, op_eq, op_ne, op_lt, op_gt, op_le, op_ge,\r
op_seteq, op_seteq,\r
op_setsb, op_setsp );\r
\r
type\r
op_indh_type = array[0..1,0..2] of opcode;\r
const\r
op_indh : op_indh_type = (\r
(op_indh0,op_indh01,op_indh02),\r
(op_indh1,op_indh11,op_indh12) );\r
\r
\r
\r
(* procedure declarations global for pass5: *)\r
\r
\r
\r
procedure eom;\r
begin\r
writeln (out_pass5);\r
close (in_pass5);\r
if not preserve_option then\r
begin\r
erase(in_pass5);\r
assign(in_pass5, concat(path1_name, o_pass4_nixname));\r
erase(in_pass5);\r
end;\r
flush(out_pass5);\r
close (out_pass5);\r
(*$I-*)\r
close (ext_pass5);\r
(*$I+*)\r
if ioresult = 0 then;\r
end;\r
\r
\r
procedure printhead;\r
begin\r
write ('*** pass 5 line ', in_line_no:4, ', ');\r
end;\r
\r
\r
procedure printstatus;\r
begin\r
writeln (' token =', ord(token));\r
writeln (' no of items=', in_item_count);\r
writeln (' stack =', c.stack_size);\r
writeln(' hw stack size=',hw_stack_size);\r
end;\r
\r
\r
procedure error_this_pass (e: pass5errors);\r
begin\r
write('compiler error, error code = ', ord(e):1);\r
end;\r
\r
\r
procedure abort (e: pass5errors);\r
begin\r
write ('compilation terminated by ');\r
case e of\r
ext_table_size: writeln ('external routine table overflow');\r
ext_param_number: writeln ('too many params in declaration');\r
v_stack_size: writeln ('operand stack overflow');\r
pass4code_error: writeln ('pass 4 code error');\r
param_table_full: writeln ('external routine param table full');\r
compiler_error: writeln ('inconsistency in pass5');\r
overflow: writeln('hardware stack overflow');\r
wrong_version: writeln ('wrong pass4/pass5 combination');\r
else error_this_pass(e);\r
end;\r
printstatus;\r
eom; rtphalt(true);\r
end;\r
\r
\r
procedure error (e: pass5errors);\r
const stars= '********************* ';\r
begin\r
printhead;\r
case e of\r
case_label_error: writeln ('+decl caselabel');\r
param_number: writeln ('too many formal parameters');\r
inconsistent_use: writeln ('user is not allowed to call system-routines');\r
moveg_warning: begin\r
writeln('WARNING, Call of PROCEDURE moveg.');\r
writeln(stars, 'You are breaking the RTP security.');\r
writeln(stars, 'Try to find another solution');\r
writeln(stars, 'inside the RTP language !!');\r
end;\r
else abort(e);\r
end;\r
pass5_ok := pass5_ok and (e=moveg_warning);\r
end;\r
\r
\r
procedure evalstack_error;\r
begin\r
printhead;\r
writeln ('evaluation stack error');\r
printstatus;\r
c.stack_size := 0;\r
hw_stack_size := 0;\r
end;\r
procedure table_error(op: opcode);\r
begin\r
with op_table[op] do\r
begin\r
writeln('error in opcodetable:',opname);\r
writeln('opappetite:',opappetite:2,' min_hw_stack:',min_hw_stack:2);\r
end;\r
end;\r
\r
procedure out_comment(str:string);\r
forward;\r
\r
procedure hw_stack_error(err:hw_errors);\r
begin\r
out_comment('****PASS5 HWSTACKERROR****');\r
writeln('error in hw stack evaluation.');\r
case err of\r
set_instruction: writeln('occured in out_opcode. hwstacksize too big for setinstruction');\r
open_routine: writeln('occoured in generating code for open routine.');\r
simple_open_function: writeln('occoured in generating code for simple open function.');\r
array_init: writeln('occurred when generating code for arrays with systemcomponents');\r
ref_removal: writeln('occurred when generating code for ref removal');\r
shadow_removal: writeln('occured when generating code for shadow removal');\r
end;\r
writeln('hw_stack_size is:',hw_stack_size:3);\r
end;\r
\r
\r
\r
procedure context_eval( change : integer );\r
\r
begin\r
\r
with c do\r
begin\r
\r
stack_size := stack_size + change;\r
if stack_size > max_stack_size then max_stack_size := stack_size\r
\r
end\r
\r
end;\r
\r
\r
\r
\r
(* procedure declarations from the modules: *)\r
\r
\r
procedure extin(var n: integer);\r
begin\r
extcode_fileix := extcode_fileix + 1;\r
if extcode_fileix > filrec_max then\r
begin\r
read(ext_pass5, extcode_filptr^);\r
extcode_fileix := 1;\r
end;\r
(*$R-*)\r
n := swap(extcode_filptr^[extcode_fileix]);\r
(*$R+*)\r
end;\r
\r
procedure passin(var n: integer);\r
begin\r
incode_fileix := incode_fileix + 1;\r
if incode_fileix > filrec_max then\r
begin\r
read(in_pass5, incode_filptr^);\r
incode_fileix := 1;\r
end;\r
n := incode_filptr^[incode_fileix];\r
end;\r
\r
procedure get_token;\r
\r
var\r
found : boolean;\r
pass5_yes : boolean;\r
no1, no2, passno : integer;\r
\r
begin\r
\r
found := false;\r
\r
repeat\r
begin\r
\r
passin(no1);\r
token := convert_in_code [ no1 ];\r
(*$R-*)\r
in_item_count := in_item_count + 1;\r
(*$R+*)\r
\r
case token of\r
xoption:\r
begin\r
\r
passin(passno );\r
passin(no1 );\r
passin(no2 );\r
(*$R-*)\r
in_item_count := in_item_count + 3;\r
(*$R+*)\r
pass5_yes := no2 <> 0;\r
\r
if passno = 5 then\r
case no1 of\r
1: prolog_yes := pass5_yes;\r
2: epilog_yes := pass5_yes;\r
3: statacc_yes := pass5_yes;\r
4: compress_yes := pass5_yes;\r
5: callpass6_yes := pass5_yes;\r
6: summary_yes := pass5_yes;\r
7: enforced_exception_app := no2;\r
8: lambda_version := no2;\r
9: openroutine_yes := pass5_yes;\r
10: enforced_create_size := no2;\r
11: measurement_yes := pass5_yes;\r
12: preserve_option:= pass5_yes;\r
else ; (* blind *)\r
end\r
else\r
with in_options do\r
begin\r
\r
if passno = 0 then (* version identification *)\r
if no1 = 4 (* pass 4 *) then\r
if (no2 div 100 <> versionpass4 div 100) or\r
(no2 mod 100 < versionpass4 mod 100) then\r
error (wrong_version);\r
\r
if out_state = 1 (* after newline *) then\r
writeln (out_pass5, 'o.', passno:3, no1:7, no2:7, '.')\r
else\r
\r
if no_of_options < c_size_option_list then\r
begin\r
\r
out_special := true;\r
\r
no_of_options := no_of_options + 1;\r
with options [ no_of_options ] do\r
begin\r
pno := passno;\r
p1 := no1;\r
p2 := no2;\r
end;\r
\r
end\r
\r
end\r
end;\r
xnewline:\r
begin\r
\r
passin(in_line_no);\r
(*$R-*)\r
in_item_count := in_item_count + 1;\r
(*$R+*)\r
\r
out_special := true;\r
out_line_state := true;\r
end;\r
else found := true;\r
end;\r
\r
end\r
until found;\r
\r
end; (* get_token *)\r
\r
\r
procedure skip_token (t: pass4codes);\r
begin\r
if token <> t then error (pass4code_error);\r
get_token;\r
end;\r
\r
\r
function in_integer : integer;\r
\r
var i : integer;\r
\r
begin\r
passin( i );\r
(*$R-*)\r
in_item_count := in_item_count + 1;\r
(*$R+*)\r
in_integer := i;\r
end;\r
\r
\r
procedure in_identifier( var ident : identifier );\r
\r
var\r
i, j, w : integer;\r
\r
begin\r
\r
i := 1;\r
\r
for j := 1 to 12 do\r
begin\r
\r
passin( w );\r
(*$R-*)\r
in_item_count := in_item_count + 1;\r
(*$R+*)\r
\r
if i <= c_size_identifier then\r
begin\r
\r
ident[ i ] := chr( w );\r
i := i + 1\r
\r
end;\r
\r
end;\r
\r
while i <= c_size_identifier do\r
begin\r
\r
ident[ i ] := ' ';\r
i := i + 1\r
\r
end;\r
\r
end (* in_identifier *);\r
\r
\r
procedure in_init;\r
var token: pass4codes;\r
begin\r
\r
(* initialize conversion-table *)\r
for token := xfirstcode to xlastcode do\r
begin\r
in_item_count := ord(token);\r
convert_in_code [ in_item_count ] := token;\r
end;\r
\r
assign(in_pass5, concat(path1_name, o_pass4_codename));\r
(*$I-*)\r
reset(in_pass5);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(path1_name, o_pass4_codename));\r
end;\r
(*$I+*)\r
incode_fileix := filrec_max;\r
in_item_count := 0;\r
in_line_no := 0;\r
in_options.no_of_options := 0;\r
\r
(* read first token *)\r
get_token;\r
\r
out_line_state := false; (* suppress previous reading of linenumbers *)\r
end;\r
\r
\r
\r
\r
procedure mess_summary_line( name : identifier; head_line, begin_line, end_line : integer;\r
appetite : integer; dynamic_variables : boolean ; process_appetite : integer );\r
\r
var\r
dyn_mark : alfa;\r
\r
begin\r
\r
if summary_yes then\r
begin\r
\r
if mess_summ_state = 0 then\r
begin\r
\r
(* print a header for the summary : *)\r
writeln(output);\r
writeln(output, 'Information survey from REAL-TIME PASCAL, pass5, version ',\r
version_date);\r
\r
writeln;\r
writeln( ' name headline beginline endline appetite(words) default create-size');\r
writeln;\r
\r
mess_summ_state := 1\r
\r
end;\r
if dynamic_variables then\r
dyn_mark := '+ dynamic '\r
else\r
dyn_mark := ' ';\r
\r
write( ' ', name );\r
if head_line = -1 (* external routine *) then\r
write( ' external, called ', appetite : 2, ' time(s) ')\r
else\r
write( head_line : 6, begin_line : 10, end_line : 8, ' : ', appetite div 2 : 6\r
, dyn_mark );\r
if process_appetite <> 0 then\r
write( process_appetite : 12 );\r
writeln;\r
\r
end\r
\r
end;\r
\r
procedure out_nl;\r
var\r
i : integer;\r
\r
begin\r
writeln( out_pass5 );\r
\r
out_state := 1; out_pos := 0;\r
\r
if out_special then\r
begin\r
\r
out_special := false;\r
\r
with in_options do\r
if no_of_options > 0 then\r
begin\r
for i := 1 to no_of_options do\r
with options [ i ] do\r
writeln (out_pass5, 'o.', pno:3, p1:7, p2:7, '.');\r
no_of_options := 0;\r
end;\r
\r
if out_line_state then\r
begin\r
writeln( out_pass5, 'l. ', in_line_no : 1);\r
out_line_state := false\r
end;\r
\r
end;\r
\r
end;\r
\r
\r
procedure out_char( chr : char );\r
\r
begin\r
write( out_pass5, chr );\r
out_pos := out_pos + 1\r
end;\r
\r
procedure out_tab( pos : integer );\r
\r
begin\r
if out_pos < pos then\r
begin\r
write( out_pass5, ' ' : pos - out_pos);\r
out_pos := pos;\r
end\r
end;\r
\r
\r
procedure out_integer( i : integer );\r
\r
begin\r
if (i > 999) or (i < -99) then\r
begin\r
write (out_pass5, i : 6); out_pos := out_pos + 6;\r
end\r
else\r
begin\r
write (out_pass5, i : 4); out_pos := out_pos + 4;\r
end;\r
end;\r
\r
\r
procedure out_identifier( id : identifier );\r
\r
var\r
i, n : integer;\r
\r
begin\r
\r
n := c_size_identifier;\r
while ( id[ n ] = ' ' ) and ( n > 1 ) do n := n - 1;\r
\r
write(out_pass5, ' ');\r
for i := 1 to n do write( out_pass5, id[i]);\r
out_pos := out_pos + n + 1;\r
\r
end;\r
\r
\r
procedure out_def( id : identifier );\r
\r
begin\r
if out_state <> 1 then out_nl;\r
\r
out_identifier ( id );\r
write( out_pass5, '= ' ); out_pos := out_pos + 2;\r
\r
out_state := 6\r
end;\r
\r
\r
procedure out_label( id : identifier );\r
\r
begin\r
if out_state <> 1 then out_nl;\r
\r
out_identifier( id );\r
write( out_pass5, ': ' ); out_pos := out_pos + 2;\r
\r
out_state := 2\r
end;\r
\r
\r
procedure out_lix (id_letter: char; index: integer);\r
begin\r
write (out_pass5, id_letter:2, '#', index:1);\r
out_pos := out_pos + 4; (* assume normally two-digit indices... *)\r
end;\r
\r
\r
procedure out_lix_label (id_letter: char; index: integer);\r
begin\r
out_nl;\r
out_lix (id_letter, index);\r
out_label (' ');\r
end;\r
\r
\r
procedure out_comment( str : string );\r
var n: integer;\r
\r
begin\r
if out_state <> 5 then\r
begin\r
if not compress_yes then out_tab( 25 );\r
write( out_pass5, '; ' ); out_pos := out_pos + 2;\r
end;\r
if not compress_yes then\r
begin\r
n := length(str);\r
while (str [ n ] = ' ') and (n > 1) do n := n-1;\r
write (out_pass5, str:n);\r
out_pos := out_pos + n;\r
end;\r
\r
out_state := 5\r
end;\r
\r
\r
procedure out_start_param;\r
\r
begin\r
case out_state of\r
3: out_state := 4;\r
4: out_char(',');\r
else error (compiler_error);\r
end;\r
end;\r
\r
procedure out_resta(request:integer);\r
(*outputs a restore instruction i. e. the hardware stack will contain\r
exactly request elements after the instruction *)\r
begin\r
if request > max_hw_stack then error(overflow);\r
if out_state<>1 then out_nl;\r
write (out_pass5,'resta');\r
write (out_pass5,request:4);\r
hw_stack_size := request;\r
out_state := 3;\r
end;\r
\r
procedure hw_stack_adjust(min_request,adjustment:integer);\r
(*checks if the hwstack has to be pushed or poped and does so if nessesary *)\r
begin\r
if hw_stack_size < min_request then\r
(*not enough elements i. e. push some elements to the stack *)\r
out_resta(min_request)\r
else\r
if (hw_stack_size + adjustment) > max_hw_stack then\r
(*overflow : leave 2 words on stack *)\r
out_resta(2*word_length);\r
\r
(*if none of the tests were true then there is enough room on the stack so do nothing *)\r
end;\r
\r
\r
procedure out_opcode( op : opcode );\r
\r
var\r
i : integer;\r
\r
begin\r
with op_table[op] do\r
begin\r
if compiler_test then\r
begin\r
if ((min_hw_stack + opappetite) > max_hw_stack) or\r
(op_type = open_instr) then table_error(op);\r
\r
end;\r
\r
if op_type <> hw_instr then\r
begin\r
\r
(* if not set instr then*)\r
if (op_type <> set_instr) and (op_type <> set_only_sw) and\r
(op_type <> set_hw_word) then\r
\r
(*check and eventually adjust hw stack *)\r
hw_stack_adjust(min_hw_stack,opappetite)\r
\r
else\r
begin (*set instruction*)\r
(*only simple operands on stack*)\r
if hw_stack_size <> min_hw_stack then\r
out_resta(min_hw_stack);\r
(* NB! setcr is not marked as set instruction, the update of dyn eval stack is\r
done after the call of out_opcode(op_setcr) *)\r
if (op=op_setad) or (op=op_setre) then\r
dyn_eval_stack:= true;\r
end; (* set instruction *)\r
\r
(*output instruction*)\r
if (out_state <> 1) and (out_state <> 2) then out_nl;\r
if not compress_yes then out_tab(5);\r
write(out_pass5,opname);\r
\r
(*adjust stackpointers*)\r
context_eval(opappetite);\r
case op_type of\r
empty_stack:\r
\r
if opappetite > 0 then hw_stack_size := opappetite\r
else\r
hw_stack_size := 0;\r
\r
set_hw_word: hw_stack_size := word_length;\r
set_only_sw: ; (*setst*) (*only sw_stack manipulation*)\r
\r
else\r
hw_stack_size := hw_stack_size + opappetite;\r
end;\r
end\r
else\r
begin (*hw_instruction*)\r
(*normally not allowed in pass5, but nessesary for code execption *)\r
writeln(out_pass5);\r
write(out_pass5, opname);\r
hw_stack_size := 0;\r
end;\r
\r
end; (*with op_table *)\r
out_pos := out_pos + c_size_opcode;\r
out_state := 3\r
end;\r
\r
\r
procedure out_p_id (id: identifier);\r
begin\r
out_start_param;\r
out_identifier (id);\r
end;\r
\r
\r
procedure out_p_int (i: integer);\r
begin\r
out_start_param;\r
out_integer (i);\r
end;\r
\r
\r
procedure out_expr (id: identifier; i: integer);\r
begin\r
out_start_param;\r
out_identifier (id);\r
if i >= 0 then out_char ('+');\r
out_integer (i);\r
end;\r
\r
\r
procedure out_op_id (op: opcode; id: identifier);\r
begin\r
out_opcode (op);\r
out_identifier (id);\r
out_state := 4;\r
end;\r
\r
\r
procedure out_op_int (op: opcode; i: integer);\r
begin\r
out_opcode (op);\r
out_integer (i);\r
out_state := 4;\r
end;\r
\r
procedure out_i_frame_addr(level : integer);\r
(*generates code for placing the address of the i_frame denoted by level\r
on top of stack*)\r
const\r
max_level = 4; (*max number of intermidiate references in one instruction*)\r
\r
var\r
step,stop: integer;\r
begin\r
if level = 0 then error(compiler_error)\r
else (*level > 0*)\r
if level <= max_level then\r
out_op_int(op_reaid,level)\r
else (*level > max_level*)\r
begin\r
stop := level div max_level;\r
if (level mod max_level = 0) then\r
begin\r
out_op_int(op_reaid,max_level);\r
stop := stop - 1;\r
end (*level = x * maxlevel*)\r
else\r
out_op_int(op_reaid, level mod max_level);\r
\r
for step := 1 to stop do\r
out_op_int(op_reaisd,max_level);\r
end; (*level > maxlevel *)\r
end; (*out_i_frame_addr*)\r
\r
procedure out_specopcode(op:opcode;movement:integer);\r
(* this procedure is used for instructions with extra stackchange than denoted\r
in the opcode table i. e.\r
pcals0 (-paramlength), pcals1 (-paramlength), pcals (-paramlength),\r
revsm (size)\r
renhb (param)\r
stnhb (-param)\r
setre (size)\r
setst (-size), settm (-size), setad (size + 2) *)\r
begin\r
if op = op_stnhb then\r
out_op_int(op,-movement)\r
else\r
if op = op_renhb then\r
out_op_int(op,movement)\r
else\r
out_opcode(op);\r
context_eval(movement);\r
end;\r
\r
procedure out_op_rea(level,offset:integer);\r
(*pushes the address denoted by level, offset on top of the stack*)\r
begin\r
(*move address of i_frame on top of stack*)\r
out_i_frame_addr(level);\r
\r
(*add offset*)\r
out_op_int(op_reasd,offset);\r
\r
end; (*out_op_rea*)\r
\r
procedure out_op_rev__(access:frame_kind;type_v:base_types;level,offset:integer);\r
(*outputs a rev.. instruction dependent of which frame and type_v. In case of\r
i_frame the address is placed on top of stack and a revs. 0 is output*)\r
begin\r
\r
if access <> i_frame\r
then (*g_frame l_frame or s_frame*)\r
out_op_int(op_rev[conv_frame[access],conv_type[type_v]],offset)\r
else begin(*i_frame*)\r
out_op_rea(level,offset);\r
out_op_int(op_rev[s,conv_type[type_v]],0);\r
end;\r
end;\r
\r
\r
procedure out_token (t: char);\r
begin\r
case t of\r
dollar_a: begin out_char ('$'); out_char ('a'); end;\r
dollar_b: begin out_char ('$'); out_char ('b'); end;\r
dollar_i: begin out_char ('$'); out_char ('i'); end;\r
else\r
begin\r
if t <> zendlist then\r
out_char (t);\r
out_char ('.');\r
end;\r
end;\r
out_state := 3;\r
end;\r
\r
\r
procedure out_init;\r
\r
begin\r
assign( out_pass5, concat(path2_name, o_pass5_codename));\r
settextbuf(out_pass5, out_buf_ptr^);\r
rewrite( out_pass5 );\r
\r
out_state := 1; out_pos := 0;\r
\r
out_special := false;\r
out_line_state := false;\r
writeln (out_pass5,\r
'o.', 0 : 3 (* version id *), ownpassno:7, versionpass5:7, '.');\r
\r
out_nl;\r
\r
end;\r
\r
\r
procedure ext_init;\r
var\r
key : integer;\r
begin\r
not_resolved := -1;\r
ext_open_codes.cur_word_ptr := 1;\r
file_position := -1; (* before reset *)\r
assign (ext_pass5, concat(rtp35_pathname, i_pass5_extname));\r
for key := 1 to ext_tab_max do\r
with ext_tab [ key ] do\r
state := ext_unused;\r
end;\r
\r
\r
procedure find_ext_routine;\r
var\r
key : integer;\r
cur_param: param_ptr;\r
begin\r
\r
key := in_integer;\r
if key > ext_tab_max then error (ext_table_size);\r
\r
with ext_tab [ key ] do\r
begin\r
in_identifier (id);\r
no_of_param := in_integer;\r
if no_of_param > 0 then\r
new(paramptr)\r
else\r
paramptr:= nil;\r
cur_param:= paramptr;\r
\r
no_of_uses := 0;\r
\r
get_token;\r
while token = xparamtype do\r
with cur_param^ do\r
begin\r
kind := in_integer;\r
size := in_integer;\r
get_token;\r
if token=xparamtype then\r
new(next_param)\r
else\r
next_param:= nil;\r
cur_param:= next_param;\r
end; (* with *)\r
\r
state := ext_declared;\r
while key<=not_resolved do\r
(* remove unused elements of parallel block from the chain of non reslved routines *)\r
not_resolved:= ext_tab[ not_resolved ].decl_link;\r
\r
decl_link := not_resolved;\r
not_resolved := key;\r
end;\r
end; (* procedure find_ext_routine *)\r
\r
\r
procedure ext_copy_code (key : integer);\r
var\r
i, c, w : integer;\r
begin\r
with ext_tab [ key ] do\r
with ext_open_codes do\r
if wordcount > 0 then\r
begin\r
\r
(* put a warning if it is a call of 'moveg' *)\r
if id='moveg' then error(moveg_warning);\r
\r
if firstword < 0 then\r
begin (* text not in charbuf, position the library-file *)\r
if (file_position = -1) or (-firstword < file_position) then\r
begin\r
extcode_fileix := filrec_max;\r
(*$I-*)\r
reset(ext_pass5);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(rtp35_pathname, i_pass5_extname));\r
end;\r
(*$I+*)\r
file_position := 0;\r
end;\r
for i := 1 to -(file_position + firstword) do extin ( w);\r
end;\r
\r
out_nl;\r
\r
for i := 1 to wordcount do\r
begin\r
if firstword > 0 then\r
w := charbuf [ i + firstword - 1 ]\r
else\r
extin ( w);\r
c := w shr 8; if c = 10 then out_nl else out_char (chr(c));\r
c := w and 255; if c = 10 then out_nl else out_char (chr(c));\r
end;\r
if firstword < 0 then (* update file position *)\r
file_position := -firstword + wordcount;\r
\r
end;\r
end; (* procedure ext_copy_code *)\r
\r
\r
procedure ext_scan;\r
const\r
size_of_codedescr = 8; (* no of words in descr, containing date etc *)\r
var\r
i, j, codewords, skipwords, codepos,\r
descr_length, no_of_pages, size_of_page, bytes_on_last_page, kind_of_obj,\r
app, pno, next_word,\r
curkey, prevkey : integer;\r
ident : identifier;\r
paramtab : array [ 1 .. descr_max_param ] of param_descr;\r
found : boolean;\r
param_p: param_ptr;\r
\r
begin\r
\r
extcode_fileix := filrec_max;\r
(*$I-*)\r
reset(ext_pass5);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(rtp35_pathname, i_pass5_extname));\r
end;\r
(*$I+*)\r
extin(next_word);\r
file_position := 0;\r
\r
with ext_open_codes do\r
while not eof(ext_pass5) and (next_word > 0) and (not_resolved > 0) do\r
begin\r
descr_length := next_word;\r
extin(no_of_pages);\r
extin(size_of_page);\r
extin(bytes_on_last_page);\r
extin(kind_of_obj);\r
\r
(* read name *)\r
for i := 1 to 6 do\r
begin\r
extin (app);\r
ident [ i*2-1 ] := chr (app div 256);\r
ident [ i*2 ] := chr (app mod 256);\r
end;\r
for i := 13 to c_size_identifier do ident [ i ] := ' ';\r
\r
(* skip entry points etc *)\r
for i := 1 to 5 do extin (next_word);\r
(*read last param offset*)\r
extin (app);\r
\r
(*skip the free words*)\r
for i := 1 to descr_free_words do extin(next_word);\r
\r
(*read number of params *)\r
extin(pno);\r
if pno > descr_max_param then error (ext_param_number);\r
for i := 1 to pno do\r
with paramtab[ i ] do\r
begin\r
extin (kind);\r
extin (size);\r
end;\r
\r
file_position := descr_length div 2 + file_position;\r
codewords := ((no_of_pages - 1) * size_of_page + bytes_on_last_page + 1) div 2;\r
skipwords := codewords;\r
\r
if (kind_of_obj = 4) or (kind_of_obj = 5) then\r
begin (* open routine in library *)\r
\r
for i := 1 to size_of_codedescr do\r
begin\r
extin (next_word); (* skip date etc *)\r
skipwords := skipwords - 1;\r
codewords := codewords - 1;\r
end;\r
file_position := file_position + size_of_codedescr;\r
\r
\r
curkey := not_resolved;\r
prevkey := -1;\r
codepos := - file_position;\r
\r
repeat\r
with ext_tab [ curkey ] do\r
begin\r
(* total match is: same name and paramlist *)\r
if no_of_param = pno then\r
if id = ident then\r
begin\r
found := true; (* assume same param-descr *)\r
param_p:= paramptr;\r
for i := 1 to pno do\r
with paramtab[ i ] do\r
begin\r
if (param_p^.kind<>kind) or (param_p^.size<>size) then\r
found:= false;\r
param_p:= param_p^.next_param;\r
end;\r
if found then\r
begin\r
state := ext_open;\r
appetite := app;\r
wordcount := codewords;\r
\r
if prevkey = -1 then\r
not_resolved := decl_link\r
else\r
ext_tab [ prevkey ] . decl_link := decl_link;\r
curkey := prevkey;\r
\r
if skipwords > 0 then\r
if skipwords <= ext_max_routine then\r
(* routine is not too large *)\r
if cur_word_ptr + skipwords <= ext_max_charbuf then\r
begin (* there is room in charbuf *)\r
codepos := cur_word_ptr;\r
for i := 1 to skipwords do\r
extin (charbuf [ i + codepos - 1 ]);\r
cur_word_ptr := cur_word_ptr + skipwords;\r
skipwords := 0;\r
end;\r
\r
firstword := codepos;\r
end;\r
end;\r
prevkey := curkey;\r
curkey := decl_link;\r
end;\r
until curkey <= 0;\r
end;\r
\r
(* skip any remaining part of code-body *)\r
for i := 1 to skipwords do extin(next_word);\r
file_position := file_position + codewords;\r
(* skip external link part *)\r
extin (pno);\r
file_position := file_position + 1;\r
for i := 1 to pno do\r
begin\r
(* skip external name *)\r
for j := 1 to 6 do extin (next_word);\r
file_position := file_position + 6;\r
(* skip parameter list *)\r
extin (j); (* number of params *)\r
file_position := file_position + 2*j + 1;\r
for j := 2*j downto 1 do extin (next_word);\r
(* skip number of uses *)\r
extin (next_word);\r
file_position := file_position + 1;\r
end;\r
(* skip internal link part *)\r
extin (pno);\r
pno := pno * 4; (* four words per entry *)\r
for i := 1 to pno do extin (next_word);\r
file_position := file_position + pno + 1;\r
\r
(* now the libraryfile is positioned at start of next entry *)\r
extin(next_word);\r
end; (* scan of library file *)\r
\r
(* classify all remaining ext_declared as closed-routines *)\r
while not_resolved > 0 do\r
with ext_tab [ not_resolved ] do\r
begin\r
state := ext_closed;\r
not_resolved := decl_link;\r
end;\r
\r
end; (* procedure extscan *)\r
\r
\r
function getkind (key: integer) : callmodes;\r
begin\r
with ext_tab [ key ] do\r
begin\r
if state = ext_declared then ext_scan;\r
if state = ext_open then\r
getkind := open_call\r
else\r
getkind := ext_call;\r
end;\r
end; (* procedure getkind *)\r
\r
\r
function ext_lookup (var key: integer; look_id: identifier) : callmodes;\r
var\r
i : integer;\r
found : boolean;\r
begin\r
i := 1;\r
found := false;\r
repeat\r
with ext_tab [ i ] do\r
if state = ext_unused then\r
i := ext_tab_max + 1\r
else\r
if id = look_id then found := true\r
else\r
i := i + 1;\r
until found or (i > ext_tab_max);\r
if not found then error (compiler_error);\r
key := i;\r
ext_lookup := getkind (i);\r
end; (* procedure getkind *)\r
\r
\r
procedure descr_end;\r
\r
var\r
i, j, no_of_entries : integer;\r
param_p: param_ptr;\r
\r
begin\r
\r
writeln (out_pass5, 'd.');\r
writeln (out_pass5, descr.name);\r
writeln (out_pass5, descr.kind);\r
writeln (out_pass5);\r
(* if it is a closed routine the entrypoint is the second instruction. This is *)\r
(*handelt by adding the length of the first instruction to the symbolic *)\r
(* value : entry_point *)\r
if (descr.kind = 1(*process*)) or\r
(descr.kind = 2(*procedure*)) or (descr.kind = 3(*function*)) then\r
writeln(out_pass5,descr.entry_point, '+', jump_across_first)\r
else (*open routine = 4 or 5*)\r
writeln(out_pass5,descr.entry_point);\r
writeln (out_pass5, descr.exception_point);\r
writeln (out_pass5);\r
if enforced_create_size <> 0 then\r
begin\r
writeln (out_pass5, enforced_create_size);\r
if descr.kind = 1 (* process *) then\r
enforced_create_size := 0;\r
end\r
else\r
\r
writeln (out_pass5, descr.default_appetite);\r
writeln (out_pass5, descr.last_param_offset);\r
writeln (out_pass5);\r
for i := 1 to descr_free_words do writeln(out_pass5,descr.free_words[i]);\r
writeln(out_pass5);\r
\r
writeln (out_pass5, descr.no_of_params);\r
for i := 1 to descr.no_of_params do\r
with descr.param [ i ] do\r
writeln (out_pass5, kind, ',', size);\r
writeln (out_pass5);\r
\r
no_of_entries := 0;\r
for i := 1 to ext_tab_max do\r
with ext_tab [ i ] do\r
if state = ext_closed (* closed routine *) then\r
begin\r
if no_of_uses > 0 then\r
no_of_entries := no_of_entries + 1\r
end;\r
\r
writeln( out_pass5, no_of_entries );\r
\r
for i := 1 to ext_tab_max do\r
with ext_tab [ i ] do\r
begin\r
if state = ext_closed (* closed routine *) then\r
begin\r
if no_of_uses > 0 then\r
begin\r
writeln (out_pass5);\r
writeln (out_pass5, id);\r
mess_summary_line( id, -1 (* external routine !! *), 0, 0, no_of_uses, false, 0 );\r
writeln (out_pass5, no_of_param);\r
param_p:= paramptr;\r
for j := 1 to no_of_param do\r
with param_p^ do\r
begin\r
writeln (out_pass5, kind, ',', size);\r
param_p:= next_param;\r
end; (* with *)\r
\r
writeln (out_pass5, no_of_uses);\r
writeln (out_pass5, e_name, '#', i:1);\r
end;\r
end;\r
no_of_uses := 0;\r
end;\r
end; (* descr_end *)\r
\r
\r
procedure init_trap_table;\r
var\r
step : integer;\r
begin\r
if trap_nr_table = nil then new(trap_nr_table);\r
with trap_nr_table ^ do\r
begin\r
for step := 2 to 255 do trap_entry [ step ] := 0; (* unused *)\r
trap_entry [ 0 ] := 1; (* reserved for main program *)\r
trap_entry [ 1 ] := 1; (* reserved for garbage and overload *)\r
end; (* with *)\r
no_of_measure_recs := 1 (* entry(0) for main *) + 1 (* entry(1) for overload *);\r
current_trap_nr := 0; (* main *)\r
end;\r
\r
\r
function new_trap_entry( ident : integer ) : integer;\r
(* if more free entries then find one, else use entry(1) *)\r
var\r
trap_nr : integer;\r
begin\r
trap_nr := 1;\r
if no_of_measure_recs < 256 then (* more free *)\r
with trap_nr_table ^ do\r
begin\r
no_of_measure_recs := no_of_measure_recs + 1;\r
trap_nr := abs( ident ) mod 256;\r
while trap_entry [ trap_nr ] <> 0 (* free *) do\r
trap_nr := (trap_nr + 1) mod 256;\r
trap_entry [ trap_nr ] := ident;\r
end; (* with *)\r
new_trap_entry := trap_nr;\r
end; (* new trap entry *)\r
\r
\r
function get_trap_nr( ident : integer ) : integer;\r
var\r
first_guess, trap_nr : integer;\r
begin\r
trap_nr := abs( ident ) mod 256;\r
first_guess := trap_nr;\r
get_trap_nr := 1; (* in case of miss entry(1) is used *)\r
with trap_nr_table ^ do\r
repeat\r
if trap_entry [ trap_nr ] <> ident then\r
trap_nr := (trap_nr + 1) mod 256\r
else\r
begin\r
first_guess := trap_nr; (* exit repeat *)\r
get_trap_nr := trap_nr;\r
end;\r
until trap_nr = first_guess;\r
end; (* get trap nr *)\r
\r
\r
\r
\r
\r
procedure code_call_proc\r
(use: usemodes; callkind: callmodes; key, niv, lix, paramlength,size_of_function_result: integer);\r
var\r
dummy,step,stop,level : integer;\r
\r
begin\r
\r
if callkind <> int_call then\r
with ext_tab [ key ] do\r
begin\r
no_of_uses := no_of_uses + 1;\r
if no_of_uses = 1 then\r
begin\r
mode := use;\r
if trap_code and ( callkind = ext_call ) then\r
dummy := new_trap_entry( -key ); (* externals are marked with negative identification *)\r
end;\r
if mode <> use then\r
error(inconsistent_use);\r
end;\r
\r
case callkind of\r
\r
open_call:\r
begin\r
with ext_tab[key] do\r
begin\r
(*check and adjust hw stack if nessesary *)\r
if paramlength <> hw_stack_size then\r
begin\r
if paramlength > max_hw_stack then (*not enough room for parameters empty stack*)\r
out_resta(0)\r
else\r
if size_of_function_result <> 0 then\r
begin (*simple function*)\r
if (appetite + paramlength) > max_hw_stack then\r
(*not room for both appetite and parameters . assure exactly parameters*)\r
out_resta(paramlength)\r
else\r
if (hw_stack_size + appetite) > max_hw_stack then\r
(*overflow make room for appetite*)\r
out_resta(max_hw_stack-appetite)\r
else\r
if paramlength > hw_stack_size then out_resta(paramlength);\r
end (*simple function*)\r
else (*procedure or non simple function*)\r
(*push exactly parameters to the stack*)\r
out_resta(paramlength)\r
end;\r
\r
(*copy the open routine *)\r
\r
ext_copy_code(key);\r
\r
(*adjust stack pointers*)\r
context_eval(appetite);\r
context_eval(-appetite-paramlength+size_of_function_result);\r
(*hw_stackpointer*)\r
if size_of_function_result <> 0 then\r
begin (*simple function *)\r
if hw_stack_size = 0 then hw_stack_size := size_of_function_result\r
else\r
hw_stack_size := hw_stack_size - paramlength + size_of_function_result;\r
\r
(*check consistence*)\r
if (hw_stack_size < 0) or (hw_stack_size > max_hw_stack) then\r
hw_stack_error(simple_open_function);\r
end\r
else\r
(*procedure or non simple function*)\r
hw_stack_size := 0;\r
end;\r
end;\r
\r
int_call,\r
ext_call:\r
begin\r
if trap_code then\r
begin\r
out_op_int(op_mtrh,trapenter);\r
out_start_param;\r
out_integer(current_trap_nr);\r
end;\r
level := c.niv - niv;\r
case level of\r
0: out_specopcode(op_pcals0,-paramlength);\r
1: out_specopcode(op_pcals1,-paramlength);\r
\r
else begin\r
(*level > 1*)\r
(*move addr of i frame on top of stack*)\r
out_i_frame_addr(level);\r
out_specopcode(op_pcals,-paramlength);\r
end;\r
end;\r
out_start_param;\r
if callkind = int_call then\r
begin\r
out_lix(r_name,lix);\r
out_char('+');\r
out_integer(jump_across_first);\r
end\r
else\r
begin\r
out_lix (e_name, key);\r
if trap_code then\r
begin\r
out_op_int(op_mtrh,trapreturn);\r
out_start_param;\r
out_integer(get_trap_nr(-key));\r
end;\r
end;\r
\r
end;\r
\r
end; (* case *)\r
\r
end; (* procedure code_call_proc *)\r
\r
\r
procedure code_initvar( kind, offset, type_o : integer;\r
var ref_count : integer; var shadow_count : integer);\r
forward;\r
\r
\r
procedure get_niv_offset ( var v : varaddr_descr );\r
\r
begin\r
with v do\r
begin\r
\r
kind := addr;\r
niv := in_integer; offset := in_integer;\r
size := 0;\r
if niv = c.niv then access := l_frame\r
else\r
if niv = const_niv_0 then access := g_frame\r
else\r
access := i_frame;\r
\r
end;\r
end; (* get niv, offset *)\r
\r
\r
\r
procedure load_address( var v : varaddr_descr; offset_zero : boolean);\r
\r
(* the execution of this procedure enforces 'v.kind' = 'addr' *)\r
\r
begin\r
\r
case v.kind of\r
\r
addr:\r
begin\r
case v.access of\r
g_frame: out_op_int(op_reagd,v.offset);\r
l_frame: out_op_int(op_reald,v.offset);\r
i_frame: out_op_rea(c.niv - v.niv, v.offset);\r
(*s_frame not possible here*)\r
end; (*case*)\r
\r
v.kind := stack_addr; v.offset := 0; v.access := s_frame;\r
end;\r
\r
stack_addr:\r
if ( offset_zero ) and ( v.offset <> 0 ) then\r
begin\r
out_opcode( op_reasd );\r
out_p_int( v.offset );\r
\r
v.offset := 0\r
end;\r
\r
packed_arr: error (compiler_error);\r
\r
end\r
\r
end;\r
\r
\r
\r
procedure code_exc_trigger( exception_no : integer);\r
\r
begin\r
\r
out_opcode( op_rechw );\r
out_expr (id_cpexcfirst, exception_no);\r
\r
out_opcode( op_mtrs );\r
out_comment( ' trigger exception no. : ' ); out_integer( exception_no )\r
\r
\r
end;\r
\r
\r
procedure code_allocpool( kind, offset, number, size : integer);\r
\r
var\r
w_offset, key, refs : integer;\r
w_size : word;\r
begin\r
\r
(* init. the semaphore of the pool to nil : *)\r
\r
if (kind = 2) and (number > 0) then\r
begin\r
\r
out_opcode( op_revpd )\r
\r
end;\r
\r
code_initvar( kind, offset, 6, refs, refs);\r
\r
out_comment( ' start init. of pool. ' );\r
\r
\r
(* prepare call of the routine: _initpool_rc : *)\r
if number > 0 then\r
begin\r
\r
(* generate the actual parameters: *)\r
\r
if kind = 1 then\r
begin\r
out_op_int (op_reald, offset);\r
\r
end\r
\r
else\r
if kind = 2 then\r
begin\r
if offset <> 0 then\r
out_op_int( op_reasd, offset );\r
\r
\r
end\r
\r
else\r
error(compiler_error);\r
\r
out_op_int (op_rechw, number);\r
(*$R-*)\r
w_size := size;\r
(*$R+*)\r
if odd( w_size ) then w_size := w_size + 1;\r
w_size := w_size div 2;\r
size := w_size;\r
\r
out_op_int (op_rechw, size);\r
\r
code_call_proc (sys_use, ext_lookup (key, '_initpool_rc'), key, const_niv_0, 0,\r
4 (* address *) + 2 (* number *) + 2 (* size *),0 );\r
end; (* if number > 0 *)\r
\r
end (* code_allocpool *);\r
\r
\r
«eof»