⟦6232f3d98⟧

TextFileVerbose

program cross_linker(in_obj_file, out_bin_file, output);


(*    cross linker.
      ================
*)



label
1 ;           (*  continuation point after fatal error  *)

const
(*$t- *)
version = '81.06.02';
boot_revisio_number = 6;   (* boot files must say this version !!! *)
compiler_version_number = 6;  (* the expected compiler version number *)
max_obj_params = 20;
max_externals = 150;
alfa_length = 12;
three_shift_6 = 192;
two_to_16 = 65536;
preoccupied = 0; (* stack used by boot-process *)
coresize = 20000;
process_kind = 1; (* used as 'kind-of-obj' *)
test_version = false;  (* for conditional tests *)
yes = 'yes'; no = 'no'; (* fp parameters *)

type
file_identifier = alfa;

identifier = array [ 1 .. 6 ] of integer;

program_point =  record
                   page_no : integer;
                   rel_byte : integer
                 end;

address = record
            base : integer;
            displ : integer
          end;

param_descr = record
                no_of_params : integer;
                param : array [ 1 .. max_obj_params ] of
                          record
                            param_type : integer;
                            param_size : integer
                          end
              end;

ext_states = (defined, undef);




var
obj_file_name : file_identifier;
bin_file_name : file_identifier;

core_image: array [ 1 .. coresize ] of integer;
hextab: array [ 0 .. 15 ] of char;
ext_table: array [ 1 .. max_externals ] of
record
name: identifier;
compile_date : integer;  (* as packed by pass 6!!! *)
compile_time : packed record
case boolean of
false: ( int : integer );
true : (
revision : 0 .. 31;   (* 5 bits *)
hour     : 0 .. 31;   (* 5 bits *)
minute   : 0 .. 63;   (* 6 bits *)
);
end; (* compile time as defined by pass6 !!! *)
state: ext_states;
paramlist: param_descr;
saved_d_addr: address;
entry_addr: address;
end;

bind_yes,
descr_yes : boolean;

start_module : integer;
start_displ  : integer;
start_addr   : address;
first_of_module,
top_of_module : integer;

param_index : integer;
no_of_obj_files : integer;


descr_length,
no_of_pages,
size_of_page,
bytes_on_last_page,
kind_of_obj              : integer;

name_of_obj              : identifier;

entry_point,
exception_point,
exit_point               : program_point;

default_appetite,
appetite                 : integer;

obj_params               : param_descr;


top_of_bin,
d_addr,
code_addr                : address;

d_length                 : integer;


in_obj_file,
out_bin_file             : file of integer;


r, i, j, sep, length, word      : integer;
code_words, code_bytes : integer;

a : alfa;

to_addr,
addr : address;

map_yes,
print_code : boolean;
print_pr_line : integer;
print_heading : boolean;

library,
source_file: boolean;

scan : integer;
last_scan, any_included,
after_lib,
wanted: boolean;
entry, ext_entry,
last_external: integer;
no_of_uses,
no_of_int,
no_of_ext: integer;





procedure  mess_init;
begin
writeln;
writeln( '   cross linker, version ', version )
end;


procedure  mess_end;
begin
writeln( '   end, cross linker. ' )
end;


procedure  mess_error( kind, no, inf : integer );
begin
write( ' ****** message from cross linker :' );
if kind = 1 then
write( 'fatal error' )
else
write( 'warning' );
write( '   at :   ' );    writeln( no );
write( '      information : ' );   writeln( inf );
if kind = 1 then readln(output);
end;


procedure writehex (decimal: integer);
begin
write (hextab [ decimal div (16*16*16) ]);
write (hextab [ decimal div (16*16)    mod 16 ]);
write (hextab [ decimal div (16)       mod 16 ]);
write (hextab [ decimal                mod 16 ]);
end;


procedure  in_open( id : file_identifier );
begin
open( in_obj_file, id );
reset( in_obj_file )
end;


procedure  in_close;
begin
close( in_obj_file )
end;


