|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 55907 (0xda63)
Types: TextFile
Names: »P6INIT.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P6INIT.PAS«
\r
const\r
version= 'REAL-TIME PASCAL, pass6, version 90.03.01';\r
pass6_version = 1001; (* revision * 100 + subversion *)\r
compiler_version = 3*8192 (* SW2103 *) + 1*256 + 11; (* compiler version*)\r
demanded_pass5_version = 100; (* the least allowed pass5 version number *)\r
\r
hash_function_test = false; (* conditional print of hash function collisions *)\r
statistical_version = true; (* conditional code !!! *)\r
blank = ' ';\r
min_buffer_size = 30;\r
default_buffer_size = 512; (* default size of code segment *)\r
codebuffersize = 65520; (* max size of code segment *)\r
length_of_descriptor = 16; (* length of name table head *)\r
\r
default_line_table_spacing = 52; (* i.e. a line record is generated for groups of 26 bytes of code *)\r
fix_line_table_part = 7; (* 3 bytes for a chain to the next table\r
+ 2 bytes for a start line number\r
+ 2 bytes for first and last record *)\r
max_line = 255; (* line records are numbers inside (0..255) *)\r
namelength = 6; (* number of significant characters of a name *)\r
chbufmax = 15; (* maximum number of characters of a word read *)\r
nill = 0;\r
maxlinelength = 200; (* maximum number of characters in one line *)\r
higherror = 16; (* number of error messages *)\r
\r
maxbyte = 256;\r
bytesize = 1; (*number of bytes for a byte*)\r
wordsize = 2; (*number of bytes for a word*)\r
addrsize = 3; (* number of bytes for a long address *)\r
longjump_size = 4; (* number of bytes for a long jump *)\r
\r
max_code_number = 255;\r
\r
hash1 = 14; hash2 = 23; hash3 = 256;\r
(* hash function used for instruction name table is:\r
hashvalue:= abs( name(1,2) div hash1 + name(3,4) div hash2) mod hash3;\r
note: hash3 <= max_code_number !! *)\r
\r
max_intervals = 90; (* intervals for ais parameters *)\r
\r
bytes_pr_word = 2; (* number of bytes packed into one word on the code file *)\r
\r
max_no_of_trailers = 2;\r
\r
descr1_size = 82; (*maximum length of descriptor part 1,\r
fixed part: 0..21 (22 words) + 2 words per parameter (max 30 parameters) *)\r
\r
elems_per_line = 16; (* number of code words per line (option print.yes) *)\r
\r
\r
type\r
\r
namestring = packed array [ 1 .. namelength ] of char;\r
name_ptr = ^ namenodes;\r
unsatref_ptr = ^ unsatrefnode;\r
interval_index = 0 .. max_intervals;\r
code_ix = 0 .. codebuffersize;\r
chbuf_ix = 0 .. chbufmax;\r
\r
universal_ptr = ^ integer;\r
\r
\r
t_buffer= packed array [ code_ix ] of byte;\r
t_buf_ptr= ^ t_buffer;\r
\r
symbol_kinds = (label_def, constant_def, undefined);\r
\r
namenodes = record\r
namepart : namestring;\r
def_segment : integer;\r
def_offset : integer;\r
next_name : name_ptr;\r
use_chain : unsatref_ptr;\r
kind : symbol_kinds;\r
end;\r
\r
unsatrefnode = record\r
next_ref : unsatref_ptr;\r
ic_relative : boolean; (* tells if the opcode uses ic-relative addressing *)\r
use_segment : integer;\r
use_offset : integer;\r
size : integer;\r
end;\r
\r
level_ptr= ^ level_node;\r
level_node= record\r
former_level: level_ptr;\r
level_list: name_ptr;\r
end;\r
\r
label_list_ptr= ^ label_list_node;\r
label_list_node= record\r
next_label: label_list_ptr;\r
label_name: name_ptr;\r
end;\r
\r
prog_kinds = (closed_routine, open_routine );\r
\r
tokens = ( blockbegin, blockend, constbegin, endprogram, labeldef, startdescr,\r
constdef, comment, symbol, option, source_line_number, line_table, other );\r
\r
coderange = 0 .. max_code_number;\r
\r
opcode_kinds = (jump_long, jump_short,\r
first_of_pair, second_of_pair, addr_neutral,negative_short );\r
\r
\r
opcode_node = record\r
namepart : namestring;\r
opcodeval : integer;\r
(* number of bytes for the operands *)\r
trailers : array [ 1 .. max_no_of_trailers ] of integer;\r
total_length : integer; (* total number of bytes to reserve for this code *)\r
opcode_kind : opcode_kinds;\r
exc_time, (* execution time in 0.1 micro secs *)\r
use_count : integer;\r
end;\r
\r
line_ix = 0 .. maxlinelength;\r
line_type= array [ line_ix ] of char;\r
\r
jump_table_ptr = ^ jump_information;\r
jump_information= record\r
next_jump : jump_table_ptr;\r
jump_from : code_ix;\r
destination : name_ptr;\r
end;\r
\r
\r
dep_chain_ptr = ^ dep_chain_element;\r
\r
dep_chain_element = record\r
next_dep : dep_chain_ptr;\r
dependent,\r
dependence: name_ptr;\r
end;\r
\r
\r
\r
\r
var\r
length_of_current_code, (* used in printline to adjust current offset *)\r
end_of_code,\r
linenumber, (* assembler list line number *)\r
current_source_line, (* pascal80 line number *)\r
line_add, (* number of source lines met since last line table record *)\r
coded_time, (* compiler version * 64 * 32 + hour*64 + minute *)\r
coded_date, (* (year - 1900) * (16 * 32) + month * 32 + day *)\r
source_date, (* date of source text, found as option values\r
pass0, 81..85, (year, month, day, hour, minute *)\r
source_time, (* time of source text, hour and minute *)\r
users_version, (* user defined version number, saved in descr part one *)\r
errorcount : integer;\r
sourcefilename,\r
cur_date, cur_time : alfa;\r
start_clock: datetime;\r
\r
code, (* file for the resulting code *)\r
codefile : file; (* file for temporary code *)\r
code_buffer_ptr: t_buf_ptr;\r
program_kind : prog_kinds;\r
\r
\r
token : tokens;\r
\r
nil_jump_ptr,\r
current_jump_ptr : jump_table_ptr;\r
\r
nil_label_ptr, (* stop element of allocated label list nodes *)\r
cur_lab_ptr : label_list_ptr; (* list of labels associated with current instruction *)\r
\r
current_segment : integer;\r
current_offset : code_ix; (* first free byte in the code buffer, i.e. the\r
address to associate with a label when the label is defined\r
(unless a segment shift is needed) *)\r
current_name : namestring;\r
\r
chbuf : array [ chbuf_ix ] of char; (* current word to be handled *)\r
lastchar : chbuf_ix; (* length of current word *)\r
\r
help,\r
step : integer; (* help variable, used in for-statements *)\r
\r
\r
line_table_descriptor,\r
current_line_record,\r
last_line_number,\r
length_of_last_segment,\r
internal_link_list,\r
nil_name,\r
namefreelist : name_ptr;\r
\r
unsatisfied_nil,\r
unsatref_freelist : unsatref_ptr;\r
\r
errorindex,\r
lineindex,\r
linelength : line_ix;\r
line: line_type; (* line (0)=sp !!! *)\r
errormarks : packed array [ 0 .. higherror ] of boolean;\r
object_code_file_opened,\r
last_page,\r
codesize_met, (* option code size met, only the first is significant *)\r
spacing_met, (* option spacing met, - - - - *)\r
lineinfo_met,\r
generate_line_info,(* option lineinfo (10) *)\r
dump_nametable, (* option nametable, default is nametable.no *)\r
print_code, (* option print, default is print.no *)\r
errorreporting, (* option errormess, default is errormess.no *)\r
preserve_option, (* option preserve, default is no *)\r
test, (* option test, default is test.no *)\r
printed,\r
codelist : boolean; (* option list, default is list.no *)\r
\r
nil_level, (* bottom element of level stack *)\r
global_level, (* level of environment *)\r
free_level_list,\r
current_level : level_ptr;\r
\r
dep_chain_start,\r
free_dep_list : dep_chain_ptr;\r
\r
lastcode : integer; (* index of the last defined op-code *)\r
opcodes : array [ coderange ] of opcode_node;\r
check_open_code,\r
\r
longjump,\r
no_op_ix : coderange;\r
\r
ais_codes : packed array [ coderange ] of interval_index;\r
\r
intervals : array [ interval_index ] of packed record\r
ais_code_val : coderange;\r
trailer_nr : 1 .. 2;\r
trailer_size : 0 .. 2; (* number of bytes *)\r
next_interval : interval_index;\r
interval_low, interval_high : integer;\r
end;\r
\r
reserve_max : integer; (* max used code buffer greater than segment_size *)\r
\r
rem_buffer_size, (* remaining code buffer size *)\r
last_to_emit, (* offset of last byte of the last page from code_file (the temporary file) *)\r
start_of_line_table,\r
next_line_table_entry,\r
line_table_size, (* room reserved for the line information *)\r
line_spacing, (* distance in bytes between dump of line information *)\r
segment_size : code_ix; (* number of the last byte in a segment,\r
note: (segment_size + 1) mod bytes_pr_word must be 0 *)\r
\r
code_buffer : t_buf_ptr;\r
\r
descr1 : array [ 0 .. descr1_size ] of integer;\r
(* used for part 1 of the descriptor block *)\r
\r
systemparamno : integer; (* current fp-parameter *)\r
codefilename, (* external name of the resulting code file *)\r
procname : alfa; (* name of the process *)\r
\r
\r
(* variables for statistical use *)\r
survey_name_nodes, (* count number of allocated namenodes *)\r
survey_dependence_nodes, (* count number of allocated dep_chain_elements *)\r
survey_jump_nodes, (* count number of allocated jump_information nodes *)\r
survey_cur_label_nodes, (* count number of allocated label_list_nodes *)\r
survey_unsat_nodes, (* count number of allocated unsatrefnodes *)\r
survey_level_nodes, (* count number of allocated level_nodes *)\r
survey_greatest_const, (* size of most extensive constant in the code *)\r
barrier,\r
current_time, (* execution time for current code, -1 if not code line *)\r
total_time, (* execution time accumulator *)\r
survey_option_number : integer;\r
short_instructions, (* option(13), short, use ais codes *)\r
survey_info, (* survey.yes/no, if yes then dump resource statistics *)\r
generate_statistics : boolean; (* option (10) statistics *)\r
\r
(* end of variables for statistical use *)\r
\r
\r
no_of_elems_in_line : integer; (* current number of emited code words in this line *)\r
\r
\r
procedure printerrors;\r
var\r
i, current_text_no : integer;\r
ch : char;\r
\r
begin\r
if errorcount <> 0 then\r
begin\r
writeln(output, ' number of errors : ', errorcount : 4);\r
writeln(output); writeln(output);\r
writeln('Error description');\r
assign( input, concat(rtp35_pathname, i_passx_err2name));\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(rtp35_pathname, i_passx_err2name));\r
end;\r
(*$I+*)\r
repeat\r
repeat\r
readln(input);\r
read(input, ch);\r
until ch = '6';\r
readln(input, i );\r
until i = 666;\r
current_text_no:= -1;\r
\r
for i:= 1 to higherror do\r
if errormarks [ i ] then\r
begin\r
\r
(* find the text *)\r
while i > current_text_no do\r
begin\r
if not eof(input) then readln(input);\r
if not eof(input) then read(current_text_no)\r
else current_text_no:= higherror + 1;\r
end;\r
\r
write(output, i : 4, ': ');\r
if i <> current_text_no then\r
write(output, ' ( no text ) ' )\r
else\r
while not eoln(input) do\r
begin\r
read(ch); write(output, ch);\r
end;\r
writeln(output);\r
end; (* for i ... *)\r
close(input);\r
\r
end\r
else\r
if (reserve_max = 0) and not errormarks[0] then\r
begin\r
errorcount := 1;\r
writeln(output,' Compiler error detected ');\r
writeln(output, ' please inform the compiler group' );\r
end;\r
(*$R-*)\r
if reserve_max <> 0 then\r
begin\r
errorcount := 1;\r
i:= reserve_max + line_table_size + longjump_size;\r
i:= i + ( i - segment_size + line_spacing ) div line_spacing;\r
(*$R+*)\r
writeln(output, 'Error in compilation');\r
writeln(' Use option codesize, with at least ',\r
i : 1, ' as page size');\r
end;\r
\r
if errorcount <> 0 then\r
begin\r
writeln(output);\r
writeln(output,'Binary output file deleted');\r
erase(code);\r
end;\r
\r
rtphalt( false (* terminate program with ok.no *) );\r
\r
end;\r
\r
procedure pass6(var code_buffer: t_buffer);\r
label 9997, 9998;\r
\r
\r
procedure write_hex_addr( address : code_ix);\r
begin\r
if no_of_elems_in_line = elems_per_line then\r
begin\r
writeln(output);\r
no_of_elems_in_line:= 0;\r
write_hex( current_segment , 4); write('.');\r
write_hex( address , 4); write(': ');\r
end\r
else\r
write(' ' : 2);\r
no_of_elems_in_line:= no_of_elems_in_line + 1;\r
end; (* write hex address *)\r
\r
procedure write_hex_descr( word : integer );\r
begin\r
if no_of_elems_in_line = elems_per_line then\r
begin\r
writeln(output);\r
no_of_elems_in_line:= 0;\r
write(' ':12);\r
end\r
else\r
write(' ' : 2);\r
\r
no_of_elems_in_line:= no_of_elems_in_line + 1;\r
write_hex( word , 4 );\r
end;\r
\r
\r
\r
\r
\r
procedure outtest( textstring : string );\r
begin\r
writeln(output, 'outtest called from ', textstring);\r
end;\r
\r
procedure output_names;\r
(* dump the nametable, option nametable.yes *)\r
\r
var\r
level: level_ptr;\r
stop: boolean;\r
local_name : name_ptr;\r
\r
begin\r
(* output all the names declared until now *)\r
writeln;\r
writeln(' name table dump ');\r
writeln;\r
level:= current_level;\r
stop:= false;\r
repeat\r
if level<>nil_level then\r
begin\r
writeln;\r
writeln('level = ', seg(level): 1, ofs(level): 1 );\r
writeln;\r
local_name:= level ^.level_list ;\r
end\r
else\r
begin\r
writeln;\r
writeln('internal links');\r
writeln;\r
local_name:= internal_link_list;\r
stop:= true;\r
end;\r
\r
while local_name <> nil_name do\r
with local_name ^ do\r
begin\r
write(namepart);\r
if kind = label_def then\r
begin\r
write(': ', def_segment, ' ');\r
write_hex(def_offset, 4);\r
end\r
else\r
if kind = constant_def then\r
begin\r
write('=', ' ' : 8);\r
write_hex(def_offset, 4);\r
end\r
else\r
write(' undefined');\r
if test then\r
write('next:', seg(next_name), ofs(next_name),\r
' use:', seg(use_chain), ofs(use_chain));\r
writeln(output);\r
local_name:= next_name;\r
end; (* while .. with *)\r
\r
level:= level^.former_level;\r
until stop; (* until all levels and the internal link list are dumped *)\r
\r
end; (* output name *)\r
\r
\r
\r
procedure prepare_linetable;\r
\r
var\r
step : code_ix;\r
\r
begin\r
for step:= 0 to addrsize - 1 do\r
(* reserve room for an address *)\r
code_buffer [ start_of_line_table + step ]:= 0;\r
\r
code_buffer [ start_of_line_table + addrsize ]:= current_source_line shr 8;\r
code_buffer [ start_of_line_table + addrsize + 1 ]:= current_source_line and 255;\r
\r
(*$R-*)\r
next_line_table_entry:= start_of_line_table + fix_line_table_part - 2;\r
\r
rem_buffer_size:= rem_buffer_size - line_table_size;\r
(*$R+*)\r
end; (* prepare line table *)\r
\r
\r
\r
procedure readcall;\r
(* read the call of pass6 from current input *)\r
const\r
power12=256;\r
equality=6;\r
point=8;\r
list = 'list';\r
yes = 'yes';\r
no = 'no';\r
testout = 'test';\r
codesize = 'codesize';\r
errormess = 'errormess';\r
nametable = 'nametable';\r
lineinfo = 'lineinfo';\r
spacing = 'spacing';\r
print = 'print';\r
preserve = 'preserve';\r
\r
\r
var\r
i,j, int, separator, length : integer;\r
a: alfa;\r
first, default_used : boolean;\r
param : (list_program, filename, code_size, line_info_param, spacing_param, test_gen,\r
preserve_param, error_mess, nametab_param, print_param );\r
\r
\r
procedure checkleftside;\r
begin\r
systemparamno:= 1;\r
if paramread(systemparamno, int, a) div power12 = equality then\r
begin\r
(* left hand side present *)\r
\r
i:= paramread(0, int, codefilename);\r
\r
systemparamno:= systemparamno + 1; (* skip name rtp35022p6 *)\r
end;\r
\r
\r
end; (* checkcall *)\r
\r
\r
\r
procedure error;\r
begin\r
writeln(' ??? error in call of rtp3526 ');\r
rtphalt( false (* terminate program with ok.no *) );\r
end;\r
\r
begin\r
assign_alfa(sourcefilename, o_pass5_codename); (* default name *)\r
default_used := true;\r
checkleftside;\r
\r
\r
\r
j:=paramread(systemparamno,int,a);\r
first:=true;\r
param:= pred(filename); (* param <> filename *)\r
\r
while ((j mod power12) <> 0) and ((j div power12) <> 2)\r
and (param <> filename) do\r
begin\r
separator:=j div power12;\r
length:=j mod power12;\r
\r
if first then\r
begin\r
first:=false;\r
if separator = point then error\r
else\r
if a = list then param:=list_program\r
else if a = testout then param:= test_gen\r
else if a = codesize then param:= code_size\r
else if a = spacing then param:= spacing_param\r
else if a = lineinfo then param:= line_info_param\r
else if a = print then param:= print_param\r
else if a = errormess then param:= error_mess\r
else if a = nametable then param:= nametab_param\r
else if a = preserve then param:= preserve_param\r
else\r
begin\r
param:= filename;\r
sourcefilename:= a;\r
default_used := false;\r
end;\r
end\r
else\r
begin\r
first:=true;\r
if (separator <> point) and (param <> filename) then error\r
else\r
case param of\r
list_program:if length <> 10 then error\r
else\r
if (a = yes) or (a = no) then\r
begin\r
codelist:= a=yes;\r
errorreporting:= errorreporting or (a=yes);\r
end\r
else error;\r
\r
filename: systemparamno:= systemparamno - 1; (* make the next increment dummy *)\r
\r
test_gen: if length <> 10 then error\r
else\r
if (a = yes) or (a = no) then test:= a = yes\r
else error;\r
\r
code_size: if length <> 4 then error\r
else\r
if not codesize_met then\r
begin\r
codesize_met:= true;\r
(*$R-*)\r
segment_size:= (int shl 1) shr 1 - 1;\r
(*$R+*)\r
end;\r
\r
error_mess: if length <> 10 then error\r
else\r
if (a=yes) or (a = no) then\r
errorreporting:= errorreporting or (a = yes)\r
else error;\r
\r
preserve_param: if length<>10 then error\r
else\r
if (a=yes) or (a=no) then\r
preserve_option:= a=yes\r
else\r
error;\r
\r
nametab_param : if length <> 10 then error\r
else\r
if (a = yes) or (a = no) then dump_nametable:= a = yes\r
else error;\r
\r
print_param: if length <> 10 then error\r
else\r
if (a = yes) or ( a = no ) then print_code:= a = yes\r
else error;\r
line_info_param: if length <> 10 then error\r
else\r
if (a=yes) or (a = no) then\r
begin\r
if not lineinfo_met then\r
begin\r
lineinfo_met:= true;\r
generate_line_info:= a = yes;\r
if a <> yes then\r
begin\r
start_of_line_table:= 0;\r
rem_buffer_size:= segment_size + 1 - longjump_size;\r
end;\r
end;\r
end\r
else error;\r
\r
spacing_param : if length <> 4 then error\r
else\r
if not spacing_met then\r
begin\r
spacing_met:= true;\r
line_spacing:= int;\r
(* no check for reasonable result !!!!!!! *)\r
end;\r
\r
\r
end; (* case *)\r
if (param = spacing_param) then\r
begin\r
(* adjust the mutual dependent variables *)\r
(*$R-*)\r
line_table_size:= (segment_size + 1 - fix_line_table_part) div (line_spacing + 1) + fix_line_table_part;\r
line_table_size:= (line_table_size + 1) div 2 * 2; (* integral number of words *)\r
rem_buffer_size:= segment_size + 1 - longjump_size;\r
if rem_buffer_size < min_buffer_size then error;\r
if generate_line_info then\r
begin\r
start_of_line_table:= segment_size + 1 - line_table_size;\r
(*$R+*)\r
prepare_linetable; (* line table set-up *)\r
end;\r
\r
end; (* code size or spacing *)\r
end; (* second *)\r
systemparamno:= systemparamno + 1;\r
if param <> filename then j:=paramread(systemparamno,int,a);\r
end;\r
\r
if default_used then\r
begin\r
assign(input, concat(path2_name,sourcefilename));\r
end else\r
begin\r
assign(input, concat(source_path,sourcefilename));\r
end;\r
settextbuf(input, in_buf_ptr^);\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
if default_used then\r
begin\r
nofile(concat(path2_name, sourcefilename));\r
end else\r
nofile(concat(source_path, sourcefilename));\r
end;\r
(*$I+*)\r
\r
end; (* read call *)\r
\r
\r
\r
procedure output_statistics;\r
begin\r
\r
\r
end; (* output statistics *)\r
\r
\r
\r
procedure printline;\r
var step : integer;\r
\r
begin\r
write(output, linenumber : 5, ' ');\r
if current_time <> -1 then\r
begin\r
write(output, current_time div 10 : 3, '.',\r
current_time mod 10 : 1, word(total_time) div 10:8, ' ' : 3);\r
current_time:= -1;\r
end\r
else (* not code line *)\r
write(output, ' ' : 3 + 1 + 1 + 8 + 3 );\r
\r
write_hex( current_segment, 2); write(output,' ');\r
write_hex( current_offset - length_of_current_code, 4);\r
length_of_current_code:= 0; (* do not adjust non-code lines *)\r
write(': ');\r
for step:= 1 to linelength do\r
write(output, line [ step ] );\r
writeln(output);\r
printed:= true;\r
end; (* print line *)\r
\r
\r
\r
procedure markerror ( no : integer );\r
\r
(* print current line and mark the erroneous token *)\r
var\r
i : integer;\r
\r
begin\r
errorcount:= errorcount + 1;\r
errormarks [ no ]:= true;\r
if errorreporting then\r
begin\r
if not printed or (program_kind = open_routine) then\r
printline;\r
if errorindex = 0 then\r
write(output, '*******************************');\r
for i:= errorindex to lineindex do write(output,' ');\r
write(output,'^', no:1);\r
errorindex:= lineindex + 2;\r
end; (* error report *)\r
end; (* mark error *)\r
\r
\r
\r
procedure markerror1 ( no : integer; errortext : namestring );\r
\r
begin\r
markerror ( no );\r
if test then\r
begin\r
errorindex:= 0;\r
writeln(output);writeln('name is: ', errortext );\r
end;\r
end; (* markerror1 *)\r
\r
\r
\r
\r
\r
procedure stop( constname, calledfrom : alfa );\r
\r
(* fatal error in connection with 'constnam', detected in\r
procedure 'calledfrom', stop the program *)\r
\r
begin\r
markerror(0); (* fatal error *)\r
writeln(output);writeln;\r
writeln('constant ', constname, ' too small');\r
writeln('Source line number = ', current_source_line :1);\r
if test then\r
write(output, ' detected in procedure ', calledfrom);\r
\r
writeln(output);\r
printerrors;\r
\r
end; (* stop *)\r
\r
\r
procedure readline;\r
\r
(* at exit lineindex will denote the last leading space of the line\r
and linelength denotes the last character of the line *)\r
\r
var\r
next_input_character: char;\r
lgt : integer; (* local linelength *)\r
\r
begin\r
lgt:= 1;\r
printed:= false;\r
errorindex:= 0;\r
linenumber:= linenumber + 1;\r
repeat\r
repeat\r
read(next_input_character);\r
until ord(next_input_character) <> 0;\r
if next_input_character < ' ' then printed := true else\r
if lgt = maxlinelength then printed := true else\r
begin\r
line [ lgt ]:= next_input_character;\r
lgt := lgt + 1;\r
end;\r
until printed ;\r
printed := false;\r
if eof(input) then line[lgt] := '.' else\r
begin\r
while ord(next_input_character) <> 10 do read(next_input_character);\r
line[lgt] := ' ';\r
end;\r
lineindex:= 1;\r
while (lineindex<lgt) and (line[ lineindex ]=' ') do\r
lineindex:= lineindex+1;\r
lineindex:= lineindex-1;\r
\r
linelength:= lgt;\r
\r
end; (* read line *)\r
\r
\r
\r
function get_next_token : tokens;\r
\r
(* move (less than chbufmax) characters from 'line'\r
to 'chbuf', let lastchar denote the length of the word, the\r
funciton result is set according to the delimiter following the\r
word, i.e. 'line [ lineindex ] ' *)\r
\r
label 1;\r
\r
var\r
localtoken : tokens;\r
insert, finished : boolean;\r
\r
begin\r
lastchar:= 0;\r
finished:= false;\r
insert := true;\r
\r
while not finished do\r
begin\r
1:\r
if lineindex >= linelength then\r
begin\r
if errorindex > 0 then writeln(output);\r
if codelist and not printed then printline;\r
readline;\r
end;\r
\r
lineindex:= lineindex + 1;\r
case line [ lineindex ] of\r
'#' :\r
begin\r
if lastchar <> 1 then\r
begin (* # is a delimiter, i.e. stop reading *)\r
finished:= true;\r
insert:= false;\r
localtoken:= symbol;\r
end;\r
(* else insert = true , ok *)\r
end; (* '#' *)\r
\r
'.' :\r
begin\r
insert:= false;\r
finished:= true;\r
if lastchar <> 0 then\r
localtoken:= symbol\r
else\r
localtoken:= other;\r
if lastchar = 1 then\r
begin\r
if chbuf [ 1 ] = 'l' then\r
localtoken:= source_line_number\r
else\r
if chbuf [ 1 ] = 'b' then\r
localtoken:= blockbegin\r
else\r
if chbuf [ 1 ] = 'e' then\r
begin\r
if current_level = global_level then\r
localtoken:= endprogram\r
else\r
localtoken:= blockend\r
end\r
else\r
if chbuf [ 1 ] = 'c' then\r
localtoken:= constbegin\r
else\r
if chbuf [ 1 ] = 'z' then\r
localtoken:= line_table\r
else\r
if chbuf [ 1 ] = 'o' then\r
localtoken:= option\r
else\r
if chbuf [ 1 ] = 'd' then\r
localtoken:= startdescr (* start of descriptor segment *)\r
\r
end;\r
end; (* '.' *)\r
\r
' ' :\r
begin\r
if lastchar = 0 then goto 1 (* skip leading spaces *) else\r
begin\r
finished:= lineindex = linelength; (* nl is a delimiter *)\r
insert:= false; (* skip trailing spaces *)\r
localtoken:= symbol;\r
end;\r
end; (* space *)\r
\r
'+', '-', ',' , '/' :\r
begin\r
finished:= true;\r
insert:= false;\r
localtoken:= symbol;\r
end; (* ',' '-' '+' *)\r
\r
';' :\r
begin\r
insert:= false;\r
finished:= true;\r
if lastchar > 0 then\r
localtoken:= symbol\r
else\r
localtoken:= comment;\r
lineindex:= linelength; (* force new line, delim = ' ' *)\r
end; (* ';' *)\r
\r
':' :\r
begin\r
insert:= false;\r
finished:= true;\r
localtoken:= labeldef;\r
end;\r
\r
'=' :\r
begin\r
insert:= false;\r
finished:= true;\r
localtoken:= constdef;\r
end;\r
\r
\r
\r
else\r
begin\r
if not insert then (* after skip spaces *)\r
begin\r
finished:= true;\r
lineindex:= lineindex - 1;\r
end;\r
end;\r
end;\r
if not ((line [ lineindex ] = '0') and (chbuf [ lastchar ] = '#')) then\r
(* not leading '0' of a seq-name *)\r
\r
\r
if insert and (lastchar < chbufmax) then\r
begin\r
lastchar:= lastchar + 1;\r
chbuf [ lastchar ]:= line [ lineindex ] ;\r
end;\r
\r
\r
end; (* while *)\r
\r
get_next_token:= localtoken;\r
\r
if test then writeln(output,'get next token, token = ', ord(localtoken) );\r
exit;\r
\r
end; (* get next token *)\r
\r
\r
\f
\r
function get_constant_value : integer;\r
\r
(* read an 16 bit unsigned integer from chbuf, i.e. convert text to internal\r
representation; if chbuf <> integer then the function result becomes 0 *)\r
\r
const\r
limit = 6553; (* max unsigned integer (2**16 - 1) div 10 *)\r
last_of_limit = '5' ; (* the last character of max unsigned integer *)\r
base = 10;\r
\r
var\r
localresult : integer;\r
chbufptr : chbuf_ix;\r
currentch : char; (* holds the character from chbuf [ chbufptr ] *)\r
\r
begin\r
localresult:= 0;\r
chbufptr:= 1;\r
currentch:= chbuf [ chbufptr ] ;\r
\r
while (currentch >= '0') and (currentch <= '9') and (chbufptr <= lastchar) do\r
begin\r
(*$R-*)\r
localresult:= localresult * base + (ord(currentch) - ord('0'));\r
chbufptr:= chbufptr + 1;\r
currentch:= chbuf [ chbufptr ] ;\r
end; (* while *)\r
\r
get_constant_value:= localresult;\r
\r
end; (* get constant value *)\r
\r
\f
\r
function getnamenode : name_ptr;\r
\r
(* get a free name node *)\r
var\r
localnode : name_ptr;\r
\r
begin\r
if namefreelist <> nil_name then\r
localnode:= namefreelist\r
else\r
begin\r
new(localnode);\r
survey_name_nodes:= survey_name_nodes+1;\r
localnode^.next_name:= nil_name;\r
end;\r
\r
with localnode ^ do\r
begin\r
namefreelist:= next_name;\r
next_name:= nil_name;\r
namepart:= blank;\r
def_segment:= nill; (* i.e. undefined *)\r
def_offset:= 0;\r
use_chain:= unsatisfied_nil;\r
kind:= undefined;\r
end; (* with *)\r
\r
getnamenode:= localnode;\r
\r
end ; (* get name node *)\r
\r
\r
procedure returnname(name : name_ptr);\r
(* insert the name into the name free list *)\r
\r
begin\r
if test then writeln('return =', name ^ . namepart);\r
name ^ . next_name:= namefreelist;\r
namefreelist:= name;\r
end; (* return name *)\r
\r
\f
\r
function get_dep_chain_node : dep_chain_ptr;\r
\r
(* get a free node to describe the interdependence\r
between two constants, e.g. a = b + 7 *)\r
\r
var\r
localnode : dep_chain_ptr;\r
\r
begin\r
if free_dep_list = dep_chain_start then\r
begin\r
new(localnode);\r
survey_dependence_nodes:= survey_dependence_nodes+1;\r
localnode^.next_dep:= dep_chain_start;\r
end\r
else\r
localnode:= free_dep_list;\r
\r
free_dep_list:= localnode ^ . next_dep;\r
\r
localnode ^. next_dep:= dep_chain_start ^. next_dep;\r
dep_chain_start ^. next_dep:= localnode;\r
\r
get_dep_chain_node:= localnode;\r
\r
end; (* get dep chain node *)\r
\r
\r
procedure return_dependence_node( former, actual : dep_chain_ptr);\r
\r
(* let former.next:= actual.next and insert actual into the free list *)\r
\r
begin\r
with actual ^ do\r
begin\r
former ^ . next_dep:= next_dep;\r
next_dep:= free_dep_list;\r
end;\r
free_dep_list:= actual;\r
\r
end; (* return dependence node *)\r
\f
\r
procedure initcodes(codename : namestring; codevalue : coderange;\r
trailerbyte1, trailerbyte2 : integer; addr_kind : opcode_kinds;\r
execution_time : integer );\r
\r
(* initialize the op_code structure according to the parameters\r
of the call *)\r
(* nb: lastcode will contain the table index used *)\r
type\r
used_name = packed array[1..4] of char;\r
var\r
i: integer;\r
us_name: used_name;\r
hash_name : packed record\r
case boolean of\r
true: ( name : used_name; );\r
false:( int1, int2 : integer; )\r
end;\r
\r
begin\r
for i := 1 to 4 do us_name[i] := codename[i];\r
with hash_name do\r
begin\r
name:= us_name;\r
(* the hash function must be the same as in 'function find_code' *)\r
lastcode:= abs ( int1 div hash1 + int2 div hash2 ) mod hash3;\r
end; (* with *)\r
\r
while opcodes [ lastcode ] . namepart <> blank do\r
begin\r
if hash_function_test then\r
writeln( codename, ' ', lastcode, ' ', opcodes [ lastcode ].namepart);\r
lastcode:= (lastcode + 1) mod hash3;\r
end;\r
\r
\r
with opcodes [ lastcode ] do\r
begin\r
namepart := codename;\r
opcodeval:= codevalue;\r
trailers [ 1 ]:= trailerbyte1;\r
trailers [ 2 ]:= trailerbyte2;\r
total_length:= 1 (* opcode_length *) + trailerbyte1 + trailerbyte2;\r
opcode_kind:= addr_kind;\r
exc_time:= execution_time;\r
use_count:= 0;\r
\r
end; (* with *)\r
\r
end; (* init codes *)\r
\r
\r
\r
procedure initialization;\r
var\r
int : integer;\r
ch : char;\r
current_interval : integer;\r
\r
procedure init_interval( trailer, low, high : integer; last_of_chain : boolean );\r
\r
begin\r
with intervals [ current_interval ] do\r
begin\r
ais_code_val:= lastcode; (* this procedure must be called just after\r
insertion of the ais_code *)\r
interval_low:= low;\r
interval_high:= high;\r
trailer_nr:= trailer;\r
if last_of_chain then\r
next_interval:= 0\r
else\r
next_interval:= current_interval + 1;\r
end; (* with .. *)\r
current_interval:= current_interval + 1;\r
\r
end; (* init interval *)\r
\r
procedure code_node_init;\r
(* split the initialization code, this is done\r
because of a pascal-pass2 constraint, max produced\r
code per routine can not exceed 6000 words !!! *)\r
begin\r
initcodes('abs ',$051,0,0,addr_neutral, 15);\r
initcodes('add ',$044,0,0,addr_neutral, 11);\r
initcodes('and ',$04c,0,0,addr_neutral, 11);\r
initcodes('cexch ',$0fe,0,0,addr_neutral,102);\r
initcodes('cgreg ',$01f,0,0,addr_neutral, 8);\r
initcodes('cinwq ',$013,0,0,addr_neutral, 20);\r
initcodes('compl ',$052,0,0,addr_neutral, 11);\r
initcodes('coutwq',$014,0,0,addr_neutral, 30);\r
initcodes('crc16 ',$04f,0,0,addr_neutral, 65);\r
initcodes('crele ',$011,1,0,addr_neutral,141);\r
initcodes('crget ',$091,0,0,addr_neutral, 15);\r
initcodes('crput ',$0b1,0,0,addr_neutral, 15);\r
initcodes('crram ',$0de,0,0,addr_neutral, 20);\r
initcodes('csell ',$01a,0,0,addr_neutral, 61);\r
initcodes('csens ',$015,0,0,addr_neutral,101);\r
initcodes('csign ',$010,0,0,addr_neutral,108);\r
initcodes('cslev ',$01e,0,0,addr_neutral, 15);\r
initcodes('cstart',$01c,0,0,addr_neutral, 32);\r
initcodes('cstop ',$01b,0,0,addr_neutral,126);\r
initcodes('cwait ',$040,0,0,addr_neutral,130);\r
initcodes('cwram ',$0df,0,0,addr_neutral, 57);\r
initcodes('div ',$04a,0,0,addr_neutral,145);\r
initcodes('eq ',$032,0,0,addr_neutral, 15);\r
initcodes('escape',$012,1,0,addr_neutral,100);\r
initcodes('ge ',$037,0,0,addr_neutral, 15);\r
initcodes('gt ',$035,0,0,addr_neutral, 15);\r
initcodes('index ',$06d,0,0,addr_neutral, 71);\r
initcodes('indh0 ',$038,2,2,addr_neutral, 48);\r
initcodes('indh01',$08d,2,0,addr_neutral, 16);\r
initcodes('indh02',$0ad,2,0,addr_neutral, 16);\r
initcodes('indh1 ',$039,2,2,addr_neutral, 50);\r
initcodes('indh11',$0cd,2,0,addr_neutral, 18);\r
initcodes('indh12',$0ed,2,0,addr_neutral, 18);\r
initcodes('inpdv ',$06f,0,0,addr_neutral,150);\r
initcodes('inth0 ',$0c1,2,0,addr_neutral, 16);\r
initcodes('intpa ',$06e,0,0,addr_neutral, 42);\r
initcodes('intrs ',$06c,0,0,addr_neutral, 39);\r
initcodes('iocci ',$01d,0,0,addr_neutral, 20);\r
initcodes('iocda ',$02a,0,0,addr_neutral, 45);\r
initcodes('iogi ',$026,0,0,addr_neutral,145);\r
initcodes('iogo ',$025,0,0,addr_neutral, 30);\r
initcodes('ioibx ',$02b,0,0,addr_neutral, 86);\r
initcodes('ionci ',$027,0,0,first_of_pair, 17);\r
initcodes('iorbb ',$071,0,0,addr_neutral,160);\r
initcodes('iorbbc',$070,0,0,addr_neutral,160);\r
initcodes('iorbw ',$075,0,0,addr_neutral,165);\r
initcodes('iorbwc',$074,0,0,addr_neutral,165);\r
initcodes('iors ',$022,0,0,addr_neutral,138);\r
initcodes('iorsc ',$02d,0,0,addr_neutral,164);\r
initcodes('iorw ',$023,0,0,addr_neutral,144);\r
initcodes('iowbb ',$073,0,0,addr_neutral, 57);\r
initcodes('iowbbc',$072,0,0,addr_neutral, 57);\r
initcodes('iowbw ',$077,0,0,addr_neutral, 63);\r
initcodes('iowbwc',$076,0,0,addr_neutral, 63);\r
initcodes('iowc ',$021,0,0,addr_neutral, 29);\r
initcodes('ioww ',$024,0,0,addr_neutral, 30);\r
initcodes('jmcht ',$06b,3,0,addr_neutral,100);\r
initcodes('jmpga ',$06a,2,0,addr_neutral, 61);\r
initcodes('jmphc ',$069,3,0,jump_long, 42);\r
longjump := lastcode; (*remember the index of longjump*)\r
initcodes('jmprw ',$068,2,0,jump_short, 34);\r
initcodes('jmzeq ',$062,2,0,jump_short, 26);\r
initcodes('jmzge ',$067,2,0,jump_short, 26);\r
initcodes('jmzgt ',$065,2,0,jump_short, 26);\r
initcodes('jmzle ',$066,2,0,jump_short, 26);\r
initcodes('jmzlt ',$064,2,0,jump_short, 26);\r
initcodes('jmzne ',$063,2,0,jump_short, 26);\r
initcodes('le ',$036,0,0,addr_neutral, 16);\r
initcodes('llock ',$07f,2,0,addr_neutral,118);\r
initcodes('lpop ',$07d,0,0,addr_neutral,136);\r
initcodes('lpush ',$07c,0,0,addr_neutral,135);\r
initcodes('lrele ',$016,0,0,addr_neutral, 34);\r
initcodes('lrese ',$07e,0,0,addr_neutral, 36);\r
initcodes('lt ',$034,0,0,addr_neutral, 15);\r
initcodes('madd ',$03f,0,0,addr_neutral, 17);\r
initcodes('mbset ',$0d0,2,0,addr_neutral, 17);\r
initcodes('mbtes ',$0d1,2,0,addr_neutral, 19);\r
initcodes('mcis ',$061,0,0,first_of_pair,187);\r
initcodes('mcist ',$0e1,0,0,first_of_pair,194);\r
initcodes('mcit ',$0a1,0,0,first_of_pair,147);\r
initcodes('mhalt ',$018,0,0,addr_neutral, 50);\r
initcodes('mmul ',$03e,0,0,addr_neutral,154);\r
initcodes('mnoop ',$02f,0,0,addr_neutral, 7);\r
no_op_ix := lastcode; (*remember the index of noop*)\r
initcodes('mod ',$04b,0,0,addr_neutral,145);\r
initcodes('moveb ',$0ac,0,0,addr_neutral,157);\r
initcodes('moveg ',$0ae,0,0,addr_neutral,139);\r
initcodes('mrecha',$081,0,0,addr_neutral,119);\r
initcodes('mrest ',$028,0,0,addr_neutral, 77);\r
initcodes('mstst ',$029,0,0,addr_neutral, 66);\r
initcodes('msub ',$041,0,0,addr_neutral, 17);\r
initcodes('mtime ',$017,0,0,addr_neutral,132);\r
initcodes('mtrh ',$02c,1,1,first_of_pair, 84);\r
initcodes('mtrs ',$02e,0,0,addr_neutral, 81);\r
initcodes('mul ',$049,0,0,addr_neutral, 67);\r
initcodes('mwi ',$020,0,0,first_of_pair, 88);\r
initcodes('mwis ',$060,0,0,first_of_pair,163);\r
initcodes('mwist ',$0e0,0,0,first_of_pair,170);\r
initcodes('mwit ',$0a0,0,0,first_of_pair,123);\r
initcodes('mwst ',$0c0,0,0,first_of_pair,148);\r
initcodes('mwt ',$080,0,0,first_of_pair, 82);\r
initcodes('ne ',$033,0,0,addr_neutral, 15);\r
initcodes('neg ',$050,0,0,addr_neutral, 12);\r
initcodes('not ',$055,0,0,addr_neutral, 11);\r
initcodes('or ',$04d,0,0,addr_neutral, 11);\r
initcodes('pcals ',$07a,3,0,addr_neutral,131);\r
initcodes('pcals0',$078,3,0,addr_neutral,131);\r
initcodes('pcals1',$079,3,0,addr_neutral,142);\r
initcodes('pexit ',$07b,2,0,addr_neutral, 61);\r
initcodes('reaad ',$0fb,3,0,addr_neutral, 20);\r
initcodes('readb ',$090,0,0,addr_neutral, 26);\r
initcodes('readw ',$0b0,0,0,addr_neutral, 26);\r
initcodes('reagd ',$0b4,2,0,addr_neutral, 26);\r
ais_codes[lastcode] := current_interval;\r
initcodes('reagds',$0ce,1, 0,addr_neutral, 21);\r
init_interval( 1, 0, 255,true);\r
initcodes('reaid ',$0e2,1,0,addr_neutral, 39);\r
initcodes('reaisd',$0b5,1,0,addr_neutral, 37);\r
initcodes('reald ',$0e4,2,0,addr_neutral, 26);\r
ais_codes[lastcode] := current_interval;\r
initcodes('realds',$0cf,1, 0,addr_neutral, 21);\r
init_interval( 1, 0, 255,true);\r
initcodes('reard ',$0fc,2,0,addr_neutral, 26);\r
initcodes('reasd ',$0e6,2,0,addr_neutral, 16);\r
ais_codes[lastcode] := current_interval;\r
initcodes('reasd1',$030,0, 0,addr_neutral, 9);\r
init_interval( 1, 1, 1,true);\r
initcodes('reaxd ',$0fd,0,0,addr_neutral, 58);\r
initcodes('rechd ',$0e8,2,2,addr_neutral, 26);\r
initcodes('rechw ',$0a8,2,0,addr_neutral, 14);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rec0 ',$088,0, 0,addr_neutral, 7);\r
init_interval( 1, 0, 0,false);\r
initcodes('rec1 ',$001,0, 0,addr_neutral, 7);\r
init_interval( 1, 1, 1,false);\r
initcodes('rec2 ',$002,0, 0,addr_neutral, 7);\r
init_interval( 1, 2, 2,false);\r
initcodes('rec3 ',$003,0, 0,addr_neutral, 7);\r
init_interval( 1, 3, 3,false);\r
initcodes('rec4 ',$004,0, 0,addr_neutral, 7);\r
init_interval( 1, 4, 4,false);\r
initcodes('rec5 ',$005,0, 0,addr_neutral, 7);\r
init_interval( 1, 5, 5,false);\r
initcodes('rec6 ',$006,0, 0,addr_neutral, 7);\r
init_interval( 1, 6, 6,false);\r
initcodes('rec7 ',$007,0, 0,addr_neutral, 7);\r
init_interval( 1, 7, 7,false);\r
initcodes('rec8 ',$008,0, 0,addr_neutral, 7);\r
init_interval( 1, 8, 8,false);\r
initcodes('rec9 ',$009,0, 0,addr_neutral, 7);\r
init_interval( 1, 9, 9,false);\r
initcodes('rec10 ',$00a,0, 0,addr_neutral, 7);\r
init_interval( 1, 10, 10,false);\r
initcodes('rec11 ',$00b,0, 0,addr_neutral, 7);\r
init_interval( 1, 11, 11,false);\r
initcodes('rec12 ',$00c,0, 0,addr_neutral, 7);\r
init_interval( 1, 12, 12,false);\r
initcodes('rec13 ',$00d,0, 0,addr_neutral, 7);\r
init_interval( 1, 13, 13,false);\r
initcodes('rec14 ',$00e,0, 0,addr_neutral, 7);\r
init_interval( 1, 14, 14,false);\r
initcodes('rec15 ',$00f,0, 0,addr_neutral, 7);\r
init_interval( 1, 15, 15,false);\r
initcodes('rechws',$0c8,1, 0,addr_neutral, 8);\r
init_interval( 1, 16, 255,true);\r
initcodes('renhb ',$08f,2,0,addr_neutral, 31);\r
initcodes('renpb ',$08e,0,0,addr_neutral, 29);\r
\r
end; (* code node init *)\r
\r
\r
begin\r
coded_date:= (( ord( cur_date [ 4 ] ) - ord ( '0' ) ) * 10\r
+ ord( cur_date [ 5 ] ) - ord ( '0' ) ) * 16 * 32\r
+ (( ord( cur_date [ 7 ] ) - ord ( '0' ) ) * 10\r
+ ord( cur_date [ 8 ] ) - ord ( '0' ) ) * 32\r
+ ( ord( cur_date [ 10 ] ) - ord ( '0' ) ) * 10\r
+ ord( cur_date [ 11 ] ) - ord ( '0' );\r
\r
coded_time:= pass6_version div 100 * 64 * 32\r
+ (( ord( cur_time [ 2 ] ) - ord( '0' ) ) * 10\r
+ ord( cur_time [ 3 ] ) - ord( '0' ) ) * 64\r
+ ( ord( cur_time [ 5 ] ) - ord( '0' ) ) * 10\r
+ ord( cur_time [ 6 ] ) - ord( '0' );\r
\r
\r
users_version:= 0;\r
\r
length_of_current_code:= 0;\r
\r
\r
\r
(* create start of name list, nil_name is stop mark *)\r
new(nil_name);\r
with nil_name ^ do\r
begin\r
namepart:= blank;\r
def_segment:= nill; (* i.e. undefined *)\r
def_offset:= 0;\r
next_name:= nil;\r
use_chain:= unsatisfied_nil;\r
kind := undefined;\r
end;\r
\r
survey_name_nodes:= 0;\r
namefreelist:= nil_name;\r
\r
\r
(* create nil dependence element, stop mark of dep_elems *)\r
new(dep_chain_start);\r
(* dep_chain_start ^ is dummy (stop mark) *)\r
with dep_chain_start ^ do\r
begin\r
next_dep:= dep_chain_start; (* cyclical list of elements *)\r
dependent:= nil_name;\r
dependence:= nil_name;\r
end;\r
\r
survey_dependence_nodes:= 0;\r
free_dep_list:= dep_chain_start;\r
\r
(* create nil jump elem, start of jump chain *)\r
new(nil_jump_ptr);\r
nil_jump_ptr^.next_jump:= nil;\r
survey_jump_nodes:= 0;\r
\r
(* create nil label list, start of current labels *)\r
new(nil_label_ptr);\r
nil_label_ptr^.next_label:= nil;\r
survey_cur_label_nodes:= 0;\r
\r
(* create nil element for unsatisfied references *)\r
new(unsatisfied_nil);\r
with unsatisfied_nil^ do\r
begin\r
next_ref:= nil;\r
end;\r
unsatref_freelist:= unsatisfied_nil;\r
survey_unsat_nodes:= 0;\r
\r
(* create bottom of name level stack *)\r
new(nil_level);\r
with nil_level^ do\r
begin\r
former_level:= nil_level;\r
level_list:= nil_name;\r
end; (* stop element *)\r
current_level:= nil_level;\r
\r
new(global_level);\r
global_level^:= nil_level^;\r
free_level_list:= global_level; (* first level to be allocated !!! *)\r
survey_level_nodes:= 1;\r
\r
survey_greatest_const:= 0;\r
\r
current_name:= blank;\r
\r
lastchar:= 0;\r
\r
errorcount:= 0;\r
\r
linenumber:= 0;\r
\r
errorindex:= 0;\r
\r
lineindex:= 0;\r
\r
linelength:= 0;\r
\r
line [ 0 ]:= ' ';\r
chbuf[ 0 ]:= ' ';\r
\r
for step:= 0 to higherror do\r
errormarks [ step ]:= false;\r
\r
printed:= true;\r
\r
object_code_file_opened:= false;\r
\r
systemparamno:= 0;\r
\r
errorreporting:= false;\r
\r
preserve_option:= false;\r
\r
test:= false;\r
\r
dump_nametable:= false;\r
\r
print_code:= false;\r
\r
\r
codelist:= test;\r
\r
current_time:= -1; (* not code line *)\r
\r
\r
codefilename:= 'rtppass6.cod'; (* default name *)\r
\r
no_of_elems_in_line:= elems_per_line; (* force newline at start *)\r
\r
\r
(* opcodes ........ *)\r
\r
for lastcode:= 0 to max_code_number do\r
begin\r
opcodes [ lastcode ] . namepart:= blank; (* unused *)\r
ais_codes [ lastcode ]:= 0; (* not used *)\r
end;\r
\r
current_interval:= 1;\r
\r
short_instructions:= true;\r
\r
survey_info:= false;\r
generate_statistics:= false;\r
\r
(* initialize first part of the code nodes *)\r
\r
code_node_init;\r
initcodes('resta ',$095,1,0,addr_neutral, 69);\r
initcodes('restc ',$0d5,0,0,addr_neutral, 62);\r
initcodes('revga ',$0d3,2,0,addr_neutral, 41);\r
ais_codes[lastcode] := current_interval;\r
initcodes('revgas',$0c9,1, 0,addr_neutral, 36);\r
init_interval( 1, 0, 255,true);\r
initcodes('revgb ',$093,2,0,addr_neutral, 30);\r
ais_codes[lastcode] := current_interval;\r
initcodes('revgbs',$089,1, 0,addr_neutral, 23);\r
init_interval( 1, 0, 255,true);\r
initcodes('revgd ',$0f9,2,0,addr_neutral, 51);\r
ais_codes[lastcode] := current_interval;\r
initcodes('revgds',$0e9,1, 0,addr_neutral, 46);\r
init_interval( 1, 0, 255,true);\r
initcodes('revgw ',$0b3,2,0,addr_neutral, 36);\r
ais_codes[lastcode] := current_interval;\r
initcodes('revgws',$0a9,1, 0,addr_neutral, 30);\r
init_interval( 1, 0, 255,true);\r
initcodes('revla ',$0d7,2,0,addr_neutral, 41);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvlans',$0dc,1, 0,negative_short, 36);\r
init_interval( 1,-255, 0,false);\r
initcodes('revlas',$0cb,1, 0,addr_neutral, 36);\r
init_interval( 1, 0, 255,true);\r
initcodes('revlb ',$097,2,0,addr_neutral, 30);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvlbns',$0da,1, 0,negative_short, 23);\r
init_interval( 1,-255, 0,false);\r
initcodes('revlbs',$08b,1, 0,addr_neutral, 23);\r
init_interval( 1, 0, 255,true);\r
initcodes('revld ',$0f7,2,0,addr_neutral, 51);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvldns',$0dd,1, 0,negative_short, 46);\r
init_interval( 1,-255, 0,false);\r
initcodes('revlds',$0eb,1, 0,addr_neutral, 46);\r
init_interval( 1, 0, 255,true);\r
initcodes('revlw ',$0b7,2,0,addr_neutral, 36);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvlwns',$0db,1, 0,negative_short, 30);\r
init_interval( 1,-255, 0,false);\r
initcodes('revlws',$0ab,1, 0,addr_neutral, 30);\r
init_interval( 1, 0, 255,true);\r
initcodes('revpd ',$0ef,0,0,addr_neutral, 17);\r
initcodes('revpw ',$0af,0,0,addr_neutral, 11);\r
initcodes('revsa ',$0bc,2,0,addr_neutral, 41);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvsa0 ',$0f4,0, 0,addr_neutral, 32);\r
init_interval( 1, 0, 0,false);\r
initcodes('rvsa2 ',$0c3,0, 0,addr_neutral, 34);\r
init_interval( 1, 2, 2,false);\r
initcodes('rvsa4 ',$0c5,0, 0,addr_neutral, 34);\r
init_interval( 1, 4, 4,false);\r
initcodes('rvsa6 ',$0c7,0, 0,addr_neutral, 34);\r
init_interval( 1, 6, 6,true);\r
initcodes('revsb ',$0b8,2,0,addr_neutral, 29);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvsb0 ',$0f0,0, 0,addr_neutral, 20);\r
init_interval( 1, 0, 0,false);\r
initcodes('rvsb1 ',$0b9,0, 0,addr_neutral, 22);\r
init_interval( 1, 1, 1,false);\r
initcodes('rvsb2 ',$083,0, 0,addr_neutral, 22);\r
init_interval( 1, 2, 2,false);\r
initcodes('rvsb3 ',$0bb,0, 0,addr_neutral, 22);\r
init_interval( 1, 3, 3,false);\r
initcodes('rvsb4 ',$085,0, 0,addr_neutral, 22);\r
init_interval( 1, 4, 4,false);\r
initcodes('rvsb5 ',$0bd,0, 0,addr_neutral, 22);\r
init_interval( 1, 5, 5,false);\r
initcodes('rvsb6 ',$087,0, 0,addr_neutral, 22);\r
init_interval( 1, 6, 6,false);\r
initcodes('rvsb7 ',$0bf,0, 0,addr_neutral, 22);\r
init_interval( 1, 7, 7,true);\r
initcodes('revsd ',$0be,2,0,addr_neutral, 53);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvsd0 ',$0f6,0, 0,addr_neutral, 46);\r
init_interval( 1, 0, 0,false);\r
initcodes('rvsd2 ',$0e3,0, 0,addr_neutral, 48);\r
init_interval( 1, 2, 2,false);\r
initcodes('rvsd4 ',$0e5,0, 0,addr_neutral, 48);\r
init_interval( 1, 4, 4,false);\r
initcodes('rvsd6 ',$0e7,0, 0,addr_neutral, 48);\r
init_interval( 1, 6, 6,true);\r
initcodes('revsf ',$0d9,0,0,addr_neutral, 59);\r
initcodes('revsm ',$0cc,0,0,addr_neutral,181);\r
initcodes('revsw ',$0ba,2,0,addr_neutral, 36);\r
ais_codes[lastcode] := current_interval;\r
initcodes('rvsw0 ',$0f2,0, 0,addr_neutral, 27);\r
init_interval( 1, 0, 0,false);\r
initcodes('rvsw2 ',$0a3,0, 0,addr_neutral, 29);\r
init_interval( 1, 2, 2,false);\r
initcodes('rvsw4 ',$0a5,0, 0,addr_neutral, 29);\r
init_interval( 1, 4, 4,false);\r
initcodes('rvsw6 ',$0a7,0, 0,addr_neutral, 29);\r
init_interval( 1, 6, 6,true);\r
initcodes('setad ',$05f,0,0,addr_neutral, 30);\r
initcodes('setatm',$058,0,0,addr_neutral, 65);\r
initcodes('setcr ',$056,0,0,addr_neutral,147);\r
initcodes('setdi ',$05e,0,0,addr_neutral,185);\r
initcodes('seteq ',$059,0,0,addr_neutral,126);\r
initcodes('setin ',$05d,0,0,addr_neutral,185);\r
initcodes('setre ',$094,0,0,addr_neutral,187);\r
initcodes('setsb ',$05a,0,0,addr_neutral,126);\r
initcodes('setsp ',$05b,0,0,addr_neutral,126);\r
initcodes('setst ',$0ec,0,0,addr_neutral,183);\r
initcodes('settm ',$057,0,0,addr_neutral, 80);\r
initcodes('setun ',$05c,0,0,addr_neutral,185);\r
initcodes('shc ',$053,0,0,addr_neutral, 35);\r
initcodes('shc8 ',$054,0,0,addr_neutral, 9);\r
initcodes('stcea ',$0ee,0,0,addr_neutral,118);\r
initcodes('stnhb ',$08c,2,0,addr_neutral, 52);\r
initcodes('ststc ',$0d4,0,0,addr_neutral, 51);\r
initcodes('stvga ',$0d2,2,0,addr_neutral, 46);\r
initcodes('stvgb ',$092,2,0,addr_neutral, 29);\r
initcodes('stvgd ',$0fa,2,0,addr_neutral, 51);\r
initcodes('stvgw ',$0b2,2,0,addr_neutral, 35);\r
initcodes('stvla ',$0d6,2,0,addr_neutral, 46);\r
ais_codes[lastcode] := current_interval;\r
initcodes('stvlas',$0ca,1, 0,addr_neutral, 42);\r
init_interval( 1, 0, 255,true);\r
initcodes('stvlb ',$096,2,0,addr_neutral, 29);\r
ais_codes[lastcode] := current_interval;\r
initcodes('stvlbs',$08a,1, 0,addr_neutral, 24);\r
init_interval( 1, 0, 255,true);\r
initcodes('stvld ',$0f8,2,0,addr_neutral, 51);\r
ais_codes[lastcode] := current_interval;\r
initcodes('stvlds',$0ea,1, 0,addr_neutral, 46);\r
init_interval( 1, 0, 255,true);\r
initcodes('stvlw ',$0b6,2,0,addr_neutral, 35);\r
ais_codes[lastcode] := current_interval;\r
initcodes('stvlws',$0aa,1, 0,addr_neutral, 30);\r
init_interval( 1, 0, 255,true);\r
initcodes('stvsa ',$09c,2,0,addr_neutral, 48);\r
ais_codes[lastcode] := current_interval;\r
initcodes('svsa0 ',$0f5,0, 0,addr_neutral, 41);\r
init_interval( 1, 0, 0,false);\r
initcodes('svsa2 ',$0c2,0, 0,addr_neutral, 43);\r
init_interval( 1, 2, 2,false);\r
initcodes('svsa4 ',$0c4,0, 0,addr_neutral, 43);\r
init_interval( 1, 4, 4,false);\r
initcodes('svsa6 ',$0c6,0, 0,addr_neutral, 43);\r
init_interval( 1, 6, 6,true);\r
initcodes('stvsb ',$098,2,0,addr_neutral, 30);\r
ais_codes[lastcode] := current_interval;\r
initcodes('svsb0 ',$0f1,0, 0,addr_neutral, 22);\r
init_interval( 1, 0, 0,false);\r
initcodes('svsb1 ',$099,0, 0,addr_neutral, 24);\r
init_interval( 1, 1, 1,false);\r
initcodes('svsb2 ',$082,0, 0,addr_neutral, 24);\r
init_interval( 1, 2, 2,false);\r
initcodes('svsb3 ',$09b,0, 0,addr_neutral, 24);\r
init_interval( 1, 3, 3,false);\r
initcodes('svsb4 ',$084,0, 0,addr_neutral, 24);\r
init_interval( 1, 4, 4,false);\r
initcodes('svsb5 ',$09d,0, 0,addr_neutral, 24);\r
init_interval( 1, 5, 5,false);\r
initcodes('svsb6 ',$086,0, 0,addr_neutral, 24);\r
init_interval( 1, 6, 6,false);\r
initcodes('svsb7 ',$09f,0, 0,addr_neutral, 24);\r
init_interval( 1, 7, 7,true);\r
initcodes('stvsd ',$09e,2,0,addr_neutral, 53);\r
initcodes('stvsf ',$0d8,0,0,addr_neutral, 89);\r
initcodes('stvsw ',$09a,2,0,addr_neutral, 36);\r
ais_codes[lastcode] := current_interval;\r
initcodes('svsw0 ',$0f3,0, 0,addr_neutral, 28);\r
init_interval( 1, 0, 0,false);\r
initcodes('svsw2 ',$0a2,0, 0,addr_neutral, 30);\r
init_interval( 1, 2, 2,false);\r
initcodes('svsw4 ',$0a4,0, 0,addr_neutral, 30);\r
init_interval( 1, 4, 4,false);\r
initcodes('svsw6 ',$0a6,0, 0,addr_neutral, 30);\r
init_interval( 1, 6, 6,true);\r
initcodes('sub ',$045,0,0,addr_neutral, 13);\r
initcodes('teqad ',$03c,0,0,addr_neutral, 17);\r
initcodes('tlock ',$03b,0,0,addr_neutral, 32);\r
initcodes('tnill ',$03d,0,0,addr_neutral, 25);\r
initcodes('topen ',$03a,0,0,addr_neutral, 30);\r
initcodes('uadd ',$042,0,0,addr_neutral, 15);\r
initcodes('uadhw ',$0e6,2,0,addr_neutral, 16);\r
ais_codes[lastcode] := current_interval;\r
initcodes('uadhw1',$030,0, 0,addr_neutral, 9);\r
init_interval( 1, 1, 1,true);\r
initcodes('udiv ',$047,0,0,addr_neutral,137);\r
initcodes('ult ',$031,0,0,addr_neutral, 15);\r
initcodes('umod ',$048,0,0,addr_neutral,137);\r
initcodes('umul ',$046,0,0,addr_neutral,153);\r
initcodes('usub ',$043,0,0,addr_neutral, 15);\r
initcodes('xor ',$04e,0,0,addr_neutral, 11);\r
\r
\r
reserve_max:= 0;\r
\r
line_spacing:= default_line_table_spacing;\r
\r
segment_size:= default_buffer_size - 1;\r
codesize_met:= false;\r
\r
line_add:= 0;\r
\r
current_source_line:= 0;\r
line_table_descriptor:= nil_name;\r
\r
end; (* initialization *)\r
\r
\r
procedure init_between_code_blocks;\r
\r
(* initialize variables and internal structures, ready for\r
a new block of code *)\r
\r
begin\r
\r
internal_link_list:= nil_name;\r
\r
total_time:= 0;\r
\r
program_kind:= closed_routine;\r
\r
current_jump_ptr:= nil_jump_ptr;\r
\r
cur_lab_ptr:= nil_label_ptr;\r
\r
current_segment:= 1;\r
\r
current_offset:= 0;\r
\r
rewrite( codefile, 1 ); (* work file for the code *)\r
\r
last_page:= false;\r
\r
generate_line_info:= true;\r
\r
spacing_met:= false;\r
\r
lineinfo_met:= false;\r
(*$R-*)\r
line_table_size:= (segment_size + 1 - fix_line_table_part) div\r
(line_spacing + 1) + fix_line_table_part;\r
line_table_size:= (line_table_size + 1) div 2 * 2; (* integral number of words *)\r
\r
rem_buffer_size:= segment_size + 1 - longjump_size; (* prepared for a closed routine or process *)\r
\r
line_table_descriptor:= getnamenode;\r
\r
start_of_line_table:= segment_size + 1 - line_table_size;\r
\r
prepare_linetable; (* otherwise the line table is set up after allocation *)\r
\r
\r
end; (* initialization of variables used per-block of code *)\r
\r
\r
\r
\r
\f
\r
function add_unsatisfied_node ( chainstart : unsatref_ptr;\r
ic_rel : boolean; byte_size : integer): unsatref_ptr;\r
\r
(* get a new node for a use of a label or a constant, and initialize\r
the node, byte_size is the number of bytes to change when the symbol is defined *)\r
var\r
localnode : unsatref_ptr;\r
\r
begin\r
if unsatref_freelist = unsatisfied_nil then\r
begin\r
new(localnode);\r
survey_unsat_nodes:= survey_unsat_nodes+1;\r
localnode^.next_ref:= unsatisfied_nil;\r
end\r
else\r
localnode:= unsatref_freelist;\r
\r
with localnode ^ do\r
begin\r
unsatref_freelist:= next_ref;\r
next_ref:= chainstart;\r
ic_relative:= ic_rel;\r
use_segment:= current_segment;\r
(*$R-*)\r
use_offset:= current_offset + byte_size - 1; (* least significant byte *)\r
(*$R+*)\r
size:= byte_size;\r
end;\r
\r
add_unsatisfied_node:= localnode;\r
\r
end; (* add unsatisfied node *)\r
\r
\r
procedure remove_unsatisfied_node( var chainstart : unsatref_ptr);\r
\r
(* insert the element specified by chainstart into the free list and\r
let chainstart denote the successor of the removed element *)\r
\r
var\r
localresult : unsatref_ptr;\r
\r
begin\r
with chainstart ^ do\r
begin\r
localresult:= next_ref;\r
next_ref:= unsatref_freelist;\r
unsatref_freelist:= chainstart;\r
end;\r
\r
chainstart:= localresult;\r
\r
end; (* remove unsatisfied node *)\r
\f
\r
function search_name(name : namestring; namelist : name_ptr;\r
insert : boolean ) : name_ptr;\r
\r
(* lookup name in the list starting at namelist ^,\r
if not found and insert then add a new name node as the\r
successor of namelist ^,\r
if not found and not insert then the function result\r
becomes nil_name, if found or inserted the function result\r
becomes the name table entry of the searched name *)\r
\r
var\r
localresult : name_ptr;\r
found : boolean;\r
\r
begin\r
localresult:= namelist;\r
found:= false;\r
\r
while (localresult <> nil_name) and not found do\r
with localresult ^ do\r
if namepart = name then\r
found:= true\r
else\r
localresult:= next_name;\r
\r
if not found and insert then\r
begin (* inser the name as successor of namelist *)\r
localresult:= getnamenode;\r
with localresult ^ do\r
begin\r
namepart:= name;\r
next_name:= namelist ^ . next_name;\r
end; (* with *)\r
namelist ^ . next_name:= localresult;\r
end; (* if not found and insert *)\r
\r
(* now localresult denotes the searched node if the name is\r
in the list, otherwisw localresult is null, i.e. localresult is\r
the wanted function result *)\r
\r
search_name:= localresult;\r
\r
end; (* search name *)\r
\r
\r
function find_name : name_ptr;\r
\r
(* find the index of the name kept in chbuf, if not declared the\r
function result becomes nil_name. if the name is of the\r
sequential type the namepart ( a# ) is searched (if not\r
found then error) after that the entire name is searched -\r
and possibly inserted - at the level of the namepart *)\r
\r
var\r
namestr : namestring;\r
seq_name : boolean;\r
level: level_ptr;\r
step : integer;\r
nameptr : name_ptr;\r
\r
begin\r
namestr:= blank;\r
seq_name:= (chbuf [ 2 ] = '#') and (lastchar >= 2);\r
\r
if seq_name then\r
begin\r
namestr [ 1 ]:= chbuf [ 1 ];\r
namestr [ 2 ]:= '#'; (* = chbuf [ 2 ] *)\r
end\r
else\r
for step:= 1 to lastchar do\r
if step <= namelength then\r
namestr [ step ]:= chbuf [ step ] ;\r
\r
level:= current_level;\r
\r
repeat\r
nameptr:= search_name(namestr, level ^.level_list, false);\r
level:= level^.former_level;\r
until (nameptr <> nil_name) or (level=nil_level);\r
\r
if (nameptr <> nil_name) and seq_name then\r
begin\r
for step:= 3 to lastchar do\r
namestr [ step ]:= chbuf [ step ] ;\r
(* if namestr not defined yet then insert a definition as successor\r
of nameptr *)\r
nameptr:= search_name(namestr, nameptr, true);\r
end;\r
\r
find_name:= nameptr;\r
if test then\r
begin\r
outtest('find_name');\r
writeln(output,' name is : ', namestr,\r
'index = ', seg(nameptr), ofs(nameptr));\r
end;\r
\r
\r
end; (* find name *)\r
\r
\r
\f
\r
\r
procedure output_line_information;\r
(* generate next line table entry *)\r
\r
begin\r
if generate_line_info then\r
begin\r
if line_add <= max_line then\r
begin\r
code_buffer [ next_line_table_entry ]:= line_add;\r
line_add:= 0;\r
end\r
else\r
begin\r
code_buffer [ next_line_table_entry ]:= max_line;\r
line_add:= line_add - max_line;\r
end;\r
\r
(*$R-*)\r
next_line_table_entry:= next_line_table_entry + 1;\r
(*$R+*)\r
end;\r
end; (* output line information *)\r
\r
\r
procedure outbyte(byte_operand : integer);\r
\r
(* check the size of byte_operand ( -128 <= byte_operand <= 255)\r
and insert the operand as current byte of the code buffer\r
and update the code buffer pointer *)\r
\r
begin\r
\r
if (byte_operand >= -128) and (byte_operand <= 255) then\r
begin\r
if byte_operand < 0 then\r
byte_operand:= byte_operand + maxbyte; (* let the byte be inside (0..255) *)\r
end\r
else\r
begin\r
markerror( 1); (* byte operand out of bounds (-128..127) *)\r
byte_operand:= 0;\r
end;\r
\r
code_buffer [ current_offset ]:= byte_operand;\r
if current_offset mod line_spacing = 0 then\r
output_line_information;\r
(*$R-*)\r
current_offset:= current_offset + 1;\r
(*$R+*)\r
end; (* out byte *)\r
\r
\r
procedure outword ( word_operand : integer );\r
\r
(* check the size of word operand (-2**15 <= operand <= 2**16 -1)\r
insert the operand as two bytes ( 0.. 255 ) into the code buffer\r
and adjust the code buffer pointer *)\r
\r
\r
begin\r
\r
code_buffer [ current_offset ]:= word_operand shr 8;\r
(*$R-*)\r
current_offset:= current_offset + 1;\r
code_buffer [ current_offset ]:= word_operand and 255;\r
if current_offset mod line_spacing <= 1 then\r
output_line_information;\r
current_offset:= current_offset + 1;\r
(*$R+*)\r
\r
end; (* out word *)\r
\r
\r
\r
\r
\r
\r
procedure outcode( cur_code : coderange );\r
begin\r
\r
with opcodes [ cur_code ] do\r
begin\r
use_count:= use_count + 1;\r
\r
code_buffer [ current_offset ]:= opcodeval;\r
end; (* with *)\r
(*$R-*)\r
if current_offset mod line_spacing = 0 then\r
output_line_information;\r
current_offset:= current_offset + 1;\r
(*$R+*)\r
end; (* outcode *)\r
\r
\r
procedure put_word( displacement : code_ix; destination : integer );\r
\r
(* add 'destination' (two bytes) to the contents of code buffer, displacement\r
bytes from the start *)\r
var temp : integer;\r
\r
begin\r
(*$R-*)\r
\r
temp := code_buffer[displacement-1] shl 8 + code_buffer[displacement];\r
temp := temp + destination;\r
\r
code_buffer [ displacement - 1 ] := temp shr 8;\r
code_buffer [ displacement ] := temp and 255;\r
\r
(*$R+*)\r
end; (* put word *)\r
\r
\r
«eof»