|
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: 47554 (0xb9c2)
Types: TextFile
Names: »P6REST.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P6REST.PAS«
procedure insert_address_and_return( unsat_ref : unsatref_ptr );\r
\r
(* insert current offset into the two bytes the offset of which is\r
described by unsat_ref, free the reserved space for long addressing\r
and return the unsat_ref_node *)\r
\r
var\r
offset : integer;\r
\r
begin\r
\r
offset:= current_offset;\r
(*$R-*)\r
\r
with unsat_ref ^ do\r
begin\r
if ic_relative then\r
offset:= offset - use_offset-1;\r
put_word(use_offset,offset);\r
if ic_relative then\r
(* release the reserved space *)\r
rem_buffer_size:= rem_buffer_size + longjump_size;\r
(*$R+*)\r
\r
end;\r
\r
remove_unsatisfied_node( unsat_ref );\r
\r
end; (* insert address and return *)\r
\r
\r
\r
\r
procedure fill_in_jumps;\r
var\r
step : integer;\r
chain : unsatref_ptr;\r
found : boolean;\r
local_jump_ptr: jump_table_ptr;\r
\r
begin\r
if current_jump_ptr<>nil_jump_ptr then\r
begin (* non empty list of jumps *)\r
local_jump_ptr:= nil_jump_ptr;\r
while local_jump_ptr<>current_jump_ptr do\r
with local_jump_ptr ^ .next_jump ^ do\r
begin\r
if (code_buffer [jump_from] = 0) and\r
(code_buffer [jump_from-1] = 0) then\r
begin\r
(*find the unsatisfied ref-node and update it *)\r
chain:= destination^.use_chain;\r
found:= false;\r
\r
while (chain <> unsatisfied_nil) and (not found) do\r
with chain^ do\r
if use_offset = jump_from then\r
begin (*the node to change is found*)\r
ic_relative:= false;\r
use_offset:= current_offset + addrsize;\r
size:= addrsize;\r
found:= true;\r
end\r
else (*not found yet*)\r
chain:= next_ref;\r
\r
if found then\r
begin (*long jump is needed*)\r
put_word(jump_from,current_offset - jump_from - 1);\r
outcode(longjump);\r
outbyte(0);outword(0);\r
end; (*long jump generated*)\r
\r
end; (* if ... *)\r
local_jump_ptr:= local_jump_ptr^.next_jump;\r
end; (* while ... with ... *)\r
\r
current_jump_ptr:= nil_jump_ptr; (*reset jump table*)\r
end;\r
end; (*fill in jumps*)\r
\r
\r
\r
\r
\r
procedure emitcode( jump_to_next : boolean );\r
\r
\r
(* make exit jump and long jumps for the jumps denoted by the\r
jump table, and write the code buffer contents onto the codefile *)\r
\r
var\r
step, step1 : integer;\r
word : integer;\r
link_node : name_ptr;\r
\r
begin\r
if test then outtest('emitcode');\r
(* make exit jump *)\r
if jump_to_next then\r
begin\r
outcode(longjump);\r
\r
link_node:= getnamenode;\r
\r
with link_node ^ do\r
begin (* create a node denoting the entry of the next segment *)\r
namepart:= 'noname';\r
kind:= label_def;\r
def_segment:= current_segment + 1;\r
def_offset:= 0;\r
use_chain:= add_unsatisfied_node(unsatisfied_nil, false, addrsize);\r
next_name:= internal_link_list;\r
end;\r
internal_link_list:= link_node;\r
\r
(* reserve room for the jump address to be filled in by the linker *)\r
outbyte(0); outword(0);\r
end; (* jump to next page *)\r
\r
(* prepare internal linking - through a long jump - for short address jumps\r
out of the segment *)\r
fill_in_jumps;\r
\r
(* line table handling *)\r
if start_of_line_table <> 0 then\r
begin (* line table present *)\r
if line_add <= max_line then\r
code_buffer [ next_line_table_entry ]:= line_add\r
else\r
code_buffer [ next_line_table_entry ]:= max_line;\r
line_add:= 0;\r
(*$R-*)\r
next_line_table_entry:= next_line_table_entry + 1;\r
(*$R+*)\r
\r
(* zero fill unused part of reserved line table *)\r
if not last_page then\r
for step:= next_line_table_entry to segment_size do\r
code_buffer [ step ]:= 0;\r
\r
(* remember current offset *)\r
last_to_emit:= current_offset;\r
current_offset:= start_of_line_table;\r
\r
with current_line_record ^ do\r
begin\r
def_segment:= current_segment;\r
def_offset := start_of_line_table;\r
kind:= label_def;\r
end;\r
\r
if not last_page then\r
begin\r
current_line_record:= getnamenode;\r
with current_line_record ^ do\r
begin\r
namepart:= 'linrec';\r
next_name:= internal_link_list;\r
internal_link_list:= current_line_record;\r
\r
use_chain:= add_unsatisfied_node(use_chain, false,addrsize);\r
end;\r
end;\r
\r
(* now get the correct current_offset back *)\r
current_offset:= last_to_emit;\r
\r
end; (* handling of line table *)\r
\r
\r
(* emit the code *)\r
if not last_page and (start_of_line_table<>0) then\r
for step:= current_offset to start_of_line_table-1 do\r
code_buffer [step]:= 0;\r
\r
\r
(*$R-*)\r
if jump_to_next then\r
last_to_emit:= segment_size\r
else\r
last_to_emit:= current_offset - 1;\r
(*$R+*)\r
\r
(* dump all of the code buffer *)\r
blockwrite(codefile, code_buffer, segment_size+1);\r
\r
(* prepare a fresh code buffer *)\r
rem_buffer_size:= segment_size + 1 - longjump_size; (* reserve room for the exit jump *)\r
current_offset:= 0;\r
current_segment:= current_segment + 1;\r
(* prepare a line table if needed *)\r
\r
if not last_page and (start_of_line_table <> 0) then\r
prepare_linetable;\r
\r
\r
end; (* emit code *)\r
\r
procedure word_align;\r
var\r
labels: label_list_ptr;\r
begin\r
(* if not word boundary then insert a dummy byte and update current_labels *)\r
if odd( current_offset ) then\r
begin (* room for alignment is guaranteed *)\r
rem_buffer_size:= rem_buffer_size - 1;\r
outbyte(0);\r
\r
if cur_lab_ptr<>nil_label_ptr then\r
begin\r
labels:= nil_label_ptr;\r
repeat\r
labels:= labels^.next_label;\r
labels^.label_name^.def_offset:= current_offset;\r
until labels=cur_lab_ptr;\r
end;\r
\r
end; (* else current_offset is even or reservecode will force a segment change *)\r
\r
end; (* word align *)\r
\r
\r
function reservecode( reserve_size : integer ) : boolean;\r
\r
(* ensure that reserve_size consecutive bytes are available on\r
the same segment, if the remaining part of current segment is\r
insufficient the code buffer contents will be optput, and a fresh\r
buffer is prepared; if still not enough room the function result becomes false.\r
the labels which are defined at current "point" are changed\r
to denote the start of the new segment *)\r
\r
var\r
listnext,\r
list : unsatref_ptr;\r
labels: label_list_ptr;\r
reserve_c_size: code_ix;\r
\r
begin\r
reservecode := true;\r
reserve_c_size := reserve_size;\r
\r
if reserve_c_size > rem_buffer_size then\r
begin\r
emitcode(true); (* empty the buffer and fill in jumps *)\r
if reserve_c_size > rem_buffer_size then\r
begin\r
reservecode:= false;\r
markerror( 14 ); (* constant block greater than page size *)\r
if reserve_c_size > reserve_max then\r
reserve_max:= reserve_c_size; (* remember maximum block size *)\r
if reserve_max > codebuffersize then\r
stop('buffersize ', 'reservecode ');\r
reserve_size:= 0; reserve_c_size := 0;\r
end; (* not enough room *)\r
\r
\r
if cur_lab_ptr<>nil_label_ptr then\r
begin\r
labels:= nil_label_ptr;\r
repeat\r
labels:= labels^.next_label;\r
with labels^, label_name^ do\r
begin\r
def_offset:= current_offset;\r
def_segment:= current_segment;\r
end;\r
until labels=cur_lab_ptr;\r
end; (* labels associated *)\r
end; (* change buffer *)\r
\r
(* update the symbol nodes for the names kept in 'current labels list',\r
and try to solve some of the uses; let the list be empty at procedre exit *)\r
\r
if cur_lab_ptr<>nil_label_ptr then\r
begin\r
labels:= nil_label_ptr;\r
repeat\r
labels:= labels^.next_label;\r
with labels^, label_name^ do\r
begin\r
list:= use_chain;\r
use_chain:= unsatisfied_nil;\r
while list <> unsatisfied_nil do\r
with list ^ do\r
begin\r
listnext:= next_ref; (* point at successor *)\r
if (size <= 2) and (use_segment = current_segment) then\r
insert_address_and_return(list)\r
else\r
begin\r
(* insert in usechain again *)\r
next_ref:= use_chain;\r
use_chain:= list;\r
end;\r
list:= listnext;\r
end;\r
\r
end; (* with label name *)\r
until labels=cur_lab_ptr;\r
\r
cur_lab_ptr:= nil_label_ptr; (* empty the list *)\r
end; (* if cur lab ptr <> nil label ptr *)\r
\r
(* end of update label definitions *)\r
\r
rem_buffer_size:= rem_buffer_size - reserve_c_size;\r
\r
end; (* reserve code *)\r
\r
\f
\r
\r
(* procedures for handling of line tables and source line records *)\r
\r
procedure emit_start_of_line_table;\r
\r
(* output a record as follows:\r
\r
start_of_line_information_chain : packed record\r
. coded_date : packed record * 2 bytes *\r
. year_after_1980 : 0..127;\r
. month : 0..15;\r
. day : 0..31;\r
. end;\r
. coded_time : packed record * 2 bytes *\r
. compiler_version : 0..31;\r
. hour : 0..31;\r
. minute : 0..63;\r
. end;\r
. length_of_code : integer; * 2 bytes *\r
. length_of_last : integer; * 2 bytes *\r
. last_line : integer; * 2 bytes *\r
. line_spacing : integer; * 2 bytes *\r
. start_of_chain : ^ line_number_table; * 4 bytes *\r
. end;\r
\r
\r
*)\r
\r
\r
var\r
reserve_result : boolean;\r
\r
begin\r
reserve_result:= reservecode(length_of_descriptor);\r
\r
with line_table_descriptor ^ do\r
begin\r
def_segment:= current_segment;\r
def_offset := current_offset;\r
kind:= label_def;\r
next_name:= internal_link_list;\r
internal_link_list:= line_table_descriptor;\r
end; (* initialization of a label describing the line table descriptor *)\r
\r
outword( coded_date );\r
outword( coded_time );\r
outword( segment_size + 1 - line_table_size ); (* may be changed by option codesize *)\r
\r
(*make a constant to be inserted later on, length of last page *)\r
\r
length_of_last_segment:= getnamenode;\r
with length_of_last_segment ^ do\r
use_chain:= add_unsatisfied_node ( use_chain, false,wordsize );\r
outword( 0 - 0 - 0 );\r
\r
\r
(* make a constant to be inserted later on, last line number *)\r
last_line_number:= getnamenode;\r
with last_line_number ^ do\r
use_chain:= add_unsatisfied_node ( use_chain, false,wordsize );\r
outword( 0 - 0 - 0 );\r
\r
outword( line_spacing ); (* may be changed by option spacing *)\r
\r
current_line_record:= getnamenode;\r
(* prepare internal linking of the line number table *)\r
with current_line_record ^ do\r
begin\r
namepart:= 'linrec';\r
next_name:= internal_link_list;\r
internal_link_list:= current_line_record;\r
\r
use_chain:= add_unsatisfied_node ( use_chain, false,addrsize );\r
(* the name node will be defined by procedure emitcode *)\r
end;\r
(*now make room for the address (3 bytes).*)\r
(*note!: since pass5 copies the open routines directly into the code\r
by reading the library as a file of integer, it is nessesary to output\r
4 bytes for the address. The cross linker does not bother since it gets\r
the address of the last byte of the address and then fills the address\r
"backwards" leaving the first of the four bytes as a dummy byte.*)\r
outbyte(0); (*dummy*)\r
outbyte(0);outword(0); (*room for the address*)\r
\r
end; (* emit start of line table *)\r
\r
\r
\r
procedure handle_line;\r
\r
(* read the line number, just met l. *)\r
\r
var\r
local_next_line : integer;\r
\r
begin\r
while get_next_token <> symbol do (* skip *) ;\r
local_next_line:= get_constant_value;\r
\r
if current_source_line < local_next_line then\r
begin (* the line tables will contain an increasing sequence of line numbers *)\r
\r
line_add:= local_next_line - current_source_line + line_add;\r
current_source_line:= local_next_line;\r
end;\r
\r
token:= get_next_token; (* prepare next token *)\r
\r
end; (* handle line *)\r
\r
\r
procedure handle_linetable;\r
\r
(* just read z.\r
syntax:\r
\r
. -----> name -----> e. ----->\r
\r
\r
produce a block of information for the exception handler:\r
\r
. routine name 12 bytes\r
. address of descriptor 3 bytes\r
\r
. the descriptor is a record as defined in procedure emit_start_of_line_table \r
\r
*)\r
\r
const\r
z_block_length = 15; (* bytes *)\r
\r
var\r
step : integer;\r
reserve_result : boolean;\r
\r
begin\r
if generate_line_info then\r
begin\r
(* this construction may cause reservation of one byte more than\r
actually used, namely in case of page change, and in that case\r
a zero byte is emitted on the former page between the code and the\r
jump_to_next_page !!!!! *)\r
reserve_result:= reservecode( z_block_length );\r
\r
while get_next_token <> symbol do (* skip until name has been read *);\r
\r
for step:= lastchar + 1 to alfalength do\r
chbuf [ step ]:= ' '; (* fill with spaces *)\r
\r
(* emit the name *)\r
for step:= 1 to alfalength div 2 do\r
outword( ord(chbuf [ 2*step - 1 ]) shl 8\r
+ ord(chbuf [ 2*step ]) );\r
\r
with line_table_descriptor ^ do\r
use_chain:= add_unsatisfied_node ( use_chain, false,addrsize);\r
outbyte( 0 ); outword( 0 );\r
\r
end;\r
\r
while get_next_token <> blockend do (* skip *);\r
\r
token:= get_next_token;\r
\r
end; (* handle_linetable *)\r
\r
\f
\r
\r
procedure read_symbolic_expression(\r
var symb : name_ptr;\r
var constant_part : integer );\r
\r
(* ------------> signed integer ------------------------------->\r
. ! !\r
. -----> symbol -->-------------------------------\r
. ! !\r
. !--> + -> unsigned integer -->!\r
. ! !\r
. !--> - ->!\r
*)\r
(* let symb be a pointer to symbol (if present) and\r
let constant_part be the value of the unsigned integer\r
with the operator (if present) as sign\r
the default values are symb = nil_name and constant_part = 0 *)\r
\r
var\r
local_const : integer;\r
operator : char;\r
\r
begin\r
symb:= nil_name;\r
constant_part:= 0;\r
if line [ lineindex ] = '-' then\r
operator:= '-'\r
else\r
operator:= '+';\r
\r
if get_next_token <> symbol then\r
markerror( 3 ) (* illegal expression *)\r
else\r
begin\r
if lastchar = 0 then (* signed integer *)\r
begin\r
operator:= line [ lineindex ];\r
if get_next_token <> symbol then\r
markerror( 3 );\r
end;\r
\r
if not ((chbuf [ 1 ] >= '0') and (chbuf [ 1 ] <= '9')) then\r
begin (* name *)\r
symb:= find_name;\r
if symb = nil_name then\r
markerror( 3 );\r
operator:= line [ lineindex ] ; (* see if expression *)\r
if (operator = '+') or (operator = '-') then\r
(* make chbuf contain the second operand *)\r
if get_next_token <> symbol then markerror( 3 );\r
end;\r
\r
local_const:= get_constant_value;\r
\r
(*$R-*)\r
if operator = '-' then\r
local_const:= - local_const;\r
(*$R+*)\r
\r
constant_part:= local_const;\r
end;\r
end; (* read symbolic expression *)\r
\r
\r
\r
procedure solve_uses( name : name_ptr );\r
\r
var\r
displ : integer;\r
list : unsatref_ptr;\r
\r
begin\r
with name ^ do\r
begin\r
list:= use_chain;\r
\r
while list <> unsatisfied_nil do\r
with list ^ do\r
if use_segment = current_segment then\r
begin\r
case size of\r
\r
1:\r
begin\r
if def_offset < 0 then\r
displ:= def_offset + maxbyte\r
else\r
displ:= def_offset mod ( maxbyte );\r
end;\r
\r
2:\r
begin\r
displ:= def_offset;\r
end;\r
\r
end; (* case *)\r
put_word( use_offset , displ );\r
\r
remove_unsatisfied_node ( list );\r
use_chain:= list;\r
end\r
else\r
list:= unsatisfied_nil; (* no more inside this segment *)\r
\r
end; (* with names .... *)\r
\r
end; (* solve uses *)\r
\r
\r
\r
procedure update_constants;\r
\r
(* traverse the dependence chain and fill in \r
information into the constant descriptors ( name nodes )\r
and remove the satisfied dependence chain elements *)\r
\r
var\r
former, current : dep_chain_ptr;\r
\r
begin\r
former:= dep_chain_start;\r
current:= dep_chain_start ^ . next_dep;\r
\r
while current <> dep_chain_start do\r
with current ^ do\r
if dependence ^ . def_segment <> nill then\r
(* the unsatisfied dependence can be solved *)\r
with dependent ^ do\r
begin\r
def_segment:= dependence ^ . def_segment;\r
def_offset := dependence ^ . def_offset + def_offset;\r
kind := dependence ^ . kind;\r
\r
solve_uses ( dependent );\r
\r
\r
return_dependence_node(former, current);\r
\r
(* now start all over since a symbol more has been defined *)\r
former:= dep_chain_start;\r
current:= dep_chain_start ^ . next_dep;\r
end\r
\r
else\r
\r
begin\r
former:= current;\r
current:= next_dep;\r
end;\r
\r
\r
end; (* update constants *)\r
\r
\r
\r
procedure update_symbol;\r
\r
(* two cases:\r
1) label definition : read all the labels for the next instruction\r
or structured constant and let them be defined with current program\r
(segment) point as addressl make a chain of the labels to be used\r
in case of redefinition because of segment change, e.g. a\r
structured constant which needs more space than is left in current\r
segment is to be defined.\r
2) constant definition : read the symbolic expression and let the\r
value of the constant be the expression result, if the symbol of the\r
expression is not defined yet an element describing the interdependence\r
is created *)\r
\r
var\r
nameptr, symb : name_ptr;\r
disp : integer;\r
dep_ix : dep_chain_ptr;\r
\r
begin\r
\r
if test then outtest('update symbol');\r
\r
nameptr:= find_name;\r
\r
if nameptr = nil_name then\r
markerror( 4 ) (* undeclared symbol *)\r
else\r
with nameptr ^ do\r
if def_segment <> nill then\r
markerror( 5 ) (* double defined symbol *)\r
else\r
if token = labeldef then\r
begin\r
if cur_lab_ptr^.next_label=nil then\r
begin\r
new(cur_lab_ptr^.next_label);\r
survey_cur_label_nodes:= survey_cur_label_nodes+1;\r
cur_lab_ptr:= cur_lab_ptr^.next_label;\r
cur_lab_ptr^.next_label:= nil;\r
end\r
else\r
cur_lab_ptr:= cur_lab_ptr^.next_label;\r
\r
cur_lab_ptr^.label_name:= nameptr;\r
def_segment:= current_segment;\r
def_offset:= current_offset;\r
kind:= label_def;\r
end\r
else (* constant definition *)\r
begin\r
read_symbolic_expression( symb, disp );\r
def_offset:= disp;\r
if symb <> nil_name then\r
begin\r
def_segment:= nill; (* i.e. yet undefined *)\r
dep_ix:= get_dep_chain_node;\r
\r
with dep_ix ^ do\r
begin\r
dependent:= nameptr;\r
dependence:= symb;\r
end;\r
\r
end\r
else (* symb = nil_name *)\r
begin\r
def_segment:= 1; (* <> nill, i.e. defined *)\r
kind:= constant_def;\r
solve_uses ( nameptr );\r
end;\r
\r
update_constants;\r
\r
end; (* constant definition *)\r
\r
token:= get_next_token;\r
\r
end; (* update symbol *)\r
\r
\r
\r
\r
\f
\r
function find_code : coderange;\r
\r
(* search the codes for the name kept in chbuf,\r
if not found the function result becomes the index of no_op\r
and an error is marked *)\r
\r
label 256; (* exit label, used in case of undefined opcode *)\r
\r
var\r
hash_code : packed record\r
case boolean of\r
true: ( codeword : namestring;);\r
false: (int1, int2 : integer);\r
end;\r
result : integer;\r
found : boolean;\r
step : integer;\r
\r
begin\r
with hash_code do\r
begin\r
(* pack the contents of chbuf *)\r
codeword:= blank;\r
\r
for step:= 1 to lastchar do\r
if step <= namelength then \r
codeword [ step ]:= chbuf [ step ] ;\r
\r
found:= false;\r
step:= 0;\r
\r
(* this function m u s t be the same as in init-codes *)\r
result:= abs( int1 div hash1 + int2 div hash2 ) mod hash3;\r
while codeword <> opcodes [ result ] . namepart do\r
begin\r
result:= (result + 1) mod hash3;\r
step:= step + 1;\r
if step > 256 then goto 256; (* exit, not found *)\r
end;\r
256:\r
found:= step < 256;\r
\r
\r
if not found then\r
begin\r
if not (generate_statistics and (codeword = 'bar')) then\r
markerror1( 6, codeword ); (* undefined opcode *)\r
result:= no_op_ix;\r
end;\r
\r
find_code:= result;\r
\r
end; (* with hash code *)\r
\r
end; (* find code *)\r
\r
\r
\r
\r
\r
procedure handle_code;\r
\r
var\r
symb : name_ptr;\r
next_length,displacement : integer;\r
trailernr, operandsize : integer;\r
current_code : coderange;\r
reserve_ok : boolean;\r
found, displ_ready : boolean ;\r
start_interval : interval_index;\r
\r
begin\r
\r
if test then outtest('handle code');\r
\r
current_code:= find_code;\r
\r
with opcodes [ current_code ] do\r
begin\r
\r
if codelist then (* accumulate time *)\r
begin\r
if exc_time<>-1 then begin\r
(*$R-*)\r
total_time:= total_time + exc_time;\r
(*$R+*)\r
current_time:= exc_time;\r
end;\r
end; (* list and accumulate times *)\r
case opcode_kind of\r
jump_short: reserve_ok:= reservecode(total_length + longjump_size);\r
first_of_pair: begin\r
if namepart = 'mtrh ' then next_length:= 3 else next_length:= 1;\r
(*after trapreturn from internal routine a pexit istruction follows.\r
and it occupies 3 bytes. Otherwise a 1 byte intruction follows a\r
first_of_pair instruction *)\r
reserve_ok:= reservecode( total_length + next_length );\r
rem_buffer_size:= rem_buffer_size + next_length;\r
end;\r
\r
else\r
reserve_ok:= reservecode(total_length);\r
end; (* case *)\r
length_of_current_code:= total_length;\r
outcode(current_code);\r
trailernr:= 1;\r
operandsize:= trailers [ 1 ];\r
while operandsize <> 0 do\r
begin\r
displ_ready:= false;\r
read_symbolic_expression( symb, displacement );\r
\r
if symb <> nil_name then\r
with symb ^ do\r
begin\r
if (def_segment <> nill) and (operandsize <= 2) then\r
if opcode_kind = jump_short then\r
if def_segment = current_segment then\r
begin\r
displ_ready:= true;\r
(*$R-*)\r
displacement:= displacement + def_offset -\r
(current_offset + 1) - 1\r
(*$R+*)\r
end\r
else\r
use_chain:= add_unsatisfied_node( use_chain, true, operandsize)\r
else\r
begin\r
if statistical_version then\r
displ_ready:= true;\r
(*$R-*)\r
displacement:= displacement + def_offset;\r
(*$R+*)\r
end\r
else\r
use_chain:= add_unsatisfied_node(use_chain,(opcode_kind = jump_short),operandsize);\r
if (opcode_kind = jump_short) and (def_segment <> current_segment) then\r
begin\r
(* add a new element to the jump_table *)\r
if current_jump_ptr^.next_jump=nil then\r
begin\r
new(current_jump_ptr^.next_jump);\r
(*$R-*)\r
survey_jump_nodes:= survey_jump_nodes+1;\r
(*$R+*)\r
current_jump_ptr:= current_jump_ptr^.next_jump;\r
current_jump_ptr^.next_jump:= nil;\r
end\r
else\r
current_jump_ptr:= current_jump_ptr^.next_jump;\r
\r
with current_jump_ptr ^ do\r
begin\r
(*$R-*)\r
jump_from:= current_offset + 1; (* least significant byte of the operand *)\r
(*$R+*)\r
destination:= symb;\r
end; (* with jump table .. *)\r
\r
end; (* if opcode kind = jump short .. *)\r
end;\r
\r
if displ_ready or ( symb = nil_name ) then\r
if (ais_codes [ current_code ] <> 0) and short_instructions then\r
begin\r
\r
start_interval:= ais_codes [ current_code ];\r
if trailernr = intervals [ start_interval ] . trailer_nr then\r
begin\r
\r
repeat\r
with intervals [ start_interval ] do\r
begin\r
found:= (displacement >= interval_low) and (displacement <= interval_high);\r
if not found then start_interval:= next_interval;\r
\r
end; (* with *)\r
\r
until found or ( start_interval = 0 );\r
\r
if found then\r
begin\r
with opcodes [ current_code ] do\r
begin\r
(*$R-*)\r
use_count:= use_count - 1;\r
(*$R+*)\r
end;\r
\r
with opcodes [ intervals [ start_interval ] . ais_code_val ] do\r
begin\r
code_buffer [ current_offset- 1 ]:= opcodeval;\r
\r
(*if negative_short instruction change negative displacement to positive\r
displacement i.e. revlb -6 ~ revlbns 6 *)\r
if opcode_kind = negative_short then displacement:= - displacement;\r
\r
length_of_current_code:= total_length;\r
\r
rem_buffer_size:= rem_buffer_size + operandsize - trailers [ trailernr ];\r
\r
operandsize:= trailers [ trailernr ];\r
\r
(*$R-*)\r
use_count:= use_count + 1;\r
(*$R+*)\r
\r
(* execution time information changed !!! *)\r
if codelist then\r
if current_time<>-1 then\r
begin\r
(*$R-*)\r
total_time:=total_time-current_time+exc_time;\r
(*$R+*)\r
current_time:=exc_time;\r
end;\r
\r
end; (* with *)\r
\r
end; (* if found *)\r
\r
end; (* if trailernr ... *)\r
\r
end; (* if ais codes ... *)\r
\r
\r
\r
case operandsize of\r
bytesize: outbyte( displacement );\r
wordsize: outword( displacement );\r
addrsize: begin\r
outbyte( 0 ); outword( displacement );\r
end;\r
else ;\r
end; (* case *)\r
\r
\r
if trailernr < max_no_of_trailers then\r
begin\r
trailernr:= trailernr + 1;\r
operandsize:= trailers [ trailernr ] ;\r
end\r
else\r
operandsize:= 0; (* stop *)\r
\r
if (operandsize > 0) and (line [ lineindex ] <> ',') then\r
begin\r
markerror( 7 ); (* missing operand *)\r
operandsize:= 0;\r
end;\r
\r
end; (* while operandsize > 0 *)\r
\r
end; (* with opcodes [ current_code ] *)\r
\r
token:= get_next_token; (* prepare next instruction *)\r
\r
end; (* handle code *)\r
\r
\f
\r
procedure handle_constant;\r
\r
(* just read 'c.' now handle :\r
\r
. -----> size ->-> field ---->-------> e. ------->\r
. ! !\r
. !<--- nl <-------!\r
. ! !\r
. !<--- , <-------!\r
.\r
. where field is defined as:\r
.\r
. --->-------->------> symbolic expression ---------->\r
. ! !\r
. !-> $b ->!\r
. ! !\r
. !-> $i ->!\r
. ! !\r
. !-> $a ->!\r
\r
*)\r
\r
type\r
constant_modes = (byte_mode, word_mode, addr_mode);\r
\r
var\r
current_mode : constant_modes;\r
segment, disp, constant_size, size : integer;\r
symb : name_ptr;\r
\r
begin\r
\r
if test then outtest('handle constant');\r
\r
current_mode:= word_mode; (* default *)\r
constant_size:= 2;\r
\r
word_align; (* assure constant start at a word boundary *)\r
\r
read_symbolic_expression( symb, size);\r
if survey_greatest_const<size then\r
survey_greatest_const:= size;\r
if not reservecode( size ) then\r
size:= -1; (* force skip of constant *)\r
\r
while token <> blockend do\r
begin\r
if lineindex = linelength then\r
begin\r
if (errorindex > 0) and errorreporting then writeln(output);\r
if codelist and not printed then printline;\r
readline;\r
if codelist then printline;\r
end;\r
if line [ lineindex + 1 ] = '$' then\r
begin\r
case line [ lineindex + 2 ] of\r
'b', 'B' : \r
begin\r
current_mode:= byte_mode; constant_size:= bytesize;\r
end;\r
\r
'i', 'I' :\r
begin\r
current_mode:= word_mode; constant_size:= wordsize;\r
end;\r
\r
'a', 'A' :\r
begin\r
current_mode:= addr_mode; constant_size:= addrsize;\r
end;\r
\r
end; (* case *)\r
lineindex:= lineindex + 2; (* skip radix *)\r
\r
end; (* if change mode *)\r
\r
size:= size - constant_size;\r
\r
if size < 0 then\r
begin\r
token:= get_next_token; (* skip until 'e.' *)\r
if size + constant_size < 0 then\r
markerror( 8 ); (* too many fields in structured constant definition *)\r
end\r
else\r
begin\r
read_symbolic_expression( symb, disp);\r
\r
if symb <> nil_name then\r
with symb ^ do\r
begin\r
segment:= def_segment;\r
if (segment <> nill) and (current_mode <> addr_mode) then\r
disp:= disp + def_offset\r
else\r
use_chain:= add_unsatisfied_node( use_chain, false, constant_size);\r
end\r
\r
else\r
\r
segment:= 0;\r
\r
case current_mode of\r
\r
byte_mode : outbyte( disp );\r
\r
word_mode : outword( disp );\r
\r
addr_mode : \r
begin\r
outbyte( 0 ); outword( disp );\r
end;\r
\r
end; (* case *)\r
\r
end;\r
\r
end; (* while not blockend *)\r
\r
if size > 0 then \r
markerror( 9 ); (* too few constants *)\r
\r
token:= get_next_token;\r
\r
end; (* handle constants *)\r
\r
\f
\r
procedure read_declaration;\r
\r
(*\r
\r
. ---->----------------------->--> . ---> nl --->\r
. ! !\r
. !->-> declaration -->-->!\r
. ! !\r
. !<---------<- , <-!\r
. ! !\r
. !<- nl <--!\r
\r
\r
there is no check against double declarations,\r
the names are inserted into the name table in opposite order of\r
declaration\r
\r
*)\r
label 117; (* allow line numbers between declarations *)\r
\r
var\r
localtoken : tokens;\r
step : integer;\r
local_level: level_ptr;\r
nameptr : name_ptr;\r
\r
begin\r
\r
if test then outtest('read declaration');\r
\r
if free_level_list=nil_level then\r
begin\r
new(local_level);\r
survey_level_nodes:= survey_level_nodes+1;\r
local_level^.former_level:= nil_level;\r
end\r
else\r
local_level:= free_level_list;\r
\r
free_level_list:= local_level^.former_level;\r
local_level^.former_level:= current_level;\r
current_level:= local_level;\r
\r
current_level ^.level_list:= nil_name;\r
\r
repeat\r
localtoken:= get_next_token;\r
117: if (localtoken <> symbol) and (localtoken <> other) (* empty declaration *) then\r
begin\r
if localtoken = source_line_number then\r
begin\r
handle_line;\r
localtoken:= token; (* token was assigned by handle line *)\r
goto 117; (* proceed as if source line was not met *)\r
end\r
else\r
markerror( 10 ); (* error in declaration *)\r
end\r
else\r
if lastchar > 0 then\r
begin\r
(* non empty declaration *)\r
nameptr:= getnamenode;\r
\r
with nameptr ^ do\r
begin\r
for step:= 1 to lastchar do\r
if step <= namelength then\r
namepart [ step ]:= chbuf [ step ] ;\r
def_segment:= nill; (* undefined *)\r
def_offset:= 0;\r
kind:= undefined;\r
next_name:= current_level ^.level_list;\r
end; (* with *)\r
current_level ^.level_list:= nameptr;\r
\r
end;\r
\r
until line [ lineindex ] = '.'; (* end declaration list *)\r
\r
token:= get_next_token;\r
\r
end; (* read declaration *)\r
\f
\r
procedure unstack_level;\r
\r
(*\r
. ------> e. ------->\r
\r
traverse the name list of current level \r
if use chain = unsatisfied_nil then remove entry\r
else\r
if not defined then error\r
else put the name definition into the internal link list\r
\r
remove level \r
\r
*)\r
\r
var\r
local_free_level: level_ptr;\r
local_next_name , list : name_ptr;\r
\r
begin\r
if test then\r
outtest('unstack level');\r
\r
if dump_nametable then\r
output_names;\r
\r
list:= current_level ^.level_list;\r
\r
while list <> nil_name do\r
with list ^ do\r
begin\r
local_next_name:= next_name;\r
if use_chain = unsatisfied_nil then\r
returnname(list)\r
else\r
if kind = undefined then\r
begin\r
markerror1( 11, namepart ); (* undefined but used label *)\r
returnname( list );\r
end\r
\r
else\r
\r
begin\r
next_name:= internal_link_list;\r
internal_link_list:= list\r
end;\r
\r
list:= local_next_name;\r
\r
end; (* while list <> nil_name *)\r
\r
local_free_level:= free_level_list;\r
free_level_list:= current_level;\r
current_level:= current_level^.former_level;\r
free_level_list^.former_level:= local_free_level;\r
\r
token:= get_next_token;\r
\r
end; (* unstack level *)\r
\r
\r
procedure read_options;\r
(*\r
. ------> o. ---->----> pass nr --> option --> value -->---> . --->\r
. ! !\r
. !---------------<-------------------------!\r
\r
if pass nr <> (0, 6) then skip\r
\r
legal options :\r
\r
. option default value meaning\r
. 1 (list) 0 (no) codelist:= value=1\r
. 2 (test) 0 (no) test := value=1\r
. 3 (codesize) 512 segment_size:= max(min_buffer_size, value)\r
. 4 (print) 0 (no) print_code:= value=1\r
. 5 (errormess) 0 (no) errorreporting:= value=1\r
. 6 (preserve) 0 (no) preserve_option:= value=1\r
. 7 (nametable) 0 (no) dump_nametable:= value=1\r
. 81..86 (left hand side) the file name is given as options\r
. 81 to 86, two characters per option\r
. 9 (spacing) 52 line table spacing:=\r
. max( 4, min(value, segment_size))\r
. 10 (statistics) 0 generate stitistical information\r
. 11 (lineinfo) 1 (yes) generate line tables and other information\r
. for the exception handler\r
. 12 (open or closed) 1 (closed) program_kind:= value of opt(12)\r
. 13 short 1 (yes) use short instructions (ais)\r
. 141 start time year\r
. 142 start time month\r
. 143 start time day\r
. 144 start time hour\r
. 145 start time minute\r
. 146 start time second\r
. 15 (version) 0 user defined version number, saved in\r
. descriptor segment part one\r
\r
.PASS0 options of interest for pass 6\r
. 5 version of pass5 must be greater than or equal to demanded_pass5_version\r
. 81..85 source date and time year, month, day, hour, minute saved in\r
. descriptor segment part one\r
\r
*)\r
\r
var\r
symb : name_ptr;\r
current_code : coderange;\r
pass, opt, val : integer;\r
\r
begin\r
repeat\r
repeat \r
read_symbolic_expression( symb, pass );\r
read_symbolic_expression( symb, opt );\r
read_symbolic_expression( symb, val );\r
\r
if pass = 6 then\r
begin\r
case opt of\r
1:\r
begin\r
codelist:= val = 1;\r
errorreporting:= errorreporting or ( val = 1 );\r
end;\r
\r
2: test:= val = 1;\r
\r
3: if not codesize_met and (current_segment=1) and\r
(current_offset < min_buffer_size (* i.e. before code *)) then\r
begin\r
if val < min_buffer_size then val:= min_buffer_size;\r
segment_size:= ((val shr 1) shl 1) - 1;\r
codesize_met:= true;\r
end;\r
\r
4: print_code:= val = 1;\r
\r
5: errorreporting:= errorreporting or (val = 1);\r
\r
6: preserve_option:= val=1;\r
\r
7: dump_nametable:= val = 1;\r
\r
9:\r
if not spacing_met and (current_segment = 1)\r
and (current_offset < min_buffer_size (* i.e. before code *)) then\r
begin\r
if val < 4 then\r
val:= 4;\r
line_spacing:= val;\r
spacing_met:= true;\r
end;\r
\r
10: begin\r
survey_info:= val=1;\r
\r
generate_statistics:= val > 1;\r
if generate_statistics and statistical_version then\r
begin\r
survey_option_number:= val;\r
if (val = 3) or (val = 5) then barrier:= 0 else barrier:= -1;\r
\r
if survey_option_number > 5 then\r
(* no longer permitted !!!!!!!! 85 10 23 jaba *)\r
writeln(output, '****** WARNING: statistical information will not be produced ');\r
\r
\r
end; (* generate statistics *)\r
\r
end; (* 10 *)\r
\r
\r
11: if not lineinfo_met and\r
(current_segment = 1) and (current_offset < min_buffer_size)\r
and (val <> 1) then\r
begin\r
lineinfo_met:= true;\r
generate_line_info:= false;\r
(* return the line table head *)\r
current_offset:= 0;\r
start_of_line_table:= 0; (* do not reserve room for line tables *)\r
internal_link_list:= nil_name; (* forget the names in connection with line info *)\r
rem_buffer_size:= segment_size + 1 - longjump_size;\r
end;\r
\r
12: if (val = 0) and (current_segment = 1) and\r
(current_offset <= length_of_descriptor + 1) then\r
program_kind:= open_routine;\r
\r
13: short_instructions:= val = 1;\r
\r
15: users_version:= val;\r
\r
else\r
begin\r
if (opt >= 81) and (opt <= 86) then\r
begin\r
if opt = 81 then assign_alfa(codefilename,' ');\r
codefilename [ 2 * ( opt - 81 ) + 1 ]:= chr ( val shr 8 );\r
codefilename [ 2 * ( opt - 81 ) + 2 ]:= chr ( val and 255 );\r
end\r
else\r
if (opt>=141) and (opt<=146) then\r
with start_clock do\r
case opt of\r
141: year := val;\r
142: month:= val;\r
143: day := val;\r
144: hour := val;\r
145: min := val;\r
146: sec := val;\r
end; (* case 141 .. 146 *)\r
end; (* otherwise *)\r
end; (* case *)\r
if (opt = 3) or (opt = 9) then\r
begin\r
(* adjust the mutual dependent varables *)\r
(*$R-*)\r
line_table_size:= (segment_size + 1 - fix_line_table_part) div (line_spacing + 1) + fix_line_table_part;\r
line_table_size:= (line_table_size + 1) div 2 * 2; (* integral number of words *)\r
start_of_line_table:= segment_size + 1 - line_table_size;\r
rem_buffer_size:= segment_size+1-current_offset-longjump_size;\r
prepare_linetable;\r
(*$R+*)\r
end;\r
end\r
else\r
if pass = 0 then\r
begin\r
if opt=5 then\r
begin\r
if val < demanded_pass5_version then\r
begin\r
writeln(' compiler inconsistency .... ');\r
rtphalt( true (* terminate program with trace and ok.no *));\r
end; (* test of pass5 version *)\r
end (* opt=5 *)\r
else\r
(*$R-*)\r
case opt of\r
81: source_date:= (val-1900) shl 9; (* reset old value, if present *)\r
82: source_date:= source_date+val shl 5;\r
83: source_date:= source_date+val;\r
84: source_time:= val shl 6; (* reset old value *)\r
85: source_time:= source_time+val\r
else ;\r
end; (* case *)\r
(*$R+*)\r
end; (* pass = 0 ... *)\r
\r
\r
\r
\r
until line [ lineindex ] = '.';\r
\r
token:= get_next_token;\r
\r
until token <> option ;\r
\r
end; (* read option *)\r
\r
procedure read_environment;\r
(* read standard definitions from file: 'rtp35022en5'\r
the names are declared on level = global_level *)\r
(* syntax:\r
\r
. anything ---> b. ---> declarations --> definitions --> . -->\r
\r
. declarations: see procedure read_declaration\r
\r
. definitions:\r
. --->-------------------------->---->\r
. ! !\r
. !<--- constant definition <-!\r
. ! !\r
. !<--- option <--------------!\r
. ! !\r
. !<--- comment <-------------!\r
\r
. constant definition:\r
. --> identifier --> = --> symbolic expression -->\r
\r
. symbolic expression: see procedure read_symbolic_expression\r
\r
*)\r
var\r
chain : name_ptr;\r
\r
\r
begin\r
assign(input,concat(rtp35_pathname, i_pass6_envname));\r
settextbuf(input, in_buf_ptr^);\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(rtp35_pathname, i_pass6_envname));\r
end;\r
(*$I+*)\r
\r
while get_next_token <> blockbegin do\r
(* skip , no check for eof !!!!! *);\r
\r
read_declaration; (* includes: token:= get_next_token *)\r
\r
while token <> other do\r
\r
case token of\r
\r
constdef: update_symbol;\r
\r
option: read_options;\r
\r
comment: token:= get_next_token; (* skip *)\r
\r
\r
else\r
\r
begin\r
markerror( 15 ); (* error in lambda environment *)\r
token:= get_next_token;\r
end;\r
end; (* case *)\r
\r
chain:= current_level ^.level_list;\r
(* check that all names from environment are defined *)\r
while chain <> nil_name do\r
with chain ^ do\r
begin\r
if kind = undefined then\r
markerror1( 11, namepart ); (* undefined constant *)\r
chain:= next_name;\r
end;\r
\r
\r
close( input );\r
lineindex := linelength;\r
\r
end; (* read environment *)\r
\r
\r
\r
\r
\r
\r
procedure handle_descriptor_block;\r
\r
(* process the descriptorblocks according to the input\r
descriptions and the internal link information gathered during the\r
code processing *)\r
\r
var\r
former, link, link1, symb, no_of_int_links : name_ptr;\r
noofinternallinks,\r
noofparams, descrelem, step, step1, nooflinks, descrptr : integer;\r
chain : unsatref_ptr;\r
\r
\r
procedure (*local*)outword( word : integer );\r
\r
\r
begin\r
if rem_buffer_size < 2 then\r
begin\r
emitcode(false); (* empty the buffer without exit-jump *)\r
(* do not reserve room for an exit jump *)\r
rem_buffer_size:= rem_buffer_size + longjump_size;\r
(* do not produce more line tables *)\r
start_of_line_table:= 0;\r
end;\r
\r
rem_buffer_size:= rem_buffer_size - 2;\r
code_buffer [ current_offset ]:= word shr 8;\r
code_buffer [ current_offset + 1 ]:= word and 255;\r
\r
current_offset:= current_offset + 2;\r
\r
end; (* local out word *)\r
\r
\r
begin\r
if test then outtest('handle_descriptor_blocks');\r
\r
(* fill in descr1 as follows:\r
entry contents\r
\r
0 length of descriptor part 1\r
1 no of program pages\r
2 size of a program page\r
3 no of bytes on last page\r
4 kind of object program\r
5-10 name of object program\r
11-12 entry point\r
13-14 exception point\r
15 default create size\r
16 global frame offset of first parameter or routine appetite\r
17 source date (packed as coded date)\r
18 source time (packed as coded time)\r
19 user defined version number, default=0\r
20 free word for future use\r
21 no of parameters\r
22-23 type, size of first param\r
24-25 type, size of second param\r
....\r
....\r
....\r
*)\r
\r
\r
descr1 [ 1 ]:= current_segment; (* number of codeblocks *)\r
descr1 [ 2 ]:= segment_size + 1;\r
descr1 [ 3 ]:= current_offset;\r
while get_next_token <> symbol do (* skip until program name *) ;\r
\r
\r
for step:= lastchar + 1 to alfalength do\r
chbuf [ step ]:= ' ';\r
descrptr:= 4;\r
for step:= 1 to alfalength do\r
begin\r
if odd(step) then\r
begin\r
(* next word *)\r
descrptr:= descrptr + 1;\r
descr1 [ descrptr ]:= 0;\r
end;\r
descr1 [ descrptr ]:= descr1 [ descrptr ] * 256 + ord( chbuf [ step ] );\r
(* remember the name for survey information *)\r
procname [ step ]:= chbuf [ step ];\r
\r
end; (* program name *)\r
\r
(* kind of object program *)\r
read_symbolic_expression( symb, descrelem );\r
descr1 [ 4 ]:= descrelem;\r
\r
(* entry point, exception point, *)\r
descrptr:= 10;\r
for step:= 1 to 2 do\r
begin\r
read_symbolic_expression( symb, descrelem );\r
with symb ^ do\r
begin\r
descrptr:= descrptr + 1;\r
descr1 [ descrptr ]:= def_segment;\r
descrptr:= descrptr + 1;\r
descr1 [ descrptr ]:= def_offset + descrelem;\r
end; (* with .. *)\r
\r
end; (* for ... *)\r
\r
(* default appetite *)\r
read_symbolic_expression( symb, descr1 [ 15 ] );\r
\r
(* last param offset *)\r
read_symbolic_expression( symb, descr1 [ 16 ] );\r
(* source date and time and version not initialized by pass 5 *)\r
for step:= 1 to 4 do read_symbolic_expression(symb,descr1[16 + step]);\r
descr1[ 17 ]:= source_date;\r
descr1[ 18 ]:= source_time;\r
descr1[ 19 ]:= users_version;\r
descr1[ 20 ]:= compiler_version;\r
(* parameter list *)\r
\r
read_symbolic_expression( symb, noofparams );\r
descrptr:= 21;\r
if descrptr + noofparams * 2 > descr1_size then\r
stop('descr1_size', 'handle descriptor');\r
descr1 [ descrptr ]:= noofparams;\r
\r
for step:= 1 to noofparams * 2 do\r
(* each parameter consist of type and size *)\r
begin\r
read_symbolic_expression( symb, descrelem );\r
descrptr:= descrptr + 1;\r
descr1 [ descrptr ]:= descrelem;\r
end; (* for ... *)\r
\r
descr1 [ 0 ]:= (descrptr + 1) * 2; (* remember the length of part1 *)\r
\r
(* end of part 1 *)\r
\r
\r
(* now the external linking table must be produced and put into\r
the descriptorblock\r
note: the descriptor block starts at a word boundary *)\r
if odd(current_offset) then outbyte(0);\r
rem_buffer_size:= rem_buffer_size + longjump_size;\r
(* room for exit jump is not needed *)\r
\r
\r
(* read the external linking table and\r
substitute the symbols by the associated addresses *)\r
\r
read_symbolic_expression( symb, nooflinks );\r
\r
(*local*)outword( nooflinks ); (* number of external link entries *)\r
\r
for step:= 1 to nooflinks do\r
begin\r
\r
token:= get_next_token; (* read the name *)\r
for step1:= lastchar + 1 to alfalength do\r
chbuf [ step1 ]:= ' ';\r
\r
\r
for step1:= 1 to alfalength div 2 do\r
(*local*)outword( ord(chbuf [2*step1 - 1]) shl 8 + ord(chbuf [2 * step1]));\r
\r
(* parameter list *)\r
\r
read_symbolic_expression( symb, noofparams );\r
(*local*)outword( noofparams );\r
\r
for step1:= 1 to 2 * noofparams do\r
begin\r
read_symbolic_expression( symb, descrelem );\r
(*local*)outword( descrelem );\r
end; (* end of parameter list *)\r
\r
\r
(* uses list *)\r
\r
read_symbolic_expression( symb, noofparams );\r
(*local*)outword( noofparams ); (* number of uses *)\r
\r
(* read the internal name and output the use chain *)\r
read_symbolic_expression ( symb, descrelem );\r
with symb ^ do\r
begin\r
chain:= use_chain;\r
use_chain:= unsatisfied_nil;\r
end;\r
\r
\r
\r
for step1:= 1 to noofparams do\r
begin\r
\r
if chain = unsatisfied_nil then\r
markerror1 ( 12, symb ^ . namepart ); (* trouble with descriptor block *)\r
\r
with chain ^ do\r
begin\r
(*local*)outword( use_segment );\r
(*local*)outword( use_offset );\r
remove_unsatisfied_node( chain );\r
end;\r
\r
end; (* uses list *)\r
\r
if chain <> unsatisfied_nil then\r
markerror1 ( 12, symb ^ . namepart ); (* trouble with descriptor block *)\r
\r
end; (* for .. to nooflinks *)\r
\r
unstack_level;\r
\r
(* NB!!!: instead of "reservecode(2); add_unsatisfied_node..; outword(0)", outword is\r
called first and the address in the unsat_node is changed accordingly, afterwards *)\r
(*local*)outword( 0 ); (* room for the number of internal links *)\r
\r
no_of_int_links:= getnamenode;\r
(* make a name node to describe the constant: number of internal links *)\r
with no_of_int_links ^ do\r
begin\r
use_chain:= add_unsatisfied_node(use_chain, false,wordsize);\r
with use_chain^ do\r
use_offset:= use_offset-2; (* the address was incremented before the call *)\r
end;\r
\r
noofinternallinks:= 0;\r
\r
link:= internal_link_list;\r
former:= nil_name;\r
\r
while link <> nil_name do\r
with link ^ do\r
begin\r
if (kind = label_def) and (use_chain <> unsatisfied_nil) then\r
begin\r
chain:= use_chain;\r
\r
while chain <> unsatisfied_nil do\r
with chain ^ do\r
begin\r
\r
noofinternallinks:= noofinternallinks + 1;\r
(*local*)outword( use_segment );\r
(*local*)outword( use_offset );\r
(*local*)outword( def_segment );\r
(*local*)outword( def_offset );\r
\r
remove_unsatisfied_node( chain );\r
\r
\r
end; (* while chain ... *)\r
\r
end; (* if kind = label_def *)\r
\r
link1:= next_name;\r
if (kind = label_def) then\r
begin\r
returnname(link);\r
if former = nil_name then\r
internal_link_list:= link1\r
else\r
former ^ . next_name:= link1;\r
end (* remove the name node *)\r
else\r
former:= link;\r
link:= link1;\r
\r
end; (* while link ... *)\r
with no_of_int_links ^ do\r
begin\r
def_segment:= 1; (* defined *)\r
def_offset:= noofinternallinks;\r
kind:= constant_def;\r
next_name:= internal_link_list;\r
internal_link_list:= no_of_int_links;\r
end; (* with .. *)\r
\r
\r
\r
(* end of internal links *)\r
if current_offset <> 0 then\r
emitcode(false); (* empty the code buffer *)\r
\r
\r
end; (* handle descriptor blocks *)\r
\r
\r
\r
\r
\r
\r
procedure insert_constants;\r
\r
var\r
former, chain, list, sortlist : unsatref_ptr;\r
step, codeptr,\r
next_segment, next_offset : integer;\r
link, next_link : name_ptr;\r
code_word : integer;\r
\r
\r
begin\r
reset(codefile, 1);\r
if not object_code_file_opened then\r
begin\r
\r
assign(code, concat(source_path,codefilename));\r
rewrite(code, 1);\r
object_code_file_opened:= true;\r
end;\r
\r
(* the number of significant elements of descriptor block part 1\r
is kept in descr1 [ 0 ] *)\r
if print_code then\r
begin\r
if codelist and not printed then printline; (*output the last line before\r
descriptorsegment part 1*)\r
writeln(output, ' descriptor part 1 ');\r
end;\r
\r
\r
for step:= 0 to descr1 [ 0 ] div 2 - 1 do\r
begin\r
code_word := descr1 [ step ];\r
code_word := lo(code_word) shl 8 + hi(code_word);\r
blockwrite(code, code_word, 2 );\r
if print_code then\r
write_hex_descr(descr1 [ step ] );\r
end;\r
if print_code then\r
begin\r
no_of_elems_in_line:= elems_per_line;\r
writeln(output); writeln(output); writeln(output);\r
end;\r
\r
\r
\r
(* now, make a sorted list of constant uses *)\r
\r
unsatisfied_nil ^ . use_segment:= current_segment + 1; (* stop mark *)\r
\r
sortlist:= unsatisfied_nil;\r
\r
link:= internal_link_list;\r
\r
while link <> nil_name do\r
with link ^ do\r
begin\r
if kind = constant_def then\r
begin\r
chain:= use_chain;\r
while chain <> unsatisfied_nil do\r
begin\r
\r
(* insert chain into the sorted list starting at sortlist *)\r
\r
list:= sortlist;\r
former:= unsatisfied_nil;\r
\r
with chain ^ do\r
begin\r
while (use_segment > list ^ . use_segment)\r
or (( use_segment = list ^ . use_segment)\r
and (use_offset > list ^ . use_offset)) do\r
begin\r
former:= list;\r
list:= list ^ . next_ref;\r
end;\r
\r
(* now insert 'chain' between 'former' and 'list' *)\r
if size = 1 then\r
size := def_offset and 255\r
else\r
size := def_offset;\r
(* the size is known to be 2 bytes, and 'size' may be used to hold the\r
constant value, i.e. the name node is not needed any more *)\r
\r
if former <> unsatisfied_nil then\r
former ^ . next_ref:= chain\r
else\r
sortlist:= chain;\r
chain:= next_ref;\r
next_ref:= list;\r
end; (* with chain` ... *)\r
\r
end; (* while chain <> unsatisfied_nil *)\r
\r
end; (* with .. if constant_def *)\r
\r
next_link:= next_name;\r
returnname( link );\r
link:= next_link;\r
\r
end; (* while *)\r
\r
\r
(* now copy the code and insert the constants *)\r
if test then\r
begin (* output the sorted list of constants *)\r
chain:= sortlist;\r
while chain <> unsatisfied_nil do\r
with chain ^ do\r
begin\r
writeln('next:', seg(next_ref), ofs(next_ref),\r
' use:', use_segment, use_offset, ' value=', size);\r
chain:= next_ref;\r
end; (* with *)\r
end;\r
\r
current_segment:= 1;\r
current_offset:= 0;\r
\r
\r
if test then outtest('start of constant insertion ');\r
\r
blockread(codefile, code_buffer, segment_size+1);\r
\r
while sortlist <> unsatisfied_nil do\r
with sortlist ^ do\r
begin\r
next_segment:= use_segment;\r
next_offset:= use_offset - 1; (* first byte of the constant *)\r
\r
(* copy until (next_segment, next_offset) *)\r
\r
while (current_segment < next_segment) do\r
begin\r
blockwrite(code, code_buffer, segment_size+1 (* not last segment *));\r
current_segment:= current_segment+1;\r
\r
blockread(codefile, code_buffer, segment_size+1);\r
\r
end;\r
(* code_buffer contains the segment to be modified *)\r
(* note: constants are always seen as 2 consecutive bytes,\r
insertion of small constants are done just as long constants, i.e.\r
add the value to the contents already put into the code with byte offsets\r
next_offset and next_offset+1 *)\r
\r
code_buffer[ next_offset ] :=\r
code_buffer[ next_offset ] + size shr 8;\r
code_buffer[ next_offset + 1 ] :=\r
code_buffer[ next_offset + 1 ] + (size and 255);\r
\r
if test then writeln('where:', next_segment, next_offset, ' value=', size);\r
\r
remove_unsatisfied_node( sortlist );\r
\r
\r
end; (* with sortlist^ .... *)\r
\r
if test then outtest('end of constant insertion');\r
\r
(* output the remaining code and descriptor part 2 *)\r
if not eof(codefile) then\r
blockwrite(code, code_buffer, segment_size+1 (* not last segment *))\r
else\r
blockwrite(code, code_buffer, last_to_emit+1);\r
\r
while not eof(codefile) do\r
begin\r
blockread(codefile, code_buffer, segment_size + 1);\r
if not eof(codefile) then\r
blockwrite(code, code_buffer, segment_size+1 (* not last segment *))\r
else\r
blockwrite(code, code_buffer, last_to_emit+1);\r
end;\r
\r
end; (* insert constants *)\r
«eof»