procedure in_word ( var i : integer );
begin
if eof (in_obj_file) then i := -1
else
read (in_obj_file, i);
if test_version then
if ( i < -1 ) or ( i >= two_to_16 ) then mess_error (1, 7919, i);
end;


procedure  in_identifier( var id : identifier );
var i : integer;
begin
for i := 1 to 6 do read( in_obj_file,  id[ i ] )
end;


procedure in_params ( var p: param_descr);
var i: integer;
begin
with p do
begin
read( in_obj_file, no_of_params);
for i := 1 to no_of_params do
with param [ i ] do
begin
read( in_obj_file, param_type);
read( in_obj_file, param_size);
end;
for i := no_of_params+1 to max_obj_params do
with param [ i ] do
begin
param_type := 0;
param_size := 0;
end;
end;
end;


function compare_paramlists (entry: integer): boolean;
var
i: integer;
begin
compare_paramlists := true;  (* assume everything ok *)
with ext_table [ entry ] . paramlist do
if no_of_params <> obj_params.no_of_params then
compare_paramlists := false
else
for i := 1 to no_of_params do
with param [ i ] do
if (
param_type <> obj_params.param [ i ] . param_type
) 
or
(param_size <> obj_params.param [ i ] . param_size)
then
compare_paramlists := false;
end;




procedure  in_point( var p : program_point );
begin
read( in_obj_file,  p.page_no );
read( in_obj_file,  p.rel_byte )
end;




procedure out_init( id : file_identifier );
begin
open( out_bin_file, id );
rewrite( out_bin_file )
end;


procedure  out_integer( i : integer );
begin
if ( i < 0 ) or ( i >= two_to_16 ) then mess_error( 1, 2, i );
write( out_bin_file, i )
end;


procedure  out_addr( a : address );
begin
out_integer( three_shift_6 + a.base * 2 );
out_integer( a.displ )
end;


procedure  out_identifier( id : identifier );
var  i : integer;
begin
for i := 1 to 6 do out_integer( id[ i ] )
end;


procedure  out_end;
begin
write( out_bin_file, -1 );
close( out_bin_file )
end;



procedure print_addr (a: address);
begin
with a do
begin
writehex (three_shift_6 + base * 2);
write('.');
writehex (displ);
end;
end;



procedure print_name (name: identifier);
var i: integer;
begin
for i := 1 to 6 do
write ( chr ( name [ i ] div 256 ), chr ( name [ i ] mod 256 ) );
end;



procedure print_map (entry: integer);
var
i : integer;
begin
if print_heading then
begin
writeln;
write ('  name      ');
write ('     date   ');
write (' time  ');
write ('    descr  ');
write ('    code   ');
write ('    entry  ');
write ('     top   ');
writeln;
for i := 1 to 12+12+7+4*11 do write ('-');
writeln;
print_heading := false;
end;
with ext_table [ entry ] do
begin
print_name (name); write ('  ');
if compile_date > 0 then
write(1900+compile_date div (16*32):4,
'.', compile_date div 32 mod 16 div 10:1, compile_date div 32 mod 16 mod 10:1,
'.', compile_date mod 32 div 10:1, compile_date mod 32 mod 10:1,
' ')
else
write(' ':4+1+2+1+2+2);
if compile_time.revision <> compiler_version_number then
write( 0:5 )
else
with compile_time do
write(hour div 10 : 1, hour mod 10 :1,
'.', minute div 10 :1, minute mod 10 :1, '   ' );

if descr_yes then
print_addr (d_addr)
else
write (' ': 9);
write ('  ');
print_addr (code_addr);
write ('  ');
print_addr (entry_addr);
write ('  ');
print_addr (top_of_bin);
writeln;
if (compile_time . revision <> compiler_version_number ) and descr_yes then
mess_error ( 2, 35, -3 );
end;
end;


procedure  map_hex( a : alfa; var h : integer );
var  k, i : integer;
begin
   if a[ 1 ] <> 'h' then mess_error( 1, 3, param_index );
k := 0;

