|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 61440 (0xf000)
Types: TextFile
Names: »t290xasm«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »t290xasm«
begin
message version 790505;
algol copy.tcgproclib;
integer elements_pr_line,
length_of_code,
half_words_pr_instr,no_of_bits_in_code,
HEAP_length,
search_table_length,
no_of_errors,
name_table_length,index,
code_kind,start_addrs;
integer field refference_first_free,refference_last_free;
integer comma_class,illegal_class,star_class,left_par_class,
right_par_class,period_class,plus_class,minus_class,
colon_class,semi_colon_class,equal_class,delim_class,
apost_class, <* apostrof used as address identf. in micro code *>
quote_class, <* same as above *>
double_quote_class,
slash_class, <* indicate special print for label def *>
text_class,long_text_class,number_class,
illegal_number_class,
unknown_name_class,stop_line_class,eof_class,
class,type,
class1,type1,
class2,type2,
nil, <* end off refference chain *>
label_type, <* a generel type *>
mask_type, <* type value used by type definitions value 101 *>
not_used; <* a general value used for indicating
dummy, nil and not used conditioning
initialized to max negative integer + 10 *>
long array
param_name, <* used for gettting abitrary parameters *>
find_name, <* to find and list lines with specific contents *>
current_out_name(1:2);
integer current_out_mode_and_kind;
integer array tail(1:20); <* used to change the entry of
the object code *>
boolean test,
test_label_ref,
test_label_bit,
find, <* list mode is only to special lines *>
found, <* if a special line is found
( detected in get next element) *>
list, <* a listing of relewant lines *>
line_num, <* if listning is wanted then
is line numbers wanted default is yes *>
dec_code, <* if listning then is code numbers in
decimal wanted , default is yes *>
octal_code, <* if listning thenis code numbers wnted in
octal ( basis 8) wanted, defaulst is yes,
the parameter can be set to octal.only,
which will set line_num and dec_code to false *>
entry_list_wanted, <* list all entryes marked with slash *>
return_from_skip, <* the return to the main loop is from
some skip logic *>
list_all, <* a listing of all lines , also
lines which is skipped *>
help_wanted; <* used with parameter check *>
boolean procedure lookup_name(name_table,short_name,index);
<**********************************************************>
value short_name; long array name_table; long short_name,index;
begin
integer table_length,hash_index,prim_index;
table_length := nametable(0,0);
hash_index := (short_name extract 12) +
( short_name shift (-12) extract 12) +
(short_name shift (-24) extract 12) +
(short_name shift (-36) extract 12);
prim_index:=hash_index mod table_length +1;
if false then
write(out,<:<10>***look::>,<<_dddd>,tablelength,<:index: :>,
hashindex,<:prim: :>,primindex,<:name: :>,string shortname);
for hash_index := hash_index mod table_length +1 while
nametable(hash_index,0) > - 1 and
name_table(hash_index,1) <> short_name and
hash_index+1 <> prim_index do;
index:=hash_index;
lookup_name := if name_table(hash_index,1) = short_name
then true else false;
if false then
write(out,<: index::>,<<_dddd>,hash_index,
name_table(hashindex,0),<: :>,string nametable(hash_index,1));
end look_up_name;
long present_code, <* the object code handled now *>
name,number,name1,
number1,name2,number2; <* variables for lookup in
tables , and reading from source *>
procedure present(func_value,func_mask);
<**************************************>
value func_value,func_mask; long func_value,func_mask;
begin
present_code := mask_in(present_code,func_value,func_mask);
end present;
long procedure mask_in(code,func_value,func_mask);
<*************************************************>
value code,func_value,func_mask;
long func_value,func_mask, code;
begin
integer init_shift,func_bit,mask_bit;
long instr,long_one,long_all;
init_shift := 0;
long_one := 1; long_all := -1;
for mask_bit := func_mask extract 1 while func_mask <> 0 do
begin
if mask_bit = 1 then
begin
if func_value extract 1 = 1 then
code := logor(code,long_one shift init_shift)
else
code := logand(code,exor(long_all,long_one shift init_shift));
func_value := func_value shift (-1);
end;
func_mask := func_mask shift (-1);
init_shift := init_shift +1;
end;
mask_in := code;
end mask_in;
long procedure octal(number);
value number; long number;
begin
integer index,tal;
tal:=0;
for index:=1,index*10 while number <> 0 do
begin
tal := tal + (index*(number extract 3 ));
number := number shift (-3);
end;
octal := tal;
end octal;
integer array read_table(0:383);
<* init of read classes *>
illegal_class := 10;
star_class := 11;
comma_class := 12;
<* ille_gal_class_2 := 13; *>
left_par_class := 14;
right_par_class :=15;
period_class := 16;
minus_class := 17;
colon_class := 18;
semi_colon_class := 19;
equal_class := 20;
plus_class := 21;
quote_class := apost_class := 23;
slash_class := 24;
double_quote_class := 25;
delim_class := 7; <* space and / is resent delim*>
text_class := 6;
long_text_class := 5;
number_class := 2;
illegal_number_class := 1;
unknown_name_class := 9 ; <* short or long name *>
stop_line_class := 8;
eof_class := 22; <* this is not in read_table but is calc.
in get_next_element *>
not_used := -8388598 ;
iso_table(read_table);
<* 0 - 127 is modified std_table *>
<* 128- 255 is
comment shift table
256 - 383 is comment text table *>
for index := 128 step 1 until 255 do
read_table(index) := 1 shift 12 + 256;
semi_colon_class := 19;
read_table(128+59):=semi_colon_class shift 12 + 59;
for index:= 256 step 1 until 383 do
read_table(index):= 6 shift 12 + (index-256);
read_table(256+0) := 0 shift 12 + 0;
read_table(256+10) := 1 shift 12 + 0;
read_table(256+12) := 1 shift 12 + 0;
read_table(256+13) := 0 shift 12 + 0;
read_table(256+25) := 1 shift 12 + 0;
read_table(256+127) := 0 shift 12 + 127;
for index := 33 step 1 until 39 do
read_table(index):= illegal_class shift 12 + index;
read_table(39) := apost_class shift 12 + 39;
read_table('"'):=double_quote_class shift 12 + '"';
read_table(40):= left_par_class shift 12 + 40;
read_table(41) := right_par_class shift 12 + 41;
read_table(42) := star_class shift 12 + 42;
read_table(44):= comma_class shift 12 + 44;
read_table(46):= period_class shift 12 + 46;
read_table(47):=slash_class shift 12 + 47;
read_table(43):= plus_class shift 12 + 43;
read_table(45):= minus_class shift 12 + 45;
read_table(58):=colon_class shift 12 + 58;
read_table(59) := 1 shift 12 + 128; <* semicolon shift table *>
for index := 60 step 1 until 64 do
read_table(index) := 10 shift 12 + index;
read_table(61) := equal_class shift 12 + 61;
for index:= 94 step 1 until 96,126 do
read_table(index):= 10 shift 12 + index;
intable(read_table);
test := false;
no_of_bits_in_code := 40;
length_of_code := 1024;
search_table_length := 253;
name_table_length := 511;
HEAP_length := 5000;
nil := -8388608; <* min integer *>
label_type := 97;
mask_type := 101;
<* search for the parameter help.yes *>
get_bool_string(<:help:>,help_wanted);
if help_wanted then help_string(<:micasmhelp:>);
begin
integer instr_index,
last_instr_index,
line_no,line_no1,line_pointer,line_pointer_1,
line_pointer_2,line_pointer_3,char_value,char_value_1,char_value_2,
char_class,char_class_1,element_no,
no_of_elements,
reg_op_type,alu_function_type,jump_addrs_type,
jump_sekvens_type,load_counter_type,special_type,
condition_type,
condition_type_min,condition_type_max,
special_min,special_max;
boolean code_generated,eof,eol,alu_function_performed,
jump_addrs_performed,jump_sekvens_performed,
shift_condition_performed,addrs_performed,
print_code,object_file_known,
list_error_lines,
message_list,
list_bit_lines,
line_listed,
help_wanted,
error_in_this_line;
integer array format(0:no_of_bits_in_code);
long array read_value(1:80);
integer array read_kind(1:80);
integer array search_table(0:search_table_length - 1);
long array name_table(0:name_table_length,0:4);
integer array HEAP(1:HEAP_length);
long array field name_record;
long field name_name,
name_mask;
integer field name_value,
name_type,
name_chain;
integer name_record_length;
long array field error_record;
long field error_record_text;
integer field error_record_line_no;
integer field error_record_element_pos;
integer field error_record_instr_index;
integer field error_record_chain;
integer error_record_length;
long array field error_record_chain_head;
long array field l_d_record, l_d_record_chain_head;
long field l_d_name;
integer spec_class,map_spec,vector_spec; <* and nil *>
integer field l_d_spec, l_d_spec_class;
integer field l_d_index;
integer field l_d_line_no;
integer field l_d_chain;
integer l_d_record_length;
long array field l_r_record;
integer field l_r_chain;
long field l_r_name;
integer field l_r_index;
integer field l_r_line_no;
integer field l_r_element_no;
integer l_r_record_length,l_r_record_chain_head;
long array op_code(0:length_of_code-1);
long array object_file_known_name(1:2);
<* error text variables *>
long plus_label_dec,declaration,operand_type,minus_delim,missing_operand,
label_dec,illegal_type,plus_name_dec,name_unknown,directive,
unknown,name_length,delimiter,undec_label,multiple_function,
plus_addrs_def,minus_addrs_def,operand,
special_def_type,illegal_source,illegal_dest,
illegal_dest_and_source,save_file_name,load_file_name,
termination;
algol copy.1 <* schould be taken from m290xdec *>;
<* fixed bit long values *>
long array bits(0:48);
long prom_code, <* the value not to destroy the used prom *>
nop_code; <* the code which will perform nothing abd continue
with the next micro instr.*>
procedure init_HEAP;
<******************************>
begin
integer index;
refference_first_free := 2*2;
for index := 2 step 2 until HEAP_length do
begin
HEAP(index-1) := index*2-4; <* points to previus element *>
HEAP(index) := index*2+4; <* point to next element *>
refference_last_free := index*2;
end;
end init_HEAP;
integer procedure allocate(no_of_halfwords);
<******************************************>
value no_of_halfwords; integer no_of_halfwords;
begin
allocate := refference_first_free - 4;
if ( no_of_halfwords mod 4) <> 0 then
no_of_halfwords := no_of_half_words + (4 -(no_of_halfwords mod 4));
refference_first_free := refference_first_free + no_of_half_words;
if refference_first_free > refference_last_free then
fatal_error(<:REFFERENCE TABLE LENGTH EXEEDED:>);
end allocate;
procedure fatal_error(error_text);
<********************************>
string error_text;
begin
print_error_table;
write(out,"nl",1,"*",5,"sp",1,error_text,"nl",1,
"sp",7,<:RUN ABORT:>);
fp_proc(7,0,0,0);
end fatal_error;
procedure error(error_text,line_no,element_pos);
<**********************************************>
value error_text,line_no,element_pos;
long error_text;
integer line_no,element_pos;
begin
error_in_this_line := true;
no_of_errors := no_of_errors + 1;
error_record := allocate(error_record_length);
HEAP.error_record.error_record_chain := error_record_chain_head;
error_record_chain_head := error_record;
HEAP.error_record.error_record_text := error_text;
HEAP.error_record.error_record_line_no := line_no;
HEAP.error_record.error_record_element_pos := element_pos;
HEAP.error_record.error_record_instr_index := instr_index;
end error;
boolean procedure new_lookup_name(name,name_record_index,name_type);
value name; long name;
integer name_record_index,name_type;
begin
long array field look_name_record;
boolean found;
found := false;
name_record_index := calculate_hash_key(name);
look_name_record := search_table(name_record_index);
while look_name_record <> nil and -,found do
begin
if name = HEAP.look_name_record.name_name then
found := true
else
look_name_record := HEAP.look_name_record.name_name;
end;
name_record_index := look_name_record;
new_lookup_name := found;
end new_lookup_name;
integer procedure new_insert_name(name,reff_index,type,record_length);
value name,type,record_length;
long name;
integer reff_index,type,record_length;
begin
integer array field insert_name_record;
integer hash_key;
hash_key := calculate_hash_key(name);
insert_name_record := allocate(record_length);
new_insert_name := insert_name_record;
reff_index := insert_name_record;
HEAP.insert_name_record.name_name := name;
HEAP.insert_name_record.name_type := type;
HEAP.insert_name_record.name_chain := search_table(hash_key);
search_table(hash_key) := insert_name_record;
end new_insert_name;
integer procedure calculate_hash_key(name);
value name; long name;
begin
calculate_hash_key := (( name extract 12) +
( name shift (-12) extract 12) +
( name shift (-24) extract 12) +
( name shift (-36) extract 12) +
( name shift (-40) extract 8) +
( name shift (-32) extract 8) +
( name shift (-24) extract 12)
)
mod search_table_length;
end calculate_hash_key;
integer procedure insert_name_table(index,name,type,reff);
value index,name,type,reff; long index,name;
integer type,reff;
begin
name_table(index,1) := name;
name_table(index,0) := type;
name_table(index,4) := reff;
end insert_name_table;
integer procedure addrs_ref(name,instr_index,line_no,element_no);
value name,instr_index,line_no,element_no;
long name;
integer instr_index,line_no,element_no;
begin
l_r_record := allocate(l_r_record_length);
HEAP.l_r_record.l_r_chain := l_r_record_chain_head;
l_r_record_chain_head := l_r_record;
HEAP.l_r_record.l_r_name := name;
HEAP.l_r_record.l_r_index := instr_index;
HEAP.l_r_record.l_r_line_no := line_no;
HEAP.l_r_record.l_r_element_no := element_no;
addrs_ref := l_r_record;
end addrs_ref;
integer procedure new_insert_label_def(name,index,instr_index,line_no,spec,spec_class);
value name,index,instr_index,spec,line_no,spec_class;
long name,index;
integer instr_index,spec,line_no,spec_class;
begin
l_d_record := allocate(l_d_record_length);
insert_name_table(index,name,label_type,l_d_record);
HEAP.l_d_record.l_d_chain := l_d_record_chain_head;
l_d_record_chain_head := index;
HEAP.l_d_record.l_d_index := instr_index;
HEAP.l_d_record.l_d_line_no := line_no;
HEAP.l_d_record.l_d_spec := spec;
HEAP.l_d_record.l_d_spec_class := spec_class;
new_insert_label_def := index;
end new_insert_label_def;
procedure resolve_labels;
begin
integer op_code_index;
long name_table_index;
long array wr_name(1:2); <* used for writing of a name *>
wr_name(2):=0;
l_r_record := l_r_record_chain_head;
while l_r_record >-1 do
begin
if -, lookup_name(name_table,HEAP.l_r_record.l_r_name,
name_table_index) then
begin
instr_index := HEAP.l_r_record.l_r_index;
error(undec_label,HEAP.l_r_record.l_r_line_no,
HEAP.l_r_record.l_r_element_no);
end
else
begin
l_d_record := name_table(name_table_index,4);
op_code_index := HEAP.l_r_record.l_r_index;
op_code(opcode_index) := mask_in(op_code(op_code_index),
extend HEAP.l_d_record.l_d_index,
addrs_mask);
if test_label_bit or test_label_ref then
begin
wr_name(1) := HEAP.l_d_record.l_d_name;
write(out,"nl",1,"sp",5,<<zddd>,
octal(extend HEAP.l_r_record.l_r_index),
<: label reff to: :>,
octal(extend HEAP.l_d_record.l_d_index),
<: name: :>,wr_name);
end;
if test_label_bit then
begin
write(out,"nl",1,"sp",11);
print_formated(op_code(op_code_index));
end;
end;
l_r_record := HEAP.l_r_record.l_r_chain;
end scan loop;
end resolve_labels;
procedure label_list(only_spec_wanted);
value only_spec_wanted; boolean only_spec_wanted;
begin
integer no_of_spec,max_spec,max_index;
long array wr_name(1:2),hex_number(1:2);
integer index;
no_of_spec := 0;
wr_name(2) := 0;
for index := 1 step 1 until name_table_length do
begin
if name_table(index,0) = label_type then
begin
l_d_record := name_table(index,4);
if HEAP.l_d_record.l_d_spec <> nil or
-, only_spec_wanted then
begin
wr_name(1) := name_table(index,1);
write(out,"sp",15 - write(out,"nl",1,wr_name),
"cr",1,"sp",7,<: reff. to address:>,
<<_zddd>,HEAP.l_d_record.l_d_index,
octal(extend HEAP.l_d_record.l_d_index),
if HEAP.l_d_record.l_d_spec = nil then <::> else
if HEAP.l_d_record.l_d_spec < 0 then
<:_line_no_:> else <:_spec.____:>,
if HEAP.l_d_record.l_d_spec <> nil then <<__dddd> else <<b>,
if HEAP.l_d_record.l_d_spec = nil then
0 else
abs HEAP.l_d_record.l_d_spec);
no_of_spec := no_of_spec + 1;
end;
end;
end for loop;
if only_spec_wanted then
begin
for spec_class := nil,map_spec ,vector_spec do
begin
if no_of_spec > 0 then
write(out,"nl",4,
if spec_class = map_spec then <: MAP ENTRIES :>
else if spec_class = vector_spec then <: VECTOR ENTIES :>
else <::>,"nl",1,
<:_name_____________spec.____instr.___octal____:>);
repeat
begin
max_spec := nil;
for index := 1 step 1 until name_table_length do
begin
if name_table(index,0) = label_type then
begin
l_d_record := name_table(index,4);
if HEAP.l_d_record.l_d_spec > max_spec and
HEAP.l_d_record.l_d_spec <> nil and
HEAP.l_d_record.l_d_spec_class = spec_class then
begin
max_spec := HEAP.l_d_record.l_d_spec;
max_index := index;
end;
end;
end loop name_table;
<* write spec *>
if max_spec <> nil then
begin
wr_name(1) := name_table(max_index,1);
l_d_record := name_table(max_index,4);
write(out,"sp",15-write(out,"nl",1,wr_name),
<<____dddd>,HEAP.l_d_record.l_d_spec,
HEAP.l_d_record.l_d_index,
octal(extend HEAP.l_d_record.l_d_index),
HEAP.l_d_record.l_d_index shift (-8),
HEAP.l_d_record.l_d_index extract 8);
<* delete label entry in name table *>
name_table(max_index,0) := nil;
no_of_spec := no_of_spec-1;
end;
end;
until max_spec = nil;
end spec_class_loo;
end only_spec_loop;
end label_list;
boolean procedure print_error_table;
begin
long array field previus,this,min_line;
integer min_line_no;
if error_record_chain_head = nil then
print_error_table := true
else
begin
print_error_table := false;
while error_record_chain_head <> nil do
begin
min_line_no := 8388606;
this := error_record_chain_head;
previus := nil;
while this <> nil do
begin
if HEAP.this.error_record_line_no <= min_line_no then
begin
min_line_no := HEAP.this.error_record_line_no;
min_line:= previus;
end;
previus := this;
this := HEAP.this.error_record_chain;
end;
<* remove record from list *>
if min_line = nil then
begin
this := error_record_chain_head;
error_record_chain_head := HEAP.this.error_record_chain;
end
else
begin
previus := min_line;
this := HEAP.previus.error_record_chain;
HEAP.previus.error_record_chain :=
HEAP.this.error_record_chain;
end;
write(out,"nl",1,<<_dddd>,
HEAP.this.error_record_line_no,
HEAP.this.error_record_instr_index,
octal(extend HEAP.this.error_record_instr_index),
HEAP.this.error_record_element_pos,
"sp",2,string HEAP.this.error_record_text);
end;
end;
end print_error_table;
procedure print_formated(opcode);
<********************************>
value opcode; long opcode;
begin
integer from,to,number,index;
from := 0;
for index :=-47 step 1 until 0 do
begin
outchar(out,if opcode shift index extract 1 = 1 then
49 else 46);
if format(from) extract 12 = 47 + index then
begin
outchar(out,32);
from:=from+1;
end;
end for loop;
<* for improving readability write an extra newline *>
outchar(out,10);
end print_format;
algol copy.2 <* source should be m290xproc *>;
integer procedure
get_all_reg_operands(op_1,kind_1,op_2,kind_2,op_3,kind_3);
<**********************************************************>
integer op_1,kind_1,op_2,kind_2,op_3,kind_3;
begin
integer no_of_op;
no_of_op := 0;
op_1 := op_2 := op_3 := kind_1 := kind_2 := kind_3 := not_used;
class := look_ahead_class;
if class = left_par_class then
begin
next;
get_a_reg_operand(op_1,kind_1);
no_of_op := 1;
if look_ahead_class = comma_class then
begin
next;
get_a_reg_operand(op_2,kind_2);
no_of_op := 2;
if look_ahead_class = comma_class then
begin
next;
get_a_reg_operand(op_3,kind_3);
no_of_op := 3;
end;
end;
next;
if class <> right_par_class then
error(termination,line_no,element_no);
end else error(missing_operand,line_no,element_no);
get_all_reg_operands := no_of_op;
end get_all_reg_operands;
<*
procedure check_unknown_operands(op_kind_1,op_kind_2,op_kind_3,op_kind_4);
value op_kind_1,op_kind_2,op_kind_3,op_kind_4;
integer op_kind_1,op_kind_2,op_kind_3,op_kind_4;
begin
integer no_of_op;
no_of_op := if op_kind_1 = not_used then 0 else
if op_kind_2 = not_used then 1 else
if op_kind_3 = not_used then 2 else
if op_kind_4 = not_used then 3 else 4;
if op_kind_1 = unknown_name_class then
error(operand,line_no,element_no - 1 -(2*(no_of_op-1)));
if op_kind_2 = unknown_name_class then
error(operand,line_no,element_no -1-(2*(no_of_op-2)));
if op_kind_3 = unknown_name_class then
error(operand,line_no,element_no - 1 - 2*(no_of_op-3));
if op_kind_4 = unknown_name_class then
error(operand,line_no,element_no -1);
end check_unkown_operands; *>
procedure get_a_reg_operand(op_value,kind);
<*****************************************>
integer op_value,kind;
begin
long lookup_index;
next;
if class = number_class then
begin
kind := number_class;
op_value := number
end
else
if class = apost_class then
begin
next;
kind := 0;
op_value := 0;
if class = unknown_name_class or
(class = text_class and type = label_type) then
begin
addrs_ref(name,instr_index,line_no,element_no);
kind := number_class;
end
else
error(operand_type,line_no,element_no);
end
else
if class = text_class then
begin
if name_table(number,0) <> reg_op_type then
begin
kind := 0;
error(operand_type,line_no,element_no)
end
else
begin
op_value := name_table(number,2);
kind := text_class;
end;
end
else
begin
kind := unknown_name_class;
error(operand,line_no,element_no);
end;
end of get_a_reg_operand;
procedure get_2_reg_operands(op_value_1,op_value_2);
integer op_value_1,op_value_2;
begin
integer kind_1,kind_2;
get_a_reg_operand(op_value_1,kind_1);
next;
if class <> comma_class then error(delimiter,line_no,element_no);
get_a_reg_operand(op_value_2,kind_2);
end of get_2_reg_operands;
integer procedure look_ahead_class;
begin
integer to; long name,number;
look_ahead_class := get_element(name,number,line_pointer,to);
end look_ahead_class;
procedure skip_until_delim_class;
begin
for class:=read_kind(line_pointer) while class <> delim_class
and class <> eof_class
and class <> stop_line_class do
line_pointer:=line_pointer + 1;
end skip_until_delim_class;
integer procedure get_long_name(long_name);
long array long_name;
begin
integer class,to;
long name,number;
class := get_element(name,number,line_pointer,to);
if class = unknown_name_class or class = text_class then
begin
get_long_name := 1;
long_name(1) := name;
long_name(2) := 0;
end
else
if class = long_text_class then
begin
long_name(1) := read_value(line_pointer);
long_name(2) := read_value(line_pointer + 2);
get_long_name := if read_kind(line_pointer + 3 ) = text_class
then -2 else 2;
end
else
get_long_name := 0;
end get_long_name;
<* the following procedures uses getnext element
to get next element into
class,name,number,type
class1,name1,number1,type2
class2,name2,number2,type2 *>
integer procedure next;
begin
next := class := get_next_element(name,number);
type := if class = text_class then name_table(number,0) else class;
end next;
integer procedure next1;
begin
next1 := class1 := get_next_element(name1,number1);
type1 := if class1 = text_class then name_table(number,0) else class1;
end next1;
integer procedure next2;
begin
next2:=class2:=get_next_element(name2,number2);
type2 := if class2 = text_class then name_table(number,0) else class2;
end next2;
integer procedure skip_next;
begin
long dummyname,dummynumber;
skip_next:=get_next_element(dummyname,dummynumber);
end skip_next;
integer procedure look;
begin
look := class := look_ahead_class;
end look;
integer procedure look1;
begin
look1 := class1 := look_ahead_class;
end look1;
integer procedure look2;
begin
look2:= class2 := look_ahead_class;
end look2;
integer procedure get_next_element(name,number);
long name,number;
begin
integer to,testclass;;
get_next_element := testclass := get_element(name,number,line_pointer,to);
element_no:=element_no+1;
line_pointer := if line_pointer = no_of_elements then line_pointer else to;
end get_next_element;
integer procedure get_element(name,number,from,to);
value from; integer from,to; long name,number;
begin
integer class;
for class:=read_kind(from) while class = delim_class do
from := from + 1;
if class = text_class then
begin
if read_kind(from+1) <> text_class or
( read_kind(from+1) = text_class and read_value(from+1) = 0) then
begin
<* short text *>
name := read_value(from);
if name = find_name(1) then found := true;
get_element := if look_up_name(name_table,name,number) then
text_class else unknown_name_class;
end
else get_element := unknown_name_class;;
<* skip to 1. not text element *>
for from := from+1 while read_kind(from) = text_class do;
to := from;
end
else
if class = plus_class then
begin
if get_integer(number,from+1,to) then get_element := 2
else get_element := 1;
end
else
if class = minus_class then
begin
if get_integer(number,from+1,to) then get_element:=2
else get_element:=1;
number:= number*(-1);
end else
if class = 2 then
begin
if get_integer(number,from,to) then get_element:=2
else get_element := 1;
end
else
if class = stop_line_class then
begin
number := read_value(from);
if number extract 24 = 25 <* eof value *> then
get_element := eof_class
else
get_element :=class;
to :=from+1;
end else
begin
number:=read_value(from);
to := from+1;
get_element := class;
end;
end get_element;
boolean procedure get_integer(number,from,to);
value from; integer from,to; long number;
begin
long base;
if read_kind(from)<> 2 then get_integer:=false
else
begin
if read_kind(from+1) = period_class then
begin
base:=read_value(from);
from:=from+2;
if read_kind(from) <> 2 then
begin
get_integer := false;
to := from-1;
end else
begin
number:=read_value(from);
get_integer:=base_convert(base,number);
to := from + 1;
end;
end else
begin
number:=read_value(from);
get_integer := true;
to := from + 1;
end;
end;
end get_integer;
boolean procedure base_convert(base,number);
long base,number;
begin
integer shift_index; long number1,number2;
number2:=0; shift_index :=0;
base_convert := true;
if base = 8 then
begin
for number1 := number mod 10 while number <> 0 do
begin
number := number // 10;
if number1>7 or number1 < 0 then base_convert := false;
number2:=number2 + number1 shift shift_index;
shift_index := shift_index+3;
end;
number := number2;
end else base_convert:=false;
end base_convert;
boolean procedure read_and_set_bits(operand);
<******************************************>
long array operand;
begin
boolean error;
error := false;
repeat
begin
next;
if class = left_par_class then
begin
if next1 <> number_class then
error := true
else
if next<> colon_class then
error := true
else
if next2 <> number_class then
error := true
else
if next <> right_par_class then
error := true;
if number_1 <= number_2 and
number_1 >= 0 and
number_2 <= no_of_bits_in_code and
-, error then
error := -, set_bits(operand,number1 extract 24,
number2 extract 24)
else error := true;
next;
end else
if class = number_class then
begin
if number >= 0 and number <= no_of_bits_in_code then
error := -, set_bits(operand,number extract 24,
number extract 24)
else error := true;
next;
end;
end;
until class <> comma_class or error;
read_and_set_bits := -, error;
end read_and_set_bits;
boolean procedure set_bits(operand,bit_low,bit_high);
<****************************************************>
value bit_low,bit_high; integer bit_low,bit_high;
long array operand;
begin
integer
index_low,
index_high,
bit_high_in_word,
bit_low_in_word,
word_index;
if bit_high < bit_low then
set_bits := false
else
begin
index_low := case ( bit_low//48) + 1 of
(1,2,3,4,5,6,7,8);
index_high := case (bit_high//48) + 1 of
(1,2,3,4,5,6,7,8);
bit_low_in_word := bit_low mod 48;
bit_high_in_word := bit_high mod 48;
if index_low = index_high then
begin
operand(index_low) := log_or(operand(index_low),
extend(-1) shift ((-48)+(bit_high_in_word+1-bit_low_in_word))
shift (47 - bit_high_in_word));
end
else
begin
operand(index_low) := log_or(operand(index_low),
extend (-1) shift ( - bit_low_in_word));
operand(index_high) := log_or(operand(index_high),
extend(-1) shift (47 - bit_high_in_word));
for word_index := index_low+1 step 1 until index_low - 1 do
operand(word_index) := -1;
end;
set_bits := true;
end;
end set_bits;
long procedure init_mask(operand,from,to);
<******************************************>
value from,to,operand; long operand; integer from,to;
init_mask:=mask_in(operand,extend (-1),
extend (-1) shift ((-48)+(to+1-from)) shift (47-to));
<* *************************************************
directive procedures section
************************************************* *>
procedure directive_skip_until;
begin
boolean until_condition_met;
long skip_end_name;
next1;
if class1 = text_class or class1 = unknown_name_class then
begin
skip_end_name := name1;
repeat
if list_all then list_line;
read_next_source_line;
if class = star_class then
begin
next1;
if name1 = long <:until:> then
begin
next1;
if class1 = colon_class then
next1;
if name1 = skip_end_name then
until_condition_met := true;
end;
end control of first token;
until until_condition_met;
end else
error(directive,line_no,element_no);
return_from_skip := true;
end directive_skip_until;
procedure directive_onlyin_logic(mode);
<********************************>
value mode; boolean mode;
<* if mode is true then skip only in is performed
else skip not in is performed *>
begin
<* check the param list to se the param
mode.<text> , where <text> schall be equal
the next element *>
long array param_name,until_name,only_name(1:2);
integer param_call_result;
boolean until_condition_met;
param_call_result := get_text_string(<:version:>,param_name);
class1 := get_long_name(only_name);
if param_call_result <> 0 or
(param_call_result = 0 and
(( mode and (param_name(1) <> only_name(1) or
param_name(2) <> only_name(2)))
or
( -, mode and param_name(1) = only_name(1) and
param_name(2) = only_name(2) ))) then
begin
<* skip until a 'until' directive is met with
with the version text as parameter. *>
until_condition_met := false;
repeat
if list_all then list_line;
read_next_source_line;
if class = eof_class then until_condition_met := true;
if class = star_class then
begin
next1;
if name1 = long <:until:> then
begin
next1;
if class1 = colon_class then
class1 := get_long_name(until_name);
if class1 > 0 and
only_name(1) =until_name(1) and
only_name(2) = until_name(2) then
until_condition_met := true;
end;
end control of first token 'colon' ;
until until_condition_met;
end skip not this version ;
return_from_skip := true;
end directive_only_in;
procedure include_source_file;
<****************************>
begin
long array file_name(1:2);
integer stack_result;
class1 := get_long_name(file_name);
if class1 > 0 then
begin
stack_result := stack_and_connect_in(file_name);
if list then list_line;
if stack_result <> 0 then
write(out,"*",4,<: copy connect error: :>,file_name,"nl",1)
else
write(out,<: micasm source : :>,file_name,"nl",1);
end else
error(directive,line_no,element_no);
end include_source_file;
procedure list_line;
<*******************>
begin
if -, line_listed then
begin
line_listed := true;
if line_num then write(out,<<dddd>,line_no);
if code_generated then
begin
if dec_code then write(out,<<_zddd>,instr_index);
if octal_code then write(out,<<_zddd>,octal(extend instr_index));
outchar(out,'sp');
end
else
begin
if dec_code then write(out,"sp",5);
if octal_code then write(out,"sp",5);
outchar(out,'sp');
end;
line_pointer := 0;
for line_pointer := line_pointer+1
while line_pointer <= no_of_elements do
begin
if read_kind(line_pointer) = 6 then
begin
write(out,string read_value(increase(line_pointer)));
line_pointer := line_pointer - 1;
end
else
if read_kind(line_pointer) = 2 then
write(out,<<d>,read_value(line_pointer))
else
outchar(out,read_value(line_pointer) extract 8);
end;
end;
end list_line;
procedure read_next_source_line;
<******************************>
begin
<* reset boolean control *>
error_in_this_line := false ;
code_generated := false;
alu_function_performed := false;
jump_sekvens_performed := false;
addrs_performed := false;
shift_condition_performed := false;
jump_addrs_performed := false;
line_listed := false;
line_pointer := 1;
element_no := 0;
no_of_elements := read_all(in,read_value,read_kind,1);
line_no := line_no + 1;
next;
end read_next_source_line;
plus_label_dec := long <:plus label dec.:>;
declaration := long <:declaration:>;
operand_type := long <:operand type:>;
minus_delim := long <:minus delim.:>;
missing_operand := long <:missing operand.:>;
label_dec:= long <:label dec.:>;
illegal_type := long <:illegal type:>;
plus_name_dec := long <:plus name dec.:>;
name_unknown := long <:name unknown:>;
directive := long <:directive:>;
unknown := long <:unknown:>;
name_length := long <:name length exeedes 6 char.:>;
delimiter := long <:delimiter:>;
undec_label := long <:undec. label or addrs. :>;
multiple_function := long <:multiple function.:>;
plus_addrs_def := long <:plus addrs def.:>;
minus_addrs_def := long <:minus addrs. def.:>;
illegal_source := long <:illegal source:>;
illegal_dest := long <:illegal destination:>;
illegal_dest_and_source := long <:illegal destination and or source :>;
save_file_name := long <:illegal save file name:>;
load_file_name := long <:illegal load file name:>;
termination := long <:termination:>;
operand := long <:unknown operand:>;
algol copy.3 <* schould be m290xinit *>;
init_long_array(name_table,-1);
init_HEAP;
<* init of fields *>
no_of_errors := 0;
error_record_chain_head := nil;
error_record_text := 4;
error_record_line_no := 8;
error_record_element_pos := 10;
error_record_chain := 6;
error_record_instr_index := 12;
error_record_length := 12;
l_d_record_chain_head := nil;
l_d_name := 4;
l_d_chain := 8;
l_d_spec := 2;
l_d_index := 4;
l_d_line_no := 6;
l_d_spec_class := 10;
l_d_record_length := 10;
map_spec := 1; vector_spec := 2;
l_r_chain := 2;
l_r_name := 6;
l_r_index := 8;
l_r_line_no := 10;
l_r_element_no := 12;
l_r_record_length := 12;
l_r_record_chain_head :=nil; <* no label refference blocks *>
name_name := 8;
name_chain := 2;
name_type := 4;
name_record_length := 8;
name_table(0,0) := name_table_length;
<* asm. begin *>
prom_code := -1;
for index := 0 step 1 until length_of_code-1 do
opcode(index):=prom_code;
begin
integer array tail(1:20);
zone dummy(128,1,stderror);
real r;
integer i,j,lookup_result;
long array mic_asm_prog_name,program_name(1:2);
i:=system(2,j,program_name);
open(dummy,4,programname,0);
lookup_result:=monitor(42,dummy,0,tail);
write(out,"ff",1,<:Micro asm.:__:>,true,12,program_name,
<: version date.:>,
<<zddddd.dddd>,systime(6,tail(6),r) + r/1000000,"nl",1);
close(dummy,true);
if connect_file_in(mic_asm_prog_name) = 4 then
write(out,"nl",1,"*",5,<:Source file connect error::>,
mic_asm_prog_name);
get_connected_name(in,micasm_prog_name);
lookup_result:=monitor(42,in,0,tail);
write(out,"nl",1,<:Source file:_:>,true,12,
mic_asm_prog_name,<: version date.:>,
<<zddddd.dddd>,systime(6,tail(6),r)+r/1000000,"nl",1);
<* control if any and get name of object file *>
if get_left_side(object_file_known_name) = 0 then
object_file_known := true else object_file_known := false;
if object_file_known then
begin
open(dummy,0,object_file_known_name,0);
lookup_result := monitor(42) lookup tail:(dummy,0,tail);
if lookup_result <> 0 then
object_file_known := false;
write(out,"nl",1,if object_file_known then
<:Object file:_:> else <:*** Unknown object file::>,
true,12,object_file_known_name);
if object_file_known then
write(out,<: version date.:>,
<<zddddd.dddd>,systime(6,systime(7,0,0.0),r)+r/1000000);
outchar(out,'nl');
close(dummy,true);
end;
end block with control of files;
<* get and control of other parameters,
unknown parameters is ignored. *>
get_bool_string(<:help:>,help_wanted);
if help_wanted then help_string(<:micasmhelp:>);
if get_bool_string(<:message:>,message_list) <> 0 then
message_list := true;
list_all := false;
if get_bool_string(<:list:>,list) <> 0 then
begin
long array param_name(1:2);
if get_text_string(<:list:>,param_name) = 0 then
begin
if param_name(1) = long <:all:> then list:=list_all := true;
end;
end;
if get_bool_string(<:linenum:>,line_num) <> 0 then line_num:= true;
if get_bool_string(<:deccode:>,dec_code) <> 0 then dec_code := true;
if get_bool_string(<:octal:>,octal_code) <> 0 then
begin
octal_code := true;
if get_text_string(<:octal:>,param_name) = 0 then
begin
if param_name(1) = long <:only:> then dec_code:= line_num := false;
end;
end;
if get_text_string(<:find:>,find_name) = 0 then find := true;
if get_bool_string(<:errors:>,list_error_lines) <> 0 and
get_bool_string(<:errorlines:>,list_error_lines) <> 0 and
get_bool_string(<:els:>,list_error_lines) <> 0 then
list_error_lines := true;
get_bool_string(<:code:>,print_code);
get_bool_string(<:labelxref:>,test_label_ref);
get_bool_string(<:labelbit:>,test_label_bit);
get_bool_string(<:entry:>,entry_list_wanted);
get_bool_string(<:bitlines:>,list_bit_lines);
return_from_skip := false;
<* initializing of counting variables and
reading of first code line *>
instr_index:=0;
present_code := nop_code;
error_in_this_line := false;
line_no := 0;
read_next_source_line;
while class <> eof_class do
begin
if class = stop_line_class then
begin
<*
end line , or
comment . Commant wil be be created by
get_next_element *>
if (list or (error_in_this_line and list_error_lines )
or ( find and found ))
and ( -, return_from_skip or list_all) then
list_line;
return_from_skip := false;
found := false;
if print_code and code_generated then
begin
if -, list and -, list_bit_lines and
-, (error_in_this_line and list_error_lines) then
write(out,<<-zddd>,instr_index,
octal(extend instr_index),"sp",1)
else
if -, list and list_bit_lines and
-, (error_in_this_line and list_error_lines) then
begin
list_line;
write(out,<: :>);
end
else
write(out,<: :>);
print_formated(present_code);
outchar(out,10);
end;
if code_generated then
begin
op_code(instr_index):=present_code;
instr_index:=instr_index+1;
present_code := nop_code;
end;
<* read next line of source text *>
read_next_source_line;
end class 2 new line
else
if class = text_class or class = unknown_name_class then
begin
class_2 := look_ahead_class;
if class_2 = colon_class or class_2 = slash_class then
begin
spec_class := nil;
if element_no = 1 and class = unknown_name_class then
begin
if class2 = slash_class then
begin
skip_next;
look2;
if class2 = quote_class or class2 = double_quote_class then
begin
spec_class := if class2 = quoteclass then map_spec else vectorspec;
skip_next; <* skip quote or double quote *>
look2;
end;
if class2 = number_class or class2 = colon_class then
begin
if class_2 = number_class then
begin
next1;
class2 := look_ahead_class;
end
else
number_1 := line_no;
if class2 = colon_class then
begin
new_insert_label_def(name,number,instr_index,line_no,
number1 extract 24,spec_class);
end else
error(directive,line_no,element_no);
end
else
error(directive,line_no,element_no);
end
else
begin
new_insert_label_def(name,number,instr_index,line_no,
nil,spec_class)
end;
next;
end
else
error(label_dec,line_no,element_no);
next;
end
else
begin
if class = unknown_name_class then
begin
error(name_unknown,line_no,element_no);
skip_until_delim_class;
next;
end
else
if name_table(number,0) = alu_function_type then
alu_function
else
if name_table(number,0) = jump_addrs_type then
jump_addrs
else
if name_table(number,0) = jump_sekvens_type then
jump_sekvens
else
if name_table(number,0) = load_counter_type then
load_counter
else
if name_table(number,0) = special_type then
special
else
begin
error(illegal_type,line_no,element_no);
next
end;
end;
end type equal identifier
else
if class = star_class then
begin
<* After star is assm. directive,
1 direktive pr. line,
after the direktive the rest of the line is skipped,
the direktive schould be the first element in the line *>
if code_generated then error(directive,line_no,element_no)
else
begin
next1;
next2;
if (class1 <> 9 and class1 <> 6 ) or class2 <> colon_class <*colon*> then
error(long <:test dir 1 :>,line_no,if class2 <> colon_class then element_no else
element_no -1)
else
begin
if name1 = long <:name:> then
begin
next1;
if class1 <> 9 then
error(if class1 <> 6 then long <:test dir 2.:> else
plus_name_dec,line_no,element_no)
else
begin
name_table(number1,1) := name1;
index:=0;
for class2 := next2
while class2 = comma_class and index < 5 do
begin
next2;
if class2 = number_class then
name_table(number1,index) := number2
else
if class2 = 6 <* defined name *> then
name_table(number1,index) := number_2
else
begin
error(long <:test dir. 3:>,line_no,element_no);
index:=100;
end;
if index = 0 then index :=2 else
if index<100 then index:=index+1;
end;
end;
end else
if name1 = long <:const:> then
begin
next1;
if class1 <> 9 then
error(if class1 <> 6 then directive else
plus_name_dec,line_no,element_no)
else
begin
next2;
if class2 = comma_class then
begin
next2;
if class2 = number_class then
begin
new_insert_label_def(name1,number1,
number2 extract 12,line_no,nil,nil);
end
else error(directive,line_no,element_no);
end
else error(directive,line_no,element_no);
end;
end else
if name1 = long <:mask:> then
begin
long array operand(1:1); <* only one word used *>
boolean mask_succes;
long mask_name,mask_number;
operand(1) := 0;
if next1 <> unknown_name_class then
error(long <: directive 2:>,line_no,element_no)
else
if next2 <> comma_class then
error(long <:directive 3:>,line_no,element_no)
else
begin
mask_name := name1;
mask_number := number1;
mask_succes := read_and_set_bits(operand);
if -, mask_succes then
error(long <:directive 4:>,line_no,element_no)
else
begin
name_table(mask_number,0) := mask_type;
name_table(mask_number,1) := mask_name;
name_table(mask_number,2) := operand(1);
end;
end;
end else
if name1 = long <:origo:> then
begin
if next1 <> number_class then
error(long <:test dir. 4:>,line_no,element_no)
else
instr_index := number1;
end
else
if name1 = long <:list:> then
begin
next1;
if name1 = long <:on:> or name1 = long <:yes:> then
list := true
else
if name1 = long <:off:> or name1 = long <:no:> then
list := false
else
error(long <:test dir 5:>,line_no,element_no)
end else
if name1 = long <:page:> then
begin
if list then
outchar(out,12);
end else
if name1 = long <:skip:> then
begin
<* procedure skip logic *>
directive_skip_until;
end else
if name1 = long <:onlyi:> add 'n' then
begin
<* procedure skip if not in named mode *>
directive_onlyin_logic(true);
end else
if name1 = long <:notin:> then
begin
<* skip if named mode *>
directive_onlyin_logic(false <* invert the onlyin logic *>);
end else
if name1 = long <:until:> then
begin
<* a until directive met outside the
performing of the skip logic is blind *>
return_from_skip := true;
end else
if name1 = long <:load:> then
begin
zone zntb(128,1,stderror);
long array long_name(1:2);
integer move_count,no_of_halfwords;
long array field move_index;
move_index := -4;
class1 := get_long_name(long_name);
if class1 >0 then
begin
open(zntb,4,longname,0);
movecount:=(name_table_length +1)* 5 <*dimension*> * 4 <*halfwords*>;
for movecount :=movecount while movecount > 0 do
begin
no_of_halfwords := if move_count > 512 then 512 else
move_count;
move_count := move_count - no_of_halfwords;
inrec6(zntb,no_of_halfwords);
to_from(name_table.move_index,zntb,no_of_half_words);
move_index := move_index + no_of_half_words;
end read and move;
end else error(load_file_name,0,0);
if false then
begin
<******* test *******>
write(out,<:<12>load contents of name table::>);
for move_count :=0 step 1 until name_table_length do
write(out,<:<10>:>,move_count,name_table(move_count,0),
name_table(move_count,1),
name_table(move_count,2),
name_table(move_count,3),
name_table(move_count,4));
end test;
end else
if name1 = long <:save:> then
begin
zone zntb(128,1,stderror);
integer movecount,no_of_half_words;
integer array field move_index;
long array long_name(1:2);
class1:=get_long_name(long_name);
if class1>0 then
begin
open(zntb,4,long_name,0);
if false then
begin
<***** test ***>
write(out,<:<12>contents of saved name table::>);
for move_count := 0 step 1 until name_table_length do
write(out,<:<10>:>,movecount,name_table(move_count,0),
name_table(move_count,1),
name_table(move_count,2),
name_table(move_count,3),
name_table(move_count,4));
end test;
movecount := (name_table_length +1)* 5 <*dimmension*> * 4 <*halfwords*>;
move_index := -4;
for movecount := movecount while movecount > 0 do
begin
no_of_halfwords := if movecount > 512 then 512 else
movecount;
movecount := movecount - no_of_half_words;
outrec6(zntb,no_of_half_words);
tofrom(zntb,name_table.move_index,no_of_half_words);
move_index := moveindex + no_of_half_words;
end move and write;
close(zntb,true);
end else error(save_file_name,0,0);
end else
if name1 = long <:end:> then
begin
class := eof_class;
if list then list_line;
end else
if name1 = long <:copy:> then
begin
include_source_file;
end
else
if name1 = long <:test:> then
begin
next;
if class <> 9 and class <> 6 then
error(long <:test dir t1:>,line_no,element_no)
else
begin
if name = long <:on:> or name = long <:yes:> then
test := true
else
if name = long <:off:> or name = long <:no:> then
test := false
else
if name = long <:biton:> or name = long <:bitye:> add 115 then
print_code := true
else
if name = long <:bitof:> add 102 or name = long <:bitno:> then
print_code := false
else
if name = long <:labre:> add 102 then
test_label_ref := true
else
if name = long <:labbi:> add 116 then
test_label_bit := true
else error(directive,line_no,element_no);
end;
end
else
error(long <:unknown directive:>,line_no,element_no-1);
end;
end;
class := if class <> eof_class then stop_line_class
else eof_class;
end directive class
else
if class = semicolon_class then
begin
<*
comment start *>
class := stop_line_class;
end
else
if class = long_text_class then
begin
error(name_length,line_no,element_no);
next;
end
else
begin
<* class is something else *>
error(delimiter,line_no,element_no);
next;
end;
if class = eof_class then
begin
long array mic_asm_prog_name(1:2);
integer result;
result := connect_file_in(mic_asm_prog_name);
if result = 0 then
begin
write(out,"nl",1,<: micasm source file: :>,mic_asm_prog_name);
read_next_source_line;
end;
end;
end scan loop;
last_instr_index := instr_index ;
resolve_labels;
<* temp delete
for index:=1 step 1 until label_ref_index do
begin
name := label_ref_table(index,0);
if -, lookup_name(label_def_table,name,number) then
begin
instr_index := label_ref_table(index,2);
error(undec_label,label_ref_table(index,1) extract 24,
label_ref_table(index,3) extract 24)
end
else
begin
op_code(label_ref_table(index,2)):=
mask_in(op_code(label_ref_table(index,2)),
extend ( label_def_table(number,0) extract 24),addrs_mask);
if test_label_bit or test_label_ref then
begin
write(out,"nl",1,"sp",5,<<zddd>,
octal(label_ref_table(index,2)),
<: label ref to: :>,
octal(label_def_table(number,0)));
if test_label_bit then
begin
write(out,<:<10> :>);
print_formated(opcode(label_ref_table(index,2)));
end;
end;
end;
end label insert loop;
if entry_list_wanted then
begin
<@ print label xref table @>
procedure shellsort(n,file);
value n;
integer n;
long array file;
begin
integer dist,i,k0,k,kmd;
long a,fkmd,a_help,fkmd_help;
dist:= -1;
for dist:= dist shift(-1) while dist>0 do
if dist<n then
begin
for k0:= dist+1 step 1 until n do
begin
a:= file(k0,1);
a_help := file(k0,2);
k:= k0;
p: kmd:= k-dist;
if kmd>0 then
begin
fkmd:= file(kmd,1);
fkmd_help := file(kmd,2);
if fkmd>a then
begin
file(k,2) := fkmd_help;
file(k,1):= fkmd;
k:= kmd;
goto p
end
end;
file(k,1):= a;
file(k,2) := a_help;
end
end
end;
integer sort_index;
long array wr_name(1:2);
comment
shell_sort(label_def_table_length,label_def_table);
wr_name(2):=0;
for index := 1 step 1 until label_def_table_length do
begin
l_d_record := ((index-1)*8)+4;
if label_def_table(index,0) > 0 and
(label_def_table.l_d_record.l_d_spec >0)
then
begin
wr_name(1):= label_def_table(index,1);
write(out,false add 32,15 -
write(out,<:<10>:>,wr_name),
<:<13> :>,<: ref. to addrs.::>,
<<__zddd>,
label_def_table.l_d_record.l_d_index,
octal(extend label_def_table.l_d_record.l_d_index),
<: spec or line no.::>,label_def_table.l_d_record.l_d_spec -1);
end;
end;
end write xref label table loop;
end of temp delete *>
if test_label_ref then label_list(false);
if entry_list_wanted then label_list(true);
if print_error_table then
write(out,<:<10>MIC. ASM. OK! :>)
else
write(out,<:<10>MIC. ASM. SORRY!:>,<<_ddd>,no_of_errors,<: error(s):>,
<: found.:>);
write(out,"nl",1,<:LAST INSTR. ADDRS.::>,<<_dddd>,last_instr_index,
<: OCTAL INSTR. ADDRS.::>,octal(extend(last_instr_index)));
if object_file_known then
begin
zone code_out(128,1,stderror);
long array field code_block;
integer short_clock;
index :=1;
open(code_out,4,object_file_known_name(increase(index)),0);
setposition(code_out,0,1); <* start on segm 1. due to
historic reasons *>
for code_block :=-4,code_block + 512
while code_block < 4*length_of_code - 4 do
begin
outrec6(code_out,512);
to_from(code_out,op_code.code_block,512);
end;
for index := 1 step 1 until 10 do tail(index):=0;
tail(1) :=1 + ( length_of_code//128);
tail(6) := systime(7)short clock:(0,0.0);
tail(9) := code_kind shift 12 + start_addrs extract 12;
tail(10) := length_of_code*4 + 512 <* first segm is dummy *>;
monitor(44)change entry:(code_out,0,tail);
close(code_out,true);
end send object code to backing storage area;
end dec of table block;
write(out,<: TRANSLATOR BLOCKS::>,<<__d>,blocksread,"nl",1);
fp_proc(7,0,0,0); <* end program *>
end the whole prog;
▶EOF◀