⟦1d2478251⟧

TextFileVerbose

(*$t- *)
program pass6(input,output,code);

(* if used as an asembler the call is:

<code file> = platonpass6 <option list> <source file> <descriptor file>

<code file>        punch16 file, default name is pass6code
<source file>      default name is pass5code
<descriptor file>  defaule name is pass5descr

.                                                     *
<option list> ::= ( <option> . <yes or no or number> ) 

.                              default         meaning

<option> ::= list              ( no )      list the input
.          ! test              ( no )      generate test output
.          ! codesize          ( 512 )     size of a program page
.          ! print             ( no )      print the generated code
.          ! errormess         ( no )      list erroneus lines
.          ! nametable         ( no )      list the nametable at blockends
.          ! spacing           ( 52 )      line table spacing
.          ! statistics         ( no )    generate op-code statistics
.          ! lineinfo          ( yes )      generate line information



<yes or no or number> ::= yes  ! no  ! <number>




*)

\f


label
9997,    (* open routine, end of line action *)
9998,   (* end program met *)
9999;  (* exit label used in case of fatal errors *)



const
version = 'pascal80 pass6      1981.05.06 ';
pass6_version = 415; (* internal compiler version * 100 + sub version *)
demanded_pass5_version = 200; (* the least allowed pass5 version number *)
hash_function_test = true; (* conditional print of hash function collisions *)

statistical_version = true; (* conditional code !!! *)
blank      = '      ';
maxnameix  =   1500;  (* maximum number of different (active) names *)
maxunsatrefs = 2200;  (* maximum number of internal links *)
min_buffer_size = 30;
default_buffer_size = 512;
codebuffersize = 15000;
length_of_descriptor = 16;  (* length of name table head *)
linrec_segment_offset=  4;  (* offset of segment length in the line table head *)
linrec_spacing_offset=  10;  (* offset of spacing info in the line table head *)

default_line_table_spacing = 52;   (* i.e. a line record is generated for groups of 26 bytes of code *)
fix_line_table_part = 8;       (* 4 bytes for a chain to the next table
+ 2 bytes for a start line number 
+ 2 bytes for first and last record *)
max_line = 255;      (* line records are numbers inside (0..255) *)
namelength =  6;     (* number of significant characters of a name *)
chbufmax   = 15;     (* maximum number of characters of a word read *)
nill       =  0;
maxlevel   = 25;     (* maximum depth of nesting *)
maxlinelength = 200; (* maximum number of characters in one line *)
higherror  = 16;     (* number of error messages *)

word_min   = -32768; (* - 2 ** 15       *)
word_max   =  65535; (*   2 ** 16 - 1   *)
maxbyte    = 256;
addrsize   = 4;      (* number of bytes for a long address *)
longjump_size = 5;   (* number of bytes for a long jump *)


dep_chain_start   = 0;
max_dependence_ix = 30;
max_code_number   = #hff;

hash1 = 14; hash2 = 23; hash3 = 256;
(* hash function used for instruction name table is:
hashvalue := abs( name(1,2,3) div hash1 + name(4,5,6) div hash2) mod hash3;
note:  hash3 <= max_code_number  !! *)

max_intervals = 90; (* intervals for ais parameters *)


bytes_pr_word  = 2;  (* number of bytes packed into one word on the code file *)

max_no_of_trailers = 3;
 

max_jump_ix  = 300;  (* maximum number of short jumps pr segment *)

max_cur_labels = 10;  (* maximum  number of labels associated to one instruction *)

descr1_size   =  75;   (* maximum length of descriptor part 1 *)

elems_per_line = 16; (* number of code words per line (option print.yes) *)


type

string        = packed array [ 1 .. 26 ] of char;
namestring    = packed array [ 1 .. namelength ] of char;
name_ix       = nill .. maxnameix;
unsatref_ix   = nill .. maxunsatrefs;
interval_index =    0 .. max_intervals;
code_ix       =    0 .. codebuffersize;
chbuf_ix      =    0 .. chbufmax;

symbol_kinds  = (label_def, constant_def, undefined);

namenodes     = packed record
namepart    : namestring;
def_segment : integer;
def_offset  : integer;
next_name   : name_ix;
use_chain   : unsatref_ix;
kind        : symbol_kinds;
end;

unsatrefnode  = packed record
next_ref    : unsatref_ix;
ic_relative : boolean;  (* tells if the opcode uses ic-relative addressing *)
reloc       : 0..8;     (* number of bytes between the opcode and the operand *)
use_segment : integer;
use_offset  : integer;
size        : integer;
end;

prog_kinds    = (closed_routine, open_routine );

tokens        = ( blockbegin, blockend, constbegin, endprogram, labeldef, startdescr,
constdef, comment, symbol, option, source_line_number, line_table, other );

coderange     = 0 .. max_code_number;
 
opcode_kinds  = (jump_long, jump_short, special,
first_of_pair, second_of_pair,  ic_rel, addr_neutral );


opcode_node   = record
namepart     : namestring;
opcodeval    : integer;
(* number of bytes for the operands *)
trailers     : array [ 1 .. max_no_of_trailers ] of integer;
total_length : integer; (* total number of bytes to reserve for this code *)
opcode_kind  : opcode_kinds;
exc_time,              (* execution time in 0.1 micro secs *)
use_count    : integer;
end;

(* types used in connection with statistical version *)

interval_descriptor = record
next_descriptor : ^ interval_descriptor;
upper_limit,
interval_count : integer;
end;

interval_head = record
number_of_intervals : integer;
first_descriptor : ^ interval_descriptor ;
end;

stat_opcode_node = record
trail_head : array [ 1.. 2 ] of interval_head;
end;

stat_code_table = array [ coderange ] of stat_opcode_node;

stat_unsatref_node = ^ interval_descriptor;

stat_unsat_table = array [ unsatref_ix ] of stat_unsatref_node;

(* end of types for statistical use  *)


line_ix       = 0 .. maxlinelength;

byte          = 0 .. 255;
jump_information = record
jump_from   : code_ix;
destination : name_ix;
end;

jump_table_ix = 0 .. max_jump_ix;


dep_chain_ix   = dep_chain_start .. max_dependence_ix;

dep_chain_element = record
next_dep  : dep_chain_ix;
dependent,
dependence: name_ix;
end;



var
length_of_current_code,      (* used in printline to adjust current offset *)
revision_number,             (*  default is 3 *)

linenumber,                  (* assembler list line number *)
current_source_line,         (* pascal80 line number *)
segment_start_line,          (* source line at segment entry *)
line_add,                    (* number of source lines met since last line table record *)
coded_time,                   (* compiler version * 64 * 32 + hour*64 + minute *)
coded_date,                  (* (year - 1980) * (16 * 32) + month * 32 + day *)
errorcount      : integer;
cur_date, cur_time : alfa;


code,                                 (* file for the resulting code *)
codefile        : file of integer;    (* file for temporary code *)
program_kind   : prog_kinds;


token           : tokens;

current_jump_ptr : jump_table_ix;
current_labels  : array [ 1 .. max_cur_labels ] of name_ix;
cur_lab_ptr     : integer;

current_segment : integer;
current_offset  : code_ix;   (* first free byte in the code buffer, i.e. the
address to associate with a label when the label is defined 
(unless a segment shift is needed) *)
current_level   : -1 .. maxlevel;
current_name    : namestring;

chbuf           : array [ chbuf_ix ] of char; (* current word to be handled *)
lastchar        : chbuf_ix;                   (* length of current word *)

help,
step            : integer; (* help variable, used in for-statements *)

names           : array [ name_ix ] of namenodes;


line_table_descriptor,
current_line_record,
last_line_number,
length_of_last_segment,


internal_link_list,
namefreelist   : name_ix;

unsatisfied_refs : array [ unsatref_ix ] of unsatrefnode;
unsatref_freelist : unsatref_ix;

errorindex, 
lineindex,
linelength      : line_ix;
line            : array [ line_ix ] of char;   (* line(0) = sp !!! *)
errormarks      : packed array [ 0 .. higherror ] of boolean;
object_code_file_opened,
last_page,
codesize_met,                (* option code size met, only the first is significant *)
spacing_met,                 (* option spacing met,  -   - -   -      *)
lineinfo_met,
generate_line_info,(* oprion lineinfo (10)   *)
dump_nametable,              (* option  nametable, default is nametable.no *)
print_code,                  (* option  print, default is print.no *)
errorreporting,              (* option  errormess, default is errormess.no *)
test,                        (* option  test, default is test.no *)
printed,
codelist        : boolean;     (* option  list, default is list.no *)

levelstack      : array [ 0 .. maxlevel ] of name_ix;

free_dep_list   : dep_chain_ix;
dependence_chain : array [ dep_chain_ix ] of dep_chain_element;

lastcode        : integer;      (* index of the last defined op-code *)
opcodes         : array [ coderange ] of opcode_node;
check_open_code,

longjump,
no_op_ix        : coderange;

ais_codes : packed array [ coderange ] of interval_index;

intervals : array [ interval_index ] of packed record
ais_code_val : coderange;
trailer_nr : 1 .. 3;
trailer_size : 0 .. 2; (* number of bytes *)
next_interval : interval_index;
interval_low, interval_high : integer;
end;


jump_table      : array [ jump_table_ix ] of jump_information;
reserve_max     : integer; (* max used code buffer greater than segment_size *)

rem_buffer_size,             (* remaining code buffer size *)
head_of_lines,               (* start offfset of line information chain record *)
start_of_line_table,
next_line_table_entry,
line_table_size,             (* room reserved for the line information *)
line_spacing,                (* distance in bytes between dump of line information *)
segment_size    : code_ix;  (* number of the last byte in a segment,
note: (segment_size + 1) mod bytes_pr_word  must be  0  *)
 
code_buffer     : packed array [ code_ix ] of byte;


descr1          : array [ 0 .. descr1_size ] of integer; 
(* used for part 1 of the descriptor block *)

systemparamno : integer;  (* current  fp-parameter *)
codefilename,            (* external name of the resulting code file *)
procname        : alfa;  (* name of the process *)

hexnumber       : array [ 0 .. 15 ] of char;

(* variables for statistical use *)

stat_opcodes : ^ stat_code_table;

stat_unsat_refs : ^ stat_unsat_table;

current_interval : ^ interval_descriptor;
current_time,  (* execution time for current code, -1 if not code line *)
total_time,   (* execution time accumulator *)

barrier, survey_option_number  : integer;

generate_statistics : boolean;  (* option (10) statistics *)

(* end of variables for statistical use *)


no_of_elems_in_line : integer; (* current number of emited code words in this line *)






procedure write_hex(dec_number, positions : integer);
begin
if positions = 4 then
write(hexnumber [ dec_number div (256*16) ]);
if positions >= 3 then
write(hexnumber [ dec_number div 256 mod 16 ]);
write(hexnumber [ dec_number mod 256 div 16 ],
hexnumber [ dec_number mod 16 ] );
end;

procedure write_hex_addr( address : code_ix);
begin
if no_of_elems_in_line = elems_per_line then
begin
writeln(output);
no_of_elems_in_line := 0;
write_hex( current_segment , 4); write('.');
write_hex( address         , 4); write(':  ');
end
else
write(' ' : 2);
no_of_elems_in_line := no_of_elems_in_line + 1;
end; (* write hex address *)

procedure write_hex_descr( word : integer );
begin
if no_of_elems_in_line = elems_per_line then
begin
writeln(output);
no_of_elems_in_line := 0;
write(' ':12);
end
else
write(' ' : 2);

no_of_elems_in_line := no_of_elems_in_line + 1;
write_hex( word , 4 );
end;





procedure outtest( textstring : string );
begin
writeln(output, 'outtest called from ', textstring);
end;

procedure output_names;
(* dump the nametable, option nametable.yes *)

var
level_count : integer;
local_name : name_ix;

begin
(* output all the names declared until now *)
writeln( nl, ' name table dump ',  nl);
for level_count := 0 to current_level + 1 do
begin
if level_count <= current_level then
begin
writeln( nl, 'level = ', level_count : 1 , nl);
local_name := levelstack [ level_count ] ;
end
else
begin
writeln(nl, 'internal links', nl);
local_name := internal_link_list;
end;

while local_name <> nill do
with names [ local_name ] do
begin
write(namepart);
if kind = label_def then
begin
write(': ', def_segment, '  ');
write_hex(def_offset, 4);
end
else
if kind = constant_def then
begin
write('=', ' ' : 8);
if def_offset >= 0 then
begin
write_hex(def_offset div 256, 2);
write_hex(def_offset mod 256, 2);
end
else
begin
write_hex((def_offset + word_max + 1) div 256, 2);
write_hex((def_offset + word_max + 1) mod 256, 2);
end;
end
else
write('      undefined');
if test then 
write('next:', next_name, ' use:', use_chain);
writeln(output);
local_name := next_name;
end; (* while .. with *)

end;  (* for .... *)

end; (* output name *)




procedure prepare_linetable;

var
step : integer;

begin
for step := 0 to addrsize - 1 do
(* reserve room for an address *)
code_buffer [ start_of_line_table + step ] := 0;

code_buffer [ start_of_line_table + addrsize ] := current_source_line div maxbyte;
code_buffer [ start_of_line_table + addrsize + 1 ] := current_source_line mod maxbyte;

next_line_table_entry := start_of_line_table + fix_line_table_part - 2;

rem_buffer_size := rem_buffer_size - line_table_size;

end; (* prepare line table *)



procedure readcall;
(* read the call of pass6 from current input *)
const
power12=4096;
equality=6;
point=8;
list  = 'list        ';
yes   = 'yes         ';
no    = 'no          ';
testout   = 'test';
codesize  = 'codesize';
errormess = 'errormess';
nametable = 'nametable';
lineinfo = 'lineinfo';
spacing   = 'spacing';
print     = 'print';



var
i,j, int, separator, length : integer;
a,  sourcefilename : alfa;
first : boolean;
param : (list_program, filename, code_size, line_info_param, spacing_param, test_gen,
error_mess, nametab_param, print_param );


procedure checkleftside;
begin
systemparamno := 1;
if system(systemparamno, int, a) div power12 = equality then
begin
(* left hand side present *)

i := system(0, int, codefilename);

systemparamno := systemparamno + 1; (* skip name platonpass6 *)
end;


end; (* checkcall *)



procedure error;
begin
writeln(' ??? error in call of platonpass6 ');
goto 9999;
end;

begin
sourcefilename := 'pass5code'; (* default name *)
checkleftside;



j:=system(systemparamno,int,a);
first:=true;
param := pred(filename); (* param <> filename *)

while ((j mod power12) <> 0) and ((j div power12) <> 2) 
and (param <> filename) do
begin
separator:=j div power12;
length:=j mod power12;