for i := 2 to alfa_length do
begin
if ( '0' <= a[ i ] ) and ( a[ i ] <= '9' ) then
k := k * 16 + ( ord( a[ i ] ) - ord( '0' ) )
else
if ( 'a' <= a[ i ] ) and ( a[ i ] <= 'f' ) then
k := k * 16 + ( ord( a[ i ] ) - ord( 'a' ) + 10 )
else
if a[ i ] <> ' ' then
mess_error( 1, 4, param_index )
end (*  for .....  *);

if k >= two_to_16 then mess_error( 1, 5, param_index );

h := k
end;


procedure  map_laddr( m, d : integer; var a : address );
begin
if ( m < 0 ) or ( m >= 32 ) then mess_error( 1, 7, m );
if ( d < 0 ) or ( d >= two_to_16 ) then mess_error( 1, 8, d );
a.base := m;
a.displ := d
end;


procedure reserve_area (size: integer; var a: address);
begin
if a.displ + size > top_of_module then
begin
map_laddr (a.base + 1, first_of_module, a);
end;
end;


procedure  map_incr( f : address; offset : integer; var a : address );
var old_base : integer;
begin
old_base := f.base;
reserve_area(offset+1, f);
a.base := f.base;
if old_base = f.base then  (* same module *)
a.displ := f.displ + offset
else (* change module *)
a.displ := f.displ;
end;


procedure  map_point( f : address; size : integer; p : program_point;
                         var a : address );
var  offset : integer;
begin
offset := ( p.page_no - 1 ) * size + p.rel_byte;
if (offset < 0) or (offset >= code_bytes) then
mess_error(1, 7913, offset);
map_incr( f, offset, a )
end;


procedure in_addr (var a: address);
var point: program_point;
begin
 (* simulate: in_point (point); *)
with point do read(in_obj_file, page_no, rel_byte );

map_point (code_addr, size_of_page, point, a);
end;


function get_byte (addr: address; rel: integer) : integer;
var
byte_index, word_index: integer;
begin
with addr do
begin
byte_index := displ + rel - code_addr.displ;
if (byte_index < 0) or (byte_index >= code_bytes) then
mess_error(1, 7913, byte_index);
word_index := byte_index div 2 + 1;
if not odd (byte_index) then
get_byte := core_image [ word_index ] div 256
else
get_byte := core_image [ word_index ] mod 256;
end;
end;

procedure store_byte (to_addr: address; rel, byte: integer);
var
byte_index, word_index: integer;
begin
with to_addr do
begin
byte_index := displ + rel - code_addr.displ;
if (byte_index < 0) or (byte_index >= code_bytes) then
mess_error(1, 7913, byte_index);
word_index := byte_index div 2 + 1;
if not odd (byte_index) then
core_image [ word_index ] := core_image [ word_index ] mod 256 + byte * 256
else
core_image [ word_index ] := core_image [ word_index ] div 256 * 256 + byte;
end;
end;


procedure store_addr (to_addr, addr: address);
begin
(* add the displ in core-image to the new contents *)
map_incr (addr, get_byte (to_addr, -1) * 256 + get_byte (to_addr, 0), addr);
with addr do
begin
base := three_shift_6 + base * 2;
store_byte (to_addr, -3, base div 256);
store_byte (to_addr, -2, base mod 256);
store_byte (to_addr, -1, displ div 256);
store_byte (to_addr,  0, displ mod 256);
end;
end;


function new_entry: integer;
begin
last_external := last_external + 1;
new_entry := last_external;
with ext_table [ last_external ] do
begin
name := name_of_obj;
compile_date := 0;  (* undefined date *)
state := undef;
paramlist := obj_params;
entry_addr := start_addr;  (* dummy entry-addr *)
end;
any_included := true;
end;


function search_ext: integer;
label 99;
var entry: integer;
begin
for entry := 1 to last_external do
if ext_table [ entry ] . name = name_of_obj then
if compare_paramlists (entry) then
goto 99;
entry := 0; (* not found *)
99:;
search_ext := entry;
end;

begin

