|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 48384 (0xbd00)
Types: TextFile
Names: »prelinktext«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦ef5fa0e68⟧ »jtas«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦ef5fa0e68⟧ »jtas«
└─⟦this⟧
<**********************************************************************>
<* *>
<* linkhead *>
<* *>
<**********************************************************************>
begin
comment prelinker part 1, consisting of global declarations
and procedures for reading fp command, opening of files,
read/write and error message procedures;
<* input/output declarations *>
zone input, output (2*128, 2, stderror);
real array input_name, output_name (0:1); <* for file names *>
boolean output_on; <* true if output wanted *>
integer input_segment, output_segment; <* no of current segment *>
integer array in_tail, out_tail (1:10); <* for entry tail *>
boolean array field bytes; <* in order to read/write *>
integer array field words; <* ...from 0 to max - like *>
real array field reals; <* ...code segm.used to be *>
<* declaration of code pointers etc. *>
integer entry, <* start address (byte) *>
ext_start, <* start of ext. list *>
no_of_code_segms, <* no of code segments *>
no_of_segments, <* total no of segments *>
first_ext_segm, <* first segment (start of ext. list) *>
first_code_segm, <* first segment containing code *>
old_no_of_ext, <* orig. no of ext. references *>
cat_no_of_ext, <* no of ext. in local catalog *>
new_no_of_ext, <* no in new ext. list (init 0) *>
no_of_entries, <* no of global entry points *>
no_of_own_bytes, <* no of bytes to copy to own *>
max_no_of_ext, <* max. no of ext. made room for *>
date, time; <* date and time from ext. list *>
\f
<* option declarations *>
boolean list_option, <* list of ext. is output *>
test_option; <* test output is written *>
<* for use in error_procedure call *>
real array dummy(0:0);
<* declarations concerning eff_start and set_entry *>
integer eff_start_no, <* (local) ext. no of eff_start *>
set_entry_no, <* same for set_entry *>
eff_start_segm, <* segm. where eff_start is called *>
eff_start_rel; <* rel. of eff_start call *>
real array eff_start_name (0:1), <* for 'eff_start' as string *>
set_entry_name (0:1); <* for 'set_entry' as string *>
\f
integer
p_r_o_c_e_d_u_r_e open_zone (ext_zone, name, tail);
zone ext_zone; real array name; integer array tail;
comment if 'name' contains a name the corresponding area is opened.
the type of 'name' is given in the result:
-1: 'name' not a name,
0: standard variable,
1: procedure,
2: procedure contained in library,
3: subentry in a procedure;
begin
integer i, status, contents_key;
<* is it a name... *>
if name(0) < 0 then open_zone := -1
else
begin
close (ext_zone, true);
i := 0;
open (ext_zone, 4, string name (increase(i)), 0);
<* lookup: *>
status := monitor (42, ext_zone, 0, tail);
if status <> 0 then fatal_error (110+status, name);
<* is it an external of any kind... *>
contents_key := tail.bytes(16) extract 12;
if contents_key <> 4 and contents_key < 32 then fatal_error (101,name);
<* is it a standard variable... ( 1. param. >= 8 ) *>
if (tail.bytes (12) extract 12) >= 512 then open_zone := 0
else
<* is it a normal ext. procedure *>
if tail.words(0) >= 0 then open_zone := 1
else
<* is it an ext. procedure contained in a library *>
if contents_key >= 32 then open_zone := 2
else
<* it must be a subentry *>
open_zone := 3;
end;
e_n_d p_r_o_c_e_d_u_r_e open_zone;
\f
p_r_o_c_e_d_u_r_e open_input (name);
real array name;
comment opens input area 'name';
begin
integer i, status;
integer array lib_tail (1:10);
real array lib_name (0:1);
if test_option then
begin
i := 0;
write (out, <:<10>input: :>, string name (increase(i)));
end;
status := open_zone (input, name, in_tail);
<* is it a procedure in a library... *>
if status = 2 then
begin
for i := 1 step 1 until 4 do lib_name.words(i-3) := in_tail.words(i);
status := open_zone (input, lib_name, lib_tail);
if status <> 1 then fatal_error (101, lib_name);
if test_option then
begin
i := 0;
write (out, <: on :>, string lib_name (increase(i)));
end;
end;
if status <> 1 then fatal_error (101, name);
input_segment := -1;
e_n_d p_r_o_c_e_d_u_r_e open_input;
\f
p_r_o_c_e_d_u_r_e get_fp_command;
comment interprets an fp command:
prelink <source>.<chain entry>.<program name> <option list>
ex.: prelink pip.1023.aks test.yes, and opens i/o areas;
begin
integer status;
real array item (0:1);
integer
p_r_o_c_e_d_u_r_e next_fp_item (item);
real array item;
comment reads next fp item in the command stack.
result -1: unknown
0: end of fp command
1: '('or<nl>or<space> <string>
2: =<string>
3: .<string>
4: <string>.yes
5: <string>.no;
begin
integer separator, type; own integer item_no;
real array item_1 (0:1);
integer
p_r_o_c_e_d_u_r_e fp_item (item_no, item, separator, item_type);
value item_no; integer item_no, separator, item_type;
real array item;
comment takes an item from the fp command stack.
input: item_no - number of the item.
output: item - name or number.
separator - code for preceeding separator,
ex. 4=point, 8=space.
item_type - code for type of item,
ex. 0=nothing, 4=number, 10=string.
see 'utility programs' part 1, chapter 2.4;
begin
separator := system (4, item_no, item);
item_type := separator extract 12;
if separator >= 0 then separator := separator shift (-12)
else separator := -(-separator shift (-12));
e_n_d p_r_o_c_e_d_u_r_e fp-item;
\f
fp_item (item_no, item, separator, type);
if type = 0 then next_fp_item := 0
else
if type = 10 then
begin
if separator = 6 then next_fp_item := 2
else
if separator = 8 then next_fp_item := 3
else
begin comment is it <string>.yes/no;
fp_item (item_no + 1, item_1, separator, type);
if separator = 8 and item_1(0) = real <:yes:> then
begin next_fp_item := 4; item_no := item_no + 1 end
else
if separator = 8 and item_1(0) = real <:no:> then
begin next_fp_item := 5; item_no := item_no + 1 end
else next_fp_item := 1;
end;
end
else next_fp_item := -1;
item_no := item_no + 1;
e_n_d p_r_o_c_e_d_u_r_e next_fp_item;
\f
<* b_o_d_y of get_fp_command *>
<* output area name (if any) *>
status := next_fp_item (output_name);
if status <> 1 then fatal_error (3, dummy);
<* if not '=<string>' then there was no output area given *>
status := next_fp_item (input_name);
if status = 1 then output_on := false
else
if status = 2 then
begin <* then the next one is input name *>
output_on := true;
status := next_fp_item (input_name);
end;
if status <> 1 then fatal_error (1, dummy);
<* options (if any) *>
status := next_fp_item (item);
while status > 0 do
begin
if status <> 4 and status <> 5 then fatal_error (3, dummy);
if item(0) = real <:test:> then
test_option := if status = 4 then true else false
else
if item(0) = real <:list:> then
list_option := if status = 4 then true else false
else fatal_error (2, dummy);
status := next_fp_item (item);
end while;
if status < 0 then fatal_error (3, dummy);
<* open input/output area *>
open_input (input_name);
e_n_d p_r_o_c_e_d_u_r_e get_fp_command;
\f
p_r_o_c_e_d_u_r_e read_segment (segment_no);
value segment_no; integer segment_no;
comment reads a segment from 'input';
begin
if segment_no <> input_segment then
begin
if segment_no <> input_segment + 1 then setposition (input, 0, segment_no);
inrec6 (input, 512);
input_segment := segment_no;
end;
e_n_d p_r_o_c_e_d_u_r_e read_segment;
p_r_o_c_e_d_u_r_e out_segment (segment_no);
value segment_no; integer segment_no;
comment calls outrec6 if neccesary. it is an error to try to jump
backwards or to try to skip segments;
begin
if segment_no <> output_segment then
begin
if segment_no <> output_segment + 1 then fatal_error (-2,dummy);
outrec6 (output, 512);
output_segment := segment_no;
end;
e_n_d p_r_o_c_e_d_u_r_e out_segment;
\f
integer
p_r_o_c_e_d_u_r_e next_ext_word (start_word);
integer start_word;
comment reads a word from external list. inputs a segment when
necessary. if start_word = 0 then the next word is taken;
begin
own integer ext_pointer;
<* start of list... *>
if start_word > 0 then ext_pointer := start_word;
<* get word *>
next_ext_word := input.words(ext_pointer);
ext_pointer := ext_pointer + 1;
<* end of segment... (we do this now because if it is last word of
ext. list then first code segment is next segment) *>
if ext_pointer = 251 then
begin comment word 251 contains rel. addr. of cont word;
ext_pointer := ( input.words(ext_pointer) extract 12 ) // 2;
read_segment (input_segment + 1);
end;
e_n_d p_r_o_c_e_d_u_r_e next_ext_word;
\f
p_r_o_c_e_d_u_r_e write_message (error_no, text);
value error_no; integer error_no;
real array text;
comment writes an error message on current output.
the meaning of 'text' (if any) depends on 'error_no';
begin
integer type, status, i;
i := 0;
<* errors in the prelinker *>
if error_no < 0 then write (out, <:<10><10>*** error in the prelinker<10>:>,
case -error_no of (<:no room in local ext. catalog:>,
<:output error (out<95>segment):>))
else
<* error in fp command line *>
if error_no < 100 then
write (out, <:<10><10>*** error in command line<10>:>,
case error_no of (<:input area expected:>,
<:unknown option:>,
<:syntax error:>))
else
<* error in opening input/output *>
if error_no < 200 then
begin
type := (error_no - 100) // 10;
status := error_no mod 10;
write (out, <:<10><10>*** input/output error<10>:>);
if error_no < 110 then write (out,
<:bad ext. procedure: :>, string text(increase(i)))
else write (out,
case type of (<:look up failure:>,
<:create entry failure:>,
<:change entry failure:>),
status, <: on :>, string text(increase(i)));
end
\f
else
<* error in external code procedure *>
begin
write (out, <:<10><10>*** code structure error<10>:>,
case error_no-200 of (<:no str<95>eff<95>start call:>,
<:no str<95>set<95>entry call:>,
<:str<95>set<95>entry called before str<95>eff<95>start:>,
<:str<95>eff<95>start never callled:>,
<:str<95>eff<95>start called twice:>,
<:str<95>set<95>entry called twice:>,
<:jump from eff. code to init. code:>,
<:str<95>eff<95>start called from :>,
<:str<95>set<95>entry called from :>));
if error_no = 208 or error_no = 209 then write (out, string text(increase(i)));
end;
e_n_d p_r_o_c_e_d_u_r_e write_message;
p_r_o_c_e_d_u_r_e fatal_error (error_no, text);
value error_no; integer error_no;
real array text;
comment calls write_message and stops execution;
begin
write_message (error_no, text);
error_bits := 3; <* ok.no warning.yes *>
goto fatal_error_exit;
e_n_d p_r_o_c_e_d_u_r_e fatal_error;
\f
<*** initialization of global variables ***>
<* initialization of field variables *>
bytes := 1;
words := 2;
reals := 4;
<* initialization of option variables *>
list_option := false;
test_option := false;
<* initialization of error dummy array *>
dummy(0) := -1.0;
<* read fp command and open input/output *>
get_fp_command;
<* initialize global variables *>
no_of_code_segms := intail.bytes(18) extract 12;
first_ext_segm := intail.bytes(16) extract 12 - 32;
<* if not a procedure in a library it should be zero *>
if first_ext_segm < 0 then first_ext_segm := 0;
<* no_of_segments and first_code_segm are set in analyze_code *>
entry := intail.bytes(11) extract 12;
ext_start := (intail.bytes(17) extract 12);
read_segment (first_ext_segm);
no_of_entries := input.bytes(ext_start) extract 12;
old_no_of_ext := input.bytes(ext_start+1) extract 12;
cat_no_of_ext := 0;
new_no_of_ext := 0;
max_no_of_ext := old_no_of_ext * 3 + 40;
\f
<* these strings are used when externals are checked *>
eff_start_name(0) := real (<:stref:> add 102); <* 102 is 'f' *>
eff_start_name(1) := real <:start:>;
set_entry_name(0) := real (<:strse:> add 116); <* 116 is 't' *>
set_entry_name(1) := real <:entry:>;
begin comment *** body for linker procedures ***;
<* declarations of local external catalog *>
real array ext_names (1:max_no_of_ext, 0:1);
integer array ext_params (1:max_no_of_ext, 0:1),
entry_points (0:no_of_entries), <* '0' to avoid 1:0 *>
new_ext_no (1:max_no_of_ext),
old_ext_no (1:max_no_of_ext);
\f
<**********************************************************************>
<* *>
<* linkanalyze *>
<* *>
<**********************************************************************>
p_r_o_c_e_d_u_r_e analyze_code;
comment the external list is copied into the local external catalog
constisting of 'ext_names' and 'ext_params', and it is
checked that 'eff_start' and 'set_entry' are included in
proper order.
externals that are used after 'eff_start' are marked:
new_ext_no ( old ext. number ) := new ext. number,
old_ext_no ( new ext. number ) := old ext. number.
finally it is checked that the code does not incluse jumps
from code after eff_start till code before eff_start;
begin
\f
p_r_o_c_e_d_u_r_e read_ext_list;
comment reads global entry pointes into 'entry_points' and
externals from external list into the local external
catalog consisting of 'ext_names' and 'ext_params';
begin
integer i, j;
integer array ext_words (1:4);
<* start ext list and skip head word *>
next_ext_word (ext_start//2);
<* read no of own bytes and skip them *>
no_of_own_bytes := next_ext_word (0);
for i := 1 step 1 until (no_of_own_bytes+1) // 2 do next_ext_word (0);
<* get entry points *>
for i:= 1 step 1 until no_of_entries do entry_points(i) := next_ext_word (0);
<* get externals *>
eff_start_no := -1;
set_entry_no := -1;
for i := 1 step 1 until old_no_of_ext do
begin
for j := 1 step 1 until 4 do ext_words(j) := next_ext_word (0);
ext_names(i,0) := ext_words.reals(0);
ext_names(i,1) := ext_words.reals(1);
ext_params(i,0) := next_ext_word (0);
ext_params(i,1) := next_ext_word (0);
<* is it eff_start... *>
if ext_names(i,0) = eff_start_name(0)
and ext_names(i,1) = eff_start_name(1) then eff_start_no := i;
<* is it set_entry... *>
if ext_names(i,0) = set_entry_name(0)
and ext_names(i,1) = set_entry_name(1) then set_entry_no := i;
end;
cat_no_of_ext := old_no_of_ext;
\f
<* get date and time from ext. list *>
date := next_ext_word(0); time := next_ext_word(0);
if test_option then
begin
write (out, <:<10>entry point: :>, entry,
<:<10>no of ent. pnts::>, no_of_entries,
<:<10>no of externals::>, old_no_of_ext,
<:<10>no of own bytes::>, no_of_own_bytes,
<:<10>start ext. list::>, ext_start, <:<10>:>);
<* udskriv external list *>
if old_no_of_ext > 0 then
begin
write (out, <:<10>external list::>);
for i := 1 step 1 until old_no_of_ext do
begin
j := 0;
<* is it a special running system enrty *>
if ext_names(i,0) <0 then write (out, <:<10>:>, i, <:. <r.s.entry>:>)
else write (out, <:<10>:>, i, <:. :>, string ext_names(i,increase(j)));
end for;
end if;
end test_option;
if eff_start_no < 0 then fatal_error (201, dummy)
else if set_entry_no < 0 then fatal_error (202, dummy)
else if eff_start_no > set_entry_no then fatal_error (203, dummy);
e_n_d p_r_o_c_e_d_u_r_e read_ext_list;
\f
p_r_o_c_e_d_u_r_e check_entry_ref (entry_no);
value entry_no; integer entry_no;
comment 'entry_no' is expected to be the no of an entry
which is refered to after call of eff_start. it is
tested if the label is placed before call of eff_start;
begin
integer segment, rel_byte;
rel_byte := entry_points(entry_no);
<* only code segments are counted *>
segment := rel_byte shift (-12) + first_code_segm;
rel_byte := rel_byte extract 12;
<* is it ref. to segment before eff_start segment *>
if segment < eff_start_segm
<* eff_start segment is tested only if rel. byte is given *>
or ( segment = eff_start_segm
and rel_byte > 0
and rel_byte < eff_start_rel ) then fatal_error (207, dummy);
e_n_d p_r_o_c_e_d_u_r_e check_entry_ref;
\f
p_r_o_c_e_d_u_r_e check_ext_ref (ext_no, chain);
value ext_no, chain; integer ext_no, chain;
comment 'ext_no' is expected to be the no. of an external which
is called after 'eff_start'. the external gets the next
new external no., if it has not got a new no. allready.
it is an error if the external is 'eff_start' (it must
be 2. call), or if 'set_entry' is called and it has got
a new ext. no or if it is called with a nonzero chain
(more than one call in the same segment);
begin
<* is it eff_start *>
if ext_no = eff_start_no then fatal_error (205, dummy);
<* is it set_entry *>
if ext_no = set_entry_no then
begin
<* test if it was used in another segment *>
if new_ext_no(ext_no) > 0 then fatal_error (206, dummy);
<* if chain used then test more than one call in this segm. *>
if chain > 0 then
begin
if input.bytes(chain) extract 12 > 0 then fatal_error (206, dummy);
end;
end
else
<* is it a new entry *>
if new_ext_no(ext_no) = 0 then
begin
new_no_of_ext := new_no_of_ext + 1;
new_ext_no(ext_no) := new_no_of_ext;
old_ext_no(new_no_of_ext) := ext_no;
end;
e_n_d p_r_o_c_e_d_u_r_e check_ext_ref;
\f
p_r_o_c_e_d_u_r_e check_segment_ref (rel_segm, rel_byte);
value rel_segm, rel_byte; integer rel_segm, rel_byte;
comment 'rel_segm', 'rel_byte' is expected to be a segment
reference which is used after call of eff_start.
it is tested if the segment is placed before eff_start
and (if rel. byte is given) if the entry is in eff_
start segment before call of eff_start;
begin
integer segment;
<* rel_segm has 1. bit set. shift 0 in from right and 0/1 from left *>
segment := input_segment + (rel_segm shift 1) / 2;
<* is it ref. to segment before eff_start segment *>
if segment < eff_start_segm
<* eff_start segment is tested only if rel. byte is given *>
or ( segment = eff_start_segm
and rel_byte > 0
and rel_byte < eff_start_rel ) then
fatal_error (207, dummy);
e_n_d p_r_o_c_e_d_u_r_e check_segment_ref;
\f
p_r_o_c_e_d_u_r_e find_eff_start;
comment reads from input until the segment calling 'eff_start'
is found;
begin
integer segment_no, byte_no, last_point, right_byte;
segment_no := first_code_segm;
eff_start_segm := -1; <* -1 until the segment is found *>
while eff_start_segm < 0 and segment_no < no_of_segments do
begin
read_segment (segment_no);
<* read no of abs. words and points *>
last_point := input.bytes(0) extract 12;
byte_no := 2;
while eff_start_segm < 0 and byte_no <= last_point do
begin
if (input.bytes(byte_no) extract 12) - no_of_entries = eff_start_no then
begin
<* test that eff_start is called only once *>
right_byte := input.bytes(byte_no+1) extract 12;
if right_byte <> 0 then
begin
if (input.bytes(right_byte) extract 12) <> 0 then fatal_error (205, dummy);
end;
eff_start_segm := segment_no;
eff_start_rel := right_byte;
if test_option then write (out, <:<10> * str<95>eff<95>start in segment:>, segment_no);
end;
byte_no := byte_no + 2;
end word loop;
segment_no := segment_no + 1;
end segment loop;
if eff_start_segm < 0 then fatal_error (204, dummy);
e_n_d p_r_o_c_e_d_u_r_e find_eff_start;
\f
p_r_o_c_e_d_u_r_e test_eff_start_segm;
comment performs some tests on the special segment, in which
'eff_start' is called;
begin
integer byte_no, last_point, left_byte, right_byte, chain;
boolean ref_used;
read_segment (eff_start_segm);
last_point := input.bytes(0) extract 12;
for byte_no := 2 step 2 until last_point do
begin
left_byte := input.bytes(byte_no) extract 12;
right_byte := input.bytes(byte_no+1) extract 12;
<* is it an entry point / external ref. *>
if left_byte > 0 and left_byte <= no_of_entries + old_no_of_ext then
begin
<* test if it is used after call of eff start *>
ref_used := false;
chain := right_byte;
<* if no chain then nobody knows *>
if chain = 0 then ref_used := true
else
repeat
if chain > eff_start_rel then ref_used := true;
chain := input.bytes(chain) extract 12;
until chain = 0; <* = end of chain *>
if ref_used then
begin
<* is it an entry point ref. *>
if left_byte <= no_of_entries then check_entry_ref (left_byte)
else check_ext_ref (left_byte-no_of_entries, right_byte);
end if ref_used;
end entry point/external;
end word loop;
e_n_d p_r_o_c_e_d_u_r_e test_eff_start_segm;
\f
p_r_o_c_e_d_u_r_e test_eff_code;
comment analyzes the segments after eff_start segment;
begin
integer segment_no, byte_no, last_point, left_byte, right_byte;
for segment_no := eff_start_segm + 1 step 1 until no_of_segments - 1 do
begin
read_segment (segment_no);
last_point := input.bytes(0) extract 12;
for byte_no := 2 step 2 until last_point do
begin
left_byte := input.bytes(byte_no) extract 12;
right_byte := input.bytes(byte_no+1) extract 12;
<* is it a segment reference... *>
if left_byte >= 2048 then <* 1. bit of byte was set *>
check_segment_ref (left_byte, right_byte)
else
<* is it a reference to own... *>
if left_byte = 0 then
begin <* skip it *> end
else
<* is it an entry point reference... *>
if left_byte <= no_of_entries then
check_entry_ref (left_byte)
else
<* is it an external reference... *>
if left_byte <= no_of_entries + old_no_of_ext then
check_ext_ref (left_byte - no_of_entries, right_byte);
end word loop;
end segment loop;
e_n_d p_r_o_c_e_d_u_r_e test_eff_code;
\f
<* b_o_d_y of analyze_code *>
if test_option then
write (out, <:<10><10> > start analyze<95>code:>);
<* initialize connection between new and old ext. list *>
zeroset (new_ext_no, old_ext_no);
<* read external list *>
read_ext_list;
<* now we know where the code starts *>
first_code_segm := input_segment;
no_of_segments := no_of_code_segms + first_code_segm;
if test_option then write (out, <:<10>no. of segments: :>, no_of_segments,
<:<10>first code segment::>, first_code_segm);
<* search code until segment with call of eff_start is found *>
find_eff_start;
<* test eff_start segment *>
test_eff_start_segm;
<* test segments after eff_start segment *>
test_eff_code;
e_n_d p_r_o_c_e_d_u_r_e analyze_code;
\f
<**********************************************************************>
<* *>
<* linkextend *>
<* *>
<**********************************************************************>
p_r_o_c_e_d_u_r_e extend_ext_list;
comment the local external catalog is tested from one end, and
for each exteral used after eff_start ( new_ext_no(ext.no)
> 0 ) its external list is searched and externals which
are not allready in the catalog are added to the end of
this and given the next number ( in new_ext_no/old_ext_no ).
these externals will then be tested later on, and more
externals might be added to the list. in this way the
test is continued until the end of the list is reached.
if an external is a subentry the main procedure is added
instead of the subentry;
begin
integer ext_no, ext_ext_no, ext_ext_rel, no_of_ext_ext, i;
real array main_name, name (0:1);
integer array param (0:1), ext_tail (1:10);
boolean more;
\f
boolean
p_r_o_c_e_d_u_r_e open_ext_input (name, tail);
real array name; integer array tail;
comment if 'name' is the name of an extrenal procedure
this is conneted to the zone 'input'. if it is a
subentry the main procedure is found, if it is a
procedure in a compressed library the library area
is opened. if an area is opened the result is true and
the position is set to the first segment of the procedure;
begin
integer i, type, entry_segm;
entry_segm := -1; <* until entry segment is found *>
repeat
type := open_zone (input, name, tail);
input_segment := -1;
<* if procedure on library or subentry then get name in tail *>
if type = 2 or type = 3 then
for i := 1 step 1 until 4 do name.words(i-3) := tail.words(i);
<* procedure in library: store ext. list segm./rel. *>
if type = 2 then
begin
entry_segm := tail.bytes(16) extract 12 - 32;
ext_ext_rel := tail.bytes(17) extract 12;
end;
<* is it a normal procedure and not a proc. in a libray... *>
if type = 1 and entry_segm < 0 then
begin
entry_segm := 0;
ext_ext_rel := tail.bytes(17) extract 12;
end;
until type <> 2 and type <> 3;
<* area opened... *>
if type <> 1 then open_ext_input := false
else
begin open_ext_input := true; read_segment (entry_segm) end;
e_n_d p_r_o_c_e_d_u_r_e open_ext_input;
\f
boolean
p_r_o_c_e_d_u_r_e next_ext_ext (start, name);
integer start;
real array name;
comment finds the name of the next external on 'input'.
if 'start' > 0 then it is expected to be the start of the
external list and then own bytes/entry points are skipped.
the proper segment is supposed to be read in allreay.
if an external is found it is stored in 'name' and
result is true. if the list is exhausted result is false;
begin
own integer total_no, this_no;
integer i, owns, ent_points;
integer array ext_words (1:4);
if start > 0 then
begin
total_no := next_ext_word (start//2);
ent_points := total_no shift (-12);
owns := next_ext_word (0);
<* skip own bytes and entry points *>
for i := 1 step 1 until (owns+1)//2 + ent_points do next_ext_word (0);
total_no := total_no extract 12;
this_no := 1;
end;
if this_no > total_no then next_ext_ext := false
else
begin
for i := 1 step 1 until 4 do ext_words(i) := next_ext_word (0);
name(0) := ext_words.reals(0);
name(1) := ext_words.reals(1);
<* skip parameters *>
next_ext_word(0); next_ext_word(0);
this_no := this_no + 1;
next_ext_ext := true;
end;
e_n_d p_r_o_c_e_d_u_r_e next_ext_ext;
\f
boolean
p_r_o_c_e_d_u_r_e lookup (name, param);
real array name;
integer array param;
comment result is true if 'name' is an external procedure.
if it is a procedure that is a subentry in another one
the name of the main procedure is stored in 'name'.
the parameter codes from the entry tail are stored
in 'param';
begin
zone lookup_zone (128, 1, stderror);
integer array tail (1:10);
integer type, i;
type := open_zone (lookup_zone, name, tail);
<* is it a subentry... *>
if type = 3 then
begin
for i := 1 step 1 until 4 do name.words(i-3) := tail.words(i);
type := open_zone (lookup_zone, name, tail);
<* main proc. is supposed to a normal proc. or proc. in lib. *>
if type <> 1 and type <> 2 then fatal_error (101, name);
end;
if type <= 0 then lookup := false
else
begin
lookup := true;
param(0) := tail.words(6);
param(1) := tail.words(7);
end;
close (lookup_zone, true);
e_n_d p_r_o_c_d_e_u_r_e lookup;
\f
p_r_o_c_e_d_u_r_e add_ext (name, param);
real array name; integer array param;
comment if 'name' is not in the local catalog it is inserted and
given the next 'new no'. if name is in the catalog, but has
no 'new no' (only used before eff_start) it is given one;
begin
integer ext_ptr;
boolean not_found;
<* test if it is in the catalog *>
ext_ptr := 0; not_found := true;
while ext_ptr < cat_no_of_ext and not_found do
begin
ext_ptr := ext_ptr + 1;
if name(0) = ext_names(ext_ptr,0) then
begin if name(1) = ext_names(ext_ptr,1) then not_found := false; end;
end while;
<* if not in the catalog then add it *>
if not_found then
begin
<* cat_no_of_ext is the no of externals in local catalog *>
cat_no_of_ext := cat_no_of_ext + 1;
if cat_no_of_ext > max_no_of_ext then fatal_error (-1, dummy);
ext_names (cat_no_of_ext, 0) := name(0);
ext_names (cat_no_of_ext, 1) := name(1);
ext_params (cat_no_of_ext, 0) := param(0);
ext_params (cat_no_of_ext, 1) := param(1);
ext_ptr := cat_no_of_ext;
end;
<* if not given a 'new no.' then do it *>
if new_ext_no(ext_ptr) = 0 then
begin
<* new_no_of_ext = no of ext. in new_ext_no/old_ext_no *>
new_no_of_ext := new_no_of_ext + 1;
new_ext_no (ext_ptr) := new_no_of_ext;
old_ext_no (new_no_of_ext) := ext_ptr;
end;
e_n_d p_r_o_c_e_d_u_r_e add_ext;
\f
<* b_o_d_y of extend_ext_list *>
if test_option then write (out, <:<10><10> > start extend<95>ext<95>list:>);
for ext_no := 1 step 1 until new_no_of_ext do
begin
main_name(0) := ext_names (old_ext_no(ext_no), 0);
main_name(1) := ext_names (old_ext_no(ext_no), 1);
if main_name(0) shift (-40) extract 8 > 64 then <* first char. is a letter *>
begin <* it is not '*version' or something like that *>
if open_ext_input (main_name, ext_tail) then
begin
i := 0; if test_option then write (out, <:<10> test: :>, string main_name(increase(i)),
<: segm.:>, input_segment, <: rel.:>, ext_ext_rel);
more := next_ext_ext (ext_ext_rel, name);
while more do
begin
<* eff_start and set_entry must not be called from ext. ext. *>
if name(0) = eff_start_name(0) then
begin if name(1) = eff_start_name(1) then fatal_error (208, main_name) end;
if name(0) = set_entry_name(0) then
begin if name(i) = set_entry_name(1) then fatal_error (209, main_name) end;
if name(0) shift (-40) extract 8 > 64 then <* first char. is a letter *>
begin
if lookup (name, param) then <* lookup gets main proc. in case of a subentry *>
begin
add_ext (name, param);
i := 0; if test_option then write (out,<:<10> * found: :>,string name(increase(i)));
end if lookup;
end if letter;
more := next_ext_ext (0, name);
end while more;
end if open;
end if letter;
end ext. loop;
<* insert end_task, eff_start and ext. called before eff_start *>
for ext_no := eff_start_no, set_entry_no, 1 step 1 until old_no_of_ext do
if new_ext_no(ext_no) = 0 then
begin
new_no_of_ext := new_no_of_ext + 1;
new_ext_no(ext_no) := new_no_of_ext; old_ext_no(new_no_of_ext) := ext_no;
end;
e_n_d p_r_o_c_e_d_u_r_e extend_ext_list;
\f
<**********************************************************************>
<* *>
<* linkoutput *>
<* *>
<**********************************************************************>
p_r_o_c_e_d_u_r_e write_code;
comment the external list might have grown in size and if so new
new segments are added in front. the start pointers for
the new external list are calculated and the list is
output. the other segments are then written with updated
reference numbers in abs. words/points;
begin
integer new_ext_start, extra_segments, i;
integer array next_segm_rel (0:19);
\f
p_r_o_c_e_d_u_r_e new_ext_pointers;
comment finds 'new_ext_start' (the start byte of the new list) and
assigns a value to 'extra_segments' (the no of segments
that must be added in front). finds continuation bytes for
ext. list segments and stores them in 'next_seg_rel';
begin
integer extension, input_segm_no, i;
extension := (new_no_of_ext - old_no_of_ext) * 12;
<* is it necessary to insert new segments *>
if extension <= 0 then
begin
extra_segments := 0;
new_ext_start := ext_start;
end
else
begin
extra_segments := extension//500 + 1;
new_ext_start := extra_segments*500 - extension + 2;
end;
<* find continuation pointers for external list segments.
this is done in order to avoid segment conflicts when we read
from input during output of ext.list (own bytes) *>
input_segm_no := first_ext_segm;
for i := 0 step 1 until (first_code_segm - first_ext_segm) + extra_segments - 1 do
begin
if i + 1 < extra_segments then next_segm_rel(i) := 2
else
if i + 1 = extra_segments then next_segm_rel(i) := ext_start
else
begin
read_segment (input_segm_no);
input_segm_no := input_segm_no + 1;
next_segm_rel(i) := input.words(251) extract 12;
end;
end segment loop;
e_n_d p_r_o_c_e_d_u_r_e new_ext_pointers;
\f
p_r_o_c_e_d_u_r_e open_output;
comment opens output area on zone 'output'. the entry tail is
copied from the input entry, except for segment/byte
pointers and segment counters - if new externals are added
or if old area was a library procedure;
begin
integer i, status, fnc;
integer array head_and_tail (1:17);
i := 0; open (output, 4, string output_name(increase(i)), 0);
<* lookup head and tail *>
status := monitor (76, output, 0, head_and_tail);
<* if it does not exist then create in on 'disc' *>
if status = 3 then
begin
fnc := 40; <* 'create entry' *>
out_tail.words(1) := 6580595; <* = 'dis' *>
out_tail.words(2) := 6488064; <* = 'c' < 18 *>
out_tail.words(3) := 0; out_tail.words(4) := 0;
end
else <* test if it is permanent *>
begin
if status = 0 then
begin
fnc := 44; <* 'change entry' *>
for i := 1,2,3,4 do out_tail.words(i) := head_and_tail.words(i+7);
end
else fatal_error (110+status, output_name);
end;
out_tail.words(0) := no_of_segments + extra_segments;
out_tail.bytes(16) := false add 4;
out_tail.bytes(17) := false add new_ext_start;
for i := 5,6,7,9 do out_tail.words(i) := in_tail.words(i);
status := monitor (fnc, output, 0, out_tail);
if status <> 0 then fatal_error (if fnc=40 then 120+status else 130+status, output_name);
e_n_d p_r_o_c_e_d_u_r_e open_output;
\f
p_r_o_c_e_d_u_r_e put_ext_word (word, start_pointer);
value word, start_pointer;
integer word, start_pointer;
comment writes a word into output external list. outputs a segment
if necessary. if start_ptr = 0 then the next word is used;
begin
own integer word_pointer, next_pointer_no;
integer byte_pointer;
<* is it the start of the list... *>
if start_pointer > 0 then
begin
output_segment := -1; <* no current output segment *>
out_segment (0);
output.words(0) := 0; <* head word, might be overwritten *>
word_pointer := start_pointer;
end;
<* put word *>
output.words(word_pointer) := word;
word_pointer := word_pointer + 1;
<* is it end of segment... (word 251 is rel. start of next) *>
if word_pointer = 251 then
begin
<* start ptr. of next segment is set by 'next_ext_pointers' *>
byte_pointer := next_segm_rel(increase(next_pointer_no));
output.words(251) := byte_pointer; <* continuation word *>
out_segment (output_segment + 1);
output.words(0) := 0; <* head word, might be overwritten *>
word_pointer := byte_pointer // 2;
end;
e_n_d p_r_o_c_e_d_u_r_e put_ext_word;
\f
p_r_o_c_e_d_u_r_e copy_ext_list;
comment writes the new external list on the output area;
begin
integer i, ptr, old_ptr;
integer array ext_words (1:4);
<* start of list *>
put_ext_word (no_of_entries shift 12 + new_no_of_ext, new_ext_start // 2);
read_segment (first_ext_segm);
<* set start pointer and skip first word *>
next_ext_word (ext_start // 2);
<* copy own bytes *>
for i := 1 step 1 until (no_of_own_bytes+3) // 2 do
put_ext_word (next_ext_word(0), 0);
<* copy entry points *>
for i := 1 step 1 until no_of_entries do put_ext_word (entry_points(i), 0);
<* copy list from local external catalog *>
for ptr := 1 step 1 until new_no_of_ext do
begin
old_ptr := old_ext_no (ptr);
ext_words.reals(0) := ext_names(old_ptr,0);
ext_words.reals(1) := ext_names(old_ptr,1);
for i := 1 step 1 until 4 do put_ext_word (ext_words(i), 0);
put_ext_word (ext_params(old_ptr,0), 0);
put_ext_word (ext_params(old_ptr,1), 0);
end;
<* write date and time from original ext. list *>
put_ext_word (date, 0);
put_ext_word (time, 0);
e_n_d p_r_o_c_e_d_u_r_e copy_ext_list;
\f
p_r_o_c_e_d_u_r_e copy_segments;
comment code segments are written on output. some of the abs.
words/points are changed due to the new ext. numbers:
1. ext. references are changed to their new numbers.
2. running system references are increased by the no of
externals that is added to the list. (r.s.ref. =
r.s.entry + no of entry points + no of ext.);
begin
integer extra_ext, segment_no, prev_out_segm,
first_ext_byte, i, last_point, byte_no, left_byte;
extra_ext := new_no_of_ext - old_no_of_ext;
<* segments are numbered from 0 to no of segments - 1 *>
for segment_no := first_code_segm step 1 until no_of_segments - 1 do
begin
read_segment (segment_no);
out_segment (segment_no + extra_segments);
last_point := input.bytes(0) extract 12;
<* most part of the segment will not be changed *>
if segment_no <> first_code_segm then to_from (output, input, 512)
else
begin <* do not overwrite ext. list *>
prev_out_segm := first_code_segm + extra_segments - 1;
first_ext_byte := if prev_out_segm < 0 then ext_start else next_segm_rel(prev_out_segm);
for i := 0 step 1 until (first_ext_byte-2)//2 do output.words(i) := input.words(i);
for i := entry//2 step 1 until 255 do output.words(i) := input.words(i);
end;
<* test abs.words/points *>
for byte_no := 2 step 2 until last_point do
begin
left_byte := input.bytes(byte_no) extract 12;
<* ext. reference... *>
if left_byte > no_of_entries and left_byte <= no_of_entries + old_no_of_ext then
<* local numbers do not count entry points *>
output.bytes(byte_no) := false add ( new_ext_no(left_byte-no_of_entries) + no_of_entries )
else <* r.s.entry... ( < 2048 means 1. bit of byte not set) *>
if left_byte > no_of_entries + old_no_of_ext and left_byte < 2048 then
output.bytes(byte_no) := false add ( left_byte + extra_ext );
end word loop;
end segment loop;
e_n_d p_r_o_c_e_d_u_r_e copy_segments;
\f
<* b_o_d_y of write_code *>
if test_option then
begin
write (out, <:<10><10> > start write<95>code:>);
i := 0;
write (out, <:<10>output: :>, string output_name (increase(i)));
end;
<* reopen input area *>
open_input (input_name);
<* find 'new_ext_start' and 'extra_segments' *>
new_ext_pointers;
if test_option then write (out, <:<10> segments added::>, extra_segments,
<:<10> new ext. start::>, new_ext_start);
<* open output area and set entry tail *>
open_output;
<* copy new external list to output area *>
copy_ext_list;
<* copy other segments with new abs.words/points *>
copy_segments;
setposition (output, 0, 0);
close (output, true);
e_n_d p_r_o_c_e_d_u_r_e write_code;
\f
<**********************************************************************>
<* *>
<* linkmain *>
<* *>
<**********************************************************************>
<* check code and find externals called after 'eff_start' *>
analyze_code;
<* add extenals to the local external catalog *>
extend_ext_list;
<* output code with new ext. list and changed abs.words/points *>
if output_on then write_code;
if test_option or list_option then <* write new external list *>
begin
integer i, j;
write (out, <:<10><10>new external list::>);
for i := 1 step 1 until new_no_of_ext do
begin
j := 0;
write (out, <:<10>:>, <<dd>, i, <:. (:>);
if old_ext_no(i) > old_no_of_ext then write (out, <: -:>)
else write (out, old_ext_no(i));
write (out, <: ) :>,
if ext_names(old_ext_no(i),0) < 0 then <:<r.s.entry>:>
else string ext_names(old_ext_no(i),increase(j)), <: (:>,
ext_params(old_ext_no(i),0) shift (-12),
ext_params(old_ext_no(i),0) extract 12,
ext_params(old_ext_no(i),1) shift (-12),
ext_params(old_ext_no(i),1) extract 12, <:):> );
end ext. loop;
end if test_option;
end *** main body for linker procedures ***;
fatal_error_exit:
trapmode := 1 shift 10; <* no 'end <no of seg. trans.>' *>
write (out, <:<10>prelinker end<10>:>);
end
\f
▶EOF◀