if first then
begin
first:=false;
if separator = point then error
else
if a = list then param:=list_program
else if a = testout then param := test_gen
else if a = codesize then param := code_size
else if a = spacing then param := spacing_param
else if a = lineinfo then param := line_info_param
else if a = print then param := print_param
else if a = errormess then param := error_mess
else if a = nametable then param := nametab_param
else
begin
param := filename;
sourcefilename := a;
end;
end
else
begin
first:=true;
if (separator <> point) and (param <> filename) then error
else
case param of
list_program:if length <> 10 then error
else
if (a = yes) or (a = no) then
begin
codelist :=  a=yes;
errorreporting := errorreporting or (a=yes);
end
else error;

filename: systemparamno := systemparamno - 1; (* make the next increment dummy *)

test_gen: if length <> 10 then error
else
if (a = yes) or (a = no) then test := a = yes
else error;

code_size: if length <> 4 then error
else
if not codesize_met then
begin
codesize_met := true;
if int > codebuffersize then int := codebuffersize;
segment_size := int div 2 * 2 - 1;
end;

error_mess: if length <> 10 then error
else
if (a=yes) or (a = no) then
errorreporting := errorreporting or (a = yes)
else error;

nametab_param : if length <> 10 then error
else
if (a = yes) or (a = no) then dump_nametable := a = yes
else error;

print_param: if length <> 10 then error
else
if (a = yes) or ( a = no ) then print_code := a = yes
else error;
line_info_param: if length <> 10 then error
else
if (a=yes) or (a = no) then
begin
if not lineinfo_met then
begin
lineinfo_met := true;
generate_line_info := a = yes;
if a <> yes then
begin
start_of_line_table := 0;
rem_buffer_size := segment_size + 1 - longjump_size;
end;
end;
end
else error;

spacing_param : if length <> 4 then error
else
if not spacing_met then
begin
spacing_met := true;
line_spacing := int;
(* no check for reasonable result !!!!!!! *)
end;


end; (* case *)
if (param = code_size) or (param = spacing_param) then
begin
(* adjust the mutual dependent variables *)
line_table_size := (segment_size + 1 - fix_line_table_part) div (line_spacing + 1) + fix_line_table_part;
line_table_size := (line_table_size + 1) div 2 * 2; (* integral number of words *)
rem_buffer_size := segment_size + 1 - longjump_size;
if rem_buffer_size < min_buffer_size then error;
if generate_line_info then
begin
start_of_line_table := segment_size + 1 - line_table_size; 
prepare_linetable;
end; (* line table set-up *)
end; (* code size or spacing *)
end; (* second *)
systemparamno := systemparamno + 1;
j:=system(systemparamno,int,a);
end;

open(input, sourcefilename);
reset(input);

end; (* read call *)



procedure printerrors;
var
i, current_text_no : integer;
ch : char;

begin
page(output);
if errorreporting then
begin
writeln(output, ' number of errors : ', errorcount : 4);
writeln(output, nl, nl, 'error description');
open ( input, 'platonerror' ); reset( input );
repeat
readln(input, i);
until i = 6666;
current_text_no := -1;

for i := 1 to higherror do
if errormarks [ i ] then 
begin

(* find the text *)
while i > current_text_no do
begin
if not eof(input) then readln(input);
if not eof(input) then read(current_text_no)
else current_text_no := higherror + 1;
end;

write(output, i : 4, ': ');
if i <> current_text_no then
write(output, ' ( no text ) ' )
else
while not eoln(input) do
begin
read(ch); write(output, ch);
end;
writeln(output);
end; (* for i ... *)
close(input);

end
else
if (reserve_max = 0) or (reserve_max > codebuffersize) then
begin
writeln(output,' Compiler error detected ');
writeln(output, ' please inform the compiler group' );
end;
if (reserve_max > 0) and (reserve_max <= codebuffersize) then
begin
i := reserve_max + line_table_size + longjump_size;
i := i + ( i - segment_size + line_spacing ) div line_spacing;
writeln(output, 'Error in compilation', nl, 'use option codesize, with at least ',
i : 1, ' as page size');
end;



end;


procedure output_statistics;
var 
float_prc : real;
total_int_count, low, max_use, candidate, net_codesize,
total_usecount, percentage, step, step1, step2 : integer;

begin

page(output);
writeln( nl, 'Statistics from pass6 for ', procname, ' ( ', current_source_line : 1,
' lines )', nl);
net_codesize := 0;

total_usecount := 0;
for step := 0 to max_code_number do
if opcodes [ step ] . namepart <> blank then
with opcodes [ step ] do
begin
net_codesize := net_codesize + use_count * total_length;
total_usecount := total_usecount +  use_count;
end;

if survey_option_number <> 9 then
begin
if barrier >= 0 then
writeln('barrier = ', barrier : 1, '%');

write( nl, 'opcode        use count,  percentage' , nl, 
'1' : 31 + 5 * 11, nl, ' ' : 31);
for step := 0 to 10 do write( step mod 10 : 5 );
write(nl, ' ' : 31 );
for step := 0 to 10 do write( 0 : 5 );
writeln;
for step := 1 to 31 + 11 * 5 do write('-');
write( '> %' , nl, nl );
for step := 0 to max_code_number do
if opcodes [ step ] . namepart <> blank then
with opcodes [ step ] do
begin
float_prc := use_count * 100.0 / total_usecount;
if float_prc > barrier then
begin
write( namepart , ' ' : 7 );
write(use_count, ' <=>', float_prc : 7 : 2 , '% ' );
case survey_option_number of
1, 2, 5, 6: begin
percentage := round( float_prc );
write('!');
for step1 := 1 to percentage div 2 do write('-');
if odd( percentage ) then write('.') ;
end; (* case 1, 2, 5, 6 *)
end
otherwise ;
writeln;
end;

end;

writeln(nl, '-----------------------' , nl,
   'total = ' , total_usecount  : 13, ' , net code size = ', net_codesize : 1, ' bytes' );


case survey_option_number of
5, 6, 7, 8 : begin
writeln( nl, nl, nl);
for step := 0 to max_code_number do
if opcodes [ step ] . namepart <> blank then
for step1 := 1 to 2 do
with stat_opcodes^ [ step ] . trail_head [ step1 ] do
if first_descriptor <> nil then
with opcodes [ step ] do
begin
writeln('opcode = ', namepart, '  parameter number =', step1 :1,
 ' use count = ', use_count : 1, ' <=>', use_count * 100.0 / total_usecount 
: 7 : 2, '%' );
total_int_count := use_count;
low := word_min;
current_interval := first_descriptor;

repeat
with current_interval ^ do
begin
write( '(', low : 6, '..', upper_limit : 6, ']', interval_count : 5,
' <=>',
interval_count * 100.0 / use_count : 7 : 2, '% ' );
percentage := round( interval_count * 100.0 / use_count);
write('!');
for step2 := 1 to percentage div 2 do
write('-');
if odd( percentage ) then write('.');
writeln;
low := upper_limit;
current_interval := next_descriptor;
end; (* with current *)
until current_interval = nil;
write(nl, nl);
end;
end; (* case 5, 6, 7, 8 *)
end
otherwise ;

end (* if  <> 9 ... *)

else 
begin (* survey option number = 9 *)
(* output 'barrier' most used codes *)

writeln(barrier, ' most used codes are', nl );

for step := 1 to barrier do
begin
max_use := 0;
candidate := -1;
for step1 := 0 to max_code_number do
with opcodes [ step1 ] do
if namepart <> blank then
if use_count > max_use then
begin
max_use := use_count;
candidate := step1;
end;

if candidate <> -1 then
with opcodes [ candidate ] do
begin
writeln( namepart, ' '  , use_count, ' <=>',
use_count * 100.0 / total_usecount : 6 : 2 , '%' );
use_count := - use_count;
end;

end; (* for step .... *)

end; (* survey_option_number = 9  *)


end; (* output statistics *)
  


procedure printline;
var step : integer;

begin
write(output, linenumber : 5, '  ');
if current_time <> -1 then
begin
write(output, current_time div 10 : 3, '.',
current_time mod 10 : 1, total_time div 10, ' ' : 3);
current_time := -1;
end
else (* not code line *)
write(output, ' ' : 3 + 1 + 1 + 8 + 3 );

write_hex( current_segment, 2); write(output,' ');
write_hex( current_offset - length_of_current_code, 4);
length_of_current_code := 0; (* do not adjust non-code lines *) 
write(':  ');
for step := 1 to linelength do
write(output, line [ step ] );
writeln(output);
printed := true;
end; (* print line *)



procedure markerror ( no : integer );

(* print current line and mark the erroneous token *)
var
i : integer;

begin
errorcount := errorcount + 1;
errormarks [ no ] := true;
if errorreporting then
begin
if not printed or (program_kind = open_routine) then
printline;
if errorindex = 0 then
write(output, '*******************************');
for i := errorindex to lineindex do write(output,' ');
write(output,'^', no:1);
errorindex := lineindex + 2;
end; (* error report *)
end; (* mark error *)



procedure markerror1 ( no : integer; errortext : namestring );

begin
markerror ( no );
if test then
begin
errorindex := 0;
writeln(output, nl, 'name is: ', errortext  );
end;
end; (* markerror1 *)





procedure stop( constname, calledfrom : alfa );

(* fatal error in connection with 'constnam', detected in
procedure 'calledfrom', stop the program *)

begin
markerror(0); (* fatal error *)
writeln(output, nl, nl, 'constant ', constname, ' too small');
if test then
write(output, ' detected in procedure ', calledfrom);

writeln(output);
goto 9999; (* exit *)

end; (* stop *)


procedure readline;
 
(* at exit lineindex will denote the last leading space of the line 
and linelength denotes the last character of the line *)

var
lgt : integer; (* local linelength *)
leading_spaces : boolean;

begin
lineindex := 0;
lgt := 1; 
printed := false;
errorindex := 0;
leading_spaces := true;
linenumber := linenumber + 1;

while not eoln(input) and (lgt < maxlinelength) do
begin
if (input^= ' ') and leading_spaces then
lineindex := lineindex + 1
else
leading_spaces := false;
read(input, line [ lgt ] );
lgt := lgt + 1;
end;
if eof(input) then line [ lgt ] := '.'
else 
begin
readln(input); (* skip if more than maxlinelength characters *)
line [ lgt ] := ' ';
end;

linelength := lgt;

end; (* read line *)



function get_next_token  :  tokens;

(* move (less than chbufmax) characters from 'line'
to 'chbuf', let lastchar denote the length of the word, the
funciton result is set according to the delimiter following the
word, i.e. 'line [ lineindex ] ' *)

label
1; (* used for skip of leading spaces *)


var
localtoken : tokens;
insert, finished : boolean;

begin
lastchar := 0;
finished := false;
insert := true;

while not finished do
begin
1:
if lineindex >= linelength then
begin
if errorindex > 0 then writeln(output);
if codelist  and not printed then printline;
readline;
end;