(*  initialize the modules ( except the output module ) :  *)

for i := 0 to 9 do hextab [ i ] := chr ( ord('0') + i);
for i := 10 to 15 do hextab [ i ] := chr ( ord('a') + i - 10);
mess_init;

last_external := 0;

(*  initialize the output module :  *)

print_heading := true;

r := system( 1, i, a );
if r = 0 then mess_error( 1, 101, r );

sep := r div 4096;   length := r mod 4096;
if ( length <> 10 ) or ( sep <> 6 ) then
mess_error( 1, 102, r );

r := system( 0, i, bin_file_name );
if r = 0 then mess_error( 1, 103, r );

sep := r div 4096;   length := r mod 4096;
if length <> 10 then mess_error( 1, 104, r );

out_init( bin_file_name );

scan := 0;
any_included := true; (* actually not correct, but helps first scan *)


(*  scan the parameter list :  *)
repeat
last_scan := not any_included;
any_included := false;
after_lib := false;

scan := scan + 1;
if last_scan then
writeln ('    linking solved in: ', scan:1, ' scans');

(* default values for options *)

bind_yes := false;

descr_yes := true;

start_module := 0;   start_displ := 256 (* = hex 100 *);

print_code := false;
print_pr_line := 16; (* default: 16 words pr line *)

map_yes := true;

(* initialize loop-variables *)

first_of_module := 2;
top_of_module   := two_to_16 - preoccupied;

param_index := 2;
no_of_obj_files := 0;


r := system( param_index, i, a );

while r <> 0 do
begin

library := false;

sep := r div 4096;   length := r mod 4096;
if ( length <> 10 ) or ( sep <> 4 ) then
mess_error( 1, 105, r );

sep := system (param_index+1, i, a) div 4096; (* get next seperator *)
r   := system (param_index  , i, a);
if sep = 8 then
begin (* option name, followed by point *)

source_file := false;

if a = 'descr' then
begin

r := system( param_index + 1 , i, a );
if r = 0 then mess_error( 1, 106, param_index + 1 );

sep := r div 4096;   length := r mod 4096;
if ( length <> 10 ) or ( sep <> 8 ) then
mess_error( 1, 107, r );

if a =  yes  then  descr_yes := true
else
if a =  no  then descr_yes := false
else
mess_error( 1, 108, param_index + 1 );

param_index := param_index + 2


end  (*  a = 'descr' .........  *)

else

if a = 'start' then
begin

if no_of_obj_files > 0 then mess_error( 1, 113, param_index );

(*  get the module no. :  *)

r := system( param_index + 1, i, a );
if r = 0 then mess_error( 1, 109, param_index + 1 );

sep := r div 4096;   length := r mod 4096;
if sep <> 8 then mess_error( 1, 110, r );

if length = 4 then  start_module := i
else
if length = 10 then  map_hex( a, start_module )
else
mess_error( 1, 111, r );
if (start_module < 192) or (256 <= start_module) then
mess_error( 1, 115, r );

start_module := (start_module mod 64) div 2;


(*  get the displacement :  *)

r := system( param_index + 2, i, a );
if r = 0 then mess_error( 1, 112, param_index + 2 );

sep := r div 4096;   length := r mod 4096;
if sep <> 8 then mess_error( 1, 114, r );

if length = 4 then  start_displ := i
else
if length = 10 then  map_hex( a, start_displ )
else
mess_error( 1, 119, r );

param_index := param_index + 3;

end (*  a = 'start' .......  *)

else

if a = 'print' then
begin
r := system (param_index+1, i, a);
if r <> 8*4096 + 10 then
mess_error (1, 7914, param_index);
if a =  yes  then print_code := true
else
if a =  no  then print_code := false
else
mess_error (1, 7915, param_index);
param_index := param_index + 2;
r := system (param_index, i, a);
if r = 8*4096 + 4 then
begin (* point-integer *)
print_pr_line := i;
param_index := param_index + 1;
end;

end (* a = 'print' .......  *)

else

