1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27 basic_:
28 proc (source_p, source_l, output_pointer, info_p, mp, err_count);
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69 which = 1;
70 main_pt = null;
71 source_info_pt = addr (auto_source_info);
72
73
74 if info_p = null
75 then do;
76 generate_object = "0"b;
77 source_info.dirname, source_info.segname, source_info.given_ename = "";
78 source_info.date_time_modified = 0;
79 source_info.unique_id = "0"b;
80 end;
81 else do;
82 generate_object = "1"b;
83 source_info.given_ename = old_source_info.segname;
84 source_info.date_time_modified = old_source_info.date_time_modified;
85 source_info.unique_id = old_source_info.unique_id;
86 call hcs_$fs_get_path_name (source_p, temp_dir, i, temp_ent, code);
87 source_info.dirname = substr (temp_dir, 1, i);
88 source_info.segname = rtrim (source_info.given_ename) || ".basic";
89 end;
90 source_info.version = compiler_source_info_version_2;
91 source_info.input_pointer = source_p;
92 source_info.input_lng = source_l;
93
94 add_lib_name = build_lib_list;
95 go to join;
96
97
98 compile:
99 entry (source_info_pointer, output_pointer, output_length, a_code);
100
101
102
103 which = 2;
104 generate_object = "1"b;
105 source_info_pt = source_info_pointer;
106 output_length = 0;
107 add_lib_name = build_lib_list;
108 go to join;
109
110
111 run_unit_compiler:
112 entry (source_info_pointer, output_pointer, output_length, debug_sw, get_next_source_seg_, add_to_lib_list_, a_code);
113
114
115
116 which = 3;
117 generate_object = "1"b;
118 source_info_pt = source_info_pointer;
119 output_length = 0;
120 add_lib_name = add_to_lib_list_;
121 go to join;
122
123
124
125 check_line:
126 entry (source_p, source_l);
127
128 which = 4;
129 source_info_pt = addr (auto_source_info);
130 generate_object = "0"b;
131 source_info.input_pointer = source_p;
132 source_info.input_lng = source_l;
133
134 dcl source_info_pointer ptr,
135 output_pointer ptr,
136 output_length fixed bin,
137 source_p ptr,
138 source_l fixed bin,
139 info_p ptr,
140 mp ptr,
141 err_count fixed bin;
142
143 dcl debug_sw bit (1) aligned, debug
144 a_code fixed bin (35),
145 get_next_source_seg_ entry (ptr) variable,
146
147 add_to_lib_list_ entry (char (*)) variable;
148
149
150
151
152 dcl ioa_ entry options (variable),
153 basic_next_line entry (ptr),
154 clock_ entry returns (fixed bin (71)),
155 get_temp_segment_ entry (char (*), ptr, fixed bin (35)),
156 release_temp_segment_ entry (char (*), ptr, fixed bin (35)),
157 add_lib_name entry (char (*), fixed bin (35)) variable,
158 hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
159 hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)),
160 get_group_id_ entry (char (32));
161
162
163
164 dcl (abs, addr, addrel, bit, convert, dim, fixed, float, hbound, index, ptr, lbound, null, string, length,
165 search, substr, unspec, binary, verify, max, min, mod, divide, sign, reverse, bin, rel, rtrim)
166 builtin;
167
168
169
170 dcl (cleanup, size, conversion, overflow, underflow)
171 condition;
172 ^L
173
174
175 dcl (
176 main_pt,
177 source_info_pt,
178 output_pt,
179 instruction_temp_ptr,
180 constant_ptr,
181 program_header_pt,
182 entry_pt,
183 token_pt,
184 temps_pt,
185 local_pt,
186 inst_pt,
187 table_pt (4),
188 basic_temp_ptr,
189 array_p,
190 lib_name_pt,
191 missing_pt
192 ) ptr;
193
194 dcl (
195 number_of_errors,
196 program_number,
197 statement_type,
198 current_token,
199 number_of_tokens,
200 number_of_assigns,
201 number_of_dims,
202 address_register_loaded,
203 matrix_type,
204 npars,
205 fn_start,
206 fn_name,
207 operand_level,
208 operator_level,
209 for_level,
210 current_line_number,
211 precision_lng,
212 odd_available (0:1),
213 operand_type (32),
214 operand_in_register (0:2),
215 operator (32),
216 i,
217 err,
218 which,
219 lib_count,
220 source_number,
221 for_type (8)
222 ) fixed bin;
223
224 dcl code fixed bin (35);
225 dcl auto_ctr (0:1) fixed bin (35);
226 dcl error_table_$translation_failed
227 ext fixed bin (35);
228
229 dcl dec_num float dec (22);
230
231 dcl small_numeric_data (100) float bin (63);
232 dcl small_string_data (100) fixed bin;
233 dcl small_line (200) fixed bin;
234
235 dcl (
236 output_pos,
237 local_ctr,
238 al_count,
239 block_size,
240 first_code_word,
241 last_instruction,
242 for_location (8),
243 large_table_offset (3),
244 table_pos (3),
245 table_max (3)
246 ) fixed bin (18);
247
248 dcl number_of_constants fixed bin (19);
249
250 dcl seg_name char (32) varying;
251 dcl temp_dir char (168);
252 dcl temp_ent char (32);
253
254 dcl (
255 numeric_data_count def table_pos (1),
256 string_data_count def table_pos (2),
257 number_of_lines def table_pos (3)
258 ) fixed bin (18);
259
260 dcl (
261 max_numeric_data_count def table_max (1),
262 max_string_data_count def table_max (2),
263 max_number_of_lines def table_max (3)
264 ) fixed bin (18);
265
266 dcl single bit (1) aligned;
267
268 dcl (
269 first_statement,
270 last_statement,
271 generate_object,
272 sub_ok,
273 small_table (3)
274 ) bit (1) aligned;
275
276 dcl (loc, next_loc) bit (18) aligned;
277
278 dcl (
279 modifier,
280 operand (32),
281 for_variable (8)
282 ) bit (36) aligned;
283
284 dcl 1 subprogram (50) aligned,
285 2 name char (32) varying,
286 2 header_pos fixed bin (18),
287 2 entry_pos fixed bin (18);
288
289 dcl 1 d_tokens (250) aligned,
290 2 type bit (18),
291 2 name char (8),
292 2 number fixed bin,
293 2 value float bin (63);
294
295 dcl 1 symbol_table aligned,
296 2 scalars (-286:286) bit (36),
297 2 dim_not_allowed (-26:26) bit (1) unaligned,
298 2 arrays (-26:26),
299 3 address bit (36),
300 3 dimensions fixed bin,
301 3 bounds (2) fixed bin;
302
303 dcl 1 normal_temps (0:2),
304 2 next fixed bin,
305 2 address (20) bit (36) aligned;
306
307 dcl 1 local_temps (0:2),
308 2 next fixed bin,
309 2 address (20) bit (36) aligned;
310
311 dcl 1 fn_table (-26:26) aligned,
312 2 address bit (36),
313 2 usage bit (18);
314
315 dcl 1 save aligned,
316 2 number (60) fixed bin,
317 2 address (60) bit (36);
318
319 dcl 1 missing_table (0:1) aligned,
320 2 count fixed bin,
321 2 missing_lines (100) unaligned,
322 3 chain bit (18),
323 3 number fixed bin (17);
324
325 dcl 1 fn_call_word,
326 2 number bit (5) unaligned,
327 2 mode bit (1) unaligned,
328 2 arg (30) bit (1) unaligned;
329
330 dcl 1 next_line_storage,
331 2 input_pt ptr,
332 2 input_length fixed bin,
333 2 input_pos fixed bin,
334 2 line_number fixed bin init (0),
335 2 error_number fixed bin,
336 2 class_tally fixed bin,
337 2 original_class_tally
338 fixed bin,
339 2 ch_tally fixed bin,
340 2 original_ch_tally fixed bin,
341 2 save_ch_tally fixed bin,
342 2 char fixed bin,
343 2 statement_number fixed bin,
344 2 statement_ending fixed bin,
345 2 temp_ch fixed bin,
346 2 skip (9) fixed bin,
347 2 ch_class (256) fixed bin,
348 2 ch (256) char (1) aligned;
349
350 dcl 1 source_map_info (20) aligned,
351 2 pathname char (168) var,
352 2 uid bit (36) aligned,
353 2 dtm fixed bin (71);
354 ^L
355
356
357
358 dcl basic_data$precision_length
359 fixed bin (35) ext static;
360
361 dcl 1 basic_error_messages_$
362 aligned ext,
363 2 index_block (0:500),
364 3 loc fixed bin,
365 3 sev fixed bin,
366 3 len fixed bin,
367 2 message_block char (248000);
368
369 dcl (
370 basic_data$array_prototype,
371 basic_data$constant_prototype,
372 basic_data$function_dummy,
373 basic_data$param_prototype,
374 basic_data$scalar_prototype
375 (0:1)
376 ) bit (36) aligned ext;
377
378 dcl 1 basic_data$instruction_sequences
379 (1:2) ext aligned like instructions;
380
381 dcl basic_severity_ fixed bin ext static;
382
383 dcl 1 instructions aligned based (inst_pt),
384 ( 2 add,
385 2 change (2),
386 2 check_eof,
387 2 compare,
388 2 data_read (0:1),
389 2 divide,
390 2 divide_inv,
391 2 end_input,
392 2 end_print,
393 2 enter_main,
394 2 enter_proc,
395 2 error (4),
396 2 file,
397 2 fneg,
398 2 fszn,
399 2 function_arg (5),
400 2 function_call (0:2),
401 2 function_return (0:1),
402 2 get_fcb_pt,
403 2 gosub,
404 2 inner_product,
405 2 input (0:1),
406 2 linput (0:1),
407 2 load (0:4),
408 2 margin,
409 2 mat_data_read (0:1),
410 2 mat_input (0:1),
411 2 mat_linput (0:1),
412 2 mat_print (0:1),
413 2 mat_print_using (0:1),
414 2 mat_read (0:1),
415 2 mat_write (0:1),
416 2 matrix_add_sub (2),
417 2 matrix_assign_numeric,
418 2 matrix_assign_string,
419 2 matrix_mult (3),
420 2 matrix_scalar_mult,
421 2 multiply,
422 2 on,
423 2 on_gosub,
424 2 power,
425 2 power_inverse,
426 2 print (0:1),
427 2 print_new_line,
428 2 print_using (0:1),
429 2 print_using_start,
430 2 print_using_end,
431 2 randomize,
432 2 read (0:1),
433 2 redimension (3),
434 2 reset_ascii,
435 2 reset_data,
436 2 reset_random,
437 2 return,
438 2 save_fcb_pt,
439 2 scratch,
440 2 setdigits,
441 2 stop,
442 2 store (0:2),
443 2 string_assign (0:1),
444 2 string_compare (0:1),
445 2 string_concatenate (0:1),
446 2 subend,
447 2 subprogram_call,
448 2 subscript (3),
449 2 subtract,
450 2 tab_for_comma,
451 2 tmi,
452 2 tnz,
453 2 tpl,
454 2 tpnz,
455 2 tra,
456 2 tze,
457 2 use_fcb,
458 2 use_file,
459 2 use_tty,
460 2 write (0:1)
461 ) bit (36) aligned;
462
463 dcl 1 basic_data$ascii_table
464 (1) aligned external,
465 2 val char (1),
466 2 abbreviation char (4);
467
468 dcl basic_data$ascii_table_length
469 fixed bin ext;
470
471 dcl 1 basic_data$statement_list
472 (34) aligned ext static,
473 2 first char (4),
474 2 rest char (8),
475 2 number fixed bin;
476
477 dcl 1 basic_data$statement_spelling
478 (26) external aligned,
479 2 (start, finish) fixed binary;
480
481 dcl 1 basic_data$functions (1) external aligned,
482 2 name char (4),
483 2 class fixed binary,
484 2 run_time bit (36) aligned;
485
486 dcl 1 basic_data$numeric_spelling
487 (26) external aligned,
488 2 (start, finish) fixed binary;
489
490 dcl 1 basic_data$string_spelling
491 (26) external aligned like basic_data$numeric_spelling;
492
493
494
495 dcl basic_data$function_templates
496 (34) bit (18) aligned external;
497
498 dcl 1 basic_data$relational_table
499 (1) aligned external,
500 2 name char (4);
501
502 dcl basic_data$relational_table_length
503 fixed bin ext;
504
505 dcl (
506 basic_data$normal_relational,
507 basic_data$inverse_relational
508 ) dim (1) bit (36) aligned external;
509
510 dcl basic_$symbol_table fixed bin ext;
511
512 dcl basic_version_$ char (132) ext;
513 ^L
514
515
516 dcl output_word (0:65536) bit (36) aligned based (output_pt);
517
518 dcl fixed_output_word (0:65536) fixed bin aligned based (output_pt);
519
520 dcl 1 half (0:8) aligned based,
521 2 (left, right) bit (18) unaligned;
522
523 dcl block (block_size) bit (36) aligned based;
524
525 dcl 1 missing aligned like missing_table based (missing_pt);
526
527 dcl missing_lines_word (100) fixed bin based (addr (missing.missing_lines));
528
529 dcl 1 tokens (250) aligned based (addr (d_tokens)),
530 2 type bit (18),
531 2 name char (8),
532 2 number fixed bin,
533 2 value float bin,
534 2 pad bit (36) aligned;
535
536 dcl 1 this_token like tokens aligned based (token_pt);
537
538 dcl 1 d_this_token like d_tokens aligned based (token_pt);
539
540 dcl scalar bit (36) aligned based;
541
542 dcl 1 array like arrays aligned based;
543
544 dcl 1 temps (0:2) like normal_temps aligned based (temps_pt);
545
546 %include basic_symbols;
547
548 %include basic_program_header;
549
550 dcl 1 basic_entry aligned based,
551 2 word_0 unaligned,
552 3 descriptor bit (18),
553 3 flag bit (1),
554 3 skip bit (17),
555 2 word_1 unaligned,
556 3 stack_size bit (18),
557 3 eax_7 bit (18),
558 2 word_2 bit (36),
559 2 word_3 bit (36),
560 2 header fixed binary;
561
562 dcl 1 source_info aligned based (source_info_pt) like compiler_source_info;
563
564 %include compiler_source_info;
565
566 dcl 1 auto_source_info aligned like compiler_source_info;
567
568 dcl 1 old_source_info aligned based (info_p),
569 %include basic_source_info;
570
571 dcl lib_names (20) char (168) var;
572
573 dcl 1 based_lib_name aligned based (lib_name_pt),
574 2 count fixed bin,
575 2 next_lib_name char (0 refer (based_lib_name.count)) unaligned;
576
577 dcl numeric_data (100) float bin based (table_pt (1));
578
579 dcl d_numeric_data (100) float bin (63) based (table_pt (1));
580
581 dcl string_data (100) fixed bin based (table_pt (2));
582
583 dcl constants (16383) float bin based (constant_ptr);
584
585 dcl d_constants (8191) float bin (63) based (constant_ptr);
586
587 dcl 1 line (100) aligned based (table_pt (3)),
588 2 in_function bit (1) unaligned,
589 2 location bit (17) unaligned,
590 2 number fixed bin (17) unaligned;
591
592 dcl 1 instruction aligned based,
593 2 base bit (3) unaligned,
594 2 offset bit (15) unaligned,
595 2 opcode bit (10) unaligned,
596 2 string bit (1) unaligned,
597 2 ext_base bit (1) unaligned,
598 2 tag bit (6) unaligned;
599
600 dcl based_vs char (32) varying based;
601
602 dcl 1 param_info_aligned aligned based,
603 2 param_info (npars) bit (9) unaligned;
604
605 dcl 1 itp aligned based,
606 2 base unal bit (3),
607 2 skip1 unal bit (6),
608 2 type unal bit (9),
609 2 skip2 unal bit (10),
610 2 string unal bit (1),
611 2 skip3 unal bit (1),
612 2 flag unal bit (6),
613 2 offset unal bit (18),
614 2 skip5 unal bit (12),
615 2 tag unal bit (6);
616
617 dcl 1 rand (32) aligned based (addr (operand)),
618 2 base unal bit (3),
619 2 offset unal bit (15),
620 2 opcode unal bit (10),
621 2 string unal bit (1),
622 2 ext_base unal bit (1),
623 2 tag unal bit (6);
624
625 dcl whole (11) aligned bit (36) based;
626
627 dcl 1 fn_local_word aligned based (local_pt),
628 2 number bit (5) unaligned,
629 2 skip bit (1) unaligned,
630 2 local (30) bit (1) unaligned;
631
632 dcl symbol_string char (300) varying;
633 ^L
634
635
636 dcl (
637 floating_zero init ("100000000000000000000000000000000011"b),
638 floating_nine init ("000001000100100000000000000000000011"b),
639 normal_modifier init ("000000000000000000000000000000000000"b),
640 function_modifier init ("000000000000000000000000000000001100"b),
641 prototype_mask init ("111000000000000000111111111111111111"b),
642 ptr_register_mask init ("000111111111111111111111111111111111"b),
643 arg_prototype init ("110000000000000000000000000001001110"b)
644 ) bit (36) int static;
645
646 dcl ic (0:4) bit (36) aligned static
647 init ("000000000000000000000000000000000100"b,
648 "000000000000000001000000000000000100"b, "000000000000000010000000000000000100"b,
649 "000000000000000011000000000000000100"b, "000000000000000100000000000000000100"b)
650 ;
651
652 dcl (
653 end_token init ("000000000000000000"b),
654 numeric_variable_token init ("101000000000000000"b),
655 string_variable_token init ("011000000000000000"b),
656 user_string_fun_token init ("010011000000000000"b),
657 user_numeric_fun_token init ("100011000000000000"b),
658 numeric_constant_token init ("100100000000000000"b),
659 integer_constant_token init ("100100000000100000"b),
660 string_constant_token init ("010100000000000000"b),
661 basic_numeric_fun_token
662 init ("100010100000000000"b),
663 basic_string_fun_token init ("010010100000000000"b),
664 secondary_token init ("000000000001000000"b),
665 integer_token init ("100100000000100000"b),
666 numeric_operator_token init ("100000010000000000"b),
667 string_operator_token init ("010000010000000000"b),
668 relational_token init ("000000000100000000"b),
669 assign_token init ("000000001000000000"b),
670 punctuation_token init ("000000000010000000"b)
671 ) bit (18) int static;
672
673 dcl (
674 is_numeric init ("100000000000000000"b),
675 is_string init ("010000000000000000"b),
676 is_variable init ("001000000000000000"b),
677 is_constant init ("000100000000000000"b),
678 is_function init ("000010000000000000"b),
679 is_user init ("000001000000000000"b),
680 is_basic init ("000000100000000000"b),
681 is_operator init ("000000010000000000"b),
682 is_assign init ("000000001000000000"b),
683 is_relational init ("000000000100000000"b),
684 is_punctuation init ("000000000010000000"b),
685 is_secondary init ("000000000001000000"b),
686 is_integer init ("000000000000100000"b)
687 ) bit (18) int static;
688 ^L
689
690
691 dcl (
692 call_statement init (1),
693 chain_statement init (2),
694 change_statement init (3),
695 data_statement init (4),
696 def_statement init (5),
697 dim_statement init (6),
698 end_statement init (7),
699 file_statement init (8),
700 fnend_statement init (9),
701 for_statement init (10),
702 goto_statement init (11),
703 gosub_statement init (12),
704 if_statement init (13),
705 input_statement init (14),
706 let_statement init (15),
707 library_statement init (16),
708 linput_statement init (17),
709 margin_statement init (18),
710 mat_statement init (19),
711 next_statement init (20),
712 on_statement init (21),
713 print_statement init (22),
714 randomize_statement init (23),
715 read_statement init (24),
716 remark_statement init (25),
717 reset_statement init (26),
718 return_statement init (27),
719 scratch_statement init (28),
720 setdigits_statement init (29),
721 stop_statement init (30),
722 sub_statement init (31),
723 subend_statement init (32),
724 teach_statement init (33),
725 time_statement init (34),
726 write_statement init (35)
727 ) fixed bin int static;
728
729 dcl (
730 plus init (1),
731 minus init (2),
732 times init (3),
733 quotient init (4),
734 power init (5),
735 concat init (6),
736 letter init (7),
737 digit init (8),
738 decimal init (9),
739 dollar init (10),
740 punctuation init (11),
741 relational init (12),
742 assign init (13),
743 new_line init (14),
744 quote init (15),
745 illegal init (16),
746 remark init (17),
747 backslash init (18)
748 ) fixed bin int static;
749
750 dcl (
751 plus_op init (1),
752 minus_op init (2),
753 times_op init (3),
754 divide_op init (4),
755 power_op init (5),
756 string_op init (6),
757 unary_minus_op init (7),
758 open_paren init (8),
759 close_paren init (9),
760 comma init (10)
761 ) fixed bin int static;
762
763 dcl (
764 n_0_fun init (1),
765 n_n_fun init (2),
766 n_s_fun init (3),
767 n_f_fun init (4),
768 s_0_fun init (5),
769 s_n_fun init (6),
770 s_nn_fun init (7),
771 n_nn_fun init (8),
772 n_fs_fun init (9),
773 n_ssn_fun init (10),
774 s_ssn_fun init (11),
775 n_var_fun init (12),
776 matrix_fun init (13),
777 print_fun init (14),
778 matrix_constant init (15),
779 s_snn_fun init (16),
780 pos_args init (17)
781 ) fixed bin static;
782
783 dcl one init (1) float bin (27) static;
784
785
786
787
788
789 dcl number_of_args_required
790 (17) fixed bin static init (0, 1, 1, 1, 0, 1, 2, 2, 2, 3, 3, -1, 0, 1, 0, 2, 1);
791
792 %include basic_param_types;
793
794 dcl (
795 numeric_data_table init (1),
796 string_data_table init (2),
797 line_table init (3)
798 ) fixed bin static;
799
800 dcl first_auto_loc init (128) fixed bin static;
801
802 dcl max_temp init (20) fixed bin static;
803
804 dcl table_limit init (261120) fixed bin (18) static;
805
806 dcl large_table_size (3) init (2048, 1024, 1024) fixed bin static;
807
808 dcl table_increment (3) init (2048, 1024, 1024) fixed bin static;
809
810 dcl number_of_tables init (3) fixed bin static;
811
812 dcl table_full (3) init (-47, -47, -84) fixed bin static;
813
814 dcl table_element_size (2, 3) init (1, 1, 1, 2, 1, 1) fixed bin static options (constant);
815
816 dcl letter_a init (97) fixed bin static;
817
818 dcl digit_0 init (48) fixed bin static;
819
820 dcl max_line_number init (99999) fixed bin static;
821
822 dcl next_line_err (-5:-1) init (4, 12, 11, 10, 9) fixed bin static;
823
824 dcl max_number_of_errors init (10) fixed bin static;
825
826 dcl max_number_of_constants
827 init (16382) fixed bin static;
828
829
830 dcl max_subprogram_name_length
831 init (32) fixed bin static;
832
833 dcl max_string_constant_length
834 init (250) fixed bin static;
835
836 dcl max_number_of_digits init (22) fixed bin static;
837
838 dcl max_storage_amount init (261120) fixed bin (20) static;
839
840 ^L
841
842
843 dcl alphanumeric char (65) static
844 init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_.-");
845
846 dcl digits char (10) static init ("0123456789");
847
848 dcl NL char (1) static init ("
849 ");
850
851 dcl matrix_secondary (5) char (8) static init ("input", "linput", "print", "read", "write");
852 ^L
853 join:
854 on conversion goto invalid_constant;
855 on size goto size_error;
856 on overflow goto overflow_error;
857 on underflow goto underflow_error;
858
859 next_line_storage.input_pt = source_info.input_pointer;
860 next_line_storage.input_length = source_info.input_lng;
861 next_line_storage.input_pos = 0;
862 next_line_storage.statement_number = 0;
863 next_line_storage.statement_ending = 0;
864 next_line_storage.temp_ch = 0;
865 source_number = 0;
866
867 output_pt = output_pointer;
868 output_pos = 0;
869
870 precision_lng = basic_data$precision_length;
871 if precision_lng = 1
872 then single = "1"b;
873 else single = "0"b;
874 inst_pt = addr (basic_data$instruction_sequences (precision_lng));
875
876 if generate_object
877 then do;
878 seg_name = source_info_pt -> source_info.given_ename;
879
880 i = index (seg_name, ".basic");
881 if i > 0
882 then seg_name = substr (seg_name, 1, i - 1);
883 end;
884 else seg_name = "{main_program}";
885
886 basic_temp_ptr = null;
887 instruction_temp_ptr = null;
888 number_of_errors = 0;
889 program_number = 0;
890 lib_count = 0;
891
892 on cleanup
893 begin;
894 if instruction_temp_ptr ^= null
895 then call release_temp_segment_ ("basic", instruction_temp_ptr, code);
896
897 if basic_temp_ptr ^= null
898 then call release_temp_segment_ ("basic", basic_temp_ptr, code);
899 end;
900
901 call get_temp_segment_ ("basic", instruction_temp_ptr, code);
902 if code ^= 0
903 then do;
904 call ioa_ ("Unable to get temporary segment.");
905 number_of_errors = 1;
906 return;
907 end;
908
909 first_statement = "1"b;
910 sub_ok = "0"b;
911
912 process_source:
913 source_number = source_number + 1;
914 source_map_info (source_number).pathname = source_info.dirname || ">" || source_info.segname;
915 source_map_info (source_number).uid = source_info.unique_id;
916 source_map_info (source_number).dtm = source_info.date_time_modified;
917
918 do while (input_pos < input_length);
919
920
921
922 for_level = 0;
923 fn_name = 0;
924 current_line_number = -1;
925 modifier = "0"b;
926
927
928
929 table_pt (1) = addr (small_numeric_data);
930 table_max (1) = hbound (small_numeric_data, 1);
931 table_pos (1) = 0;
932 large_table_offset (1) = 0;
933 small_table (1) = "1"b;
934
935 table_pt (2) = addr (small_string_data);
936 table_max (2) = hbound (small_string_data, 1);
937 table_pos (2) = 0;
938 large_table_offset (2) = 2048;
939 small_table (2) = "1"b;
940
941 table_pt (3) = addr (small_line);
942 table_max (3) = hbound (small_line, 1);
943 table_pos (3) = 0;
944 large_table_offset (3) = 3072;
945 small_table (3) = "1"b;
946
947 if mod (output_pos, 2) ^= 0
948 then output_pos = output_pos + 1;
949
950 number_of_constants = 0;
951 begin;
952 dcl size builtin;
953
954 constant_ptr = addrel (output_pointer, output_pos + size (basic_program_header));
955
956 end;
957
958 missing_pt = addr (missing_table (0));
959 missing.count = 0;
960
961 temps_pt = addr (normal_temps);
962
963 last_statement = "0"b;
964
965 do i = 1 to max_temp;
966 normal_temps (0).address (i), normal_temps (1).address (i), normal_temps (2).address (i) = (36)"0"b;
967 end;
968
969 do i = lbound (scalars, 1) to hbound (scalars, 1);
970 scalars (i) = (36)"0"b;
971 end;
972
973 string (dim_not_allowed) = "0"b;
974
975 do i = lbound (arrays, 1) to hbound (arrays, 1);
976 arrays (i).address = (36)"0"b;
977 arrays (i).dimensions = 0;
978 arrays (i).bounds (1), arrays (i).bounds (2) = -1;
979 end;
980
981 do i = lbound (fn_table, 1) to hbound (fn_table, 1);
982 string (fn_table (i)) = "0"b;
983 end;
984
985 auto_ctr (0) = first_auto_loc;
986 auto_ctr (1) = 0;
987
988 odd_available (0) = 0;
989 odd_available (1) = 0;
990
991 init:
992 operand_level = 0;
993 operator_level = 0;
994
995
996
997 if which = 4
998 then do;
999 call lexical_analyzer;
1000 return;
1001 end;
1002 else ;
1003
1004 do while (^last_statement);
1005 call lexical_analyzer;
1006 call compile_statement;
1007
1008 if operator_level + operand_level ^= 0
1009 then call error (12);
1010 end;
1011
1012
1013
1014 call finish_subprogram;
1015 end;
1016
1017 if which = 3
1018 then do;
1019 source_info_pt = addr (auto_source_info);
1020 call get_next_source_seg_ (source_info_pt);
1021 if source_info.input_pointer ^= null
1022 then do;
1023 input_pt = source_info.input_pointer;
1024 input_length = source_info.input_lng;
1025 input_pos = 0;
1026 go to process_source;
1027 end;
1028 end;
1029
1030
1031
1032 finish:
1033 call finish_object;
1034
1035
1036
1037
1038 abort_compilation:
1039 if basic_temp_ptr ^= null
1040 then call release_temp_segment_ ("basic", basic_temp_ptr, code);
1041
1042 if instruction_temp_ptr ^= null
1043 then call release_temp_segment_ ("basic", instruction_temp_ptr, code);
1044
1045 if which = 1
1046 then do;
1047 mp = main_pt;
1048 err_count = number_of_errors;
1049 end;
1050 else do;
1051 if number_of_errors = 0
1052 then a_code = 0;
1053 else a_code = error_table_$translation_failed;
1054 end;
1055 return;
1056
1057
1058
1059
1060 abort_statement:
1061 output_word (output_pos) = instructions.error (1);
1062 output_pos = output_pos + 1;
1063
1064 if input_pos < input_length
1065 then goto init;
1066 else goto abort_compilation;
1067 ^L
1068
1069
1070 size_error:
1071 overflow_error:
1072 call error (1);
1073
1074 incorrect_format:
1075 call error (2);
1076
1077 line_number_too_large:
1078 call error (3);
1079
1080 no_line_number:
1081 call error (4);
1082
1083 invalid_function:
1084 call error_name (6, this_token.name);
1085
1086 invalid_statement:
1087 call error (7);
1088
1089 invalid_variable:
1090 call error_name (8, this_token.name);
1091
1092 line_too_long:
1093 call error (9);
1094
1095 program_out_of_order:
1096 call error (14);
1097
1098 invalid_asc:
1099 call error (15);
1100
1101 invalid_operator:
1102 call error_name (16, this_token.name);
1103
1104 invalid_character:
1105 call error (17);
1106
1107 invalid_constant:
1108 call error (18);
1109
1110 relational_required:
1111 call error (20);
1112
1113 mixed_expression:
1114 call error (21);
1115
1116 then_goto_missing:
1117 call error (22);
1118
1119 mixed_let:
1120 call error (23);
1121
1122 assign_missing:
1123 call error (24);
1124
1125 not_yet:
1126 call error (25);
1127
1128 numeric_expression_required:
1129 expression_required (0):
1130 call error (26);
1131
1132 string_expression_required:
1133 expression_required (1):
1134 call error (27);
1135
1136 file_expression_required:
1137 call error (28);
1138
1139 wrong_number_of_args:
1140 call error_name (29, this_token.name);
1141
1142 parenthesis_mismatch:
1143 call error (30);
1144
1145 punctuation_not_allowed:
1146 call error (31);
1147
1148 too_deep:
1149 call error (32);
1150
1151 invalid_array:
1152 call error_name (33, this_token.name);
1153
1154 invalid_line_number:
1155 call error (34);
1156
1157 line_number_required:
1158 call error (35);
1159
1160 too_many_missing_lines:
1161 call error (36);
1162
1163 then_goto_gosub_missing:
1164 call error (37);
1165
1166 wrong_number_of_subs:
1167 call error_name (38, this_token.name);
1168
1169 missing_colon:
1170 call error (39);
1171
1172 string_reference_required:
1173 call error (40);
1174
1175 function_not_allowed:
1176 call error_name (41, this_token.name);
1177
1178 numeric_variable_required:
1179 call error (42);
1180
1181 next_without_for:
1182 call error (43);
1183
1184 for_next_mismatch:
1185 call error (44);
1186
1187 for_too_deep:
1188 call error (46);
1189
1190 multiple_commas:
1191 call error (48);
1192
1193 operation_not_allowed:
1194 call error (49);
1195
1196 integer_constant_required:
1197 call error (50);
1198
1199 fnend_without_def:
1200 call error (52);
1201
1202 nested_def:
1203 call error (53);
1204
1205 multiple_def:
1206 call error (54);
1207
1208 invalid_arg_list:
1209 call error (55);
1210
1211 invalid_def:
1212 call error (56);
1213
1214 redim_not_allowed:
1215 call error (57);
1216
1217 some_matrix_required:
1218 call error (58);
1219
1220 numeric_matrix_required:
1221 matrix_required (0):
1222 call error (59);
1223
1224 string_matrix_required:
1225 matrix_required (1):
1226 call error (60);
1227
1228 numeric_list_required:
1229 call error (61);
1230
1231 too_many_locals:
1232 call error (62);
1233
1234 array_occurs_twice:
1235 call error (63);
1236
1237 end_or_subend_must_be_last:
1238 call error (64);
1239
1240 end_not_allowed:
1241 call error (65);
1242
1243 file_occurs_twice:
1244 call error (66);
1245
1246 statement_outside_program:
1247 call error (68);
1248
1249 sub_not_allowed:
1250 call error (69);
1251
1252 subprogram_defined_twice:
1253 call error (70);
1254
1255 variable_occurs_twice:
1256 call error (71);
1257
1258 string_constant_required:
1259 call error (72);
1260
1261 invalid_subprogram_name:
1262 call error (73);
1263
1264 invalid_subprogram_parameter:
1265 call error (74);
1266
1267 subend_not_allowed:
1268 call error (75);
1269
1270 array_defined_twice:
1271 call error_name (76, this_token.name);
1272
1273 too_many_subprograms:
1274 call error (77);
1275
1276 function_occurs_twice:
1277 call error (78);
1278
1279 fun_cannot_be_passed:
1280 call error_name (82, this_token.name);
1281
1282 assign_out_of_order:
1283 call error (83);
1284
1285 underflow_error:
1286 call error (85);
1287 ^L
1288
1289
1290
1291
1292
1293
1294 lexical_analyzer:
1295 proc;
1296
1297 dcl (i, j, k, ip, token_length)
1298 fixed bin,
1299 numsign float bin,
1300 p ptr,
1301 integer bit (1),
1302 abbrev char (4),
1303 cs1 char (1),
1304 stm char (4),
1305 rest char (8);
1306
1307 dcl (size, string) builtin;
1308 ^L
1309
1310
1311 loop:
1312 if input_pos >= input_length
1313 then do;
1314 call error (-13);
1315 statement_type = end_statement;
1316
1317 current_token = 1;
1318 number_of_tokens = 1;
1319 tokens (1).type = end_token;
1320
1321 return;
1322 end;
1323
1324 call basic_next_line (addr (next_line_storage));
1325
1326 if error_number = -3
1327 then if (ch (1) = "r") & (ch (2) = "e") & (ch (3) = "m")
1328 then error_number = 6;
1329
1330 if error_number < 0
1331 then do;
1332 if current_line_number = -1 & (error_number = -2 | error_number = -4)
1333 then do;
1334 input_pos = input_length;
1335 go to finish;
1336 end;
1337 call error (next_line_err (error_number));
1338 end;
1339
1340 if next_line_storage.statement_number = 0
1341 then do;
1342
1343
1344
1345
1346 if line_number > max_line_number
1347 then goto line_number_too_large;
1348
1349 if line_number <= current_line_number
1350 then goto program_out_of_order;
1351
1352
1353
1354 number_of_lines = number_of_lines + 1;
1355
1356 if number_of_lines = max_number_of_lines
1357 then call table_overflow (line_table);
1358
1359 current_line_number, line (number_of_lines).number = line_number;
1360
1361 line (number_of_lines).location = bit (fixed (output_pos, 17), 17);
1362
1363 in_function (number_of_lines) = fn_name ^= 0;
1364
1365
1366
1367 do i = 1 to missing.count;
1368 if missing.number (i) = line_number
1369 then do;
1370
1371 do loc = missing.chain (i) repeat (next_loc) while (loc);
1372
1373 p = addrel (output_pt, loc);
1374 next_loc = p -> half (0).left;
1375
1376 p -> half (0).left = bit (fixed (output_pos - fixed (loc, 18), 18), 18);
1377 end;
1378
1379
1380
1381 do j = i + 1 to missing.count;
1382 missing_lines_word (j - 1) = missing_lines_word (j);
1383 end;
1384
1385 missing.count = missing.count - 1;
1386 end;
1387 end;
1388 end;
1389
1390
1391
1392 if ch_class (1) = new_line | ch_class (1) = backslash
1393 then goto loop;
1394
1395 if ch_class (1) ^= letter
1396 then goto invalid_statement;
1397
1398 stm = ch (1);
1399
1400 j = fixed (unspec (ch (1)), 9) - letter_a + 1;
1401
1402 if ch_class (2) ^= letter
1403 then do;
1404 statement_type = let_statement;
1405 ip = 0;
1406 go to have_statement_type;
1407 end;
1408
1409 substr (stm, 2, 1) = ch (2);
1410
1411 if (stm = "fn ") & (ch (4) ^= "n")
1412 then do;
1413 statement_type = let_statement;
1414 ip = 0;
1415 goto have_statement_type;
1416 end;
1417
1418
1419 ip = 2;
1420
1421 if stm = "if "
1422 then statement_type = if_statement;
1423 else if stm = "on "
1424 then statement_type = on_statement;
1425 else do;
1426 ip = ip + 1;
1427
1428 if ch_class (3) ^= letter
1429 then goto invalid_statement;
1430
1431 substr (stm, 3, 1) = ch (3);
1432
1433 do statement_type = basic_data$statement_spelling.start (j)
1434 to basic_data$statement_spelling.finish (j);
1435 if stm = basic_data$statement_list.first (statement_type)
1436 then goto have_statement_type;
1437 end;
1438
1439 goto invalid_statement;
1440 end;
1441
1442 have_statement_type:
1443 if statement_type = sub_statement
1444 then if ch_class (ip + 1) ^= quote
1445 then statement_type = subend_statement;
1446
1447 k = basic_data$statement_list.number (statement_type);
1448
1449 if k > 0
1450 then do;
1451
1452
1453
1454 rest = "";
1455 do i = 1 to k;
1456 ip = ip + 1;
1457
1458 if ch_class (ip) ^= letter
1459 then goto invalid_statement;
1460
1461 substr (rest, i, 1) = ch (ip);
1462 end;
1463
1464 if rest ^= basic_data$statement_list.rest (statement_type)
1465 then do;
1466 if statement_type ^= chain_statement
1467 then goto invalid_statement;
1468
1469
1470
1471 ip = ip + 1;
1472
1473 if ch_class (ip) ^= letter
1474 then goto invalid_statement;
1475
1476 substr (rest, 3, 1) = ch (ip);
1477
1478 if substr (rest, 1, 4) ^= "nge "
1479 then goto invalid_statement;
1480
1481 statement_type = change_statement;
1482 end;
1483 end;
1484
1485 if statement_type = remark_statement
1486 then goto loop;
1487 if statement_type = data_statement
1488 then goto next_data_value;
1489
1490 number_of_assigns = 0;
1491 current_token = 0;
1492
1493 next_token:
1494 current_token = current_token + 1;
1495 if current_token >= hbound (tokens, 1)
1496 then goto line_too_long;
1497
1498 token_pt = addr (tokens (current_token));
1499 this_token.name = (8)" ";
1500
1501 ip = ip + 1;
1502 goto sw (ch_class (ip));
1503
1504
1505
1506
1507 sw (14):
1508 sw (18):
1509 this_token.type = end_token;
1510 number_of_tokens = current_token;
1511 current_token = 1;
1512
1513 return;
1514
1515
1516
1517 sw (7):
1518 substr (this_token.name, 1, 1) = ch (ip);
1519 this_token.number = fixed (unspec (ch (ip)), 9) - letter_a + 1;
1520
1521 ip = ip + 1;
1522
1523 if ch_class (ip) = digit
1524 then do;
1525
1526
1527
1528 substr (this_token.name, 2, 1) = ch (ip);
1529 this_token.number = this_token.number + 26 * (fixed (unspec (ch (ip)), 9) - digit_0 + 1);
1530
1531 ip = ip + 1;
1532
1533
1534
1535
1536
1537 if ch_class (ip) = dollar
1538 then do;
1539 this_token.type = string_variable_token;
1540 this_token.number = -this_token.number;
1541 end;
1542 else do;
1543 this_token.type = numeric_variable_token;
1544 ip = ip - 1;
1545 end;
1546
1547 goto next_token;
1548 end;
1549
1550 if ch_class (ip) = dollar
1551 then do;
1552
1553
1554
1555 this_token.type = string_variable_token;
1556 this_token.number = -this_token.number;
1557 goto next_token;
1558 end;
1559
1560 if ch_class (ip) ^= letter
1561 then do;
1562
1563
1564
1565 this_token.type = numeric_variable_token;
1566 ip = ip - 1;
1567 goto next_token;
1568 end;
1569
1570
1571
1572 substr (this_token.name, 2, 1) = ch (ip);
1573
1574 if substr (this_token.name, 1, 4) = "to "
1575 then do;
1576 is_secondary:
1577 this_token.type = secondary_token;
1578 goto next_token;
1579 end;
1580
1581 ip = ip + 1;
1582
1583 if ch_class (ip) ^= letter
1584 then goto invalid_variable;
1585
1586
1587
1588 substr (this_token.name, 3, 1) = ch (ip);
1589
1590 if substr (this_token.name, 1, 4) = "bit "
1591 then goto is_secondary;
1592 if substr (this_token.name, 1, 4) = "end "
1593 then goto is_secondary;
1594
1595
1596
1597 if substr (this_token.name, 2, 2) = "to"
1598 then do;
1599
1600
1601
1602 split:
1603 if current_token = hbound (tokens, 1)
1604 then goto line_too_long;
1605
1606 current_token = current_token + 1;
1607 tokens (current_token).type = secondary_token;
1608 tokens (current_token).name = substr (this_token.name, 2);
1609
1610 substr (this_token.name, 2) = (7)" ";
1611 this_token.type = numeric_variable_token;
1612 this_token.number = fixed (unspec (substr (this_token.name, 1, 1)), 9) - letter_a + 1;
1613
1614 goto next_token;
1615 end;
1616
1617
1618
1619 if substr (this_token.name, 1, 2) = "fn"
1620 then do;
1621
1622
1623
1624 this_token.number = fixed (unspec (ch (ip)), 9) - letter_a + 1;
1625
1626 ip = ip + 1;
1627
1628 if ch_class (ip) = dollar
1629 then do;
1630 this_token.type = user_string_fun_token;
1631 this_token.number = -this_token.number;
1632 end;
1633 else do;
1634 this_token.type = user_numeric_fun_token;
1635 ip = ip - 1;
1636 end;
1637
1638 goto next_token;
1639 end;
1640
1641 if substr (this_token.name, 1, 3) = "asc"
1642 then do;
1643
1644
1645
1646 ip = ip + 1;
1647
1648 if ch (ip) ^= "("
1649 then goto invalid_asc;
1650
1651 token_length = 0;
1652 abbrev = (4)" ";
1653
1654 asc_loop:
1655 ip = ip + 1;
1656
1657 if token_length > 3
1658 then goto invalid_asc;
1659
1660 if ch_class (ip) = new_line
1661 then goto invalid_asc;
1662
1663 if token_length = 0 | ch (ip) ^= ")"
1664 then do;
1665 token_length = token_length + 1;
1666 substr (abbrev, token_length, 1) = ch (ip);
1667 goto asc_loop;
1668 end;
1669
1670 if token_length = 1
1671 then cs1 = substr (abbrev, 1, 1);
1672 else do;
1673
1674
1675
1676 if token_length = 3
1677 then do;
1678 if substr (abbrev, 1, 2) = "lc"
1679 then if ch_class (ip - 1) = letter
1680 then do;
1681 cs1 = ch (ip - 1);
1682 goto asc_ok;
1683 end;
1684 else goto invalid_asc;
1685
1686 if substr (abbrev, 1, 2) = "uc"
1687 then if ch_class (ip - 1) ^= letter
1688 then goto invalid_asc;
1689 else do;
1690 unspec (cs1) = unspec (ch (ip - 1)) & "111011111"b;
1691 goto asc_ok;
1692 end;
1693 end;
1694
1695
1696
1697 do i = 1 to basic_data$ascii_table_length;
1698 if abbrev = basic_data$ascii_table (i).abbreviation
1699 then do;
1700 cs1 = basic_data$ascii_table (i).val;
1701 goto asc_ok;
1702 end;
1703 end;
1704
1705 goto invalid_asc;
1706 end;
1707
1708 asc_ok:
1709 this_token.type = numeric_constant_token;
1710 if single
1711 then this_token.value = float (fixed (unspec (cs1), 9), 27);
1712 else d_this_token.value = float (fixed (unspec (cs1), 9), 63);
1713 goto next_token;
1714 end;
1715
1716
1717
1718 j = fixed (unspec (substr (this_token.name, 1, 1)), 9) - letter_a + 1;
1719
1720 do i = basic_data$numeric_spelling.start (j) to basic_data$numeric_spelling.finish (j);
1721 if substr (this_token.name, 1, 4) = basic_data$functions (i).name
1722 then do;
1723
1724
1725
1726 if ch_class (ip + 1) = dollar
1727 then goto invalid_function;
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747 if substr (this_token.name, 1, 4) = "tst "
1748 then if ch (ip + 1) = "e"
1749 then if ch (ip + 2) = "p"
1750 then goto not_a_function;
1751
1752 this_token.type = basic_numeric_fun_token;
1753 this_token.number = i;
1754 goto next_token;
1755 end;
1756 end;
1757
1758 call id_string_function;
1759
1760
1761
1762
1763 not_a_function:
1764 ip = ip + 1;
1765
1766 if ch_class (ip) ^= letter
1767 then goto invalid_variable;
1768
1769
1770
1771 substr (this_token.name, 4, 1) = ch (ip);
1772
1773
1774
1775 if substr(this_token.name,1,4) ^= "righ" then
1776 call id_string_function;
1777
1778 if substr (this_token.name, 1, 4) = "step"
1779 then goto is_secondary;
1780 if substr (this_token.name, 1, 4) = "goto"
1781 then goto is_secondary;
1782 if substr (this_token.name, 1, 4) = "then"
1783 then goto is_secondary;
1784 if substr (this_token.name, 1, 4) = "more"
1785 then goto is_secondary;
1786 if substr (this_token.name, 1, 4) = "read"
1787 then goto is_secondary;
1788
1789 if substr (this_token.name, 2, 3) = "bit"
1790 then goto split;
1791
1792 ip = ip + 1;
1793
1794 if ch_class (ip) ^= letter
1795 then goto invalid_variable;
1796
1797
1798
1799 substr (this_token.name, 5, 1) = ch (ip);
1800
1801
1802
1803 call id_string_function;
1804
1805 if this_token.name = "gosub "
1806 then goto is_secondary;
1807 if this_token.name = "using "
1808 then goto is_secondary;
1809
1810 if statement_type = mat_statement
1811 then do;
1812 if this_token.name = "input "
1813 then goto is_secondary;
1814 if this_token.name = "print "
1815 then goto is_secondary;
1816 if this_token.name = "write "
1817 then goto is_secondary;
1818 end;
1819
1820 if substr (this_token.name, 2, 4) = "then"
1821 then goto split;
1822 if substr (this_token.name, 2, 4) = "goto"
1823 then goto split;
1824 if substr (this_token.name, 2, 4) = "step"
1825 then goto split;
1826
1827 ip = ip + 1;
1828
1829 if ch_class (ip) = letter
1830 then do;
1831
1832
1833
1834 substr (this_token.name, 6, 1) = ch (ip);
1835
1836 if statement_type = mat_statement
1837 then if this_token.name = "linput "
1838 then goto is_secondary;
1839
1840 if substr (this_token.name, 2, 5) = "gosub"
1841 then goto split;
1842 end;
1843
1844
1845
1846 goto invalid_variable;
1847
1848 id_string_function:
1849 proc ();
1850
1851 do i = basic_data$string_spelling.start (j) to basic_data$string_spelling.finish (j);
1852 if substr (this_token.name, 1, 4) = basic_data$functions (i).name
1853 then do;
1854
1855
1856
1857 ip = ip + 1;
1858
1859 if ch_class (ip) ^= dollar
1860 then if substr (this_token.name, 1, 3) = "sst"
1861 then do;
1862 if (ch_class (ip) = letter) & (ch_class (ip + 1) = letter)
1863 then do;
1864 substr (this_token.name, 4, 2) = ch (ip) || ch (ip + 1);
1865 ip = ip + 1;
1866 if substr (this_token.name, 1, 5) = "sstep"
1867 then go to split;
1868 end;
1869 go to invalid_function;
1870 end;
1871
1872 this_token.type = basic_string_fun_token;
1873 this_token.number = i;
1874 goto next_token;
1875 end;
1876 end;
1877 end id_string_function;
1878
1879
1880
1881 sw (8):
1882 sw (9):
1883 if single
1884 then this_token.value = s_convert_number ();
1885 else d_this_token.value = d_convert_number ();
1886
1887 if integer
1888 then this_token.type = integer_token;
1889 else this_token.type = numeric_constant_token;
1890
1891 goto next_token;
1892
1893
1894
1895 sw (1):
1896 sw (2):
1897 sw (3):
1898 sw (4):
1899 sw (5):
1900 this_token.type = numeric_operator_token;
1901
1902 is_op:
1903 this_token.number = ch_class (ip);
1904 substr (this_token.name, 1, 1) = ch (ip);
1905 goto next_token;
1906
1907
1908
1909 sw (6):
1910 this_token.type = string_operator_token;
1911 goto is_op;
1912
1913
1914
1915 sw (13):
1916 if statement_type ^= if_statement
1917 then do;
1918
1919 this_token.type = assign_token;
1920 number_of_assigns = number_of_assigns + 1;
1921
1922 substr (this_token.name, 1, 1) = ch (ip);
1923 goto next_token;
1924 end;
1925
1926
1927
1928 sw (12):
1929 substr (this_token.name, 1, 1) = ch (ip);
1930
1931 ip = ip + 1;
1932
1933 if ch_class (ip) = new_line | ch_class (ip) = backslash
1934 then goto next_token;
1935
1936 if ch_class (ip) = relational | ch_class (ip) = assign
1937 then substr (this_token.name, 2, 1) = ch (ip);
1938 else ip = ip - 1;
1939
1940 do i = 1 to basic_data$relational_table_length;
1941 if substr (this_token.name, 1, 4) = basic_data$relational_table (i).name
1942 then do;
1943 this_token.type = relational_token;
1944 this_token.number = i;
1945 goto next_token;
1946 end;
1947 end;
1948
1949
1950
1951 goto invalid_operator;
1952
1953
1954
1955 sw (15):
1956 this_token.type = string_constant_token;
1957 this_token.number = quoted_string ();
1958 goto next_token;
1959
1960
1961
1962 sw (11):
1963 this_token.type = punctuation_token;
1964 substr (this_token.name, 1, 1) = ch (ip);
1965
1966 goto next_token;
1967
1968
1969
1970 sw (10):
1971 this_token.name = "$";
1972 goto invalid_variable;
1973
1974 sw (16):
1975 data (16):
1976 goto invalid_character;
1977 ^L
1978
1979
1980 next_data_value:
1981 numsign = +1.0e0;
1982
1983 ip = ip + 1;
1984 goto data (ch_class (ip));
1985
1986
1987
1988 data (2):
1989 numsign = -1.0e0;
1990
1991
1992
1993 data (1):
1994 ip = ip + 1;
1995
1996 if ch_class (ip) ^= digit
1997 then if ch_class (ip) ^= decimal
1998 then goto invalid_constant;
1999
2000
2001
2002 data (8):
2003 data (9):
2004 if numeric_data_count = max_numeric_data_count
2005 then call table_overflow (numeric_data_table);
2006
2007 numeric_data_count = numeric_data_count + 1;
2008
2009 if single
2010 then numeric_data (numeric_data_count) = numsign * s_convert_number ();
2011 else d_numeric_data (numeric_data_count) = numsign * d_convert_number ();
2012
2013
2014
2015 comma_check:
2016 ip = ip + 1;
2017
2018 if ch (ip) = ","
2019 then goto next_data_value;
2020
2021 if ch_class (ip) = new_line | ch_class (ip) = backslash
2022 then goto loop;
2023
2024 if ch_class (ip) <= 6
2025 then goto operation_not_allowed;
2026 else goto incorrect_format;
2027
2028
2029
2030 data (15):
2031 if string_data_count = max_string_data_count
2032 then call table_overflow (string_data_table);
2033
2034 string_data_count = string_data_count + 1;
2035
2036
2037
2038
2039 string_data (string_data_count) = quoted_string () - 1;
2040
2041 goto comma_check;
2042
2043
2044
2045 data (3):
2046 data (4):
2047 data (5):
2048 data (6):
2049 data (7):
2050 data (10):
2051 data (12):
2052 data (13):
2053 if string_data_count = max_string_data_count
2054 then call table_overflow (string_data_table);
2055
2056 string_data_count = string_data_count + 1;
2057
2058 string_data (string_data_count) = non_quoted_string () - 1;
2059
2060 goto comma_check;
2061
2062
2063
2064 data (11):
2065 if ch (ip) = ","
2066 then goto multiple_commas;
2067 else goto data (3);
2068
2069
2070
2071 data (14):
2072 data (18):
2073 goto loop;
2074 ^L
2075 s_convert_number:
2076 proc returns (float bin (27));
2077
2078 dcl int fixed bin,
2079 value float bin (27);
2080
2081 call convert_number ();
2082
2083 if ^integer
2084 then value = convert (value, dec_num);
2085 else do;
2086 int = convert (int, dec_num);
2087 value = convert (value, int);
2088 end;
2089
2090 return (value);
2091 end;
2092
2093 d_convert_number:
2094 proc returns (float bin (63));
2095
2096 dcl int fixed bin (71),
2097 value float bin (63);
2098
2099 call convert_number ();
2100
2101 if ^integer
2102 then value = convert (value, dec_num);
2103 else do;
2104 int = convert (int, dec_num);
2105 value = convert (value, int);
2106 end;
2107
2108 return (value);
2109 end;
2110
2111 convert_number:
2112 proc;
2113
2114 dcl (exp, prec, scale, exp_sign)
2115 fixed bin,
2116 no_digits bit (1);
2117
2118 dcl 1 num_overlay aligned based (addr (dec_num)),
2119 2 sign unal char (1),
2120 2 digits (22) unal char (1),
2121 2 skip unal bit (1),
2122 2 exponent unal fixed bin (7);
2123
2124
2125
2126
2127
2128 exp = 0;
2129 prec = 0;
2130 scale = 0;
2131
2132 dec_num = 0.0e0;
2133
2134 integer = ch_class (ip) = digit;
2135
2136
2137
2138 do while (ch_class (ip) = digit);
2139 prec = prec + 1;
2140 num_overlay.digits (prec) = ch (ip);
2141 ip = ip + 1;
2142 end;
2143
2144
2145
2146 if ch (ip) = "."
2147 then do;
2148 integer = "0"b;
2149
2150 ip = ip + 1;
2151 do while (ch_class (ip) = digit);
2152 prec = prec + 1;
2153 scale = scale + 1;
2154 num_overlay.digits (prec) = ch (ip);
2155 ip = ip + 1;
2156 end;
2157 end;
2158
2159
2160
2161 if ch (ip) = "e"
2162 then do;
2163 integer = "0"b;
2164
2165 ip = ip + 1;
2166
2167 if ch (ip) = "-"
2168 then do;
2169 exp_sign = -1;
2170 ip = ip + 1;
2171 end;
2172 else do;
2173 exp_sign = +1;
2174 if ch (ip) = "+"
2175 then ip = ip + 1;
2176 end;
2177
2178 no_digits = "1"b;
2179
2180 do while (ch_class (ip) = digit);
2181 no_digits = "0"b;
2182 exp = 10 * exp + fixed (unspec (ch (ip)), 9) - digit_0;
2183 ip = ip + 1;
2184 end;
2185
2186 if no_digits
2187 then goto invalid_constant;
2188
2189 exp = exp * exp_sign;
2190 end;
2191
2192 ip = ip - 1;
2193
2194 if prec = 0
2195 then goto invalid_constant;
2196 if prec > max_number_of_digits
2197 then goto invalid_constant;
2198
2199 num_overlay.exponent = exp - scale + prec - max_number_of_digits;
2200
2201 end;
2202 ^L
2203 quoted_string:
2204 proc returns (fixed bin);
2205
2206 dcl string_constant char (250),
2207 p ptr,
2208 (i, k, nwords, constant_loc)
2209 fixed bin;
2210
2211 dcl 1 basic_string_constant
2212 aligned based,
2213 2 constant_length fixed bin,
2214 2 constant_value char (k refer (constant_length));
2215
2216
2217
2218 k = fixed (unspec (ch (ip)), 9);
2219
2220 if k > max_string_constant_length
2221 then call error (22);
2222
2223
2224
2225 do i = 1 to k;
2226 ip = ip + 1;
2227 substr (string_constant, i, 1) = ch (ip);
2228 end;
2229
2230
2231
2232 place:
2233 nwords = size (basic_string_constant);
2234
2235
2236
2237
2238
2239
2240 unspec (constants (number_of_constants + nwords)) = (36)"0"b;
2241
2242
2243
2244 constant_loc = number_of_constants + 1;
2245 p = addr (constants (constant_loc));
2246 p -> constant_length = k;
2247 if k ^= 0
2248 then p -> constant_value = substr (string_constant, 1, k);
2249
2250 number_of_constants = number_of_constants + nwords;
2251 return (constant_loc + size (basic_program_header));
2252
2253 non_quoted_string:
2254 entry returns (fixed bin);
2255
2256 k = 0;
2257 do while (ch (ip) ^= "," & ch_class (ip) ^= new_line & ch_class (ip) ^= backslash);
2258 k = k + 1;
2259 substr (string_constant, k, 1) = ch (ip);
2260
2261 ip = ip + 1;
2262 end;
2263
2264 ip = ip - 1;
2265 goto place;
2266 end;
2267
2268 end;
2269 ^L
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283 compile_statement:
2284 proc;
2285
2286 dcl (
2287 i,
2288 j,
2289 ft,
2290 ndims,
2291 b1,
2292 b2,
2293 array_type,
2294 fn_type,
2295 sv,
2296 nv,
2297 mop (3),
2298 mult_type,
2299 bl
2300 ) fixed bin,
2301 (
2302 p,
2303 array_pt,
2304 ap (3)
2305 ) ptr,
2306 (inst, val, word, fnloc)
2307 bit (36) aligned,
2308 (have_redim, function_is_parameter)
2309 bit (1) aligned,
2310 (n_args, n_locals) fixed bin (5);
2311
2312 dcl (buffer1, buffer2) (32) bit (36) aligned;
2313
2314 dcl (size, string) builtin;
2315 ^L
2316
2317
2318 temps (0).next, temps (1).next, temps (2).next = 0;
2319
2320
2321
2322 operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;
2323
2324 if statement_type ^= sub_statement
2325 then do;
2326 if sub_ok
2327 then goto statement_outside_program;
2328
2329 if first_statement
2330 then do;
2331
2332
2333
2334 program_number = 1;
2335 if which = 1
2336 then subprogram.name (1) = "";
2337 else subprogram.name (1) = "main_";
2338
2339 header_pos (1) = output_pos;
2340 program_header_pt = addrel (output_pt, output_pos);
2341
2342 output_pos = output_pos + size (basic_program_header);
2343 first_code_word = output_pos;
2344 entry_pos (1) = output_pos;
2345
2346 addrel (instruction_temp_ptr, output_pos) -> basic_entry.word_3 = instructions.enter_main;
2347 output_pos = output_pos + size (basic_entry);
2348 output_pt = instruction_temp_ptr;
2349
2350
2351 string (basic_program_header.incoming_args) = "0"b;
2352 basic_program_header.time_limit = 0.0e0;
2353
2354
2355
2356
2357
2358
2359 do i = 1 to number_of_lines;
2360 line (i).location = bit (fixed (output_pos, 17), 18);
2361 end;
2362
2363 first_statement = "0"b;
2364 end;
2365 end;
2366
2367 goto stm (statement_type);
2368 ^L
2369
2370
2371 stm (1):
2372 call expression;
2373
2374 if operand_type (1) = 0
2375 then goto string_expression_required;
2376
2377 if operand_in_register (1) ^= 0
2378 then call save_register (1);
2379
2380 if substr (tokens (current_token).name, 1, 4) = ": "
2381 then do;
2382
2383
2384
2385 call_list:
2386 current_token = current_token + 1;
2387 if current_token >= number_of_tokens
2388 then goto incorrect_format;
2389
2390 token_pt = addr (tokens (current_token));
2391
2392 if substr (this_token.name, 1, 4) = "# "
2393 then do;
2394
2395
2396
2397 current_token = current_token + 1;
2398 call expression_in_register (0);
2399
2400
2401
2402 operand (operand_level) = allocate_temp (0) | modifier;
2403
2404 output_word (output_pos) = instructions.use_file;
2405 output_word (output_pos + 1) = instructions.save_fcb_pt | operand (operand_level);
2406 output_pos = output_pos + 2;
2407
2408 operand_in_register (0) = 0;
2409 operand_type (operand_level) = file_param;
2410
2411 goto next_arg;
2412 end;
2413
2414 if ((this_token.type & is_function) ^= "0"b)
2415 & (substr (tokens (current_token + 1).name, 1, 4) = ", "
2416 | tokens (current_token + 1).type = end_token)
2417 then do;
2418
2419
2420
2421 if this_token.type & is_user
2422 then fnloc = user_function_loc ();
2423 else do;
2424
2425
2426
2427
2428
2429 i = basic_data$functions (this_token.number).class;
2430
2431 if basic_data$function_templates (i) = "0"b
2432 then goto fun_cannot_be_passed;
2433
2434
2435
2436
2437 p = ptr (addr (basic_data$function_templates),
2438 basic_data$function_templates (i + (17 * (precision_lng - 1))));
2439
2440 j = fixed (p -> half.left (0), 18);
2441 fnloc = bit (fixed (262145 - j, 18), 18) | ic (0);
2442
2443 do i = 1 to j;
2444 if p -> whole (i) = basic_data$function_dummy
2445 then output_word (output_pos) =
2446 basic_data$functions (this_token.number).run_time;
2447 else output_word (output_pos) = p -> whole (i);
2448
2449 output_pos = output_pos + 1;
2450 end;
2451
2452 function_is_parameter = "0"b;
2453 end;
2454
2455
2456
2457
2458 operand_level = operand_level + 1;
2459 if operand_level > hbound (operand, 1)
2460 then goto too_deep;
2461
2462 word = allocate_temp (2) | modifier;
2463 operand (operand_level) = word;
2464
2465 if function_is_parameter
2466 then do;
2467
2468
2469
2470
2471
2472 output_word (output_pos) = instructions.function_arg (4) | fnloc;
2473 output_word (output_pos + 1) = instructions.function_arg (5) | word;
2474 output_pos = output_pos + 2;
2475 end;
2476 else do;
2477
2478
2479
2480
2481
2482
2483 output_word (output_pos) = instructions.function_arg (1) | fnloc;
2484 output_word (output_pos + 1) = instructions.function_arg (2) | word;
2485 substr (word, 1, 18) = bit (fixed (fixed (substr (word, 1, 18), 18) + 1, 18), 18);
2486
2487 output_word (output_pos + 2) = instructions.function_arg (3) | word;
2488 output_pos = output_pos + 3;
2489 end;
2490
2491 operand_type (operand_level) =
2492 numeric_function_param + fixed (substr (this_token.type, 2, 1), 1);
2493
2494 current_token = current_token + 1;
2495
2496 goto next_arg;
2497 end;
2498
2499 if this_token.type & is_variable
2500 then if abs (this_token.number) <= 26
2501 then if substr (tokens (current_token + 1).name, 1, 4) = "( "
2502 then if substr (tokens (current_token + 2).name, 1, 4) = ") "
2503 | substr (tokens (current_token + 2).name, 1, 4) = ", "
2504 then do;
2505
2506
2507
2508 j = 1;
2509 i = numeric_list_param;
2510
2511 current_token = current_token + 2;
2512
2513 if substr (tokens (current_token).name, 1, 4) = ", "
2514 then do;
2515 j = j + 1;
2516 i = numeric_table_param;
2517 current_token = current_token + 1;
2518 end;
2519
2520 if substr (tokens (current_token).name, 1, 4) ^= ") "
2521 then goto incorrect_format;
2522
2523 call dimension_array (j, 11, 11);
2524
2525 if this_token.type & is_string
2526 then i = i + 1;
2527
2528 operand_level = operand_level + 1;
2529 if operand_level > hbound (operand, 1)
2530 then goto too_deep;
2531
2532 operand (operand_level) = array_pt -> array.address;
2533 operand_type (operand_level) = i;
2534
2535 current_token = current_token + 1;
2536 goto next_arg;
2537 end;
2538
2539
2540
2541
2542 call expression;
2543
2544 if operand_is_constant (operand_level)
2545 then call load_register (operand_type (operand_level), operand_level);
2546
2547 if operand_in_register (operand_type (operand_level)) ^= 0
2548 then call save_register (operand_type (operand_level));
2549
2550 operand_type (operand_level) = numeric_scalar_param + operand_type (operand_level);
2551
2552 next_arg:
2553 if substr (tokens (current_token).name, 1, 4) = ", "
2554 then goto call_list;
2555
2556 if operand_in_register (2) ^= 0
2557 then call save_register (2);
2558 end;
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572 if mod (output_pos, 2) ^= 0
2573 then do;
2574 output_word (output_pos) = instructions.tra | ic (1);
2575 output_pos = output_pos + 1;
2576 end;
2577
2578 call load_register (1, 1);
2579
2580 output_word (output_pos) = instructions.subprogram_call;
2581 output_word (output_pos + 1) = bit (fixed (operand_level - 1, 17), 18);
2582 output_word (output_pos + 2) = "0"b;
2583 output_pos = output_pos + 3;
2584
2585 do i = 2 to operand_level;
2586 p = addr (output_word (output_pos));
2587 string (p -> itp) = "0"b;
2588 p -> itp.base = rand (i).base;
2589 p -> itp.flag = "100001"b;
2590 p -> itp.type = bit (fixed (operand_type (i), 9), 9);
2591 p -> itp.string = rand (i).string;
2592 p -> itp.offset = "000"b || rand (i).offset;
2593 p -> itp.tag = rand (i).tag;
2594 output_pos = output_pos + 2;
2595 end;
2596
2597 operand_level = 0;
2598 goto done;
2599 ^L
2600
2601
2602 stm (2):
2603 goto not_yet;
2604 ^L
2605
2606
2607 stm (3):
2608 if tokens (1).type & is_string
2609 then do;
2610
2611
2612
2613 call expression;
2614
2615 if substr (tokens (current_token).name, 1, 4) ^= "to "
2616 then goto incorrect_format;
2617
2618 current_token = current_token + 1;
2619
2620 call numeric_list_reference;
2621
2622 sv = 1;
2623 nv = 2;
2624 end;
2625 else do;
2626
2627
2628
2629 call numeric_list_reference;
2630
2631 if substr (tokens (current_token).name, 1, 4) ^= "to "
2632 then goto incorrect_format;
2633
2634 current_token = current_token + 1;
2635
2636 call reference;
2637
2638 if operand_type (2) ^= 1
2639 then goto string_reference_required;
2640
2641 sv = 2;
2642 nv = 1;
2643 end;
2644
2645 if substr (tokens (current_token).name, 1, 4) = "bit "
2646 then do;
2647 current_token = current_token + 1;
2648 call expression_in_register (0);
2649 end;
2650 else do;
2651 output_word (output_pos) = instructions.load (0) | floating_nine;
2652 output_pos = output_pos + 1;
2653 end;
2654
2655 call load_register (1, sv);
2656
2657 output_word (output_pos) = instructions.load (2) | operand (nv);
2658 output_word (output_pos + 1) = instructions.change (sv);
2659 output_pos = output_pos + 2;
2660
2661 operand_level = 0;
2662 goto done;
2663 ^L
2664
2665
2666 stm (4):
2667 return;
2668 ^L
2669
2670
2671 stm (5):
2672 if fn_name ^= 0
2673 then goto nested_def;
2674
2675 if (tokens (1).type & is_user) = "0"b
2676 then goto invalid_def;
2677
2678 fn_name = tokens (1).number;
2679 if fn_table.address (fn_name)
2680 then goto multiple_def;
2681
2682
2683
2684 output_word (output_pos) = instructions.tra | ic (0);
2685 output_pos = output_pos + 1;
2686
2687
2688
2689 do loc = fn_table.usage (fn_name) repeat (next_loc) while (loc);
2690 p = addrel (output_pt, loc);
2691 next_loc = p -> half (0).left;
2692 p -> half (0).left = bit (fixed (output_pos - fixed (loc, 18), 18), 18);
2693 end;
2694
2695
2696
2697 fn_table.address (fn_name) = bit (output_pos, 18);
2698 fn_table.usage (fn_name) = (18)"0"b;
2699
2700 string (fn_call_word) = "0"b;
2701 fn_call_word.mode = substr (tokens (1).type, 2, 1);
2702 fn_type = fixed (substr (tokens (1).type, 2, 1), 1);
2703
2704 al_count = 0;
2705
2706 current_token = 2;
2707
2708 if substr (tokens (2).name, 1, 4) ^= "( "
2709 then n_args = 0;
2710 else do;
2711 current_token = current_token + 1;
2712
2713 if substr (tokens (3).name, 1, 4) ^= ") "
2714 then do;
2715 call arg_or_local;
2716 if substr (tokens (current_token).name, 1, 4) ^= ") "
2717 then goto invalid_arg_list;
2718 end;
2719
2720 n_args = al_count;
2721 if n_args > hbound (fn_call_word.arg, 1)
2722 then goto invalid_arg_list;
2723
2724 fn_call_word.number = bit (n_args, 5);
2725
2726
2727
2728 do i = 1 to n_args;
2729 if save.number (i) < 0
2730 then fn_call_word.arg (i) = "1"b;
2731 end;
2732
2733 current_token = current_token + 1;
2734 end;
2735
2736
2737
2738 output_word (output_pos) = string (fn_call_word);
2739 output_pos = output_pos + 1;
2740
2741
2742
2743 missing_pt = addr (missing_table (1));
2744 missing.count = 0;
2745
2746
2747
2748 temps_pt = addr (local_temps);
2749
2750 do i = 1 to max_temp;
2751 local_temps (0).address (i), local_temps (1).address (i), local_temps (2).address (i) = (36)"0"b;
2752 end;
2753
2754 local_temps (0).next, local_temps (1).next, local_temps (2).next = 0;
2755
2756 modifier = function_modifier;
2757
2758
2759
2760 local_pt = addr (output_word (output_pos));
2761 output_pos = output_pos + 1;
2762
2763 if substr (tokens (current_token).name, 1, 4) = "= "
2764 then do;
2765
2766
2767
2768 string (fn_local_word) = "0"b;
2769
2770 current_token = current_token + 1;
2771
2772 local_ctr = (al_count + 1) * precision_lng;
2773
2774
2775
2776 call expression_in_register (fn_type);
2777 operand_level = operand_level - 1;
2778
2779
2780
2781 if fn_type = 0
2782 then do;
2783 output_word (output_pos) = instructions.store (0) | arg_prototype;
2784 output_pos = output_pos + 1;
2785 end;
2786 else do;
2787 output_word (output_pos) = instructions.string_assign (0) | arg_prototype;
2788 output_word (output_pos + 1) = instructions.string_assign (1);
2789 output_pos = output_pos + 2;
2790 end;
2791
2792 call fn_cleanup;
2793 end;
2794
2795 else do;
2796
2797
2798
2799 if current_token ^= number_of_tokens
2800 then do;
2801 call arg_or_local;
2802 if current_token ^= number_of_tokens
2803 then goto invalid_arg_list;
2804 end;
2805
2806 n_locals = al_count - n_args;
2807 if n_locals > hbound (fn_local_word.local, 1)
2808 then goto too_many_locals;
2809
2810 string (fn_local_word) = bit (n_locals, 5);
2811
2812 do i = 1 to n_locals;
2813 if save.number (n_args + i) < 0
2814 then fn_local_word.local (i) = "1"b;
2815 end;
2816
2817 local_ctr = (al_count + 1) * precision_lng;
2818
2819 fn_start = current_line_number;
2820 end;
2821
2822 goto done;
2823 ^L
2824
2825
2826 stm (6):
2827 token_pt = addr (tokens (current_token));
2828
2829 if (this_token.type & is_variable) = "0"b
2830 then goto invalid_variable;
2831
2832 if substr (tokens (current_token + 1).name, 1, 4) ^= "( "
2833 then goto incorrect_format;
2834
2835 if tokens (current_token + 2).type ^= integer_constant_token
2836 then goto integer_constant_required;
2837
2838 b1 = fixed (tokens (current_token + 2).value) + 1;
2839
2840 if substr (tokens (current_token + 3).name, 1, 4) = ") "
2841 then do;
2842 ndims = 1;
2843 current_token = current_token + 4;
2844 end;
2845 else do;
2846 if substr (tokens (current_token + 3).name, 1, 4) ^= ", "
2847 then goto incorrect_format;
2848
2849 if tokens (current_token + 4).type ^= integer_constant_token
2850 then goto integer_constant_required;
2851
2852 b2 = fixed (tokens (current_token + 4).value) + 1;
2853
2854 if substr (tokens (current_token + 5).name, 1, 4) ^= ") "
2855 then goto incorrect_format;
2856
2857 ndims = 2;
2858 current_token = current_token + 6;
2859 end;
2860
2861 call dimension_array (ndims, b1, b2);
2862
2863 if substr (tokens (current_token).name, 1, 4) = ", "
2864 then do;
2865 current_token = current_token + 1;
2866 goto stm (6);
2867 end;
2868
2869 goto done;
2870 ^L
2871
2872
2873 stm (7):
2874 if program_number > 1
2875 then goto end_not_allowed;
2876
2877 word = instructions.stop;
2878
2879 end:
2880 last_statement = "1"b;
2881 sub_ok = "1"b;
2882
2883 if fn_name ^= 0
2884 then do;
2885 call error (-51);
2886 call fn_cleanup;
2887 end;
2888
2889 output_word (output_pos) = word;
2890 output_pos = output_pos + 1;
2891
2892 done:
2893 if current_token ^= number_of_tokens
2894 then goto incorrect_format;
2895
2896 return;
2897 ^L
2898
2899
2900 stm (8):
2901 if substr (tokens (1).name, 1, 4) ^= "# "
2902 then goto file_expression_required;
2903
2904 current_token = current_token + 1;
2905
2906 call numeric_expression;
2907
2908 if substr (tokens (current_token).name, 1, 4) ^= ": "
2909 then goto missing_colon;
2910
2911 current_token = current_token + 1;
2912
2913 call expression_in_register (1);
2914 call load_register (0, 1);
2915
2916 output_word (output_pos) = instructions.file;
2917 output_pos = output_pos + 1;
2918
2919 operand_level = operand_level - 2;
2920 goto done;
2921 ^L
2922
2923
2924 stm (9):
2925 if fn_name = 0
2926 then goto fnend_without_def;
2927
2928 call fn_cleanup;
2929 goto done;
2930 ^L
2931
2932
2933 stm (10):
2934 for_level = for_level + 1;
2935
2936 if for_level > hbound (for_type, 1)
2937 then goto for_too_deep;
2938
2939 token_pt = addr (tokens (1));
2940
2941 if this_token.type ^= numeric_variable_token
2942 then goto numeric_variable_required;
2943
2944 call push_variable;
2945
2946 current_token = current_token + 1;
2947
2948 if substr (tokens (2).name, 1, 4) ^= "= "
2949 then goto incorrect_format;
2950
2951 current_token = current_token + 1;
2952
2953 call numeric_expression;
2954
2955 if substr (tokens (current_token).name, 1, 4) ^= "to "
2956 then goto incorrect_format;
2957
2958 current_token = current_token + 1;
2959
2960 call for_expression;
2961
2962
2963
2964 if substr (tokens (current_token).name, 1, 4) ^= "step"
2965 then do;
2966
2967
2968
2969 ft = 1;
2970 if single
2971 then operand (4) = unspec (binary (1.0e0)) | "000000000000000000000000000000000011"b;
2972 else do;
2973 operand_level = 4;
2974 call push_constant_dp_notok (1.0e0);
2975 end;
2976 end;
2977 else do;
2978
2979
2980
2981 current_token = current_token + 1;
2982 token_pt = addr (tokens (current_token));
2983
2984 call for_expression;
2985
2986
2987
2988
2989 if operand_is_constant (operand_level)
2990 then if sign (tokens (current_token - 1).value) = -1
2991 then ft = -1;
2992 else ft = 1;
2993 else ft = 0;
2994 end;
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008 if operand_in_register (0) ^= 0
3009 then call save_register (0);
3010
3011 for_variable (for_level) = operand (1);
3012 for_type (for_level) = ft;
3013
3014
3015
3016
3017
3018 output_word (output_pos) = instructions.load (0) | operand (2);
3019 output_word (output_pos + 1) = instructions.tra | ic (2);
3020 output_pos = output_pos + 2;
3021
3022
3023
3024
3025
3026
3027 for_location (for_level) = output_pos;
3028
3029 output_word (output_pos) = instructions.add | operand (4);
3030 output_word (output_pos + 1) = instructions.store (0) | operand (1);
3031 output_pos = output_pos + 2;
3032
3033 goto step_type (ft);
3034
3035
3036
3037
3038
3039 step_type (-1):
3040 output_word (output_pos) = instructions.compare | operand (3);
3041 output_word (output_pos + 1) = instructions.tmi | ic (0);
3042
3043 output_pos = output_pos + 2;
3044
3045 goto for_done;
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056 step_type (0):
3057 output_word (output_pos) = instructions.fszn | operand (4);
3058 output_word (output_pos + 1) = instructions.tpl | ic (4);
3059 output_word (output_pos + 2) = instructions.compare | operand (3);
3060 output_word (output_pos + 3) = instructions.tmi | ic (0);
3061 output_word (output_pos + 4) = instructions.tra | ic (3);
3062 output_word (output_pos + 5) = instructions.compare | operand (3);
3063 output_word (output_pos + 6) = instructions.tpnz | ic (0);
3064
3065 output_pos = output_pos + 7;
3066 goto for_done;
3067
3068
3069
3070
3071
3072 step_type (1):
3073 output_word (output_pos) = instructions.compare | operand (3);
3074 output_word (output_pos + 1) = instructions.tpnz | ic (0);
3075
3076 output_pos = output_pos + 2;
3077
3078 for_done:
3079 operand_level = 0;
3080 goto done;
3081 ^L
3082
3083
3084 stm (11):
3085 call gen_xfer (instructions.tra);
3086 goto done;
3087 ^L
3088
3089
3090 stm (12):
3091 call gen_xfer (instructions.load (2));
3092
3093 output_word (output_pos) = instructions.gosub;
3094 output_pos = output_pos + 1;
3095
3096 goto done;
3097 ^L
3098
3099
3100 stm (13):
3101 if tokens (1).type = secondary_token
3102 then do;
3103
3104
3105
3106 if substr (tokens (1).name, 1, 4) = "more"
3107 then inst = instructions.tze;
3108 else if substr (tokens (1).name, 1, 4) = "end "
3109 then inst = instructions.tnz;
3110 else goto incorrect_format;
3111
3112 if substr (tokens (2).name, 1, 4) ^= "# "
3113 then goto incorrect_format;
3114
3115 current_token = 3;
3116
3117 call expression_in_register (0);
3118
3119 output_word (output_pos) = instructions.check_eof;
3120 output_pos = output_pos + 1;
3121
3122 operand_level = operand_level - 1;
3123 end;
3124 else do;
3125
3126
3127
3128 call expression;
3129
3130 token_pt = addr (tokens (current_token));
3131
3132 if this_token.type ^= relational_token
3133 then goto relational_required;
3134
3135 i = this_token.number;
3136
3137 current_token = current_token + 1;
3138
3139 call expression;
3140
3141
3142
3143
3144
3145 if operand_type (1) ^= operand_type (2)
3146 then goto mixed_expression;
3147
3148 if operand_in_register (operand_type (1)) = 2
3149 then do;
3150 if operand_type (1) = 0
3151 then if operand (1) ^= floating_zero
3152 then do;
3153 output_word (output_pos) = instructions.compare | operand (1);
3154 output_pos = output_pos + 1;
3155 end;
3156 else ;
3157 else do;
3158 output_word (output_pos) = instructions.string_compare (0) | operand (1);
3159 output_word (output_pos + 1) = instructions.string_compare (1);
3160 output_pos = output_pos + 2;
3161 end;
3162
3163 inst = basic_data$inverse_relational (i);
3164 end;
3165 else do;
3166 call load_register (operand_type (1), 1);
3167
3168 if operand_type (1) = 0
3169 then if operand (2) ^= floating_zero
3170 then do;
3171 output_word (output_pos) = instructions.compare | operand (2);
3172 output_pos = output_pos + 1;
3173 end;
3174 else ;
3175 else do;
3176 output_word (output_pos) = instructions.string_compare (0) | operand (2);
3177 output_word (output_pos + 1) = instructions.string_compare (1);
3178 output_pos = output_pos + 2;
3179 end;
3180
3181 inst = basic_data$normal_relational (i);
3182 end;
3183
3184 operand_level = operand_level - 2;
3185 end;
3186
3187 token_pt = addr (tokens (current_token));
3188
3189 if this_token.type ^= secondary_token
3190 then goto then_goto_missing;
3191
3192 if substr (this_token.name, 1, 4) ^= "then"
3193 then if substr (this_token.name, 1, 4) ^= "goto"
3194 then goto then_goto_missing;
3195
3196 current_token = current_token + 1;
3197
3198 call gen_xfer (inst);
3199 goto done;
3200 ^L
3201
3202
3203 stm (14):
3204 call optional_file;
3205 call input_list (0, instructions.input, "1"b);
3206
3207 goto done;
3208 ^L
3209
3210
3211 stm (15):
3212 if number_of_assigns = 0
3213 then goto assign_missing;
3214
3215 do while (operand_level < number_of_assigns);
3216 call reference;
3217
3218 if operand_level > 1
3219 then if operand_type (1) ^= operand_type (operand_level)
3220 then goto mixed_let;
3221
3222 if tokens (current_token).type ^= assign_token
3223 then goto assign_out_of_order;
3224
3225 current_token = current_token + 1;
3226 end;
3227
3228 call expression_in_register ((operand_type (1)));
3229
3230 operand_level = operand_level - 1;
3231
3232 if operand_type (1) = 0
3233 then do while (operand_level > 0);
3234 output_word (output_pos) = instructions.store (0) | operand (operand_level);
3235 output_pos = output_pos + 1;
3236 operand_level = operand_level - 1;
3237 end;
3238 else do while (operand_level > 0);
3239 output_word (output_pos) = instructions.string_assign (0) | operand (operand_level);
3240 output_word (output_pos + 1) = instructions.string_assign (1);
3241 output_pos = output_pos + 2;
3242 operand_level = operand_level - 1;
3243 end;
3244
3245 goto done;
3246 ^L
3247
3248
3249 stm (16):
3250 if which = 1
3251 then do;
3252 call error (-167);
3253 number_of_errors = number_of_errors - 1;
3254 go to init;
3255 end;
3256
3257 else do;
3258 next_libe:
3259 token_pt = addr (tokens (current_token));
3260 if this_token.type & is_constant
3261 then if this_token.type & is_string
3262 then do;
3263 lib_name_pt = addr (constants (this_token.number - size (basic_program_header)));
3264 call add_lib_name (next_lib_name, code);
3265 if code ^= 0
3266 then call error (-168);
3267 end;
3268 else go to string_reference_required;
3269 else go to string_reference_required;
3270
3271 current_token = current_token + 1;
3272 if current_token = number_of_tokens
3273 then go to done;
3274 if substr (tokens (current_token).name, 1, 4) ^= ", "
3275 then goto incorrect_format;
3276 current_token = current_token + 1;
3277 go to next_libe;
3278 end;
3279 ^L
3280
3281
3282 stm (17):
3283 call optional_file;
3284 call input_list (1, instructions.linput, "1"b);
3285
3286 goto done;
3287 ^L
3288
3289
3290 stm (18):
3291 call optional_file;
3292
3293 call expression_in_register (0);
3294
3295 output_word (output_pos) = instructions.margin;
3296 output_pos = output_pos + 1;
3297
3298 operand_level = operand_level - 1;
3299 goto done;
3300 ^L
3301
3302
3303 stm (19):
3304 if tokens (1).type = secondary_token
3305 then do;
3306
3307
3308
3309 current_token = 2;
3310
3311 do i = 1 to hbound (matrix_secondary, 1);
3312 if tokens (1).name = matrix_secondary (i)
3313 then goto mat (i);
3314 end;
3315
3316 goto incorrect_format;
3317
3318
3319
3320 mat (1):
3321 call optional_file;
3322 call mat_input_list (0, instructions.mat_input, "0"b);
3323 goto done;
3324
3325
3326
3327 mat (2):
3328 call optional_file;
3329 call mat_input_list (1, instructions.mat_linput, "1"b);
3330 goto done;
3331
3332
3333
3334 mat (3):
3335 call optional_file;
3336
3337 if tokens (current_token).name = "using "
3338 then do;
3339
3340
3341
3342 current_token = current_token + 1;
3343
3344 call expression_in_register (1);
3345
3346 output_word (output_pos) = instructions.print_using_start;
3347 output_pos = output_pos + 1;
3348 operand_level = 0;
3349 operand_in_register (1) = 0;
3350
3351 if substr (tokens (current_token).name, 1, 4) ^= ", "
3352 then goto incorrect_format;
3353
3354 mat_print_using_list:
3355 current_token = current_token + 1;
3356 call matrix_reference ("0"b);
3357
3358 output_word (output_pos) = instructions.mat_print_using (operand_type (1));
3359 output_pos = output_pos + 1;
3360 operand_level = 0;
3361
3362 if substr (tokens (current_token).name, 1, 4) = ", "
3363 then goto mat_print_using_list;
3364
3365 output_word (output_pos) = instructions.print_using_end;
3366 output_word (output_pos + 1) = instructions.print_new_line;
3367 output_pos = output_pos + 2;
3368 end;
3369 else do;
3370 mat_print_list:
3371 call matrix_reference ("0"b);
3372
3373 output_word (output_pos) = instructions.mat_print (operand_type (1));
3374 output_pos = output_pos + 1;
3375
3376 operand_level = 0;
3377
3378 i = index (",;", substr (tokens (current_token).name, 1, 1));
3379
3380 if i ^= 0
3381 then do;
3382 output_word (output_pos) = unspec (i);
3383 output_pos = output_pos + 1;
3384
3385 current_token = current_token + 1;
3386 if current_token < number_of_tokens
3387 then goto mat_print_list;
3388 end;
3389 else do;
3390 output_word (output_pos) = "0"b;
3391 output_pos = output_pos + 1;
3392 end;
3393 end;
3394
3395 goto done;
3396
3397
3398
3399 mat (4):
3400 if substr (tokens (2).name, 1, 4) ^= "# "
3401 then call mat_input_list (0, instructions.mat_data_read, "0"b);
3402 else do;
3403 call optional_file;
3404 call mat_input_list (0, instructions.mat_read, "0"b);
3405 end;
3406
3407 goto done;
3408
3409
3410
3411 mat (5):
3412 call required_file;
3413
3414 mat_write_list:
3415 call matrix_reference ("0"b);
3416
3417 output_word (output_pos) = instructions.mat_write (operand_type (1));
3418 output_pos = output_pos + 1;
3419
3420 operand_level = 0;
3421
3422 if substr (tokens (current_token).name, 1, 4) = ", "
3423 then do;
3424 current_token = current_token + 1;
3425 goto mat_write_list;
3426 end;
3427
3428 goto done;
3429 end;
3430 else do;
3431
3432
3433
3434 mop (1) = 3;
3435 mop (2) = 1;
3436 mop (3) = 0;
3437
3438 token_pt = addr (tokens (1));
3439
3440 if this_token.type & is_string
3441 then do;
3442
3443
3444
3445 if substr (tokens (2).name, 1, 4) ^= "= "
3446 then goto incorrect_format;
3447
3448 if tokens (3).type = basic_string_fun_token
3449 then call matrix_function;
3450 else if tokens (4).type = end_token
3451 then do;
3452 matrix_type = 1;
3453 call matrix_op (instructions.matrix_assign_string);
3454 current_token = 4;
3455 end;
3456 else goto incorrect_format;
3457
3458 goto done;
3459 end;
3460
3461
3462
3463 matrix_type = 0;
3464
3465 if this_token.number > 26
3466 then goto check_dot;
3467
3468 if substr (tokens (2).name, 1, 4) ^= "= "
3469 then goto check_dot;
3470
3471 if tokens (3).type = basic_numeric_fun_token
3472 then do;
3473 call matrix_function;
3474 goto done;
3475 end;
3476
3477 if tokens (4).type = end_token
3478 then do;
3479 call matrix_op (instructions.matrix_assign_numeric);
3480 current_token = 4;
3481 goto done;
3482 end;
3483
3484 if substr (tokens (3).name, 1, 4) = "( "
3485 then do;
3486
3487
3488
3489
3490 current_token = 4;
3491 call expression_in_register (0);
3492
3493 if substr (tokens (current_token).name, 1, 4) ^= ") "
3494 then goto incorrect_format;
3495
3496 current_token = current_token + 1;
3497 if substr (tokens (current_token).name, 1, 4) ^= "* "
3498 then goto incorrect_format;
3499
3500 current_token = current_token + 1;
3501
3502 mop (1) = current_token;
3503
3504 call matrix_op (instructions.matrix_scalar_mult);
3505
3506 current_token = current_token + 1;
3507 operand_level = operand_level - 1;
3508 goto done;
3509 end;
3510
3511 mop (3) = 5;
3512
3513 i = index ("+-", substr (tokens (4).name, 1, 1));
3514
3515 if i ^= 0
3516 then do;
3517
3518
3519
3520
3521 call matrix_op (instructions.matrix_add_sub (i));
3522
3523 current_token = 6;
3524 goto done;
3525 end;
3526
3527 if substr (tokens (4).name, 1, 4) ^= "* "
3528 then goto incorrect_format;
3529
3530
3531
3532
3533 ap (1) = addr (arrays (tokens (3).number));
3534 ap (2) = addr (arrays (tokens (1).number));
3535 ap (3) = addr (arrays (tokens (5).number));
3536
3537 if ap (1) -> array.dimensions = 1
3538 then if ap (3) -> array.dimensions = 1
3539 then goto check_dot;
3540
3541 call matrix_operand (1, -2);
3542 call matrix_operand (3, -2);
3543
3544 mult_type = 2 * (ap (1) -> array.dimensions - 1) + ap (3) -> array.dimensions - 1;
3545
3546 if mult_type = 3
3547 then number_of_dims = 2;
3548 else number_of_dims = 1;
3549
3550 call matrix_operand (2, number_of_dims);
3551
3552 output_word (output_pos) = instructions.matrix_mult (mult_type);
3553 output_pos = output_pos + 1;
3554
3555 current_token = 6;
3556 goto done;
3557
3558
3559
3560
3561 check_dot:
3562 current_token = 1;
3563 call reference;
3564
3565 if operand_type (1) ^= 0
3566 then goto numeric_variable_required;
3567
3568 if substr (tokens (current_token).name, 1, 4) ^= "= "
3569 then goto incorrect_format;
3570
3571 current_token = current_token + 1;
3572 call numeric_list_reference;
3573
3574 if substr (tokens (current_token).name, 1, 4) ^= "* "
3575 then goto incorrect_format;
3576
3577 current_token = current_token + 1;
3578 call numeric_list_reference;
3579
3580
3581
3582 output_word (output_pos) = instructions.load (1) | operand (2);
3583 output_word (output_pos + 1) = instructions.load (3) | operand (3);
3584 output_word (output_pos + 2) = instructions.inner_product;
3585 output_word (output_pos + 3) = instructions.store (0) | operand (1);
3586
3587 output_pos = output_pos + 4;
3588 operand_level = operand_level - 3;
3589 end;
3590
3591 goto done;
3592 ^L
3593
3594
3595 stm (20):
3596 if for_level = 0
3597 then goto next_without_for;
3598
3599 token_pt = addr (tokens (1));
3600
3601 if this_token.type ^= numeric_variable_token
3602 then goto numeric_variable_required;
3603
3604 call push_variable;
3605
3606 if operand (1) ^= for_variable (for_level)
3607 then goto for_next_mismatch;
3608
3609
3610
3611
3612
3613 output_word (output_pos) = instructions.load (0) | operand (1);
3614 output_pos = output_pos + 1;
3615
3616 i = for_location (for_level);
3617
3618 output_word (output_pos) = instructions.tra | bit (fixed (262144 + i - output_pos, 18), 18) | ic (0);
3619 output_pos = output_pos + 1;
3620
3621
3622
3623 p = addrel (output_pt, i);
3624
3625 if for_type (for_level) ^= 0
3626 then p -> half (3).left = bit (fixed (output_pos - (i + 3), 18), 18);
3627 else do;
3628 p -> half (5).left = bit (fixed (output_pos - (i + 5), 18), 18);
3629 p -> half (8).left = bit (fixed (output_pos - (i + 8), 18), 18);
3630 end;
3631
3632 operand_level = 0;
3633 for_level = for_level - 1;
3634
3635 current_token = current_token + 1;
3636 goto done;
3637 ^L
3638
3639
3640 stm (21):
3641 call expression_in_register (0);
3642
3643 operand_level = operand_level - 1;
3644
3645 token_pt = addr (tokens (current_token));
3646
3647 if this_token.type ^= secondary_token
3648 then goto then_goto_gosub_missing;
3649
3650 if substr (this_token.name, 1, 4) = "then"
3651 then inst = instructions.on;
3652 else if substr (this_token.name, 1, 4) = "goto"
3653 then inst = instructions.on;
3654 else if substr (this_token.name, 1, 4) = "gosu"
3655 then inst = instructions.on_gosub;
3656 else goto then_goto_gosub_missing;
3657
3658 output_word (output_pos) = inst;
3659 output_pos = output_pos + 2;
3660
3661 i = output_pos - 1;
3662
3663 on_list:
3664 current_token = current_token + 1;
3665
3666 call gen_xfer (instructions.tra);
3667
3668 if substr (tokens (current_token).name, 1, 4) = ", "
3669 then goto on_list;
3670
3671 fixed_output_word (i) = output_pos - i;
3672 goto done;
3673 ^L
3674
3675
3676 stm (22):
3677 call optional_file;
3678
3679 if tokens (current_token).name = "using "
3680 then do;
3681
3682
3683
3684 current_token = current_token + 1;
3685
3686 call expression_in_register (1);
3687
3688 output_word (output_pos) = instructions.print_using_start;
3689 output_pos = output_pos + 1;
3690 operand_level = 0;
3691 operand_in_register (1) = 0;
3692
3693 print_using_list:
3694 if current_token = number_of_tokens
3695 then do;
3696 output_word (output_pos) = instructions.print_using_end;
3697 output_word (output_pos + 1) = instructions.print_new_line;
3698 output_pos = output_pos + 2;
3699 goto done;
3700 end;
3701
3702 if substr (tokens (current_token).name, 1, 4) ^= ", "
3703 then goto incorrect_format;
3704
3705 current_token = current_token + 1;
3706
3707 call put_expression (instructions.print_using);
3708
3709 operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;
3710
3711 if substr (tokens (current_token).name, 1, 4) ^= "; "
3712 then goto print_using_list;
3713
3714 current_token = current_token + 1;
3715
3716 output_word (output_pos) = instructions.print_using_end;
3717 output_pos = output_pos + 1;
3718 goto done;
3719 end;
3720
3721
3722
3723 print_list:
3724 if current_token = number_of_tokens
3725 then do;
3726
3727 print_done:
3728 output_word (output_pos) = instructions.print_new_line;
3729 output_pos = output_pos + 1;
3730
3731 goto done;
3732 end;
3733
3734 token_pt = addr (tokens (current_token));
3735
3736 if substr (this_token.name, 1, 4) = ", "
3737 then do;
3738
3739 print_comma:
3740 output_word (output_pos) = instructions.tab_for_comma;
3741 output_pos = output_pos + 1;
3742
3743 next_print:
3744 current_token = current_token + 1;
3745
3746 if current_token < number_of_tokens
3747 then goto print_list;
3748
3749 output_word (output_pos) = instructions.end_print;
3750 output_pos = output_pos + 1;
3751
3752 goto done;
3753 end;
3754
3755 if this_token.type = basic_numeric_fun_token
3756 then do;
3757 i = basic_data$functions (this_token.number).class;
3758
3759 if i = print_fun
3760 then do;
3761
3762
3763
3764 inst = basic_data$functions (this_token.number).run_time;
3765
3766 current_token = current_token + 1;
3767
3768 if substr (tokens (current_token).name, 1, 4) ^= "( "
3769 then goto wrong_number_of_args;
3770
3771 current_token = current_token + 1;
3772
3773 call expression_in_register (0);
3774
3775 if substr (tokens (current_token).name, 1, 4) ^= ") "
3776 then goto incorrect_format;
3777
3778 current_token = current_token + 1;
3779
3780 output_word (output_pos) = inst;
3781 output_pos = output_pos + 1;
3782
3783 operand_level = operand_level - 1;
3784 operand_in_register (0) = 0;
3785 goto comma_check;
3786 end;
3787 end;
3788
3789 call put_expression (instructions.print);
3790 operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;
3791
3792 comma_check:
3793 token_pt = addr (tokens (current_token));
3794
3795 if substr (this_token.name, 1, 4) = ", "
3796 then goto print_comma;
3797
3798 if substr (this_token.name, 1, 4) = "; "
3799 then goto next_print;
3800
3801
3802 goto print_done;
3803 ^L
3804
3805
3806 stm (23):
3807 output_word (output_pos) = instructions.randomize;
3808 output_pos = output_pos + 1;
3809 goto done;
3810 ^L
3811
3812
3813 stm (24):
3814 if substr (tokens (1).name, 1, 4) ^= "# "
3815 then call input_list (0, instructions.data_read, "0"b);
3816 else do;
3817 call optional_file;
3818 call input_list (0, instructions.read, "0"b);
3819 end;
3820
3821 goto done;
3822 ^L
3823
3824
3825 stm (25):
3826 return;
3827 ^L
3828
3829
3830 stm (26):
3831 if number_of_tokens = 1
3832 then do;
3833 output_word (output_pos) = instructions.reset_data;
3834 output_pos = output_pos + 1;
3835 goto done;
3836 end;
3837
3838 call required_file;
3839
3840 if current_token = number_of_tokens
3841 then do;
3842 output_word (output_pos) = instructions.reset_ascii;
3843 output_pos = output_pos + 1;
3844 goto done;
3845 end;
3846
3847 call expression_in_register (0);
3848
3849 output_word (output_pos) = instructions.reset_random;
3850 output_pos = output_pos + 1;
3851
3852 operand_level = operand_level - 1;
3853 goto done;
3854 ^L
3855
3856
3857 stm (27):
3858 output_word (output_pos) = instructions.return;
3859 output_pos = output_pos + 1;
3860
3861 goto done;
3862 ^L
3863
3864
3865 stm (28):
3866 call required_file;
3867
3868 output_word (output_pos) = instructions.scratch;
3869 output_pos = output_pos + 1;
3870 goto done;
3871 ^L
3872
3873
3874 stm (29):
3875 if tokens (1).type = end_token
3876 then go to numeric_expression_required;
3877 current_token = 1;
3878 call expression_in_register (0);
3879 output_word (output_pos) = instructions.setdigits;
3880 output_pos = output_pos + 1;
3881 operand_level = operand_level - 1;
3882 go to done;
3883 ^L
3884
3885
3886 stm (30):
3887 output_word (output_pos) = instructions.stop;
3888 output_pos = output_pos + 1;
3889 goto done;
3890 ^L
3891
3892
3893 stm (31):
3894 if first_statement
3895 then do;
3896 program_number = 0;
3897 first_statement = "0"b;
3898 end;
3899 else do;
3900 if ^sub_ok
3901 then goto sub_not_allowed;
3902
3903 if program_number >= hbound (subprogram, 1)
3904 then goto too_many_subprograms;
3905 end;
3906
3907 number_of_lines = number_of_lines - 1;
3908
3909 sub_ok = "0"b;
3910
3911 if tokens (1).type ^= string_constant_token
3912 then goto string_constant_required;
3913
3914 p = addr (constants (tokens (1).number - size (basic_program_header)));
3915
3916 do i = 1 to program_number;
3917 if subprogram.name (i) = p -> based_vs
3918 then goto subprogram_defined_twice;
3919 end;
3920
3921 program_number = program_number + 1;
3922 subprogram.name (program_number) = p -> based_vs;
3923
3924 header_pos (program_number) = output_pos;
3925 program_header_pt = addrel (output_pt, output_pos);
3926
3927 if length (p -> based_vs) = 0
3928 then goto invalid_subprogram_name;
3929 if length (p -> based_vs) > max_subprogram_name_length
3930 then goto invalid_subprogram_name;
3931
3932 if verify (p -> based_vs, alphanumeric) ^= 0
3933 then goto invalid_subprogram_name;
3934
3935 basic_program_header.time_limit = 0.0e0;
3936
3937 output_pos = output_pos + size (basic_program_header);
3938 first_code_word = output_pos;
3939
3940 current_token = 2;
3941 npars = 0;
3942 bl = 0;
3943
3944
3945
3946 if substr (tokens (2).name, 1, 4) ^= ": "
3947 then string (basic_program_header.incoming_args) = "0"b;
3948 else do;
3949 if number_of_tokens <= 3
3950 then goto incorrect_format;
3951
3952 current_token = 3;
3953 basic_program_header.incoming_args.location = bit (fixed (size (basic_program_header), 18), 18);
3954
3955 p = addrel (instruction_temp_ptr, output_pos);
3956
3957 param_list:
3958 token_pt = addr (tokens (current_token));
3959
3960 npars = npars + 1;
3961
3962 word = (allocate (0, 2) & ptr_register_mask) | basic_data$param_prototype;
3963
3964 if this_token.type & is_variable
3965 then if substr (tokens (current_token + 1).name, 1, 4) ^= "( "
3966 then do;
3967
3968
3969
3970 if scalars (this_token.number)
3971 then goto variable_occurs_twice;
3972
3973 scalars (this_token.number) = word;
3974
3975 i = numeric_scalar_param;
3976 end;
3977 else do;
3978
3979
3980
3981 if abs (this_token.number) > 26
3982 then goto invalid_array;
3983
3984 array_pt = addr (arrays (this_token.number));
3985
3986 if array_pt -> array.address
3987 then goto array_occurs_twice;
3988
3989 dim_not_allowed (this_token.number) = "1"b;
3990
3991 j = 1;
3992 i = numeric_list_param;
3993 current_token = current_token + 2;
3994
3995 if substr (tokens (current_token).name, 1, 4) = ", "
3996 then do;
3997 j = j + 1;
3998 i = numeric_table_param;
3999 current_token = current_token + 1;
4000 end;
4001
4002 if substr (tokens (current_token).name, 1, 4) ^= ") "
4003 then goto incorrect_format;
4004
4005 array_pt -> array.dimensions = j;
4006 array_pt -> array.address = word;
4007 end;
4008 else if (this_token.type = user_string_fun_token) | (this_token.type = user_numeric_fun_token)
4009 then do;
4010
4011
4012
4013 if fn_table (this_token.number).address
4014 then goto function_occurs_twice;
4015
4016 fn_table (this_token.number).address = word;
4017 i = numeric_function_param;
4018 end;
4019 else if substr (this_token.name, 1, 4) = "# "
4020 then do;
4021
4022
4023
4024 current_token = current_token + 1;
4025 token_pt = addr (tokens (current_token));
4026
4027 if this_token.type ^= integer_constant_token
4028 then goto incorrect_format;
4029
4030 call push_constant;
4031
4032
4033 NOTE
4034
4035
4036
4037
4038
4039 bl = bl + 1;
4040 buffer1 (bl) = instructions.get_fcb_pt | word;
4041 buffer2 (bl) = instructions.load (0) | operand (1);
4042
4043 operand_level = 0;
4044
4045 i = file_param;
4046 end;
4047 else goto invalid_subprogram_parameter;
4048
4049 if this_token.type & is_string
4050 then i = i + 1;
4051
4052 p -> param_info (npars) = bit (fixed (i, 9), 9);
4053
4054 current_token = current_token + 1;
4055 if substr (tokens (current_token).name, 1, 4) = ", "
4056 then do;
4057 current_token = current_token + 1;
4058 goto param_list;
4059 end;
4060
4061 basic_program_header.incoming_args.number = bit (fixed (npars, 17), 18);
4062
4063 output_pos = output_pos + size (p -> param_info_aligned);
4064 end;
4065
4066 entry_pos (program_number) = output_pos;
4067
4068
4069 addrel (instruction_temp_ptr, output_pos) -> basic_entry.word_3 = instructions.enter_proc;
4070
4071 output_pos = output_pos + size (basic_entry);
4072 output_pt = instruction_temp_ptr;
4073
4074
4075
4076 do i = 1 to bl;
4077 output_word (output_pos) = buffer1 (i);
4078 output_word (output_pos + 1) = buffer2 (i);
4079 output_word (output_pos + 2) = instructions.use_fcb;
4080 output_pos = output_pos + 3;
4081 end;
4082
4083 goto done;
4084 ^L
4085
4086
4087 stm (32):
4088 if sub_ok
4089 then goto subend_not_allowed;
4090
4091 word = instructions.subend;
4092 goto end;
4093 ^L
4094
4095
4096 stm (33):
4097 goto not_yet;
4098 ^L
4099
4100
4101 stm (34):
4102 if number_of_tokens ^= 2
4103 then goto incorrect_format;
4104
4105 if tokens (1).type ^= numeric_constant_token
4106 then if tokens (1).type ^= integer_constant_token
4107 then goto incorrect_format;
4108
4109 if tokens (1).value <= 0.0e0
4110 then goto incorrect_format;
4111
4112 program_header_pt = addrel (output_pt, header_pos (program_number));
4113
4114 if time_limit = 0.0e0
4115 then time_limit = tokens (1).value;
4116 else time_limit = min (time_limit, tokens (1).value);
4117
4118 current_token = 2;
4119 goto done;
4120 ^L
4121
4122
4123 stm (35):
4124 call required_file;
4125
4126 write_list:
4127 call put_expression (instructions.write);
4128
4129 if substr (tokens (current_token).name, 1, 4) = ", "
4130 then do;
4131 current_token = current_token + 1;
4132 goto write_list;
4133 end;
4134
4135 goto done;
4136 ^L
4137
4138
4139
4140
4141
4142
4143
4144 reference:
4145 proc;
4146
4147 token_pt = addr (tokens (current_token));
4148
4149 if this_token.type & is_user
4150 then do;
4151 if fn_name ^= this_token.number
4152 then goto invalid_variable;
4153
4154 if substr (tokens (current_token + 1).name, 1, 4) = "( "
4155 then goto invalid_variable;
4156
4157
4158
4159 call push_function;
4160
4161 current_token = current_token + 1;
4162 end;
4163 else do;
4164 if (this_token.type & is_variable) = "0"b
4165 then goto invalid_variable;
4166
4167 current_token = current_token + 1;
4168
4169 if substr (tokens (current_token).name, 1, 4) ^= "( "
4170 then call push_variable;
4171 else do;
4172 call subscript_list;
4173 call push_array (token_pt, number_of_dims);
4174 end;
4175 end;
4176
4177 end;
4178 ^L
4179
4180
4181
4182
4183
4184
4185 subscript_list:
4186 proc;
4187
4188 dcl tp ptr;
4189
4190 tp = token_pt;
4191
4192 current_token = current_token + 1;
4193
4194 call numeric_expression;
4195
4196 if substr (tokens (current_token).name, 1, 4) ^= ", "
4197 then number_of_dims = 1;
4198 else do;
4199 current_token = current_token + 1;
4200 call numeric_expression;
4201 number_of_dims = 2;
4202 end;
4203
4204 if substr (tokens (current_token).name, 1, 4) ^= ") "
4205 then goto incorrect_format;
4206
4207 current_token = current_token + 1;
4208 token_pt = tp;
4209
4210 end;
4211 ^L
4212
4213
4214 numeric_expression:
4215 proc;
4216
4217 call expression;
4218
4219 if operand_type (operand_level) ^= 0
4220 then goto numeric_expression_required;
4221
4222 end;
4223 ^L
4224
4225
4226
4227
4228
4229 for_expression:
4230 proc;
4231
4232 call numeric_expression;
4233
4234 if ^operand_is_constant (operand_level)
4235 then do;
4236
4237
4238
4239 call load_register (0, operand_level);
4240
4241 operand (operand_level) = allocate (0, precision_lng);
4242
4243 output_word (output_pos) = operand (operand_level) | instructions.store (0);
4244 output_pos = output_pos + 1;
4245
4246 operand_in_register (0) = 0;
4247 end;
4248
4249 end;
4250 ^L
4251
4252
4253
4254
4255 expression_in_register:
4256 proc (reg);
4257
4258 dcl reg fixed bin;
4259
4260 dcl m fixed bin;
4261
4262 call expression;
4263
4264 if reg < 0
4265 then m = operand_type (operand_level);
4266 else m = reg;
4267
4268 call register_load (m, operand_level);
4269 end;
4270 ^L
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281 expression:
4282 proc;
4283
4284 dcl (i, current_operator, current_precedence, opcode, optype, parens_level)
4285 fixed bin;
4286
4287 dcl (parens_type, parens_count, parens_token, starting_operator_level)
4288 dim (0:32) fixed bin;
4289
4290 dcl precedence (0:9) fixed bin static init (14,
4291
4292 4,
4293 4,
4294 6,
4295 6,
4296 10,
4297 4,
4298 12,
4299 2,
4300 1);
4301
4302 dcl right_precedence (0:10) fixed bin static init (0,
4303
4304 3,
4305 3,
4306 5,
4307 5,
4308 10,
4309 3,
4310 12,
4311 14,
4312 1,
4313 1);
4314
4315 dcl (
4316 exp_paren init (1),
4317 sub_paren init (2),
4318 fun_paren init (3),
4319 user_fun_paren init (4)
4320 ) fixed bin int static;
4321
4322 parens_level = 0;
4323
4324 starting_operator_level (0) = operator_level;
4325
4326 want_operand:
4327 token_pt = addr (tokens (current_token));
4328
4329 if this_token.type & is_operator
4330 then do;
4331
4332
4333
4334 if this_token.number = plus_op
4335 then do;
4336 current_token = current_token + 1;
4337 goto want_operand;
4338 end;
4339
4340 if this_token.number = minus_op
4341 then do;
4342
4343
4344
4345
4346 if tokens (current_token + 1).type & is_constant
4347 then do;
4348 current_token = current_token + 1;
4349 token_pt = addr (tokens (current_token));
4350
4351 if this_token.type & is_string
4352 then goto numeric_expression_required;
4353
4354 if single
4355 then this_token.value = -this_token.value;
4356 else d_this_token.value = -d_this_token.value;
4357 call push_constant;
4358 goto want_operator;
4359 end;
4360
4361 current_operator = unary_minus_op;
4362 goto check_stack;
4363 end;
4364
4365 goto incorrect_format;
4366 end;
4367
4368 if this_token.type & is_variable
4369 then do;
4370 current_token = current_token + 1;
4371
4372 if substr (tokens (current_token).name, 1, 4) ^= "( "
4373 then do;
4374 call push_variable;
4375 goto want_op;
4376 end;
4377
4378 call parenthesis ((sub_paren));
4379 end;
4380
4381 if this_token.type & is_constant
4382 then do;
4383 call push_constant;
4384 goto want_operator;
4385 end;
4386
4387 if this_token.type & is_function
4388 then do;
4389
4390 if this_token.type & is_user
4391 then do;
4392 if substr (tokens (current_token + 1).name, 1, 4) ^= "( "
4393 then do;
4394 if fn_name = this_token.number
4395 then call push_function;
4396 else call user_function (token_pt, 0);
4397
4398 goto want_operator;
4399 end;
4400
4401 current_token = current_token + 1;
4402 call parenthesis ((user_fun_paren));
4403 end;
4404
4405
4406
4407 i = basic_data$functions (this_token.number).class;
4408
4409 if number_of_args_required (i) = 0
4410 then do;
4411 if substr (tokens (current_token + 1).name, 1, 4) = "( "
4412 then goto wrong_number_of_args;
4413
4414 i = fixed (substr (this_token.type, 2, 1), 1);
4415
4416 if operand_in_register (i) ^= 0
4417 then call save_register (i);
4418
4419 call function (token_pt, 0);
4420 goto want_operator;
4421 end;
4422
4423 current_token = current_token + 1;
4424
4425 if substr (tokens (current_token).name, 1, 4) ^= "( "
4426 then goto wrong_number_of_args;
4427
4428 if i = n_f_fun | i = n_fs_fun
4429 then do;
4430 current_token = current_token + 1;
4431 if substr (tokens (current_token).name, 1, 4) ^= "# "
4432 then goto file_expression_required;
4433
4434 unspec (tokens (current_token - 1)) = unspec (tokens (current_token - 2));
4435 end;
4436
4437 call parenthesis ((fun_paren));
4438 end;
4439
4440 if this_token.type & is_punctuation
4441 then do;
4442
4443 if substr (this_token.name, 1, 4) = "( "
4444 then call parenthesis ((exp_paren));
4445
4446
4447
4448 goto incorrect_format;
4449 end;
4450
4451 if parens_level ^= 0
4452 then goto parenthesis_mismatch;
4453 else goto incorrect_format;
4454
4455 want_operator:
4456 current_token = current_token + 1;
4457
4458 want_op:
4459 token_pt = addr (tokens (current_token));
4460
4461 if this_token.type & is_operator
4462 then current_operator = this_token.number;
4463 else if substr (this_token.name, 1, 4) = ") "
4464 then current_operator = close_paren;
4465 else if substr (this_token.name, 1, 4) = ", "
4466 then current_operator = comma;
4467 else current_operator = 0;
4468
4469 check_stack:
4470 current_precedence = right_precedence (current_operator);
4471
4472 do while (operator_level > starting_operator_level (parens_level));
4473 opcode = operator (operator_level);
4474
4475 if precedence (opcode) <= current_precedence
4476 then goto stack_operator;
4477
4478 if opcode <= unary_minus_op
4479 then do;
4480 optype = fixed (opcode = string_op, 1);
4481
4482
4483 if operand_type (operand_level) = 1 &
4484 operand_type (operand_level - 1) = 1 &
4485 opcode = plus_op then do;
4486
4487 optype = 1;
4488 goto op (string_op);
4489 end;
4490
4491 if operand_type (operand_level) ^= optype
4492 then goto mixed_expression;
4493
4494 if opcode ^= unary_minus_op
4495 then if operand_type (operand_level - 1) ^= optype
4496 then goto mixed_expression;
4497 end;
4498
4499 goto op (opcode);
4500
4501
4502
4503 op (1):
4504 call operate (instructions.add, instructions.add);
4505 goto op_done;
4506
4507
4508
4509 op (2):
4510 if operand_in_register (0) = operand_level
4511 then do;
4512 output_word (output_pos) = operand (operand_level - 1) | instructions.subtract;
4513 output_word (output_pos + 1) = instructions.fneg;
4514 output_pos = output_pos + 2;
4515 end;
4516 else do;
4517 call load_register (0, operand_level - 1);
4518 output_word (output_pos) = instructions.subtract | operand (operand_level);
4519 output_pos = output_pos + 1;
4520 end;
4521
4522 goto op_done;
4523
4524
4525
4526 op (3):
4527 call operate (instructions.multiply, instructions.multiply);
4528 goto op_done;
4529
4530
4531
4532 op (4):
4533 call operate (instructions.divide, instructions.divide_inv);
4534 goto op_done;
4535
4536
4537
4538 op (5):
4539 if operand_in_register (2) ^= 0
4540 then call save_register (2);
4541
4542 if operand_in_register (0) = operand_level
4543 then do;
4544 output_word (output_pos) = instructions.power_inverse;
4545 output_word (output_pos + 1) = instructions.load (0) | operand (operand_level - 1);
4546 end;
4547 else do;
4548 call load_register (0, operand_level - 1);
4549 output_word (output_pos) = instructions.power;
4550 output_word (output_pos + 1) = instructions.load (0) | operand (operand_level);
4551 end;
4552
4553 output_pos = output_pos + 2;
4554 goto op_done;
4555
4556
4557
4558 op (6):
4559 call load_register (1, operand_level - 1);
4560
4561 output_word (output_pos) = instructions.string_concatenate (0) | operand (operand_level);
4562 output_word (output_pos + 1) = instructions.string_concatenate (1);
4563
4564 output_pos = output_pos + 2;
4565 goto op_done;
4566
4567
4568
4569 op (7):
4570 call load_register (0, operand_level);
4571 output_word (output_pos) = instructions.fneg;
4572 output_pos = output_pos + 1;
4573 if operand_in_register (2) = operand_level
4574 then operand_in_register (2) = 0;
4575 goto op_thru;
4576
4577
4578
4579 op (8):
4580 if current_operator = comma
4581 then do;
4582 if parens_type (parens_level) = exp_paren
4583 then goto punctuation_not_allowed;
4584
4585 parens_count (parens_level) = parens_count (parens_level) + 1;
4586 current_token = current_token + 1;
4587 goto want_operand;
4588 end;
4589
4590 if current_operator ^= close_paren
4591 then goto parenthesis_mismatch;
4592
4593 goto paren_xeq (parens_type (parens_level));
4594
4595
4596
4597 paren_xeq (1):
4598 operator_level = operator_level - 1;
4599
4600 parens_level = parens_level - 1;
4601 if parens_level < 0
4602 then goto parenthesis_mismatch;
4603
4604 goto want_operator;
4605
4606
4607
4608 paren_xeq (2):
4609 call push_array (addr (tokens (parens_token (parens_level))), parens_count (parens_level));
4610
4611 goto paren_xeq (1);
4612
4613
4614
4615 paren_xeq (3):
4616 call function (addr (tokens (parens_token (parens_level))), parens_count (parens_level));
4617
4618 goto paren_xeq (1);
4619
4620
4621
4622 paren_xeq (4):
4623 call user_function (addr (tokens (parens_token (parens_level))), parens_count (parens_level));
4624
4625 goto paren_xeq (1);
4626
4627 op_done:
4628 operand_level = operand_level - 1;
4629
4630
4631
4632
4633 if operand_in_register (2) > operand_level
4634 then operand_in_register (2) = 0;
4635
4636 op_thru:
4637 operator_level = operator_level - 1;
4638
4639 operand (operand_level) = (36)"0"b;
4640 operand_type (operand_level) = optype;
4641 operand_in_register (optype) = operand_level;
4642
4643 end;
4644
4645
4646
4647 stack_operator:
4648 if current_operator = 0 | current_operator >= close_paren
4649 then do;
4650 if parens_level ^= 0
4651 then goto parenthesis_mismatch;
4652 return;
4653 end;
4654
4655 stack_it:
4656 operator_level = operator_level + 1;
4657 if operator_level > hbound (operator, 1)
4658 then goto too_deep;
4659
4660 operator (operator_level) = current_operator;
4661 current_token = current_token + 1;
4662 goto want_operand;
4663
4664 parenthesis:
4665 proc (type);
4666
4667 dcl type fixed bin;
4668
4669 parens_level = parens_level + 1;
4670 if parens_level > hbound (parens_type, 1)
4671 then goto too_deep;
4672
4673 current_operator = open_paren;
4674
4675 parens_type (parens_level) = type;
4676 parens_count (parens_level) = 1;
4677 parens_token (parens_level) = current_token - 1;
4678 starting_operator_level (parens_level) = operator_level;
4679
4680 goto stack_it;
4681 end;
4682
4683 end;
4684 ^L
4685
4686
4687
4688 push_function:
4689 proc;
4690
4691 operand_level = operand_level + 1;
4692 if operand_level > hbound (operand, 1)
4693 then goto too_deep;
4694
4695 operand (operand_level) = arg_prototype;
4696 operand_type (operand_level) = fixed (substr (this_token.type, 2, 1), 1);
4697
4698 end;
4699 ^L
4700
4701
4702
4703 push_variable:
4704 proc;
4705
4706 dcl k fixed bin,
4707 amount (2, 0:1) fixed bin static init (1, 1, 2, 1);
4708
4709 operand_level = operand_level + 1;
4710 if operand_level > hbound (operand, 1)
4711 then goto too_deep;
4712
4713 k = fixed (substr (this_token.type, 2, 1), 1);
4714
4715 if scalars (this_token.number) = "0"b
4716 then scalars (this_token.number) = allocate (k, (amount (precision_lng, k)));
4717
4718 operand (operand_level) = scalars (this_token.number) | modifier;
4719 operand_type (operand_level) = k;
4720 end;
4721 ^L
4722
4723
4724
4725
4726
4727
4728
4729 push_array:
4730 proc (tp, ndims);
4731
4732 dcl tp ptr,
4733 ndims fixed bin;
4734
4735 dcl m fixed bin;
4736
4737
4738
4739
4740 if ndims > 2
4741 then goto wrong_number_of_subs;
4742
4743 token_pt = tp;
4744
4745 call dimension_array (ndims, 11, 11);
4746
4747 if operand_in_register (2) ^= 0
4748 then do;
4749
4750
4751
4752
4753 do m = address_register_loaded to output_pos;
4754 if (output_word (m) & "111111111111111111000000000001111111"b) = basic_data$array_prototype
4755 then goto clear_address_register;
4756 end;
4757
4758
4759
4760
4761 if ndims = 1
4762 then if operand_in_register (2) = operand_level
4763 then goto clear_address_register;
4764 else ;
4765 else if operand_in_register (0) ^= operand_level
4766 then if operand_in_register (2) = operand_level - 1
4767 then goto clear_address_register;
4768
4769 call save_register (2);
4770
4771 clear_address_register:
4772 operand_in_register (2) = 0;
4773 end;
4774
4775 call array_op (instructions.subscript, ndims);
4776
4777 operand (operand_level) = basic_data$array_prototype;
4778 operand_type (operand_level) = array_type;
4779
4780 address_register_loaded = output_pos;
4781 end;
4782 ^L
4783
4784
4785
4786
4787
4788
4789
4790
4791 array_op:
4792 proc (op, ndims);
4793
4794 dcl op (3) bit (36) aligned,
4795 ndims fixed bin;
4796
4797 if ndims = 1
4798 then do;
4799 call load_register (0, operand_level);
4800 call plop (op (1), "0"b);
4801 end;
4802 else do;
4803 if operand_in_register (0) = operand_level
4804 then call plop (op (3), operand (operand_level - 1));
4805 else do;
4806 call load_register (0, operand_level - 1);
4807 call plop (op (2), operand (operand_level));
4808 end;
4809
4810 operand_level = operand_level - 1;
4811 end;
4812
4813 operand_in_register (0) = 0;
4814 operand_in_register (2) = operand_level;
4815
4816 plop:
4817 proc (x1, x2);
4818
4819 dcl (x1, x2) bit (36) aligned;
4820
4821 output_word (output_pos) = instructions.load (2) | array_pt -> array.address | modifier;
4822 output_word (output_pos + 1) = x1;
4823 output_pos = output_pos + 2;
4824
4825 if x2
4826 then do;
4827 output_word (output_pos) = instructions.load (0) | x2;
4828 output_pos = output_pos + 1;
4829 end;
4830
4831 end;
4832
4833 end;
4834 ^L
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845 dimension_array:
4846 proc (ndims, bound1, bound2);
4847
4848 dcl (ndims, bound1, bound2)
4849 fixed bin;
4850
4851 dcl nd fixed bin;
4852
4853 if abs (this_token.number) > 26
4854 then goto invalid_array;
4855
4856 nd = abs (ndims);
4857
4858 array_type = fixed (substr (this_token.type, 2, 1), 1);
4859 array_pt = addr (arrays (this_token.number));
4860
4861 if array_pt -> array.address = "0"b
4862 then do;
4863
4864
4865
4866 array_pt -> array.dimensions = nd;
4867
4868 if statement_type = dim_statement
4869 then dim_not_allowed (this_token.number) = "1"b;
4870
4871 call set_bounds;
4872
4873 array_pt -> array.address = allocate (0, size (array_dope));
4874 end;
4875 else do;
4876 if ndims > 0
4877 then if nd ^= array_pt -> array.dimensions
4878 then goto wrong_number_of_subs;
4879
4880 if statement_type = dim_statement
4881 then do;
4882 if dim_not_allowed (this_token.number)
4883 then goto array_defined_twice;
4884
4885 dim_not_allowed (this_token.number) = "1"b;
4886
4887 call set_bounds;
4888 end;
4889 end;
4890
4891 set_bounds:
4892 proc;
4893
4894 array_pt -> array.bounds (1) = bound1;
4895 if nd = 2
4896 then array_pt -> array.bounds (2) = bound2;
4897
4898 end;
4899 end;
4900 ^L
4901
4902
4903
4904
4905 push_constant:
4906 proc;
4907
4908 dcl i fixed bin (18),
4909 d_value float bin (63),
4910 based_single fixed bin (35) based,
4911 based_double fixed bin (71) based,
4912 word bit (36) aligned;
4913
4914 operand_level = operand_level + 1;
4915 if operand_level > hbound (operand, 1)
4916 then goto too_deep;
4917
4918 operand_type (operand_level) = fixed (substr (this_token.type, 2, 1), 1);
4919
4920 if this_token.type & is_string
4921 then do;
4922 i = this_token.number;
4923 word = basic_data$constant_prototype | bit (fixed (i - 1, 18), 18);
4924 end;
4925
4926 else if single
4927 then do;
4928 val = unspec (this_token.value);
4929
4930 if substr (val, 1, 18) = "0"b
4931 then word = substr (val, 19, 18) || "000000000000000111"b;
4932 else if substr (val, 19, 18) = "0"b
4933 then word = substr (val, 1, 18) || "000000000000000011"b;
4934 else do;
4935
4936 do i = 1 to number_of_constants;
4937 if addr (constants (i)) -> based_single = addr (this_token.value) -> based_single
4938 then goto ok;
4939 end;
4940
4941
4942
4943 number_of_constants = number_of_constants + 1;
4944
4945 constants (number_of_constants) = this_token.value;
4946
4947 ok:
4948 word = basic_data$constant_prototype
4949 | bit (fixed (i - 1 + size (basic_program_header), 18), 18);
4950 end;
4951 end;
4952 else do;
4953 d_value = d_this_token.value;
4954
4955 dp_case:
4956 do i = 1 to divide (number_of_constants, 2, 17, 0);
4957 if addr (d_constants (i)) -> based_double = addr (d_value) -> based_double
4958 then go to d_ok;
4959 end;
4960
4961 i = divide (number_of_constants + 3, 2, 17, 0);
4962 number_of_constants = i * 2;
4963 d_constants (i) = d_value;
4964
4965 d_ok:
4966 word = basic_data$constant_prototype
4967 | bit (fixed ((i - 1) * 2 + size (basic_program_header), 18), 18);
4968 end;
4969
4970 operand (operand_level) = word;
4971 return;
4972
4973 push_constant_dp_notok:
4974 entry (a_value);
4975
4976 dcl a_value float bin (63);
4977
4978 d_value = a_value;
4979 operand_type (operand_level) = 0;
4980 go to dp_case;
4981
4982 end;
4983 ^L
4984
4985
4986
4987 operand_is_constant:
4988 proc (level) returns (bit (1) aligned);
4989
4990 dcl level fixed bin;
4991
4992 return (((operand (level) & prototype_mask) = basic_data$constant_prototype) | (rand (level).tag = "000111"b)
4993 | (rand (level).tag = "000011"b));
4994 end;
4995 ^L
4996
4997
4998
4999 allocate:
5000 proc (which, amount) returns (bit (36) aligned);
5001
5002 dcl which fixed bin,
5003 amount fixed bin;
5004
5005 dcl loc fixed bin (18);
5006
5007 if amount = 1
5008 then if odd_available (which) ^= 0
5009 then do;
5010 loc = odd_available (which);
5011 odd_available (which) = 0;
5012 end;
5013 else do;
5014 loc = auto_ctr (which);
5015 auto_ctr (which) = auto_ctr (which) + 1;
5016 end;
5017 else do;
5018
5019
5020
5021 if mod (auto_ctr (which), 2) ^= 0
5022 then do;
5023 odd_available (which) = auto_ctr (which);
5024 auto_ctr (which) = auto_ctr (which) + 1;
5025 end;
5026
5027 loc = auto_ctr (which);
5028 auto_ctr (which) = auto_ctr (which) + amount;
5029 end;
5030
5031 return (basic_data$scalar_prototype (which) | bit (loc, 18));
5032 end;
5033 ^L
5034
5035
5036
5037
5038
5039
5040 allocate_temp:
5041 proc (reg) returns (bit (36) aligned);
5042
5043 dcl reg fixed bin;
5044
5045 dcl space (0:2) fixed bin static init (0, 1, 0),
5046 amount (2, 0:2) fixed bin static init (1, 1, 2, 2, 2, 2);
5047
5048 dcl k fixed bin,
5049 ta bit (36) aligned;
5050
5051 temps (reg).next = temps (reg).next + 1;
5052
5053 k = temps (reg).next;
5054 if k > max_temp
5055 then goto too_deep;
5056
5057 ta = temps (reg).address (k);
5058
5059 if ta = "0"b
5060 then do;
5061 if modifier = normal_modifier
5062 then ta = allocate ((space (reg)), (amount (precision_lng, reg)));
5063 else ta = allocate_local (space (reg), amount (precision_lng, reg), reg);
5064
5065 temps (reg).address (k) = ta;
5066 end;
5067
5068 return (ta);
5069 end;
5070 ^L
5071
5072
5073
5074 allocate_local:
5075 proc (which, amount, reg) returns (bit (36) aligned);
5076
5077 dcl which fixed bin,
5078 amount fixed bin,
5079 reg fixed bin;
5080
5081 dcl loc fixed bin (18),
5082 number (2, 0:2) fixed bin static init (1, 1, 2, 1, 1, 1) options (constant),
5083 n_locs fixed bin (5);
5084
5085 n_locs = fixed (fn_local_word.number, 5) + number (precision_lng, reg);
5086
5087 if amount ^= 1
5088 then if mod (local_ctr, 2) ^= 0
5089 then do;
5090 n_locs = n_locs + 1;
5091 local_ctr = local_ctr + 1;
5092 end;
5093
5094 if n_locs > hbound (fn_local_word.local, 1)
5095 then goto too_many_locals;
5096
5097 fn_local_word.number = bit (n_locs, 5);
5098
5099 loc = local_ctr;
5100 local_ctr = local_ctr + amount;
5101
5102 fn_local_word.local (n_locs) = bit (fixed (which, 1), 1);
5103 if number (precision_lng, reg) = 2
5104 then fn_local_word.local (n_locs - 1) = "0"b;
5105
5106 return (arg_prototype | bit (loc, 18));
5107 end;
5108 ^L
5109
5110
5111
5112
5113
5114
5115
5116 load_register:
5117 proc (reg, level);
5118
5119 dcl reg fixed bin,
5120 level fixed bin;
5121
5122 lr:
5123 if operand_in_register (reg) = level
5124 then return;
5125
5126 if operand_in_register (reg) ^= 0
5127 then call save_register (reg);
5128
5129 output_word (output_pos) = operand (level) | instructions.load (reg);
5130 output_pos = output_pos + 1;
5131
5132 operand_in_register (reg) = level;
5133 return;
5134
5135 register_load:
5136 entry (reg, level);
5137
5138 if reg ^= operand_type (level)
5139 then goto expression_required (reg);
5140
5141 goto lr;
5142 end;
5143 ^L
5144
5145
5146
5147 save_register:
5148 proc (reg);
5149
5150 dcl reg fixed bin;
5151
5152 dcl k fixed bin;
5153
5154 k = operand_in_register (reg);
5155
5156 operand (k) = allocate_temp (reg) | modifier;
5157
5158 if reg ^= 1
5159 then do;
5160 output_word (output_pos) = operand (k) | instructions.store (reg);
5161 output_pos = output_pos + 1;
5162 end;
5163 else do;
5164 output_word (output_pos) = instructions.string_assign (0) | operand (k);
5165 output_word (output_pos + 1) = instructions.string_assign (1);
5166 output_pos = output_pos + 2;
5167 end;
5168
5169
5170
5171
5172 if reg = 2
5173 then rand (k).tag = rand (k).tag | "010000"b;
5174
5175 operand_in_register (reg) = 0;
5176 end;
5177 ^L
5178
5179
5180
5181
5182
5183
5184 operate:
5185 proc (op1, op2);
5186
5187 dcl (op1, op2) bit (36) aligned;
5188
5189 if operand_in_register (0) = operand_level
5190 then output_word (output_pos) = op2 | operand (operand_level - 1);
5191 else do;
5192 call load_register (0, operand_level - 1);
5193 output_word (output_pos) = op1 | operand (operand_level);
5194 end;
5195
5196 output_pos = output_pos + 1;
5197 if operand_in_register (2) = operand_level - 1
5198 then operand_in_register (2) = 0;
5199 end;
5200 ^L
5201
5202
5203
5204 gen_xfer:
5205 proc (op);
5206
5207 dcl op bit (36) aligned;
5208
5209 dcl (i, ln, lower, upper) fixed bin,
5210 offset bit (18);
5211
5212 token_pt = addr (tokens (current_token));
5213
5214 if this_token.type ^= integer_token
5215 then if this_token.type = end_token
5216 then goto line_number_required;
5217 else goto invalid_line_number;
5218
5219 ln = fixed (this_token.value, 17);
5220
5221 if ln <= current_line_number
5222 then do;
5223
5224
5225
5226 lower = 1;
5227 upper = number_of_lines;
5228
5229 do while (lower <= upper);
5230 i = divide (upper + lower, 2, 17, 0);
5231
5232 if ln = line (i).number
5233 then do;
5234
5235 if fn_name = 0
5236 then if in_function (i)
5237 then goto l0;
5238 else ;
5239 else if ln <= fn_start
5240 then goto l0;
5241
5242 offset = bit (fixed (fixed (line (i).location, 17) - output_pos + 262144, 18), 18);
5243 goto l1;
5244 end;
5245
5246 if ln < line (i).number
5247 then upper = i - 1;
5248 else lower = i + 1;
5249 end;
5250
5251 end;
5252
5253
5254
5255 l0:
5256 do i = 1 to missing.count;
5257 if ln = missing.number (i)
5258 then do;
5259
5260 offset = missing.chain (i);
5261 goto l2;
5262 end;
5263 end;
5264
5265
5266
5267 if i > hbound (missing.missing_lines, 1)
5268 then goto too_many_missing_lines;
5269
5270 offset = "0"b;
5271 missing.count = i;
5272 missing.number (i) = ln;
5273
5274
5275
5276 l2:
5277 missing.chain (i) = bit (output_pos, 18);
5278
5279 l1:
5280 output_word (output_pos) = op | offset | ic (0);
5281 output_pos = output_pos + 1;
5282
5283 current_token = current_token + 1;
5284 end;
5285 ^L
5286
5287
5288
5289
5290
5291 function:
5292 proc (tp, nargs);
5293
5294 dcl tp ptr,
5295 nargs fixed bin;
5296
5297
5298
5299 dcl d_value float bin (63),
5300 based_single fixed bin (35) based,
5301 based_double fixed bin (71) based,
5302 word bit (36) aligned;
5303
5304 dcl jump bit (36) aligned,
5305 (i, k) fixed bin;
5306
5307 token_pt = tp;
5308 i = basic_data$functions (this_token.number).class;
5309
5310
5311 if i ^= pos_args then
5312 if number_of_args_required (i) >= 0
5313 then if nargs ^= number_of_args_required (i)
5314 then goto wrong_number_of_args;
5315
5316 jump = basic_data$functions (this_token.number).run_time;
5317 k = fixed (substr (this_token.type, 2, 1), 1);
5318
5319 if operand_in_register (1) ^= 0
5320 then call save_register (1);
5321 if operand_in_register (2) ^= 0
5322 then call save_register (2);
5323
5324 goto fn_xeq (i);
5325
5326
5327
5328 fn_xeq (5):
5329 if operand_in_register (1) ^= 0
5330 then call save_register (1);
5331
5332 fn_xeq (1):
5333 operand_level = operand_level + 1;
5334
5335 fn_put:
5336 if operand_level > hbound (operand, 1)
5337 then goto too_deep;
5338
5339 output_word (output_pos) = jump;
5340
5341 fn_done:
5342 output_pos = output_pos + 1;
5343
5344 fn_thru:
5345 operand (operand_level) = (36)"0"b;
5346 operand_type (operand_level) = k;
5347
5348 operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;
5349
5350 operand_in_register (k) = operand_level;
5351
5352 return;
5353
5354
5355
5356 fn_xeq (6):
5357 fn_xeq (2):
5358 fn_xeq (4):
5359 call register_load (0, operand_level);
5360
5361 goto fn_put;
5362
5363
5364
5365 fn_xeq (3):
5366 call register_load (1, operand_level);
5367
5368 if operand_in_register (0) ^= 0
5369 then call save_register (0);
5370
5371 goto fn_put;
5372
5373
5374
5375 fn_xeq (7):
5376 if operand_in_register (1) ^= 0
5377 then call save_register (1);
5378
5379 fn_xeq (8):
5380 if operand_type (operand_level - 1) + operand_type (operand_level) ^= 0
5381 then goto numeric_expression_required;
5382
5383 if operand_in_register (0) = operand_level
5384 then call save_register (0);
5385
5386 call load_register (0, operand_level - 1);
5387
5388 output_word (output_pos) = jump;
5389 output_pos = output_pos + 1;
5390
5391 output_word (output_pos) = instructions.load (0) | operand (operand_level);
5392
5393 operand_level = operand_level - 1;
5394 goto fn_done;
5395
5396
5397
5398 fn_xeq (9):
5399 call register_load (0, operand_level - 1);
5400 call register_load (1, operand_level);
5401
5402 operand_level = operand_level - 1;
5403 goto fn_put;
5404
5405
5406
5407 fn_xeq (10):
5408 call register_load (0, operand_level);
5409 call register_load (1, operand_level - 2);
5410
5411 if operand_type (operand_level - 1) = 0
5412 then goto string_expression_required;
5413
5414 output_word (output_pos) = instructions.load (3) | operand (operand_level - 1);
5415 output_pos = output_pos + 1;
5416
5417 operand_level = operand_level - 2;
5418 goto fn_put;
5419
5420
5421
5422 fn_xeq (11):
5423 call register_load (0, operand_level - 1);
5424 call register_load (1, operand_level - 2);
5425
5426 if operand_type (operand_level) ^= 0
5427 then goto numeric_expression_required;
5428
5429 output_word (output_pos) = jump;
5430 output_pos = output_pos + 1;
5431
5432 output_word (output_pos) = instructions.load (0) | operand (operand_level);
5433
5434 operand_level = operand_level - 2;
5435 goto fn_done;
5436
5437
5438
5439 fn_xeq (12):
5440 do i = 0 to 2;
5441 if operand_in_register (i) ^= 0
5442 then call save_register (i);
5443 end;
5444
5445 output_word (output_pos) = instructions.load (4) | bit (fixed (nargs, 18), 18);
5446 output_word (output_pos + 1) = jump;
5447 output_pos = output_pos + 2;
5448
5449 do i = 1 to nargs;
5450 output_word (output_pos) =
5451 instructions.load (operand_type (operand_level - nargs + i)) | operand (operand_level - nargs + i);
5452 output_pos = output_pos + 1;
5453 end;
5454
5455 operand_level = operand_level - nargs + 1;
5456 goto fn_thru;
5457
5458
5459
5460 fn_xeq (13):
5461 goto fn_not_yet;
5462
5463
5464
5465 fn_xeq (14):
5466 goto function_not_allowed;
5467
5468 fn_xeq (16):
5469
5470
5471
5472
5473
5474 if operand_type (operand_level - 1) = 0 then goto string_expression_required;
5475 call register_load (1, operand_level - 1);
5476
5477
5478
5479 if operand_type (operand_level) ^= 0 then goto numeric_expression_required;
5480 call register_load (0, operand_level);
5481
5482 output_word (output_pos) = jump;
5483 output_pos = output_pos + 1;
5484
5485 output_word (output_pos) = instructions.load (0) | operand (operand_level);
5486
5487 operand_level = operand_level - 1;
5488 goto fn_done;
5489
5490 fn_xeq (17):
5491
5492
5493
5494 if nargs = 3 then do;
5495
5496 goto fn_xeq (10);
5497 end;
5498 else if nargs = 2 then do;
5499
5500 if single then do;
5501
5502 val = unspec (one);
5503 word = substr (val, 1, 18)||"000000000000000011"b;
5504 end;
5505 else do;
5506
5507 d_value = 1;
5508
5509
5510 do i = 1 to divide (number_of_constants, 2, 17, 0);
5511 if addr (d_constants (i)) -> based_double = addr (d_value) -> based_double
5512 then go to d_ok_1;
5513 end;
5514
5515 i = divide (number_of_constants + 3, 2, 17, 0);
5516 number_of_constants = i * 2;
5517 d_constants (i) = d_value;
5518
5519 d_ok_1:
5520 word = basic_data$constant_prototype
5521 | bit (fixed ((i - 1) * 2 + size (basic_program_header), 18), 18);
5522 end;
5523 output_word(output_pos) = word|instructions.load(0);
5524 output_pos = output_pos + 1;
5525 call register_load (1, operand_level - 1);
5526 if operand_type (operand_level) = 0 then goto string_expression_required;
5527
5528 output_word (output_pos) = operand (operand_level)|instructions.load (3) ;
5529 output_pos = output_pos + 1;
5530
5531 operand_level = operand_level - 1;
5532 goto fn_put;
5533 end;
5534 else do;
5535 goto wrong_number_of_args;
5536 end;
5537
5538
5539 fn_not_yet:
5540 call error_name (86, this_token.name);
5541 goto abort_statement;
5542 end;
5543 ^L
5544
5545
5546
5547
5548
5549
5550
5551 user_function_loc:
5552 proc returns (bit (36) aligned);
5553
5554 NOTE
5555
5556
5557 function_is_parameter = (fn_table.address (this_token.number) & prototype_mask) = basic_data$param_prototype;
5558
5559 if function_is_parameter
5560 then return (fn_table.address (this_token.number));
5561
5562 loc = fn_table.address (this_token.number);
5563
5564 if loc
5565 then loc = bit (fixed (fixed (loc, 18) - output_pos + 262144, 18), 18);
5566 else do;
5567 loc = fn_table.usage (this_token.number);
5568 fn_table.usage (this_token.number) = bit (output_pos, 18);
5569 end;
5570
5571 return (loc | ic (0));
5572 end;
5573 ^L
5574
5575
5576
5577
5578
5579 user_function:
5580 proc (tp, nargs);
5581
5582 dcl tp ptr,
5583 nargs fixed bin;
5584
5585 dcl (i, k) fixed bin;
5586
5587 token_pt = tp;
5588
5589 do i = 0 to 2;
5590 if operand_in_register (i) ^= 0
5591 then call save_register (i);
5592 end;
5593
5594
5595
5596 output_word (output_pos) = instructions.function_call (0) | user_function_loc ();
5597
5598 if (fn_table.address (this_token.number) & prototype_mask) = basic_data$param_prototype
5599 then output_word (output_pos + 1) = instructions.function_call (2);
5600 else output_word (output_pos + 1) = instructions.function_call (1);
5601
5602 output_pos = output_pos + 3;
5603
5604 string (fn_call_word) = bit (fixed (nargs, 5), 5);
5605
5606 if this_token.number < 0
5607 then fn_call_word.mode = "1"b;
5608
5609 do i = 1 to nargs;
5610 k = operand_type (operand_level - nargs + i);
5611
5612 output_word (output_pos) = instructions.load (k) | operand (operand_level - nargs + i);
5613 output_pos = output_pos + 1;
5614
5615 if k ^= 0
5616 then fn_call_word.arg (i) = "1"b;
5617 end;
5618
5619 output_word (output_pos - nargs - 1) = string (fn_call_word);
5620
5621 k = fixed (substr (this_token.type, 2, 1), 1);
5622 operand_level = operand_level - nargs + 1;
5623 operand_type (operand_level) = k;
5624
5625 operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;
5626 operand_in_register (k) = operand_level;
5627 end;
5628 ^L
5629
5630
5631
5632
5633
5634
5635
5636 input_list:
5637 proc (type, seq, input_stm);
5638
5639 dcl type fixed bin,
5640 seq (0:1) bit (36) aligned,
5641 input_stm bit (1) aligned;
5642
5643 list:
5644 call reference;
5645
5646
5647
5648 if operand_type (1) < type
5649 then goto string_reference_required;
5650
5651 output_word (output_pos) = seq (operand_type (1));
5652 output_pos = output_pos + 1;
5653
5654 if operand_type (1) = 0
5655 then do;
5656 output_word (output_pos) = instructions.store (operand_type (1)) | operand (1);
5657 output_pos = output_pos + 1;
5658 end;
5659 else do;
5660 output_word (output_pos) = instructions.string_assign (0) | operand (1);
5661 output_word (output_pos + 1) = instructions.string_assign (1);
5662 output_pos = output_pos + 2;
5663 end;
5664
5665 operand_level = 0;
5666
5667 if substr (tokens (current_token).name, 1, 4) = ", "
5668 then do;
5669 current_token = current_token + 1;
5670
5671 if current_token ^= number_of_tokens
5672 then goto list;
5673
5674 if ^input_stm
5675 then goto incorrect_format;
5676
5677 return;
5678 end;
5679
5680 if input_stm
5681 then do;
5682 output_word (output_pos) = instructions.end_input;
5683 output_pos = output_pos + 1;
5684 end;
5685
5686 end;
5687 ^L
5688
5689
5690
5691
5692 optional_file:
5693 proc;
5694
5695 if substr (tokens (current_token).name, 1, 4) ^= "# "
5696 then output_word (output_pos) = instructions.use_tty;
5697 else do;
5698 get_file:
5699 current_token = current_token + 1;
5700 call expression_in_register (0);
5701
5702 if substr (tokens (current_token).name, 1, 4) = ": "
5703 then current_token = current_token + 1;
5704 else if current_token ^= number_of_tokens
5705 then goto missing_colon;
5706
5707 output_word (output_pos) = instructions.use_file;
5708
5709 operand_level = operand_level - 1;
5710 operand_in_register (0) = 0;
5711 end;
5712
5713 output_pos = output_pos + 1;
5714
5715 return;
5716
5717 required_file:
5718 entry;
5719
5720 if substr (tokens (current_token).name, 1, 4) ^= "# "
5721 then goto file_expression_required;
5722
5723 goto get_file;
5724 end;
5725 ^L
5726
5727
5728
5729 put_expression:
5730 proc (seq);
5731
5732 dcl seq (0:1) bit (36) aligned;
5733
5734 call expression_in_register (-1);
5735
5736
5737
5738 output_word (output_pos) = seq (operand_type (1));
5739 output_pos = output_pos + 1;
5740
5741 operand_in_register (operand_type (1)) = 0;
5742 operand_level = 0;
5743
5744 end;
5745 ^L
5746
5747
5748
5749
5750
5751
5752 arg_or_local:
5753 proc;
5754
5755 do while ("1"b);
5756 token_pt = addr (tokens (current_token));
5757
5758 if (this_token.type & is_variable) = "0"b
5759 then goto invalid_arg_list;
5760
5761
5762
5763 if (scalars (this_token.number) & prototype_mask) = arg_prototype
5764 then goto invalid_arg_list;
5765
5766 al_count = al_count + 1;
5767 if al_count > hbound (save.number, 1)
5768 then goto invalid_arg_list;
5769
5770 save.number (al_count) = this_token.number;
5771
5772
5773 save.address (al_count) = scalars (this_token.number);
5774
5775
5776
5777 scalars (this_token.number) = arg_prototype | bit (fixed (al_count * precision_lng, 18), 18);
5778
5779 current_token = current_token + 1;
5780
5781 if substr (tokens (current_token).name, 1, 4) ^= ", "
5782 then return;
5783
5784 current_token = current_token + 1;
5785 end;
5786 end;
5787 ^L
5788
5789
5790 fn_cleanup:
5791 proc;
5792
5793 i = fixed (substr (fn_table.address (fn_name), 1, 18), 18);
5794 output_word (output_pos) =
5795 instructions.function_return (0) | bit (fixed (i - output_pos + 262144, 18), 18) | ic (0);
5796 output_word (output_pos + 1) = instructions.function_return (1);
5797 output_pos = output_pos + 2;
5798
5799
5800
5801 substr (output_word (i - 1), 1, 18) = bit (fixed (output_pos - i + 1, 18), 18);
5802
5803
5804
5805 do i = 1 to al_count;
5806 scalars (save.number (i)) = save.address (i);
5807 end;
5808
5809 fn_name = 0;
5810
5811 call scan_missing_list;
5812 missing_pt = addr (missing_table (0));
5813
5814 temps_pt = addr (normal_temps);
5815
5816 modifier = normal_modifier;
5817 end;
5818 ^L
5819
5820
5821
5822
5823 matrix_function:
5824 proc;
5825
5826 dcl m fixed bin;
5827
5828 if basic_data$functions (tokens (3).number).class = matrix_constant
5829 then do;
5830 current_token = 4;
5831 call optional_redimension;
5832 operand_level = operand_level - 1;
5833 end;
5834 else do;
5835 if substr (tokens (4).name, 1, 4) ^= "( "
5836 then goto incorrect_format;
5837
5838 token_pt = addr (tokens (5));
5839
5840 if this_token.number > 26
5841 then goto numeric_matrix_required;
5842 if (this_token.type & is_numeric) = "0"b
5843 then goto numeric_matrix_required;
5844
5845 if substr (tokens (6).name, 1, 4) ^= ") "
5846 then goto incorrect_format;
5847
5848 if substr (tokens (3).name, 1, 4) = "inv "
5849 then m = 2;
5850 else m = -2;
5851
5852 call dimension_array (m, 11, 11);
5853
5854 output_word (output_pos) = instructions.load (1) | modifier | array_pt -> array.address;
5855 output_pos = output_pos + 1;
5856
5857 token_pt = addr (tokens (1));
5858 call dimension_array (array_pt -> array.dimensions, 11, 11);
5859
5860 output_word (output_pos) = instructions.load (2) | modifier | array_pt -> array.address;
5861 output_pos = output_pos + 1;
5862
5863 current_token = 7;
5864 end;
5865
5866 output_word (output_pos) = basic_data$functions (tokens (3).number).run_time;
5867 output_pos = output_pos + 1;
5868 end;
5869 ^L
5870
5871
5872
5873
5874 matrix_reference:
5875 proc (redim_allowed);
5876
5877 dcl redim_allowed bit (1) aligned;
5878
5879 token_pt = addr (tokens (current_token));
5880
5881 if (this_token.type & is_variable) = "0"b
5882 then goto some_matrix_required;
5883
5884 current_token = current_token + 1;
5885
5886 call optional_redimension;
5887
5888 if have_redim & ^redim_allowed
5889 then goto redim_not_allowed;
5890
5891 operand (operand_level) = basic_data$array_prototype;
5892 operand_type (operand_level) = fixed (substr (this_token.type, 2, 1), 1);
5893 end;
5894 ^L
5895
5896
5897
5898
5899
5900 optional_redimension:
5901 proc;
5902
5903 if substr (tokens (current_token).name, 1, 4) = "( "
5904 then call redimension_matrix;
5905 else do;
5906 have_redim = "0"b;
5907 call dimension_array (-1, 11, 11);
5908
5909 output_word (output_pos) = instructions.load (2) | modifier | array_pt -> array.address;
5910 output_pos = output_pos + 1;
5911
5912 operand_level = operand_level + 1;
5913 end;
5914 end;
5915 ^L
5916
5917
5918 redimension_matrix:
5919 proc;
5920
5921 call subscript_list;
5922 call dimension_array (number_of_dims, 11, 11);
5923 call array_op (instructions.redimension, number_of_dims);
5924
5925 have_redim = "1"b;
5926
5927 end;
5928 ^L
5929
5930
5931
5932
5933
5934
5935 mat_input_list:
5936 proc (type, seq, input_stm);
5937
5938 dcl type fixed bin,
5939 seq (0:1) bit (36) aligned,
5940 input_stm bit (1) aligned;
5941
5942 dcl last_mat_input_word fixed bin;
5943
5944 last_mat_input_word = 0;
5945
5946 list:
5947 call matrix_reference ("1"b);
5948
5949
5950
5951 if operand_type (1) < type
5952 then goto string_matrix_required;
5953
5954
5955
5956 output_word (output_pos) = seq (operand_type (1));
5957 output_pos = output_pos + 1;
5958
5959 if seq (0) = instructions.mat_input (0)
5960 then do;
5961 last_mat_input_word = output_pos;
5962 output_word (output_pos) = have_redim || (35)"1"b;
5963 output_pos = output_pos + 1;
5964 end;
5965
5966 operand_level = 0;
5967
5968 if substr (tokens (current_token).name, 1, 4) = ", "
5969 then do;
5970 current_token = current_token + 1;
5971
5972 if current_token ^= number_of_tokens
5973 then goto list;
5974
5975 if ^input_stm
5976 then goto incorrect_format;
5977 end;
5978 else if input_stm
5979 then do;
5980 output_word (output_pos) = instructions.end_input;
5981 output_pos = output_pos + 1;
5982 end;
5983
5984 if last_mat_input_word ^= 0
5985 then if output_word (last_mat_input_word) ^= (36)"1"b
5986 then output_word (last_mat_input_word) = (36)"0"b;
5987
5988 end;
5989 ^L
5990
5991
5992
5993
5994 numeric_list_reference:
5995 proc;
5996
5997 token_pt = addr (tokens (current_token));
5998
5999 if this_token.type ^= numeric_variable_token
6000 then goto numeric_list_required;
6001
6002 current_token = current_token + 1;
6003
6004 if substr (tokens (current_token).name, 1, 4) = "( "
6005 then goto incorrect_format;
6006
6007 call dimension_array (-1, 11, 11);
6008
6009 operand_level = operand_level + 1;
6010
6011 operand (operand_level) = array_pt -> array.address | modifier;
6012 operand_type (operand_level) = 0;
6013
6014 end;
6015 ^L
6016
6017
6018
6019
6020 matrix_op:
6021 proc (op);
6022
6023 dcl op bit (36) aligned;
6024
6025
6026
6027 if tokens (mop (1)).number > 26
6028 then go to matrix_required (matrix_type);
6029 ap (1) = addr (arrays (tokens (mop (1)).number));
6030 if tokens (mop (2)).number > 26
6031 then go to matrix_required (matrix_type);
6032 ap (2) = addr (arrays (tokens (mop (2)).number));
6033
6034 number_of_dims = max (ap (1) -> array.dimensions, ap (2) -> array.dimensions);
6035
6036 if mop (3) ^= 0
6037 then do;
6038 ap (3) = addr (arrays (tokens (mop (3)).number));
6039 number_of_dims = max (number_of_dims, ap (3) -> array.dimensions);
6040 end;
6041
6042 if number_of_dims = 0
6043 then number_of_dims = 2;
6044
6045 do i = 1 to 2;
6046 call matrix_operand (i, number_of_dims);
6047 end;
6048
6049 if mop (3) ^= 0
6050 then call matrix_operand (3, number_of_dims);
6051
6052 output_word (output_pos) = op;
6053 output_pos = output_pos + 1;
6054
6055 end;
6056 ^L
6057
6058
6059
6060
6061
6062 matrix_operand:
6063 proc (num, dims);
6064
6065 dcl (num, dims) fixed bin;
6066
6067 token_pt = addr (tokens (mop (num)));
6068
6069 if this_token.type ^= tokens (1).type
6070 then goto matrix_required (matrix_type);
6071 if this_token.number > 26
6072 then goto matrix_required (matrix_type);
6073
6074 call dimension_array (dims, 11, 11);
6075
6076 output_word (output_pos) = instructions.load (num) | modifier | array_pt -> array.address;
6077 output_pos = output_pos + 1;
6078 end;
6079
6080 end;
6081 ^L
6082
6083
6084
6085 scan_missing_list:
6086 proc;
6087
6088 dcl (i, j, m) fixed bin,
6089 p ptr;
6090
6091 m = 0;
6092 do i = 1 to missing.count;
6093 j = missing.number (i);
6094
6095 if m = 0
6096 then do;
6097 m = output_pos;
6098 output_word (output_pos) = instructions.error (2);
6099 output_pos = output_pos + 1;
6100 end;
6101
6102 do loc = missing.chain (i) repeat (next_loc) while (loc);
6103 p = addrel (output_pt, loc);
6104 next_loc = p -> half (0).left;
6105
6106 p -> half (0).left = bit (fixed (m - fixed (loc, 18), 18), 18);
6107
6108 call error_number_line (-81, j, get_line_number ());
6109 end;
6110 end;
6111 end;
6112 ^L
6113
6114
6115
6116 get_line_number:
6117 proc returns (fixed bin);
6118
6119 dcl (k, lower, upper) fixed bin,
6120 divide builtin;
6121
6122 lower = 1;
6123 upper = number_of_lines;
6124
6125 do while (lower <= upper);
6126 k = divide (upper + lower, 2, 17, 0);
6127
6128 if loc >= "0"b || line (k).location
6129 then if loc < "0"b || line (k + 1).location
6130 then return (line (k).number);
6131 else lower = k + 1;
6132 else upper = k - 1;
6133
6134 end;
6135
6136 return (-1);
6137 end;
6138 ^L
6139
6140
6141
6142
6143 finish_subprogram:
6144 proc;
6145
6146 dcl (constant_pos, i, k, m, end_pos)
6147 fixed bin (18),
6148 string_start fixed bin (18) unsigned,
6149 p ptr,
6150 name char (8) aligned;
6151
6152 dcl (size, string) builtin;
6153 ^L
6154
6155
6156 call scan_missing_list;
6157 ^L
6158
6159
6160 m = 0;
6161 do i = 1 to for_level;
6162 loc = bit (for_location (i), 18);
6163 call error_line (-79, get_line_number ());
6164
6165 if m = 0
6166 then do;
6167 m = output_pos;
6168 output_word (output_pos) = instructions.error (3);
6169 output_pos = output_pos + 1;
6170 end;
6171
6172 p = addrel (output_pt, loc);
6173
6174 if for_type (i) ^= 0
6175 then p -> half (3).left = bit (fixed (m - (for_location (i) + 3), 18), 18);
6176 else do;
6177 p -> half (5).left = bit (fixed (m - (for_location (i) + 5), 18), 18);
6178 p -> half (8).left = bit (fixed (m - (for_location (i) + 8), 18), 18);
6179 end;
6180
6181 end;
6182 ^L
6183
6184
6185 m = 0;
6186 do i = lbound (fn_table, 1) to hbound (fn_table, 1);
6187 loc = fn_table.usage (i);
6188
6189 if loc
6190 then do;
6191 name = "fn" || substr ("abcdefghijklmnopqrstuvwxyz", abs (i), 1);
6192 if i < 0
6193 then substr (name, 4, 1) = "$";
6194
6195 if m = 0
6196 then do;
6197 m = output_pos;
6198 output_word (output_pos) = instructions.error (4);
6199 output_pos = output_pos + 1;
6200 end;
6201
6202 do while (loc);
6203 p = addrel (output_pt, loc);
6204 next_loc = p -> half (0).left;
6205
6206 p -> half (0).left = bit (fixed (m - fixed (loc, 18), 18), 18);
6207
6208 call error_name_line (-80, name, get_line_number ());
6209
6210 loc = next_loc;
6211 end;
6212 end;
6213 end;
6214
6215 end_pos = output_pos;
6216 ^L
6217
6218
6219
6220 if number_of_constants > max_number_of_constants
6221 then do;
6222 call error_no_line (-169);
6223 number_of_constants = max_number_of_constants;
6224 call hcs_$truncate_seg (output_pointer, bin (rel (constant_ptr), 18) + max_number_of_constants, code);
6225 end;
6226
6227
6228
6229 if mod (number_of_constants, 2) ^= 0
6230 then number_of_constants = number_of_constants + 1;
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243 block_size = output_pos - first_code_word;
6244 addr (constants (number_of_constants + 1)) -> block = addr (output_word (first_code_word)) -> block;
6245
6246 output_pt = output_pointer;
6247
6248 output_pos = output_pos + number_of_constants;
6249 last_instruction = output_pos - 1;
6250
6251 entry_pos (program_number) = entry_pos (program_number) + number_of_constants;
6252 entry_pt = addrel (output_pointer, entry_pos (program_number));
6253 if program_number = 1
6254 then main_pt = addr (entry_pt -> basic_entry.word_1);
6255 basic_program_header.incoming_args.location =
6256 bit (fixed (fixed (basic_program_header.incoming_args.location, 18) + number_of_constants, 18), 18);
6257
6258 end_pos = end_pos + number_of_constants;
6259
6260
6261
6262 if numeric_data_count ^= 0
6263 then do;
6264 if precision_lng = 2
6265 then if mod (output_pos, 2) ^= 0
6266 then output_pos = output_pos + 1;
6267 basic_program_header.numeric_data.location =
6268 bit (bin (output_pos - header_pos (program_number), 18), 18);
6269
6270 block_size = numeric_data_count * precision_lng;
6271 basic_program_header.numeric_data.number = bit (block_size, 18);
6272
6273 addrel (output_pt, output_pos) -> block = addr (numeric_data (1)) -> block;
6274
6275 output_pos = output_pos + block_size;
6276 end;
6277
6278 if string_data_count ^= 0
6279 then do;
6280 basic_program_header.string_data.location =
6281 bit (bin (output_pos - header_pos (program_number), 18), 18);
6282
6283 basic_program_header.string_data.number = bit (string_data_count, 18);
6284
6285 block_size = string_data_count;
6286 addrel (output_pt, output_pos) -> block = addr (string_data (1)) -> block;
6287 output_pos = output_pos + block_size;
6288 end;
6289
6290
6291
6292 if precision_lng = 2
6293 then if mod (auto_ctr (0), 2) ^= 0
6294 then auto_ctr (0) = auto_ctr (0) + 1;
6295
6296 string (basic_program_header.numeric_arrays) = process_arrays (1);
6297
6298
6299 string_start = auto_ctr (0);
6300
6301 basic_program_header.numeric_storage.location = "000000000010000000"b;
6302 basic_program_header.numeric_storage.number = bit (fixed (auto_ctr (0) - 128, 18), 18);
6303
6304
6305
6306
6307 auto_ctr (0) = auto_ctr (0) + auto_ctr (1);
6308
6309 string (basic_program_header.string_arrays) = process_arrays (-1);
6310
6311
6312
6313
6314
6315
6316
6317 if auto_ctr (0) > max_storage_amount
6318 then call error_no_line (-170);
6319
6320 basic_program_header.string_storage.location = bit (string_start, 18);
6321 basic_program_header.string_storage.number = bit (fixed (auto_ctr (0) - string_start, 18), 18);
6322
6323
6324
6325
6326
6327 string (basic_program_header.numeric_scalars) = process_scalars (1);
6328
6329 string (basic_program_header.string_scalars) = process_scalars (-1);
6330
6331
6332
6333 m = header_pos (program_number);
6334 basic_program_header.statement_map.location = bit (fixed (output_pos - m, 18), 18);
6335
6336 basic_program_header.statement_map.number = bit (number_of_lines, 18);
6337
6338 do i = 1 to number_of_lines;
6339 output_word (output_pos) =
6340 bit (fixed (fixed (line (i).location, 17) - m + number_of_constants, 18), 18)
6341 || unspec (line (i).number);
6342 output_pos = output_pos + 1;
6343 end;
6344
6345
6346
6347 output_word (output_pos) = bit (end_pos, 18) || (18)"1"b;
6348 output_pos = output_pos + 1;
6349
6350 if single
6351 then basic_program_header.version_number = 2;
6352 else basic_program_header.version_number = -2;
6353
6354 basic_program_header.precision_ind = precision_lng - 1;
6355 ^L
6356
6357
6358
6359 k = mod (auto_ctr (0), 16);
6360 if k ^= 0
6361 then auto_ctr (0) = auto_ctr (0) + 16 - k;
6362
6363 entry_pt -> basic_entry.stack_size = bit (fixed (auto_ctr (0), 18), 18);
6364 entry_pt -> basic_entry.eax_7 = "110010111000000000"b;
6365 entry_pt -> basic_entry.word_2 = "111000000000101000011101010001010000"b;
6366
6367 entry_pt -> basic_entry.header = header_pos (program_number) - entry_pos (program_number);
6368 ^L
6369
6370
6371
6372
6373 process_arrays:
6374 proc (which) returns (bit (36) aligned);
6375
6376 dcl which fixed bin (3);
6377
6378 dcl (num, amount, i) fixed bin (18),
6379 loc bit (18),
6380 (ap, tp) ptr;
6381
6382 loc = bit (bin (output_pos - bin (rel (program_header_pt), 18), 18), 18);
6383 num = 0;
6384
6385 do i = 1 to hbound (arrays, 1);
6386 ap = addr (arrays (which * i));
6387 if ap -> array.address
6388 then do;
6389 tp = addrel (output_pt, output_pos);
6390
6391 tp -> array_symbol.name = substr (alphanumeric, i, 1);
6392 tp -> array_symbol.location = "00"b || substr (ap -> array.address, 4, 15);
6393
6394 amount, tp -> array_symbol.bounds (1) = ap -> array.bounds (1);
6395
6396 tp -> array_symbol.bounds (2) = ap -> array.bounds (2);
6397
6398 if tp -> array_symbol.bounds (2) >= 0
6399 then amount = amount * tp -> array_symbol.bounds (2);
6400
6401 tp -> array_symbol.parameter =
6402 (ap -> array.address & prototype_mask) = basic_data$param_prototype;
6403
6404 if ^tp -> array_symbol.parameter
6405 then do;
6406 tp -> array_symbol.offset = auto_ctr (0);
6407 auto_ctr (0) = auto_ctr (0) + amount * precision_lng;
6408 end;
6409
6410 num = num + 1;
6411 output_pos = output_pos + size (array_symbol);
6412 end;
6413 end;
6414
6415 if num = 0
6416 then return ((36)"0"b);
6417
6418 output_word (output_pos) = "0"b;
6419 output_pos = output_pos + 1;
6420
6421 return (loc || bit (num, 18));
6422 end;
6423 ^L
6424
6425
6426
6427
6428 process_scalars:
6429 proc (which) returns (bit (36) aligned);
6430
6431 dcl which fixed bin (3);
6432
6433 dcl (num, i, k1, k2) fixed bin (18),
6434 loc bit (18),
6435 (tp, sp) ptr;
6436
6437 loc = bit (bin (output_pos - bin (rel (program_header_pt), 18), 18), 18);
6438 num = 0;
6439
6440 do i = 1 to hbound (scalars, 1);
6441 sp = addr (scalars (which * i));
6442 if sp -> scalar
6443 then do;
6444 tp = addrel (output_pt, output_pos);
6445
6446 if i < 27
6447 then tp -> scalar_symbol.name = substr (alphanumeric, i, 1);
6448 else do;
6449
6450 k1 = divide (i, 26, 17, 0);
6451 k2 = i - 26 * k1;
6452
6453 substr (tp -> scalar_symbol.name, 1, 1) = substr (alphanumeric, k2, 1);
6454 substr (tp -> scalar_symbol.name, 2, 1) = substr (digits, k1, 1);
6455 end;
6456
6457 tp -> scalar_symbol.location = "00"b || substr (sp -> scalar, 4, 15);
6458
6459
6460
6461 if which < 0
6462 then tp -> scalar_symbol.location =
6463 bit (fixed (fixed (tp -> scalar_symbol.location, 17) + string_start, 17), 17);
6464
6465 tp -> scalar_symbol.parameter = (sp -> scalar & prototype_mask) = basic_data$param_prototype;
6466
6467 num = num + 1;
6468 output_pos = output_pos + size (scalar_symbol);
6469 end;
6470 end;
6471
6472 if num = 0
6473 then return ((36)"0"b);
6474
6475 return (loc || bit (num, 18));
6476 end;
6477
6478 end;
6479 ^L
6480
6481
6482 finish_object:
6483 proc;
6484
6485 dcl (def_start, def_pos, link_start, sym_start, sym_pos, constant_pos, i, j, k, m, n, end_pos)
6486 fixed bin (18),
6487 name_lng fixed bin (17),
6488 (def_base, link_base, sym_base, p, lib_list_pt)
6489 ptr,
6490 user_id char (32),
6491 based_name char (name_lng) based (lib_name_pt),
6492 (zero_def, seg_def, last_def, b18)
6493 aligned bit (18);
6494
6495 dcl (size, string) builtin;
6496
6497 dcl 1 saved_lib_list aligned based (lib_list_pt),
6498 2 nlibs fixed bin,
6499 2 names (n refer (nlibs)) aligned,
6500 3 offset bit (18) unaligned,
6501 3 lng fixed bin (17) unaligned;
6502
6503 dcl 1 relinfo aligned based,
6504 2 version fixed binary,
6505 2 rel_bit_count fixed binary,
6506 2 relbits bit (i refer (rel_bit_count)) unaligned;
6507
6508 dcl 1 def_header aligned based,
6509 2 forward unaligned bit (18),
6510 2 backward unaligned bit (18),
6511 2 skip unaligned bit (18),
6512 2 flags unaligned bit (18);
6513
6514 dcl 1 link_header aligned based,
6515 2 word_0 bit (36),
6516 2 word_1 unaligned,
6517 3 def_block bit (18),
6518 3 right bit (18),
6519 2 word_2 bit (36),
6520 2 word_3 bit (36),
6521 2 word_4 bit (36),
6522 2 word_5 bit (36),
6523 2 word_6 unaligned,
6524 3 first_link bit (18),
6525 3 block_length bit (18),
6526 2 word_7 unaligned,
6527 3 skip bit (18),
6528 3 static_length bit (18);
6529
6530 %include definition;
6531 %include std_symbol_header;
6532 %include source_map;
6533 %include relbts;
6534 %include object_map;
6535 ^L
6536 if lib_count > 0
6537 then do;
6538 lib_list_pt = addrel (output_pt, output_pos);
6539 saved_lib_list.nlibs, n = lib_count;
6540 lib_name_pt = addrel (lib_list_pt, size (saved_lib_list));
6541
6542 do j = 1 to lib_count;
6543 name_lng, saved_lib_list.names (j).lng = length (lib_names (j));
6544 saved_lib_list.names (j).offset = rel (lib_name_pt);
6545 based_name = substr (lib_names (j), 1, name_lng);
6546 lib_name_pt = addrel (lib_name_pt, divide (name_lng + 3, 4, 17, 0));
6547 end;
6548 output_pos = fixed (rel (lib_name_pt), 18);
6549 end;
6550 else lib_list_pt = null;
6551
6552
6553
6554 def_start = output_pos + mod (output_pos, 2);
6555 def_base = addrel (output_pt, def_start);
6556
6557
6558
6559 def_base -> def_header.flags = "11"b;
6560
6561 zero_def = "000000000000000010"b;
6562 last_def = (18)"0"b;
6563
6564 def_pos = 3;
6565
6566 call generate_definition (seg_name, 3, zero_def, "0"b);
6567
6568 call generate_definition ("symbol_table", 2, "0"b, "0"b);
6569
6570 addrel (def_base, seg_def) -> definition.segname = last_def;
6571
6572 if lib_list_pt ^= null
6573 then call generate_definition ("library_list_", 0, rel (lib_list_pt), "0"b);
6574
6575
6576
6577
6578 do j = 1 to program_number;
6579 p = addr (subprogram.name (j));
6580
6581 if length (p -> based_vs) = 0
6582 then p = addr (seg_name);
6583
6584 call generate_definition (p -> based_vs, 0, bit (fixed (subprogram.entry_pos (j) + 1, 18), 18), "1"b);
6585
6586 p = addrel (output_pt, subprogram.entry_pos (j));
6587 p -> basic_entry.descriptor = last_def;
6588 p -> basic_entry.flag = "1"b;
6589
6590 program_header_pt = addrel (output_pt, subprogram.header_pos (j));
6591
6592 if generate_object
6593 then basic_program_header.definitions = 0;
6594 else basic_program_header.definitions = def_start - subprogram.header_pos (j);
6595 end;
6596
6597
6598
6599
6600 addrel (def_base, last_def) -> definition.forward = bit (def_pos, 18);
6601
6602 def_pos = def_pos + 1;
6603
6604 if ^generate_object
6605 then return;
6606 ^L
6607
6608
6609 link_start = def_start + def_pos + mod (def_pos, 2);
6610 link_base = addrel (output_pt, link_start);
6611
6612 link_base -> link_header.def_block = bit (def_start, 18);
6613
6614 link_base -> link_header.first_link, link_base -> link_header.block_length = "000000000000001000"b;
6615 ^L
6616
6617
6618 sym_start = link_start + 8;
6619
6620 sym_base = addrel (output_pt, sym_start);
6621 sym_pos = size (std_symbol_header);
6622
6623 sym_base -> std_symbol_header.dcl_version = 1;
6624 sym_base -> std_symbol_header.identifier = "symbtree";
6625 sym_base -> std_symbol_header.gen_number = 1;
6626
6627 sym_base -> std_symbol_header.gen_created = addr (basic_$symbol_table) -> std_symbol_header.object_created;
6628
6629 sym_base -> std_symbol_header.object_created = clock_ ();
6630 sym_base -> std_symbol_header.generator = "basic";
6631
6632 m = index (basic_version_$, NL);
6633 symbol_string = substr (basic_version_$, 1, m - 1);
6634 string (sym_base -> std_symbol_header.gen_version) = store_string ();
6635
6636 call get_group_id_ (user_id);
6637
6638 m = index (user_id, " ") - 1;
6639 if m < 0
6640 then m = length (user_id);
6641 symbol_string = substr (user_id, 1, m);
6642 string (sym_base -> std_symbol_header.userid) = store_string ();
6643
6644 string (sym_base -> std_symbol_header.comment) = (36)"0"b;
6645 sym_base -> std_symbol_header.text_boundary = "000000000000000010"b;
6646 sym_base -> std_symbol_header.stat_boundary = "000000000000000010"b;
6647
6648
6649
6650 sym_pos = sym_pos + mod (sym_pos, 2);
6651
6652 sym_base -> std_symbol_header.source_map = bit (sym_pos, 18);
6653
6654 p = addrel (sym_base, sym_pos);
6655 p -> source_map.version = 1;
6656 p -> source_map.number, n = source_number;
6657
6658 sym_pos = sym_pos + size (source_map);
6659
6660 do i = 1 to source_number;
6661 symbol_string = source_map_info (i).pathname;
6662 string (p -> source_map.pathname (i)) = store_string ();
6663
6664 p -> source_map.uid (i) = source_map_info (i).uid;
6665 p -> source_map.dtm (i) = source_map_info (i).dtm;
6666 end;
6667 ^L
6668
6669
6670 sym_base -> std_symbol_header.maxi_truncate, sym_base -> std_symbol_header.mini_truncate = bit (sym_pos, 18);
6671
6672
6673
6674
6675 sym_base -> std_symbol_header.rel_text = bit (sym_pos, 18);
6676
6677 p = addrel (sym_base, sym_pos);
6678 p -> relinfo.version = 1;
6679
6680 i = 0;
6681 k = 0;
6682
6683 do j = 1 to program_number;
6684 m = 2 * entry_pos (j) - k;
6685
6686 do while (m > 1023);
6687 substr (p -> relbits, i + 1, 15) = "111101111111111"b;
6688 i = i + 15;
6689 m = m - 1023;
6690 end;
6691
6692 substr (p -> relbits, i + 1, 15) = "11110"b || bit (fixed (m, 10), 10);
6693 substr (p -> relbits, i + 16, 5) = "10101"b;
6694
6695 i = i + 20;
6696
6697 k = 2 * entry_pos (j) + 1;
6698 end;
6699
6700 if lib_list_pt ^= null
6701 then do;
6702 m = 2 * (fixed (rel (lib_list_pt), 18) + 1) - k;
6703
6704 do while (m > 1023);
6705 substr (p -> relbits, i + 1, 15) = "111101111111111"b;
6706 i = i + 15;
6707 m = m - 1023;
6708 end;
6709 substr (p -> relbits, i + 1, 15) = "11110"b || bit (fixed (m, 10), 10);
6710 i = i + 15;
6711 do j = 1 to lib_count;
6712 substr (p -> relbits, i + 1, 10) = "1"b;
6713 i = i + 10;
6714 end;
6715 end;
6716
6717
6718 p -> rel_bit_count = i;
6719
6720 sym_pos = sym_pos + size (p -> relinfo);
6721 p = addrel (sym_base, sym_pos);
6722
6723
6724
6725
6726 sym_base -> std_symbol_header.rel_def = bit (sym_pos, 18);
6727 p -> relinfo.version = 1;
6728 p -> rel_bit_count = 0;
6729
6730 sym_pos = sym_pos + 3;
6731
6732 p = addrel (sym_base, sym_pos);
6733
6734
6735
6736 sym_base -> std_symbol_header.rel_link = bit (sym_pos, 18);
6737 p -> relinfo.version = 1;
6738 p -> rel_bit_count = 8;
6739 substr (p -> relbits, 1, 8) = "00100000"b;
6740
6741 sym_pos = sym_pos + 3;
6742 p = addrel (p, 3);
6743
6744
6745
6746 sym_base -> std_symbol_header.rel_symbol = bit (sym_pos, 18);
6747 p -> relinfo.version = 1;
6748 p -> rel_bit_count = 0;
6749
6750 sym_pos = sym_pos + 3;
6751
6752 sym_base -> std_symbol_header.block_size = bit (sym_pos, 18);
6753 ^L
6754
6755
6756 n = divide (sym_start + sym_pos + 1, 2, 17, 0) * 2;
6757 p = addrel (output_pt, n);
6758
6759 p -> object_map.decl_vers = 2;
6760 p -> object_map.identifier = "obj_map";
6761 p -> object_map.text_length = bit (output_pos, 18);
6762 p -> object_map.definition_offset = bit (def_start, 18);
6763 p -> object_map.definition_length = bit (def_pos, 18);
6764 p -> object_map.linkage_offset = bit (link_start, 18);
6765 p -> object_map.linkage_length = "000000000000001000"b;
6766 p -> object_map.static_offset = bit (link_start + 8, 18);
6767 p -> object_map.static_length = "0"b;
6768 p -> object_map.symbol_offset = bit (sym_start, 18);
6769 p -> object_map.symbol_length = bit (sym_pos, 18);
6770
6771 p -> object_map.entry_bound, p -> object_map.text_link_offset = "0"b;
6772
6773 p -> object_map.format.relocatable, p -> object_map.format.procedure, p -> object_map.format.standard = "1"b;
6774
6775 output_pos = n + size (p -> object_map);
6776 if which > 1
6777 then output_length = output_pos + 1;
6778 else old_source_info.word_count = output_pos + 1;
6779
6780 ptr (output_pt, output_pos) -> map_ptr = bit (n, 18);
6781 ^L
6782 generate_definition:
6783 proc (name, class, value, entry_sw);
6784
6785 dcl name char (32) varying,
6786 class fixed bin (3),
6787 entry_sw bit (1) aligned,
6788 value bit (18) aligned;
6789
6790 dcl n fixed bin (9),
6791 i fixed bin,
6792 (def_ptr, q) ptr;
6793
6794 dcl 1 acc aligned based,
6795 2 count bit (9) unaligned,
6796 2 str char (n) unaligned;
6797
6798 b18 = bit (def_pos, 18);
6799 q = addrel (def_base, def_pos);
6800
6801 n = length (name);
6802 q -> acc.count = bit (n, 9);
6803 q -> acc.str = name;
6804
6805 def_pos = def_pos + size (acc);
6806
6807 def_ptr = addrel (def_base, def_pos);
6808
6809 if last_def
6810 then def_ptr -> definition.backward = last_def;
6811 else def_ptr -> definition.backward = zero_def;
6812
6813 addrel (def_base, last_def) -> definition.forward = bit (def_pos, 18);
6814
6815 def_ptr -> definition.new = "1"b;
6816 def_ptr -> definition.retain = "1"b;
6817 def_ptr -> definition.symbol = b18;
6818 def_ptr -> definition.value = value;
6819
6820 def_ptr -> definition.class = bit (class, 3);
6821
6822 if class = 3
6823 then seg_def = bit (def_pos, 18);
6824 else do;
6825 def_ptr -> definition.segname = seg_def;
6826 def_ptr -> definition.entry = entry_sw;
6827 end;
6828
6829 last_def = bit (def_pos, 18);
6830 def_pos = def_pos + 3;
6831
6832 end;
6833 ^L
6834 store_string:
6835 proc returns (bit (36) aligned);
6836
6837 dcl p ptr,
6838 b36 bit (36),
6839 based_string char (length (symbol_string)) based aligned;
6840
6841 if length (symbol_string) = 0
6842 then return ((36)"0"b);
6843
6844 substr (b36, 1, 18) = bit (sym_pos, 18);
6845 p = addrel (sym_base, sym_pos);
6846 p -> based_string = symbol_string;
6847 sym_pos = sym_pos + size (based_string);
6848 substr (b36, 19, 18) = bit (fixed (length (symbol_string), 18), 18);
6849
6850 return (b36);
6851 end;
6852
6853 end;
6854 ^L
6855 build_lib_list:
6856 proc (pname, al_code);
6857
6858
6859
6860 dcl pname char (*);
6861 dcl al_code fixed bin (35);
6862
6863 lib_count = lib_count + 1;
6864 lib_names (lib_count) = pname;
6865 al_code = 0;
6866 return;
6867 end;
6868 ^L
6869
6870
6871
6872
6873
6874 table_overflow:
6875 proc (tabno);
6876
6877 dcl tabno fixed bin;
6878
6879 dcl p ptr;
6880 dcl j fixed bin;
6881
6882 if small_table (tabno)
6883 then do;
6884
6885 if basic_temp_ptr = null
6886 then call get_temp_segment_ ("basic", basic_temp_ptr, code);
6887
6888
6889
6890
6891 block_size = table_pos (tabno) * table_element_size (precision_lng, tabno);
6892 p = ptr (basic_temp_ptr, large_table_offset (tabno));
6893 p -> block = table_pt (tabno) -> block;
6894
6895
6896
6897 table_pt (tabno) = p;
6898 table_max (tabno) = large_table_size (tabno);
6899 small_table (tabno) = "0"b;
6900 end;
6901 else do;
6902
6903
6904
6905 if large_table_offset (number_of_tables) + table_increment (tabno) > table_limit
6906 then do;
6907 call error_sev (table_full (tabno),4);
6908 goto abort_compilation;
6909 end;
6910
6911 do i = number_of_tables to tabno + 1 by -1;
6912 if ^small_table (i)
6913 then do;
6914 p = addrel (table_pt (i), table_increment (tabno));
6915 block_size = table_pos (i) * table_element_size (precision_lng, i);
6916 do j = block_size to 1 by -1;
6917 p -> block (j) = table_pt (i) -> block (j);
6918 end;
6919 table_pt (i) = p;
6920 end;
6921
6922 large_table_offset (i) = large_table_offset (i) + table_increment (tabno);
6923 end;
6924
6925
6926
6927 table_max (tabno) = table_max (tabno) + table_increment (tabno);
6928 end;
6929 end;
6930 ^L
6931
6932
6933 error:
6934 proc (p_err_num);
6935 dcl (p_err_num, p_sev_level, p_line_num,p_num_var) fixed bin parameter;
6936 dcl p_name_var char (8) aligned parameter;
6937
6938 dcl severity_level fixed bin init (1);
6939 dcl line_num3 fixed bin;
6940 dcl (i, k) fixed bin;
6941
6942 dcl 1 message_overlay aligned based (addr (basic_error_messages_$)),
6943 2 index_block_skip (0:500),
6944 3 (a, b, c) fixed bin,
6945 2 skip unal char (k),
6946 2 message unal char (index_block (i).len - 1);
6947
6948 if mess_sv_in_tb ()
6949 then do;
6950 if current_line_number = -1
6951 then line_num3 = current_line_number;
6952 else line_num3 = line_number;
6953 if p_err_num = 3 | p_err_num = 4 | p_err_num = 14
6954 then call pr_sev_line_header2 (p_err_num, severity_level, line_num3);
6955 else call pr_sev_line_header (p_err_num, severity_level, line_num3);
6956 call ioa_ (message);
6957 end;
6958
6959 severity_check:
6960
6961 basic_severity_ = max (basic_severity_, severity_level);
6962 if severity_level >= 4 | number_of_errors >= max_number_of_errors
6963 then goto abort_compilation;
6964 else if p_err_num < 0 then return;
6965 else goto abort_statement;
6966
6967 error_name:
6968 entry (p_err_num, p_name_var);
6969
6970 if mess_sv_in_tb ()
6971 then do;
6972 call pr_sev_line_header (p_err_num, severity_level, current_line_number);
6973 call ioa_ (message, p_name_var, current_line_number);
6974 end;
6975 goto severity_check;
6976
6977 error_line:
6978 entry (p_err_num, p_line_num);
6979
6980 if mess_sv_in_tb ()
6981 then do;
6982 call pr_sev_line_header (p_err_num, severity_level, p_line_num);
6983 call ioa_ (message, p_line_num);
6984 end;
6985 goto severity_check;
6986
6987 error_sev:
6988 entry (p_err_num, p_sev_level);
6989
6990 if mess_sv_in_tb ()
6991 then do;
6992 if current_line_number = -1
6993 then line_num3 = current_line_number;
6994 else line_num3 = line_number;
6995 call pr_sev_line_header (p_err_num, p_sev_level, line_num3);
6996 call ioa_ (message, line_number);
6997 end;
6998 goto severity_check;
6999
7000 error_name_line:
7001 entry (p_err_num, p_name_var, p_line_num);
7002
7003 if mess_sv_in_tb ()
7004 then do;
7005 call pr_sev_line_header (p_err_num, severity_level, p_line_num);
7006 call ioa_ (message, p_name_var, p_line_num);
7007 end;
7008 goto severity_check;
7009
7010 error_number_line:
7011 entry (p_err_num, p_num_var, p_line_num);
7012
7013 if mess_sv_in_tb ()
7014 then do;
7015 call pr_sev_line_header (p_err_num, severity_level, p_line_num);
7016 call ioa_ (message, p_num_var, p_line_num);
7017 end;
7018 goto severity_check;
7019
7020 error_no_line:
7021 entry (p_err_num);
7022
7023 if mess_sv_in_tb ()
7024 then do;
7025 call pr_severity_header (p_err_num, severity_level);
7026 call ioa_ (message);
7027 end;
7028 goto severity_check;
7029
7030
7031 mess_sv_in_tb:
7032 proc returns (bit (1) aligned);
7033
7034 if program_number ^= 0
7035 then if length (subprogram.name (program_number)) ^= 0
7036 then call ioa_ ("Subroutine: ^a", subprogram.name (program_number));
7037 number_of_errors = number_of_errors + 1;
7038 call ioa_ ("");
7039 i = abs (p_err_num);
7040
7041 if i > hbound (index_block, 1)
7042 then do;
7043 severity_level = 3;
7044 goto print_header_only;
7045 end;
7046 else if index_block(i).sev >= 1
7047 then severity_level = index_block(i).sev;
7048 if p_err_num < 0 then severity_level = min (severity_level, 2);
7049
7050 k = index_block (i).loc;
7051 if k ^= -1 then return ("1"b);
7052
7053 print_header_only:
7054
7055 if severity_level = 1
7056 then call ioa_ ("WARNING, on line ^d", current_line_number);
7057 else if severity_level = 5
7058 then call ioa_ ("FATAL ERROR, on line ^d", current_line_number);
7059 else call ioa_ ("Severity ^d ERROR, on line ^d", severity_level, current_line_number);
7060 return ("0"b);
7061 end;
7062
7063
7064
7065
7066
7067 pr_sev_line_header:proc (err_num, severity_level, line_num);
7068 dcl (err_num, severity_level, line_num) fixed bin;
7069
7070 i = abs (err_num);
7071 if severity_level = 1
7072 then call ioa_ ("WARNING - ^d, on line ^d", i, line_num);
7073 else if severity_level = 5
7074 then call ioa_ ("FATAL ERROR - ^d, on line ^d", i, line_num);
7075 else call ioa_ ("ERROR - ^d ,Severity ^d on line ^d", i, severity_level, line_num);
7076 return;
7077
7078 end;
7079
7080
7081
7082 pr_severity_header:proc (err_num, severity_level);
7083 dcl (err_num, severity_level) fixed bin;
7084
7085 i = abs(err_num);
7086 if severity_level = 1
7087 then call ioa_ ("WARNING - ^d", i);
7088 else if severity_level = 5
7089 then call ioa_ ("FATAL ERROR - ^d", i);
7090 else call ioa_ ("ERROR - ^d ,Severity ^d", i, severity_level);
7091 return;
7092 end;
7093
7094
7095
7096
7097 pr_sev_line_header2:proc (err_num, severity_level, line_num);
7098 dcl (err_num, severity_level, line_num) fixed bin;
7099
7100 i = abs (err_num);
7101 if line_num > 0
7102 then do;
7103 if severity_level = 1
7104 then call ioa_ ("WARNING - ^d, after line ^d", i, line_num);
7105 else if severity_level = 5
7106 then call ioa_ ("FATAL ERROR - ^d, after line ^d", i, line_num);
7107 else call ioa_ ("ERROR - ^d ,Severity ^d after line ^d", i, severity_level, line_num);
7108 end;
7109 else do;
7110 if severity_level = 1
7111 then call ioa_ ("WARNING - ^d", i);
7112 else if severity_level = 5
7113 then call ioa_ ("FATAL ERROR - ^d", i);
7114 else call ioa_ ("ERROR - ^d ,Severity ^d", i, severity_level);
7115 end;
7116 return;
7117 end;
7118 end;
7119 end;