lineindex := lineindex + 1;
case line [ lineindex ] of
'#' : 
begin
if lastchar <> 1 then
begin (* # is a delimiter, i.e. stop reading *)
finished := true;
insert := false;
localtoken := symbol;
end;
(* else insert = true ,  ok *)
end; (* '#' *)

'.' :
begin
insert := false;
finished := true;
if lastchar <> 0 then
localtoken := symbol
else
localtoken := other;
if lastchar = 1 then
begin
if chbuf [ 1 ] = 'l' then
localtoken := source_line_number
else
if chbuf [ 1 ] = 'b' then
localtoken := blockbegin
else
if chbuf [ 1 ] = 'e' then
begin
if current_level = 0 then
localtoken := endprogram
else
localtoken := blockend
end
else
if chbuf [ 1 ] = 'c' then
localtoken := constbegin
else
if chbuf [ 1 ] = 'z' then
localtoken := line_table
else
if chbuf [ 1 ] = 'o' then
localtoken := option
else
if chbuf [ 1 ] = 'd' then
localtoken := startdescr (* start of descriptor segment *)

end;
end;  (* '.' *)

' ' :
begin
if lastchar = 0 then
goto 1  (* skip leading spaces *)
else
begin
finished := lineindex = linelength; (* nl is a delimiter *)
insert := false; (* skip trailing spaces *)
localtoken := symbol;
end;
end; (* space *)

'+', '-', ',' , '/' :
begin
finished := true;
insert := false;
localtoken := symbol;
end; (* ',' '-' '+' *)

';' :
begin
insert := false;
finished := true;
if lastchar > 0 then
localtoken := symbol
else
localtoken := comment;
lineindex := linelength; (* force new line, delim = ' ' *)
end; (* ';' *)

':' :
begin
insert := false;
finished := true;
localtoken := labeldef;
end;

'=' :
begin
insert := false;
finished := true;
localtoken := constdef;
end;


end

otherwise
begin
if not insert then (* after skip spaces *)
begin
finished := true;
lineindex := lineindex - 1;
end;
end;
if not ((line [ lineindex ] = '0') and (chbuf [ lastchar ] = '#')) then
(* not leading '0' of a seq-name *)


if insert and (lastchar < chbufmax) then
begin
lastchar := lastchar + 1;
chbuf [ lastchar ] := line [ lineindex ] ;
end;


end; (* while *)

get_next_token := localtoken;

if test then writeln(output,'get next token, token = ', ord(localtoken) );

end; (* get next token *)


\f


function get_constant_value : integer;

(* read an 16 bit unsigned integer from chbuf, i.e. convert text to internal
representation; if chbuf <> integer then the function result becomes 0 *)

label 9998; (* exit label used in case of error (overflow) *)

const
limit = 6553; (* max unsigned integer (2**16 - 1) div 10 *)
last_of_limit = '5' ; (* the last character of max unsigned integer *)
base = 10;

var
localresult : integer;
chbufptr : chbuf_ix;
currentch : char; (* holds the character from chbuf [ chbufptr ] *)

begin
localresult := 0;
chbufptr := 1;
currentch := chbuf [ chbufptr ] ;

while (currentch >= '0') and (currentch <= '9') and (chbufptr <= lastchar) do
begin
if (localresult < limit) or
((localresult = limit) and (currentch <= last_of_limit)) then
localresult := localresult * base + (ord(currentch) - ord('0'))
else
begin
markerror( 2 ); (* illegal constant ( > 2**16 - 1 ) *)
goto 9998;
end;
chbufptr := chbufptr + 1;
currentch := chbuf [ chbufptr ] ;
end; (* while *)

9998:
get_constant_value := localresult;

end; (* get constant value *)

\f


function getnamenode : name_ix;

(* get a free name node *)
var
localnode : name_ix;

begin
if namefreelist <> nill then
localnode := namefreelist
else
stop('maxname_ix', 'getnamenode');

with names [ localnode ] do
begin
namefreelist := next_name;
next_name := nill;
namepart := blank;
def_segment := nill;  (* i.e. undefined *)
def_offset := 0;
use_chain := nill;
kind := undefined;
end; (* with *)

if test then writeln('get name : ', localnode );


getnamenode := localnode;

end ; (* get name node *)


procedure returnname(name : name_ix);
(* insert the name into the name free list *)

begin
if test then writeln('return ', name, '=', names [ name ] . namepart);
names [ name ] . next_name := namefreelist;
namefreelist := name;
end; (* return name *)

\f


function get_dep_chain_node  :  dep_chain_ix;

(* get a free node to describe the interdependence
between two constants, e.g.  a = b + 7 *)

var 
localnode : dep_chain_ix;

begin
if free_dep_list = nill then

stop('max_dependence_ix', 'get_dep_chain_node')
else
begin
localnode := free_dep_list;
free_dep_list := dependence_chain [ localnode ] . next_dep;
get_dep_chain_node := localnode;
end;

end; (* get dep chain node *)


procedure return_dependence_node( former, actual : dep_chain_ix);

(* let former.next := actual.next and insert actual into the free list *)

begin
with dependence_chain [ actual ] do
begin
dependence_chain [ former ] . next_dep := next_dep;
next_dep := free_dep_list;
end;
free_dep_list := actual;

end; (* return dependence node *)
\f


procedure initcodes(codename : namestring; codevalue : coderange;
trailerbyte1, trailerbyte2, trailerbyte3 : integer; addr_kind : opcode_kinds;
execution_time : integer );

(* initialize the op_code structure according to the parameters
of the call  *)
(* nb: lastcode will contain the table index used *)

var
hash_name : packed record
case boolean of
true: ( name : namestring; );
false:( int1, int2 : integer; )
end;

begin
with hash_name do
begin
name := codename;
(* the hash function must be the same as in 'function find_code' *)
lastcode := abs ( int1 div hash1 + int2 div hash2 ) mod hash3;
end; (* with *)

while opcodes [ lastcode ] . namepart <> blank do
begin
if hash_function_test then
writeln( codename, ' ', lastcode, ' ', opcodes [ lastcode ].namepart);
lastcode := (lastcode + 1) mod hash3;
end;


with opcodes [ lastcode ] do
begin
namepart  := codename;
opcodeval := codevalue;
trailers [ 1 ] := trailerbyte1;
trailers [ 2 ] := trailerbyte2;
trailers [ 3 ] := trailerbyte3;
total_length :=  1 (* opcode_length *) + trailerbyte1 + trailerbyte2 + trailerbyte3;
opcode_kind := addr_kind;
exc_time := execution_time;
use_count := 0;

end;  (* with *)

end; (* init codes *)



procedure initialization;
var
int : integer;
prog_name : alfa;
ch : char;
current_interval : integer;

procedure init_interval( trailer, low, high : integer; last_of_chain : boolean );

begin
with intervals [ current_interval ] do
begin
ais_code_val := lastcode; (* this procedure must be called just after
insertion of the ais_code *)
interval_low := low;
interval_high := high;
trailer_nr := trailer;
if last_of_chain then
next_interval := 0
else
next_interval := current_interval + 1;
end; (* with .. *)
current_interval := current_interval + 1;

end; (* init interval *)


begin
date(cur_date);
time(cur_time);
coded_date := (( ord( cur_date [ 1 ] ) - ord ( '0' ) ) * 10 
+                ord( cur_date [ 2 ] ) - ord ( '0' ) - 80) * 16 * 32
+             (( ord( cur_date [ 4 ] ) - ord ( '0' ) ) * 10
+                ord( cur_date [ 5 ] ) - ord ( '0' )     ) * 32
+              ( ord( cur_date [ 7 ] ) - ord ( '0' ) ) * 10
+                ord( cur_date [ 8 ] ) - ord ( '0' );

coded_time := pass6_version div 100 * 64 * 32 
+             (( ord( cur_time [ 1 ] ) - ord( '0' ) ) * 10
+                ord( cur_time [ 2 ] ) - ord( '0' ) ) * 64
+              ( ord( cur_time [ 4 ] ) - ord( '0' ) ) * 10
+                ord( cur_time [ 5 ] ) - ord( '0' );



(* decide revision 3 or 5 , program name dependent *)
if system(1, int, prog_name) = 6 * 4096 + 10 then
(* left hand side present and prog is the program name *)
else
if system( 0, int, prog_name) mod 4096 <> 10 then readln(output); (* force exit *)
revision_number := 3 + 2 * ord( prog_name <> 'platonpass6' );

length_of_current_code := 0;




(* insert all the names into the name free list *)
(* names [ nill ] is dummy (stop mark *)
with names [ nill ] do
begin
namepart := blank;
def_segment := nill; (* i.e. undefined *)
def_offset := 0;
next_name := nill; (* itself *)
use_chain := nill;
kind       := undefined;
end;

(* let the last element be predecessor of names [ nill ]  *)

names [ maxnameix ] := names [ nill ] ;

for step := nill + 1 to maxnameix - 1 do
with names [ step ] do
next_name := step + 1;
namefreelist := nill + 1;


(* insert all the dependence elements into  free_dep_list *)

(* dependence_chain [ dep_chain_start ] is dummy (stop mark)  *)
with dependence_chain [ dep_chain_start ] do
begin
next_dep := dep_chain_start;
dependent := nill;
dependence := nill;
end;

(* let next_dep of the last element be dep_chain_start *)
dependence_chain [ max_dependence_ix ] := dependence_chain [ dep_chain_start ] ;

for step := dep_chain_start + 1 to max_dependence_ix - 1 do
dependence_chain [ step ] . next_dep := step + 1;

free_dep_list := dep_chain_start + 1;


(* insert all the unsatisfied nodes into unsatref_freelist *)

(* let unsatisfied_refs [ nill ] be dummy  *)
with unsatisfied_refs [ nill ] do
begin
next_ref := nill;
use_segment := nill;
use_offset := 0;
size := 0;
end;

(* let next_ref of the last element be nill *)
unsatisfied_refs [ maxunsatrefs ] . next_ref := nill;

for step := nill + 1 to maxunsatrefs - 1 do
unsatisfied_refs [ step ] . next_ref := step + 1;

unsatref_freelist := nill + 1;
levelstack [ 0 ] := nill;
levelstack [ 1 ] := nill;

current_level := -1;

current_name := blank;

lastchar := 0;

errorcount := 0;

linenumber := 0;

errorindex := 0;

lineindex := 0;

linelength := 0;

line [ 0 ] := ' ';

for step := 0 to higherror do
errormarks [ step ] := false;

printed := true;

object_code_file_opened := false;

systemparamno := 0;

errorreporting := false;

test := false;

dump_nametable := false;

print_code := false;


codelist := test;

current_time := -1; (* not code line *)


codefilename := 'pass6code'; (* default name *)
for ch := '0' to '9' do
hexnumber [ ord(ch) - ord ('0') ] := ch;
for ch := 'a' to 'f' do
hexnumber [ ord(ch) - ord('a') + 10 ] := ch;

no_of_elems_in_line := elems_per_line; (* force newline at start *)


(* opcodes ........ *)

for lastcode := 0 to max_code_number do
begin
opcodes [ lastcode ] . namepart := blank; (* unused *)
ais_codes [ lastcode ] := 0; (* not used *)
end;

current_interval := 1;


generate_statistics := false;



initcodes( 'jmphc', #h001, 4, 0, 0, jump_long, 68);
longjump := lastcode; (* remember the index of longjump *)
initcodes( 'jmppd', #h003, 0, 0, 0, addr_neutral, 58);
initcodes( 'jmprw', #h004, 2, 0, 0, jump_short, 42);
initcodes( 'jmcht', #h005, 4, 0, 0, addr_neutral, 163);
initcodes( 'jmzeq', #h006, 2, 0, 0, jump_short, 62);
initcodes( 'jmzne', #h007, 2, 0, 0, jump_short, 62);
initcodes( 'jmzlt', #h008, 2, 0, 0, jump_short, 62);
initcodes( 'jmzgt', #h009, 2, 0, 0, jump_short, 62);
initcodes( 'jmzle', #h00a, 2, 0, 0, jump_short, 62);
initcodes( 'jmzge', #h00b, 2, 0, 0, jump_short, 62);

initcodes( 'csign', #h010, 0, 0, 0, addr_neutral, 583);
initcodes( 'cwait', #h011, 0, 0, 0, first_of_pair, 547);
initcodes( 'csens', #h012, 0, 0, 0, addr_neutral, 302);
initcodes( 'csell', #h013, 0, 0, 0, addr_neutral, 756);
initcodes( 'cstdr', #h014, 0, 0, 0, addr_neutral, 258);
initcodes( 'cstop', #h015, 0, 0, 0, addr_neutral, 570);
initcodes( 'cllst', #h016, 0, 0, 0, addr_neutral, 282);
if revision_number = 3 then
initcodes( 'cufst', #h017, 0, 0, 0, addr_neutral, 263);
initcodes( 'sched', #h018, 0, 0, 0, addr_neutral, 177);
initcodes( 'crget', #h019, 0, 0, 0, addr_neutral, 55);
initcodes( 'crput', #h01a, 0, 0, 0, addr_neutral, 73);
initcodes( 'cskip', #h01b, 0, 0, 0, addr_neutral, 140);
initcodes( 'crram', #h01e, 0, 0, 0, addr_neutral, 79);
initcodes( 'cwram', #h01f, 0, 0, 0, addr_neutral, 86);
initcodes( 'crele', #h020, 1, 0, 0, addr_neutral, 611);
initcodes( 'cwtac', #h021, 0, 0, 0, second_of_pair, 118);
initcodes( 'cgreg', #h024, 0, 0, 0, addr_neutral, 40);
initcodes( 'cslev', #h025, 0, 0, 0, addr_neutral, 120);
initcodes( 'cexch', #h026, 0, 0, 0, addr_neutral, 206);
if revision_number = 5 then
begin
initcodes( 'readw', #h027, 2, 0, 0, addr_neutral, 110 );
initcodes( 'readb', #h028, 2, 0, 0, addr_neutral, 110 );
end
else
begin
(* pseudo instructions for revsw and revsb !! *)
initcodes( 'readw', #h0a3, 2, 0, 0, addr_neutral, 110 );
initcodes( 'readb', #h0a2, 2, 0, 0, addr_neutral, 110 );
end;

initcodes( 'iowc', #h030, 0, 0, 0, addr_neutral, 63);
initcodes( 'iogo', #h031, 0, 0, 0, addr_neutral, 87);
initcodes( 'iors', #h032, 0, 0, 0, addr_neutral, 127);
initcodes( 'iorw', #h033, 0, 0, 0, addr_neutral, 120);
initcodes( 'ioww', #h034, 0, 0, 0, addr_neutral, 74);
initcodes( 'iogi', #h035, 0, 0, 0, addr_neutral, 150);
initcodes( 'iorbb', #h036, 0, 0, 0, addr_neutral, 252);
initcodes( 'iorbw', #h037, 0, 0, 0, addr_neutral, 250);
initcodes( 'iowbb', #h038, 0, 0, 0, addr_neutral, 206);
initcodes( 'iowbw', #h039, 0, 0, 0, addr_neutral, 209);
initcodes( 'iocci', #h03b, 0, 0, 0, addr_neutral, 77);
initcodes( 'iocda', #h03c, 0, 0, 0, addr_neutral, 111);
initcodes( 'ioibx', #h03e, 0, 0, 0, addr_neutral, 255);
initcodes( 'ionci', #h03f, 0, 0, 0, first_of_pair, 42);
initcodes( 'uadd', #h048, 0, 0, 0, addr_neutral, 73);
initcodes( 'usub', #h049, 0, 0, 0, addr_neutral, 73);
initcodes( 'umul', #h04a, 0, 0, 0, addr_neutral, 205);
initcodes( 'udiv', #h04b, 0, 0, 0, addr_neutral, 327);
initcodes( 'umod', #h04c, 0, 0, 0, addr_neutral, 329);
initcodes( 'teqad', #h04d, 0, 0, 0, addr_neutral, 88);
initcodes( 'swap',  #h04e, 0, 0, 0, addr_neutral, 59);
initcodes( 'xor',   #h04f, 0, 0, 0, addr_neutral, 71);

initcodes( 'neg', #h050, 0, 0, 0, addr_neutral, 59);
initcodes( 'not', #h051, 0, 0, 0, addr_neutral, 61);
initcodes( 'tnill', #h052, 0, 0, 0, addr_neutral, 101);
initcodes( 'abs', #h053, 0, 0, 0, addr_neutral, 63);
initcodes( 'compl', #h054, 0, 0, 0, addr_neutral, 49);
initcodes( 'add', #h055, 0, 0, 0, addr_neutral, 73);
initcodes( 'sub', #h056, 0, 0, 0, addr_neutral, 73);
initcodes( 'mul', #h057, 0, 0, 0, addr_neutral, 205);
initcodes( 'div', #h058, 0, 0, 0, addr_neutral, 327);
initcodes( 'mod', #h059, 0, 0, 0, addr_neutral, 329);
initcodes( 'sha', #h05a, 0, 0, 0, addr_neutral, 120);
initcodes( 'and', #h05b, 0, 0, 0, addr_neutral, 71);
initcodes( 'or', #h05c, 0, 0, 0, addr_neutral, 71);
initcodes( 'shc', #h05d, 0, 0, 0, addr_neutral, 120);
initcodes( 'ult', #h05e, 0, 0, 0, addr_neutral, 75);
initcodes( 'eq', #h05f, 0, 0, 0, addr_neutral, 75);
initcodes( 'ne', #h060, 0, 0, 0, addr_neutral, 75);
initcodes( 'lt', #h061, 0, 0, 0, addr_neutral, 77);
initcodes( 'gt', #h062, 0, 0, 0, addr_neutral, 77);
initcodes( 'le', #h063, 0, 0, 0, addr_neutral, 77);
initcodes( 'ge', #h064, 0, 0, 0, addr_neutral, 77);
initcodes( 'setcr', #h065, 0, 0, 0, addr_neutral, 450);
initcodes( 'setun', #h066, 0, 0, 0, addr_neutral, 263);
initcodes( 'setin', #h067, 0, 0, 0, addr_neutral, 263);
initcodes( 'setdi', #h068, 0, 0, 0, addr_neutral, 263);
initcodes( 'seteq', #h069, 0, 0, 0, addr_neutral, 278);
initcodes( 'setsb', #h06a, 0, 0, 0, addr_neutral, 278);
initcodes( 'setsp', #h06b, 0, 0, 0, addr_neutral, 278);
initcodes( 'settm', #h06c, 0, 0, 0, addr_neutral, 151);
initcodes( 'setad', #h06d, 0, 0, 0, addr_neutral, 240);
initcodes( 'tlock', #h06e, 0, 0, 0, addr_neutral, 103);
initcodes( 'topen', #h06f, 0, 0, 0, addr_neutral, 105);

initcodes( 'intrs', #h070, 0, 0, 0, addr_neutral, 115);
initcodes( 'index', #h071, 0, 0, 0, addr_neutral, 210);
initcodes( 'inprs', #h072, 0, 0, 0, addr_neutral, 480);
initcodes( 'inpss', #h073, 0, 0, 0, addr_neutral, 600);

initcodes( 'renpb', #h080, 0, 0, 0, addr_neutral, 42);
initcodes( 'renhb', #h081, 2, 0, 0, addr_neutral, 49);
initcodes( 'rechw', #h082, 2, 0, 0, addr_neutral, 60);
ais_codes [ lastcode ] := current_interval;
initcodes( 'rec0', #h40, 2, 0, 0, addr_neutral, 60);
init_interval( 1, 0, 0, false );
initcodes( 'rec1', #h41, 2, 0, 0, addr_neutral, 60);
init_interval( 1, 1, 1, false );
initcodes( 'rec2', #h42, 2, 0, 0, addr_neutral, 60);
init_interval( 1, 2, 2, true );
initcodes( 'rechd', #h083, 2, 2, 0, addr_neutral, 99);
initcodes( 'reaxd', #h084, 0, 0, 0, addr_neutral, 60);
initcodes( 'reaad', #h083, 4, 0, 0, addr_neutral, 99);
initcodes( 'reard', #h086, 2, 0, 0, addr_neutral, 77);
initcodes( 'reald', #h087, 2, 0, 0, addr_neutral, 79);
initcodes( 'reagd', #h088, 2, 0, 0, addr_neutral, 79);
initcodes( 'reaid', #h089, 1, 2, 0, addr_neutral, 121);
initcodes( 'reasd', #h08a, 2, 0, 0, addr_neutral, 112);
initcodes( 'uadhw', #h08a, 2, 0, 0, addr_neutral, 112); (* !! pseudo instruction name for reasd !! *)


initcodes( 'revpw', #h090, 0, 0, 0, addr_neutral, 54);
initcodes( 'revpd', #h091, 0, 0, 0, addr_neutral, 85);
initcodes( 'revab', #h092, 4, 0, 0, addr_neutral, 97);
initcodes( 'revaw', #h093, 4, 0, 0, addr_neutral, 97);
initcodes( 'revad', #h094, 4, 0, 0, addr_neutral, 131);
initcodes( 'revaf', #h095, 4, 1, 0, addr_neutral, 186);
initcodes( 'revlb', #h096, 2, 0, 0, addr_neutral, 77);
initcodes( 'revlw', #h097, 2, 0, 0, addr_neutral, 77);
initcodes( 'revld', #h098, 2, 0, 0, addr_neutral, 112);
initcodes( 'revlf', #h099, 2, 1, 0, addr_neutral, 174);
initcodes( 'revgb', #h09a, 2, 0, 0, addr_neutral, 77);
initcodes( 'revgw', #h09b, 2, 0, 0, addr_neutral, 77);
initcodes( 'revgd', #h09c, 2, 0, 0, addr_neutral, 112);
initcodes( 'revgf', #h09d, 2, 1, 0, addr_neutral, 174);
initcodes( 'revib', #h09e, 1, 2, 0, addr_neutral, 112);
initcodes( 'reviw', #h09f, 1, 2, 0, addr_neutral, 112);
initcodes( 'revid', #h0a0, 1, 2, 0, addr_neutral, 147);
initcodes( 'revif', #h0a1, 1, 2, 1, addr_neutral, 210);
initcodes( 'revsb', #h0a2, 2, 0, 0, addr_neutral, 110);
initcodes( 'revsw', #h0a3, 2, 0, 0, addr_neutral, 110);
initcodes( 'revsd', #h0a4, 2, 0, 0, addr_neutral, 144);
initcodes( 'revsf', #h0a5, 2, 1, 0, addr_neutral, 207);
initcodes( 'revsm', #h0a7, 0, 0, 0, addr_neutral, 210);
initcodes( 'moveg', #h0a8, 0, 0, 0, addr_neutral, 170);
initcodes( 'moveb', #h0a9, 0, 0, 0, addr_neutral, 300);


initcodes( 'stnhb', #h0b0, 2, 0, 0, addr_neutral, 44);
initcodes( 'stvab', #h0b1, 4, 0, 0, addr_neutral, 95);
initcodes( 'stvaw', #h0b2, 4, 0, 0, addr_neutral, 95);
initcodes( 'stvad', #h0b3, 4, 0, 0, addr_neutral, 126);
initcodes( 'stvaf', #h0b4, 4, 1, 0, addr_neutral, 238);
initcodes( 'stvlb', #h0b5, 2, 0, 0, addr_neutral, 76);
initcodes( 'stvlw', #h0b6, 2, 0, 0, addr_neutral, 76);
initcodes( 'stvld', #h0b7, 2, 0, 0, addr_neutral, 106);
initcodes( 'stvlf', #h0b8, 2, 1, 0, addr_neutral, 218);
initcodes( 'stvgb', #h0b9, 2, 0, 0, addr_neutral, 76);
initcodes( 'stvgw', #h0ba, 2, 0, 0, addr_neutral, 76);
initcodes( 'stvgd', #h0bb, 2, 0, 0, addr_neutral, 106);
initcodes( 'stvgf', #h0bc, 2, 1, 0, addr_neutral, 218);
initcodes( 'stvib', #h0bd, 1, 2, 0, addr_neutral, 116);
initcodes( 'stviw', #h0be, 1, 2, 0, addr_neutral, 116);
initcodes( 'stvid', #h0bf, 1, 2, 0, addr_neutral, 146);
initcodes( 'stvif', #h0c0, 1, 2, 1, addr_neutral, 250);
initcodes( 'stvsb', #h0c1, 2, 0, 0, addr_neutral, 110);
initcodes( 'stvsw', #h0c2, 2, 0, 0, addr_neutral, 110);
initcodes( 'stvsd', #h0c3, 2, 0, 0, addr_neutral, 142);
initcodes( 'stvsf', #h0c4, 2, 1, 0, addr_neutral, 250);
initcodes( 'stcea', #h0c9, 0, 0, 0, addr_neutral, 170);
initcodes( 'setst', #h0cc, 0, 0, 0, addr_neutral, 350);

initcodes( 'pcals', #h0d0, 2, 1, 4, addr_neutral, 251);
initcodes( 'pcald', #h0d1, 0, 0, 0, addr_neutral, 216);
initcodes( 'pexit', #h0d2, 0, 0, 0, addr_neutral, 91);

initcodes( 'lpush', #h0e0, 0, 0, 0, addr_neutral, 302);
initcodes( 'lpop',  #h0e1, 0, 0, 0, addr_neutral, 278);
initcodes( 'lrese', #h0e2, 0, 0, 0, addr_neutral, 89);
initcodes( 'llock', #h0e3, 2, 0, 0, addr_neutral, 217);


initcodes( 'mnoop', #h0f0, 0, 0, 0, addr_neutral, 120);
no_op_ix := lastcode; (* remember no op index *)
initcodes( 'mcist', #h0f1, 0, 0, 0, first_of_pair, 120);

initcodes( 'mbtes', #h0f2, 2, 0, 0, addr_neutral, 120);
initcodes( 'mbset', #h0f3, 2, 0, 0, addr_neutral, 120);
initcodes( 'mxept', #h0f4, 0, 0, 0, addr_neutral, 120);
if revision_number = 3 then
initcodes( 'madlu', #h0f5, 0, 0, 0, addr_neutral, 120);
initcodes( 'mwi',   #h0f6, 0, 0, 0, first_of_pair, 120);
initcodes( 'mwt',   #h0f7, 0, 0, 0, first_of_pair, 120);
initcodes( 'mwis',  #h0f8, 0, 0, 0, first_of_pair, 120);
initcodes( 'mwit',  #h0f9, 0, 0, 0, first_of_pair, 120);
initcodes( 'mwst',  #h0fa, 0, 0, 0, first_of_pair, 120);
initcodes( 'mwist', #h0fb, 0, 0, 0, first_of_pair, 120);
initcodes( 'mwtac', #h0fc, 0, 0, 0, second_of_pair, 120);
initcodes( 'mtime', #h0fd, 0, 0, 0, addr_neutral, 120);
initcodes( 'mcis',  #h0fe, 0, 0, 0, first_of_pair, 120);
initcodes( 'mcit',  #h0ff, 0, 0, 0, first_of_pair, 120);


reserve_max := 0;

line_spacing := default_line_table_spacing;

segment_size := default_buffer_size - 1;

line_add := 0;

current_source_line := 0;
line_table_descriptor := nill;





end;  (* initialization *)



procedure init_between_code_blocks;

(* initialize variables and internal structures, ready for
a new block of code *)

begin

internal_link_list := nill;

total_time := 0;


program_kind := closed_routine;

current_jump_ptr := 0;

cur_lab_ptr := 0;

current_segment := 1;

current_offset := 0;

rewrite( codefile );  (* work file for the code *)

last_page := false;

codesize_met := false;

generate_line_info := true;

spacing_met := false;

lineinfo_met := false;

line_table_size := (segment_size + 1 - fix_line_table_part) div
(line_spacing + 1)  +  fix_line_table_part;
line_table_size := (line_table_size + 1) div 2 * 2; (* integral number of words *)

rem_buffer_size := segment_size + 1 - longjump_size; (* prepared for a closed routine or process *)

line_table_descriptor := getnamenode;

start_of_line_table := segment_size + 1 - line_table_size;

prepare_linetable;


end; (* initialization of variables used per-block of code *)




\f


function add_unsatisfied_node ( chainstart : unsatref_ix;
ic_rel : boolean;  relative_byteno : integer;
byte_size : integer) : unsatref_ix ;

(* get a new node for a use of a label or a constant, and initialize
the node, byte_size is the number of bytes to change when the symbol is defined *)
var
localnode : unsatref_ix;

begin
if unsatref_freelist = nill then
stop('maxunsatrefs', 'addunsatisfiednode')
else
localnode := unsatref_freelist;

with unsatisfied_refs [ localnode ] do
begin
unsatref_freelist := next_ref;
next_ref := chainstart;
ic_relative := ic_rel;
reloc := relative_byteno;
use_segment := current_segment;
use_offset := current_offset + byte_size - 1; (* least significant byte *)
size := byte_size;
end;

add_unsatisfied_node := localnode;

end; (* add unsatisfied node *)


procedure remove_unsatisfied_node( var chainstart : unsatref_ix);

(* insert the element specified by chainstart into the free list and
let chainstart denote the successor of the removed element *)

var
localresult : unsatref_ix;

begin
with unsatisfied_refs [ chainstart ] do
begin
localresult := next_ref;
next_ref := unsatref_freelist;
unsatref_freelist := chainstart;
end;

chainstart := localresult;

end; (* remove unsatisfied node *)
\f


function search_name(name : namestring; namelist : name_ix;
insert : boolean ) : name_ix;

(* lookup name in the list starting at names [ namelist ], 
if not found and insert then add a new name node as the
successor of names [ namelist ],
if not found and not insert then the function result
becomes nill, if found or inserted the function result
becomes the name table entry of the searched name *)

var
localresult : name_ix;
found : boolean;

begin
localresult := namelist; 
found := false;

while (localresult <> nill) and not found do
with names [ localresult ] do
if namepart = name then
found := true
else
localresult := next_name;

if not found and insert then
begin (* inser the name as successor of namelist *)
localresult := getnamenode;
with names [ localresult ] do
begin
namepart := name;
next_name := names [ namelist ] . next_name;
end; (* with *)
names [ namelist ] . next_name := localresult;
end; (* if not found and insert *)

(* now localresult denotes the searched node if the name is
in the list, otherwisw localresult is null, i.e. localresult is
the wanted function result *)

search_name := localresult;

end; (* search name *)


function find_name : name_ix;

(* find the index of the name kept in chbuf, if not declared the
function result becomes nill. if the name is of the
sequential type the namepart ( a# ) is searched (if not
found then error) after that the entire name is searched -
and possibly inserted - at the level of the namepart *)

var
namestr : namestring;
seq_name : boolean;
level, step : integer;
nameptr : name_ix;

begin
namestr := blank;
seq_name := (chbuf [ 2 ] = '#') and (lastchar >= 2);

if seq_name then
begin
namestr [ 1 ] := chbuf [ 1 ];
namestr [ 2 ] := '#'; (* = chbuf [ 2 ] *)
end
else
for step := 1 to lastchar do
if step <= namelength then
namestr [ step ] := chbuf [ step ] ;

level := current_level;

repeat
nameptr := search_name(namestr, levelstack [ level ], false);
level := level - 1;
until (nameptr <> nill) or (level < 0 );

if (nameptr <> nill) and seq_name then
begin
for step := 3 to lastchar do
namestr [ step ] := chbuf [ step ] ;
(* if namestr not defined yet then insert a definition as successor
of nameptr *)
nameptr := search_name(namestr, nameptr, true);
end;

find_name := nameptr;
if test then
begin
outtest('find_name');
writeln(output,' name is : ', namestr, 'index = ', nameptr);
end;


end; (* find name *)


\f



procedure output_line_information;
(* generate next line table entry *)

begin
if generate_line_info then
begin
if line_add <= max_line then
begin
code_buffer [ next_line_table_entry ] :=  line_add;
line_add := 0;
end
else
begin
code_buffer [ next_line_table_entry ] := max_line;
line_add := line_add - max_line;
end;

next_line_table_entry := next_line_table_entry + 1;

end;
end; (* output line information *)


procedure outbyte(byte_operand  :  integer);

(* check the size of byte_operand ( -128 <= byte_operand <= 255)
and insert the operand as current byte of the code buffer
and update the code buffer pointer  *)

begin

if (byte_operand >= -128) and (byte_operand <= 255) then
begin
if byte_operand < 0 then
byte_operand := byte_operand  + maxbyte; (* let the byte be inside (0..255) *)
end
else
begin
markerror( 1); (* byte operand out of bounds (-128..127)  *)
byte_operand := 0;
end;

code_buffer [ current_offset ] := byte_operand;
if current_offset mod line_spacing = 0 then
output_line_information;
current_offset := current_offset + 1;

end;  (* out byte *)


procedure outword ( word_operand  : integer );

(* check the size of word operand (-2**15 <= operand <= 2**16 -1)
insert the operand as two bytes ( 0.. 255 ) into the code buffer
and adjust the code buffer pointer *)


begin
if (word_operand >= word_min) and (word_operand <= word_max) then
begin
if word_operand < 0 then
word_operand := word_operand + word_max + 1;
end
else
begin
markerror( 2); (* word operand out of bounds ( - 32768 .. 65535 ) *)
word_operand := 0;
end;

code_buffer [ current_offset ] := word_operand div maxbyte;
current_offset := current_offset + 1;
code_buffer [ current_offset ] := word_operand mod maxbyte;
if current_offset mod line_spacing <= 1 then
output_line_information;
current_offset := current_offset + 1;

end; (* out word *)






procedure outcode( cur_code : coderange );
begin

with opcodes [ cur_code ] do
begin
use_count := use_count + 1;

code_buffer [ current_offset ] :=  opcodeval;
end; (* with *)
if current_offset mod line_spacing = 0 then
output_line_information;
current_offset := current_offset + 1;

end; (* outcode *)


procedure change_code( disp : code_ix );

(*see if opcode could be an ais;
disp denotes the least significant byte of the first
parameter, i.e. disp - 2 is the op-code *)

var
offset, opcode_val : coderange;
interval : interval_index;
step : integer; 
found : boolean;

begin
opcode_val := code_buffer [ disp - 2 ];

step := -1;
repeat
step := step + 1;
until (step > max_code_number) or (opcodes [ step ] . opcodeval = opcode_val);

if step <= max_code_number then
if ais_codes [ step ] <> 0 then
begin

offset := code_buffer [ disp - 1 ];
if offset >= 128 then
offset := (offset - 128) * 256 + word_min (* sign extension *)
else
offset := offset * 256;
offset := offset + code_buffer [ disp ] ;

interval := ais_codes [ step ];

repeat
with intervals [ interval ] do
begin
found := (offset >= interval_low) and (offset <= interval_high);
if not found then
interval := next_interval;
end; (* with *)

until found or ( interval = 0 );

if found then
begin
with opcodes [ step ] do use_count := use_count - 1;
with opcodes [ intervals [ interval ] . ais_code_val ] do
begin
code_buffer [ disp - 2 ] := opcodeval;
use_count := use_count + 1;
end; (* with opcodes ( intervals ... *)
end; (* if found ... *)

end; (* if ais-code ... *)

end; (* change code *)





procedure put_word( displacement : code_ix; destination : integer );

(* add 'destination' (two bytes) to the contents of code buffer, displacement
bytes from the start *)

begin

if destination < 0 then
destination := destination + word_max + 1;

code_buffer [ displacement - 1 ] := destination div maxbyte + code_buffer [ displacement - 1 ] ;
code_buffer [ displacement ] := destination mod maxbyte + code_buffer [ displacement ] ;

change_code( displacement );

end; (* put word *)


 

procedure insert_address_and_return( unsat_ref : unsatref_ix );

(* insert current offset into the two bytes the offset of which is
described by unsat_ref, free the reserved space for long addressing
and return the unsat_ref_node *)

var
offset : integer;

begin

offset := current_offset;

with unsatisfied_refs [ unsat_ref ] do
begin
if ic_relative then
offset := offset - use_offset + reloc -1;
code_buffer [ use_offset - 1] := code_buffer [ use_offset - 1 ] + offset div maxbyte;
code_buffer [ use_offset ] := code_buffer [ use_offset ] + offset mod maxbyte;
if ic_relative then
(* release the reserved space *)
rem_buffer_size := rem_buffer_size + longjump_size;

change_code ( use_offset );


if statistical_version then
if generate_statistics and (survey_option_number > 4) and
(survey_option_number < 9) then
begin
current_interval := stat_unsat_refs ^ [ unsat_ref ];

if current_interval <> nil then
begin
offset := code_buffer [ use_offset - 1 ] ;
if offset >= 128 then
offset := (offset - 128) * 256 + word_min  (* extend sign *)
else
offset := offset * 256;
offset := offset + code_buffer [ use_offset ] ;

while offset > current_interval ^ . upper_limit do
current_interval := current_interval ^ . next_descriptor;

with current_interval ^ do
interval_count := interval_count + 1;

end; (* current <> nil *)
end; (* statistical version *)


end;

remove_unsatisfied_node( unsat_ref );

end; (* insert address and return *)




procedure fill_in_jumps;

(* prepare internal linking - through a long jump - for short address jumps
out of the segment *)

var
step : integer;
chain : unsatref_ix;

begin
for step := 1 to current_jump_ptr do
with jump_table [ step ] do
if (code_buffer [ jump_from ] = 0) and (code_buffer [ jump_from - 1 ] = 0) then
begin (* long jump is needed *)
put_word(jump_from, current_offset - jump_from + 2 );
outcode(longjump);
(* find the unsatisfied ref-node and update it *)
chain := names [ destination ] . use_chain;

while chain <> nill do
with unsatisfied_refs [ chain ] do
if use_offset = jump_from then
begin (* the node to change is found *)
ic_relative := false; (* i.e. reloc has no meaning *)
(* use segment is not changed *)
use_offset := current_offset + addrsize - 1;
size := addrsize;

chain := nill; (* exit *)
end
else (* not found yet *)
chain := next_ref;
outword(0); outword(0);
end; (* long jump generated *)
current_jump_ptr := 0; (* reset jump_table *)

end; (* fill in jumps *)





procedure emitcode( jump_to_next : boolean );

 
(* make exit jump and long jumps for the jumps denoted by the
jump table, and write the code buffer contents onto the codefile *)

var
step, step1 : integer;
word : integer;
last_to_emit : code_ix;
link_node : name_ix;

begin
if test then outtest('emitcode');
(* make exit jump *)
if jump_to_next then
begin
outcode(longjump);

link_node := getnamenode;

with names [ link_node ] do
begin (* create a node denoting the entry of the next segment *)
namepart := 'no name';
kind := label_def;
def_segment := current_segment + 1;
def_offset := 0;
use_chain := add_unsatisfied_node(nill, false, 5, addrsize);
next_name := internal_link_list;
end;
internal_link_list := link_node;

(* reserve room for the jump address to be filled in by the linker *)
outword(0); outword(0);
end; (* jump to next page *)

(* prepare internal linking - through a long jump - for short address jumps
out of the segment *)
fill_in_jumps;

(* line table handling *)
if start_of_line_table <> 0 then
begin (* line table present *)
if line_add <= max_line then
code_buffer [ next_line_table_entry ] := line_add
else
code_buffer [ next_line_table_entry ] := max_line;
line_add := 0;
next_line_table_entry := next_line_table_entry + 1;

(* remember current offset *)
last_to_emit := current_offset;
current_offset := start_of_line_table;

with names [ current_line_record ] do
begin
def_segment := current_segment;
def_offset  := start_of_line_table;
kind := label_def;
end;

if not last_page then
begin
current_line_record := getnamenode;
with names [ current_line_record ] do
begin
namepart := 'linrec';
next_name := internal_link_list;
internal_link_list := current_line_record;

use_chain := add_unsatisfied_node(use_chain, false, 0, 4);
end;
end;

(* now get the correct current_offset back *)
current_offset := last_to_emit;

end; (* handling of line table *)


(* emit the code *)

if jump_to_next then
last_to_emit := segment_size
else
last_to_emit := current_offset - 1;

for step := 0 to (last_to_emit + (bytes_pr_word - 1 - bytes_pr_word)) div bytes_pr_word do
begin
word := 0;
for step1 := 1 to bytes_pr_word do
word := word * maxbyte + code_buffer [ step * bytes_pr_word + step1 - 1 ];
write(codefile, word);

end;


(* prepare a fresh code buffer *)
rem_buffer_size := segment_size + 1 - longjump_size; (* reserve room for the exit jump *)
current_offset := 0;
current_segment := current_segment + 1;
(* prepare a line table if needed *)

if not last_page and (start_of_line_table <> 0) then
prepare_linetable;


end; (* emit code *)

procedure word_align;
var
step : integer;
begin
(* if not word boundary then insert a dummy byte and update current_labels *)
if odd( current_offset ) then
begin (* room for alignment is guaranteed *)
rem_buffer_size := rem_buffer_size - 1;
outbyte(0);

for step := 1 to cur_lab_ptr do
with names [ current_labels [ step ] ]  do
def_offset := current_offset;
end; (* else current_offset is even or reservecode will force a segment change *)

end; (* word align *)






function reservecode( reserve_size : integer ) : boolean;

(* ensure that reserve_size consecutive bytes are available on
the same segment, if the remaining part of current segment is
insufficient the code buffer contents will be optput, and a fresh
buffer is prepared; if still not enough room the function result becomes false.
the labels which are defined at current "point" are changed
to denote the start of the new segment *)

var
step : integer;
listnext,
list : unsatref_ix;

begin
reservecode := true;
if reserve_size > rem_buffer_size then
begin
emitcode(true); (* empty the buffer and fill in jumps *)
if reserve_size > rem_buffer_size then
begin
reservecode := false;
markerror( 14 ); (* constant block greater than page size *)
if reserve_size > reserve_max then
reserve_max := reserve_size; (* remember maximum block size *)
reserve_size := 0;
end; (* not enough room *)

for step := 1 to cur_lab_ptr do
with names [ current_labels [ step ] ] do
begin
def_offset := current_offset;
def_segment := current_segment;
end;
end; (* change buffer *)

(* update the symbol nodes for the names kept in 'current_labels',
and try to solve some of the uses; let the list be empty at procedre exit *)

for step := 1 to cur_lab_ptr do
with names [ current_labels [ step ] ] do
begin
list := use_chain; use_chain := nill;
while list <> nill do
with unsatisfied_refs [ list ] do
begin
listnext := next_ref;  (* point at successor *)
if (size <= 2) and (use_segment = current_segment) then
insert_address_and_return(list)
else
begin
(* insert in usechain again *)
next_ref := use_chain;
use_chain := list;
end;
list := listnext;
end;

end; (* with names .... *)

cur_lab_ptr := 0; (* empty the list *)

(* end of  update label definitions *)

rem_buffer_size := rem_buffer_size - reserve_size;

end;  (* reserve code *)

\f



(* procedures for handling of line tables and source line records *)

procedure emit_start_of_line_table;

(* output a record as follows:

start_of_line_information_chain : packed record
.          coded_date : packed record                   * 2 bytes *
.                         year_after_1980 : 0..127;
.                         month           : 0..15;
.                         day             : 0..31;
.                       end;
.          coded_time : packed record       * 2 bytes *
.                         compiler_version : 0..31;
.                         hour             : 0..31;
.                         minute           : 0..63;
.                       end;
.          length_of_code : integer;                    * 2 bytes *
.          length_of_last : integer;                    * 2 bytes *
.          last_line      : integer;                    * 2 bytes *
.          line_spacing   : integer;                    * 2 bytes *
.          start_of_chain : ^ line_number_table;        * 4 bytes *
.       end;


*)


var
reserve_result : boolean;

begin
reserve_result := reservecode(length_of_descriptor);

head_of_lines := current_offset;

with names [ line_table_descriptor ] do
begin
def_segment := current_segment;
def_offset  := current_offset;
kind := label_def;
next_name := internal_link_list;
internal_link_list := line_table_descriptor;
end; (* initialization of a label describing the line table descriptor *)

outword( coded_date );
outword( coded_time );
outword( segment_size + 1 - line_table_size ); (* may be changed by option codesize *)

(*make a constant to be inserted later on, length of last page *)

length_of_last_segment := getnamenode;
with names [ length_of_last_segment ] do
use_chain := add_unsatisfied_node ( use_chain, false, 0, 2 );
outword( 0 - 0 - 0 );


(* make a constant to be inserted later on, last line number *)
last_line_number := getnamenode;
with names [ last_line_number ] do
use_chain := add_unsatisfied_node ( use_chain, false, 0, 2 );
outword( 0 - 0 - 0 );

outword( line_spacing ); (* may be changed by option spacing *)

current_line_record := getnamenode;
(* prepare internal linking of the line number table *)
with names [ current_line_record ] do
begin
namepart := 'linrec';
next_name := internal_link_list;
internal_link_list := current_line_record;

use_chain := add_unsatisfied_node ( use_chain, false, 0, 4 );
(* the name node will be defined by procedure emitcode *)
end;

outword( 0 ); outword( 0 );  (* room for the address *)

end; (* emit start of line table *)



procedure handle_line;
 
(* read the line number, just met  l.  *)

var
local_next_line : integer;

begin
while get_next_token <> symbol do (* skip *) ;
local_next_line := get_constant_value;

if current_source_line < local_next_line then
begin (* the line tables will contain an increasing sequence of line numbers *)

line_add := local_next_line - current_source_line + line_add;
current_source_line := local_next_line;
end;

token := get_next_token; (* prepare next token *)

end; (* handle line *)


procedure handle_linetable;

(* just read  z.
syntax:

.   ----->  name    ----->  e.  ----->


produce a block of information for the exception handler:

.      routine name         12 bytes
.      address of descriptor 4 bytes

.  the descriptor is a record as defined in procedure emit_start_of_line_table  

*)

const
z_block_length = 16; (* bytes *)

var
step : integer;
reserve_result : boolean;

begin
if generate_line_info then
begin
(* this construction may cause reservation of one byte more than
actually used, namely in case of page change, and in that case
a zero byte is emitted on the former page between the code and the
jump_to_next_page !!!!! *)

(* word allign *)
word_align;
reserve_result := reservecode( z_block_length );

while get_next_token <> symbol do (* skip until name has been read *);

for step := lastchar + 1 to alfalength do
chbuf [ step ] := ' '; (* fill with spaces *)

(* emit the name *)
for step := 1 to alfalength div 2 do
outword( ord(chbuf [ 2*step - 1 ]) * maxbyte
+        ord(chbuf [ 2*step     ]) );

with names [ line_table_descriptor ] do
use_chain := add_unsatisfied_node ( use_chain, false, 0, 4);
outword( 0 ); outword( 0 );

end;

while get_next_token <> blockend do (* skip *);

token := get_next_token;

end; (* handle_linetable *)

\f



procedure read_symbolic_expression(
var symb : name_ix;
var constant_part : integer );

(*  ------------>   signed integer ------------------------------->
.        !                                              !
.        -----> symbol -->-------------------------------
.                         !                             !
.                         !--> + -> unsigned integer -->!
.                         !        !
.                         !--> - ->!
*)
(* let symb be a pointer to symbol (if present) and
let constant_part be the value of the unsigned integer
with the operator (if present) as sign
the default values are symb = nill and constant_part = 0 *)

var
local_const : integer;
operator : char;

begin
symb := nill;
constant_part := 0;
if line [ lineindex ] = '-' then
operator := '-'
else
operator := '+';

if get_next_token <> symbol then
markerror( 3 ) (* illegal expression *)
else
begin
if lastchar = 0 then (* signed integer *)
begin
operator := line [ lineindex ];
if get_next_token <> symbol then
markerror( 3 );
end;

if not ((chbuf [ 1 ] >= '0') and (chbuf [ 1 ] <= '9')) then
begin (* name *)
symb := find_name;
if symb = nill then
markerror( 3 );
operator := line [ lineindex ] ; (* see if expression *)
if (operator = '+') or (operator = '-') then
(* make chbuf contain the second operand *)
if get_next_token <> symbol then markerror( 3 );
end;

local_const := get_constant_value;

if operator = '-' then
local_const := - local_const;

constant_part := local_const;
end;
end; (* read symbolic expression *)



procedure solve_uses( name : name_ix );

var
displ : integer;
list : unsatref_ix;

begin
with names [ name ] do
begin
list := use_chain;

while list <> nill do
with unsatisfied_refs [ list ] do
if use_segment = current_segment then
begin
case size of

1: 
begin
if def_offset < 0 then
displ := def_offset + maxbyte + 1
else
displ := def_offset mod ( maxbyte + 1 );
end;

2:
begin
if def_offset < 0 then
displ := def_offset + word_max + 1
else
displ := def_offset  mod (word_max + 1);
end;
 
end; (* case *)
put_word( use_offset , displ );
if statistical_version then
if generate_statistics and (survey_option_number > 4) and
(survey_option_number < 9) then
begin
current_interval := stat_unsat_refs ^ [ list ];

if current_interval <> nil then
begin
if code_buffer [ use_offset - 1 ] >= 128 then
displ := (code_buffer [ use_offset - 1 ] - 128) * 256 + word_min
         + code_buffer [ use_offset ]
else
displ := code_buffer [ use_offset - 1 ] * 256 +
         code_buffer [ use_offset ] ;

while displ > current_interval ^ . upper_limit do
current_interval := current_interval ^ . next_descriptor;

with current_interval ^ do
interval_count := interval_count + 1;

end; (* current <> nil *)
end; (* statistical version *)


remove_unsatisfied_node ( list );
use_chain := list;
end
else
list := nill; (* no more inside this segment *)

end; (* with names .... *)

end; (* solve uses *)



procedure update_constants;

(* traverse the dependence chain and fill in 
information into the constant descriptors ( name nodes )
and remove the satisfied dependence chain elements *)

var
former, current : dep_chain_ix;

begin
former := dep_chain_start;
current := dependence_chain [ dep_chain_start ] . next_dep;

while current <> nill do
with dependence_chain [current ] do
if names [ dependence ] . def_segment <> nill then
(* the unsatisfied dependence can be solved *)
with names [ dependent ] do
begin
def_segment := names [ dependence ] . def_segment;
def_offset  := names [ dependence ] . def_offset + def_offset;
kind        := names [ dependence ] . kind;

solve_uses ( dependent );


return_dependence_node(former, current);

(* now start all over since a symbol more has been defined *)
former := dep_chain_start;
current := dependence_chain [ dep_chain_start ] . next_dep;
end

else

begin
former := current;
current := next_dep;
end;


end; (* update constants *)



procedure update_symbol;

(* two cases:
1) label definition : read all the labels for the next instruction
or structured constant and let them be defined with current program
(segment) point as addressl make a chain of the labels to be used
in case of redefinition because of segment change, e.g. a
structured constant which needs more space than is left in current
segment is to be defined.
2) constant definition : read the symbolic expression and let the
value of the constant be the expression result, if the symbol of the
expression is not defined yet an element describing the interdependence
is created *)

var
nameptr, symb : name_ix;
disp : integer;
dep_ix : dep_chain_ix;
 
begin

if test then outtest('update symbol');

nameptr := find_name;

if nameptr = nill then
markerror( 4 )  (* undeclared symbol *)
else
with names [ nameptr ] do
if def_segment <> nill then
markerror( 5 )  (* double defined symbol *)
else
if token = labeldef then
begin
if cur_lab_ptr < max_cur_labels then
cur_lab_ptr := cur_lab_ptr + 1
else
stop('max_cur_labels', 'update_symbol');
current_labels [ cur_lab_ptr ] := nameptr;
def_segment := current_segment;
def_offset := current_offset;
kind := label_def;
end
else (* constant definition *)
begin
read_symbolic_expression( symb, disp );
def_offset := disp;
if symb <> nill then
begin
def_segment := nill; (* i.e. yet undefined *)
dep_ix := get_dep_chain_node;

with dependence_chain [ dep_ix ] do
begin
dependent := nameptr;
dependence := symb;
next_dep := dependence_chain [ dep_chain_start ] . next_dep;
end;
dependence_chain [ dep_chain_start ] . next_dep := dep_ix;

end
else (* symb = nill *)
begin
def_segment := 1; (* <> nill, i.e. defined *)
kind := constant_def;
solve_uses ( nameptr );
end;

update_constants;

end; (* constant definition *)

token := get_next_token;

end; (* update symbol *)




\f


function find_code  :  coderange;

(* search the codes for the name kept in chbuf,
if not found the function result becomes the index of no_op
and an error is marked *)

label 256; (* exit label, used in case of undefined opcode *)

var
hash_code : packed record
case boolean of
true:  ( codeword : namestring;);
false: (int1, int2 : integer);
end;
result : integer;
found : boolean;
step : integer;

begin
with hash_code do
begin
(* pack the contents of chbuf *)
codeword := blank;

for step := 1 to lastchar do
if step <= namelength then 
codeword [ step ] := chbuf [ step ] ;

found := false;
step := 0;

(* this function  m u s t  be the same as in init-codes *)
result := abs( int1 div hash1 + int2 div hash2 ) mod hash3;
while codeword <> opcodes [ result ] . namepart do
begin
result := (result + 1) mod hash3;
step := step + 1;
if step > 256 then goto 256; (* exit, not found *)
end;
256:
found := step < 256;


if not found then
begin
if not (generate_statistics and (codeword = 'bar')) then
markerror1( 6, codeword );  (* undefined opcode *)
result := no_op_ix;
end;

find_code := result;

end; (* with hash code *)

end; (* find code *)





procedure handle_code;

var
symb : name_ix;
displacement : integer;
trailernr, operandsize : integer;
current_code : coderange;
reserve_ok : boolean;
found, displ_ready : boolean ;
start_interval : interval_index;
local_reloc : 0 .. 8 ;

begin

if test then outtest('handle code');

current_code := find_code;

with opcodes [ current_code ] do
begin

if codelist then (* accumulate time *)
begin
total_time := total_time + exc_time;
current_time := exc_time;
end; (* list and accumulate times *)
case opcode_kind of
jump_short: reserve_ok := reservecode(total_length + longjump_size);
first_of_pair: begin
 reserve_ok := reservecode( total_length + 1 );
rem_buffer_size := rem_buffer_size + 1;
end;
end (* case *)

otherwise
reserve_ok := reservecode(total_length);
length_of_current_code := total_length;
outcode(current_code);
local_reloc := 1; (* space for the op-code *)
trailernr := 1;
operandsize := trailers [ 1 ];
while operandsize <> 0 do
begin
displ_ready := false;

local_reloc := local_reloc + operandsize;
read_symbolic_expression( symb, displacement );

if symb <> nill then
with names [ symb ] do
begin
if (def_segment <> nill) and (operandsize <= 2) then
if (opcode_kind = jump_short) or (opcode_kind = ic_rel) then
if def_segment = current_segment then
begin
displ_ready := true;
displacement := displacement + def_offset -
 (current_offset + 1) + local_reloc - 1 
end
else
use_chain := add_unsatisfied_node( use_chain, true, local_reloc, operandsize)
else
begin
if statistical_version then
displ_ready := true;
displacement := displacement + def_offset;
end
else
use_chain := add_unsatisfied_node(use_chain, 
((opcode_kind = ic_rel) and (operandsize >= 2)) or (opcode_kind = jump_short),
local_reloc, operandsize );
if (opcode_kind = jump_short) and (def_segment <> current_segment) then
begin
(* add a new element to the jump_table *)
if current_jump_ptr < max_jump_ix then
current_jump_ptr := current_jump_ptr + 1
else
stop('max_jump_ix', 'handle_code');

with jump_table [ current_jump_ptr ] do
begin
jump_from := current_offset + 1; (* least significant byte of the operand *)
destination := symb;
end; (* with jump table .. *)

end; (* if opcode kind = jump short .. *)
end;

if displ_ready or ( symb = nill ) then
if ais_codes [ current_code ] <> 0 then
begin

start_interval := ais_codes [ current_code ];
if trailernr = intervals [ start_interval ] . trailer_nr then
begin

repeat
with intervals [ start_interval ] do
begin
found := (displacement >= interval_low) and (displacement <= interval_high);
if not found then start_interval := next_interval;

end; (* with *)

until found or ( start_interval = 0 );

if found then
begin
with opcodes [ current_code ] do use_count := use_count - 1;

with opcodes [ intervals [ start_interval ] . ais_code_val ] do
begin
code_buffer [ current_offset - local_reloc + operandsize ] := opcodeval;
local_reloc := local_reloc - operandsize + trailers [ trailernr ];

length_of_current_code := total_length;

rem_buffer_size := rem_buffer_size + operandsize - trailers [ trailernr ];

operandsize := trailers [ trailernr ];

use_count := use_count + 1;

(* execution time information not changed !!! *)

end;  (* with *)

end; (* if found *)

end; (* if trailernr ...  *)

end; (* if ais codes ...  *)



case operandsize of
1: outbyte( displacement );
2: outword( displacement );
4: begin
outword( 0 ); outword( displacement );
end;
end (* case *)
otherwise ;

if statistical_version then
if generate_statistics and
(survey_option_number > 4) and (survey_option_number < 9) then
begin
if trailernr < 3 then
if stat_opcodes ^ [ current_code ] . trail_head [ trailernr ] . first_descriptor <> nil then
if (symb = nill) or displ_ready then (* inline constant *)
begin
current_interval := stat_opcodes ^ [ current_code ] . trail_head [ trailernr ] . first_descriptor;

while displacement > current_interval ^ . upper_limit do
current_interval := current_interval ^ . next_descriptor;

with current_interval ^ do
interval_count := interval_count + 1 ;

end (* symb = nill or displ ready *)

else
(* add unsatisfied node  called !! *)
stat_unsat_refs ^ [ names [ symb ] . use_chain ] :=
stat_opcodes ^ [ current_code ] . trail_head [ trailernr ] . first_descriptor ;


end; (* if statistical version *)



if trailernr < max_no_of_trailers then
begin
trailernr := trailernr + 1;
operandsize := trailers [ trailernr ] ;
end
else
operandsize := 0; (* stop *)

if (operandsize > 0) and (line [ lineindex ] <> ',') then
begin
markerror( 7 );  (* missing operand *)
operandsize := 0;
end;

end; (* while operandsize > 0 *)

end; (* with opcodes [ current_code ]  *)

token := get_next_token; (* prepare next instruction *)

end;  (* handle code *)

\f


procedure handle_constant;

(* just read 'c.' now handle :

.   -----> size ->->  field  ---->------->  e.  ------->
.                !                !
.                !<--- nl <-------!
.                !                !
.                !<---  , <-------!
.
. where field is defined as:
.
.   --->-------->------> symbolic expression ---------->
.       !        !
.       !-> $b ->!
.       !        !
.       !-> $i ->!
.       !        !
.       !-> $a ->!

*)

type
constant_modes = (byte_mode, word_mode, addr_mode);

var
current_mode : constant_modes;
segment, disp, constant_size, size : integer;
symb : name_ix;

begin

if test then outtest('handle constant');

current_mode := word_mode;  (* default *)
constant_size := 2;

word_align; (* assure constant start at a word boundary *)

read_symbolic_expression( symb, size);
if not reservecode( size ) then
size := -1; (* force skip of constant *)

while token <> blockend do
begin
if lineindex = linelength then
begin
if (errorindex > 0) and errorreporting then writeln(output);
if codelist and not printed then printline;
readline;
if codelist then printline;
end;
if line [ lineindex + 1 ] = '$' then
begin
case line [ lineindex + 2 ] of
'b', 'B' : 
begin
current_mode := byte_mode; constant_size := 1;
end;

'i', 'I' :
begin
current_mode := word_mode; constant_size := 2;
end;

'a', 'A' :
begin
current_mode := addr_mode; constant_size := 4;
end;

end; (* case *)
lineindex := lineindex + 2; (* skip radix *)

end; (* if change mode *)

size := size - constant_size;

if size < 0 then
begin
token := get_next_token;  (* skip until 'e.' *)
if size + constant_size < 0 then
markerror( 8 );  (* too many fields in structured constant definition *)
end
else
begin
read_symbolic_expression( symb, disp);

if symb <> nill then
with names [ symb ] do
begin
segment := def_segment;
if (segment <> nill) and (current_mode <> addr_mode) then
disp := disp + def_offset
else
use_chain := add_unsatisfied_node( use_chain, false, 1, constant_size);
end

else

segment := 0;

case current_mode of

byte_mode : outbyte( disp );

word_mode : outword( disp );

addr_mode : 
begin
outword( 0 ); outword( disp );
end;

end; (* case *)

end;

end; (* while not blockend *)

if size > 0 then 
markerror( 9 ); (* too few constants *)

token := get_next_token;

end; (* handle constants *)

\f


procedure read_declaration;

(*

.   ---->----------------------->-->  .  --->  nl  --->
.        !                       !
.        !->-> declaration -->-->!
.           !                 !
.           !<---------<- , <-!
.           !         !
.           !<- nl <--!


there is no check against double declarations,
the names are inserted into the name table in opposite order of
declaration

*)
label  117;  (* allow line numbers between declarations *)

var
localtoken : tokens;
step : integer;
nameptr : name_ix;

begin

if test then outtest('read declaration');

if current_level < maxlevel then
current_level := current_level + 1
else
stop('max_level', 'read_declaration' );

levelstack [ current_level ] := nill;

repeat
localtoken := get_next_token;
117: if (localtoken <> symbol) and (localtoken <> other) (* empty declaration *) then
begin
if localtoken = source_line_number then
begin
handle_line;
localtoken := token; (* token was assigned by handle line *)
goto 117; (* proceed as if source line was not met *)
end
else
markerror( 10 ); (* error in declaration *)
end
else
if lastchar > 0 then
begin
(* non empty declaration *)
nameptr := getnamenode;

with names [ nameptr ] do
begin
for step := 1 to lastchar do
if step <= namelength then
namepart [ step ] := chbuf [ step ] ;
def_segment := nill;  (* undefined *)
def_offset := 0;
kind := undefined;
next_name := levelstack [ current_level ];
end; (* with *)
levelstack [ current_level ] := nameptr;

end;

until line [ lineindex ] = '.'; (* end declaration list *)

token := get_next_token;

end; (* read declaration *)
\f


procedure unstack_level;

(*
.     ------>   e.    ------->

traverse the name list of current level 
if use chanin = nill then remove entry
else
if not defined then error
else put the name definition into the internal link list

remove level 

*)

var
local_next_name , list : name_ix;

begin
if test then
outtest('unstack level');

if dump_nametable then
output_names;

list := levelstack [ current_level ];

while list <> nill do
with names [ list ] do
begin
local_next_name := next_name;
if use_chain = nill then
returnname(list)
else
if kind = undefined then
begin
markerror1( 11, namepart ); (* undefined but used label *)
returnname( list );
end

else

begin
next_name := internal_link_list;
internal_link_list := list
end;

list := local_next_name;

end; (* while list <> nill *)

current_level := current_level - 1;
token := get_next_token;

end; (* unstack level *)


procedure read_options;
(*
.   ------>  o.  ---->----> pass nr  -->  option  -->  value -->---> . --->
.                    !                                         !
.                    !---------------<-------------------------!

if pass nr <> 6 then skip

legal options :

.   option      default value     meaning
.    1 (list)        0 (no)       codelist := value=1
.    2 (test)        0 (no)       test     := value=1
.    3 (codesize)  512            segment_size := max(min_buffer_size, min(codebuffersize, value ))
.    4 (print)       0 (no)       print_code:= value=1
.    5 (errormess)   0 (no)       errorreporting := value=1
.    7 (nametable)   0 (no)       dump_nametable := value=1
.    8 (left hand side)           the file name is given as options
.                                 81 to 86, two characters per option
.    9 (spacing)        52        line table spacing :=
.                                 max( 4, min(codebuffersize, value, segmentsize))
.   10  (statistics)     0      generate stitistical information
.   11 (lineinfo)        1 (yes)  generate line tables and other information 
.                                 for the exception handler
.   12 (open or closed)    1 (closed)   program_kind := value of opt(12)
 


*)

var
dummyname, symb : name_ix;
current_code : coderange;
paramno, no_of_intervals, limit,    (* only used in case of statistical version *)
pass, opt, val : integer;

begin
repeat
repeat 
read_symbolic_expression( symb, pass );
read_symbolic_expression( symb, opt  );
read_symbolic_expression( symb, val  );

if pass = 6 then
begin
case opt of
1: 
begin
codelist := val = 1;
errorreporting := errorreporting or ( val = 1 );
end;

2: test := val = 1;

3: if not codesize_met and (current_segment = 1) and (current_offset < min_buffer_size (* i.e. before code *)) then 
begin
if val > codebuffersize then
val := codebuffersize;
if val < min_buffer_size then
val := min_buffer_size;
segment_size := val div 2 * 2 - 1;
codesize_met := true;
end;

4: print_code := val = 1;

5: errorreporting := errorreporting or (val = 1);

7: dump_nametable := val = 1;

9: if not spacing_met and (current_segment = 1) 
and (current_offset < min_buffer_size (* i.e. before code *)) then
begin
if val > codebuffersize then
val := codebuffersize;
if val < 4 then
val := 4;
line_spacing := val;
(* adjust the line table head record *)
code_buffer [ head_of_lines + linrec_spacing_offset ] := 
line_spacing div maxbyte;
code_buffer [ head_of_lines + linrec_spacing_offset + 1 ] :=
line_spacing mod maxbyte;
spacing_met := true;
end;

10: begin
generate_statistics := val >= 1;
if generate_statistics and statistical_version then
begin
survey_option_number := val;
if (val = 2) or (val = 4) then barrier := 0 else barrier := -1;

if survey_option_number > 4 then
(* read options from file 'surveyspec'  *)
begin

new( stat_opcodes );

new( stat_unsat_refs );

for step := 0 to lastcode do
with stat_opcodes ^ [ step ] do
begin
trail_head [ 1 ] . first_descriptor := nil;
trail_head [ 2 ] . first_descriptor := nil;
end; (* with *)
for step := nill to maxunsatrefs do
stat_unsat_refs ^ [ step ] := nil;

open ( input, 'surveyspec');
reset ( input );

while get_next_token <> symbol do; (* skip *)
while not eof(input) do
begin
current_code := find_code;
if current_code <> no_op_ix then
begin
read_symbolic_expression( dummyname, paramno );
if (paramno > 0) and (paramno <= 2 ) then
with stat_opcodes ^ [ current_code ] do
begin
new( trail_head [ paramno ] . first_descriptor );

read_symbolic_expression ( dummyname, no_of_intervals );
with trail_head [ paramno ] do
begin
number_of_intervals := no_of_intervals;
current_interval := first_descriptor;
end;
for step := 1 to no_of_intervals do
begin
read_symbolic_expression( dummyname, limit);

with current_interval ^  do
begin
upper_limit := limit;
interval_count := 0;
new( next_descriptor );
current_interval := next_descriptor;
end; (* with current... *)

end; (* for ... *)

with current_interval ^ do
(* last in chain *)
begin
next_descriptor := nil;
upper_limit := word_max;
interval_count := 0;
end;

end; (* with stat_opcodes ^ *)

end (* code <> noop  *)

else

begin (* current token is 'bar'  no check !!!!! *)
(* if option value = 9 then the barrier is the number of codes to output *)
read_symbolic_expression( dummyname, limit );
if (survey_option_number >= 6) and (survey_option_number <> 7) then
barrier := limit; (* option 6, 8, and 9 *)

end;

token := get_next_token;

end; (* while not eof  *)

close ( input ); (* unstack surveyspec  *)
lineindex := linelength; (* set well defined position *)
line [ lineindex ] := '.';  (* end of option !!!!! *)

end; (* option > 4 *)

end; (* generate statistics *)

end; (* 10 *)


11: if not lineinfo_met and
 (current_segment = 1) and (current_offset < min_buffer_size) 
and (val <> 1) then
begin
lineinfo_met := true;
generate_line_info := false;
(* return the line table head *)
current_offset := 0;
start_of_line_table := 0; (* do not reserve room for line tables *)
internal_link_list := nill; (* forget the names in connection with line info *)
rem_buffer_size := segment_size + 1 - longjump_size;
end;

12: if (val = 0) and (current_segment = 1) and 
(current_offset <= length_of_descriptor + 1) then
program_kind := open_routine;

end (* case *)
otherwise
begin
if (opt >= 81) and (opt <= 86) then
begin
codefilename [ 2 * ( opt - 81 ) + 1 ] := chr ( val div maxbyte );
codefilename [ 2 * ( opt - 81 ) + 2 ] := chr ( val mod maxbyte );
end;
end;
if (opt = 3) or (opt = 9) then
begin
(* adjust the mutual dependent varables *)
line_table_size := (segment_size + 1 - fix_line_table_part) div (line_spacing + 1) + fix_line_table_part;
line_table_size := (line_table_size + 1) div 2 * 2; (* integral number of words *)
(* recompute free buffer size: *)
rem_buffer_size := segment_size + 1 - current_offset - longjump_size;
if generate_line_info then
begin

(* update the line table head record *)
code_buffer [ head_of_lines + linrec_segment_offset ] :=
(segment_size + 1 - line_table_size) div maxbyte;
code_buffer [ head_of_lines + linrec_segment_offset + 1 ] :=
(segment_size + 1 - line_table_size) mod maxbyte;

start_of_line_table := segment_size + 1 - line_table_size;
prepare_linetable;

(* update the line table with information for the code buffer used until now *)
for step := 0 to (current_offset - 1) div line_spacing do
begin
code_buffer [ next_line_table_entry ] := 0; (* no lines processed yet *)
next_line_table_entry := next_line_table_entry + 1;
end;

end;
end;
end
else
if pass = 0 then
begin (* version number of former pass *)
(* note pass5 version number must be greater than 1 *)
case opt of

5: if val < demanded_pass5_version then
begin
writeln(' compiler inconsistency .... ');
goto 9999;
end; (* test of pass5 version *)

end (* case *)

otherwise ;
end; (* pass = 0   ... *)




until line [ lineindex ] = '.';

token := get_next_token;

until token <> option ;

end; (* read option *)

procedure read_environment;
(* read standard definitions from file: 'lambdaenv'
the names are declared on level = 0  *)
(* syntax:

.   anything ---> b. ---> declarations --> definitions --> eof -->

.  declarations:  see procedure read_declaration

.  definitions:
.  --->-------------------------->---->
.     !                           !
.     !<--- constant definition <-!
.     !                           !
.     !<--- option <--------------!
.     !                           !
.     !<--- comment <-------------!

.  constant definition:
.  --> identifier --> = --> symbolic expression -->

.  symbolic expression: see procedure read_symbolic_expression

*)
var
chain : name_ix;


begin
open(input,'lambdaenv'); reset(input);

while get_next_token <> blockbegin do
(* skip , no check for eof !!!!! *);

read_declaration; (* includes: token := get_next_token *)

while not eof(input) do

case token of

constdef: update_symbol;

option: read_options;

comment: token := get_next_token; (* skip *)

end (* case *)

otherwise

begin
markerror( 15 ); (* error in lambda environment *)
token := get_next_token;
end;

chain := levelstack [ current_level ];
(* check that all names from environment are defined *)
while chain <> nill do
with names [ chain ] do
begin
if kind = undefined then
markerror1( 11, namepart ); (* undefined constant *)
chain := next_name;
end;


close( input );

end; (* read environment *)






procedure handle_descriptor_block;

(* process the descriptorblocks according to the input
descriptions and the internal link information gathered during the
code processing *)

var
former, link, link1, symb, no_of_int_links : name_ix;
noofinternallinks,
noofparams, descrelem, step, step1, nooflinks, descrptr : integer;
chain : unsatref_ix;


procedure outword( word : integer );

const
adjustment = 65536; (* 2**16 *)

begin
if rem_buffer_size < 2 then
begin
emitcode(false); (* empty the buffer without exit-jump *)
(* do not reserve room for an exit jump *)
rem_buffer_size := rem_buffer_size + longjump_size;
(* do not produce more line tables *)
start_of_line_table := 0;
end;

rem_buffer_size := rem_buffer_size - 2;
if word < 0 then
word := word + adjustment; (* 16 bit positive representation *)
code_buffer [ current_offset ] := word div maxbyte;
code_buffer [ current_offset + 1 ] := word mod maxbyte;

current_offset := current_offset + 2;

end;  (* local out word *)


begin
if test then outtest('handle_descriptor_blocks');

(* fill in descr1 as follows:
   entry          contents

    0      length of descriptor part 1
    1      no of program pages
    2      size of a program page
3      no of bytes on last page
4      kind of object program
5-10   name of object program
11-12  entry point
13-14  exception point
15-16  exit point
17     exception mask
18     appetite
19     no of parameters
20-21  type, size of first param
22-23  type, size of second param
....
....
....
*)


descr1 [ 1 ] := current_segment; (* number of codeblocks *)
descr1 [ 2 ] := segment_size + 1;
descr1 [ 3 ] := current_offset;
while get_next_token <> symbol do (* skip until program name *) ;


for step := lastchar + 1 to alfalength do
chbuf [ step ] := ' ';
descrptr := 4;
for step := 1 to alfalength do
begin
if odd(step) then
begin
(* next word *)
descrptr := descrptr + 1;
descr1 [ descrptr ] := 0;
end;
descr1 [ descrptr ] := descr1 [ descrptr ] * 256 + ord( chbuf [ step ] );
(* remember the name for survey information *)
procname [ step ] := chbuf [ step ];

end; (* program name *)

(* kind of object program *)
read_symbolic_expression( symb, descrelem );
descr1 [ 4 ] := descrelem;

(* entry point, exception point, exit point *)
descrptr := 10;
for step := 1 to 3 do
begin
read_symbolic_expression( symb, descrelem );
with names [ symb ] do
begin
descrptr := descrptr + 1;
descr1 [ descrptr ] := def_segment;
descrptr := descrptr + 1;
descr1 [ descrptr ] := def_offset;
end; (* with .. *)

end; (* for ... *)

(* exception mask *)
read_symbolic_expression( symb, descr1 [ 17 ] );

(* appetite *)
read_symbolic_expression( symb, descr1 [ 18 ] );


(* parameter list *)

read_symbolic_expression( symb, noofparams );
descrptr := 19;
if descrptr + noofparams * 2 > descr1_size then
stop('descr1_size', 'handle descriptor');
descr1 [ descrptr ] := noofparams;

for step := 1 to noofparams * 2 do
(* each parameter consist of type and  size  *)
begin
read_symbolic_expression( symb, descrelem );
descrptr := descrptr + 1;
descr1 [ descrptr ] := descrelem;
end; (* for ... *)

descr1 [ 0 ] := (descrptr + 1) * 2; (* remember the length of part1  *)

(* end of part 1 *)


(* now the external linking table must be produced and put into
the descriptorblock 
note: the descriptor block starts at a word boundary *)
if odd(current_offset) then outbyte(0);
rem_buffer_size := rem_buffer_size + longjump_size;
(* room for exit jump is not needed *)


(* read the external linking table and
substitute the symbols by the associated addresses *)

read_symbolic_expression( symb, nooflinks );

outword( nooflinks ); (* number of external link entries *)

for step := 1 to nooflinks do
begin

token := get_next_token; (* read the name *)
for step1 := lastchar + 1 to alfalength do
chbuf [ step1 ] := ' ';


for step1 := 1 to alfalength div 2 do
outword( ord( chbuf [ 2 * step1 - 1 ] ) * maxbyte +
ord( chbuf [ 2 * step1 ] ) );


(* parameter list *)

read_symbolic_expression( symb, noofparams );
outword( noofparams );

for step1 := 1 to 2 * noofparams do
begin
read_symbolic_expression( symb, descrelem );
outword( descrelem );
end; (* end of parameter list *)


(* uses list *)

read_symbolic_expression( symb, noofparams );
outword( noofparams ); (* number of uses *)

(* read the internal name and output the use chain *)
read_symbolic_expression ( symb, descrelem );
with names [ symb ] do
begin
chain := use_chain;
use_chain := nill;
end;



for step1 := 1 to noofparams do
begin

if chain = nill then
markerror1 ( 12, names [ symb ] . namepart ); (* trouble with descriptor block *)

with unsatisfied_refs [ chain ] do
begin
outword( use_segment );
outword( use_offset );
remove_unsatisfied_node( chain );
end;


end; (* uses list *)

if chain <> nill then 
markerror1 ( 12, names [ symb ] . namepart ); (* trouble with descriptor block *)

end; (* for .. to nooflinks  *)

unstack_level;


no_of_int_links := getnamenode;
(* make a name node to describe the constant: number of internal links *)
with names [ no_of_int_links ] do
begin
use_chain := add_unsatisfied_node(use_chain, false, 2, 2);
end;

outword( 0 ); (* room for the number of internal links *)

noofinternallinks := 0;

link := internal_link_list;
former := nill;

while link <> nill do
with names [ link ] do
begin
if (kind = label_def) and (use_chain <> nill) then
begin
chain := use_chain;

while chain <> nill do
with unsatisfied_refs [ chain ] do
begin

noofinternallinks := noofinternallinks + 1; 
outword( use_segment );
outword( use_offset );
outword( def_segment );
outword( def_offset );

remove_unsatisfied_node( chain );


end; (* while chain ... *)

end; (* if kind = label_def *)

link1 := next_name;
if (kind = label_def) then
begin
returnname(link);
if former = nill then
internal_link_list := link1
else
names [ former ] . next_name := link1;
end (* remove the name node *)
else
former := link;
link := link1;

end; (* while link ... *)
with names [ no_of_int_links ] do
begin
def_segment := 1; (* defined *)
def_offset := noofinternallinks;
kind := constant_def;
next_name := internal_link_list;
internal_link_list := no_of_int_links;
end; (* with .. *)



(* end of internal links *)
if current_offset <> 0 then
emitcode(false); (* empty the code buffer *)


end; (* handle descriptor blocks *)






procedure insert_constants;

var
chain, chain1, list, sortlist : unsatref_ix;
const_val, step, codeptr, elem, next_word, next_elem,
next_segment, next_offset : integer;
former, link, next_link : name_ix;



begin
reset(codefile);
if not object_code_file_opened then
begin

open(code, codefilename );
rewrite(code);
object_code_file_opened := true;
end;

(* the number of significant elements of descriptor block part 1
is kept in descr1 [ 0 ]   *)
if print_code then 
begin
page(output); writeln(output, ' descriptor part 1 ');
end;


for step := 0 to descr1 [ 0 ] div 2 - 1 do
begin
write(code, descr1 [ step ] );
if print_code then
write_hex_descr(descr1 [ step ] );
end;
if print_code then
begin
no_of_elems_in_line := elems_per_line; 
writeln(output, nl, nl);
end;



(* now, make a sorted list of constant uses *)

unsatisfied_refs [ nill ] . use_segment := current_segment + 1; (* stop mark *)

sortlist := nill;

link := internal_link_list;

while link <> nill do
with names [ link ] do
begin
if kind = constant_def then
begin
chain := use_chain;
while chain <> nill do
begin

(* insert chain into the sorted list starting at sortlist *)

list := sortlist;
former := nill;

with unsatisfied_refs [ chain ] do
begin
while (use_segment > unsatisfied_refs [ list ] . use_segment)
or (( use_segment = unsatisfied_refs [ list ] . use_segment) 
and (use_offset > unsatisfied_refs [ list ] . use_offset)) do
begin
former := list;
list := unsatisfied_refs [ list ] . next_ref;
end;

(* now insert 'chain' between 'former' and 'list' *)
if size = 1 then
codeptr := maxbyte - 1
else 
codeptr := word_max ;
if def_offset < 0 then
size := (def_offset + codeptr + 1) mod (codeptr + 1)
else
size := (def_offset) mod ( codeptr + 1 );
(* the size is known to be 2 bytes, and 'size' may be used to hold the
constant value, i.e. the name node is not needed any more *)

if former <> nill then
unsatisfied_refs [ former ] . next_ref := chain
else
sortlist := chain;
chain := next_ref;
next_ref := list;
end; (* with unsatisfied_refs ...  *)

end; (* while chain <> nill *)

end; (*  with .. if constant_def  *)

next_link := next_name;
returnname( link );
link := next_link;

end; (* while *)


(* now copy the code and insert the constants *)
if test then
begin (* output the sorted list of constants *)
chain := sortlist;
while chain <> nill do
with unsatisfied_refs [ chain ] do
begin
writeln('next:', next_ref, ' use:', use_segment, use_offset, ' value=', size);
chain := next_ref;
end; (* with *)
end;

current_segment := 1; 
current_offset := 0;


if test then outtest('start of constant insertion ');

while sortlist <> nill do
with unsatisfied_refs [ sortlist ] do
begin
next_segment := use_segment;
next_offset := use_offset - 1; (* first byte of the constant *)

(* copy until (next_segment, next_offset)  *)

while (current_segment < next_segment) or
((current_segment = next_segment) and (current_offset < next_offset) ) do
begin
(* inline procedure get_byte:
let next_elem be the value (0..255) of next
byte from codefile  *)
if not odd(current_offset) then
begin
read(codefile, elem);
next_elem := elem div maxbyte;
end
else
next_elem := elem mod maxbyte;


(* inline procedure put_byte:
if word boundary then emit two bytes
else let next_word be the left hand byte
of the next word to copy *)
if odd(current_offset) then
begin
write(code, next_word + next_elem);
if print_code then
begin
write_hex_addr( current_offset - 1);
write_hex( next_word + next_elem , 4);
end; (* print code *)
end
else
next_word := next_elem * maxbyte;

if current_offset = segment_size then
begin
current_segment := current_segment + 1;
current_offset := 0;
end
else
current_offset := current_offset + 1;

end; (* while .... *)

(* now the next constant may be added to the next two bytes *)
(* note: constants are always seen as 2 consecutive bytes,
insertion of small constants are done just as long constants, i.e.
add the value to the contents already put into the code *)

(* special version of : 2*get_byte, add element, 2*put_byte *)
if not odd(current_offset) then
begin
read(codefile, next_elem);
if statistical_version then
const_val := next_elem + size;
write(code, next_elem + size);
if print_code then
begin
write_hex_addr( current_offset );
write_hex( next_elem + size, 4);
end; (* print code *)
end
else
begin
next_elem := (elem mod maxbyte) * maxbyte;
read(codefile, elem);
next_elem := next_elem + elem div maxbyte + size;
if statistical_version then
const_val := next_elem;
write(code, next_word + next_elem div maxbyte);
if print_code then
begin
write_hex_addr( current_offset - 1);
write_hex( next_word + (next_elem div maxbyte) , 4 );
end; (* print code *)
next_word := (next_elem mod maxbyte ) * maxbyte;
next_elem := elem mod maxbyte;
end; (* 2*get, add, 2*put *)

if statistical_version then
if generate_statistics and (survey_option_number > 4)
and (survey_option_number < 9) then
if stat_unsat_refs ^ [ sortlist ] <> nil then
begin
if const_val >= (- word_min ) then (* extend sign *)
const_val := const_val - word_max - 1;

current_interval := stat_unsat_refs ^ [ sortlist ] ;

while const_val > current_interval ^ . upper_limit do
current_interval := current_interval ^ . next_descriptor;

with current_interval ^ do
interval_count := interval_count + 1 ;

end; (* statistical version *)


if current_offset = segment_size - 1 then
begin
current_segment := current_segment + 1;
current_offset := 0;
end
else
current_offset := current_offset + 2;
if test then writeln('where:', current_segment, current_offset, ' value=', size);

remove_unsatisfied_node( sortlist );


end; (* with unsatisfied_refs .... *)

if test then outtest('end of constant insertion');

(* copy the remaining code and descriptor part 2 *)
(* since the last inserted constant is the number of internal links, i.e.
the first word of the descriptor part 2, we know for sure that the rest
of the code is aligned and copying can be done wordwise*)

if print_code then
begin
writeln(output, nl, nl, ' descriptor part 2 ');
no_of_elems_in_line := elems_per_line;
end;


while not eof(codefile) do
begin (* word copying !! *)
(* get word *)
read (codefile, elem);

(* put word *)
write(code, elem);

if print_code then
write_hex_descr( elem );

end;







end; (* insert constants *)


\f


(******************************************************************)
(******************************************************************)
(***************       main program of pass6 **********************)
(******************************************************************)
(******************************************************************)



begin

initialization;

init_between_code_blocks;


read_environment;

  readcall;  
if test then writeln(output, cur_date, cur_time, version : 30, nl );

token := get_next_token;

while token <> endprogram do
begin

if generate_line_info then
emit_start_of_line_table;

while token <> blockbegin do    (*  ---->------------> start block --->  *)
  case token of                 (*      !            !                  *)
    source_line_number : handle_line; (*!<-- nl <----!                  *)
    comment : token := get_next_token;(*!            !                  *)
    option : read_options;      (*      !<- option <--                  *)
endprogram: goto 9998;  (* no more sources *)
end (* case *)
otherwise
begin
markerror( 16 ); (* syntax error *)
token := get_next_token ;   
end;


read_declaration;    (* start block *)


while token = source_line_number do handle_line;

if token = option then
read_options;      (* maybe option( open routine )    *)

if program_kind = closed_routine then
begin

while token <> startdescr do

case token of

blockbegin : read_declaration;

blockend   : unstack_level;

constbegin : handle_constant;

line_table  : handle_linetable;

source_line_number : handle_line;

labeldef   : update_symbol;

constdef   : update_symbol;

comment    : (* do nothing *) token := get_next_token;

symbol     : (* must be an op_code *) handle_code;

option     : read_options;

other:
begin
if eof(input) then
begin
markerror( 13 ) ; (* premature end of file *)
token := startdescr;  (* exit code handling *)
end;
end; (* other *)


end; (* case *)


(* prepare internal linking of short jumps out of the segment *)
fill_in_jumps;

if generate_line_info then
begin

(* move the last line table to end-of-code *)

if odd(current_offset) then outbyte(0);
if current_offset <> start_of_line_table then
begin
help := current_offset;
for step := start_of_line_table to next_line_table_entry - 1 do
begin
code_buffer [ current_offset ] := code_buffer [ step ];
current_offset := current_offset + 1;
end;
start_of_line_table := help;
next_line_table_entry := current_offset;

(* initialize current line record before the internal linking is performed *)
with names [ current_line_record ] do
begin
def_segment := current_segment;
def_offset := start_of_line_table;
kind := label_def;

(* prepare add_unsatisfied_node ... *)
current_offset := start_of_line_table;
(* let the successor of last line record be itself *)
use_chain := add_unsatisfied_node ( use_chain, false, 0, 4 );

end;

end;
(* adjust current offset to be first byte after the line table *)
current_offset := next_line_table_entry div 2 * 2 + 2; (* start of next word *)

last_page := true;

(* in case of alignment rem_buffer_size is not correct, therefore *)
rem_buffer_size := segment_size + 1 - current_offset - longjump_size;


(* initialize the constants length_of_last_segment and last_line_number *)

with names [ length_of_last_segment ] do
begin
def_segment := 1; (* defined *)
def_offset  := start_of_line_table;
kind := constant_def;
next_name := internal_link_list;
internal_link_list := length_of_last_segment;
end;

with names [ last_line_number ] do
begin
def_segment := 1; (* defined *)
def_offset  := current_source_line;
kind := constant_def;
next_name := internal_link_list;
internal_link_list := last_line_number;
end;

end; (* line table handling *)

end (* closed routine or process *)
else
begin
(* open routine *)
(* room for jump to next page and a line table is not needed *)
rem_buffer_size := rem_buffer_size + longjump_size + line_table_size;
start_of_line_table := 0; (* emitcode will not reserve room for linetables *)
while token <> startdescr do

case token of

option: read_options;

comment,
source_line_number: begin
(* skip the line *)
lineindex := linelength;
token := get_next_token;
end;

other: begin
markerror( 13 ) ;  (* premature end of code *)
token := startdescr; (* force exit of  while  <> startdescr ... *)
end;

end (* case *)

otherwise

begin
if token = symbol then
begin
check_open_code := find_code ;   (* check legal opcode *)
lineindex := linelength; (* skip paramerters and comments *)
end
else
if (token = blockbegin) or (token = constdef) then
lineindex := linelength; (* skip the remaining part of the line,
it is not checked if the declaration is terminated correct *)
if not printed then
begin
printed := true;
line [ linelength + 1 ] := ';';
(* always an even number of characters per line *)
step := -1;
repeat
step :=  step + 2;
if rem_buffer_size < 2 then
begin
emitcode(false);
rem_buffer_size := rem_buffer_size + longjump_size
end;
rem_buffer_size := rem_buffer_size - 2;
if line [ step - 1 ] = ' ' then  (* nb line [ 0 ] = ' '  *)
 begin (* state :  after space(s) *)
while line [ step ] = ' ' do step := step + 1; (* skip *)
if line [ step ] = ';' then goto 9997; (* drop trailing blanks *)
end
else
if line [ step ] = ' ' then
(* state : start of space(s)  *)
begin
while line [ step + 1 ] = ' ' do step := step + 1; (* skip *)
if line [ step + 1 ] = ';' then (* drop trailing blanks *)
goto 9997; (* end of line action, buffer room has been reserved *)
end;
outword( ord( line [ step  ] ) * maxbyte +
ord( line [ step + 1 ] ) );
until (line [ step + 1 ] = ';') or (line [ step + 2 ] = ';') ;


if rem_buffer_size < 2 then
begin
emitcode(false);
rem_buffer_size := rem_buffer_size + longjump_size;
end;

rem_buffer_size := rem_buffer_size - 2;
9997: outword( ord(' ') * maxbyte + ord( nl ) );
end; (* copy line *)

token := get_next_token;

end; (* otherwise *)


end; (* open routines *)

handle_descriptor_block;

insert_constants;
init_between_code_blocks; (* prepare next code block  *)

while token = source_line_number do handle_line;

end;   (* while token <> endprogram *)
9998:  (* no more input modules, terminate pass6 *)

if codelist and not printed then printline; (* output the last line *)



if generate_statistics then output_statistics;


writeln(output, nl,' code: ', descr1 [ 1 ] - 1 : 1, ' . ', descr1 [ 3 ] : 1,
'  = ', ( descr1 [ 1 ] - 1 ) * (segment_size + 1) + descr1 [ 3 ] : 1, ' bytes');
9999: (* exit label, used in case of fatal errors *)




if errorcount > 0 then
printerrors
else
writeln(output, nl, nl, 'end of PASCAL80 compilation ');


end.
«eof»
DataMuseum.dk

RC3500

⟦1d2478251⟧ TextFileVerbose

Derivation

TextFileVerbose