if a = 'lib' then
begin
r := system (param_index+1, i, a);
if r = 8*4096 + 10 then
begin
(* note: param-index is also incremented as <sourcefile> *)
param_index := param_index + 1;
library := true;
source_file := true;
end
else
mess_error (1, 7917, param_index);
end (* a = 'lib' ....... *)

else

if a = 'map' then
begin
r := system (param_index+1, i, a);
if r <> 8*4096 + 10 then
mess_error (1, 7920, param_index);
if a =  yes  then map_yes := true
else
if a =  no  then map_yes := false
else
mess_error (1, 7921, param_index);
param_index := param_index + 2;
end (* a = 'map' ....... *)

else
if a = 'bind' then
begin
r := system( param_index + 1, i, a );
if r mod 4096 <> 10 then
mess_error( 1, 7920, param_index );
if (a=yes) or (a=no) then
bind_yes := a = yes
else
mess_error( 1, 7921, param_index ); (* yes or no excpected *)
param_index := param_index + 2;
end   (* a = 'bind' *)

else mess_error (1, 7916, param_index); (* unknown option-name *)

end (* option *)

else source_file := true;

if source_file then
begin

(*  'a' must contain the name of an object program ( file ),
which has to be included in the binary progam ( file ) .  *)

obj_file_name := a;
no_of_obj_files := no_of_obj_files + 1;

(* optimization: omit scanning the (normal) sourcefiles except   *)
(*               during the very first and last scans, and after *)
(*               any library-files                               *)
after_lib := after_lib or library;
if no_of_obj_files = 1 then
begin
if (scan = 1) or last_scan then
map_laddr (start_module, start_displ, start_addr);
top_of_bin := start_addr;
end;
if (scan = 1) or last_scan or after_lib then
begin

in_open( obj_file_name );

(*  read segment descriptor, part 1 :  *)

read( in_obj_file,  descr_length );

while descr_length > 0 do
begin
wanted := true;
read( in_obj_file,  no_of_pages );
read( in_obj_file,  size_of_page );
read( in_obj_file,  bytes_on_last_page );

read( in_obj_file,  kind_of_obj );
if kind_of_obj > 3 then
wanted := false;  (* skip open routines in library *)

in_identifier( name_of_obj );

in_point( entry_point );
in_point( exception_point );
in_point( exit_point );

read( in_obj_file,  default_appetite );
read( in_obj_file,  appetite );

in_params (obj_params);

if descr_length <> ( 2 * ( 20 + 2 * obj_params.no_of_params ) ) then
mess_error( 1, 118, descr_length );


if descr_yes then
d_length := descr_length
else
d_length := 0;


code_bytes := (no_of_pages - 1) * size_of_page + bytes_on_last_page;
code_words := (code_bytes + 1) div 2;


entry := search_ext;
if entry = 0 (* not in table *) then
if library then
wanted := false
else
entry := new_entry;

