1
2
3
4
5
6
7
8
9
10
11 eis_tester: et: procedure;
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27 Note
28
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 debug
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84 dcl script_ptr ptr,
85
86 script_len fixed bin,
87
88 gen_seg_ptr ptr;
89
90
91
92
93
94
95
96
97 dcl setup_data_area (92) ptr;
98
99 dcl code fixed bin (35),
100
101 dup_string char (16),
102
103 debug_loop_flag fixed bin,
104
105
106 plural char (1),
107
108
109 print_string char (16) aligned,
110
111 print_pages (14) char (4),
112
113
114 print_ptr ptr,
115
116 print_len fixed bin,
117
118 long_hregs bit (1) init ("0"b),
119
120 num_words fixed bin,
121
122
123 line_length fixed bin,
124
125 set_indicators bit (36),
126
127 skip_count fixed bin,
128
129
130 test_num (10) fixed bin,
131
132
133 TEST_INSTR char (6) var init (""),
134
135 stop_num fixed bin,
136
137 times_to_repeat fixed bin,
138
139 RPT fixed bin init (1),
140
141 (SEL, SELECT) fixed bin,
142
143
144 temp_seg_name char (32),
145 temp_segp ptr,
146 copy_segp ptr,
147 copy_bit_count fixed bin (24),
148 type fixed bin (2),
149 sof_ bit (1) init ("0"b);
150
151 dcl terminate_sel bit (1);
152
153
154 dcl (brief_flag, verbose_flag) fixed bin,
155
156
157 gen_flag fixed bin,
158
159
160 nox_flag fixed bin,
161
162
163 finished_flag fixed bin,
164
165
166 error_flag fixed bin,
167
168 do_flag fixed bin,
169
170
171 start_flag fixed bin,
172
173
174
175 remember_start fixed bin,
176
177 test_instr_flag fixed bin,
178
179 stop_flag fixed bin;
180
181
182
183 dcl arg_ptr ptr,
184 arg_len fixed bin,
185 num_args fixed bin,
186 dir_name char (168),
187 ent_name char (32),
188 bit_count fixed bin (24);
189
190
191 dcl print_chars (1:4) char (12),
192
193
194 char_word char (4),
195
196 character char (1);
197
198
199 dcl (i, j, k, xx, argcount) fixed bin,
200 loopx fixed bin,
201 datax fixed bin;
202
203 dcl hreg_state bit (1) aligned;
204
205 dcl 1 bug_structure,
206 (2 dummy_print_char char (1),
207
208 2 dummy_test_char char (1),
209
210 2 result_fill_char char (1),
211
212 2 bug_pad char (1)) unaligned;
213 dcl touch_word bit (36),
214
215 workx fixed bin,
216 wptr ptr;
217 dcl int_cond_name char (32);
218
219 dcl cond_infop ptr;
220
221 dcl instr_ptr ptr,
222
223
224 save_data_ptr ptr,
225
226 our_offset fixed bin;
227
228
229
230
231
232 dcl 1 akst aligned like kst_attributes;
233
234
235
236
237
238
239 dcl 1 eis_map based,
240 2 instruction bit (36),
241 2 desc_array (3) bit (36);
242
243
244 dcl instr_overlay (7) bit (36) based;
245
246
247
248 dcl word_overlay bit (36) based,
249
250 char_overlay bit (9) based,
251
252 based_string char (16) based unaligned,
253
254
255
256
257
258
259
260 char_words (4) char (4) based (addr (print_string)) aligned,
261
262 char_bits (3) bit (3) based (addr (character)) unaligned;
263
264
265
266
267
268 dcl data_array (1:4352) char (1) based unaligned,
269
270 ptr_array (8) ptr based,
271
272
273
274
275 reg_array (16) fixed bin (17) based unaligned;
276
277 dcl script_path char(501);
278
279
280 dcl data char (data_len) based,
281
282 data_len fixed bin;
283
284
285
286
287
288 dcl copy_seg char (divide (copy_bit_count + 8, 9, 21, 0)) based;
289
290
291
292
293
294
295
296
297
298
299
300
301 dcl set_data_ptrs (5) ptr internal static;
302
303
304
305
306
307 dcl init_indicators bit (36) internal static
308 init ("000000000000000000000000000010000000"b);
309
310
311
312
313
314
315
316 dcl data_names (5) char (12) internal static
317 init ("data field 1", "data field 2", "data field 3",
318 "test data ", "result data ");
319
320
321
322
323 dcl page_names (14) char (4)
324 init (" in1", " in2",
325 " id1", " d11", " d12", " d13",
326 " id2", " d21", " d22", " d23",
327 " id3", " d31", " d32", " d33");
328
329 dcl tx fixed bin internal static init (4),
330 rx fixed bin internal static init (5);
331
332
333 dcl oct_chars (0:7) char (1) internal static aligned
334 init ("0", "1", "2", "3", "4", "5", "6", "7");
335
336 dcl segs_initialized bit (1) internal static init ("0"b);
337
338 dcl seg_ref_names (7) char (32) internal static options (constant)
339 init ("etx", "eti1", "eti2", "eti3", "etd1", "etd2", "etd3");
340
341 dcl condition_label label internal static,
342 truncation_label label internal static;
343 dcl (stringsize, quit, et_error) condition;
344
345
346
347
348
349
350
351
352
353
354 dcl (etx$set_ptrs, etx$set_regs,
355 etx$set_ind, etx$indicators,
356 etx$instruction_area,
357 etx$set_data1, etx$set_data2, etx$set_data3) external;
358
359
360 dcl com_err_ entry options (variable),
361 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
362 cu_$arg_count entry (fixed bin),
363 cu_$ptr_call entry options (variable),
364 get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin),
365 find_condition_info_ entry (ptr, ptr, fixed bin (35)),
366 continue_to_signal_ entry (fixed bin (35)),
367 et_util$char_rel entry (ptr, fixed bin),
368 etx$execute entry options (variable),
369 expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)),
370 hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
371 fixed bin (12), ptr, fixed bin (35)),
372 hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)),
373 hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
374 hcs_$history_regs_get entry (bit (1) aligned),
375 hcs_$history_regs_set entry (bit (1) aligned),
376 hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
377 hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
378 hcs_$terminate_name entry (char (*), fixed bin (35)),
379 hcs_$terminate_noname entry (ptr, fixed bin (35)),
380 phcs_$deactivate entry (ptr, fixed bin (35)),
381 phcs_$set_kst_attributes entry (fixed bin (35), ptr, fixed bin (35)),
382 ioa_ entry options (variable),
383 unique_bits_ entry () returns (bit (70)),
384 unique_chars_ entry (bit (*)) returns (char (15)),
385 error_table_$badopt fixed bin(35) ext static,
386 error_table_$bad_arg fixed bin (35) ext static,
387 et_test entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35));
388
389 %page;
390 %include kst_attributes;
391
392 dcl 1 cond_info aligned,
393 % include cond_info;
394
395
396 dcl (addr, addrel, baseno, divide, fixed, hbound, null, rtrim, substr, unspec, verify) builtin;
397 %page;
398 %include et_setup_data;
399 %page;
400
401 times_to_repeat = 1;
402 test_num (*) = -1;
403 script_path = "";
404 SELECT = 1;
405
406
407
408
409 verbose_flag, brief_flag, nox_flag = 0;
410
411 call cu_$arg_count (num_args);
412 if num_args <= 0 then goto USAGE;
413
414 debug_loop_flag = 0;
415 debug
416 remember_start, start_flag, stop_flag, do_flag = 0;
417 do argcount = 1 to num_args;
418 call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
419
420 if code ^= 0
421 then do;
422 call com_err_ (code, "ET", "Can't get command argument ^d", argcount);
423 return;
424 end;
425 new_arg:
426 data_len = arg_len;
427
428 if arg_ptr -> data = "-help"
429 then go to USAGE;
430
431 else if arg_ptr -> data = "-bf"
432 | arg_ptr -> data = "-brief"
433 then brief_flag = 1;
434
435
436 else if arg_ptr -> data = "-long"
437 | arg_ptr -> data = "-lg" then
438 verbose_flag = 1;
439
440
441 else
442 if arg_ptr -> data = "-nox"
443 then nox_flag = 1;
444
445 else
446 if arg_ptr -> data = "-debug"
447 then debug_loop_flag = 1;
448
449 else
450 if (arg_ptr -> data = "-fm")
451 | (arg_ptr -> data = "-from")
452 then do;
453
454 start_flag, remember_start = 1;
455
456 if argcount = num_args
457 then do;
458 code = error_table_$bad_arg;
459 call com_err_ (code, "ET", "No number following ^a option.",
460 arg_ptr -> data);
461 return;
462 end;
463
464 argcount = argcount + 1;
465
466 call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
467 if code ^= 0 then goto bad_arg ;
468
469 test_num (1) = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
470
471 if test_num (1) ^= 0
472 then do;
473 code = error_table_$bad_arg;
474 call com_err_ (code, "ET", "Illegal numeric option argument: ^a",
475 arg_ptr -> data);
476 return;
477 end;
478 test_num (1) = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
479 end;
480
481
482 else
483 if (arg_ptr -> data = "-instruction_type")
484 | (arg_ptr -> data = "-inst")
485 then do;
486
487
488 if argcount = num_args
489 then do;
490 code = error_table_$bad_arg;
491 call com_err_ (code, "ET", "No instruction type following ^a option.",
492 arg_ptr -> data);
493 return;
494 end;
495
496 argcount = argcount + 1;
497
498 call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
499 if code ^= 0 then go to bad_arg;
500
501 TEST_INSTR = substr (arg_ptr -> data, 1, arg_len);
502 test_instr_flag = 1;
503 if substr (TEST_INSTR, 1, 1) = "-"
504 then do;
505 code = error_table_$bad_arg;
506 call com_err_ (code, "ET", "An instruction type does not follow argument: ^a",
507 arg_ptr -> data);
508 return;
509 end;
510 end;
511
512
513 else if arg_ptr -> data = "-to"
514 then do;
515
516 stop_flag = 1;
517
518 if argcount = num_args then do;
519 code = error_table_$bad_arg;
520 call com_err_ (code, "ET", "No number following ^a option.", arg_ptr -> data);
521 return;
522 end;
523
524 argcount = argcount + 1;
525 call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
526 if code ^= 0 then go to bad_arg;
527 stop_num = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
528 if stop_num ^= 0 then do;
529 code = error_table_$bad_arg;
530 call com_err_ (code, "ET", "Illegal numeric option argument: ^a", arg_ptr -> data);
531 return;
532 end;
533
534 stop_num = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
535 end;
536
537
538 else
539 if (arg_ptr -> data = "-do")
540 | (arg_ptr -> data = "-select")
541 | (arg_ptr -> data = "-sel")
542 then do;
543
544 do_flag = 1;
545
546 if argcount = num_args
547 then do;
548 code = error_table_$bad_arg;
549 call com_err_ (code, "ET", "No number following ^a option.",
550 arg_ptr -> data);
551 return;
552 end;
553
554 terminate_sel = "0"b;
555 SELECT = 0;
556 do SEL = 1 to 10 while (^terminate_sel);
557 argcount = argcount + 1;
558
559 call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
560
561 if code ^= 0 then do;
562 if SEL = 1 then do;
563 bad_sel_arg: call com_err_ (code, "ET", "No number following the select arg.");
564 return;
565 end;
566 terminate_sel = "1"b;
567 go to set_up_sel;
568 end;
569
570 if substr (arg_ptr -> data, 1, 1) = "-" then do;
571
572 if SEL = 1 then do;
573 code = error_table_$bad_arg;
574 go to bad_sel_arg;
575 end;
576 argcount = argcount -1;
577 terminate_sel = "1"b;
578 go to set_up_sel;
579 end;
580
581 test_num (SEL) = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
582
583 if test_num (SEL) ^= 0
584 then do;
585 if (SEL >1) & ((substr(arg_ptr->data, 1, 1) ="-")
586 | (script_path = "")) then goto new_arg;
587 code = error_table_$bad_arg;
588 call com_err_ (code, "ET", "Illegal numeric option argument: ^a",
589 arg_ptr -> data);
590 return;
591 end;
592 test_num (SEL) = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
593
594 end;
595 SELECT = SELECT + 1;
596 set_up_sel:
597 end;
598
599 else if arg_ptr -> data = "-stop_on_failure"
600 | arg_ptr -> data = "-sof"
601 then sof_ = "1"b;
602
603 else if arg_ptr -> data = "-repeat"
604 | arg_ptr -> data = "-rpt" then do;
605 if argcount = num_args then do;
606 code = error_table_$bad_arg;
607 call com_err_ (code, "ET", "No number following ^a option.", arg_ptr -> data);
608 return;
609 end;
610
611 argcount = argcount + 1;
612 call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
613 if code ^= 0 then go to bad_arg;
614 times_to_repeat = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
615
616 if times_to_repeat ^= 0 then do;
617 code = error_table_$bad_arg;
618 call com_err_ (code, "ET", "Illegal numeric option argument: ^a", arg_ptr -> data);
619 return;
620 end;
621
622 times_to_repeat = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
623
624 end;
625 else
626 use_as_script_path:
627 if script_path = "" then script_path = arg_ptr -> data;
628 else do;
629 if substr(arg_ptr -> data, 1, 1) = "-" then code = error_table_$badopt;
630 else
631 bad_arg: code = error_table_$bad_arg;
632 ARG_ERROR: call com_err_ (code, "ET", "^a.", arg_ptr -> data);
633 return;
634 USAGE: call ioa_ ("ET: Usage is: et path {-control_args}");
635 call ioa_ ("Valid control args: -brief, -bf^/^-^debug
636 call ioa_ ("^-^
637 call ioa_ ("^-^
638 call ioa_ ("^-^
639
640 incons_arg:
641 if ^hreg_state then
642 call hcs_$history_regs_set ("0"b);
643 return;
644 end;
645
646 end;
647 %page;
648
649
650
651
652
653
654
655
656
657 gen_flag = 0;
658
659 goto join;
660
661
662
663 gen: entry;
664
665 gen_flag = 1;
666
667
668
669 join:
670
671 line_length = get_line_length_$switch (null (), code);
672 if line_length < 132 then long_hregs = "0"b;
673 else long_hregs = "1"b;
674
675
676 call hcs_$history_regs_get (hreg_state);
677
678 if ^hreg_state then
679 call hcs_$history_regs_set ("1"b);
680
681 if (gen_flag = 1) then do;
682 call cu_$arg_ptr(1, arg_ptr, arg_len, code);
683 if code ^= 0 then goto ARG_ERROR;
684 data_len = arg_len;
685 script_path = arg_ptr -> data;
686 end;
687
688
689
690
691 call expand_pathname_ (script_path, dir_name, ent_name, code);
692
693 if code ^= 0
694 then do;
695 call com_err_ (code, "ET", "Can't expand path name of input segment ^a.", script_path);
696 return;
697 end;
698
699
700
701
702
703
704
705 do RPT = 1 to times_to_repeat;
706
707 if remember_start = 1 then
708 start_flag = 1;
709
710 SELECT = 1;
711 if gen_flag = 0
712
713
714 then do;
715
716 call hcs_$initiate_count (dir_name, ent_name, "", bit_count, 1,
717 script_ptr, code);
718
719 if script_ptr = null ()
720 then do;
721 call com_err_ (code, "ET", "Cannot initiate data segment ^a^[>^]^a.", dir_name, (dir_name ^= ">"), ent_name);
722 return;
723 end;
724
725 code = 0;
726
727 bit_count = bit_count + 8;
728
729 script_len = bit_count / 9;
730
731 end;
732
733
734
735 else do;
736
737
738
739 call hcs_$make_ptr (null (), ent_name, ent_name, gen_seg_ptr, code);
740
741 if code ^= 0
742 then do;
743 call com_err_ (code, "ET", "Can't get pointer to entry point of gen seg ^a^[>^]^a.",
744 dir_name, (dir_name ^= ">"), ent_name);
745 return;
746 end;
747
748 end;
749
750 %page;
751
752
753
754
755 if ^segs_initialized then do;
756 do i = 1 to hbound (seg_ref_names, 1);
757 call hcs_$terminate_name (seg_ref_names (i), code);
758 call hcs_$make_ptr (null (), seg_ref_names (i), "", copy_segp, code);
759 if code ^= 0 then do;
760 call com_err_ (code, "ET", seg_ref_names (i));
761 return;
762 end;
763 call hcs_$status_mins (copy_segp, type, copy_bit_count, code);
764 if code ^= 0 then do;
765 call com_err_ (code, "ET", seg_ref_names (i));
766 return;
767 end;
768 temp_seg_name = unique_chars_ (unique_bits_ ()) || "." || rtrim (seg_ref_names (i));
769 call hcs_$make_seg ("", temp_seg_name, "", 01110b, temp_segp, code);
770 if code ^= 0 then do;
771 call com_err_ (code, "ET", "Creating [pd]>^a", temp_seg_name);
772 return;
773 end;
774 unspec (akst) = "0"b;
775 akst.set.explicit_deactivate_ok,
776 akst.value.explicit_deactivate_ok = "1"b;
777 call phcs_$set_kst_attributes (fixed (baseno (temp_segp), 17), addr (akst), code);
778 if code ^= 0 then do;
779 call com_err_ (code, "ET", "Setting KST attributes for [pd]>^a", temp_seg_name);
780 return;
781 end;
782 temp_segp -> copy_seg = copy_segp -> copy_seg;
783 call hcs_$terminate_name (seg_ref_names (i), code);
784 call hcs_$make_seg ("", temp_seg_name, seg_ref_names (i), 01110b, (null ()), code);
785 call hcs_$set_bc_seg (temp_segp, copy_bit_count, code);
786 if code ^= 0 then do;
787 call com_err_ (code, "ET", "Setting bit count for [pd]>^a", temp_seg_name);
788 return;
789 end;
790 end;
791 segs_initialized = "1"b;
792 end;
793 call ioa_ ("^/ET");
794 %page;
795
796
797 condition_label = condition_restart;
798
799 set_data_ptrs (1) = addr (etx$set_data1);
800 set_data_ptrs (2) = addr (etx$set_data2);
801 set_data_ptrs (3) = addr (etx$set_data3);
802 set_data_ptrs (4),
803 set_data_ptrs (5) = null ();
804
805 et_data_ptr = addr (setup_data_area);
806
807 page_ptrs (*) = null ();
808
809 next_instruction_x = 0;
810
811 finished_flag = 0;
812
813 test_count = 0;
814
815 addr (result_fill_char) -> char_overlay = "000000000"b;
816 addr (dummy_print_char) -> char_overlay = "111000111"b;
817 addr (dummy_test_char) -> char_overlay = "111001111"b;
818
819 Note
820
821
822
823
824 do i = 12 to 15;
825 addr (regs) -> reg_array (i) = 8191;
826 end;
827
828
829
830
831
832
833 touch_word = addr (etx$execute) -> word_overlay;
834
835
836
837
838
839
840
841 do while (finished_flag = 0);
842
843 call test_instruction;
844
845 condition_restart:
846 end;
847
848 end;
849
850
851
852
853 if gen_flag = 0
854
855 then call hcs_$terminate_noname (script_ptr, code);
856
857
858
859
860
861 if ^hreg_state then
862 call hcs_$history_regs_set ("0"b);
863 return;
864
865
866 test_instruction: procedure;
867
868
869
870
871
872
873
874
875 code = 0;
876 error_flag = 0;
877 name = " ";
878 note = " ";
879
880 test_count = test_count + 1;
881
882
883
884
885
886
887
888
889
890
891 do i = 1 to 7;
892 addr (etx$instruction_area) -> instr_overlay (i) =
893 "000000000000000000000001001000000000"b;
894 end;
895
896
897
898
899
900
901 if gen_flag = 0
902
903
904 then do;
905
906 call et_test (script_ptr, script_len, et_data_ptr, finished_flag, code);
907
908 if code ^= 0
909
910 then do;
911 call com_err_ (0, "ET", "Error in input statement for test: ^d - ^a", test_count, name);
912 return;
913 end;
914 end;
915
916
917 else do;
918
919 call cu_$ptr_call (gen_seg_ptr, et_data_ptr);
920
921 finished_flag = 1;
922
923 end;
924
925
926
927
928
929
930
931
932
933
934 NOTE
935
936
937
938 if test_instr_flag = 1 then
939 if TEST_INSTR ^= name then return;
940
941 if start_flag = 1
942 then do;
943 if test_count ^= test_num (1)
944 then return;
945
946 else do;
947 start_flag = 0;
948 do_flag = 0;
949 end;
950 end;
951
952
953 if do_flag = 1 then do;
954 if test_num (SELECT) = -1 then do;
955 finished_flag = 1;
956 return;
957 end;
958 if test_count ^= test_num (SELECT)
959 then return;
960 else
961 SELECT = SELECT +1;
962 end;
963
964
965 if stop_flag = 1 then do;
966 if test_count = stop_num then
967 finished_flag = 1;
968 end;
969
970 if brief_flag = 0 then
971 call ioa_ ("TEST ^3d (^a)", test_count, name);
972
973
974
975
976
977
978 Note
979
980 Note
981
982
983
984
985 our_offset = (instr_offset - 3)* (-1);
986
987 instr_ptr = addrel (addr (etx$instruction_area), our_offset);
988
989 instr_ptr -> eis_map.instruction = instr_word;
990
991
992
993
994
995
996
997 do i = 1 to 3;
998
999 if descriptors (i) ^= "0"b
1000
1001
1002 then do;
1003
1004 if ind_words (i) = "0"b
1005
1006
1007
1008 then instr_ptr -> eis_map.desc_array (i) = descriptors (i);
1009
1010
1011
1012
1013
1014 else do;
1015 instr_ptr -> eis_map.desc_array (i) = ind_words (i);
1016 desc_ptrs (i) -> word_overlay = descriptors (i);
1017 end;
1018
1019 end;
1020
1021 end;
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032 set_indicators = init_indicators;
1033
1034 if (substr (ir_word, 22, 1) = "1"b) |
1035 (substr (ir_word, 23, 1) = "1"b) |
1036 (substr (ir_word, 24, 1) = "1"b)
1037 then do;
1038 substr (set_indicators, 25, 1) = "1"b;
1039 substr (ir_word, 25, 1) = "1"b;
1040 end;
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051 if data_lens (tx) = 0 then goto print_instr_data;
1052
1053
1054 do i = tx to rx;
1055
1056 call et_util$char_rel (data_ptrs (i), -8);
1057 data_lens (i) = data_lens (i) + 16;
1058
1059 do j = 1 to 8;
1060 data_ptrs (i) -> data_array (j),
1061 data_ptrs (i) -> data_array (data_lens (i) +1 -j) = dummy_test_char;
1062 end;
1063
1064 end;
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074 print_instr_data:
1075
1076 if RPT > 1 then verbose_flag = 0;
1077
1078
1079 if verbose_flag = 0 then goto check_execute;
1080
1081 call ioa_ ("^/Test Description: ^a", note);
1082
1083 call ioa_ ("^/Eis instruction:^-( ^p ) Ind Desc.", instr_ptr);
1084
1085 if instr_offset = 0
1086 then call ioa_ ("^4x- - -
1087
1088 call ioa_ ("^5x^w", instr_ptr -> eis_map.instruction);
1089
1090
1091 do i = 1 to 3;
1092
1093 if instr_offset = i
1094 then call ioa_ ("^4x- - -
1095
1096 if (i = 3) & (descriptors (3) = "0"b)
1097 then goto print_ptrs;
1098
1099 if ind_words (i) = "0"b
1100
1101 then call ioa_ ("^5x^w", instr_ptr -> eis_map.desc_array (i));
1102
1103 else call ioa_ ("^5x^w^8x-> ^w ( ^p )",
1104 instr_ptr -> eis_map.desc_array (i),
1105 descriptors (i), desc_ptrs (i));
1106 end;
1107
1108
1109
1110
1111 print_ptrs:
1112
1113 do i = 0 to 7;
1114
1115 if pointers (i) ^= null ()
1116
1117 then do;
1118 call ioa_ ("^/Pointer Registers:^-( ^p )", addr (etx$set_ptrs));
1119 call ioa_ ("^5xpr0 - pr3 ^p ^p ^p ^p",
1120 pointers (0), pointers (1), pointers (2), pointers (3));
1121 call ioa_ ("^5xpr4 - pr7 ^p ^p ^p ^p",
1122 pointers (4), pointers (5), pointers (6), pointers (7));
1123 goto print_regs;
1124 end;
1125 end;
1126
1127
1128
1129
1130
1131
1132 print_regs:
1133
1134 do i = 0 to 7;
1135 if regs.x (i) ^= 8191
1136 then goto found_used_regs;
1137 end;
1138
1139 if (regs.A ^= 8191) | (regs.Q ^= 8191)
1140 then goto found_used_regs;
1141 else goto print_indicators;
1142
1143
1144 found_used_regs:
1145 call ioa_ ("^/Index Registers:^-( ^p )", addr (etx$set_regs));
1146 call ioa_ ("^5x X0 - X7 ^6o ^6o ^6o ^6o ^6o ^6o ^6o ^6o",
1147 regs.x (0), regs.x (1), regs.x (2), regs.x (3),
1148 regs.x (4), regs.x (5), regs.x (6), regs.x (7));
1149 call ioa_ ("^5x A ^w Q ^w", regs.A, regs.Q);
1150
1151
1152
1153 print_indicators:
1154
1155 call ioa_ ("^/Test Indicators:^-( ^p )", addr (etx$indicators));
1156 call ioa_ ("^5x^w", ir_word);
1157
1158
1159
1160
1161
1162 workx = 0;
1163
1164 do i = 1 to 14;
1165
1166 print_pages (i) = " ";
1167
1168 if (page_faults (i) = "1"b) & (page_ptrs (i) ^= null)
1169
1170 then do;
1171 workx = workx + 1;
1172 print_pages (workx) = page_names (i);
1173 end;
1174 end;
1175
1176 if workx = 1
1177 then plural = " ";
1178 else plural = "s";
1179
1180 call ioa_ ("^/This test will take ^d page fault^a.", workx, plural);
1181
1182 if workx ^= 0
1183 then call ioa_ ("^4x^a^a^a^a^a^a^a^a^a^a^a^a^a^a",
1184 print_pages (1), print_pages (2), print_pages (3), print_pages (4),
1185 print_pages (5), print_pages (6), print_pages (7), print_pages (8),
1186 print_pages (9), print_pages (10), print_pages (11),
1187 print_pages (12), print_pages (13), print_pages (14));
1188
1189
1190
1191
1192
1193
1194 do datax = 1 to 3;
1195
1196 if data_ptrs (datax) ^= null () then call print_data;
1197 end;
1198
1199
1200
1201
1202 if data_lens (tx) ^= 0
1203
1204 then do;
1205 datax = tx;
1206 call print_data;
1207 end;
1208
1209
1210
1211
1212
1213
1214
1215 check_execute:
1216
1217 if nox_flag ^= 0 then return;
1218
1219
1220
1221
1222
1223 debug
1224
1225
1226
1227
1228
1229 if debug_loop_flag = 1
1230 then loop_count = 10;
1231
1232 do loopx = 1 to loop_count;
1233
1234
1235
1236
1237 if data_lens (rx) ^= 0
1238
1239 then do i = 9 to data_lens (rx) - 8;
1240 data_ptrs (rx) -> data_array (i) = result_fill_char;
1241 end;
1242
1243
1244
1245
1246 do j = 1 to 3;
1247
1248 if (data_ptrs (j) ^= null ()) & (data_lens (j) ^= 0)
1249
1250 then do;
1251 data_len = data_lens (j);
1252 data_ptrs (j) -> data = set_data_ptrs (j) -> data;
1253 end;
1254
1255 end;
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265 regs.x (0) = our_offset;
1266
1267 addr (etx$set_ptrs) -> ptr_array = pointers;
1268
1269 addr (etx$set_regs) -> reg_array = addr (regs) -> reg_array;
1270
1271 addr (etx$set_ind) -> word_overlay = set_indicators;
1272 addr (etx$indicators) -> word_overlay = "0"b;
1273
1274
1275
1276 truncation_label = check_errors;
1277 on stringsize begin;
1278
1279
1280
1281
1282
1283 if truncation_flag = 0
1284 then do;
1285 error_flag = 1;
1286 call com_err_ (0, "ET", "Unexpected truncation fault for test: ^d - ^a", test_count, name);
1287 call display_mc_;
1288 go to truncation_label;
1289 end;
1290
1291
1292
1293
1294
1295
1296
1297 else truncation_flag = 2;
1298 go to truncation_label;
1299 end;
1300
1301 if ^sof_ then go to SETUP;
1302
1303
1304 on condition (et_error) begin;
1305 cond_infop = addr (cond_info);
1306 call find_condition_info_ (null (), cond_infop, code);
1307 int_cond_name = cond_info.condition_name;
1308 call display_mc_;
1309 call continue_to_signal_ (code);
1310 end;
1311 SETUP:
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321 LOOP: call DEACTIVATE;
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334 do i = 1 to 14;
1335
1336 if (page_faults (i) = "0"b) & (page_ptrs (i) ^= null ())
1337
1338 then touch_word = page_ptrs (i) -> word_overlay;
1339
1340 end;
1341
1342
1343
1344
1345
1346 call etx$execute;
1347 revert stringsize;
1348
1349
1350
1351 Note
1352 Notedebug
1353
1354
1355
1356
1357
1358 check_errors:
1359
1360 if debug_loop_flag = 1
1361 then goto end_test_loop;
1362
1363 data_len = data_lens (rx);
1364
1365 if data_len ^= 0
1366
1367 then if data_ptrs (tx) -> data ^= data_ptrs (rx) -> data
1368
1369 then do;
1370 call ioa_ ("^/Data resulting from test ( ^d - ^a ) is incorrect.", test_count, name);
1371 datax = rx;
1372 call print_data;
1373 error_flag = 1;
1374 end;
1375
1376
1377
1378
1379
1380
1381 if truncation_flag = 2
1382 then goto check_for_trun;
1383
1384 if addr (etx$indicators) -> word_overlay ^= ir_word
1385
1386 then do;
1387 call ioa_ ("^/Indicators not set correctly for test: ^d - ^a", test_count, name);
1388 call ioa_ ("^/Test indicator word is: ^w", ir_word);
1389 call ioa_ ("Result indicator word is: ^w",
1390 addr (etx$indicators) -> word_overlay);
1391 error_flag = 1;
1392 end;
1393
1394
1395
1396
1397
1398
1399 check_for_trun:
1400
1401 if truncation_flag = 1
1402 then do;
1403 call com_err_ (0, "ET", "^/Expected truncation fault did not occur.");
1404 error_flag = 1;
1405 end;
1406
1407 if error_flag = 1 then
1408 call ioa_ ("^note
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419 print_data: procedure;
1420
1421
1422
1423
1424
1425
1426 Note
1427
1428
1429 xxx
1430
1431
1432
1433 call ioa_ ("^/^a^-( ^p )", data_names (datax), data_ptrs (datax));
1434
1435
1436
1437
1438
1439
1440
1441 if data_lens (datax) = 0
1442
1443 then do;
1444 call ioa_ ("^5xResult data field initialized to all zero bits.");
1445 return;
1446 end;
1447
1448
1449
1450
1451
1452
1453 if set_data_ptrs (datax) = null ()
1454
1455 then print_ptr = data_ptrs (datax);
1456 else print_ptr = set_data_ptrs (datax);
1457
1458 print_len = data_lens (datax);
1459
1460
1461
1462
1463
1464 Note
1465
1466
1467 call et_util$char_rel (print_ptr, -data_offsets (datax));
1468 print_len = print_len + data_offsets (datax);
1469
1470 do i = 1 to data_offsets (datax);
1471 print_ptr -> data_array (i) = dummy_print_char;
1472 end;
1473
1474
1475
1476
1477
1478
1479 workx = print_len - 1;
1480 workx = 4 - (print_len - (divide (workx, 4, 17, 0))*4);
1481
1482 do i = 1 to workx;
1483 print_len = print_len + 1;
1484 print_ptr -> data_array (print_len) = dummy_print_char;
1485 end;
1486
1487
1488
1489
1490
1491
1492 skip_count = 0;
1493
1494 dup_string = "_$<-+;*><)(:|||";
1495
1496 num_words = divide (print_len, 4, 17, 0);
1497
1498
1499
1500
1501 do while (num_words > 0);
1502
1503 if num_words > 3
1504 then workx = 4;
1505 else workx = num_words;
1506
1507 num_words = num_words - 4;
1508
1509 if (num_words > 0) & (print_ptr -> based_string = dup_string)
1510
1511
1512 then do;
1513
1514
1515 skip_count = skip_count + 1;
1516 print_ptr = addr (print_ptr -> data_array (17));
1517 goto end_line;
1518 end;
1519
1520
1521
1522
1523 if skip_count ^= 0
1524
1525 then do;
1526 if skip_count = 1
1527 then plural = " ";
1528 else plural = "s";
1529 call ioa_ ("^5xPrevious line repeated ^d time^a.", skip_count, plural);
1530 skip_count = 0;
1531 end;
1532
1533
1534
1535
1536
1537
1538 print_string = print_ptr -> based_string;
1539
1540 dup_string = print_ptr -> based_string;
1541
1542 print_ptr = addr (print_ptr -> data_array (17));
1543
1544
1545
1546
1547
1548
1549
1550 do i = 1 to workx;
1551
1552 char_word = char_words (i);
1553
1554 do j = 1 to 4;
1555
1556
1557 character = substr (char_word, j, 1);
1558
1559 if character = dummy_print_char
1560 then do;
1561 xx = 1 + (j-1)*3;
1562 substr (print_chars (i), xx, 3) = " ";
1563 goto end_char;
1564 end;
1565
1566 if character = dummy_test_char
1567 then do;
1568 xx = 1 + (j-1)*3;
1569 substr (print_chars (i), xx, 3) = "xxx";
1570 goto end_char;
1571 end;
1572
1573 do k = 1 to 3;
1574 xx = k + (j-1)*3;
1575 substr (print_chars (i), xx, 1) =
1576 oct_chars (fixed (char_bits (k), 3));
1577 end;
1578
1579 end_char:
1580 end;
1581 end;
1582
1583
1584
1585
1586
1587
1588 goto print_line (workx);
1589
1590
1591
1592 print_line (1):
1593
1594 call ioa_ ("^5x^a", print_chars (1));
1595
1596 return;
1597
1598
1599 print_line (2):
1600
1601 call ioa_ ("^5x^a ^a", print_chars (1), print_chars (2));
1602
1603 return;
1604
1605
1606 print_line (3):
1607
1608 call ioa_ ("^5x^a ^a ^a", print_chars (1),
1609 print_chars (2), print_chars (3));
1610
1611 return;
1612
1613
1614 print_line (4):
1615
1616 call ioa_ ("^5x^a ^a ^a ^a", print_chars (1), print_chars (2),
1617 print_chars (3), print_chars (4));
1618
1619
1620 end_line:
1621
1622 end;
1623
1624
1625 end print_data;
1626
1627
1628
1629
1630
1631 end test_instruction;
1632
1633 display_mc_: proc;
1634
1635 dcl cu_$stack_frame_ptr entry (ptr);
1636 dcl find_condition_frame_ entry (ptr) returns (ptr);
1637 dcl find_condition_info_ entry (ptr, ptr, fixed bin (35));
1638 dcl dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin);
1639 dcl hran_$hranl entry (ptr, ptr, bit (1));
1640 dcl hreg_ptr ptr;
1641
1642
1643 dcl 1 condinfo aligned,
1644 % include cond_info;
1645
1646 dcl (stackp, faultsp) ptr;
1647 dcl (null, addr) builtin;
1648 dcl ec fixed bin (35);
1649
1650
1651 call cu_$stack_frame_ptr (stackp);
1652 faultsp = find_condition_frame_ (stackp);
1653 if faultsp = null then do;
1654 call ioa_ (" No condition frame.");
1655 return;
1656 end;
1657 else call find_condition_info_ (faultsp, addr (condinfo), ec);
1658 if condinfo.mcptr = null () then
1659 return;
1660 call ioa_ ("^/MACHINE CONDITIONS AT ^p:^/", condinfo.mcptr);
1661
1662 call dump_machine_cond_ (addr (condinfo), faultsp, "user_output", 2);
1663 if mcptr ^= null then
1664 hreg_ptr = addrel (mcptr, 96);
1665 if hreg_ptr = null then do;
1666 call ioa_ ("History Registers are not available");
1667 return;
1668 end;
1669 else do;
1670 call ioa_ ("CPU HISTORY REGISTERS AT TIME OF FAULT");
1671 call hran_$hranl (hreg_ptr, null, long_hregs);
1672 end;
1673
1674 return;
1675 end display_mc_;
1676
1677 %page;
1678 DEACTIVATE: proc;
1679 dcl i fixed bin;
1680
1681
1682
1683
1684 do i = 1 to 14;
1685 if page_ptrs (i) ^= null () then
1686 if baseno (page_ptrs (i)) ^= "077777"b3 then
1687 call phcs_$deactivate (page_ptrs (i), code);
1688 end;
1689
1690
1691 return;
1692
1693 end DEACTIVATE;
1694
1695
1696
1697 end eis_tester;