|
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: 139776 (0x22200)
Types: TextFile
Names: »listtrans03«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »listtrans03«
t290xasm d.810603.1330
0 1 begin
1 2 message version 790505;
1 3 algol copy.tcgproclib;
tcgproclib d.800929.1732
1 3 procedure init_long_array(arr,init);
1 4 <***********************************>
1 5 value init; integer init;
1 6 long array arr;
1 7 begin
2 8 <* intialize an array of type long with the value of init *>
2 9 integer upper_bound,lower_bound;
2 10 long array field laf1,laf2;
2 11 lower_bound := system(3,upper_bound,arr);
2 12 laf1:= 4 * lower_bound; laf2 := laf1 - 4;
2 13 arr.laf2(1) := extend init;
2 14 tofrom(arr.laf1,arr.laf2,(upper_bound - lower_bound) * 4);
2 15 end init_long_table;
1 16 procedure std_table(table);
1 17 <*************************>
1 18 integer array table;
1 19 begin integer i;
2 20 for i:=0 step 1 until 127 do
2 21 table(i):= case i+1 of
2 22 ( 0,7,7,7,7,7,7,7,7,7,8,7,8,0,7,7,
2 23 7,7,7,7,7,7,7,7,7,8,7,7,7,7,7,7,
2 24 7,7,7,7,7,7,7,5,7,7,7,3,7,3,4,7,
2 25 2,2,2,2,2,2,2,2,2,2,7,7,7,7,7,7,
2 26 7,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
2 27 6,6,6,6,6,6,6,6,6,6,6,6,6,6,7,7,
2 28 7,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
2 29 6,6,6,6,6,6,6,6,6,6,6,6,6,6,7,0) shift 12 + i;
2 30 end std_table;
1 31 \f
1 31
1 31
1 31
1 31 message cg proc lib 800408 page xx;
1 32 integer procedure get_bool_string(search_string,result);
1 33 <*******************************************************>
1 34 string search_string; boolean result;
1 35 begin
2 36 long array search_name(1:2);
2 37 real array field raf;
2 38 raf := 0;
2 39 movestring(search_name.raf,1,search_string);
2 40 get_bool_string := get_bool_arg(search_name,result);
2 41 end get_bool_string;
1 42
1 42 boolean procedure bool_arg_string(search_string);
1 43 <************************************************>
1 44 string search_string;
1 45 begin
2 46 boolean result;
2 47 long array search_name(1:2);
2 48 real array field raf;
2 49 raf := 0;
2 50 movestring(search_name.raf,1,search_string);
2 51 get_bool_arg(search_name,result);
2 52 bool_arg_string := result;
2 53 end bool_arg_string;
1 54
1 54
1 54
1 54 integer procedure get_bool_arg(search_name,result);
1 55 <**************************************************>
1 56 long array search_name;
1 57 boolean result;
1 58 begin
2 59 long array param_name,match_name(1:2);
2 60 integer sep_and_length,item_no;
2 61 boolean default;
2 62 real array field raf;
2 63 raf := 0;
2 64 result := default := false;
2 65
2 65 if search_param_name(search_name,item_no) = 0 then
2 66 begin
3 67 get_bool_arg := 0;
3 68 item_no := item_no + 1;
3 69
3 69 if system(4,item_no,param_name) extract 12 = 10 then
3 70 begin
4 71 if param_name(1) = long <:yes:> or
4 72 param_name(1) = long <:ja:> then
4 73 result := true
4 74 else
4 75 if param_name(1) = long <:no:> or
4 76 param_name(1) = long <:nej:> then
4 77 result := false
4 78 else
4 79 get_bool_arg := 4;
4 80 end
3 81 else
3 82 get_bool_arg :=4;
3 83 end
2 84 else
2 85 get_bool_arg := 2;
2 86 end get_bool_arg;
1 87 message cg proc lib 800707;
1 88 integer procedure get_text_string(search_string,return_name);
1 89 string search_string; long array return_name;
1 90 begin
2 91 long array search_name(1:2);
2 92 real array field raf;
2 93 raf := 0;
2 94 movestring(search_name.raf,1,search_string);
2 95 get_text_string := get_text_arg(search_name,return_name);
2 96 end get_text_string;
1 97
1 97 integer procedure get_text_arg(search_name,return_name);
1 98 <*******************************************************>
1 99 long array search_name,return_name;
1 100 begin
2 101 integer item_no,sep_and_length;
2 102 real array field raf;
2 103 raf := 0;
2 104 if search_param_name(search_name,item_no) = 0 then
2 105 begin
3 106 item_no := item_no + 1;
3 107 sep_and_length := system(4,item_no,return_name.raf);
3 108 if sep_and_length extract 12 = 10 then
3 109 get_text_arg := 0
3 110 else
3 111 get_text_arg := 4;
3 112 end
2 113 else get_text_arg := 2;
2 114 end get_text_arg;
1 115 message cg proc lib 800707;
1 116 integer procedure get_int_string(search_string,return);
1 117 <*****************************************************>
1 118 string search_string; integer return;
1 119 begin
2 120 long array search_name(1:2);
2 121 real array field raf;
2 122 raf := 0;
2 123 movestring(search_name.raf,1,search_string);
2 124 get_int_string := get_int_arg(search_name,return);
2 125 end get_int_string;
1 126
1 126
1 126 integer procedure get_int_arg(search_name,return);
1 127 <************************************************>
1 128 long array search_name;
1 129 integer return;
1 130 begin
2 131 integer sep_and_length,item_no;
2 132 long array param_name(1:2);
2 133 real array field raf;
2 134 raf := 0;
2 135 if search_param_name(search_name,item_no) = 0 then
2 136 begin
3 137 item_no := item_no + 1;
3 138 sep_and_length := system(4,item_no,param_name.raf);
3 139 if system(4,item_no,param_name.raf) extract 12 = 4 then
3 140 begin
4 141 return := param_name.raf(1);
4 142 get_int_arg := 0;
4 143 end
3 144 else
3 145 get_int_arg := 4;
3 146 end
2 147 else
2 148 get_int_arg := 2;
2 149 end get_int_arg;
1 150
1 150 integer procedure get_int_set_arg(search_name,return_set,no_in_set);
1 151 <******************************************************************>
1 152 long array search_name;
1 153 long array return_set;
1 154 integer no_in_set;
1 155 begin
2 156 integer sep_and_length,
2 157 item_no,
2 158 set_index,
2 159 low_set,
2 160 high_set;
2 161 long array param_name(1:2);
2 162 real array field raf;
2 163 raf := 0;
2 164 low_set := system(3,high_set,return_set);
2 165 set_index := low_set;
2 166
2 166 no_in_set := 0;
2 167 if search_param_name(search_name,item_no) = 0 then
2 168 begin
3 169 for item_no := item_no + 1 while
3 170 set_index <= high_set
3 171 and
3 172 system(4,item_no,param_name.raf) = 8 shift 12 + 4 do
3 173 begin
4 174 return_set(set_index) := param_name.raf(1);
4 175 set_index := set_index + 1;
4 176 end;
3 177
3 177 no_in_set := set_index - low_set;
3 178 get_int_set_arg := if low_set = set_index then 4 else 0;
3 179 end
2 180 else get_int_set_arg := 2;
2 181 end get_int_set_arg;
1 182
1 182 integer procedure get_int_set_string(search_string,return_set,no_in_set);
1 183 string search_string;
1 184 long array return_set;
1 185 integer no_in_set;
1 186 begin
2 187 long array search_name(1:2);
2 188 real array field raf;
2 189 raf := 0;
2 190 movestring(search_name.raf,1,search_string);
2 191 get_int_set_string := get_int_set_arg(search_name,return_set,no_in_set);
2 192 end get_int_set_string;
1 193
1 193
1 193 message cg proc lib 800707;
1 194
1 194
1 194 integer procedure search_param_name(search_name,item_no);
1 195 <*******************************************************>
1 196 long array search_name;
1 197 integer item_no;
1 198 begin
2 199 integer search_no,sep_and_length;
2 200 long array param_name(1:2);
2 201 boolean found;
2 202 real array field raf;
2 203 raf := 0;
2 204 found := false;
2 205 search_no := if get_left_side(param_name) = 0 then 2 else 1;
2 206 search_param_name := 2;
2 207 if search_name(1) extract 8 = 0 then search_name(2) := 0;
2 208 for sep_and_length := system(4,search_no,param_name.raf) while
2 209 sep_and_length <> 0 and -, found do
2 210 begin
3 211
3 211 if param_name(1) = search_name(1) and
3 212 param_name(2) = search_name(2) then
3 213 begin
4 214 item_no := search_no;
4 215 found := true;
4 216 search_param_name := 0;
4 217 end
3 218 else search_no := search_no + 1;
3 219
3 219 end;
2 220 end search_param_name;
1 221
1 221 integer procedure get_left_side(param_name);
1 222 <******************************************>
1 223 long array param_name;
1 224 begin
2 225 integer sep_and_length;
2 226 real array field raf;
2 227 raf := 0;
2 228
2 228 get_left_side := 2;
2 229 if system(4,1,param_name.raf) = 6 shift 12 + 10
2 230 <* fp left side *> then
2 231 begin
3 232 get_left_side :=0;
3 233 sep_and_length := system(4,0,param_name.raf);
3 234 end;
2 235 end get_left_side;
1 236
1 236 integer procedure get_next_free_text(param_name);
1 237 <***********************************************>
1 238 long array param_name;
1 239 begin own integer no;
2 240 get_next_free_text := get_free_text(no+1,param_name);
2 241 no := no + 1;
2 242 end get_next_free_text;
1 243
1 243 integer procedure get_free_text(no,param_name);
1 244 <**********************************************>
1 245 value no;
1 246 integer no;
1 247 long array param_name;
1 248 begin
2 249 real array look_ahead_param(1:2);
2 250 real array field raf;
2 251 integer start_index,sep_and_length,no_found;
2 252 raf:=0;
2 253 no_found := 0;
2 254 if get_left_side(param_name) = 0 then
2 255 start_index := 2 else start_index := 1;
2 256 repeat
2 257 sep_and_length := system(4,start_index,param_name.raf);
2 258 if sep_and_length = 4 shift 12 + 10 then
2 259 begin
3 260 sep_and_length :=system(4,start_index + 1,look_ahead_param);
3 261 if sep_and_length shift (-12) < 6 then
3 262 no_found := no_found + 1;
3 263 end;
2 264 start_index := start_index+1;
2 265 until sep_and_length = 0 or no_found = no;
2 266 if no = no_found then
2 267 get_free_text := 0
2 268 else
2 269 get_free_text := 2;
2 270 end get_free_text;
1 271 message cg proc lib 800707 < connect zone > page XX;
1 272
1 272
1 272 integer procedure connect_file_in(param_name);
1 273 <***************************************>
1 274 long array param_name;
1 275 begin
2 276 own boolean called_before;
2 277 integer result;
2 278 long array empty_param_name(1:1);
2 279 empty_param_name(1) := 0;
2 280 result := get_next_free_text(param_name);
2 281 if result <> 0 and -, called_before then
2 282 begin
3 283 get_connected_name(in,param_name);
3 284 connect_file_in := 0;
3 285 end
2 286 else
2 287 if result <> 0 and called_before then
2 288 begin
3 289 connect_file_in := 2;
3 290 end
2 291 else
2 292 if result = 0 then
2 293 begin
3 294 stack_and_connect_in(empty_param_name);
3 295 connect_file_in := stack_and_connect_in(param_name);
3 296 end;
2 297 called_before := true;
2 298 end connect_file_in;
1 299
1 299
1 299 procedure get_connected_name(z,param_name);
1 300 <*****************************************>
1 301 zone z;
1 302 long array param_name;
1 303 begin
2 304 integer array tail(1:20);
2 305 getzone6(z,tail);
2 306
2 306 param_name(1) := extend tail(2) shift 24 + tail (3);
2 307 param_name(2) := extend tail(4) shift 24 + tail(5);
2 308 end get_connected_name;
1 309
1 309 integer procedure stack_and_connect_in(doc_name);
1 310 <**********************************************>
1 311 long array doc_name;
1 312 begin
2 313 <* stack current zone in if docname(1) <> 0 and
2 314 connect current zone in to docname.
2 315 if docname = 0 and in is previous stacked
2 316 then current zone in is unstacked *>
2 317 own integer stacked;
2 318 integer result;
2 319
2 319 if doc_name(1) <> 0 then
2 320 begin
3 321 fp_proc(29) stack current in :(0,in,0);
3 322 fp_proc(27) connect current in:(result,in,doc_name);
3 323 if result <> 0 then
3 324 begin
4 325 fp_proc(30) unstack current in:(0,in,0);
4 326 stack_and_connect_in := 4
4 327 end
3 328 else
3 329 begin
4 330 stacked := stacked + 1;
4 331 stack_and_connect_in := 0
4 332 end;
3 333 end
2 334 else
2 335 if doc_name(1) = 0 then
2 336 begin
3 337 if stacked > 0 then
3 338 begin
4 339 fp_proc(30) unstack current in:(0,in,0);
4 340 stacked := stacked -1;
4 341 end;
3 342 stack_and_connect_in := 0;
3 343 end docname empty;
2 344
2 344 end stack_and_connect_in;
1 345 integer procedure connect_out_to_left_side(allways,drum);
1 346 <*******************************************************>
1 347 value allways,drum; boolean allways,drum;
1 348 <* if all ways then a area is created on 1 segm
1 349 if the file is not existent then a area is created
1 350 on 1 segm. if drum the area is created on prefearable drum *>
1 351 begin
2 352 own integer connected;
2 353 integer result, create_mask;
2 354 long array docname(1:2);
2 355 result := 0;
2 356 if connected = 0 then
2 357 begin
3 358 if get_left_side(doc_name) = 0 then
3 359 begin
4 360 create_mask := if allways then ( 1 shift 2 ) else 0;
4 361 create_mask := if drum then create_mask add 1 else create_mask;
4 362 result := stack_and_connect_out(doc_name,create_mask);
4 363 if result = 0 then connected := 2 else connected := 6;
4 364 end
3 365 else
3 366 connected := 4;
3 367 end
2 368 else
2 369 if connected = 2 then
2 370 begin
3 371 fp_proc(34) close up:(0,out,25);
3 372 fp_proc(79) terminate zone :(0,out,0);
3 373 doc_name(1) :=0;
3 374 result := stack_and_connect_out(doc_name,create_mask);
3 375 connected := 6;
3 376 end;
2 377 connect_out_to_left_side := result;
2 378 end connect_out_to_left_side;
1 379 integer procedure stack_and_connect_out(doc_name,create_mask);
1 380 <**********************************************************>
1 381 value create_mask; integer create_mask; long array doc_name;
1 382 begin
2 383 own integer stacked_out;
2 384 own long stack_chain_1,stack_chain_2;
2 385 integer result;
2 386 long array stack_chain_address(1:2);
2 387
2 387 if doc_name(1) = 0 and stacked_out > 0 then
2 388 begin
3 389 stack_chain_address(1) := stack_chain_1;
3 390 stack_chain_address(2) := stack_chain_2;
3 391 fp_proc(30,0,out,stack_chain_address);
3 392 stacked_out := stacked_out -1;
3 393 stack_and_connect_out := 1;
3 394 end
2 395 else
2 396 if doc_name(1) <> 0 then
2 397 begin
3 398 stacked_out := stacked_out + 1;
3 399 fp_proc(29,0,out,stack_chain_address);
3 400 stack_chain_1 := stack_chain_address(1);
3 401 stack_chain_2 := stack_chain_address(2);
3 402 result := create_mask;
3 403 fp_proc(28) connect out:(result,out,doc_name);
3 404 if result = 0 then
3 405 stack_and_connect_out := 0 else
3 406 stack_and_connect_out := result;
3 407 end
2 408 else stack_and_connect_out := 4;
2 409 end stack_and_connect_out;
1 410 message cg proc lib 800724 < print file and help > page xx;
1 411 procedure get_doc_spec(z,mode,kind,name);
1 412 <***************************************>
1 413 zone z; integer mode,kind; long array name;
1 414 begin
2 415 integer array zone_description(1:20);
2 416 get_zone6(z,zone_description);
2 417 mode := zone_description(1) shift (-12);
2 418 kind := zone_description(1) extract 12;
2 419 name(1) := extend(zone_description(2)) shift 24
2 420 add zone_description(3);
2 421 name(2) := extend(zone_description(4)) shift 24
2 422 add zone_description(5);
2 423 end get_doc_spec;
1 424
1 424
1 424 procedure help_string(file_name_string);
1 425 <**************************************>
1 426 string file_name_string;
1 427 begin
2 428 long array file_name(1:2);
2 429 real array field raf;
2 430 raf:=0;
2 431 movestring(file_name.raf,1,file_name_string);
2 432 help(out,file_name);
2 433 end help_string;
1 434
1 434 procedure help(out,file_name);
1 435 <************************>
1 436 zone out; long array file_name;
1 437 begin
2 438 <* prints the contents of the file <file_name> on current out.
2 439 if current out is a terminal the file is printed 22 lines at
2 440 in blocks of 22 lines, after which a continuation char is
2 441 asked for.
2 442 if current out is anything else the whole file is printed.
2 443 *>
2 444
2 444 zone help_file(128,1,stderror);
2 445 integer array line(0:132); <* line of 0 contain no of last element *>
2 446 integer nextchar,linelimit,block_line_limit,
2 447 continuation_char,line_length_limit,line_no,
2 448 last_char, mode, kind;
2 449 long array out_doc_name(1:2);
2 450 boolean terminal;
2 451
2 451 integer procedure read_line;
2 452 begin
3 453 integer char;
3 454 nextchar := 1;
3 455 repeat
3 456 read_char(help_file,char);
3 457 line(next_char) := char;
3 458 next_char := next_char + 1;
3 459 until char = 'nl' or char = 'em' or next_char >= line_length_limit;
3 460 read_line := char;
3 461 line(0) := nextchar -1;
3 462
3 462 end;
2 463
2 463 procedure write_line;
2 464 begin
3 465 integer char;
3 466 for index := 1 step 1 until line(0) do
3 467 outchar(out,line(index));
3 468 end;
2 469 line_limit := 22;
2 470 line_length_limit := 79;
2 471
2 471 open(help_file,4,file_name,0);
2 472 get_doc_spec(out,mode,kind,out_doc_name);
2 473 terminal := if kind = 8 then true else false;
2 474
2 474 repeat
2 475 line_no := 0;
2 476 for line_no := line_no + 1 while last_char <> 'em' and
2 477 line_no <= line_limit do
2 478 begin
3 479 last_char := read_line;
3 480 write_line;
3 481 end;
2 482 if last_char <> 'em' and terminal then
2 483 begin
3 484 write(out,<:<10>>>> MORE HELP? type 'c' otherwise 'e' :>);
3 485 setposition(out,0,0);
3 486 repeat
3 487 read_char(in,continuation_char);
3 488 until continuation_char>32;
3 489 end;
2 490 until continuation_char <> 'c' or last_char = 'em' ;
2 491
2 491
2 491 close(help_file,true);
2 492 setposition(out,0,0);
2 493
2 493 fp_proc(7) finis program:(0,0,0);
2 494
2 494 end help;
1 495
t290xasm
1 495
1 495 integer elements_pr_line,
1 496 length_of_code,
1 497 half_words_pr_instr,no_of_bits_in_code,
1 498 HEAP_length,
1 499 search_table_length,
1 500 no_of_errors,
1 501 name_table_length,index,
1 502 code_kind,start_addrs;
1 503
1 503 integer field refference_first_free,refference_last_free;
1 504 integer comma_class,illegal_class,star_class,left_par_class,
1 505 right_par_class,period_class,plus_class,minus_class,
1 506 colon_class,semi_colon_class,equal_class,delim_class,
1 507 apost_class, <* apostrof used as address identf. in micro code *>
1 508 quote_class, <* same as above *>
1 509 double_quote_class,
1 510 slash_class, <* indicate special print for label def *>
1 511 text_class,long_text_class,number_class,
1 512 illegal_number_class,
1 513 unknown_name_class,stop_line_class,eof_class,
1 514 class,type,
1 515 class1,type1,
1 516 class2,type2,
1 517 nil, <* end off refference chain *>
1 518 label_type, <* a generel type *>
1 519 mask_type, <* type value used by type definitions value 101 *>
1 520 not_used; <* a general value used for indicating
1 521 dummy, nil and not used conditioning
1 522 initialized to max negative integer + 10 *>
1 523
1 523 long array
1 524 param_name, <* used for gettting abitrary parameters *>
1 525 find_name, <* to find and list lines with specific contents *>
1 526 current_out_name(1:2);
1 527 integer current_out_mode_and_kind;
1 528 integer array tail(1:20); <* used to change the entry of
1 529 the object code *>
1 530
1 530 boolean test,
1 531 test_label_ref,
1 532 test_label_bit,
1 533 find, <* list mode is only to special lines *>
1 534 found, <* if a special line is found
1 535 ( detected in get next element) *>
1 536 list, <* a listing of relewant lines *>
1 537 line_num, <* if listning is wanted then
1 538 is line numbers wanted default is yes *>
1 539 dec_code, <* if listning then is code numbers in
1 540 decimal wanted , default is yes *>
1 541 octal_code, <* if listning thenis code numbers wnted in
1 542 octal ( basis 8) wanted, defaulst is yes,
1 543 the parameter can be set to octal.only,
1 544 which will set line_num and dec_code to false *>
1 545 entry_list_wanted, <* list all entryes marked with slash *>
1 546 return_from_skip, <* the return to the main loop is from
1 547 some skip logic *>
1 548 list_all, <* a listing of all lines , also
1 549 lines which is skipped *>
1 550 help_wanted; <* used with parameter check *>
1 551
1 551
1 551
1 551
1 551
1 551 boolean procedure lookup_name(name_table,short_name,index);
1 552 <**********************************************************>
1 553 value short_name; long array name_table; long short_name,index;
1 554 begin
2 555 integer table_length,hash_index,prim_index;
2 556 table_length := nametable(0,0);
2 557 hash_index := (short_name extract 12) +
2 558 ( short_name shift (-12) extract 12) +
2 559 (short_name shift (-24) extract 12) +
2 560 (short_name shift (-36) extract 12);
2 561 prim_index:=hash_index mod table_length +1;
2 562 if false then
2 563 write(out,<:<10>***look::>,<<_dddd>,tablelength,<:index: :>,
2 564 hashindex,<:prim: :>,primindex,<:name: :>,string shortname);
2 565
2 565 for hash_index := hash_index mod table_length +1 while
2 566 nametable(hash_index,0) > - 1 and
2 567 name_table(hash_index,1) <> short_name and
2 568 hash_index+1 <> prim_index do;
2 569
2 569
2 569 index:=hash_index;
2 570 lookup_name := if name_table(hash_index,1) = short_name
2 571 then true else false;
2 572 if false then
2 573 write(out,<: index::>,<<_dddd>,hash_index,
2 574 name_table(hashindex,0),<: :>,string nametable(hash_index,1));
2 575 end look_up_name;
1 576
1 576 long present_code, <* the object code handled now *>
1 577 name,number,name1,
1 578 number1,name2,number2; <* variables for lookup in
1 579 tables , and reading from source *>
1 580
1 580
1 580 procedure present(func_value,func_mask);
1 581 <**************************************>
1 582 value func_value,func_mask; long func_value,func_mask;
1 583 begin
2 584 present_code := mask_in(present_code,func_value,func_mask);
2 585 end present;
1 586
1 586
1 586
1 586
1 586
1 586 long procedure mask_in(code,func_value,func_mask);
1 587 <*************************************************>
1 588 value code,func_value,func_mask;
1 589 long func_value,func_mask, code;
1 590 begin
2 591 integer init_shift,func_bit,mask_bit;
2 592 long instr,long_one,long_all;
2 593 init_shift := 0;
2 594 long_one := 1; long_all := -1;
2 595
2 595 for mask_bit := func_mask extract 1 while func_mask <> 0 do
2 596 begin
3 597 if mask_bit = 1 then
3 598 begin
4 599 if func_value extract 1 = 1 then
4 600 code := logor(code,long_one shift init_shift)
4 601 else
4 602 code := logand(code,exor(long_all,long_one shift init_shift));
4 603 func_value := func_value shift (-1);
4 604 end;
3 605 func_mask := func_mask shift (-1);
3 606 init_shift := init_shift +1;
3 607 end;
2 608 mask_in := code;
2 609 end mask_in;
1 610
1 610
1 610
1 610
1 610 long procedure octal(number);
1 611 value number; long number;
1 612 begin
2 613 integer index,tal;
2 614 tal:=0;
2 615 for index:=1,index*10 while number <> 0 do
2 616 begin
3 617 tal := tal + (index*(number extract 3 ));
3 618 number := number shift (-3);
3 619 end;
2 620 octal := tal;
2 621 end octal;
1 622
1 622
1 622 integer array read_table(0:383);
1 623
1 623 <* init of read classes *>
1 624 illegal_class := 10;
1 625 star_class := 11;
1 626 comma_class := 12;
1 627 <* ille_gal_class_2 := 13; *>
1 628 left_par_class := 14;
1 629 right_par_class :=15;
1 630 period_class := 16;
1 631 minus_class := 17;
1 632 colon_class := 18;
1 633 semi_colon_class := 19;
1 634 equal_class := 20;
1 635 plus_class := 21;
1 636 quote_class := apost_class := 23;
1 637 slash_class := 24;
1 638 double_quote_class := 25;
1 639 delim_class := 7; <* space and / is resent delim*>
1 640 text_class := 6;
1 641 long_text_class := 5;
1 642 number_class := 2;
1 643 illegal_number_class := 1;
1 644 unknown_name_class := 9 ; <* short or long name *>
1 645 stop_line_class := 8;
1 646 eof_class := 22; <* this is not in read_table but is calc.
1 647 in get_next_element *>
1 648 not_used := -8388598 ;
1 649
1 649 iso_table(read_table);
1 650 <* 0 - 127 is modified std_table *>
1 651 <* 128- 255 is
1 652 comment shift table
1 653 256 - 383 is comment text table *>
1 654
1 654 for index := 128 step 1 until 255 do
1 655 read_table(index) := 1 shift 12 + 256;
1 656 semi_colon_class := 19;
1 657 read_table(128+59):=semi_colon_class shift 12 + 59;
1 658 for index:= 256 step 1 until 383 do
1 659 read_table(index):= 6 shift 12 + (index-256);
1 660 read_table(256+0) := 0 shift 12 + 0;
1 661 read_table(256+10) := 1 shift 12 + 0;
1 662 read_table(256+12) := 1 shift 12 + 0;
1 663 read_table(256+13) := 0 shift 12 + 0;
1 664 read_table(256+25) := 1 shift 12 + 0;
1 665 read_table(256+127) := 0 shift 12 + 127;
1 666
1 666
1 666 for index := 33 step 1 until 39 do
1 667 read_table(index):= illegal_class shift 12 + index;
1 668 read_table(39) := apost_class shift 12 + 39;
1 669 read_table('"'):=double_quote_class shift 12 + '"';
1 670
1 670 read_table(40):= left_par_class shift 12 + 40;
1 671 read_table(41) := right_par_class shift 12 + 41;
1 672 read_table(42) := star_class shift 12 + 42;
1 673 read_table(44):= comma_class shift 12 + 44;
1 674 read_table(46):= period_class shift 12 + 46;
1 675 read_table(47):=slash_class shift 12 + 47;
1 676 read_table(43):= plus_class shift 12 + 43;
1 677 read_table(45):= minus_class shift 12 + 45;
1 678 read_table(58):=colon_class shift 12 + 58;
1 679 read_table(59) := 1 shift 12 + 128; <* semicolon shift table *>
1 680 for index := 60 step 1 until 64 do
1 681 read_table(index) := 10 shift 12 + index;
1 682 read_table(61) := equal_class shift 12 + 61;
1 683 for index:= 94 step 1 until 96,126 do
1 684 read_table(index):= 10 shift 12 + index;
1 685 intable(read_table);
1 686
1 686
1 686
1 686
1 686
1 686
1 686 test := false;
1 687
1 687
1 687
1 687
1 687
1 687
1 687 no_of_bits_in_code := 40;
1 688 length_of_code := 1024;
1 689 search_table_length := 253;
1 690 name_table_length := 511;
1 691 HEAP_length := 5000;
1 692 nil := -8388608; <* min integer *>
1 693 label_type := 97;
1 694 mask_type := 101;
1 695
1 695 <* search for the parameter help.yes *>
1 696 get_bool_string(<:help:>,help_wanted);
1 697 if help_wanted then help_string(<:micasmhelp:>);
1 698
1 698
1 698
1 698
1 698
1 698
1 698 begin
2 699 integer instr_index,
2 700 last_instr_index,
2 701 line_no,line_no1,line_pointer,line_pointer_1,
2 702 line_pointer_2,line_pointer_3,char_value,char_value_1,char_value_2,
2 703 char_class,char_class_1,element_no,
2 704 no_of_elements,
2 705 reg_op_type,alu_function_type,jump_addrs_type,
2 706 jump_sekvens_type,load_counter_type,special_type,
2 707 condition_type,
2 708 condition_type_min,condition_type_max,
2 709 special_min,special_max;
2 710
2 710
2 710 boolean code_generated,eof,eol,alu_function_performed,
2 711 jump_addrs_performed,jump_sekvens_performed,
2 712 shift_condition_performed,addrs_performed,
2 713 print_code,object_file,
2 714 list_error_lines,
2 715 message_list,
2 716 list_bit_lines,
2 717 line_listed,
2 718 help_wanted,
2 719 error_in_this_line;
2 720 integer array format(0:no_of_bits_in_code);
2 721 long array read_value(1:80);
2 722 integer array read_kind(1:80);
2 723 integer array search_table(0:search_table_length - 1);
2 724 long array name_table(0:name_table_length,0:4);
2 725 integer array HEAP(1:HEAP_length);
2 726 long array field name_record;
2 727 long field name_name,
2 728 name_mask;
2 729 integer field name_value,
2 730 name_type,
2 731 name_chain;
2 732 integer name_record_length;
2 733
2 733 long array field error_record;
2 734 long field error_record_text;
2 735 integer field error_record_line_no;
2 736 integer field error_record_element_pos;
2 737 integer field error_record_instr_index;
2 738 integer field error_record_chain;
2 739 integer error_record_length;
2 740 long array field error_record_chain_head;
2 741 long array field l_d_record, l_d_record_chain_head;
2 742 long field l_d_name;
2 743 integer spec_class,map_spec,vector_spec; <* and nil *>
2 744 integer field l_d_spec, l_d_spec_class;
2 745 integer field l_d_index;
2 746 integer field l_d_line_no;
2 747 integer field l_d_chain;
2 748 integer l_d_record_length;
2 749
2 749
2 749 long array field l_r_record;
2 750 integer field l_r_chain;
2 751 long field l_r_name;
2 752 integer field l_r_index;
2 753 integer field l_r_line_no;
2 754 integer field l_r_element_no;
2 755 integer l_r_record_length,l_r_record_chain_head;
2 756 long array op_code(0:length_of_code-1);
2 757 long array object_file_name(1:2);
2 758
2 758
2 758
2 758
2 758 <* error text variables *>
2 759 long plus_label_dec,declaration,operand_type,minus_delim,missing_operand,
2 760 label_dec,illegal_type,plus_name_dec,name_unknown,directive,
2 761 unknown,name_length,delimiter,undec_label,multiple_function,
2 762 plus_addrs_def,minus_addrs_def,operand,
2 763 special_def_type,illegal_source,illegal_dest,
2 764 illegal_dest_and_source,save_file_name,load_file_name,
2 765 termination;
2 766 algol copy.1 <* schould be taken from m290xdec *>;
t2903dec d.791206.1522
2 766 long <* declarition of std mask to hc2903 *>
2 767 condition_enable_mask,
2 768 sekvens_mask,
2 769 cond_my_reg_enable_mask,
2 770
2 770 cond_m_reg_enable_mask,
2 771
2 771
2 771 condition_select_mask,
2 772 condition_full_mask, <* select and kind *>
2 773 alu_full_length_mask,
2 774 alu_dest_mask, <* alu bit i8 to both i5 *>
2 775 alu_short_dest_mask,
2 776 alu_i5_left_mask,
2 777 alu_i5_rigth_mask,
2 778 alu_both_i5_mask,
2 779 alu_function_mask, <* alu bit i4 to i1 *>
2 780 alu_full_function_mask, <* alu bit i4 to i0 *>
2 781 alu_special_control_mask, <* alu bit i0 *>
2 782 carry_control_mask,
2 783 set_2904_shift_mask,
2 784 not_ea_mask,
2 785 w_reg_enable_mask,
2 786
2 786 w_reg_enable_sel_mask,
2 787 not_oeb_mask,
2 788
2 788 read_2901_reg_mask,
2 789
2 789 write_2901_reg_mask,
2 790 alu_full_source_mask, <* not ea and not oeb and alu bit i0 *>
2 791 source_extern_mask,
2 792
2 792 dest_extern_mask,
2 793 short_source_mask,
2 794 short_dest_mask,
2 795 source_mask,
2 796 dest_mask,
2 797 addrs_mask,
2 798
2 798 addrs_and_imm_mask, <* addrs and immidiate mask *>
2 799 cond_kind_set_mask,
2 800 not_half_w_move_enable_mask,
2 801
2 801 half_w_move_dir_mask,
2 802 half_word_move_mask,
2 803
2 803 shift_control_2904_mask, <* controls the 2904 instr bit i6 to i9 *>
2 804 all_m_reg_enable_mask, <* all bits to contol the great m reg *>
2 805
2 805 select_m_reg_enable_mask, <* only the select bits *>
2 806 select_interupt_bit_mask,
2 807 instr_full_length; <* all bits in instr *>
2 808 long <* declaration of hc2903 std values *>
2 809 <* alu source control values ,
2 810 use bit not ea , alu i0 , not_oeb *>
2 811
2 811 a_and_b,
2 812 a_and_direct,
2 813 a_and_q,
2 814 im_and_b,
2 815 im_and_dir,
2 816 im_and_q;
2 817 long <* special functions *>
2 818 q_regs_value,
2 819
2 819 w_index_value,
2 820 w_pre_index_value;
2 821
t290xasm
2 821
2 821
2 821
2 821 <* fixed bit long values *>
2 822 long array bits(0:48);
2 823 long prom_code, <* the value not to destroy the used prom *>
2 824 nop_code; <* the code which will perform nothing abd continue
2 825 with the next micro instr.*>
2 826
2 826
2 826 procedure init_HEAP;
2 827 <******************************>
2 828 begin
3 829 integer index;
3 830 refference_first_free := 2*2;
3 831 for index := 2 step 2 until HEAP_length do
3 832 begin
4 833 HEAP(index-1) := index*2-4; <* points to previus element *>
4 834 HEAP(index) := index*2+4; <* point to next element *>
4 835 refference_last_free := index*2;
4 836 end;
3 837 end init_HEAP;
2 838
2 838 integer procedure allocate(no_of_halfwords);
2 839 <******************************************>
2 840 value no_of_halfwords; integer no_of_halfwords;
2 841 begin
3 842 allocate := refference_first_free - 4;
3 843 if ( no_of_halfwords mod 4) <> 0 then
3 844 no_of_halfwords := no_of_half_words + (4 -(no_of_halfwords mod 4));
3 845 refference_first_free := refference_first_free + no_of_half_words;
3 846 if refference_first_free > refference_last_free then
3 847 fatal_error(<:REFFERENCE TABLE LENGTH EXEEDED:>);
3 848 end allocate;
2 849
2 849 procedure fatal_error(error_text);
2 850 <********************************>
2 851 string error_text;
2 852 begin
3 853 print_error_table;
3 854 write(out,"nl",1,"*",5,"sp",1,error_text,"nl",1,
3 855 "sp",7,<:RUN ABORT:>);
3 856 fp_proc(7,0,0,0);
3 857 end fatal_error;
2 858
2 858 procedure error(error_text,line_no,element_pos);
2 859 <**********************************************>
2 860 value error_text,line_no,element_pos;
2 861 long error_text;
2 862 integer line_no,element_pos;
2 863 begin
3 864 error_in_this_line := true;
3 865 no_of_errors := no_of_errors + 1;
3 866 error_record := allocate(error_record_length);
3 867 HEAP.error_record.error_record_chain := error_record_chain_head;
3 868 error_record_chain_head := error_record;
3 869 HEAP.error_record.error_record_text := error_text;
3 870 HEAP.error_record.error_record_line_no := line_no;
3 871 HEAP.error_record.error_record_element_pos := element_pos;
3 872 HEAP.error_record.error_record_instr_index := instr_index;
3 873 end error;
2 874
2 874
2 874
2 874 boolean procedure new_lookup_name(name,name_record_index,name_type);
2 875 value name; long name;
2 876 integer name_record_index,name_type;
2 877 begin
3 878 long array field look_name_record;
3 879 boolean found;
3 880 found := false;
3 881 name_record_index := calculate_hash_key(name);
3 882 look_name_record := search_table(name_record_index);
3 883 while look_name_record <> nil and -,found do
3 884 begin
4 885 if name = HEAP.look_name_record.name_name then
4 886 found := true
4 887 else
4 888 look_name_record := HEAP.look_name_record.name_name;
4 889 end;
3 890 name_record_index := look_name_record;
3 891 new_lookup_name := found;
3 892 end new_lookup_name;
2 893
2 893 integer procedure new_insert_name(name,reff_index,type,record_length);
2 894 value name,type,record_length;
2 895 long name;
2 896 integer reff_index,type,record_length;
2 897 begin
3 898 integer array field insert_name_record;
3 899 integer hash_key;
3 900 hash_key := calculate_hash_key(name);
3 901 insert_name_record := allocate(record_length);
3 902 new_insert_name := insert_name_record;
3 903 reff_index := insert_name_record;
3 904 HEAP.insert_name_record.name_name := name;
3 905 HEAP.insert_name_record.name_type := type;
3 906 HEAP.insert_name_record.name_chain := search_table(hash_key);
3 907 search_table(hash_key) := insert_name_record;
3 908 end new_insert_name;
2 909
2 909 integer procedure calculate_hash_key(name);
2 910 value name; long name;
2 911 begin
3 912 calculate_hash_key := (( name extract 12) +
3 913 ( name shift (-12) extract 12) +
3 914 ( name shift (-24) extract 12) +
3 915 ( name shift (-36) extract 12) +
3 916 ( name shift (-40) extract 8) +
3 917 ( name shift (-32) extract 8) +
3 918 ( name shift (-24) extract 12)
3 919 )
3 920 mod search_table_length;
3 921 end calculate_hash_key;
2 922
2 922 integer procedure insert_name_table(index,name,type,reff);
2 923 value index,name,type,reff; long index,name;
2 924 integer type,reff;
2 925 begin
3 926 name_table(index,1) := name;
3 927 name_table(index,0) := type;
3 928 name_table(index,4) := reff;
3 929 end insert_name_table;
2 930
2 930
2 930
2 930 integer procedure addrs_ref(name,instr_index,line_no,element_no);
2 931
2 931 value name,instr_index,line_no,element_no;
2 932 long name;
2 933 integer instr_index,line_no,element_no;
2 934 begin
3 935 l_r_record := allocate(l_r_record_length);
3 936 HEAP.l_r_record.l_r_chain := l_r_record_chain_head;
3 937 l_r_record_chain_head := l_r_record;
3 938 HEAP.l_r_record.l_r_name := name;
3 939 HEAP.l_r_record.l_r_index := instr_index;
3 940 HEAP.l_r_record.l_r_line_no := line_no;
3 941 HEAP.l_r_record.l_r_element_no := element_no;
3 942 addrs_ref := l_r_record;
3 943 end addrs_ref;
2 944
2 944 integer procedure new_insert_label_def(name,index,instr_index,line_no,spec,spec_class);
2 945 value name,index,instr_index,spec,line_no,spec_class;
2 946 long name,index;
2 947 integer instr_index,spec,line_no,spec_class;
2 948 begin
3 949 l_d_record := allocate(l_d_record_length);
3 950 insert_name_table(index,name,label_type,l_d_record);
3 951 HEAP.l_d_record.l_d_chain := l_d_record_chain_head;
3 952 l_d_record_chain_head := index;
3 953 HEAP.l_d_record.l_d_index := instr_index;
3 954 HEAP.l_d_record.l_d_line_no := line_no;
3 955 HEAP.l_d_record.l_d_spec := spec;
3 956 HEAP.l_d_record.l_d_spec_class := spec_class;
3 957 new_insert_label_def := index;
3 958 end new_insert_label_def;
2 959
2 959 procedure resolve_labels;
2 960 begin
3 961 integer op_code_index;
3 962 long name_table_index;
3 963 long array wr_name(1:2); <* used for writing of a name *>
3 964 wr_name(2):=0;
3 965
3 965 l_r_record := l_r_record_chain_head;
3 966 while l_r_record >-1 do
3 967 begin
4 968 if -, lookup_name(name_table,HEAP.l_r_record.l_r_name,
4 969 name_table_index) then
4 970 begin
5 971 instr_index := HEAP.l_r_record.l_r_index;
5 972 error(undec_label,HEAP.l_r_record.l_r_line_no,
5 973 HEAP.l_r_record.l_r_element_no);
5 974 end
4 975 else
4 976 begin
5 977 l_d_record := name_table(name_table_index,4);
5 978 op_code_index := HEAP.l_r_record.l_r_index;
5 979 op_code(opcode_index) := mask_in(op_code(op_code_index),
5 980 extend HEAP.l_d_record.l_d_index,
5 981 addrs_mask);
5 982
5 982
5 982 if test_label_bit or test_label_ref then
5 983 begin
6 984 wr_name(1) := HEAP.l_d_record.l_d_name;
6 985 write(out,"nl",1,"sp",5,<<zddd>,
6 986 octal(extend HEAP.l_r_record.l_r_index),
6 987 <: label reff to: :>,
6 988 octal(extend HEAP.l_d_record.l_d_index),
6 989 <: name: :>,wr_name);
6 990 end;
5 991
5 991 if test_label_bit then
5 992 begin
6 993 write(out,"nl",1,"sp",11);
6 994 print_formated(op_code(op_code_index));
6 995 end;
5 996
5 996 end;
4 997 l_r_record := HEAP.l_r_record.l_r_chain;
4 998 end scan loop;
3 999 end resolve_labels;
2 1000
2 1000 procedure label_list(only_spec_wanted);
2 1001 value only_spec_wanted; boolean only_spec_wanted;
2 1002 begin
3 1003 integer no_of_spec,max_spec,max_index;
3 1004 long array wr_name(1:2),hex_number(1:2);
3 1005 integer index;
3 1006 no_of_spec := 0;
3 1007 wr_name(2) := 0;
3 1008
3 1008 for index := 1 step 1 until name_table_length do
3 1009 begin
4 1010 if name_table(index,0) = label_type then
4 1011 begin
5 1012 l_d_record := name_table(index,4);
5 1013 if HEAP.l_d_record.l_d_spec <> nil or
5 1014 -, only_spec_wanted then
5 1015 begin
6 1016 wr_name(1) := name_table(index,1);
6 1017 write(out,"sp",15 - write(out,"nl",1,wr_name),
6 1018 "cr",1,"sp",7,<: reff. to address:>,
6 1019 <<_zddd>,HEAP.l_d_record.l_d_index,
6 1020 octal(extend HEAP.l_d_record.l_d_index),
6 1021 if HEAP.l_d_record.l_d_spec = nil then <::> else
6 1022 if HEAP.l_d_record.l_d_spec < 0 then
6 1023 <:_line_no_:> else <:_spec.____:>,
6 1024 if HEAP.l_d_record.l_d_spec <> nil then <<__dddd> else <<b>,
6 1025 if HEAP.l_d_record.l_d_spec = nil then
6 1026 0 else
6 1027 abs HEAP.l_d_record.l_d_spec);
6 1028 no_of_spec := no_of_spec + 1;
6 1029 end;
5 1030 end;
4 1031 end for loop;
3 1032 if only_spec_wanted then
3 1033 begin
4 1034 for spec_class := nil,map_spec ,vector_spec do
4 1035 begin
5 1036 if no_of_spec > 0 then
5 1037 write(out,"nl",4,
5 1038 if spec_class = map_spec then <: MAP ENTRIES :>
5 1039 else if spec_class = vector_spec then <: VECTOR ENTIES :>
5 1040 else <::>,"nl",1,
5 1041 <:_name_____________spec.____instr.___octal____:>);
5 1042 repeat
5 1043 begin
6 1044 max_spec := nil;
6 1045 for index := 1 step 1 until name_table_length do
6 1046 begin
7 1047 if name_table(index,0) = label_type then
7 1048 begin
8 1049 l_d_record := name_table(index,4);
8 1050 if HEAP.l_d_record.l_d_spec > max_spec and
8 1051 HEAP.l_d_record.l_d_spec <> nil and
8 1052 HEAP.l_d_record.l_d_spec_class = spec_class then
8 1053 begin
9 1054 max_spec := HEAP.l_d_record.l_d_spec;
9 1055 max_index := index;
9 1056 end;
8 1057 end;
7 1058 end loop name_table;
6 1059 <* write spec *>
6 1060 if max_spec <> nil then
6 1061 begin
7 1062 wr_name(1) := name_table(max_index,1);
7 1063 l_d_record := name_table(max_index,4);
7 1064 write(out,"sp",15-write(out,"nl",1,wr_name),
7 1065 <<____dddd>,HEAP.l_d_record.l_d_spec,
7 1066 HEAP.l_d_record.l_d_index,
7 1067 octal(extend HEAP.l_d_record.l_d_index),
7 1068 HEAP.l_d_record.l_d_index shift (-8),
7 1069 HEAP.l_d_record.l_d_index extract 8);
7 1070
7 1070 <* delete label entry in name table *>
7 1071 name_table(max_index,0) := nil;
7 1072 no_of_spec := no_of_spec-1;
7 1073 end;
6 1074 end;
5 1075 until max_spec = nil;
5 1076 end spec_class_loo;
4 1077 end only_spec_loop;
3 1078 end label_list;
2 1079
2 1079 boolean procedure print_error_table;
2 1080 begin
3 1081 long array field previus,this,min_line;
3 1082 integer min_line_no;
3 1083
3 1083 if error_record_chain_head = nil then
3 1084 print_error_table := true
3 1085 else
3 1086 begin
4 1087 print_error_table := false;
4 1088 while error_record_chain_head <> nil do
4 1089 begin
5 1090 min_line_no := 8388606;
5 1091 this := error_record_chain_head;
5 1092 previus := nil;
5 1093 while this <> nil do
5 1094 begin
6 1095 if HEAP.this.error_record_line_no <= min_line_no then
6 1096 begin
7 1097 min_line_no := HEAP.this.error_record_line_no;
7 1098 min_line:= previus;
7 1099 end;
6 1100 previus := this;
6 1101 this := HEAP.this.error_record_chain;
6 1102 end;
5 1103
5 1103 <* remove record from list *>
5 1104 if min_line = nil then
5 1105 begin
6 1106 this := error_record_chain_head;
6 1107 error_record_chain_head := HEAP.this.error_record_chain;
6 1108 end
5 1109 else
5 1110 begin
6 1111 previus := min_line;
6 1112 this := HEAP.previus.error_record_chain;
6 1113 HEAP.previus.error_record_chain :=
6 1114 HEAP.this.error_record_chain;
6 1115 end;
5 1116 write(out,"nl",1,<<_dddd>,
5 1117 HEAP.this.error_record_line_no,
5 1118 HEAP.this.error_record_instr_index,
5 1119 octal(extend HEAP.this.error_record_instr_index),
5 1120 HEAP.this.error_record_element_pos,
5 1121 "sp",2,string HEAP.this.error_record_text);
5 1122 end;
4 1123 end;
3 1124 end print_error_table;
2 1125
2 1125
2 1125
2 1125 procedure print_formated(opcode);
2 1126 <********************************>
2 1127 value opcode; long opcode;
2 1128 begin
3 1129 integer from,to,number,index;
3 1130 from := 0;
3 1131 for index :=-47 step 1 until 0 do
3 1132 begin
4 1133 outchar(out,if opcode shift index extract 1 = 1 then
4 1134 49 else 46);
4 1135 if format(from) extract 12 = 47 + index then
4 1136 begin
5 1137 outchar(out,32);
5 1138 from:=from+1;
5 1139 end;
4 1140 end for loop;
3 1141 <* for improving readability write an extra newline *>
3 1142 outchar(out,10);
3 1143
3 1143 end print_format;
2 1144
2 1144
2 1144 algol copy.2 <* source should be m290xproc *>;
t2903proc d.810408.1811
2 1144
2 1145
2 1145
2 1145
2 1145
2 1145
2 1145
2 1145 procedure jump_addrs;
2 1146 <******************>
2 1147 begin
3 1148 if alu_function_performed or jump_sekvens_performed or
3 1149 jump_addrs_performed or addrs_performed then
3 1150 error(multiple_function,line_no,element_no);
3 1151 present(name_table(number,2),
3 1152 sekvens_mask);
3 1153 present(name_table(number,3),
3 1154 condition_enable_mask);
3 1155 next;
3 1156 if class = left_par_class then
3 1157 begin
4 1158 scan_sekvens_operands(false);
4 1159 end;
3 1160 addrs_performed := jump_addrs_performed := code_generated:=true;
3 1161 end of jump_addrs;
2 1162
2 1162
2 1162 procedure jump_sekvens;
2 1163 begin
3 1164 if jump_addrs_performed or jump_sekvens_performed then
3 1165 error(multiple_function,line_no,element_no);
3 1166 present(name_table(number,2),
3 1167 sekvens_mask);
3 1168 present(name_table(number,3),
3 1169 condition_enable_mask);
3 1170 next;
3 1171 if class=left_par_class then
3 1172 begin
4 1173 scan_sekvens_operands(true);
4 1174 end;
3 1175
3 1175 jump_sekvens_performed := true; code_generated:=true;
3 1176
3 1176 end of jump_sekevens;
2 1177
2 1177 procedure load_counter;
2 1178 begin
3 1179 jump_addrs;
3 1180 end of load_counter;
2 1181
2 1181
2 1181 procedure special;
2 1182 <*****************>
2 1183 begin
3 1184 long spec_number;
3 1185 integer kind_1,op_value1,op_value2,kind_2,index;
3 1186 if name_table(number,3) < special_min or
3 1187 name_table(number,3) > special_max then
3 1188 error(special_def_type,line_no,element_no)
3 1189 else
3 1190 case name_table(number,3) of
3 1191 begin
4 1192
4 1192 begin
5 1193 <* case 1 is
5 1194 value by name_table(number,2)
5 1195 mask by a mask entry given by
5 1196 nametable(nametable(number,4),2)
5 1197 *>
5 1198
5 1198 present(
5 1199 name_table(number,2),
5 1200 name_table(name_table(number,4),2));
5 1201 end of case 1;
4 1202 begin
5 1203 <* case 2 is no parameters and mask
5 1204 Is pointed out by name_table(name,4),
5 1205 among the fixed mask values,
5 1206 from left to rigth in the format
5 1207 *>
5 1208
5 1208 present(
5 1209 name_table(number,2),
5 1210 std_mask(name_table(number,4)));
5 1211 end of case 2;
4 1212 begin
5 1213 <* case 3.
5 1214 set or clear depending on value,
5 1215 the bits taken from argument 1 to
5 1216 argument 2 *>
5 1217 spec_number:=number;
5 1218 next1;
5 1219 if class1 <> left_par_class then
5 1220 error(delimiter,line_no,element_no)
5 1221 else
5 1222 begin
6 1223 if name_table(spec_number,4) = 2 then
6 1224 get_2_reg_operands(op_value_1,op_value_2)
6 1225 else
6 1226 begin
7 1227 get_a_reg_operand(op_value_1,kind_1);;
7 1228 op_value_2 := op_value_1;
7 1229 end;
6 1230 for index:= op_value_1 step 1 until op_value_2 do
6 1231 present(name_table(spec_number,2),
6 1232 (extend 1 ) shift (47 - index));
6 1233 next;
6 1234 if class <> right_par_class then
6 1235 error(delimiter,line_no,element_no)
6 1236 end;
5 1237 end case 3;
4 1238 begin
5 1239 <* case 4 one bit is set or cleared acording to
5 1240 the bit number specicfied by nametable(number,4) *>
5 1241 present(extend ( name_table(number,2)
5 1242 extract 1) , extend 1 shift (47 -
5 1243 name_table(number,4)));
5 1244 end case 4;
4 1245
4 1245
4 1245
4 1245 begin
5 1246 <* case 5
5 1247 load counter from internal register
5 1248 pointed out by
5 1249 pointed out by s address field or q reg.
5 1250 s address field second bit is set
5 1251 and w_reg enable is set *>
5 1252
5 1252 if jump_addrs_performed or jump_sekvens_performed or
5 1253 alu_function_performed or addrs_performed then
5 1254 error(multiple_function,line_no,element_no);
5 1255 jump_addrs_performed := jump_sekvens_performed :=
5 1256 alu_function_performed := addrs_performed :=true;
5 1257
5 1257 <* first the function of the 2910 is masked in *>
5 1258 present(name_table(number,2),
5 1259 sekvens_mask);
5 1260 <* if condition schould be forced to true then
5 1261 name_table(number,4) is 1 *>
5 1262 present(name_table(number,4),
5 1263 condition_enable_mask);
5 1264 class1:=getnext_element(name_1,number1);
5 1265 if class1 <> left_par_class then
5 1266 begin
6 1267 error(missing_operand,line_no,element_no);
6 1268 end
5 1269 else
5 1270 begin
6 1271 get_a_reg_operand(op_value_1,kind_1);
6 1272 if op_value_1 >=0 and op_value_1 <16 then
6 1273 begin
7 1274 <* an reg. from alu source *>
7 1275
7 1275 present(extend op_value_1,
7 1276 short_source_mask);
7 1277 present(extend 0,
7 1278 not_ea_mask);
7 1279 present(extend 6,
7 1280 alu_function_mask);
7 1281 present(extend 0,
7 1282 carry_control_mask);
7 1283 end else
6 1284 if op_value_1 = q_regs_value then
6 1285 begin
7 1286 present(extend 1,
7 1287 alu_special_control_mask);
7 1288 present(extend 4,
7 1289 alu_function_mask);
7 1290 end else
6 1291 error(illegal_type,line_no,element_no);
6 1292 present(extend 1,
6 1293 w_reg_enable_mask);
6 1294 present(extend 2,
6 1295 dest_mask);
6 1296 present(extend 6,
6 1297 alu_short_dest_mask);
6 1298
6 1298 present(extend 0,
6 1299 alu_both_i5_mask);
6 1300 next;
6 1301 if class <> right_par_class then
6 1302 error(minus_delim,line_no,element_no);
6 1303 end;
5 1304 end case 5;
4 1305
4 1305 begin
5 1306 <* case 6
5 1307 load counter from internal register
5 1308 pointed out by
5 1309 pointed out by s address field or q reg.
5 1310 s address field second bit is set
5 1311 and w_reg enable is set *>
5 1312 if jump_addrs_performed or jump_sekvens_performed
5 1313 then
5 1314 error(multiple_function,line_no,element_no);
5 1315 jump_addrs_performed := jump_sekvens_performed := true;
5 1316
5 1316 <* first the function of the 2910 is masked in *>
5 1317 present(name_table(number,2),
5 1318 sekvens_mask);
5 1319 <* if condition schould be forced to true then
5 1320 name_table(number,4) is 1 *>
5 1321 present(name_table(number,4),
5 1322 condition_enable_mask);
5 1323 present(extend 1,
5 1324 w_reg_enable_mask);
5 1325 present(extend 2,
5 1326 dest_mask);
5 1327 end case 6;
4 1328
4 1328 end of all cases;
3 1329 code_generated:=true;
3 1330 next;
3 1331 if class = comma_class then
3 1332 next;
3 1333 end of special;
2 1334
2 1334
2 1334
2 1334
2 1334 procedure scan_sekvens_operands(use_of_addrs_field);
2 1335 <***********************************************>
2 1336 value use_of_addrs_field; boolean use_of_addrs_field;
2 1337 begin
3 1338 next;
3 1339 for class := class while class <> right_par_class
3 1340 and class <> stop_line_class do
3 1341 begin
4 1342 if class = text_class and type = condition_type then
4 1343 begin
5 1344 <* condition *>
5 1345 present(name_table(number,2),
5 1346 condition_select_mask);
5 1347 end
4 1348 else
4 1349 if class = unknown_name_class or class = number_class or
4 1350 class = apost_class or
4 1351 class = text_class then
4 1352
4 1352 begin
5 1353 <* addrs. ref. *>
5 1354 if class = apost_class then next;
5 1355 if look_ahead_class = right_par_class then
5 1356 begin
6 1357 if use_of_addrs_field then error(plus_addrs_def,line_no,element_no);
6 1358 if class = unknown_name_class or
6 1359 (class = text_class <*and name_table(number,0) = label_type*>) then
6 1360 addrs_ref(name,instr_index,line_no,element_no)
6 1361 else
6 1362 present(number,
6 1363 addrs_and_imm_mask);
6 1364 use_of_addrs_field := true;
6 1365 end else
5 1366 error(unknown,line_no,element_no);
5 1367 end
4 1368 else
4 1369 begin
5 1370 error(missing_operand,line_no,element_no);
5 1371 end;
4 1372 next;
4 1373 if class = comma_class then next;
4 1374 end;
3 1375 if class = right_par_class then next;
3 1376 if -, use_of_addrs_field then error(minus_addrs_def,line_no,element_no);
3 1377 end of scan_addrs_operands;
2 1378
2 1378
2 1378
2 1378
2 1378 procedure alu_function;
2 1379 <*********************>
2 1380
2 1380 begin
3 1381 integer type_of_operands;
3 1382 if alu_function_performed then
3 1383 error(multiple_function,line_no,element_no);
3 1384 present(name_table(number,2),
3 1385 alu_function_mask);
3 1386 type_of_operands := name_table(number,3);
3 1387 class := look_ahead_class;
3 1388 if class = left_par_class then
3 1389 begin
4 1390 case type_of_operands of
4 1391 begin
5 1392 normal_function(0);
5 1393 normal_function(1);
5 1394 special_function(0);
5 1395 special_function(1);
5 1396 special_function(2);
5 1397 end; <*
4 1398 end of case *>
4 1399 next;
4 1400 end;
3 1401 code_generated:=true; alu_function_performed:=true;
3 1402 end of alu_function;
2 1403
2 1403
2 1403 procedure normal_function(carry);
2 1404 value carry; integer carry;
2 1405 begin
3 1406 integer dest_value,dest_kind,no_of_operands;
3 1407 no_of_operands := scan_alu_operands(dest_value,dest_kind);
3 1408
3 1408 if no_of_operands > 0 then
3 1409 begin
4 1410 present(extend carry,
4 1411 carry_control_mask);
4 1412 set_alu_output(dest_value,dest_kind,0,element_no -
4 1413 ( if no_of_operands = 1 then
4 1414 1 else no_of_operands+2));
4 1415 end;
3 1416 end procedure normal_function;
2 1417 procedure special_function(carry);
2 1418 <********************************>
2 1419 value carry; integer carry;
2 1420 begin
3 1421 long spec_value;
3 1422 integer dest_value,dest_kind,no_of_operands;
3 1423 spec_value := name_table(number,2);
3 1424 no_of_operands := scan_alu_operands(dest_value,dest_kind);
3 1425 if no_of_operands > 0 then
3 1426 begin
4 1427
4 1427
4 1427 end;
3 1428 present(extend carry,
3 1429 carry_control_mask);
3 1430 present(extend 0,
3 1431 alu_full_function_mask);
3 1432 present(spec_value,
3 1433 alu_dest_mask);
3 1434
3 1434 end procedure special_function;
2 1435
2 1435
2 1435
2 1435
2 1435
2 1435 integer procedure scan_alu_operands(dest_val,dest_kind);
2 1436 <******************************************************>
2 1437 integer dest_val,dest_kind;
2 1438 begin
3 1439
3 1439 integer no_of_op,val_1,kind_1,val_2,kind_2,val_3,kind_3;
3 1440 no_of_op :=
3 1441 get_all_reg_operands(val_1,kind_1,val_2,kind_2,val_3,kind_3);
3 1442 if no_of_op > 3 then no_of_op :=3;
3 1443 scan_alu_operands:= no_of_op;
3 1444 if no_of_op > 0 then
3 1445 begin
4 1446 dest_val := val_1;
4 1447 dest_kind := kind_1;
4 1448 end
3 1449 else
3 1450 begin
4 1451 dest_val := 0;
4 1452 dest_kind := 0;
4 1453 no_of_op := 0;
4 1454 end;
3 1455
3 1455 case no_of_op + 1 of
3 1456 begin
4 1457
4 1457 begin <* 0 operands *>
5 1458 end;
4 1459
4 1459 begin <* 1 operand *>
5 1460 if kind_1 <> text_class then
5 1461 error(illegal_dest,line_no,element_no-1)
5 1462 else
5 1463 set_alu_dest(val_1,kind_1,element_no - 1 );
5 1464 end;
4 1465
4 1465 begin <* 2 operands *>
5 1466 if val_1 > 15 and kind_2 <> number_class then
5 1467 begin
6 1468 set_alu_dest(val_2,kind_2,element_no - 1);
6 1469 end
5 1470 else
5 1471 if ( val_2 <= 15 and val_2 >= 0 )
5 1472 or kind_2 = number_class then
5 1473 begin
6 1474 set_alu_source(val_2,kind_2,element_no - 1);
6 1475 set_alu_dest(val_1,kind_1,element_no -3);
6 1476 end
5 1477 else
5 1478 if ( val_1 = w_index_value or val_1 = w_pre_index_value) and
5 1479 val_2 = q_regs_value then
5 1480 begin
6 1481 set_alu_dest(val_1,kind_1,element_no -3);
6 1482 present(extend 1,
6 1483 alu_special_control_mask);
6 1484 end
5 1485 else
5 1486
5 1486
5 1486 begin
6 1487 set_alu_dest(val_2,kind_2,element_no - 1);
6 1488 end;
5 1489
5 1489 end case 2 operands;
4 1490
4 1490 begin <*case 3 operands *>
5 1491
5 1491 if kind_2 = number_class or
5 1492 ( kind_3 = text_class and (val_3 = q_regs_value or
5 1493 val_3 = w_pre_index_value or val_3 = w_index_value)) then
5 1494 begin
6 1495 set_alu_source(val_2,kind_2,element_no -3);
6 1496 set_alu_dest(val_3,kind_3,element_no - 1);
6 1497 end
5 1498 else
5 1499 begin
6 1500 set_alu_source(val_3,kind_3,element_no -1);
6 1501 set_alu_dest(val_2,kind_2,element_no - 3);
6 1502 end;
5 1503 end;
4 1504
4 1504 end case loop;
3 1505 end scan_alu_operands;
2 1506
2 1506 procedure set_alu_output(op_value,op_kind,special,element_no);
2 1507 <************************************************************>
2 1508 value op_value,op_kind,special,element_no;
2 1509 integer op_value,op_kind,special,element_no;
2 1510 begin
3 1511 if op_kind = text_class then
3 1512 begin
4 1513 if op_value = q_regs_value then
4 1514 begin
5 1515 present( extend 3,
5 1516 alu_short_dest_mask);
5 1517 present(extend 0,
5 1518 alu_both_i5_mask);
5 1519 end
4 1520
4 1520 else
4 1521 if op_value = w_index_value or op_value = w_pre_index_value then
4 1522 begin
5 1523 present(extend 2,alu_short_dest_mask);
5 1524 present(extend 0,alu_both_i5_mask);
5 1525 present(extend 1,w_reg_enable_mask);
5 1526 present(if op_value = w_index_value then extend 0 else extend 1,
5 1527 dest_mask);
5 1528 end
4 1529 else
4 1530 if op_value > 15 then
4 1531 begin
5 1532
5 1532 present(extend 1,
5 1533 write_2901_reg_mask);
5 1534 present( extend 0,
5 1535 not_oeb_mask);
5 1536 present(extend 6,
5 1537 alu_short_dest_mask);
5 1538 present(extend 0,
5 1539 alu_both_i5_mask);
5 1540 end
4 1541 else
4 1542 if op_value >=0 and op_value <=15 then
4 1543 begin
5 1544 present(extend 2,
5 1545 alu_short_dest_mask);
5 1546 present(extend 0,
5 1547 alu_both_i5_mask);
5 1548 present(extend op_value,
5 1549 dest_mask);
5 1550 end
4 1551 else
4 1552 error(illegal_dest,line_no,element_no);
4 1553 end else
3 1554 error(illegal_dest,line_no,element_no);
3 1555 end set_alu_output;
2 1556
2 1556
2 1556 procedure set_alu_source(op_value,op_kind,element_no);
2 1557 <****************************************************>
2 1558 value op_value,op_kind,element_no;
2 1559 integer op_value,op_kind,element_no;
2 1560 begin
3 1561 if op_kind = number_class then
3 1562 begin
4 1563 if addrs_performed then
4 1564 error(multiple_function,line_no,element_no);
4 1565 addrs_performed := true;
4 1566 present(extend 1,
4 1567 not_ea_mask);
4 1568 present(extend op_value,
4 1569 addrs_and_imm_mask);
4 1570 end
3 1571 else
3 1572 if op_kind = text_class then
3 1573 begin
4 1574 if op_value > 16 then
4 1575 error(illegal_source,line_no,element_no)
4 1576 else
4 1577 begin
5 1578
5 1578 present(extend 0,
5 1579 not_ea_mask);
5 1580 present(extend op_value,
5 1581
5 1581 short_source_mask);
5 1582 end;
4 1583 end
3 1584 else
3 1585 error(illegal_source,line_no,element_no);
3 1586
3 1586 end of set_alu_source;
2 1587
2 1587
2 1587 procedure set_alu_dest(op_value,op_kind,element_no);
2 1588 <***************************************************>
2 1589 value op_value,op_kind,element_no;
2 1590 integer op_value,op_kind,element_no;
2 1591 begin
3 1592
3 1592 if op_kind = text_class then
3 1593 begin
4 1594 if op_value = q_regs_value then
4 1595 begin
5 1596
5 1596 present(extend 1,
5 1597 alu_special_control_mask);
5 1598 present(extend 0,
5 1599 dest_mask);
5 1600 end
4 1601 else
4 1602 if op_value = w_index_value
4 1603 or op_value = w_pre_index_value then
4 1604 begin
5 1605 present(extend 1,
5 1606 w_reg_enable_mask);
5 1607 present(
5 1608 if op_value = w_index_value then
5 1609 extend 0 else extend 1,
5 1610 dest_mask);
5 1611 present(extend 0,
5 1612 not_oeb_mask);
5 1613 present(extend 0,
5 1614 alu_special_control_mask);
5 1615 end
4 1616 else
4 1617 if op_value > 15 then
4 1618 begin
5 1619 present(extend 1,
5 1620 not_oeb_mask);
5 1621 present(extend 0,
5 1622 alu_special_control_mask);
5 1623 present(extend 0,
5 1624 dest_mask);
5 1625 end
4 1626 else
4 1627 if op_value >= 0 and op_value < 16 then
4 1628 begin
5 1629 present(extend 0,
5 1630 not_oeb_mask);
5 1631 present( extend 0,
5 1632 alu_special_control_mask);
5 1633 present(extend op_value,
5 1634 dest_mask);
5 1635 end
4 1636 else
4 1637 error(illegal_dest,line_no,element_no);
4 1638 end
3 1639 else
3 1640 error(illegal_dest,line_no,element_no);
3 1641 end set_alu_dest;
2 1642 long procedure std_mask(mask_no);
2 1643 <******************************>
2 1644 value mask_no; long mask_no;
2 1645 begin
3 1646 std_mask := case mask_no of
3 1647 (
3 1648 condition_enable_mask,
3 1649 sekvens_mask,
3 1650 cond_my_reg_enable_mask,
3 1651
3 1651 cond_m_reg_enable_mask,
3 1652
3 1652
3 1652 condition_select_mask,
3 1653 condition_full_mask, <* select and kind *>
3 1654 alu_full_length_mask,
3 1655 alu_dest_mask, <* alu bit i8 to both i5 *>
3 1656 alu_short_dest_mask,
3 1657 alu_i5_left_mask,
3 1658 alu_i5_rigth_mask,
3 1659 alu_both_i5_mask,
3 1660 alu_function_mask, <* alu bit i4 to i1 *>
3 1661 alu_full_function_mask, <* alu bit i4 to i0 *>
3 1662 alu_special_control_mask, <* alu bit i0 *>
3 1663 carry_control_mask,
3 1664 set_2904_shift_mask,
3 1665 not_ea_mask,
3 1666 w_reg_enable_mask,
3 1667
3 1667 w_reg_enable_sel_mask,
3 1668 not_oeb_mask,
3 1669
3 1669 read_2901_reg_mask,
3 1670
3 1670 write_2901_reg_mask,
3 1671 alu_full_source_mask, <* not ea and not oeb and alu bit i0 *>
3 1672 source_extern_mask,
3 1673
3 1673 dest_extern_mask,
3 1674 short_source_mask,
3 1675 short_dest_mask,
3 1676 source_mask,
3 1677 dest_mask,
3 1678 addrs_mask,
3 1679
3 1679 addrs_and_imm_mask, <* addrs and immidiate mask *>
3 1680 cond_kind_set_mask,
3 1681 not_half_w_move_enable_mask,
3 1682
3 1682 half_w_move_dir_mask,
3 1683 half_word_move_mask,
3 1684
3 1684 shift_control_2904_mask, <* controls the 2904 instr bit i6 to i9 *>
3 1685 all_m_reg_enable_mask, <* all bits to control great m reg *>
3 1686 select_m_reg_enable_mask, <* only to select th bits *>
3 1687 select_interupt_bit_mask,
3 1688 instr_full_length); <* all bits in instr *>
3 1689 end procedure std_mask;
2 1690
t290xasm
2 1690
2 1690
2 1690
2 1690
2 1690
2 1690
2 1690
2 1690
2 1690
2 1690 integer procedure
2 1691 get_all_reg_operands(op_1,kind_1,op_2,kind_2,op_3,kind_3);
2 1692 <**********************************************************>
2 1693 integer op_1,kind_1,op_2,kind_2,op_3,kind_3;
2 1694 begin
3 1695 integer no_of_op;
3 1696 no_of_op := 0;
3 1697 op_1 := op_2 := op_3 := kind_1 := kind_2 := kind_3 := not_used;
3 1698 class := look_ahead_class;
3 1699 if class = left_par_class then
3 1700 begin
4 1701 next;
4 1702 get_a_reg_operand(op_1,kind_1);
4 1703 no_of_op := 1;
4 1704 if look_ahead_class = comma_class then
4 1705 begin
5 1706 next;
5 1707 get_a_reg_operand(op_2,kind_2);
5 1708 no_of_op := 2;
5 1709 if look_ahead_class = comma_class then
5 1710 begin
6 1711 next;
6 1712 get_a_reg_operand(op_3,kind_3);
6 1713 no_of_op := 3;
6 1714 end;
5 1715 end;
4 1716 next;
4 1717 if class <> right_par_class then
4 1718 error(termination,line_no,element_no);
4 1719 end else error(missing_operand,line_no,element_no);
3 1720 get_all_reg_operands := no_of_op;
3 1721 end get_all_reg_operands;
2 1722 <*
2 1723
2 1723 procedure check_unknown_operands(op_kind_1,op_kind_2,op_kind_3,op_kind_4);
2 1724 value op_kind_1,op_kind_2,op_kind_3,op_kind_4;
2 1725 integer op_kind_1,op_kind_2,op_kind_3,op_kind_4;
2 1726 begin
2 1727 integer no_of_op;
2 1728 no_of_op := if op_kind_1 = not_used then 0 else
2 1729 if op_kind_2 = not_used then 1 else
2 1730 if op_kind_3 = not_used then 2 else
2 1731 if op_kind_4 = not_used then 3 else 4;
2 1732 if op_kind_1 = unknown_name_class then
2 1733 error(operand,line_no,element_no - 1 -(2*(no_of_op-1)));
2 1734 if op_kind_2 = unknown_name_class then
2 1735 error(operand,line_no,element_no -1-(2*(no_of_op-2)));
2 1736 if op_kind_3 = unknown_name_class then
2 1737 error(operand,line_no,element_no - 1 - 2*(no_of_op-3));
2 1738 if op_kind_4 = unknown_name_class then
2 1739 error(operand,line_no,element_no -1);
2 1740 end check_unkown_operands; *>
2 1741
2 1741
2 1741
2 1741
2 1741
2 1741
2 1741 procedure get_a_reg_operand(op_value,kind);
2 1742 <*****************************************>
2 1743 integer op_value,kind;
2 1744 begin
3 1745 long lookup_index;
3 1746 next;
3 1747 if class = number_class then
3 1748 begin
4 1749 kind := number_class;
4 1750 op_value := number
4 1751 end
3 1752 else
3 1753 if class = apost_class then
3 1754 begin
4 1755 next;
4 1756 kind := 0;
4 1757 op_value := 0;
4 1758 if class = unknown_name_class or
4 1759 (class = text_class and type = label_type) then
4 1760 begin
5 1761 addrs_ref(name,instr_index,line_no,element_no);
5 1762 kind := number_class;
5 1763 end
4 1764 else
4 1765 error(operand_type,line_no,element_no);
4 1766 end
3 1767 else
3 1768 if class = text_class then
3 1769 begin
4 1770 if name_table(number,0) <> reg_op_type then
4 1771 begin
5 1772 kind := 0;
5 1773 error(operand_type,line_no,element_no)
5 1774 end
4 1775 else
4 1776 begin
5 1777 op_value := name_table(number,2);
5 1778 kind := text_class;
5 1779 end;
4 1780 end
3 1781 else
3 1782 begin
4 1783 kind := unknown_name_class;
4 1784 error(operand,line_no,element_no);
4 1785 end;
3 1786 end of get_a_reg_operand;
2 1787
2 1787
2 1787
2 1787
2 1787 procedure get_2_reg_operands(op_value_1,op_value_2);
2 1788 integer op_value_1,op_value_2;
2 1789 begin
3 1790 integer kind_1,kind_2;
3 1791 get_a_reg_operand(op_value_1,kind_1);
3 1792 next;
3 1793 if class <> comma_class then error(delimiter,line_no,element_no);
3 1794 get_a_reg_operand(op_value_2,kind_2);
3 1795 end of get_2_reg_operands;
2 1796
2 1796
2 1796
2 1796
2 1796
2 1796
2 1796
2 1796
2 1796 integer procedure look_ahead_class;
2 1797 begin
3 1798 integer to; long name,number;
3 1799 look_ahead_class := get_element(name,number,line_pointer,to);
3 1800 end look_ahead_class;
2 1801
2 1801
2 1801
2 1801 procedure skip_until_delim_class;
2 1802 begin
3 1803 for class:=read_kind(line_pointer) while class <> delim_class
3 1804 and class <> eof_class
3 1805 and class <> stop_line_class do
3 1806 line_pointer:=line_pointer + 1;
3 1807 end skip_until_delim_class;
2 1808
2 1808
2 1808
2 1808
2 1808 integer procedure get_long_name(long_name);
2 1809 long array long_name;
2 1810 begin
3 1811 integer class,to;
3 1812 long name,number;
3 1813 class := get_element(name,number,line_pointer,to);
3 1814 if class = unknown_name_class or class = text_class then
3 1815 begin
4 1816 get_long_name := 1;
4 1817 long_name(1) := name;
4 1818 long_name(2) := 0;
4 1819 end
3 1820 else
3 1821 if class = long_text_class then
3 1822 begin
4 1823 long_name(1) := read_value(line_pointer);
4 1824 long_name(2) := read_value(line_pointer + 2);
4 1825 get_long_name := if read_kind(line_pointer + 3 ) = text_class
4 1826 then -2 else 2;
4 1827 end
3 1828 else
3 1829 get_long_name := 0;
3 1830 end get_long_name;
2 1831
2 1831 <* the following procedures uses getnext element
2 1832 to get next element into
2 1833 class,name,number,type
2 1834 class1,name1,number1,type2
2 1835 class2,name2,number2,type2 *>
2 1836
2 1836 integer procedure next;
2 1837 begin
3 1838 next := class := get_next_element(name,number);
3 1839 type := if class = text_class then name_table(number,0) else class;
3 1840 end next;
2 1841
2 1841 integer procedure next1;
2 1842 begin
3 1843 next1 := class1 := get_next_element(name1,number1);
3 1844 type1 := if class1 = text_class then name_table(number,0) else class1;
3 1845 end next1;
2 1846
2 1846 integer procedure next2;
2 1847 begin
3 1848 next2:=class2:=get_next_element(name2,number2);
3 1849 type2 := if class2 = text_class then name_table(number,0) else class2;
3 1850 end next2;
2 1851
2 1851 integer procedure skip_next;
2 1852 begin
3 1853 long dummyname,dummynumber;
3 1854 skip_next:=get_next_element(dummyname,dummynumber);
3 1855 end skip_next;
2 1856
2 1856 integer procedure look;
2 1857 begin
3 1858 look := class := look_ahead_class;
3 1859 end look;
2 1860
2 1860 integer procedure look1;
2 1861 begin
3 1862 look1 := class1 := look_ahead_class;
3 1863 end look1;
2 1864
2 1864 integer procedure look2;
2 1865 begin
3 1866 look2:= class2 := look_ahead_class;
3 1867 end look2;
2 1868
2 1868
2 1868
2 1868
2 1868
2 1868
2 1868
2 1868 integer procedure get_next_element(name,number);
2 1869 long name,number;
2 1870 begin
3 1871 integer to,testclass;;
3 1872 get_next_element := testclass := get_element(name,number,line_pointer,to);
3 1873 element_no:=element_no+1;
3 1874 line_pointer := if line_pointer = no_of_elements then line_pointer else to;
3 1875 end get_next_element;
2 1876
2 1876
2 1876
2 1876 integer procedure get_element(name,number,from,to);
2 1877 value from; integer from,to; long name,number;
2 1878 begin
3 1879 integer class;
3 1880 for class:=read_kind(from) while class = delim_class do
3 1881 from := from + 1;
3 1882
3 1882 if class = text_class then
3 1883 begin
4 1884 if read_kind(from+1) <> text_class or
4 1885 ( read_kind(from+1) = text_class and read_value(from+1) = 0) then
4 1886 begin
5 1887 <* short text *>
5 1888 name := read_value(from);
5 1889 if name = find_name(1) then found := true;
5 1890 get_element := if look_up_name(name_table,name,number) then
5 1891 text_class else unknown_name_class;
5 1892 end
4 1893 else get_element := unknown_name_class;;
4 1894 <* skip to 1. not text element *>
4 1895 for from := from+1 while read_kind(from) = text_class do;
4 1896 to := from;
4 1897 end
3 1898 else
3 1899 if class = plus_class then
3 1900 begin
4 1901 if get_integer(number,from+1,to) then get_element := 2
4 1902
4 1902 else get_element := 1;
4 1903 end
3 1904 else
3 1905 if class = minus_class then
3 1906 begin
4 1907 if get_integer(number,from+1,to) then get_element:=2
4 1908 else get_element:=1;
4 1909 number:= number*(-1);
4 1910 end else
3 1911 if class = 2 then
3 1912 begin
4 1913 if get_integer(number,from,to) then get_element:=2
4 1914 else get_element := 1;
4 1915 end
3 1916 else
3 1917 if class = stop_line_class then
3 1918 begin
4 1919 number := read_value(from);
4 1920 if number extract 24 = 25 <* eof value *> then
4 1921 get_element := eof_class
4 1922 else
4 1923 get_element :=class;
4 1924 to :=from+1;
4 1925 end else
3 1926 begin
4 1927 number:=read_value(from);
4 1928 to := from+1;
4 1929 get_element := class;
4 1930 end;
3 1931 end get_element;
2 1932
2 1932
2 1932 boolean procedure get_integer(number,from,to);
2 1933 value from; integer from,to; long number;
2 1934 begin
3 1935 long base;
3 1936 if read_kind(from)<> 2 then get_integer:=false
3 1937 else
3 1938 begin
4 1939 if read_kind(from+1) = period_class then
4 1940 begin
5 1941 base:=read_value(from);
5 1942 from:=from+2;
5 1943 if read_kind(from) <> 2 then
5 1944 begin
6 1945 get_integer := false;
6 1946 to := from-1;
6 1947 end else
5 1948 begin
6 1949 number:=read_value(from);
6 1950 get_integer:=base_convert(base,number);
6 1951 to := from + 1;
6 1952 end;
5 1953 end else
4 1954 begin
5 1955 number:=read_value(from);
5 1956 get_integer := true;
5 1957 to := from + 1;
5 1958 end;
4 1959 end;
3 1960 end get_integer;
2 1961
2 1961
2 1961 boolean procedure base_convert(base,number);
2 1962 long base,number;
2 1963 begin
3 1964 integer shift_index; long number1,number2;
3 1965 number2:=0; shift_index :=0;
3 1966 base_convert := true;
3 1967 if base = 8 then
3 1968 begin
4 1969 for number1 := number mod 10 while number <> 0 do
4 1970 begin
5 1971 number := number // 10;
5 1972 if number1>7 or number1 < 0 then base_convert := false;
5 1973 number2:=number2 + number1 shift shift_index;
5 1974 shift_index := shift_index+3;
5 1975 end;
4 1976 number := number2;
4 1977 end else base_convert:=false;
3 1978 end base_convert;
2 1979 boolean procedure read_and_set_bits(operand);
2 1980 <******************************************>
2 1981 long array operand;
2 1982 begin
3 1983 boolean error;
3 1984 error := false;
3 1985
3 1985 repeat
3 1986 begin
4 1987 next;
4 1988 if class = left_par_class then
4 1989 begin
5 1990 if next1 <> number_class then
5 1991 error := true
5 1992 else
5 1993 if next<> colon_class then
5 1994 error := true
5 1995 else
5 1996 if next2 <> number_class then
5 1997 error := true
5 1998 else
5 1999 if next <> right_par_class then
5 2000 error := true;
5 2001 if number_1 <= number_2 and
5 2002 number_1 >= 0 and
5 2003 number_2 <= no_of_bits_in_code and
5 2004 -, error then
5 2005 error := -, set_bits(operand,number1 extract 24,
5 2006 number2 extract 24)
5 2007 else error := true;
5 2008 next;
5 2009
5 2009 end else
4 2010 if class = number_class then
4 2011 begin
5 2012 if number >= 0 and number <= no_of_bits_in_code then
5 2013 error := -, set_bits(operand,number extract 24,
5 2014 number extract 24)
5 2015 else error := true;
5 2016 next;
5 2017
5 2017 end;
4 2018 end;
3 2019 until class <> comma_class or error;
3 2020 read_and_set_bits := -, error;
3 2021
3 2021 end read_and_set_bits;
2 2022
2 2022 boolean procedure set_bits(operand,bit_low,bit_high);
2 2023 <****************************************************>
2 2024 value bit_low,bit_high; integer bit_low,bit_high;
2 2025 long array operand;
2 2026 begin
3 2027 integer
3 2028 index_low,
3 2029 index_high,
3 2030 bit_high_in_word,
3 2031 bit_low_in_word,
3 2032 word_index;
3 2033
3 2033 if bit_high < bit_low then
3 2034 set_bits := false
3 2035 else
3 2036 begin
4 2037 index_low := case ( bit_low//48) + 1 of
4 2038 (1,2,3,4,5,6,7,8);
4 2039 index_high := case (bit_high//48) + 1 of
4 2040 (1,2,3,4,5,6,7,8);
4 2041 bit_low_in_word := bit_low mod 48;
4 2042 bit_high_in_word := bit_high mod 48;
4 2043 if index_low = index_high then
4 2044 begin
5 2045 operand(index_low) := log_or(operand(index_low),
5 2046 extend(-1) shift ((-48)+(bit_high_in_word+1-bit_low_in_word))
5 2047 shift (47 - bit_high_in_word));
5 2048 end
4 2049 else
4 2050 begin
5 2051 operand(index_low) := log_or(operand(index_low),
5 2052 extend (-1) shift ( - bit_low_in_word));
5 2053 operand(index_high) := log_or(operand(index_high),
5 2054 extend(-1) shift (47 - bit_high_in_word));
5 2055 for word_index := index_low+1 step 1 until index_low - 1 do
5 2056 operand(word_index) := -1;
5 2057 end;
4 2058 set_bits := true;
4 2059 end;
3 2060
3 2060 end set_bits;
2 2061
2 2061
2 2061
2 2061 long procedure init_mask(operand,from,to);
2 2062 <******************************************>
2 2063 value from,to,operand; long operand; integer from,to;
2 2064 init_mask:=mask_in(operand,extend (-1),
2 2065 extend (-1) shift ((-48)+(to+1-from)) shift (47-to));
2 2066
2 2066
2 2066 <* *************************************************
2 2067 directive procedures section
2 2068 ************************************************* *>
2 2069
2 2069 procedure directive_skip_until;
2 2070 begin
3 2071 boolean until_condition_met;
3 2072
3 2072 long skip_end_name;
3 2073 next1;
3 2074
3 2074 if class1 = text_class or class1 = unknown_name_class then
3 2075 begin
4 2076 skip_end_name := name1;
4 2077 repeat
4 2078 if list_all then list_line;
4 2079 read_next_source_line;
4 2080
4 2080 if class = star_class then
4 2081 begin
5 2082 next1;
5 2083 if name1 = long <:until:> then
5 2084 begin
6 2085 next1;
6 2086 if class1 = colon_class then
6 2087 next1;
6 2088 if name1 = skip_end_name then
6 2089 until_condition_met := true;
6 2090 end;
5 2091 end control of first token;
4 2092 until until_condition_met;
4 2093 end else
3 2094 error(directive,line_no,element_no);
3 2095 return_from_skip := true;
3 2096 end directive_skip_until;
2 2097 procedure directive_onlyin_logic(mode);
2 2098 <********************************>
2 2099 value mode; boolean mode;
2 2100 <* if mode is true then skip only in is performed
2 2101 else skip not in is performed *>
2 2102 begin
3 2103 <* check the param list to se the param
3 2104 mode.<text> , where <text> schall be equal
3 2105 the next element *>
3 2106 long array param_name,until_name,only_name(1:2);
3 2107 integer param_call_result;
3 2108 boolean until_condition_met;
3 2109
3 2109
3 2109 param_call_result := get_text_string(<:version:>,param_name);
3 2110 class1 := get_long_name(only_name);
3 2111 if param_call_result <> 0 or
3 2112 (param_call_result = 0 and
3 2113 (( mode and (param_name(1) <> only_name(1) or
3 2114 param_name(2) <> only_name(2)))
3 2115 or
3 2116 ( -, mode and param_name(1) = only_name(1) and
3 2117 param_name(2) = only_name(2) ))) then
3 2118
3 2118 begin
4 2119 <* skip until a 'until' directive is met with
4 2120 with the version text as parameter. *>
4 2121 until_condition_met := false;
4 2122 repeat
4 2123 if list_all then list_line;
4 2124 read_next_source_line;
4 2125 if class = eof_class then until_condition_met := true;
4 2126
4 2126 if class = star_class then
4 2127 begin
5 2128 next1;
5 2129 if name1 = long <:until:> then
5 2130 begin
6 2131 next1;
6 2132 if class1 = colon_class then
6 2133 class1 := get_long_name(until_name);
6 2134 if class1 > 0 and
6 2135 only_name(1) =until_name(1) and
6 2136 only_name(2) = until_name(2) then
6 2137 until_condition_met := true;
6 2138 end;
5 2139 end control of first token 'colon' ;
4 2140 until until_condition_met;
4 2141 end skip not this version ;
3 2142 return_from_skip := true;
3 2143
3 2143
3 2143 end directive_only_in;
2 2144
2 2144
2 2144 procedure include_source_file;
2 2145 <****************************>
2 2146 begin
3 2147 long array file_name(1:2);
3 2148 integer stack_result;
3 2149 class1 := get_long_name(file_name);
3 2150 if class1 > 0 then
3 2151 begin
4 2152 stack_result := stack_and_connect_in(file_name);
4 2153 if list then list_line;
4 2154
4 2154 if stack_result <> 0 then
4 2155 write(out,"*",4,<: copy connect error: :>,file_name,"nl",1)
4 2156 else
4 2157 write(out,<: micasm source : :>,file_name,"nl",1);
4 2158 end else
3 2159 error(directive,line_no,element_no);
3 2160 end include_source_file;
2 2161
2 2161
2 2161
2 2161
2 2161
2 2161
2 2161
2 2161 procedure list_line;
2 2162 <*******************>
2 2163 begin
3 2164 if -, line_listed then
3 2165 begin
4 2166 line_listed := true;
4 2167 if line_num then write(out,<<dddd>,line_no);
4 2168 if code_generated then
4 2169 begin
5 2170 if dec_code then write(out,<<_zddd>,instr_index);
5 2171 if octal_code then write(out,<<_zddd>,octal(extend instr_index));
5 2172 outchar(out,'sp');
5 2173 end
4 2174 else
4 2175 begin
5 2176 if dec_code then write(out,"sp",5);
5 2177 if octal_code then write(out,"sp",5);
5 2178 outchar(out,'sp');
5 2179 end;
4 2180 line_pointer := 0;
4 2181 for line_pointer := line_pointer+1
4 2182 while line_pointer <= no_of_elements do
4 2183 begin
5 2184 if read_kind(line_pointer) = 6 then
5 2185 begin
6 2186 write(out,string read_value(increase(line_pointer)));
6 2187 line_pointer := line_pointer - 1;
6 2188 end
5 2189 else
5 2190 if read_kind(line_pointer) = 2 then
5 2191 write(out,<<d>,read_value(line_pointer))
5 2192 else
5 2193 outchar(out,read_value(line_pointer) extract 8);
5 2194 end;
4 2195 end;
3 2196 end list_line;
2 2197
2 2197
2 2197
2 2197
2 2197 procedure read_next_source_line;
2 2198 <******************************>
2 2199 begin
3 2200 <* reset boolean control *>
3 2201 error_in_this_line := false ;
3 2202
3 2202 code_generated := false;
3 2203 alu_function_performed := false;
3 2204 jump_sekvens_performed := false;
3 2205 addrs_performed := false;
3 2206 shift_condition_performed := false;
3 2207 jump_addrs_performed := false;
3 2208 line_listed := false;
3 2209
3 2209 line_pointer := 1;
3 2210 element_no := 0;
3 2211 no_of_elements := read_all(in,read_value,read_kind,1);
3 2212 line_no := line_no + 1;
3 2213 next;
3 2214 end read_next_source_line;
2 2215
2 2215
2 2215
2 2215
2 2215
2 2215
2 2215
2 2215
2 2215
2 2215 plus_label_dec := long <:plus label dec.:>;
2 2216 declaration := long <:declaration:>;
2 2217 operand_type := long <:operand type:>;
2 2218 minus_delim := long <:minus delim.:>;
2 2219 missing_operand := long <:missing operand.:>;
2 2220 label_dec:= long <:label dec.:>;
2 2221 illegal_type := long <:illegal type:>;
2 2222 plus_name_dec := long <:plus name dec.:>;
2 2223 name_unknown := long <:name unknown:>;
2 2224 directive := long <:directive:>;
2 2225 unknown := long <:unknown:>;
2 2226 name_length := long <:name length exeedes 6 char.:>;
2 2227 delimiter := long <:delimiter:>;
2 2228 undec_label := long <:undec. label or addrs. :>;
2 2229 multiple_function := long <:multiple function.:>;
2 2230 plus_addrs_def := long <:plus addrs def.:>;
2 2231 minus_addrs_def := long <:minus addrs. def.:>;
2 2232 illegal_source := long <:illegal source:>;
2 2233 illegal_dest := long <:illegal destination:>;
2 2234 illegal_dest_and_source := long <:illegal destination and or source :>;
2 2235 save_file_name := long <:illegal save file name:>;
2 2236 load_file_name := long <:illegal load file name:>;
2 2237 termination := long <:termination:>;
2 2238 operand := long <:unknown operand:>;
2 2239 algol copy.3 <* schould be m290xinit *>;
t2903init d.801208.1518
2 2239
2 2240
2 2240
2 2240
2 2240
2 2240
2 2240 <* def. of micro types *>
2 2241 alu_function_type := 11;
2 2242 jump_addrs_type := 12;
2 2243 <*not def. type := 13 *>
2 2244 jump_sekvens_type := 14;
2 2245 load_counter_type :=15;
2 2246 special_type :=16;
2 2247 special_min:=0;
2 2248 special_max:=32;
2 2249
2 2249 reg_op_type := 30;
2 2250 condition_type := 40;
2 2251 condition_type_min :=40;
2 2252 condition_type_max:=45;
2 2253 <* init of format to be printed *>
2 2254
2 2254 format(0) := 0;
2 2255 format(1) := 1 shift 12 + 4;
2 2256 format(2) := 5 shift 12 + 5;
2 2257 format(3) := 6 shift 12 + 6;
2 2258 format(4) := 7 shift 12 + 10;
2 2259 format(5) := 11 shift 12 + 15;
2 2260 format(6) := 16 shift 12 + 20;
2 2261 format(7) := 21 shift 12 + 22;
2 2262 format(8) := 23 shift 12 + 27;
2 2263 format(9) := 28 shift 12 + 31;
2 2264 format(10) := 32 shift 12 + 35;
2 2265 format(11) := 36 shift 12 + 39;
2 2266 format(12) := 40 shift 12 + 41;
2 2267 format(13) := 42 shift 12 + 43;
2 2268 format(14) := 44 shift 12 + 47;
2 2269
2 2269 <* initialiasing standard mask *>
2 2270 condition_enable_mask := init_mask(extend 0,0,0);
2 2271 sekvens_mask := init_mask(extend 0,1,4);
2 2272 cond_my_reg_enable_mask := init_mask(extend 0,5,5);
2 2273 cond_m_reg_enable_mask := init_mask(extend 0,6,6);
2 2274 condition_select_mask := init_mask(extend 0,7,10);
2 2275 condition_full_mask := init_mask(extend 0,6,10);
2 2276 alu_full_length_mask := init_mask(extend 0,11,20);
2 2277 alu_dest_mask := init_mask(extend 0,11,15); <*alubiti8tobothi5*>
2 2278 alu_short_dest_mask := init_mask(extend 0,11,13); <* alu bit 8 to 6
2 2279 not i5 *>
2 2280 alu_i5_left_mask := init_mask(extend 0,14,14);
2 2281 alu_i5_rigth_mask := init_mask(extend 0,15,15);
2 2282 alu_both_i5_mask := init_mask(extend 0,14,15);
2 2283 alu_function_mask := init_mask(extend 0,16,19); <*alubiti4toi1*>
2 2284 alu_full_function_mask := init_mask(extend 0,16,20); <*alubiti4toi0*>
2 2285 alu_special_control_mask := init_mask(extend 0,20,20); <*alubiti0*>
2 2286 carry_control_mask := init_mask(extend 0,21,22);
2 2287 set_2904_shift_mask := init_mask(extend 0,23,23);
2 2288 not_ea_mask := init_mask(extend 0,24,24);
2 2289 w_reg_enable_mask := init_mask(extend 0,25,25);
2 2290 w_reg_enable_sel_mask := init_mask(init_mask(extend 0,25,25),35,35);
2 2291 not_oeb_mask := init_mask(extend 0,26,26);
2 2292 read_2901_reg_mask := init_mask(extend 0,26,26);
2 2293 write_2901_reg_mask := init_mask(extend 0,27,27);
2 2294 alu_full_source_mask := init_mask(init_mask(extend 0,20,20),25,27);
2 2295 <*noteaandnotoebandalubiti0*>
2 2296 source_extern_mask := init_mask(extend 0,26,26);
2 2297 dest_extern_mask := init_mask(extend 0,27,27);
2 2298 short_source_mask := init_mask(extend 0,28,31);
2 2299 short_dest_mask := init_mask(extend 0,32,35);
2 2300 source_mask := init_mask(extend 0,28,31);
2 2301 dest_mask := init_mask(extend 0,32,35);
2 2302 addrs_and_imm_mask := init_mask(extend 0,36,47);
2 2303 addrs_mask := init_mask(extend 0,36,47);
2 2304 <* addrs and immidiate operand m*>
2 2305 cond_kind_set_mask := init_mask( init_mask(extend 0,23,23),40,41);
2 2306 not_half_w_move_enable_mask := init_mask(extend 0,42,42);
2 2307 half_w_move_dir_mask := init_mask(extend 0,43,43);
2 2308 half_word_move_mask := init_mask(init_mask(extend 0,23,23),42,43);
2 2309 shift_control_2904_mask := init_mask(init_mask(extend 0,23,23),44,47); <*controlsthe2904instrbiti6toi9*>
2 2310 all_m_reg_enable_mask := init_mask(init_mask(extend 0,6,6),45,47);
2 2311 select_m_reg_enable_mask := init_mask(extend 0,45,47);
2 2312 select_interupt_bit_mask := init_mask(extend 0,46,46);
2 2313 instr_full_length:= init_mask(extend 0,0,47);
2 2314 <*allbitsininstr*>
2 2315
2 2315 q_regs_value := -1;
2 2316 w_pre_index_value := -3;
2 2317 w_index_value := -2;
2 2318 code_kind := 31;
2 2319 start_addrs := 0;
2 2320
2 2320 nop_code := mask_in(extend 0,extend 14,sekvens_mask);
2 2321 nop_code := mask_in(nop_code,extend 1,cond_m_reg_enable_mask);
2 2322 nop_code := mask_in(nop_code,extend 6,alu_short_dest_mask);
2 2323 nop_code := mask_in(nop_code,extend 0,alu_both_i5_mask);
2 2324 nop_code := mask_in(nop_code,extend 1,alu_special_control_mask);
2 2325 nop_code := mask_in(nop_code,extend 1,set_2904_shift_mask);
2 2326 nop_code := mask_in(nop_code,extend 0,not_ea_mask);
2 2327 nop_code := mask_in(nop_code,extend 0,w_reg_enable_mask);
2 2328 nop_code := mask_in(nop_code,extend 0,not_oeb_mask);
2 2329 nop_code := mask_in(nop_code,extend 0,write_2901_reg_mask);
2 2330 nop_code := mask_in(nop_code,extend 1,cond_kind_set_mask);
2 2331 nop_code := mask_in(nop_code,extend 3,half_word_move_mask);
2 2332 nop_code := mask_in(nop_code,extend 0,shift_control_2904_mask);
2 2333 nop_code := mask_in(nop_code,extend 1,set_2904_shift_mask);
2 2334
t290xasm
2 2334
2 2334
2 2334 init_long_array(name_table,-1);
2 2335
2 2335 init_HEAP;
2 2336 <* init of fields *>
2 2337
2 2337 no_of_errors := 0;
2 2338 error_record_chain_head := nil;
2 2339 error_record_text := 4;
2 2340 error_record_line_no := 8;
2 2341 error_record_element_pos := 10;
2 2342 error_record_chain := 6;
2 2343 error_record_instr_index := 12;
2 2344 error_record_length := 12;
2 2345
2 2345
2 2345 l_d_record_chain_head := nil;
2 2346 l_d_name := 4;
2 2347 l_d_chain := 8;
2 2348 l_d_spec := 2;
2 2349 l_d_index := 4;
2 2350 l_d_line_no := 6;
2 2351 l_d_spec_class := 10;
2 2352 l_d_record_length := 10;
2 2353 map_spec := 1; vector_spec := 2;
2 2354
2 2354 l_r_chain := 2;
2 2355 l_r_name := 6;
2 2356 l_r_index := 8;
2 2357 l_r_line_no := 10;
2 2358 l_r_element_no := 12;
2 2359 l_r_record_length := 12;
2 2360 l_r_record_chain_head :=nil; <* no label refference blocks *>
2 2361 name_name := 8;
2 2362 name_chain := 2;
2 2363 name_type := 4;
2 2364 name_record_length := 8;
2 2365 name_table(0,0) := name_table_length;
2 2366 <* asm. begin *>
2 2367 prom_code := -1;
2 2368 for index := 0 step 1 until length_of_code-1 do
2 2369 opcode(index):=prom_code;
2 2370 begin
3 2371 integer array tail(1:20);
3 2372 zone dummy(128,1,stderror);
3 2373 real r;
3 2374 integer i,j,lookup_result;
3 2375 long array mic_asm_prog_name,program_name(1:2);
3 2376 i:=system(2,j,program_name);
3 2377 open(dummy,4,programname,0);
3 2378 lookup_result:=monitor(42,dummy,0,tail);
3 2379 write(out,"ff",1,<:Micro asm.:__:>,true,12,program_name,
3 2380 <: version date.:>,
3 2381 <<zddddd.dddd>,systime(6,tail(6),r) + r/1000000,"nl",1);
3 2382 close(dummy,true);
3 2383 if connect_file_in(mic_asm_prog_name) = 4 then
3 2384 write(out,"nl",1,"*",5,<:Source file connect error::>,
3 2385 mic_asm_prog_name);
3 2386 get_connected_name(in,micasm_prog_name);
3 2387 lookup_result:=monitor(42,in,0,tail);
3 2388 write(out,"nl",1,<:Source file:_:>,true,12,
3 2389 mic_asm_prog_name,<: version date.:>,
3 2390 <<zddddd.dddd>,systime(6,tail(6),r)+r/1000000,"nl",1);
3 2391
3 2391
3 2391 <* control if any and get name of object file *>
3 2392 if get_left_side(object_file_name) = 0 then
3 2393 object_file := true else object_file := false;
3 2394 if object_file then
3 2395 begin
4 2396 open(dummy,0,object_file_name,0);
4 2397 lookup_result := monitor(42) lookup tail:(dummy,0,tail);
4 2398
4 2398 if lookup_result <> 0 then
4 2399 object_file := false;
4 2400 write(out,"nl",1,if objectfile then
4 2401 <:Object file:_:> else <:*** Unknown object file::>,
4 2402 true,12,object_file_name);
4 2403 if objectfile then
4 2404 write(out,<: version date.:>,
4 2405 <<zdddddd.dddd>,systime(6,systime(7,0,0.0),r)+r/1000000);
4 2406 outchar(out,'nl');
4 2407 close(dummy,true);
4 2408 end;
3 2409 end block with control of files;
2 2410
2 2410
2 2410
2 2410 <* get and control of other parameters,
2 2411 unknown parameters is ignored. *>
2 2412 get_bool_string(<:help:>,help_wanted);
2 2413 if help_wanted then help_string(<:micasmhelp:>);
2 2414 if get_bool_string(<:message:>,message_list) <> 0 then
2 2415 message_list := true;
2 2416 list_all := false;
2 2417 if get_bool_string(<:list:>,list) <> 0 then
2 2418 begin
3 2419 long array param_name(1:2);
3 2420 if get_text_string(<:list:>,param_name) = 0 then
3 2421 begin
4 2422 if param_name(1) = long <:all:> then list:=list_all := true;
4 2423 end;
3 2424 end;
2 2425 if get_bool_string(<:linenum:>,line_num) <> 0 then line_num:= true;
2 2426 if get_bool_string(<:deccode:>,dec_code) <> 0 then dec_code := true;
2 2427 if get_bool_string(<:octal:>,octal_code) <> 0 then
2 2428 begin
3 2429 octal_code := true;
3 2430 if get_text_string(<:octal:>,param_name) = 0 then
3 2431 begin
4 2432 if param_name(1) = long <:only:> then dec_code:= line_num := false;
4 2433 end;
3 2434 end;
2 2435 if get_text_string(<:find:>,find_name) = 0 then find := true;
2 2436
2 2436 if get_bool_string(<:errors:>,list_error_lines) <> 0 and
2 2437 get_bool_string(<:errorlines:>,list_error_lines) <> 0 and
2 2438 get_bool_string(<:els:>,list_error_lines) <> 0 then
2 2439 list_error_lines := true;
2 2440 get_bool_string(<:code:>,print_code);
2 2441 get_bool_string(<:labelxref:>,test_label_ref);
2 2442 get_bool_string(<:labelbit:>,test_label_bit);
2 2443 get_bool_string(<:entry:>,entry_list_wanted);
2 2444 get_bool_string(<:bitlines:>,list_bit_lines);
2 2445 return_from_skip := false;
2 2446
2 2446 <* initializing of counting variables and
2 2447 reading of first code line *>
2 2448
2 2448
2 2448 instr_index:=0;
2 2449 present_code := nop_code;
2 2450 error_in_this_line := false;
2 2451 line_no := 0;
2 2452 read_next_source_line;
2 2453
2 2453 while class <> eof_class do
2 2454 begin
3 2455 if class = stop_line_class then
3 2456 begin
4 2457 <*
4 2458 end line , or
4 2459 comment . Commant wil be be created by
4 2460 get_next_element *>
4 2461 if (list or (error_in_this_line and list_error_lines )
4 2462 or ( find and found ))
4 2463 and ( -, return_from_skip or list_all) then
4 2464 list_line;
4 2465 return_from_skip := false;
4 2466 found := false;
4 2467 if print_code and code_generated then
4 2468 begin
5 2469 if -, list and -, list_bit_lines and
5 2470 -, (error_in_this_line and list_error_lines) then
5 2471 write(out,<<-zddd>,instr_index,
5 2472 octal(extend instr_index),"sp",1)
5 2473 else
5 2474 if -, list and list_bit_lines and
5 2475 -, (error_in_this_line and list_error_lines) then
5 2476 begin
6 2477 list_line;
6 2478 write(out,<: :>);
6 2479 end
5 2480 else
5 2481 write(out,<: :>);
5 2482 print_formated(present_code);
5 2483 outchar(out,10);
5 2484 end;
4 2485 if code_generated then
4 2486 begin
5 2487 op_code(instr_index):=present_code;
5 2488 instr_index:=instr_index+1;
5 2489 present_code := nop_code;
5 2490 end;
4 2491 <* read next line of source text *>
4 2492 read_next_source_line;
4 2493 end class 2 new line
3 2494 else
3 2495 if class = text_class or class = unknown_name_class then
3 2496 begin
4 2497 class_2 := look_ahead_class;
4 2498 if class_2 = colon_class or class_2 = slash_class then
4 2499 begin
5 2500 spec_class := nil;
5 2501 if element_no = 1 and class = unknown_name_class then
5 2502 begin
6 2503 if class2 = slash_class then
6 2504 begin
7 2505 skip_next;
7 2506 look2;
7 2507 if class2 = quote_class or class2 = double_quote_class then
7 2508 begin
8 2509 spec_class := if class2 = quoteclass then map_spec else vectorspec;
8 2510 skip_next; <* skip quote or double quote *>
8 2511 look2;
8 2512 end;
7 2513
7 2513 if class2 = number_class or class2 = colon_class then
7 2514 begin
8 2515
8 2515 if class_2 = number_class then
8 2516 begin
9 2517 next1;
9 2518 class2 := look_ahead_class;
9 2519 end
8 2520 else
8 2521 number_1 := line_no;
8 2522 if class2 = colon_class then
8 2523 begin
9 2524 new_insert_label_def(name,number,instr_index,line_no,
9 2525 number1 extract 24,spec_class);
9 2526 end else
8 2527 error(directive,line_no,element_no);
8 2528 end
7 2529 else
7 2530 error(directive,line_no,element_no);
7 2531 end
6 2532 else
6 2533 begin
7 2534 new_insert_label_def(name,number,instr_index,line_no,
7 2535 nil,spec_class)
7 2536 end;
6 2537 next;
6 2538 end
5 2539
5 2539 else
5 2540 error(label_dec,line_no,element_no);
5 2541 next;
5 2542 end
4 2543 else
4 2544 begin
5 2545 if class = unknown_name_class then
5 2546 begin
6 2547 error(name_unknown,line_no,element_no);
6 2548 skip_until_delim_class;
6 2549 next;
6 2550 end
5 2551 else
5 2552 if name_table(number,0) = alu_function_type then
5 2553 alu_function
5 2554 else
5 2555 if name_table(number,0) = jump_addrs_type then
5 2556 jump_addrs
5 2557 else
5 2558 if name_table(number,0) = jump_sekvens_type then
5 2559 jump_sekvens
5 2560 else
5 2561 if name_table(number,0) = load_counter_type then
5 2562 load_counter
5 2563 else
5 2564 if name_table(number,0) = special_type then
5 2565 special
5 2566 else
5 2567 begin
6 2568 error(illegal_type,line_no,element_no);
6 2569 next
6 2570 end;
5 2571 end;
4 2572 end type equal identifier
3 2573 else
3 2574 if class = star_class then
3 2575 begin
4 2576 <* After star is assm. directive,
4 2577 1 direktive pr. line,
4 2578 after the direktive the rest of the line is skipped,
4 2579 the direktive schould be the first element in the line *>
4 2580 if code_generated then error(directive,line_no,element_no)
4 2581 else
4 2582 begin
5 2583 next1;
5 2584 next2;
5 2585 if (class1 <> 9 and class1 <> 6 ) or class2 <> colon_class <*colon*> then
5 2586 error(long <:test dir 1 :>,line_no,if class2 <> colon_class then element_no else
5 2587 element_no -1)
5 2588 else
5 2589 begin
6 2590 if name1 = long <:name:> then
6 2591 begin
7 2592 next1;
7 2593 if class1 <> 9 then
7 2594 error(if class1 <> 6 then long <:test dir 2.:> else
7 2595 plus_name_dec,line_no,element_no)
7 2596 else
7 2597 begin
8 2598 name_table(number1,1) := name1;
8 2599 index:=0;
8 2600
8 2600 for class2 := next2
8 2601 while class2 = comma_class and index < 5 do
8 2602 begin
9 2603 next2;
9 2604 if class2 = number_class then
9 2605 name_table(number1,index) := number2
9 2606 else
9 2607 if class2 = 6 <* defined name *> then
9 2608 name_table(number1,index) := number_2
9 2609 else
9 2610 begin
10 2611 error(long <:test dir. 3:>,line_no,element_no);
10 2612 index:=100;
10 2613 end;
9 2614 if index = 0 then index :=2 else
9 2615 if index<100 then index:=index+1;
9 2616 end;
8 2617 end;
7 2618 end else
6 2619
6 2619 if name1 = long <:const:> then
6 2620 begin
7 2621 next1;
7 2622 if class1 <> 9 then
7 2623 error(if class1 <> 6 then directive else
7 2624 plus_name_dec,line_no,element_no)
7 2625 else
7 2626 begin
8 2627 next2;
8 2628 if class2 = comma_class then
8 2629 begin
9 2630 next2;
9 2631 if class2 = number_class then
9 2632 begin
10 2633 new_insert_label_def(name1,number1,
10 2634 number2 extract 12,line_no,nil,nil);
10 2635 end
9 2636 else error(directive,line_no,element_no);
9 2637 end
8 2638 else error(directive,line_no,element_no);
8 2639 end;
7 2640 end else
6 2641
6 2641 if name1 = long <:mask:> then
6 2642 begin
7 2643 long array operand(1:1); <* only one word used *>
7 2644 boolean mask_succes;
7 2645 long mask_name,mask_number;
7 2646 operand(1) := 0;
7 2647 if next1 <> unknown_name_class then
7 2648 error(long <: directive 2:>,line_no,element_no)
7 2649 else
7 2650 if next2 <> comma_class then
7 2651 error(long <:directive 3:>,line_no,element_no)
7 2652 else
7 2653 begin
8 2654 mask_name := name1;
8 2655 mask_number := number1;
8 2656 mask_succes := read_and_set_bits(operand);
8 2657 if -, mask_succes then
8 2658 error(long <:directive 4:>,line_no,element_no)
8 2659 else
8 2660 begin
9 2661 name_table(mask_number,0) := mask_type;
9 2662 name_table(mask_number,1) := mask_name;
9 2663 name_table(mask_number,2) := operand(1);
9 2664
9 2664 end;
8 2665 end;
7 2666 end else
6 2667 if name1 = long <:origo:> then
6 2668 begin
7 2669 if next1 <> number_class then
7 2670 error(long <:test dir. 4:>,line_no,element_no)
7 2671 else
7 2672 instr_index := number1;
7 2673 end
6 2674 else
6 2675 if name1 = long <:list:> then
6 2676 begin
7 2677 next1;
7 2678 if name1 = long <:on:> or name1 = long <:yes:> then
7 2679 list := true
7 2680 else
7 2681 if name1 = long <:off:> or name1 = long <:no:> then
7 2682 list := false
7 2683 else
7 2684 error(long <:test dir 5:>,line_no,element_no)
7 2685 end else
6 2686 if name1 = long <:page:> then
6 2687 begin
7 2688 if list then
7 2689 outchar(out,12);
7 2690 end else
6 2691 if name1 = long <:skip:> then
6 2692 begin
7 2693 <* procedure skip logic *>
7 2694 directive_skip_until;
7 2695 end else
6 2696 if name1 = long <:onlyi:> add 'n' then
6 2697 begin
7 2698 <* procedure skip if not in named mode *>
7 2699 directive_onlyin_logic(true);
7 2700 end else
6 2701 if name1 = long <:notin:> then
6 2702 begin
7 2703 <* skip if named mode *>
7 2704 directive_onlyin_logic(false <* invert the onlyin logic *>);
7 2705 end else
6 2706 if name1 = long <:until:> then
6 2707 begin
7 2708 <* a until directive met outside the
7 2709 performing of the skip logic is blind *>
7 2710 return_from_skip := true;
7 2711 end else
6 2712 if name1 = long <:load:> then
6 2713 begin
7 2714 zone zntb(128,1,stderror);
7 2715 long array long_name(1:2);
7 2716 integer move_count,no_of_halfwords;
7 2717 long array field move_index;
7 2718 move_index := -4;
7 2719 class1 := get_long_name(long_name);
7 2720 if class1 >0 then
7 2721 begin
8 2722 open(zntb,4,longname,0);
8 2723 movecount:=(name_table_length +1)* 5 <*dimension*> * 4 <*halfwords*>;
8 2724 for movecount :=movecount while movecount > 0 do
8 2725 begin
9 2726 no_of_halfwords := if move_count > 512 then 512 else
9 2727 move_count;
9 2728 move_count := move_count - no_of_halfwords;
9 2729 inrec6(zntb,no_of_halfwords);
9 2730 to_from(name_table.move_index,zntb,no_of_half_words);
9 2731 move_index := move_index + no_of_half_words;
9 2732 end read and move;
8 2733 end else error(load_file_name,0,0);
7 2734 if false then
7 2735 begin
8 2736 <******* test *******>
8 2737 write(out,<:<12>load contents of name table::>);
8 2738 for move_count :=0 step 1 until name_table_length do
8 2739 write(out,<:<10>:>,move_count,name_table(move_count,0),
8 2740 name_table(move_count,1),
8 2741 name_table(move_count,2),
8 2742 name_table(move_count,3),
8 2743 name_table(move_count,4));
8 2744 end test;
7 2745 end else
6 2746 if name1 = long <:save:> then
6 2747 begin
7 2748 zone zntb(128,1,stderror);
7 2749 integer movecount,no_of_half_words;
7 2750 integer array field move_index;
7 2751 long array long_name(1:2);
7 2752 class1:=get_long_name(long_name);
7 2753 if class1>0 then
7 2754 begin
8 2755 open(zntb,4,long_name,0);
8 2756 if false then
8 2757 begin
9 2758 <***** test ***>
9 2759 write(out,<:<12>contents of saved name table::>);
9 2760 for move_count := 0 step 1 until name_table_length do
9 2761 write(out,<:<10>:>,movecount,name_table(move_count,0),
9 2762 name_table(move_count,1),
9 2763 name_table(move_count,2),
9 2764 name_table(move_count,3),
9 2765 name_table(move_count,4));
9 2766 end test;
8 2767 movecount := (name_table_length +1)* 5 <*dimmension*> * 4 <*halfwords*>;
8 2768 move_index := -4;
8 2769 for movecount := movecount while movecount > 0 do
8 2770 begin
9 2771 no_of_halfwords := if movecount > 512 then 512 else
9 2772 movecount;
9 2773 movecount := movecount - no_of_half_words;
9 2774 outrec6(zntb,no_of_half_words);
9 2775 tofrom(zntb,name_table.move_index,no_of_half_words);
9 2776 move_index := moveindex + no_of_half_words;
9 2777 end move and write;
8 2778 close(zntb,true);
8 2779 end else error(save_file_name,0,0);
7 2780 end else
6 2781 if name1 = long <:end:> then
6 2782 begin
7 2783 class := eof_class;
7 2784 if list then list_line;
7 2785 end else
6 2786 if name1 = long <:copy:> then
6 2787 begin
7 2788 include_source_file;
7 2789 end
6 2790 else
6 2791
6 2791 if name1 = long <:test:> then
6 2792 begin
7 2793 next;
7 2794 if class <> 9 and class <> 6 then
7 2795 error(long <:test dir t1:>,line_no,element_no)
7 2796 else
7 2797 begin
8 2798 if name = long <:on:> or name = long <:yes:> then
8 2799 test := true
8 2800 else
8 2801 if name = long <:off:> or name = long <:no:> then
8 2802 test := false
8 2803
8 2803 else
8 2804 if name = long <:biton:> or name = long <:bitye:> add 115 then
8 2805 print_code := true
8 2806 else
8 2807 if name = long <:bitof:> add 102 or name = long <:bitno:> then
8 2808 print_code := false
8 2809
8 2809 else
8 2810
8 2810 if name = long <:labre:> add 102 then
8 2811 test_label_ref := true
8 2812
8 2812 else
8 2813
8 2813 if name = long <:labbi:> add 116 then
8 2814 test_label_bit := true
8 2815 else error(directive,line_no,element_no);
8 2816 end;
7 2817 end
6 2818
6 2818 else
6 2819 error(long <:unknown directive:>,line_no,element_no-1);
6 2820 end;
5 2821 end;
4 2822 class := if class <> eof_class then stop_line_class
4 2823 else eof_class;
4 2824 end directive class
3 2825 else
3 2826 if class = semicolon_class then
3 2827 begin
4 2828 <*
4 2829 comment start *>
4 2830 class := stop_line_class;
4 2831 end
3 2832 else
3 2833 if class = long_text_class then
3 2834 begin
4 2835 error(name_length,line_no,element_no);
4 2836 next;
4 2837 end
3 2838 else
3 2839 begin
4 2840 <* class is something else *>
4 2841 error(delimiter,line_no,element_no);
4 2842 next;
4 2843 end;
3 2844 if class = eof_class then
3 2845 begin
4 2846 long array mic_asm_prog_name(1:2);
4 2847
4 2847 integer result;
4 2848 result := connect_file_in(mic_asm_prog_name);
4 2849
4 2849 if result = 0 then
4 2850 begin
5 2851 write(out,"nl",1,<: micasm source file: :>,mic_asm_prog_name);
5 2852 read_next_source_line;
5 2853 end;
4 2854
4 2854 end;
3 2855 end scan loop;
2 2856 last_instr_index := instr_index ;
2 2857 resolve_labels;
2 2858 <* temp delete
2 2859
2 2859
2 2859
2 2859
2 2859
2 2859 for index:=1 step 1 until label_ref_index do
2 2860 begin
2 2861
2 2861
2 2861 name := label_ref_table(index,0);
2 2862 if -, lookup_name(label_def_table,name,number) then
2 2863 begin
2 2864 instr_index := label_ref_table(index,2);
2 2865 error(undec_label,label_ref_table(index,1) extract 24,
2 2866 label_ref_table(index,3) extract 24)
2 2867 end
2 2868
2 2868 else
2 2869 begin
2 2870 op_code(label_ref_table(index,2)):=
2 2871 mask_in(op_code(label_ref_table(index,2)),
2 2872 extend ( label_def_table(number,0) extract 24),addrs_mask);
2 2873 if test_label_bit or test_label_ref then
2 2874 begin
2 2875 write(out,"nl",1,"sp",5,<<zddd>,
2 2876 octal(label_ref_table(index,2)),
2 2877 <: label ref to: :>,
2 2878 octal(label_def_table(number,0)));
2 2879 if test_label_bit then
2 2880 begin
2 2881 write(out,<:<10> :>);
2 2882 print_formated(opcode(label_ref_table(index,2)));
2 2883 end;
2 2884 end;
2 2885 end;
2 2886 end label insert loop;
2 2887 if entry_list_wanted then
2 2888 begin
2 2889 <@ print label xref table @>
2 2890 procedure shellsort(n,file);
2 2891 value n;
2 2892 integer n;
2 2893 long array file;
2 2894 begin
2 2895 integer dist,i,k0,k,kmd;
2 2896 long a,fkmd,a_help,fkmd_help;
2 2897
2 2897 dist:= -1;
2 2898 for dist:= dist shift(-1) while dist>0 do
2 2899 if dist<n then
2 2900 begin
2 2901 for k0:= dist+1 step 1 until n do
2 2902 begin
2 2903 a:= file(k0,1);
2 2904 a_help := file(k0,2);
2 2905 k:= k0;
2 2906 p: kmd:= k-dist;
2 2907 if kmd>0 then
2 2908 begin
2 2909 fkmd:= file(kmd,1);
2 2910 fkmd_help := file(kmd,2);
2 2911 if fkmd>a then
2 2912 begin
2 2913 file(k,2) := fkmd_help;
2 2914 file(k,1):= fkmd;
2 2915 k:= kmd;
2 2916 goto p
2 2917 end
2 2918 end;
2 2919 file(k,1):= a;
2 2920 file(k,2) := a_help;
2 2921 end
2 2922 end
2 2923 end;
2 2924 integer sort_index;
2 2925 long array wr_name(1:2);
2 2926 comment
2 2927 shell_sort(label_def_table_length,label_def_table);
2 2928 wr_name(2):=0;
2 2929 for index := 1 step 1 until label_def_table_length do
2 2930 begin
2 2931 l_d_record := ((index-1)*8)+4;
2 2932 if label_def_table(index,0) > 0 and
2 2933 (label_def_table.l_d_record.l_d_spec >0)
2 2934 then
2 2935 begin
2 2936 wr_name(1):= label_def_table(index,1);
2 2937 write(out,false add 32,15 -
2 2938 write(out,<:<10>:>,wr_name),
2 2939 <:<13> :>,<: ref. to addrs.::>,
2 2940 <<__zddd>,
2 2941 label_def_table.l_d_record.l_d_index,
2 2942 octal(extend label_def_table.l_d_record.l_d_index),
2 2943 <: spec or line no.::>,label_def_table.l_d_record.l_d_spec -1);
2 2944 end;
2 2945 end;
2 2946 end write xref label table loop;
2 2947 end of temp delete *>
2 2948
2 2948 if test_label_ref then label_list(false);
2 2949
2 2949 if entry_list_wanted then label_list(true);
2 2950
2 2950
2 2950 if print_error_table then
2 2951 write(out,<:<10>MIC. ASM. OK! :>)
2 2952 else
2 2953 write(out,<:<10>MIC. ASM. SORRY!:>,<<_ddd>,no_of_errors,<: error(s):>,
2 2954 <: found.:>);
2 2955 write(out,"nl",1,<:LAST INSTR. ADDRS.::>,<<_dddd>,last_instr_index,
2 2956 <: OCTAL INSTR. ADDRS.::>,octal(extend(last_instr_index)));
2 2957
2 2957
2 2957
2 2957
2 2957
2 2957 if object_file then
2 2958 begin
3 2959 zone code_out(128,1,stderror);
3 2960 long array field code_block;
3 2961 integer short_clock;
3 2962 index :=1;
3 2963 open(code_out,4,object_file_name(increase(index)),0);
3 2964 setposition(code_out,0,1); <* start on segm 1. due to
3 2965 historic reasons *>
3 2966 for code_block :=-4,code_block + 512
3 2967 while code_block < 4*length_of_code - 4 do
3 2968 begin
4 2969 outrec6(code_out,512);
4 2970 to_from(code_out,op_code.code_block,512);
4 2971 end;
3 2972 for index := 1 step 1 until 10 do tail(index):=0;
3 2973 tail(1) :=1 + ( length_of_code//128);
3 2974 tail(6) := systime(7)short clock:(0,0.0);
3 2975 tail(9) := code_kind shift 12 + start_addrs extract 12;
3 2976
3 2976 tail(10) := length_of_code*4 + 512 <* first segm is dummy *>;
3 2977 monitor(44)change entry:(code_out,0,tail);
3 2978 close(code_out,true);
3 2979 end send object code to backing storage area;
2 2980 end dec of table block;
1 2981 write(out,<: TRANSLATOR BLOCKS::>,<<__d>,blocksread,"nl",1);
1 2982
1 2982 fp_proc(7,0,0,0); <* end program *>
1 2983 end
algol end 129
▶EOF◀