if wanted then
with ext_table [ entry ] do
begin
d_addr := top_of_bin;
if bind_yes then
(* force new module if (descr-length + code-length) exceeds 
the remaining part of current module *)
reserve_area( d_length + 2 * code_words, d_addr )
else
reserve_area (d_length, d_addr);
if not last_scan then
saved_d_addr := d_addr
else (* test that the start-address has'nt changed during the very last scan *)
if saved_d_addr <> d_addr then
begin
mess_error (0, 7922, 0);
print_map (entry);
write ('   saved_d_addr was: ');
print_addr (saved_d_addr);
writeln;
end;
map_incr (d_addr, d_length, code_addr);
reserve_area (2 * code_words, code_addr);
map_incr (code_addr, 2 * code_words, top_of_bin);
map_point (code_addr, size_of_page, entry_point, entry_addr);
if map_yes or print_code then
if last_scan then
print_map (entry);
state := defined;
end;


if descr_yes and wanted and last_scan then
begin

(*  output the reduced descriptor segment :  *)

out_integer( d_length );
out_integer( no_of_pages );
out_integer( size_of_page );
out_integer( bytes_on_last_page );

out_integer( kind_of_obj );

out_identifier( name_of_obj );

map_point( code_addr, size_of_page, entry_point, addr );
out_addr( addr );

if kind_of_obj = process_kind then
map_point( code_addr, size_of_page, exception_point, addr );
out_addr( addr );

if kind_of_obj = process_kind then
map_point( code_addr, size_of_page, exit_point, addr );
out_addr( addr );

out_integer( default_appetite );
out_integer (appetite);

with obj_params do
begin
out_integer( no_of_params );
for i := 1 to no_of_params do
begin
out_integer( param[ i ].param_type );
out_integer( param[ i ].param_size );
end
end

end;

for i := 1 to code_words do
read (in_obj_file, core_image [ i ]);
if wanted and descr_yes then
with ext_table [ entry ] do
begin
compile_date := core_image [ 1 ];  (* first word is defined by pass6 !! *)
compile_time . int := core_image [ 2 ]; (* second word is define by pass6 !! *)
end;


read( in_obj_file, no_of_ext);
for i := 1 to no_of_ext do
begin
in_identifier (name_of_obj);
in_params (obj_params);

if wanted then
begin
ext_entry := search_ext;
if ext_entry = 0 then
ext_entry := new_entry;
addr := ext_table [ ext_entry ] . entry_addr;
end;

read( in_obj_file, no_of_uses);
if wanted and last_scan then
for j := 1 to no_of_uses do
begin
in_addr (to_addr);
store_addr (to_addr, addr);
end
else
for j := 1 to 2*no_of_uses do
begin
read( in_obj_file, ext_entry);
end;
end; (* process external links *)
 (* process the internal link list *)
read( in_obj_file,  no_of_int );
if wanted and last_scan then
for i := 1 to no_of_int do
begin
in_addr (to_addr);
in_addr (addr);
store_addr (to_addr, addr);
end
else
(* skip the internal links *)
for i := 1 to 4 * no_of_int do
begin
read( in_obj_file, j);
end;


if wanted and last_scan then
begin

(* put boot-version number into coreimage (2) if correct compiler version *)
with ext_table[ entry ] . compile_time do
if descr_yes and (revision = compiler_version_number) then
begin
revision := boot_revision_number;
core_image [ 2 ] := int;
end;


for i := 1 to code_words do
begin
j := core_image [ i ];
if (j < 0) or (j >= two_to_16) then
mess_error (1, 2, j);
write (out_bin_file, j);
end;

if print_code then
begin
for i := 1 to code_words do
begin
if (i mod print_pr_line) = 1 then
begin
map_incr (code_addr, 2 * i - 2, addr);
writehex(three_shift_6 + addr.base * 2);
write('.');
writehex (addr.displ);
write(' ');
writehex (i*2 - 2);
write (':');
end;
write('  ');
writehex (core_image [ i ]);
if (i mod print_pr_line) = 0 then
writeln;
end;
if (i mod print_pr_line) <> 0 then
writeln;
writeln;
end;


end; (* output etc *)


in_word (descr_length);
end; (* while descr-length > 0 *)


in_close;

if not after_lib then
start_addr := top_of_bin;

end;

param_index := param_index + 1


end  (*  a  must contain ..........  *);

(*  read next parameter :  *)

r := system( param_index, i, a )

end  (*  while  r <> 0  ......  *);
until last_scan;

(* test that all externals are defined *)
for i := 1 to last_external do
with ext_table [ i ] do
if state = undef then
begin
write ('*** ');
print_name (name);
writeln (' :  not defined');
end;


(*  the parameter list is exhausted.
   add the rudimentary descriptor segment to the bin. progr. ( file ) :  *)

if descr_yes then out_integer( two_to_16 - 1 (* i.e. -1 in 16-bit *) );


(*  terminate the modules :  *)
out_end;
mess_end;


1 :          (*  exit point for fatal errors.  *)


end.
«eof»
DataMuseum.dk

RC3500

⟦6232f3d98⟧ TextFileVerbose

Derivation

TextFileVerbose
