1 " ***********************************************************
2 " * *
3 " * Copyright, C Honeywell Information Systems Inc., 1982 *
4 " * *
5 " ***********************************************************
6 %;
7 " ******************************************************
8 " * *
9 " * *
10 " * Copyright c 1972 by Massachusetts Institute of *
11 " * Technology and Honeywell Information Systems, Inc. *
12 " * *
13 " * *
14 " ******************************************************
15
16 " Operator Segment for pl/1
17 " Barry Wolman
18 " March, 1969
19 "
20 " Modified: 10 April, 1971 by BLW
21 " Modified: 25 April, 1971 by BLW to have entry operator in text section
22 " Modified: June, 1972 by RBS for followon
23 " Modified: July, 1973 by RBS to see if stac working
24 "
25 name pl1_operators
26 "
27 segdef operator_table
28 segdef pl1_operator_begin
29 segdef pl1_operators_end
30 segdef ext_entry
31 segdef int_entry
32 segdef ext_entry_desc
33 segdef desc_ext_entry
34 segdef int_entry_desc
35 segdef desc_int_entry
36 segdef val_entry
37 segdef val_entry_desc
38 segdef desc_val_entry
39 segdef call_out
40
41
42
43 include stack_header
44 include stack_frame
45 include mc
46 "
47 " Definitions of variables used by operators. Since all
48 " of the operators execute using the stack frame of the
49 " pl/1 program for their temporary storage, locations 32-61
50 " of the pl/1 stack frame are reserved for operator use.
51 "
52 equ pl1_code,1 code identifying pl/1 compiled prog
53 equ maxpr,71 max precision of double fixed
54 "
55 "
56 equ length,15 timer in SREG storage
57 equ count,15
58 equ bit_op,6
59 equ n,6
60 equ display_ptr,32
61 equ int_static_ptr,34
62 equ linkage_ptr,36
63 equ on_unit_mask,31
64 equ temp_pt,40
65 equ temp_aq,42
66 equ single_bit_temp,44
67 equ double_temp,46
68 equ temp_size,48
69 equ extend_size,49
70 equ lg1,50
71 equ str1,51
72 equ a1,52
73 equ rem1,53
74 equ xr2,53
75 equ a2,54
76 equ old_lg1,55
77 equ qmask,55
78 equ arg_list,56
79 equ save_regs,56
80 equ move_return,56
81 equ label_var,56
82 equ free_pt,56
83 equ save_x23,57
84 equ rpd_pt,58
85 equ free_amt,58
86 equ lv,60
87 equ pad_it,60
88 equ num,60
89 equ lg2,61
90 equ temp,62
91 equ str2,63
92 "
93 bool stba,5511
94 bool stbq,5521
95 bool stca,7511
96 bool stcq,7521
97 "
98 pl1_operator_begin:
99 null
100 "
101 " THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM PL/1 PROGRAMS BY MEANS OF
102 " ab|offset. FOR THIS REASON, PL1_OPERATORS MUST BE THE FIRST COMPONENT OF
103 " ANY BOUND SEGMENT IN WHICH IT APPEARS AND THE ORDER OF THE FOLLOWING
104 " INSTRUCTIONS MUST NOT BE CHANGED!
105 "
106 " shift table for 9 bit bytes
107 "
108 shift_9: vfd 18/0,18/0
109 vfd 18/9,18/0
110 vfd 18/18,18/0
111 vfd 18/27,18/0
112 "
113 " shift table for 6 bit bytes
114 "
115 shift_6: vfd 18/0,18/0
116 vfd 18/6,18/0
117 vfd 18/12,18/0
118 vfd 18/18,18/0
119 vfd 18/24,18/0
120 vfd 18/30,18/0
121 "
122 " store table from a, 9 bit
123 " OFFSET SIZE
124 "
125 store_a9: vfd o18/200000,o12/stba,o6/40 0 1
126 vfd o18/200000,o12/stba,o6/20 1
127 vfd o18/200000,o12/stba,o6/10 2
128 vfd o18/200000,o12/stba,o6/04 3
129 vfd o18/200000,o12/stba,o6/60 0 2
130 vfd o18/200000,o12/stba,o6/30 1
131 vfd o18/200000,o12/stba,o6/14 2
132 vfd o18/200000,o12/stba,o6/04 3
133 vfd o18/200000,o12/stba,o6/70 0 3
134 vfd o18/200000,o12/stba,o6/34 1
135 vfd o18/200000,o12/stba,o6/14 2
136 vfd o18/200000,o12/stba,o6/04 3
137 sta bp|0 0 4
138 vfd o18/200000,o12/stba,o6/34 1
139 vfd o18/200000,o12/stba,o6/14 2
140 vfd o18/200000,o12/stba,o6/04 3
141 sta bp|0 0 5
142 vfd o18/200000,o12/stba,o6/34 1
143 vfd o18/200000,o12/stba,o6/14 2
144 vfd o18/200000,o12/stba,o6/04 3
145 "
146 " store table from q, 9 bit
147 " OFFSET SIZE
148 "
149 store_q9: nop 0,dl 0 2
150 nop 0,dl 1
151 nop 0,dl 2
152 vfd o18/200001,o12/stbq,o6/40 3
153 nop 0,dl 0 3
154 nop 0,dl 1
155 vfd o18/200001,o12/stbq,o6/40 2
156 vfd o18/200001,o12/stbq,o6/60 3
157 nop 0,dl 0 4
158 vfd o18/200001,o12/stbq,o6/40 1
159 vfd o18/200001,o12/stbq,o6/60 2
160 vfd o18/200001,o12/stbq,o6/70 3
161 vfd o18/200001,o12/stbq,o6/40 0 5
162 vfd o18/200001,o12/stbq,o6/60 1
163 vfd o18/200001,o12/stbq,o6/70 2
164 stq bp|1 3
165 "
166 " store table from a, 6 bit
167 " OFFSET SIZE
168 "
169 store_a6: vfd o18/200000,o12/stca,o6/40 0 1
170 vfd o18/200000,o12/stca,o6/20 1
171 vfd o18/200000,o12/stca,o6/10 2
172 vfd o18/200000,o12/stca,o6/04 3
173 vfd o18/200000,o12/stca,o6/02 4
174 vfd o18/200000,o12/stca,o6/01 5
175 vfd o18/200000,o12/stca,o6/60 0 2
176 vfd o18/200000,o12/stca,o6/30 1
177 vfd o18/200000,o12/stca,o6/14 2
178 vfd o18/200000,o12/stca,o6/06 3
179 vfd o18/200000,o12/stca,o6/03 4
180 vfd o18/200000,o12/stca,o6/01 5
181 vfd o18/200000,o12/stca,o6/70 0 3
182 vfd o18/200000,o12/stca,o6/34 1
183 vfd o18/200000,o12/stca,o6/16 2
184 vfd o18/200000,o12/stca,o6/07 3
185 vfd o18/200000,o12/stca,o6/03 4
186 vfd o18/200000,o12/stca,o6/01 5
187 vfd o18/200000,o12/stca,o6/74 0 4
188 vfd o18/200000,o12/stca,o6/36 1
189 vfd o18/200000,o12/stca,o6/17 2
190 vfd o18/200000,o12/stca,o6/07 3
191 vfd o18/200000,o12/stca,o6/03 4
192 vfd o18/200000,o12/stca,o6/01 5
193 vfd o18/200000,o12/stca,o6/76 0 5
194 vfd o18/200000,o12/stca,o6/37 1
195 vfd o18/200000,o12/stca,o6/17 2
196 vfd o18/200000,o12/stca,o6/07 3
197 vfd o18/200000,o12/stca,o6/03 4
198 vfd o18/200000,o12/stca,o6/01 5
199 sta bp|0 0 6
200 vfd o18/200000,o12/stca,o6/37 1
201 vfd o18/200000,o12/stca,o6/17 2
202 vfd o18/200000,o12/stca,o6/07 3
203 vfd o18/200000,o12/stca,o6/03 4
204 vfd o18/200000,o12/stca,o6/01 5
205 sta bp|0 0 7
206 vfd o18/200000,o12/stca,o6/37 1
207 vfd o18/200000,o12/stca,o6/17 2
208 vfd o18/200000,o12/stca,o6/07 3
209 vfd o18/200000,o12/stca,o6/03 4
210 vfd o18/200000,o12/stca,o6/01 5
211 "
212 " store table from q, 6 bit
213 " OFFSET SIZE
214 "
215 store_q6: nop 0,dl 0 2
216 nop 0,dl 1
217 nop 0,dl 2
218 nop 0,dl 3
219 nop 0,dl 4
220 vfd o18/200001,o12/stcq,o6/40 5
221 nop 0,dl 0 3
222 nop 0,dl 1
223 nop 0,dl 2
224 nop 0,dl 3
225 vfd o18/200001,o12/stcq,o6/40 4
226 vfd o18/200001,o12/stcq,o6/60 5
227 nop 0,dl 0 4
228 nop 0,dl 1
229 nop 0,dl 2
230 vfd o18/200001,o12/stcq,o6/40 3
231 vfd o18/200001,o12/stcq,o6/60 4
232 vfd o18/200001,o12/stcq,o6/70 5
233 nop 0,dl 0 5
234 nop 0,dl 1
235 vfd o18/200001,o12/stcq,o6/40 2
236 vfd o18/200001,o12/stcq,o6/60 3
237 vfd o18/200001,o12/stcq,o6/70 4
238 vfd o18/200001,o12/stcq,o6/74 5
239 nop 0,dl 0 6
240 vfd o18/200001,o12/stcq,o6/40 1
241 vfd o18/200001,o12/stcq,o6/60 2
242 vfd o18/200001,o12/stcq,o6/70 3
243 vfd o18/200001,o12/stcq,o6/74 4
244 vfd o18/200001,o12/stcq,o6/76 5
245 vfd o18/200001,o12/stcq,o6/40 0 7
246 vfd o18/200001,o12/stcq,o6/60 1
247 vfd o18/200001,o12/stcq,o6/70 2
248 vfd o18/200001,o12/stcq,o6/74 3
249 vfd o18/200001,o12/stcq,o6/76 4
250 stq bp|1 5
251 "
252 " THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM PL/1 PROGRAMS BY MEANS OF
253 " ap|offset. FOR THIS REASON, THE ORDER OF THE FOLLOWING INSTRUCTIONS MUST
254 " NOT BE CHANGED.
255 "
256 even
257 operator_table:
258 bit_mask:
259 vfd 0/-1,72/0
260 vfd 1/-1,71/0
261 vfd 2/-1,70/0
262 vfd 3/-1,69/0
263 vfd 4/-1,68/0
264 vfd 5/-1,67/0
265 vfd 6/-1,66/0
266 vfd 7/-1,65/0
267 vfd 8/-1,64/0
268 vfd 9/-1,63/0
269 vfd 10/-1,62/0
270 vfd 11/-1,61/0
271 vfd 12/-1,60/0
272 vfd 13/-1,59/0
273 vfd 14/-1,58/0
274 vfd 15/-1,57/0
275 vfd 16/-1,56/0
276 vfd 17/-1,55/0
277 vfd 18/-1,54/0
278 vfd 19/-1,53/0
279 vfd 20/-1,52/0
280 vfd 21/-1,51/0
281 vfd 22/-1,50/0
282 vfd 23/-1,49/0
283 vfd 24/-1,48/0
284 vfd 25/-1,47/0
285 vfd 26/-1,46/0
286 vfd 27/-1,45/0
287 vfd 28/-1,44/0
288 vfd 29/-1,43/0
289 vfd 30/-1,42/0
290 vfd 31/-1,41/0
291 vfd 32/-1,40/0
292 vfd 33/-1,39/0
293 vfd 34/-1,38/0
294 vfd 35/-1,37/0
295 ones: vfd 36/-1,36/0
296 vfd 36/-1,1/-1,35/0
297 vfd 36/-1,2/-1,34/0
298 vfd 36/-1,3/-1,33/0
299 vfd 36/-1,4/-1,32/0
300 vfd 36/-1,5/-1,31/0
301 vfd 36/-1,6/-1,30/0
302 vfd 36/-1,7/-1,29/0
303 vfd 36/-1,8/-1,28/0
304 vfd 36/-1,9/-1,27/0
305 vfd 36/-1,10/-1,26/0
306 vfd 36/-1,11/-1,25/0
307 vfd 36/-1,12/-1,24/0
308 vfd 36/-1,13/-1,23/0
309 vfd 36/-1,14/-1,22/0
310 vfd 36/-1,15/-1,21/0
311 vfd 36/-1,16/-1,20/0
312 vfd 36/-1,17/-1,19/0
313 vfd 36/-1,18/-1,18/0
314 vfd 36/-1,19/-1,17/0
315 vfd 36/-1,20/-1,16/0
316 vfd 36/-1,21/-1,15/0
317 vfd 36/-1,22/-1,14/0
318 vfd 36/-1,23/-1,13/0
319 vfd 36/-1,24/-1,12/0
320 vfd 36/-1,25/-1,11/0
321 vfd 36/-1,26/-1,10/0
322 vfd 36/-1,27/-1,9/0
323 vfd 36/-1,28/-1,8/0
324 vfd 36/-1,29/-1,7/0
325 vfd 36/-1,30/-1,6/0
326 vfd 36/-1,31/-1,5/0
327 vfd 36/-1,32/-1,4/0
328 vfd 36/-1,33/-1,3/0
329 vfd 36/-1,34/-1,2/0
330 vfd 36/-1,35/-1,1/0
331 "
332 mask_bit:
333 vfd 0/0,36/-1,36/-1
334 vfd 1/0,35/-1,36/-1
335 vfd 2/0,34/-1,36/-1
336 vfd 3/0,33/-1,36/-1
337 vfd 4/0,32/-1,36/-1
338 vfd 5/0,31/-1,36/-1
339 vfd 6/0,30/-1,36/-1
340 vfd 7/0,29/-1,36/-1
341 vfd 8/0,28/-1,36/-1
342 vfd 9/0,27/-1,36/-1
343 vfd 10/0,26/-1,36/-1
344 vfd 11/0,25/-1,36/-1
345 vfd 12/0,24/-1,36/-1
346 vfd 13/0,23/-1,36/-1
347 vfd 14/0,22/-1,36/-1
348 vfd 15/0,21/-1,36/-1
349 vfd 16/0,20/-1,36/-1
350 vfd 17/0,19/-1,36/-1
351 vfd 18/0,18/-1,36/-1
352 vfd 19/0,17/-1,36/-1
353 vfd 20/0,16/-1,36/-1
354 vfd 21/0,15/-1,36/-1
355 vfd 22/0,14/-1,36/-1
356 vfd 23/0,13/-1,36/-1
357 vfd 24/0,12/-1,36/-1
358 vfd 25/0,11/-1,36/-1
359 vfd 26/0,10/-1,36/-1
360 vfd 27/0,9/-1,36/-1
361 vfd 28/0,8/-1,36/-1
362 vfd 29/0,7/-1,36/-1
363 vfd 30/0,6/-1,36/-1
364 vfd 31/0,5/-1,36/-1
365 vfd 32/0,4/-1,36/-1
366 vfd 33/0,3/-1,36/-1
367 vfd 34/0,2/-1,36/-1
368 vfd 35/0,1/-1,36/-1
369 vfd 36/0,36/-1
370 vfd 37/0,35/-1
371 vfd 38/0,34/-1
372 vfd 39/0,33/-1
373 vfd 40/0,32/-1
374 vfd 41/0,31/-1
375 vfd 42/0,30/-1
376 vfd 43/0,29/-1
377 vfd 44/0,28/-1
378 vfd 45/0,27/-1
379 vfd 46/0,26/-1
380 vfd 47/0,25/-1
381 vfd 48/0,24/-1
382 vfd 49/0,23/-1
383 vfd 50/0,22/-1
384 vfd 51/0,21/-1
385 vfd 52/0,20/-1
386 vfd 53/0,19/-1
387 vfd 54/0,18/-1
388 vfd 55/0,17/-1
389 vfd 56/0,16/-1
390 vfd 57/0,15/-1
391 vfd 58/0,14/-1
392 vfd 59/0,13/-1
393 vfd 60/0,12/-1
394 vfd 61/0,11/-1
395 vfd 62/0,10/-1
396 vfd 63/0,9/-1
397 vfd 64/0,8/-1
398 vfd 65/0,7/-1
399 vfd 66/0,6/-1
400 vfd 67/0,5/-1
401 vfd 68/0,4/-1
402 vfd 69/0,3/-1
403 vfd 70/0,2/-1
404 vfd 71/0,1/-1
405 "
406 blanks: oct 040040040040,040040040040
407 oct 000040040040,040040040040
408 oct 000000040040,040040040040
409 oct 000000000040,040040040040
410 oct 000000000000,040040040040
411 oct 000000000000,000040040040
412 oct 000000000000,000000040040
413 oct 000000000000,000000000040
414 "
415 ptr_mask: oct 077777000077,777777077077
416 "
417 " operator to convert single fixed to double fixed
418 "
419 even
420 fx1_to_fx2:
421 llr 36
422 lrs 36
423 "
424 " operators to convert fixed to float
425 "
426 odd
427 fx1_to_fl2:
428 xed fx1_to_fx2
429 "
430 even
431 fx2_to_fl2:
432 lde =71b25,du
433 fad =0.,du
434 tra lp|0
435 "
436 " operator to reset next stack pointer
437 " this operator is executed via an xed from object code.
438 "
439 even
440 reset_stack:
441 ldx0 sp|5 get new stack offset
442 xed xed_escape-*,ic set up next sp and stack end pointers
443 "
444 " operators to convert indicators into relations
445 "
446 r_l_a: tmi true
447 lda 0,dl
448 tra lp|0
449 "
450 r_g_s: tze 2,ic
451 trc true
452 lda 0,dl
453 tra lp|0
454 "
455 r_g_a: tze 2,ic
456 tpl true
457 lda 0,dl
458 tra lp|0
459 "
460 r_l_s: tnc true
461 lda 0,dl
462 tra lp|0
463 "
464 r_e_as: tze true
465 lda 0,dl
466 tra lp|0
467 "
468 r_ne_as: tnz true
469 lda 0,dl
470 tra lp|0
471 "
472 r_le_a: tmi true
473 tze true
474 lda 0,dl
475 tra lp|0
476 "
477 r_ge_s: trc true
478 lda 0,dl
479 tra lp|0
480 "
481 r_ge_a: tpl true
482 lda 0,dl
483 tra lp|0
484 "
485 r_le_s: tnc true
486 tze true
487 lda 0,dl
488 tra lp|0
489 "
490 true: lda =o400000,du
491 tra lp|0
492 "
493 " operator to set stack ptr to that of block N static
494 " levels above the current block. Entered with N in q.
495 " should not be called with N = 0 but will work anyway.
496 "
497 set_stack:
498 tsx0 display_chase get ptr to proper frame
499 eppsp bp|0 into sp
500 tra set_stack_extend-*,ic do three more instructions added later
501 " and since compiled code knows offsets in this area
502 " couldn't add the code inline
503 "
504 "
505 " tables for use by mod2_bit and mod4_bit operations
506 "
507 mod2_tab: dec 0,18
508 "
509 mod4_tab: dec 0,9,18,27
510 "
511 " transfer vector for operators not referenced directly
512 " by the pl/1 program. new operators may be added at the
513 " end of the list only.
514 "
515 op_vector:
516 tra alloc_char_temp 0
517 tra alloc_bit_temp 1
518 tra alloc_temp 2
519 tra realloc_char_temp 3
520 tra realloc_bit_temp 4
521 tra save_string 5
522 tra load_chars 6
523 tra load_bits 7
524 tra move_chars 8
525 tra move_chars_aligned 9
526 tra move_bits 10
527 tra move_bits_aligned 11
528 tra chars_move 12
529 tra chars_move_aligned 13
530 tra bits_move 14
531 tra bits_move_aligned 15
532 tra move_not_bits 16
533 tra move_not_bits_aligned 17
534 tra ext_and_1 18
535 tra ext_and_2 19
536 tra comp_bits 20
537 tra cpbs3 21
538 tra cpbs3_aligned 22
539 tra cpbs4 23
540 tra cpcs_ext1 24
541 tra cpcs_ext2 25
542 tra cpbs_ext1 26
543 tra cpbs_ext2 27
544 tra store_string 28
545 tra cat_realloc_chars 29
546 tra cat_realloc_bits 30
547 tra cp_chars 31
548 tra cp_chars_aligned 32
549 tra cp_bits 33
550 tra cp_bits_aligned 34
551 tra enter_begin_block 35
552 tra leave_begin_block 36
553 tra call_ent_var_desc 37
554 tra call_ent_var 38
555 tra call_ext_in_desc 39
556 tra call_ext_in 40
557 tra call_ext_out_desc 41
558 tra call_ext_out 42
559 tra call_int_this_desc 43
560 tra call_int_this 44
561 tra call_int_other_desc 45
562 tra call_int_other 46
563 tra begin_return_mac 47
564 tra return_mac 48
565 tra cat_move_chars 49
566 tra cat_move_chars_aligned 50
567 tra cat_move_bits 51
568 tra cat_move_bits_aligned 52
569 tra cat_chars 53
570 tra cat_chars_aligned 54
571 tra cat_bits 55
572 tra cat_bits_aligned 56
573 tra set_chars 57
574 tra set_chars_aligned 58
575 tra set_bits 59
576 tra set_bits_aligned 60
577 tra and_bits 61
578 tra and_bits_aligned 62
579 tra or_bits 63
580 tra or_bits_aligned 64
581 tra move_label_var 65
582 tra make_label_var 66
583 tra fl2_to_fx1 67
584 tra fl2_to_fx2 68
585 tra longbs_to_fx2 69
586 tra tra_ext_1 70
587 tra tra_ext_2 71
588 tra so_mac 72
589 tra longbs_to_bs18 73
590 tra stac_mac 74
591 tra sign_mac 75
592 tra bound_ck_signal 76
593 tra allot_based 77
594 tra free_based 78
595 tra copy_words 79
596 tra mpfx2 80
597 tra mpfx3 81
598 tra dvfx2 82 obsolete
599 tra dvfx3 83 obsolete
600 tra sr_check 84
601 tra chars_move_vt 85
602 tra chars_move_vta 86
603 tra bits_move_vt 87
604 tra bits_move_vta 88
605 tra mdfl1 89
606 tra mdfl2 90
607 tra mdfx1 91
608 tra mdfx2 92
609 tra mdfx3 93
610 tra mdfx4 94
611 tra move_dope 95
612 tra string_store 96
613 tra get_chars 97
614 tra get_bits 98
615 tra pad_chars 99
616 tra pad_bits 100
617 tra signal_op 101
618 tra enable_op 102
619 tra index_chars 103
620 tra index_chars_aligned 104
621 tra index_bits 105
622 tra index_bits_aligned 106
623 tra exor_bits 107
624 tra exor_bits_aligned 108
625 tra alloc_bit_temp_q 109
626 tra realloc_bit_temp_q 110
627 tra move_bits_q 111
628 tra move_bits_aligned_q 112
629 tra bits_move_q 113
630 tra bits_move_aligned_q 114
631 tra move_not_bits_q 115
632 tra move_not_bits_aligned_q 116
633 tra cpbs3_q 117
634 tra cpbs3_aligned_q 118
635 tra cat_realloc_bits_q 119
636 tra cp_bits_q 120
637 tra cp_bits_aligned_q 121
638 tra cat_move_bits_q 122
639 tra cat_move_bits_aligned_q 123
640 tra cat_bits_q 124
641 tra cat_bits_aligned_q 125
642 tra set_bits_q 126
643 tra set_bits_aligned_q 127
644 tra and_bits_q 128
645 tra and_bits_aligned_q 129
646 tra or_bits_q 130
647 tra or_bits_aligned_q 131
648 tra bits_move_vt_q 132
649 tra bits_move_vta_q 133
650 tra index_bits_q 134
651 tra index_bits_aligned_q 135
652 tra exor_bits_q 136
653 tra exor_bits_aligned_q 137
654 tra get_bits_q 138
655 tra io_signal 139
656 tra ix_cs_1 140
657 tra ix_cs_1_aligned 141
658 tra shorten_stack 142
659 "
660 " The following section is not referenced directly by
661 " the compiled pl/1 program and may be changed as
662 " desired.
663 "
664 " N.B. ANY BIT OPERATOR WHOSE NAME ENDS IN "_q" TAKES THE SIZE IN
665 " THE q. ALL OTHER BIT OPERATORS TAKE THE SIZE IN X6.
666 "
667 " allocation operators
668 " these are entered with the size in x6 or q
669 " The char and bit allocation operators reserve two extra words
670 " the temporary is stored in the second of these.
671 "
672 alloc_char_temp:
673 eaq 0,6 number of chars to qu
674 qrl 18 and then into ql
675 mpy 9,dl form number of bits
676 tra alloc_bit_temp_q join common
677 "
678 alloc_bit_temp:
679 eaq 0,6 number of bits to qu
680 qrl 18 and then into ql
681 "
682 alloc_bit_temp_q:
683 stq sp|lg1 set length of temp
684 div 36,dl form number of words
685 qls 18 in qu
686 stq sp|str1 save
687 sta sp|rem1 save number of bits in last word
688 stz sp|a1 temp will be an aligned string
689 adq 2,du allow for header
690 cmpa 0,dl update word count
691 tze 2,ic if remainder is non-zero
692 adq 1,du ..
693 tsx0 alloc allocate N+2 words
694 eppbp bp|2 skip over the extra words make temp even
695 stz bp|-1 save size of temp just before temp
696 sxl6 bp|-1 ..
697 abt: spribp sp|temp_pt save pointer to temp
698 tra lp|0 and return to pl/1 program
699 "
700 alloc_temp:
701 eaq 0,6 number of words to qu
702 eax0 abt alloc N words and go save ptr
703 " fall into alloc coding
704 "
705 " routine to allocate N words at end of stack.
706 " entered with N in qu.
707 "
708 alloc: stq sp|temp_size save number of words
709 eppbp sb|stack_header.stack_end_ptr,* get ptr to extension
710 adq =15,du make size a multiple of 16
711 anq =o777760,du ..
712 stq sp|extend_size
713 asq sb|stack_header.stack_end_ptr+1 reset stack end ptr
714 asq sp|stack_frame.next_sp+1 reset next ptr
715 tra 0,0 return to pl1 program
716 "
717 " reallocation operators
718 " these are entered with the size in x6 or q
719 " allowance is made for the two words at the head of the string
720 "
721 cat_realloc_bits:
722 eaq 0,6
723 qrl 18 get size in q
724 "
725 cat_realloc_bits_q:
726 lda sp|str1 set for following concat
727 sta sp|str2 ..
728 lda sp|rem1 ..
729 sta sp|a2 ..
730 tra realloc-1 and go reallocate space
731 "
732 realloc_bit_temp:
733 eaq 0,6 number of bits to qu
734 qrl 18 and then into ql
735 "
736 realloc_bit_temp_q:
737 tsx0 realloc call realloc subroutine
738 stz sp|pad_it set padding word
739 tra zero_it go clear temp extension
740 "
741 cat_realloc_chars:
742 ldq sp|str1 set for following concat
743 stq sp|str2 ..
744 ldq sp|rem1 ..
745 stq sp|a2 and join realloc_char_temp
746 "
747 realloc_char_temp:
748 eaq 0,6 number of chars to qu
749 qrl 18 and then into ql
750 mpy 9,dl form number of bits
751 eax0 abt+1 fall into realloc then exit
752 "
753 realloc: ldx1 sp|temp_size save end position of current temp
754 stq sp|lg1 save bit size of temp
755 div 36,dl calculate number of whole words
756 qls 18 in qu
757 stq sp|str1 ..
758 sta sp|rem1 save number of bits in last word
759 stz sp|a1 the temp is aligned
760 adq 2,du allow for two extra words
761 cmpa 0,dl update word count
762 tze 2,ic if remainder is non-zero
763 adq 1,du ..
764 realloc_1:
765 eppbp sp|temp_pt,* get ptr to temp
766 sxl6 bp|-1 set new size left side should be zero
767 stq sp|temp_size set new size of temp
768 sbq sp|extend_size subtract size of extension
769 tmi 0,0 return if no extension needed
770 adq =15,du make increment a multiple of 16
771 anq =o777760,du ..
772 asq sp|extend_size update extension size
773 asq sb|stack_header.stack_end_ptr+1 reset stack end ptr
774 asq sp|stack_frame.next_sp+1 reset next ptr
775 tra 0,0 return to caller
776 "
777 " this operator shortens the stack frame to its original length
778 "
779 shorten_stack:
780 ldx0 sp|5
781 stx0 sb|stack_header.stack_end_ptr+1
782 stx0 sp|stack_frame.next_sp+1 update next sp
783 tra lp|0
784 "
785 " code added here to handle escape out of xed sequence at reset_stack
786 "
787 even
788 xed_escape:
789 stx0 sb|stack_header.stack_end_ptr+1 update end pointer
790 stx0 sp|stack_frame.next_sp+1 update next pointer too
791 "
792 " code added here to handle 2 extra instructions needed at set_stack
793 "
794 set_stack_extend:
795 eppbp sp|stack_frame.next_sp,* set up stack end pointer correctly
796 spribp sb|stack_header.stack_end_ptr ..
797 tra lp|0 and return to pl1 program
798 "
799 " operator to save the string in the aq in stack so it is
800 " accessable to long string operators. entered with bit_size
801 " in x6 and string in aq
802 "
803 save_string:
804 staq sp|double_temp save the string
805 eppbp sp|double_temp load ptr to string, fall into set_bits_aligned
806 "
807 " operators to save info about a string in the stack.
808 " entered with pointer in bp, unit size in x6, and offset in x7
809 "
810 set_bits_aligned:
811 eaq 0,6 bit size to qu
812 qrl 18 and then into ql
813 "
814 set_bits_aligned_q:
815 stz sp|a1 offset is zero
816 "
817 sba: spribp sp|temp_pt save pointer to string
818 stq sp|lg1 save bit size
819 div 36,dl compute number of whole words
820 qls 18 in qu
821 stq sp|str1 ..
822 sta sp|rem1 save number of bits in last word
823 tra lp|0 return to pl/1 program
824 "
825 set_bits:
826 eaq 0,6
827 qrl 18 bit size to q
828 "
829 set_bits_q:
830 eaa 0,7 offset to qu
831 sta sp|a1 save offset
832 tra sba join common section
833 "
834 set_chars_aligned:
835 stz sp|a1 offset is zero
836 eaq 0,6 char size to qu
837 qrl 18 and then into ql
838 mpy 9,dl convert to bits
839 tra sba join common section
840 "
841 set_chars:
842 eaq 0,7 offset to qu
843 stq sp|a1 save offset
844 tra set_chars_aligned+1 join common section
845 "
846 " operator to store a string when size+offset > 72
847 " entered with string to be stored in aq, bit_size+offset-72 in x6,
848 " offset in x7, and ptr to destination in bp
849 "
850 store_string:
851 stq sp|temp save right part of string
852 lrl 0,7 shift to proper position
853 era bp|0 insert in first two words
854 stq bp|1 of destination
855 ana mask_bit_one,7 mask has no trailing zeros
856 ersa bp|0
857 lda sp|temp get right part of string
858 ldq 0,dl clear q register
859 lrl 0,7 shift into position
860 erq bp|2 insert into third word
861 anq bit_mask_one,6 mask has no leading zeros
862 ersq bp|2
863 tra lp|0 return to pl1 program
864 "
865 " operator to store a string with an adjustable bit offset.
866 " entered with bit_size in x6, bit_offset in x7, and pointer
867 " to destination in bp.
868 "
869 string_store:
870 eax1 0,7 offset to x1
871 cmpx1 36,du is it greater than 36?
872 tmi 3,ic no
873 eppbp bp|1 yes, adjust destination ptr
874 eax1 -36,1 and correct offset
875 eax0 0,6 size to x0
876 stx1 sp|temp so we can form
877 adx0 sp|temp size+offset
878 cmpx0 73,du is this difficult case
879 trc ss_3 > 72 bits causes problems
880 lrl 0,1 no, shift string to position
881 era bp|0 combine first word of destination
882 ana mask_bit_one,1 mask has no trailing zeros
883 cmpx0 37,du is this 1 or 2 word case
884 trc ss_2 ..
885 ss_1: ana bit_mask_one,0 1 word only, trim to size
886 ersa bp|0 insert in destination
887 tra lp|0 and return to pl1 program
888 ss_2: erq bp|1 2 words, combine second word
889 anq bit_mask_one-36,0 trim to size
890 ersa bp|0 insert in destination
891 ersq bp|1 ..
892 tra lp|0 and return
893 ss_3: stq sp|temp 3 word case, save right part
894 lrl 0,1 shift to position
895 era bp|0 insert in first two words
896 stq bp|1 ..
897 ana mask_bit_one,1 ..
898 ersa bp|0 ..
899 lda sp|temp get right part
900 ldq 0,dl clear q
901 lrl 0,1 shift to position
902 erq bp|2 insert in third word
903 anq bit_mask_one-72,0 ..
904 ersq bp|2 ..
905 tra lp|0 return to caller
906 "
907 " operator to return in aq the first 72 bits of an adjustable char
908 " string. if length is less than 72 bits, string is padded.
909 " entered with char_size in x6, bit_offset in x7, and pointer in bp.
910 "
911 get_chars:
912 eaq 0,6 number of chars to qu
913 qrl 18 and then into ql
914 mpy 9,dl form number of bits
915 stq sp|temp+1 save so we
916 stz sp|temp save offset in rhs
917 sxl7 sp|temp
918 adq sp|temp then form offset+bit_size
919 lda sp|temp+1 then get
920 als 1 2*bit_size
921 eax1 0,al into x1
922 cmpq 73,dl is this hard case
923 trc gc_3
924 lda bp|0 easy, get first word
925 cmpq 37,dl is there another word
926 tnc 2,ic
927 ldq bp|1 yes, so load it
928 lls 0,7 shift to position
929 gc_1: eraq blanks pad with blanks
930 anaq bit_mask,1
931 eraq blanks
932 tra lp|0 and return to pl/1 program
933 gc_3: lda bp|1 get
934 ldq bp|2 second word
935 lls 0,7 into position
936 sta sp|temp and save
937 lda bp|0 get first
938 ldq bp|1 word
939 lls 0,7 into position
940 ldq sp|temp get back second word
941 lxl0 sp|temp+1 get bit_size
942 cmpx0 72,du is string 8 chars or longer
943 trc lp|0 yes, return to caller
944 tra gc_1 no, go save
945 "
946 " operators to load a string with adjustable offset. entered with
947 " bit_size in q, offset in x7 and ptr to string in bp. Note: these
948 " operators are actually the same as get_bits which follows.
949 "
950 load_chars:
951 load_bits:
952 "
953 " get_bits is same as get_bits_q execpt size is in x6
954 "
955 get_bits:
956 eaq 06 get size into qu
957 qrl 18 and then into ql
958 "
959 " operator to return in aq the first 72 bits of an adjustable bit
960 " string. if length is less than 72 bits string is padded.
961 " entered with bit_size in q bit_offset in x7 and pointer in bp.
962 "
963 get_bits_q:
964 stq sp|temp+1 save size
965 stz sp|temp save offset in rhs
966 sxl7 sp|temp
967 adq sp|temp form offset+size
968 cmpq 73dl is this hard case
969 trc gb_3
970 lda sp|temp+1 get back size
971 als 1 times 2
972 eax1 0al and thence of x1
973 lda bp|0 load first word
974 cmpq 37dl is there a second
975 tnc 2ic
976 ldq bp|1 yes so load it
977 lls 07 shift to position
978 anaq bit_mask1 apply mask
979 tra lp|0 return to pl/1 program
980 gb_3: lda bp|1 get second
981 ldq bp|2 word
982 lls 07 into position
983 sta sp|temp save
984 lda bp|0 get first
985 ldq bp|1 word
986 lls 07 into position
987 ldq sp|temp get second part
988 lxl0 sp|temp+1 get bit size
989 cmpx0 72du is string 72 bits or longer
990 trc lp|0 yes return to caller
991 anq bit_mask_one-360 apply mask
992 tra lp|0 return to pl1 program
993 "
994 " operator to pad the char string temporary to 8 chars.
995 "
996 pad_chars:
997 ldq sp|lg1 get bit length of temp
998 cmpq 73dl is it already long enough
999 trc lp|0 yes return
1000 adq sp|lg1 no form 2*bit_length
1001 eax0 0ql and place in index reg
1002 ldaq blanks get blanks
1003 eraq sp|temp_pt* insert into end of temp
1004 anaq mask_bit0
1005 eraq sp|temp_pt*
1006 staq sp|temp_pt* replace padded string
1007 tra lp|0 and return to pl/1 program
1008 "
1009 " operator to pad the bit string temporary to 72 bits.
1010 "
1011 pad_bits:
1012 ldq sp|lg1 get bit length of temp
1013 cmpq 73dl is it already long enough
1014 trc lp|0 yes return
1015 adq sp|lg1 no form 2*bit_length
1016 eax0 0ql and place in index reg
1017 ldaq sp|temp_pt* mask string
1018 anaq bit_mask0
1019 staq sp|temp_pt* replace padded string
1020 tra lp|0 and return to pl/1 program
1021 "
1022 " The operators which follow are the same as their similarly
1023 " named counterparts below except the size comes in the q.
1024 "
1025 and_bits_q:
1026 lda ana_op
1027 tra move_bits_q+1
1028 "
1029 or_bits_q:
1030 lda 1dl
1031 sta sp|pad_it
1032 lda ora_op
1033 tra log
1034 "
1035 exor_bits_q:
1036 lda 1dl
1037 sta sp|pad_it
1038 lda era_op
1039 tra log
1040 "
1041 cat_move_bits_q:
1042 lda 1dl
1043 sta sp|pad_it
1044 lda nop_op
1045 tra log
1046 "
1047 move_not_bits_q:
1048 lda 1dl
1049 sta sp|pad_it
1050 lda not_op
1051 tra log
1052 "
1053 move_bits_q:
1054 lda nop_op
1055 stz sp|pad_it
1056 tra log
1057 "
1058 " operator to AND an unaligned string into the aligned string
1059 " temporary pointed at by sp|temp_pt. the string being ANDED
1060 " is guaranteed to be no bigger than the space in the stack.
1061 " entered with bit_size in x6 bit_offset in x7 and pointer
1062 " to source in bp.
1063 "
1064 and_bits:
1065 lda ana_op pickup logical function to do
1066 tra logical join common section
1067 "
1068 " operator to OR an unaligned string into the aligned string
1069 " temporary pointed at by sp|temp_pt. the string being ORED
1070 " is guaranteed to be no bigger and the space in the stack.
1071 " entered with bit_size in x6 bit_offset in x7 and pointer
1072 " to source in bp.
1073 "
1074 or_bits:
1075 lda ora_op pickup logical function to do
1076 ldq 1dl set switch for no padding
1077 stq sp|pad_it ..
1078 tra logical+1 join common section
1079 "
1080 " operator to EXCLUSIVE OR an unaligned string into the aligned string
1081 " temporary pointed at by sp|temp_pt. the string being EXORed
1082 " is guaranteed to be no bigger than the space in the stack.
1083 " entered with bit_size in x6 bit_offset in x7 and pointer
1084 " to source in bp.
1085 "
1086 exor_bits:
1087 lda era_op pickup logial function to do
1088 tra or_bits+1 and treat like OR case
1089 "
1090 " operator to MOVE an unaligned string into the aligned string
1091 " temporary pointed at by sp|temp_pt. the string being MOVED
1092 " is guaranteed to be no bigger than the space in the stack.
1093 " since this operator is always followed by concatenation no
1094 " padding is done. entered with bit_size in x6 bit_offset in x7
1095 " and pointer to source in bp
1096 "
1097 cat_move_bits:
1098 lda nop_op pickup logical function
1099 tra or_bits+1 join common section
1100 "
1101 " operator to MOVE the COMPLEMENT of an unaligned string into
1102 " the aligned string temporary pointed at by sp|temp_pt. the string
1103 " being moved is guaranteed to be the same size as the
1104 " destination. entered with bit_size in x6 bit_offset in x7 and
1105 " pointer to source in bp.
1106 "
1107 move_not_bits:
1108 lda not_op pickup logical function to do
1109 tra or_bits+1 join common section
1110 "
1111 " operator to MOVE an unaligned string into the aligned string
1112 " temporary pointed at by sp|temp_pt. the string being MOVED
1113 " is guaranteed to be no bigger than the size of the destination.
1114 " entered with bit_size in x6 bit_offset in x7 and pointer
1115 " to source in bp.
1116 "
1117 move_bits:
1118 lda nop_op pickup logical function to do
1119 "
1120 logical: stz sp|pad_it set switch for padding
1121 eaq 06 bit_size to qu
1122 qrl 18 and then into ql
1123 log: sta sp|bit_op set operation to perform
1124 stq sp|length save for concatenation operator
1125 div 36dl get number of whole words in string
1126 qls 18 in qu
1127 stq sp|str2 save number of whole words
1128 sta sp|a2 save number of bits in last word
1129 eax1 0 initialize loop
1130 eppap sp|temp_pt* ..
1131 cmpx7 36du adjust if offset > 36 bits
1132 tmi 3ic
1133 sbx7 36du
1134 eawpbp bp|1
1135 "
1136 bit_loop:
1137 cmpx1 sp|str2 are we done with whole word part
1138 trc bit_done yes go check last part
1139 lda bp|01 get words from string
1140 ldq bp|11 ..
1141 lls 07 shift to proper position
1142 xec sp|bit_op perform logical function
1143 sta ap|01 and store word
1144 eax1 11 update counter
1145 tra bit_loop do next word
1146 bit_done: lcq sp|a2 is there any remainer in last word
1147 tze bit_fill no fill rest of temporary
1148 eax0 36ql form 36-number of bits in last
1149 lda bp|01 get last incomplete word
1150 ldq bp|11 ..
1151 lls 07 into position
1152 ars 00 shift out garbage
1153 ldq sp|pad_it get padding word
1154 lls 00 shift back padded word
1155 xec sp|bit_op perform logical function
1156 sta ap|01 and store word
1157 eax1 11 update counter
1158 bit_fill:
1159 eppbp ap|0 get pointer to temp
1160 eppap operator_table restore ap setting
1161 ldq sp|pad_it get padding word
1162 cmpq 1dl should we pad rest of temp
1163 tze lp|0 no we are done
1164 tra zero_it yes go do it
1165 "
1166 " logical functions...
1167 "
1168 nop_op: nop 0du move
1169 ana_op: ana ap|01 and
1170 ora_op: ora ap|01 or
1171 era_op: era ap|01 exclusive or
1172 "
1173 " operator to MOVE an unaligned string into the aligned string
1174 " temporary pointed at by sp|temp_pt. the string being MOVED
1175 " is guaranteed to be nor bigger than the space in the stack.
1176 " if this is cat_move_chars no padding will be done since
1177 " operator is always followed by concat. entered with chars in x6
1178 " bit_offset in x7 and pointer to source in bp.
1179 "
1180 move_chars:
1181 lda blanks get padding word
1182 tra cat_move_chars+1 join common section
1183 "
1184 cat_move_chars:
1185 lda 1dl set for no padding
1186 sta sp|pad_it save padding word
1187 eaq 06 number of chars to qu
1188 qrl 18 and then into ql
1189 mpy 9dl convert to bits
1190 lda nop_op get move operator
1191 tra log join common section
1192 "
1193 " operator to AND a single length bit string into the string
1194 " temporary pointed at by sp|temp_pt. words 123... of the
1195 " temporary are cleared.
1196 "
1197 ext_and_1:
1198 ldq 0dl clear q and join ext_and_2
1199 "
1200 " operator to AND a double length bit string into the string
1201 " temporary pointed at by sp|temp_pt. words 23... of the
1202 " temporary are cleared.
1203 "
1204 ext_and_2:
1205 eppbp sp|temp_pt* get ptr to string
1206 ansa bp|0 AND in the string
1207 ansq bp|1 ..
1208 eax1 2 clear starting at word 2
1209 stz sp|pad_it ..
1210 tra zero_it ..
1211 "
1212 " operator to complement the bit string temporary pointed
1213 " at by sp|temp_pt
1214 "
1215 comp_bits:
1216 eppbp sp|temp_pt* get pointer to source
1217 ldx1 sp|str1 get number of whole words
1218 lxl0 sp|rem1 and number of bits in last word
1219 comp: eppap sp|temp_pt* get pointer to destination
1220 tze comp_loop+1 skip if no partial word at end
1221 lda bp|01 get last partial word
1222 not_op: era ones complement it
1223 ana bit_mask_one0 mask out tail end
1224 comp_loop:
1225 sta ap|01 deposit complemented word
1226 eax1 -11 count down
1227 tmi cb_done+1 return if last word done
1228 lda bp|01 get previous word
1229 era ones complement it
1230 tra comp_loop and loop
1231 "
1232 " operator to MOVE the COMPLEMENT of an aligned string into
1233 " the aligned string temp pointed at by sp|temp_pt. entered
1234 " with bit_size in x6 or q and pointer to source in bp.
1235 "
1236 move_not_bits_aligned:
1237 eaq 06 number of bits to qu
1238 qrl 18 and then into ql
1239 "
1240 move_not_bits_aligned_q:
1241 div 36dl get number of whole words
1242 eax1 0ql into xr1
1243 eax0 0al and number bits in last into xr0
1244 tra comp join common section
1245 "
1246 " routine to execute a RPD loop based on MOVE by Noel I. Morris.
1247 " at entry:
1248 " sp|rpd_pt points at operation to perform
1249 " ap points at destination
1250 " bp points at source
1251 " qu holds number of words to process
1252 " x0 holds return point
1253 " at exit:
1254 " ap|01 points at next word of destination
1255 " bp|02 points at next word of source
1256 "
1257 bool rpd5602 RPD instruction
1258 bool rpd_bits001400 bits for RPD instruction AB
1259 "
1260 rpd_op: eax1 0 initialize counters
1261 eax2 0 ..
1262 lda 0dl clear a
1263 eaq 0qu clear right side of q
1264 lls 10 get num 256 word blocks in al rem.ls.10 in qu
1265 qls 0 set indicators from q
1266 tnz 3ic if even multiple of 256
1267 sbla 1dl count down number of blocks
1268 tmi 00 and refuse to move zero words
1269 stx0 sp|temp save return point
1270 eax0 rpd_bitsqu set up for remainder block
1271 rpd_loop: tra sp|rpd_pt* execute the RPD function
1272 sbla 1dl any more blocks to do
1273 tpl rpd_loop if so repeat until done
1274 ldx0 sp|temp restore return
1275 tra 00 and go back
1276 "
1277 odd
1278 rpd_copy: vfd 18/012/rpd6/1 RPD
1279 ldq bp|02 to move a block
1280 stq ap|01 ..
1281 tra rpd_loop+1
1282 odd
1283 rpd_or: vfd 18/012/rpd6/1 RPD
1284 ldq bp|02 to or a block
1285 orsq ap|01 into destination
1286 tra rpd_loop+1
1287 odd
1288 rpd_and: vfd 18/012/rpd6/1 RPD
1289 ldq bp|02 to and a block
1290 ansq ap|01 into destination
1291 tra rpd_loop+1
1292 odd
1293 rpd_exor: vfd 18/012/rpd6/1 RPD
1294 ldq bp|02 to exclusive or a block
1295 ersq ap|01 into destination
1296 tra rpd_loop+1
1297 "
1298 " routine to zero rest of string temp
1299 " this routine returns directly to pl/1 program
1300 " at entry:
1301 " bp|01 points at first word to be cleared
1302 " sp|temp_size holds total size of temporary
1303 "
1304 bool rpt5202 RPT instruction
1305 bool rpt_bits0 bits for RPT instruction
1306 "
1307 zero_it: eaa 01 current position to au
1308 neg 0 negate so we subtract
1309 ada sp|temp_size get number of words left to zero
1310 tze lp|0 return if zero
1311 tmi lp|0 or negative
1312 lrs 36 shift number into q
1313 lls 10 get number of 256 word blocks in al and remainder in qu
1314 qls 0 set indicators from q
1315 tnz 2ic update 256 block count
1316 sbla 1dl if no remainder
1317 eax0 0qu init RPT loop
1318 stx3 sp|save_regs save x3 just in case it is needed
1319 qrl 10 right justify initial word cnt in qu
1320 eax3 0qu init incrementer index
1321 ldq sp|pad_it get padding word
1322 z_loop: vfd 18/012/rpt6/1 RPT instruction
1323 stq bp|01 pad storage
1324 eax1 03 update x1 in case not done yet
1325 eax3 2561 update incrementer index too
1326 sbla 1du count down number of blocks
1327 tpl z_loop continue if more
1328 ldx3 sp|save_regs refetch x3
1329 tra lp|0 return to pl/1 program
1330 "
1331 " The operators which follow are the same as their similarly
1332 " named counterparts below except the size comes in the q.
1333 "
1334 and_bits_aligned_q:
1335 eppap rpd_and
1336 tra move_bits_aligned_q+1
1337 "
1338 or_bits_aligned_q:
1339 eppap rpd_or
1340 lda 1dl
1341 sta sp|pad_it
1342 tra baj
1343 "
1344 exor_bits_aligned_q:
1345 eppap rpd_exor
1346 tra or_bits_aligned_q+1
1347 "
1348 cat_move_bits_aligned_q:
1349 eppap rpd_copy
1350 tra or_bits_aligned_q+1
1351 "
1352 move_bits_aligned_q:
1353 eppap rpd_copy
1354 stz sp|pad_it
1355 tra baj
1356 "
1357 " operator to move an aligned char string into the aligned
1358 " string temporary pointed at by sp|temp_pt. if this is
1359 " cat move no padding will be done since concat always follows.
1360 " entered with char_size in x6 and pointer to source
1361 " in bp.
1362 "
1363 move_chars_aligned:
1364 lda blanks get padding word
1365 tra cat_move_chars_aligned+1
1366 "
1367 cat_move_chars_aligned:
1368 lda 1dl set for no padding
1369 sta sp|pad_it ..
1370 eaq 06 number of chars to qu
1371 qrl 18 and then into ql
1372 mpy 9dl convert to bits
1373 eppap rpd_copy set copy loop
1374 tra baj join common section
1375 "
1376 " operator to AND an aligned string into the aligned string
1377 " temporary pointed at by sp|temp_pt. the string being ANDED
1378 " is guaranteed to be no bigger than the space in the stack.
1379 " entered with bit_size in x6 and pointer to source in bp.
1380 "
1381 and_bits_aligned:
1382 eppap rpd_and get ptr to function to do
1383 tra move_bits_aligned+1 join common section
1384 "
1385 " operator to OR an aligned string into the aligned string
1386 " temporary pointed at by sp|temp_pt. the string being ORED
1387 " is guaranteed to be no bigger than the space in the stack.
1388 " entered with bit_size in x6 and pointer to source in bp.
1389 "
1390 or_bits_aligned:
1391 eppap rpd_or get ptr to function to do
1392 lda 1dl set for no padding
1393 tra ba_join join common section
1394 "
1395 " operator to EXCLUSIVE OR an aligned string into the aligned string
1396 " temporary pointed at by sp|temp_pt. the string being EXORed
1397 " is guaranteed to be no bigger than the space in the stack.
1398 " entered with bit_size in x6 and pointer to source in bp.
1399 "
1400 exor_bits_aligned:
1401 eppap rpd_exor get ptr to function to do
1402 tra or_bits_aligned+1 then treat like OR case
1403 "
1404 " operator to MOVE an aligned string into the aligned string
1405 " temporary pointed at by sp|temp_pt. the string being MOVED
1406 " is guaranteed to be no bigger than the string in the stack.
1407 " since this operator is always followed by concatenation no
1408 " padding is done. entered with bit_size in x6 and pointer to
1409 " source in bp.
1410 "
1411 cat_move_bits_aligned:
1412 eppap rpd_copy get ptr to function to do
1413 tra or_bits_aligned+1 join common section
1414 "
1415 " operator to MOVE an aligned string into the aligned string
1416 " temporary pointed at by sp|temp_pt. the string being MOVED
1417 " is guaranteed to be no bigger than the string in the stack.
1418 " entered with bit_size in x6 and pointer to source in bp.
1419 "
1420 move_bits_aligned:
1421 eppap rpd_copy get ptr to function to do
1422 lda 0dl set for padding of string
1423 "
1424 ba_join: sta sp|pad_it save padding word
1425 eaq 06 number of bits to qu
1426 qrl 18 and then into ql
1427 baj: spriap sp|rpd_pt set RPD function
1428 stx2 sp|save_x23 save x2 for user
1429 eppap sp|temp_pt* get pointer to destination
1430 stq sp|length save for concatenation
1431 div 36dl get number of whole words
1432 qls 18 in qu
1433 stq sp|str2 save number of words
1434 sta sp|a2 save number of bits in last word
1435 tsx0 rpd_op operate on whole word part
1436 lxl0 sp|a2 are there any bits in last word
1437 tze ba_fill skip if none
1438 ldq bp|02 get last word of source
1439 lls 00 shift out good bits
1440 ldq sp|pad_it get padding word
1441 lrl 00 shift back good bits
1442 eaa 2 execute function
1443 xec sp|rpd_pt*au on last word
1444 eax1 11 update pointer to destination
1445 ba_fill: ldx2 sp|save_x23 restore x2 for user
1446 tra bit_fill go check padding
1447 "
1448 " operators to move unaligned bit string_1 into unaligned bit
1449 " string_2. These operators perform the same functions as
1450 " bits_move and bits_move_aligned except the size comes in
1451 " the q register. This lets us move an entire segment.
1452 "
1453 bits_move_vt_q:
1454 stq bp|-1 store size of string
1455 "
1456 bits_move_q:
1457 stz sp|a2 save offset
1458 sxl7 sp|a2 ..
1459 tra bits_move_aligned_q+1
1460 "
1461 bits_move_vta_q:
1462 stq bp|-1 store size of string
1463 "
1464 bits_move_aligned_q:
1465 stz sp|a2 zero offset
1466 cmpq 0dl return if string 2
1467 tze lp|0 return if string 2 zero length
1468 tra cb_move-1 join common section
1469 "
1470 " operator to move unaligned string_1 into unaligned string_2
1471 " based on procedure MOVSTR by Ruth Weiss.
1472 "
1473 " string_1 is specified by the variables temp_pt lg1 and a1
1474 " which were stored by a previous operator. entered with unit
1475 " size of string_2 in x6 bit_offset in x7 and pointer in bp.
1476 "
1477 chars_move_vt:
1478 stz bp|-1 store size of string
1479 sxl6 bp|-1
1480 "
1481 chars_move:
1482 stz sp|a2 save offset
1483 sxl7 sp|a2 in rhs
1484 tra chars_move_aligned+1
1485 "
1486 chars_move_vta:
1487 stz bp|-1 store size of string
1488 sxl6 bp|-1 ..
1489 "
1490 chars_move_aligned:
1491 stz sp|a2 zero offset
1492 eaq 06 number of chars to qu
1493 tze lp|0 exit if string 2 zero length
1494 qrl 18 into ql
1495 mpy 9dl convert to bits in ql
1496 lda blanks get padding word
1497 tra cb_move join common section
1498 "
1499 bits_move_vt:
1500 stz bp|-1 store size of string
1501 sxl6 bp|-1 ..
1502 "
1503 bits_move:
1504 stz sp|a2 save offset
1505 sxl7 sp|a2 in rhs
1506 tra bits_move_aligned+1
1507 "
1508 bits_move_vta:
1509 stz bp|-1 store size of string
1510 sxl6 bp|-1 ..
1511 "
1512 bits_move_aligned:
1513 stz sp|a2 zero offset
1514 eaq 06 number of bits to qu
1515 tze lp|0 exit if string 2 zero length
1516 qrl 18 shift to ql
1517 lda 0dl get padding word
1518 "
1519 cb_move: sreg sp|save_regs save regs including padding word and lg2
1520 cmpq sp|lg1 is lg2 > lg1
1521 tnc 2ic no
1522 ldq sp|lg1 yes get lg1
1523 eppap sp|temp_pt* get pointer to source
1524 tsx0 move_it call string mover
1525 cb_done: lreg sp|save_regs restore registers
1526 eppap operator_table
1527 tra lp|0
1528 "
1529 " operators to perform concatenation. this is done by moving
1530 " the second string into the stack just after the first string.
1531 " entered with unit size of suffix string in x6 bit_offset in x7
1532 " if unaligned and pointer in bp
1533 "
1534 cat_chars:
1535 eaa 07 save offset
1536 tra cat_chars_aligned+1
1537 "
1538 cat_chars_aligned:
1539 lda 0dl zero offset
1540 eaq 06 get number of chars
1541 tze cat_done return if none
1542 sta sp|a1 save source offset
1543 qrl 18 shift char count to ql
1544 mpy 9dl convert chars to bits
1545 lda blanks get padding word
1546 tra cat join common section
1547 "
1548 cat_bits_q:
1549 eaa 07 offset to au
1550 tra cbq
1551 "
1552 cat_bits_aligned_q:
1553 lda 0dl zero offset
1554 cbq: cmpq 0dl set indicators from length
1555 tra cba join common section
1556 "
1557 cat_bits:
1558 eaa 07 save offset
1559 tra cat_bits_aligned+1
1560 "
1561 cat_bits_aligned:
1562 lda 0dl zero offset
1563 eaq 06 get number of bits
1564 qrl 18 into ql
1565 cba: tze cat_done return if none
1566 sta sp|a1 save source offset
1567 lda 0dl get padding word
1568 "
1569 cat: sta sp|n save a temporarily
1570 lda sp|lg1 save value of lg1
1571 sta sp|old_lg1 ..
1572 stq sp|lg1 set new value
1573 eppap bp|0 get pointer to source
1574 ldx0 sp|str2 get pointer to destination
1575 eppbp sp|temp_pt*0 ..
1576 lda sp|n get padding word back
1577 sreg sp|save_regs save regs including padding word and lg2
1578 tsx0 move_it call string mover
1579 lreg sp|save_regs restore registers including lg2
1580 lda sp|old_lg1 restore value of lg1
1581 sta sp|lg1 ..
1582 eppap operator_table
1583 cat_done: eppbp sp|temp_pt* get ptr to result
1584 stz sp|a1 restore offset of answer to 0
1585 tra lp|0 exit
1586 "
1587 " routine to move an unaligned string
1588 " entered with:
1589 " sp|lg1 length of source in rhs
1590 " sp|lg2 length of destination in rhs
1591 " sp|a1 bit offset of source in lhs
1592 " sp|a2 bit offset of destination in rhs
1593 " ap points at source
1594 " bp points at destination
1595 " ql number of bits to move
1596 "
1597 " the following index registers are used:
1598 " xr0 counter for source lp
1599 " xr1 - offset of source
1600 " xr2 counter for destination bp
1601 " xr3 - offset of destination
1602 " xr4 source offset - destination offset
1603 " xr5 36 - number of bits in last word of source
1604 " xr6 number of bits in last word of destination
1605 "
1606 move_it:
1607 stx0 sp|move_return save return
1608 adq sp|a2 length+a2
1609 div 36dl compute num words to move
1610 qls 18 ..
1611 stq sp|length ..
1612 neg 0 - num bits in last word moved
1613 eax5 36al 36 - num bits in last word
1614 ldq sp|lg2
1615 adq sp|a2
1616 div 36dl number of words in destination
1617 qls 18 in qu
1618 stq sp|str2 ..
1619 eax6 0al number of bits in last word of destination
1620 lcq sp|a2 get - a2
1621 eax3 0ql into x3
1622 eax4 0ql and x4
1623 adlx4 sp|a1 form a1 - a2
1624 eax0 0 init for source
1625 lcx1 sp|a1 ..
1626 eax2 0 init for destination
1627 "
1628 szn sp|lg1 is source zero length
1629 tze move_2 yes do not load it
1630 lda ap|00 load first word of source
1631 ldq sp|a1 get offset in lhs
1632 qrs 18 shift to ql
1633 adq sp|lg1
1634 cmpq 37dl is source contained in 1 word
1635 tnc 2ic
1636 ldq ap|10 no load second word
1637 lrl 361 shift start of source to q
1638 move_2:
1639 lda bp|02 load first word of destination
1640 arl 363 clear space for source
1641 lls 363 move altered word back
1642 cmpx0 sp|length should only a partial word be moved
1643 tze move_nend yes go adjust
1644 eax4 364 36 + a1 - a2
1645 cmpx4 36du is a1 - a2 > 0
1646 tze move_noup
1647 tmi move_noup
1648 eax4 -364 if a1 > a2 update word offset of source
1649 eax0 10 ..
1650 ldq 1du and update word count
1651 asq sp|length of source
1652 tra move_noup
1653 "
1654 move_loop:
1655 ldq ap|00 load word 2 of source
1656 lls 04 shift left 36+a1-a2
1657 move_noup:
1658 sta bp|02 store word in destination
1659 eax2 12 update ptr to destination
1660 lda ap|00 load word 1 of source
1661 eax0 10 update ptr to source
1662 cmpx0 sp|length more words in source
1663 tmi move_loop yes repeat
1664 stx5 sp|temp
1665 cmpx4 sp|temp does string overlap next word
1666 tmi 3ic no don't load
1667 tze 2ic ..
1668 ldq ap|00
1669 lls 04
1670 "
1671 move_nend:
1672 arl 05 last word of source
1673 ldq sp|save_regs+4 so eliminate
1674 lls 05 extraneous bits
1675 cmpx2 sp|str2 is this last word of destination
1676 trc move_nend2 yes go finish up
1677 move_6:
1678 sta bp|02 not last word of destination save
1679 lda sp|save_regs+4 get padding word
1680 tra move_loop2+1
1681 "
1682 move_loop2:
1683 sta bp|02 pad word
1684 eax2 12 update ptr
1685 cmpx2 sp|str2 are we done
1686 tmi move_loop2 no continue padding
1687 move_nend2:
1688 cmpx6 0du yes is there a partial word
1689 tze move_done no we're done
1690 era bp|02 insert in last word
1691 ana bit_mask_one6 ..
1692 ersa bp|02 ..
1693 move_done:
1694 ldx0 sp|move_return return to caller
1695 tra 00 ..
1696 "
1697 " operators to compare unaligned bit string_1 with unaligned
1698 " bit string_2. These operators perform the same function as
1699 " cp_bits and cp_bits_aligned except the size comes in the q
1700 " register. This lets us compare an entire segment.
1701 "
1702 cp_bits_q:
1703 eaa 07 save offset
1704 sta sp|a2 ..
1705 tra cp_start-1 join common section
1706 "
1707 cp_bits_aligned_q:
1708 stz sp|a2 zero offset
1709 tra cp_start-1 join common section
1710 "
1711 " operator to compare unaligned string_2 with unaligned string_1
1712 " based on procedure STRCMP by Ruth Weiss.
1713 "
1714 " string_1 is specified by the variables temp_pt lg1 and a1
1715 " which were stored by a previous operator. entered with unit
1716 " size of string_2 in x6 bit_offset in x7 and pointer in bp.
1717 "
1718 " the following index registers are used:
1719 " xr0 counter for string_1
1720 " xr1 a1 offset of string_1
1721 " xr2 counter for string_2
1722 " xr3 a2 offset of string_2
1723 " xr4 rest1 number of unused bits in last word of string_1
1724 " xr5 rest2 number of unused bits in last word of string_2
1725 "
1726 cp_chars:
1727 eaa 07 save offset
1728 sta sp|a2 ..
1729 tra cp_chars_aligned+1
1730 "
1731 cp_chars_aligned:
1732 stz sp|a2 zero offset
1733 eaq 06 number of chars to qu
1734 qrl 18 and then into ql
1735 mpy 9dl convert to bits
1736 lda blanks get padding word
1737 tra cp_start join common section
1738 "
1739 cp_bits:
1740 eaa 07 save offset
1741 sta sp|a2 ..
1742 tra cp_bits_aligned+1
1743 "
1744 cp_bits_aligned:
1745 stz sp|a2 zero offset
1746 eaq 06 number of bits to qu
1747 qrl 18 and then into ql
1748 lda 0dl get padding word
1749 "
1750 cp_start:
1751 sreg sp|save_regs save regs including padding word and lg2
1752 div 36dl calculate word length of string_2
1753 qls 18 ..
1754 stq sp|str2 ..
1755 neg 0 form rem2 = 36 - num bits in
1756 eax5 36al last word of string_2
1757 cp_join: lcq sp|rem1 form rest1 = 36 - num bits in
1758 eax4 36ql last word of string_1
1759 eax0 0 initialize
1760 ldx1 sp|a1 ..
1761 eax2 0 ..
1762 ldx3 sp|a2 ..
1763 eppap sp|temp_pt*
1764 "
1765 cp_back: lda ap|00 get next word of string_1
1766 cmpx0 sp|str1 is string_1 finished
1767 tze cp_fag yes
1768 ldq ap|10 no get next word
1769 lls 01 shift into position
1770 sta sp|temp save for later
1771 lda bp|02 get next word of string_2
1772 cmpx2 sp|str2 is string_2 finished
1773 tze cp_cag yes
1774 ldq bp|12 no get next word
1775 lls 03 shift into position
1776 cmpa sp|temp string_2 : string_1
1777 tnz cb_done exit if not equal
1778 eax0 10 update string_1 pointer
1779 eax2 12 update string_2 pointer
1780 tra cp_back and keep checking
1781 "
1782 " string_1 done
1783 "
1784 cp_fag: cmpx4 sp|a1 compare rest1 with a1
1785 tpl 2ic if .ge. do not load next word
1786 ldq ap|10 yes
1787 lls 01 shift to position
1788 arl 04 erase unused bits
1789 ldq sp|save_regs+4 get padding bits
1790 lls 04 shift word back to position
1791 "
1792 cp_bag: sta sp|temp at end of string_1 continue with string_2
1793 lda bp|02
1794 cmpx2 sp|str2 is string_2 finished
1795 tze cp_cag yes
1796 ldq bp|12 no get next word
1797 lls 03 into position
1798 cmpa sp|temp string_2 : last of string_1 or padding
1799 tnz cb_done exit if not equal
1800 eax2 12 update string_2 pointer
1801 lda sp|save_regs+4 get padding word for comparison
1802 tra cp_bag and keep looking
1803 "
1804 " string_2 done
1805 "
1806 cp_cag: cmpx5 sp|a2 compare rem2 with a2
1807 tpl 2ic if .ge. do not load next word
1808 ldq bp|12 yes
1809 lls 03 shift to position
1810 arl 05 erase unused bits
1811 ldq sp|save_regs+4 get padding word
1812 lls 05 shift word back to position
1813 cmpa sp|temp end of string_2 : string_1
1814 tnz cb_done exit if not equal
1815 "
1816 cmpx0 sp|str1 has string_1 been finished
1817 tze cb_done yes exit with zero indicators
1818 "
1819 cp_eag: eax0 10 no update for next word
1820 lda ap|00 at end of string_2 continue with string_1
1821 cmpx0 sp|str1 is this last word in string_1
1822 tze cp_gag yes
1823 ldq ap|10 no get next word
1824 lls 01 into position
1825 sta sp|temp save for comparison
1826 lda sp|save_regs+4 with padding word
1827 cmpa sp|temp padding : string_1
1828 tnz cb_done exit if not equal
1829 tra cp_eag go continue checking
1830 "
1831 cp_gag: cmpx4 sp|a1 compare rest1 with a1
1832 tpl 2ic if .ge. do not load next word
1833 ldq ap|10 get last word
1834 lls 01 into position
1835 arl 04 erase unused bits
1836 ldq sp|save_regs+4 get padding word
1837 lls 04 shift padded word back
1838 sta sp|temp save for comparsion
1839 lda sp|save_regs+4 with padding word
1840 cmpa sp|temp
1841 tra cb_done exit with indicators set
1842 "
1843 " operators to compare single double word string in a-reg aq_reg
1844 " with unaligned string specified by temp_pt lg1 and a1.
1845 "
1846 cpcs_ext1:
1847 ldq blanks convert to double length string
1848 "
1849 cpcs_ext2:
1850 staq sp|double_temp save string in aq
1851 lda blanks get padding word
1852 tra cpbs_ext2+2 join common section
1853 "
1854 cpbs_ext1:
1855 ldq 0dl convert to double length string
1856 "
1857 cpbs_ext2:
1858 staq sp|double_temp save string in aq
1859 lda 0dl get padding word
1860 "
1861 sreg sp|save_regs save regs including padding word
1862 ldq 2du set number of words
1863 stq sp|str2 in string 2
1864 stz sp|a2 offset is zero
1865 eax5 36
1866 eppbp sp|double_temp
1867 tra cp_join join regular comparison
1868 "
1869 " operator to check an unaligned string for any non-zero bits.
1870 " entered with bit_size in x6 bit_offset in x7 and pointer
1871 " to source in bp.
1872 "
1873 cpbs3:
1874 eaq 06 get number of bits
1875 qrl 18 and then into ql
1876 "
1877 cpbs3_q:
1878 cmpx7 0du is offset zero?
1879 tze cpbs3_aligned_q if so use aligned section
1880 stz sp|a1
1881 stx7 sp|a1 save bit offset
1882 div 36dl get number of whole words
1883 eax1 0ql into xr1
1884 eax0 0al and number bits in last word
1885 tze cpbs3_loop+1 skip if last word full
1886 neg 0 - num bits in last word
1887 eaq 36al num unused bits in last word
1888 lda bp|01 get last word
1889 cmpq sp|a1 does word overlap
1890 tpl 2ic ..
1891 ldq bp|11 yes get rest of it
1892 lls 07 into position
1893 ana bit_mask_one0 clear unused bits on right
1894 cpbs3_loop:
1895 tnz lp|0 return if non-zero
1896 eax1 -11 count down
1897 tmi zero_ind done if first word passed
1898 lda bp|01 not done get previous word
1899 ldq bp|11 into position
1900 lls 07 ..
1901 cmpa 0dl is it zero
1902 tra cpbs3_loop yes keep looking
1903 "
1904 " operator to check an aligned string for any non_zero bits.
1905 " entered with bit_size in x6 and pointer to source in bp.
1906 "
1907 cpbs3_aligned:
1908 eaq 06 number of bits to qu
1909 qrl 18 and then into ql
1910 "
1911 cpbs3_aligned_q:
1912 div 36dl get number of whole words
1913 eax1 0ql into xr1
1914 eax0 0al number of bits in last word
1915 tra cpbs4_a join common section
1916 "
1917 " operator to check the aligned string temp pointed at by
1918 " sp|temp_pt for any non_zero bits.
1919 "
1920 cpbs4: eppbp sp|temp_pt* get pointer to string
1921 ldx1 sp|str1 size in words
1922 lxl0 sp|rem1 num bits in last word
1923 cpbs4_a:
1924 tze cpbs4_loop+1 skip if last word full
1925 lda bp|01 get last word
1926 ana bit_mask_one0 erase unused bits
1927 cpbs4_loop:
1928 tnz lp|0 return if non-zero
1929 eax1 -11 count down
1930 tmi zero_ind done if first word passed
1931 szn bp|01 check previous word
1932 tra cpbs4_loop ..
1933 zero_ind:
1934 lda 0dl set zero indicator
1935 tra lp|0 and return
1936 "
1937 " operator to compute indexstr1str2. entered with str1 specified
1938 " by previous set operator length of str2 in x6 bit offset of str2 in x7
1939 " and pointer to str2 in bp.
1940 "
1941 index_chars_aligned:
1942 eaq 06 get number of chars in str2
1943 tze lp|0 zero means index = 0
1944 qrl 18 shift num chars to ql
1945 mpy 9dl get bit length
1946 lda 9du get element size
1947 tra ixjoin_a join common section
1948 "
1949 index_bits_aligned_q:
1950 cmpq 0dl are there any bits
1951 tra index_bits_aligned+2 go find out
1952 "
1953 index_bits_aligned:
1954 eaq 06 get number of bits in str2
1955 qrl 18 shift to ql
1956 tze lp|0 zero means index = 0
1957 lda 1du get element size
1958 "
1959 ixjoin_a: sreg sp|save_regs save arithmetic registers
1960 eax7 0 get zero offset
1961 lda bp|0 get first 36 bits of str2
1962 tra ixix join common section
1963 "
1964 index_chars:
1965 eaq 06 get number of chars in str2
1966 tze lp|0 zero means index = 0
1967 qrl 18 shift num chars to ql
1968 mpy 9dl get bit length
1969 lda 9du get element size
1970 tra ixjoin join common section
1971 "
1972 index_bits_q:
1973 cmpq 0dl are there any bits
1974 tra index_bits+2 go find out
1975 "
1976 index_bits:
1977 eaq 06 get number of bits in str2
1978 qrl 18 and then to ql
1979 tze lp|0 zero means index = 0
1980 lda 1du get element size
1981 "
1982 ixjoin: sreg sp|save_regs save arithmetic registers
1983 eaq 07 form length + offset
1984 qrl 18 of
1985 adq sp|lg2 str2
1986 lda bp|0 get first word of str2
1987 cmpq 37dl should we
1988 tmi 2ic load second word?
1989 ldq bp|1 yes fetch it
1990 lls 07 shift to position
1991 "
1992 ixix: ldq sp|lg1 get length of str1
1993 tze lp|0 zero means index = 0
1994 cmpq sp|lg2 is lg1 < lg2
1995 trc 3ic
1996 zix: ldq 0dl yes so index = 0
1997 tra lp|0 and return to caller
1998 "
1999 sta sp|temp save first 36 bits of str2
2000 eppap sp|temp_pt* get ptr to str1
2001 eax0 0 init str1 counter
2002 ldx2 sp|a1 get offset of str1
2003 ldx4 sp|num get shift register
2004 stz sp|count init index count
2005 ldq sp|lg2
2006 cmpq 37dl is lg2 >= 37 bits
2007 tpl longindex yes must use different sequence
2008 ldq 36dl form n = 36 - lg2 + num in lhs
2009 sbq sp|lg2
2010 qls 18
2011 adq sp|num
2012 stq sp|n
2013 "
2014 lda sp|lg2 form comparison mask
2015 lcq 1dl
2016 qrl 0al
2017 stq sp|qmask
2018 "
2019 ixbegin: ldq sp|lg1 are there more than 36 bits left
2020 cmpq 37dl
2021 tpl ib yes 2 words can be fetched
2022 sbq sp|lg2 no form n = lg1 - lg2 + num in lhs
2023 tmi ziy negative means we've failed
2024 qls 18
2025 adq sp|num
2026 stq sp|n
2027 eaq 02 are size + offset > 36
2028 qrs 18
2029 adq sp|lg1
2030 cmpq 37dl
2031 tmi 2ic yes skip load of second word
2032 ib: ldq ap|10 load word 2
2033 lda ap|00 load word 1
2034 lls 02 shift to position
2035 ldq sp|qmask get mask
2036 lcx3 sp|n init count
2037 "
2038 ixloop: cmk sp|temp compare
2039 tze succ on match get index and exit
2040 als 04 shift by 1 or 9
2041 aos sp|count update counter
2042 adlx3 sp|num increment loop counter
2043 tmi ixloop and repeat
2044 "
2045 lcq sp|n update length remaining
2046 qrs 18
2047 asq sp|lg1
2048 tze ziy zero means we've failed
2049 tmi ziy neg too just to be safe
2050 "
2051 adlx2 sp|n compute new offset
2052 cmpx2 36du but don't exceed 36
2053 tnc ixbegin
2054 sblx2 36du ready for new word
2055 adlx0 1du
2056 tra ixbegin
2057 "
2058 ziy: lreg sp|save_regs failure restore arith regs
2059 eppap operator_table and ptr to operator table
2060 tra zix and take failure exit
2061 "
2062 succ: aos sp|count match update count
2063 lreg sp|save_regs restore arith regs
2064 ldq sp|count get index in ql
2065 eppap operator_table restore table pointer
2066 tra lp|0 and exit
2067 "
2068 longindex:
2069 ldq sp|lg1
2070 stq sp|n
2071 "
2072 jb: lda ap|00 load two words of str1
2073 ldq ap|10
2074 lls 02 shift to position
2075 "
2076 jxloop: cmpa sp|temp compare with str2
2077 tnz jxnext no match keep looking
2078 "
2079 trycmp: sprilp sb|stack_header.stack_end_ptr* save return ptr
2080 epplp sb|stack_header.stack_end_ptr* get new stack frame of size 64
2081 sprisp lp|stack_frame.prev_sp
2082 epplp lp|64
2083 sprilp sb|stack_header.stack_end_ptr update end pointer
2084 sprilp lp|stack_frame.next_sp-64
2085 eppsp lp|-64
2086 epplp sp|stack_frame.prev_sp* get ptr to old frame
2087 eaq 02 get offset of str1
2088 stq sp|a1 and save
2089 eppap ap|00 get ptr to current word
2090 spriap sp|temp_pt ans save for set op
2091 ldq lp|lg2 get lg2 for use as lg1
2092 tsplp sba+1 jump into set operator
2093 eaq 07 get offset of str2
2094 stq sp|a2 and save
2095 ldq sp|lg1 get new lg1 = old lg2
2096 lda 0dl get filler word
2097 tsplp cp_start go compare strings
2098 "
2099 epplp sp|0* restore return ptr
2100 even "see note at label 'alm_return'
2101 sprisp sb|stack_header.stack_end_ptr set up stack end pointer
2102 eppsp sp|stack_frame.prev_sp* pop stack back
2103 tze succ exit if match ok
2104 eppap sp|temp_pt* restore ptr to str1
2105 "
2106 jxnext: aos sp|count update index counter
2107 adlx2 sp|num update loop counter
2108 lcq sp|num
2109 qrs 18
2110 asq sp|n
2111 ldq sp|n
2112 cmpq sp|lg2 do we have enough bits left?
2113 tnc ziy no we've failed
2114 cmpx2 36du do not shift more than 1 word
2115 tnc jb < 36 try again
2116 sblx2 36du adjust shift amount
2117 adlx0 1du update str1 counter
2118 tra jb and try again
2119 "
2120 " operator to compute indexstr1str2 when str2 is a single char.
2121 " entered with pointer to str1 in bp size of str1 in x6 bit offset
2122 " of str1 in x7 and value of str2 in a register.
2123 "
2124 ix_cs_1:
2125 stz sp|a1 save bit offset
2126 sxl7 sp|a1 ..
2127 tra ix_cs_1_aligned+1 and join common section
2128 "
2129 ix_cs_1_aligned:
2130 stz sp|a1 offset is zero
2131 "
2132 eaq 06 char size to qu
2133 tze lp|0 return if zero length
2134 "
2135 sta sp|temp save str2 for later
2136 qrl 18 shift size to ql
2137 mpy 9dl convert chars to bits
2138 adq sp|a1 add bit offset
2139 div 36dl get words and bits
2140 lls 18 save word count for loop
2141 stq sp|str1 ..
2142 sta sp|rem1 save number bits in last word
2143 "
2144 lda sp|temp get back char
2145 ora mask_bit_one+9 =o000777777777
2146 ldq mask_bit_one+9 form char mask in q
2147 stz sp|count init counter
2148 eax0 0 init word counter
2149 lxl1 sp|a1 get bit offset of str1
2150 cmpx1 36du is is greater than 36 ?
2151 tmi 3ic no
2152 eax0 1 yes adjust word counter
2153 eax1 -361 and bit offset
2154 lrl 01 shift mask to position
2155 cmpx0 sp|str1 check for end of string
2156 trc ix_cs_1b go finish up
2157 eax1 -361 form a1 - 36
2158 "
2159 ix_cs_1a: aos sp|count update char pos
2160 cmk bp|00 compare masked char
2161 tnz 3ic skip of no match
2162 "
2163 succ2: ldq sp|count match get char pos
2164 tra lp|0 and return
2165 "
2166 lrl 9 shift mask right
2167 adlx1 9du update shift count
2168 tnz ix_cs_1a repeat if end of word not reached
2169 "
2170 lls 36 shift char & mask back to left
2171 ldq mask_bit_one+9
2172 adlx0 1du update word count
2173 cmpx0 sp|str1 check for end of string
2174 trc ix_cs_1b
2175 eax1 -36 reset shift position
2176 tra ix_cs_1a and repeat loop
2177 "
2178 ix_cs_1b: sblx1 sp|rem1 get number bits in last word
2179 tze fail2 exit if nothing more to do
2180 "
2181 ix_cs_1c: aos sp|count update char pos
2182 cmk bp|00 compare with last partial word
2183 tze succ2
2184 lrl 9 shift char & mask right
2185 adlx1 9du update shift
2186 tnz ix_cs_1c and repeat if more to do
2187 "
2188 fail2: ldq 0dl index fails
2189 tra lp|0 too bad
2190
2191 "
2192 " operator to enter a begin block
2193 " calling sequence is:
2194 "
2195 " eax7 stack_size
2196 " tspbp ap|enter_begin_block
2197 " vfd 36/on_unit_mask
2198 "
2199 enter_begin_block:
2200 epplp sp|linkage_ptr* get linkage pointer from parent frame
2201 spribp sb|stack_header.stack_end_ptr* save pointer to entry
2202 eppbp sb|stack_header.stack_end_ptr* get ptr to next stack frame
2203 sprisp bp|stack_frame.prev_sp set back pointer of new frame
2204 eax7 157 make sure stack size is 0 mod 16
2205 anx7 =o777760du ..
2206 eppap bp|07 get ptr to end of frame
2207 spriap sb|stack_header.stack_end_ptr set new stack end
2208 spriap bp|stack_frame.next_sp set next pointer of new frame
2209 sreg sp|8 save live registers
2210 eppsp bp|0 update sp
2211 "
2212 eppbp sp|stack_frame.prev_sp* get ptr to previous frame
2213 spribp sp|display_ptr set display pointer
2214 ldaq null set arg list pointer to null
2215 staq sp|stack_frame.arg_ptr ..
2216 sprilp sp|int_static_ptr save pointer to int static
2217 sprilp sp|linkage_ptr and pointer to linkage segment
2218 eppbp sp|0* restore return pointer
2219 eppbp bp|-2 get entry pointer
2220 spribp sp|stack_frame.entry_ptr save in stack
2221 tra init_stack_join go init rest of stack frame
2222 "
2223 " operator to leave a begin block.
2224 "
2225 leave_begin_block:
2226 even "see note at label 'alm_return' of pl1_operators_
2227 sprisp sb|stack_header.stack_end_ptr reset stack end pointer
2228 eppsp sp|stack_frame.prev_sp* pop the stack
2229 lreg sp|8 reload active registers
2230 tra lp|0 return to pl1 program
2231 "
2232 " operator to do a procedure return from inside a begin block.
2233 " entered with number of nested begin blocks in ql.
2234 "
2235 begin_return_mac:
2236 even "see note at label 'alm_return' of pl1_operators_
2237 sprisp sb|stack_header.stack_end_ptr reset stack end pointer
2238 eppsp sp|stack_frame.prev_sp* pop stack
2239 sbq 1dl count down number of blocks
2240 tnz -3ic repeat until all done
2241 "
2242 " operator to do a procedure return
2243 "
2244 return_mac:
2245 even "see note at label 'alm_return' of pl1_operators_
2246 sprisp sb|stack_header.stack_end_ptr reset stack end pointer
2247 eppsp sp|stack_frame.prev_sp* pop stack
2248 fast_return:
2249 epbpsb sp|0 set sb up
2250 eppap sp|stack_frame.operator_ptr* set up operator pointer
2251 ldi sp|stack_frame.return_ptr+1 restore indicators for caller
2252 rtcd sp|stack_frame.return_ptr continue execution after call
2253 "
2254 " operators to call an entry variable
2255 " entered with pointer to entry in bp and number
2256 " of arguments in position in aq
2257 "
2258 call_ent_var_desc:
2259 eaq 0au there are descriptors
2260 "
2261 call_ent_var:
2262 ora 8dl insert pl1 code
2263 staq sp|64 save at head of list
2264 sprilp sp|0 save return point
2265 sreg sp|8 save registers
2266 eppap bp|2* get display pointer
2267 eppbp bp|0* and ptr to entry
2268 save_display:
2269 spriap sp|66au put at end of arg list
2270 eppap sp|64 get ptr to arg list
2271 epplp sp|linkage_ptr* restore ptr to linkage segment
2272 actual_call:
2273 "At this point we would like to save the indicators in the return_ptr variable
2274 "of the stack frame. However the STCD does not allow us to do this.
2275 "Therefore we save the indicators in the timer/ring-alarm cell of the registers.
2276 sti sp|15 "Sorry...
2277 stcd sp|stack_frame.return_ptr set so control will come back to operators
2278 "
2279 " This label is 'segdef'ed but is never transfered to directly. The segdef is
2280 " merely to allow default_error_handler to see if a fault occured as a result
2281 " of this particular instruction so that it can print a more informative
2282 " error message.
2283 "
2284 call_out:
2285 callsp bp|0 transfer to callee
2286 "
2287 " control comes back here after callee returns
2288 "
2289 lreg sp|8 restore the registers
2290 ldi sp|15 restore our indicators
2291 epbpab ap|0 set up operator base pointer
2292 rtcd sp|0 return to caller thru saved lp
2293 "
2294 "
2295 " operator to call an external procedure same or diff seg.
2296 " entered with pointer to entry in bp and number of args
2297 " in position in aq.
2298 call_ext_in_desc:
2299 call_ext_out_desc:
2300 eaq 0au there are descriptors
2301 "
2302 call_ext_in:
2303 call_ext_out:
2304 ora 4dl insert pl1 code
2305 staq sp|64 save at head of list
2306 sprilp sp|0 save return point
2307 sreg sp|8 save registers
2308 eppap sp|64 get pointer to arg list
2309 epplp sp|linkage_ptr* reload ptr to linkage segment
2310 tra actual_call go do call work
2311 "
2312 " operator to call an internal procedure defined in the
2313 " same block as the call. entered with pointer to entry in
2314 " bp and number of args in position in aq.
2315 "
2316 call_int_this_desc:
2317 eaq 0au there are descriptors
2318 "
2319 call_int_this:
2320 ora 8dl insert pl1 code
2321 staq sp|64 save at head of list
2322 sprilp sp|0 save return point
2323 sreg sp|8 save registers
2324 sprisp sp|66au save display pointer
2325 eppap sp|64 get pointer to arg list
2326 tra actual_call transfer to entry
2327 "
2328 " operator to call an interal procedure defined K blocks
2329 " above the call. entered with pointer to entry in bp
2330 " K in x7 and number of args in position in aq.
2331 "
2332 call_int_other_desc:
2333 eaq 0au there are descriptors
2334 "
2335 call_int_other:
2336 ora 8dl insert pl1 code
2337 staq sp|64 save at head of list
2338 sprilp sp|0 save return point
2339 sreg sp|8 save registers
2340 eppap sp|display_ptr* walk back K levels
2341 eax7 -17 ..
2342 tze save_display then go save display
2343 eppap ap|display_ptr* take another step
2344 tra -3ic and check again
2345 "
2346 " operator to move the label variable pointed at by sp|temp_pt
2347 " into the label variable pointed at by bp
2348 "
2349 move_label_var:
2350 ldaq sp|temp_pt* move first two words
2351 staq bp|0 ..
2352 eax0 2 and second two words
2353 ldaq sp|temp_pt*0 ..
2354 staq bp|2 ..
2355 tra lp|0 return to pl1 program
2356 "
2357 " operator to make a label variable in the stack. entered
2358 " with pointer to label in bp number of static blocks to walk
2359 " back in q. sp|temp_pt is set to point to the label variable
2360 "
2361 make_label_var:
2362 spribp sp|label_var save pointer to label
2363 tsx0 display_chase get pointer to stack frame
2364 spribp sp|label_var+2 and save in label var
2365 eppbp sp|label_var get pointer to label var
2366 spribp sp|temp_pt set temp_pt
2367 tra lp|0 return to pl1 program
2368 "
2369 " subroutine to walk N levels back along the display chain.
2370 " entered with N in q register exit with pointer in bp.
2371 " NB: indicators must be set from q register at time of entry.
2372 "
2373 display_chase:
2374 eppbp sp|0 get pointer to current frame
2375 tze 00 return if N = 0
2376 eppbp bp|display_ptr* take a step back the chain
2377 sbq 1dl and decrease count
2378 tra -3ic and check again
2379 "
2380 " operator to form modfx2fx2
2381 " entered with first arg in aq bp pointing at second
2382 "
2383 mdfx4: lde =71b25du set for double precision
2384 tra mdfx2+2 join modfx1fx2 case
2385 "
2386 " operator to form modfx2fx1
2387 " entered with first arg in aq bp pointing at second
2388 "
2389 mdfx3: lde =71b25du float first d.p. arg
2390 fad =0.du
2391 dfst sp|temp and save
2392 lda bp|0 get second s.p. arg
2393 ldq 0dl
2394 lde =35b25du set for single precision
2395 tra mdfx2a join modfx1fx2 case
2396 "
2397 " operator to form modfx1fx2
2398 " entered with first arg in q bp pointing at second
2399 "
2400 mdfx2: llr 36 shift q into a
2401 lde =35b25du float
2402 fad =0.du
2403 dfst sp|temp and save
2404 ldaq bp|0 get second arg
2405 lde =71b25du float it
2406 mdfx2a: fad =0.du ..
2407 tnz 3ic continue if non-zero
2408 dfld sp|temp get first arg
2409 tra fl2_to_fx2 and return as answer
2410 dfst sp|a1 save second arg
2411 dfdi sp|temp divide first/second
2412 dfad k71b25 drop digits to right of decimal pt
2413 dfmp sp|a1 multiply by second arg
2414 fneg
2415 dfad sp|temp form remainder
2416 tpl fl2_to_fx2 go fix result if pos
2417 fszn sp|a1 correct sign to pos
2418 tpl 3ic
2419 dfsb sp|a1
2420 tra fl2_to_fx2
2421 dfad sp|a1 fall into fl2_to_fx2
2422 "
2423 " operator to convert floating to fixed
2424 "
2425 fl2_to_fx1:
2426 fl2_to_fx2:
2427 fad =0.du
2428 tmi 3ic
2429 ufa =71b25du
2430 tra lp|0
2431 fneg
2432 ufa =71b25du
2433 negl
2434 tra lp|0
2435 "
2436 " stac operator. entered with word in a and pointer
2437 " to destination in bp.
2438 "
2439 stac_mac: stac bp|0 store a conditionally
2440 tze stac_debug see if stac worked DEBUGGING
2441 lda 0dl ..
2442 tra lp|0 and return
2443 stac_debug:
2444 cmpa bp|0 see if stac worked DEBUGGING
2445 tze true yes DEBUGGING
2446 oct 0 bomb DEBUGGING
2447 "
2448 " sign operator. entered with indicators set via load
2449 "
2450 sign_mac: tze lp|0 return zero if zero
2451 tmi 3ic skip if negative
2452 ldq 1dl return +1
2453 tra lp|0 ..
2454 lcq 1dl return -1
2455 tra lp|0 ..
2456 "
2457 " operator to perform block copy. entered
2458 " with block size in ql ptr to destination in sp|temp_pt and ptr
2459 " to source in bp.
2460 "
2461 copy_words:
2462 eppap rpd_copy set rpd instruction
2463 spriap sp|rpd_pt ..
2464 eppap sp|temp_pt* get ptr to destination
2465 qls 18 move size to qu
2466 tsx0 rpd_op call rpd routine
2467 eppap operator_table reset ap
2468 tra lp|0 and return to caller
2469 "
2470 " operator to copy dope template into stack. entered with
2471 " pointer to template in bp and vfd 18/stack_offset18/size
2472 " sitting at lp|0
2473 "
2474 move_dope:
2475 eppap rpd_copy set rpd instruction
2476 spriap sp|rpd_pt ..
2477 ldq lp|0 get offsetsize
2478 eppap sp|0qu get pointer to destination
2479 qlr 18 shift count to qu
2480 tsx0 rpd_op call rpd routine
2481 eppap operator_table restore pointer to op table
2482 tra lp|1 and return to pl/1 program
2483 "
2484 " operator to multiply single precision fixed number in q
2485 " by double precision fixed number pointed at by bp
2486 "
2487 mpfx2: eax0 0 set for positive sign
2488 llr 36 shift multiplier to a
2489 tpl 3ic skip if positive
2490 neg 0 neg force positive
2491 eax0 1 flip sign of result
2492 sta sp|temp save multiplier
2493 ldaq bp|0 get multiplicand
2494 tpl 3ic skip if positive
2495 negl 0 neg force positive
2496 erx0 1du flip sign of answer
2497 llr 1 get high order bit of q into q
2498 qrl 1 get zero in s bit of q
2499 ana mask_bit+2 and zero in s bit of a
2500 sta sp|rem1 save upper half
2501 mpy sp|temp form lower product
2502 staq sp|lv save for later
2503 ldq sp|rem1 get upper half
2504 mpy sp|temp form upper product
2505 lda 0dl clear a
2506 lls 35 and shift to position
2507 adaq sp|lv add lower product
2508 cmpx0 0du check result of answer
2509 tze lp|0 return if +
2510 negl 0 negate
2511 tra lp|0 and return to pl/1 program
2512 "
2513 " operator to multiply double precison fixed integer in aq
2514 " by double precsion fixed number pointed at by bp.
2515 "
2516 mpfx3: eax0 0 set positive sign
2517 cmpa 0du skip if number positive
2518 tpl 3ic
2519 negl 0 neg force positive
2520 eax0 1 flip sign of answer
2521 llr 1 split into 2 35 bit pos numbers
2522 qrl 1
2523 ana mask_bit+2
2524 sta sp|a1 save for later
2525 stq sp|a2
2526 ldaq bp|0 get multplier
2527 tpl 3ic force positive
2528 negl 0
2529 erx0 1du and set answer sign
2530 llr 1 split
2531 qrl 1
2532 ana mask_bit+2
2533 sta sp|str1 save for later
2534 stq sp|str2
2535 mpy sp|a2 form lower product
2536 staq sp|lv and save
2537 ldq sp|str1 form first upper product
2538 mpy sp|a2
2539 lda 0dl and add to lower
2540 lls 35
2541 adaq sp|lv
2542 staq sp|lv save partial answer
2543 ldq sp|a1 form second upper product
2544 mpy sp|str2
2545 lda 0dl shift to position
2546 lls 35
2547 adaq sp|lv add previous part
2548 cmpx0 0du should answer be neg
2549 tze lp|0 no return
2550 negl 0 set minus sign
2551 tra lp|0 and return
2552 "
2553 " operator to perform string range check. entered with
2554 " length of string k in x6
2555 " bp|0 pointing at i' also in q
2556 " bp|1 pointing at j
2557 "
2558 sr_check:
2559 stq bp|0 save i'
2560 stz sp|lg1 save k
2561 sxl6 sp|lg1 ..
2562 cmpq 0dl
2563 tmi sr_1 signal if i' < 0
2564 cmpq sp|lg1 signal if i' >= k
2565 tpl sr_2
2566 ldq bp|1 get j
2567 tmi sr_3 signal if j < 0
2568 cmpq sp|lg1 signal if j > k
2569 tmi 2ic
2570 tnz sr_3
2571 adq bp|0 form i + j
2572 cmpq sp|lg1 return if i + j < k
2573 tmi lp|0
2574 tze lp|0
2575 "
2576 sr_3: tsx0 string_signal
2577 ldq sp|lg1 get mink-i+1j
2578 sbq bp|0
2579 cmpq bp|1
2580 tmi 2ic
2581 ldq bp|1
2582 set_j: cmpq 0dl use zero if q < 0
2583 tpl 2ic
2584 ldq 0dl
2585 stq bp|1 set new value of j
2586 tra lp|0 return
2587 "
2588 sr_2: tsx0 string_signal
2589 stz bp|1 set new value of j = 0
2590 tra lp|0 return
2591 "
2592 sr_1: tsx0 string_signal
2593 adq bp|1 form j+i-1
2594 stz bp|0 set new value of i' = 0
2595 cmpq sp|lg1 get minj+i-1k
2596 tmi set_j and go set value of j
2597 ldq sp|lg1
2598 tra set_j
2599 "
2600 string_signal:
2601 stx0 sp|temp save x0
2602 spribp sp|lv and bp
2603 lxl6 11dl get length of condition
2604 eppbp strg get ptr to condition name
2605 tsx1 call_signal_ signal "stringrange"
2606 ldx0 sp|temp restore x0
2607 eppbp sp|lv* and bp
2608 tra 00 and return
2609 strg: aci "stringrange"
2610 "
2611 " non-local transfer operator. entered with bp pointing
2612 " at destination and number of stack levels to pop in q.
2613 "
2614 tra_ext_1:
2615 spribp sp|lv save ptr to destination
2616 tsx0 display_chase get ptr to stack frame
2617 spribp sp|lv+2 finish the label variable
2618 eppbp sp|lv fall into unwinder_ call
2619 "
2620 " non-local transfer operator. entered with bp pointing
2621 " at a label variable.
2622 "
2623 tra_ext_2:
2624 spribp sp|arg_list+2 save ptr to label var
2625 fld 2*1024dl there are 2 args
2626 staq sp|arg_list ..
2627 eppap sp|arg_list get ptr to arg_list
2628 tsx1 get_our_lp get ptr to our linkage in lp
2629 tra <unwinder_>|unwinder_ go unwind stack
2630 "
2631 " operator to assign auto adjustable variables at end of stack
2632 " frame. entered with number of words in q exit with pointer
2633 " to storage in bp.
2634 "
2635 so_mac: eaq 15ql make size a multiple of 16
2636 anq =o777760du ..
2637 eppbp sb|stack_header.stack_end_ptr* get ptr to storage
2638 asq sb|stack_header.stack_end_ptr+1 reset stack end ptr
2639 asq sp|stack_frame.next_sp+1 reset next ptr
2640 asq sp|5 and set to remember this storage
2641 tra lp|0 return to caller
2642 "
2643 " floating point mod operators entered with x in eaq and
2644 " bp pointing at y. modxy = if y = 0 then x else x - ceilx/y*y
2645 "
2646 mdfl1: fszn bp|0 is y = 0
2647 tze lp|0 yes return with x in eaq as answer
2648 fst sp|temp save x
2649 fdv bp|0 divide x/y
2650 fad =71b25du get ceiling
2651 fmp bp|0 form ceilx/y*y
2652 fneg
2653 fad sp|temp form answer
2654 tpl lp|0 return if pos
2655 fszn bp|0 correct sign
2656 tpl 3ic
2657 fsb bp|0
2658 tra lp|0
2659 fad bp|0
2660 tra lp|0 and return
2661 "
2662 mdfl2: fszn bp|0 is y = 0
2663 tze lp|0 yes return with x in eaq as answer
2664 dfst sp|temp save x
2665 dfdv bp|0 divide x/y
2666 dfad k71b25 get ceiling
2667 dfmp bp|0 form ceilx/y*y
2668 fneg
2669 dfad sp|temp form answer
2670 tpl lp|0 return if pos
2671 fszn bp|0 correct sign
2672 tpl 3ic
2673 dfsb bp|0
2674 tra lp|0
2675 dfad bp|0
2676 tra lp|0 and return
2677 even
2678 k71b25: oct 216000000000000000000000
2679 "
2680 " fixed point mod operator entered with x in q and bp pointing at y.
2681 " if y = 0 then answer is x
2682 "
2683 mdfx1: szn bp|0 is y = 0
2684 tze lp|0 yes return with x in q as answer
2685 div bp|0 form quotient
2686 lrs 36 shift remainder to q set indicators
2687 tpl lp|0 positive remainder is ok
2688 szn bp|0 check sign of divisor
2689 tpl 3ic and adjust sign of remainder
2690 sbq bp|0 ..
2691 tra lp|0 ..
2692 adq bp|0 ..
2693 tra lp|0 ..
2694 "
2695 " operator to convert a long bit string to double precision fixed.
2696 " entered with pointer to string in sp|temp_pt and a1 lg1 str1 set.
2697 " based on bsfx_ by C. Garman and D. Wagner.
2698 "
2699 longbs_to_fx2:
2700 fld 0dl clear aq
2701 szn sp|lg1 test bit length of string
2702 tze lp|0 return immediately if zero length
2703 staq sp|double_temp initialize result
2704 eax0 maxpr x0 = minlengthmaxpr
2705 ldq sp|lg1
2706 cmpq maxprdl ..
2707 tpl 2ic ..
2708 lxl0 sp|lg1 ..
2709 ldq sp|str1 get num whole words in string
2710 lda sp|rem1 and num bits in last word
2711 als 18
2712 ada sp|a1 add bit offset of string
2713 cmpa 36du greater than 36?
2714 tmi 3ic no skip
2715 sba 36du yes adjust
2716 adq 1du ..
2717 eppbp sp|temp_pt*qu get ptr to last word of string
2718 sta sp|temp save spare
2719 neg
2720 eax1 36au get amount of shift needed
2721 ldq bp|0 get last 36-temp bits of string
2722 qrl 01 ..
2723 stq sp|double_temp+1 and save
2724 eaa -20 quit if minlengthmaxpr <= 36-temp
2725 cmpa sp|temp ..
2726 tmi lbfx_done ..
2727 lda bp|-1 get next to last word
2728 ldq 0du clear q
2729 lrl 01 ..
2730 orsa sp|double_temp combine with last part
2731 orsq sp|double_temp+1 ..
2732 eaa -380 quit if minlengthmaxpr <= 72-temp
2733 cmpa sp|temp ..
2734 tmi lbfx_done ..
2735 lda bp|-2 get first part
2736 ldq 0du
2737 lrl 01 put high order bits in q
2738 orsq sp|double_temp drop high order bits into result
2739 lbfx_done:
2740 ldaq mask_bit mask out any garbage
2741 lls 00 which may have gotten into result
2742 eraq mask_bit ..
2743 anaq sp|double_temp ..
2744 tra lp|0 return to caller
2745 "
2746 " operator to convert a long bit string to bit 18 used for ptr built-ins.
2747 " entered with pointer to string in sp|temp_pt and lg1 str1 a1 set.
2748 "
2749 longbs_to_bs18:
2750 fld 0dl clear aq
2751 szn sp|lg1 test bit length of string
2752 tze lp|0 if zero length return 0
2753 eppbp sp|temp_pt* get ptr to string
2754 lda bp|0 get first word of string
2755 ldq sp|a1 form length + offset
2756 ars 18
2757 adq sp|lg1
2758 cmpq 37dl should second word beloaded
2759 tmi 2ic ..
2760 ldq bp|1 yes load it
2761 lls sp|a1* shift to position
2762 ldq sp|lg1 get length of string
2763 cmpq 18dl
2764 tpl 2ic dont mask if lg1 >= 18
2765 ana bit_mask_oneql
2766 anaq mask_bit+36 mask to length 18
2767 tra lp|0 return to caller
2768 "
2769 " operator to enable a condition. calling sequence is:
2770 " eapbp name
2771 " lxl6 name_size
2772 " tsplp ap|enable
2773 " tra on_unit_body
2774 " arg on_unit
2775 " tra skip_around_body
2776 " body of on unit starts here
2777 "
2778 equ on_name0
2779 equ on_body2
2780 equ on_size4
2781 equ on_next5
2782 equ on_file6
2783 "
2784 enable_op:
2785 lda =o100dl is there a valid on_unit_list
2786 cana sp|stack_frame.prev_sp check bit 29 of prev sp
2787 tnz 3ic non-zero means ok
2788 stz sp|stack_frame.on_unit_rel_ptrs init ptr
2789 orsa sp|stack_frame.prev_sp and set bit
2790 "
2791 ldx1 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit
2792 tze add_on zero means chain empty
2793 on_1: cmpx1 lp|1 is this the unit we want
2794 tze have_on yes go process
2795 ldx1 sp|on_next1 no get ptr to next on chain
2796 tnz on_1 and repeat if end not reached
2797 add_on: ldx1 lp|1 get rel ptr to new unit
2798 ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
2799 stz sp|on_next1 clear next ptr rhs
2800 stx0 sp|on_next1 set next ptr of new unit
2801 stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first on chain
2802 have_on: spribp sp|on_name1 set name of new unit
2803 sprilp sp|on_body1 set ptr to body
2804 stz sp|on_size1 clear size field
2805 sxl6 sp|on_size1 set size of unit name
2806 tra lp|2 return to pl2 program
2807 "
2808 " operator to signal a condition. entered with ptr to name in bp
2809 " and size of name in x6.
2810 "
2811 signal_op:
2812 tsx1 call_signal_ call signal_
2813 tra lp|0 and return
2814 "
2815 " operator to signal "subscriptrange" condition
2816 "
2817 bound_ck_signal:
2818 stx6 sp|temp save x6
2819 lxl6 14dl get size of condition
2820 eppbp subrg get ptr to name
2821 tsx1 call_signal_ call signal_
2822 ldx6 sp|temp restore x6
2823 tra lp|0 and return
2824 subrg: aci "subscriptrange"
2825 "
2826 " internal subroutine to signal a condition. entered with
2827 " bp pointing at name and x6 holding size of name
2828 "
2829 "
2830 call_signal_:
2831 sprilp sp|temp_pt save return pointer
2832 eppap sb|stack_header.stack_end_ptr* get ptr to end of stack frame
2833 eax0 48+16 increase stack frame size by mc size + arg list size
2834 asx0 sb|stack_header.stack_end_ptr+1 ..
2835 asx0 sp|stack_frame.next_sp+1 ..
2836 spri ap|mc.prs save bases
2837 spribp ap|mc.scu.tpr.tsr_word set ptr to name as tsr value
2838 call_signal_1:
2839 spriap ap|48+12 save ptr to machine conditions
2840 eppap ap|48 get ptr to argument list
2841 spribp ap|2 set ptr to name as first arg
2842 eppbp ap|12 get ptr to machine conditions
2843 spribp ap|4 as second arg
2844 ldq =o10100du get char string descriptor code
2845 stq ap|10 make descriptor for first arg
2846 sxl6 ap|10 ..
2847 eppbp ap|10 set ptr to descriptor
2848 spribp ap|6 ..
2849 eppbp =o150000000 get ptr to pointer descriptor code
2850 spribp ap|8 set ptr to descriptor
2851 eax0 sig get offset of link to signal_
2852 fld 2*2048dl set number of args
2853
2854 signal_common:
2855 sreg ap|mc.regs-48 save registers in pseudo_scu
2856 epplp lp|-1 move lp back to tspbp instruction
2857 sprilp ap|mc.scu.ppr.psr_word-48 set psr in pseudo_scu data
2858 eaq 0au and descriptors
2859 ora 4dl from a pl1 call
2860 staq ap|0 set head of arglist
2861 sreg sp|8 save regs for call
2862 tsx1 get_our_lp get ptr to our linkage in lp
2863 stcd sp|stack_frame.return_ptr call pl1 written signal program
2864 tra lp|00* ..
2865 xed reset_stack reset stack frame
2866 epplp sp|temp_pt* restore lp
2867 eppap operator_table and pointer to operators
2868 lreg sp|8 get the regs back
2869 tra 01 and return
2870
2871 get_our_lp:
2872 epbpsb sp|0 make sure sb is set up
2873 epaq * get ptr to ourselves
2874 lprplp sb|stack_header.lot_ptr*au get packed ptr to linkage from lot
2875 tra 01 return with lp loaded to our linkage
2876 "
2877 " operator to signal io condition same as signal except sp|40 holds
2878 " pointer to file name.
2879 "
2880 io_signal:
2881 sprilp sp|temp_pt save return point
2882 eppap sb|stack_header.stack_end_ptr* get pointer to end of stack frame
2883 eax0 48+32 bump frame by mc size+arg list size 0 mod 16 words
2884 asx0 sb|stack_header.stack_end_ptr+1 ..
2885 asx0 sp|stack_frame.next_sp+1 ..
2886 spri ap|mc.prs store bases
2887 spribp ap|mc.scu.tpr.tsr_word set ptr to name as tsr value
2888 spriap ap|48+16 set ptr to machine conditions
2889 eppap ap|48 get ptr to argument list
2890 spribp ap|2 save ptr to name as first arg
2891 eppbp ap|16 get ptr to machine conditions ptr
2892 spribp ap|4 save as second arg
2893 eppbp sp|40 get ptr to file name ptr
2894 spribp ap|6 save as third arg
2895 ldq 520du get char string descriptor code
2896 stq ap|14 make descriptor
2897 sxl6 ap|14 ..
2898 eppbp ap|14 set ptr to first descriptor
2899 spribp ap|8 ..
2900 eppbp =o15000000 get ptr to ptr code
2901 spribp ap|10 set descriptor for second arg
2902 spribp ap|12 and third
2903 eax0 io_sig get offset of link to signal_|io_signal
2904 fld 3*2048dl there are 3 args
2905 tsx1 signal_common jump into common section to signal
2906 tra lp|0 and return
2907 "
2908 " Following are dummies in place of operators not as yet implemented
2909 " The condition "unimplemented_pl1_operator" is signalled
2910 "
2911 dvfx2:
2912 dvfx3:
2913 allot_based:
2914 free_based:
2915 sprilp sp|temp_pt save return point
2916 eppap sb|stack_header.stack_end_ptr* get ptr to end of stack
2917 eax0 48+16 increase stack frame size by mc size + arg list size
2918 asx0 sb|stack_header.stack_end_ptr+1 ..
2919 asx0 sp|stack_frame.next_sp+1 ..
2920 spri ap|mc.prs save prs
2921 sreg ap|mc.regs and registers
2922 epplp lp|-1 move back lp to tsplp instruction
2923 sprilp ap|mc.scu.ppr.psr_word set psr in pseudo-scu data
2924 lda lp|0 pickup the tsplp instruction
2925 epplp operator_tableau get ptr to transfer table entry
2926 sprilp ap|mc.scu.tpr.tsr_word set tsr in psuedo-scu data
2927 stx6 sp|temp save x6
2928 lxl6 26dl get size of condition
2929 eppbp unimp_pl1_op get ptr to name
2930 tsx1 call_signal_1 call signal_
2931 ldx6 sp|temp restore x6
2932 epplp temp_pt* restore return point
2933 tra lp|0 and return
2934
2935 unimp_pl1_op:
2936 aci "unimplemented_pl1_operator"
2937 "
2938 " Single word mask arrays are used only by operators
2939 "
2940 bit_mask_one:
2941 vfd 0/-136/0
2942 vfd 1/-135/0
2943 vfd 2/-134/0
2944 vfd 3/-133/0
2945 vfd 4/-132/0
2946 vfd 5/-131/0
2947 vfd 6/-130/0
2948 vfd 7/-129/0
2949 vfd 8/-128/0
2950 vfd 9/-127/0
2951 vfd 10/-126/0
2952 vfd 11/-125/0
2953 vfd 12/-124/0
2954 vfd 13/-123/0
2955 vfd 14/-122/0
2956 vfd 15/-121/0
2957 vfd 16/-120/0
2958 vfd 17/-119/0
2959 vfd 18/-118/0
2960 vfd 19/-117/0
2961 vfd 20/-116/0
2962 vfd 21/-115/0
2963 vfd 22/-114/0
2964 vfd 23/-113/0
2965 vfd 24/-112/0
2966 vfd 25/-111/0
2967 vfd 26/-110/0
2968 vfd 27/-19/0
2969 vfd 28/-18/0
2970 vfd 29/-17/0
2971 vfd 30/-16/0
2972 vfd 31/-15/0
2973 vfd 32/-14/0
2974 vfd 33/-13/0
2975 vfd 34/-12/0
2976 vfd 35/-11/0
2977 "
2978 mask_bit_one:
2979 vfd 0/036/-1
2980 vfd 1/035/-1
2981 vfd 2/034/-1
2982 vfd 3/033/-1
2983 vfd 4/032/-1
2984 vfd 5/031/-1
2985 vfd 6/030/-1
2986 vfd 7/029/-1
2987 vfd 8/028/-1
2988 vfd 9/027/-1
2989 vfd 10/026/-1
2990 vfd 11/025/-1
2991 vfd 12/024/-1
2992 vfd 13/023/-1
2993 vfd 14/022/-1
2994 vfd 15/021/-1
2995 vfd 16/020/-1
2996 vfd 17/019/-1
2997 vfd 18/018/-1
2998 vfd 19/017/-1
2999 vfd 20/016/-1
3000 vfd 21/015/-1
3001 vfd 22/014/-1
3002 vfd 23/013/-1
3003 vfd 24/012/-1
3004 vfd 25/011/-1
3005 vfd 26/010/-1
3006 vfd 27/09/-1
3007 vfd 28/08/-1
3008 vfd 29/07/-1
3009 vfd 30/06/-1
3010 vfd 31/05/-1
3011 vfd 32/04/-1
3012 vfd 33/03/-1
3013 vfd 34/02/-1
3014 vfd 35/01/-1
3015
3016 "
3017 " pl1 entry operators
3018 " calling sequence is:
3019 "
3020 " aci "name of pl1 entry"
3021 " vfd 36/size_of_pl1_entry_string
3022 " vfd 72/parameter_description_string
3023 " eax7 stack_size
3024 " eax6 stack_offset_of_arg_list
3025 " tspbp lp|ext_entry* lp -> linkage section of pl1 program
3026 " vfd 18/on_unit_mask18/2*number_of_args_expected
3027 "
3028 " the operators desc_ext_entry desc_int_entry and desc_val_entry
3029 " will only copy the number of args passed and no more than are
3030 " are expected--missing args will be set to a special pointer.
3031 "
3032 " for int_entry the A register will contain the first word
3033 " of the argument list.
3034 "
3035 " for val_entry the on_unit_mask will be followed with
3036 " nop val_procdl
3037 " where val_proc is the location of the link to the validation
3038 " procedure to be called.
3039 "
3040 bool string_bit200000
3041 bool array_bit100000
3042 bool packed_bit40000
3043 bool varying_bit2000
3044 "
3045 "
3046 odd "this forces first rpd on odd loc
3047 ext_entry:
3048 spribp sb|stack_header.stack_end_ptr* save pointer to entry
3049 eppbp sb|stack_header.stack_end_ptr* get ptr to next stack frame
3050 sprisp bp|stack_frame.prev_sp set back ptr of new frame
3051 spriap bp|stack_frame.arg_ptr save arg pointer
3052 eax7 157 make sure stack size is 0 mod 16
3053 anx7 =o777760du ..
3054 eppap bp|07 get ptr to end of frame
3055 spriap bp|stack_frame.next_sp set next pointer of new frame
3056 spriap sb|stack_header.stack_end_ptr update end ptr
3057 eppsp bp|0 update sp
3058 ee: eppap sp|stack_frame.arg_ptr* restore arg pointer
3059 lda ap|0 get 2*n_args in au code in al
3060 eax7 0 this is ext entry
3061 "
3062 common_entry:
3063 ars 9 get number of pairs.ls.10 in al
3064 tze save_link-*ic skip if no args
3065 eax0 rpd_bitsal setup rpd instruction
3066 eax1 0 ..
3067 odd
3068 vfd 18/012/rpd6/2 RPD instruction
3069 ldaq ap|21 copy arg list into stack
3070 staq sp|06 ..
3071 save_link:
3072 eppbp lp|0 remember lp value
3073 sprilp sp|int_static_ptr save pointer to int static
3074 sprilp sp|linkage_ptr and pointer to linkage seg of pl1 prog
3075 init_stack:
3076 eppbp sp|0* restore pointer to entry
3077 eppbp bp|-37 get pointer to entry
3078 spribp sp|stack_frame.entry_ptr store entry pointer in its frame debugging
3079 init_stack_join:
3080 stz sp|single_bit_temp+1
3081 lda 2du fill in translator ID for VERSION I
3082 sta sp|stack_frame.translator_id
3083 epplp sb|stack_header.stack_end_ptr* get pointer to next frame
3084 eppap operator_table get pointer to operator table
3085 spriap sp|stack_frame.operator_ptr save ptr to operators
3086 epbpab pl1_operator_begin get address of base of operators
3087 sprilp sp|4 we will only store lp and that is because it points
3088 " to the next stack frame and we use this in adjusting
3089 " the current frame size up and resetting it.
3090 eppbp sp|0* restore return pointer
3091 ldi 0dl preset all indicators
3092 tra bp|1 return to pl1 program
3093 "
3094 int_entry:
3095 spribp sb|stack_header.stack_end_ptr* save pointer to entry
3096 eppbp sb|stack_header.stack_end_ptr* get ptr to next stack frame
3097 sprisp bp|stack_frame.prev_sp set back ptr of new frame
3098 spriap bp|stack_frame.arg_ptr save arg pointer
3099 eax7 157 make sure stack size is 0 mod 16
3100 anx7 =o777760du ..
3101 eppap bp|07 get ptr to end of frame
3102 spriap bp|stack_frame.next_sp set next pointer of new frame
3103 spriap sb|stack_header.stack_end_ptr update end ptr
3104 eppsp bp|0 update sp
3105 eppap sp|stack_frame.arg_ptr* restore arg pointer
3106 lda ap|0 get 2*n_args in au
3107 eppbp ap|2au* get display pointer
3108 spribp sp|display_ptr and save
3109 eax7 -3 this is int entry
3110 tra common_entry-*ic join common section
3111 "
3112 ext_entry_desc:
3113 ldx5 ap|0 get number of args actually passed
3114 tra 2ic and go do save
3115 "
3116 desc_ext_entry:
3117 lxl5 bp|0 get number of args expected
3118 "
3119 spribp sb|stack_header.stack_end_ptr* save pointer to entry
3120 eppbp sb|stack_header.stack_end_ptr* get ptr to next stack frame
3121 sprisp bp|stack_frame.prev_sp set back ptr of new frame
3122 spriap bp|stack_frame.arg_ptr save arg pointer
3123 eax7 157 make sure stack size is 0 mod 16
3124 anx7 =o777760du ..
3125 eppap bp|07 get ptr to end of frame
3126 spriap bp|stack_frame.next_sp set next pointer of new frame
3127 spriap sb|stack_header.stack_end_ptr update end ptr
3128 eppsp bp|0 update sp
3129 eed: eppap sp|stack_frame.arg_ptr* restore arg pointer
3130 lda ap|0 get 2*n_args in au code in al
3131 eax7 0 this is ext entry
3132 "
3133 desc_ce:
3134 cana 8+4dl is this an epl call
3135 tze desc_epl_call-*ic yes go convert to descriptors
3136 cmpx5 ap|0 compare number to copy with number passed
3137 tze 2ic
3138 trc desc_toofew-*ic too few go to special section
3139 eaa 05 there are >= number expected use number expected
3140 tze save_link-*ic skip if none expected
3141 ars 9 get number of pairs.ls.10 in al
3142 eax0 rpd_bitsal setup rpd instruction
3143 stx6 sp|temp save x6 for later restoration
3144 eax1 2 ..
3145 odd
3146 vfd 18/012/rpd6/2 RPD instruction
3147 ldaq ap|01 copy arg list into stack
3148 staq sp|06 ..
3149 eax6 05 get no words moved in x6
3150 adx6 sp|temp make x6 point to word just after move
3151 "
3152 ldx1 ap|0 get number of descriptors
3153 tze no_desc-*ic skip if none
3154 adlx1 2du allow for stack header
3155 lda ap|0 is there a stack pointer
3156 cana 8dl ..
3157 tze 2ic no
3158 adlx1 2du yes skip over it
3159 eaa 05 get number expected
3160 ars 9 get number of pairs.ls.10 in al
3161 eax0 rpd_bitsal setup rpd instruction
3162 odd
3163 vfd 18/012/rpd6/2 RPD instruction
3164 ldaq ap|01 copy descriptor pointers
3165 staq sp|06 into stack
3166 tra save_link-*ic then join standard sequence
3167 "
3168 no_args:
3169 eaa 05 no args passed
3170 ars 9 fill in with special pointer
3171 eax0 rpt_bitsal ..
3172 stx6 sp|temp save x6 for later restoration
3173 ldaq dummy_arg-*ic
3174 vfd 18/012/rpt6/2 rpt instruction
3175 staq sp|06 ..
3176 eax6 05 get no words moved in x6
3177 adx6 sp|temp make x6 point to word just after move
3178 "
3179 no_desc: eaa 05 no desc passed get number expected
3180 ars 9 shifted left 10 in al
3181 eax0 rpt_bitsal set up rpt instruction
3182 stx6 sp|temp save x6 for later restoration
3183 ldaq dummy_desc-*ic get ptr to dummy descriptor
3184 vfd 18/012/rpt6/2 rpt instruction
3185 staq sp|06 store descriptor
3186 eax6 05 get no words moved in x6
3187 adx6 sp|temp make x6 point to word just after move
3188 tra save_link-*ic then join standard sequence
3189 "
3190 desc_toofew:
3191 eax1 2 not enough arguments
3192 lda ap|0 get number of args passed and
3193 eax3 0au get number words to move in x3
3194 ars 9 copy as many as there are
3195 tze no_args-*ic skipping if none
3196 eax0 rpd_bitsal set up rpd instruction
3197 stx6 sp|temp save x6 for later restoration
3198 odd
3199 vfd 18/012/rpd6/2 rpd instruction
3200 ldaq ap|01 copy args
3201 staq sp|06 ..
3202 eax6 03 get no words moved in x6
3203 adx6 sp|temp make x6 point to word just after move
3204 "
3205 fill_args:
3206 eax4 05 compute number of missing args
3207 sbx4 ap|0 ..
3208 eaa 04 get number missing in au
3209 ars 9 and fill in special pointer
3210 eax0 rpt_bitsal ..
3211 stx6 sp|temp save x6 for later restoration
3212 ldaq dummy_arg-*ic ..
3213 vfd 18/012/rpt6/2 rpt instruction
3214 staq sp|06
3215 eax6 04 get no words moved in x6
3216 adx6 sp|temp make x6 point to word just after move
3217 "
3218 lda ap|0 is there a stack pointer
3219 cana 8dl ..
3220 tze 2ic no
3221 adlx1 2du yes skip over it
3222 lda ap|1 are there any descriptors
3223 tze no_desc-*ic no go fill in dummy
3224 eax3 0au save no words to be moved in x3
3225 ars 9 yes copy as many as are given
3226 eax0 rpd_bitsal
3227 stx6 sp|temp save x6 for later restoration
3228 odd
3229 vfd 18/012/rpd6/2
3230 ldaq ap|01 copy descriptor
3231 staq sp|06
3232 eax6 03 get no words moved in x6
3233 adx6 sp|temp make x6 point to word just after move
3234 "
3235 eaa 04 get number of missing descriptors
3236 ars 9
3237 eax0 rpt_bitsal set up rpt instruction
3238 ldaq dummy_desc-*ic get pointer to dummy desc
3239 vfd 18/012/rpt6/2 rpt instruction
3240 staq sp|06 save dummy descriptor
3241 tra save_link-*ic and join common section
3242 "
3243 desc_epl_call:
3244 eaa 0au erase right hand side
3245 tze no_args-*ic skip if no args given
3246 eax2 05 compute where to store descriptors
3247 eppbp sp|0* restore ptr to entry
3248 adx2 bp|-21 by adding in value in x6
3249 eax4 05 get number expected
3250 cmpx4 ap|0 take minexpectedpassed
3251 tnc 2ic ..
3252 ldx4 ap|0 ..
3253 stx4 sp|n set loop bound
3254 sprilp sp|2 save lp setting
3255 ldaq sb|stack_header.stack_end_ptr initialize stack extension mechanism
3256 staq sp|free_pt ..
3257 stz sp|free_amt ..
3258 eax0 0 init arg checking loop
3259 ldq bp|-41 get arg description string
3260 lda bp|-51 ..
3261 "
3262 desc_epl_call_1:
3263 eppbp ap|20* get ptr to argument
3264 tmi have_dope-*ic should this be a specifier
3265 spribp sp|06 no set arg pointer
3266 epplp dummy_desc-*ic* get special ptr for descriptor
3267 set_desc_pt:
3268 sprilp sp|02 set descriptor ptr
3269 adlx0 2du update arg counter
3270 cmpx0 sp|n are we done
3271 tze fill_arg_epl-*ic yes go fill any missing args
3272 adlx2 2du no update descriptor counter
3273 adlx6 2du and arg destination counter
3274 lls 1 shift to next description bit
3275 tra desc_epl_call_1-*ic and repeat
3276 "
3277 have_dope:
3278 epplp bp|0* get ptr to datum
3279 sprilp sp|06 save in unpacked form
3280 staq sp|double_temp save param description string
3281 ldaq bp|2* get first two words of dope
3282 canq string_bitdu is this a string
3283 tnz string-*ic yes
3284 als 18 no shift add offset to au
3285 asa sp|16 add into data pointer
3286 canq array_bitdu is this a non-string-array
3287 tnz non_string_array-*ic yes
3288 "
3289 non_string_scalar:
3290 lda 1du get a one word descriptor
3291 tsx3 get_desc-*ic
3292 nss: qrs 27 isolate size in ql
3293 anq 7dl ..
3294 stq lp|0 set size of descriptor
3295 ldaq sp|double_temp restore param description string
3296 tra set_desc_pt-*ic go set descriptor
3297 "
3298 non_string_array:
3299 lda 4du get a four word descriptor
3300 tsx3 get_desc-*ic
3301 lda bp|3 move multiplier
3302 sta lp|3
3303 lda bp|4 move lb
3304 sta lp|1
3305 lda bp|5 move ub
3306 sta lp|2
3307 tra nss-*ic join non_array sequence
3308 "
3309 string:
3310 canq varying_bitdu is it varying
3311 tnz varying_string-*ic yes
3312 canq packed_bitdu is this packed string
3313 tnz packed_string-*ic yes
3314 als 18 no add word address offset
3315 asa sp|16 into data ptr
3316 tra string_1-*ic join common section
3317 packed_string:
3318 lrs 36 shift bit address offset to ql
3319 div 36dl get number of words
3320 qls 18 into qu
3321 asq sp|16 adjust data ptr
3322 als 9 set bit offset of data ptr
3323 orsa sp|16 ..
3324 ldaq bp|2* reload first words of dope
3325 string_1:
3326 canq array_bitdu is this an array
3327 tnz string_array-*ic yes
3328 s1: lda 1du get a one word descriptor
3329 tsx3 get_desc-*ic
3330 ss: stq sp|length save string size.
3331 ldaq sp|double_temp get pds
3332 lls 1 shift to c|b bit
3333 staq sp|double_temp save again
3334 ldq sp|length get size back
3335 anq =o77777dl isolate size
3336 szn sp|double_temp is this a char string
3337 tpl nss+2-*ic plus means bit
3338 div 9dl form size in chars
3339 tra nss+2-*ic go save size
3340 "
3341 string_array:
3342 lda 4du get a four word descriptor
3343 tsx3 get_desc-*ic ..
3344 lda bp|4 move multiplier
3345 sta lp|3
3346 lda bp|5 move lb
3347 sta lp|1
3348 lda bp|6 move ub
3349 sta lp|2
3350 tra ss-*ic join non-array case
3351 "
3352 varying_string:
3353 canq array_bitdu is this varying-string-array
3354 tnz set_desc_pt-1-*ic yes use null ptr to descriptor
3355 ldaq bp|0* get varying string info
3356 epplp bp|4*au load free ptr into lp plus offset of string
3357 sprilp sp|06 use as data ptr
3358 tra s1-*ic now treat like non-varying string
3359 "
3360 fill_arg_epl:
3361 sbx5 ap|0 compute number of missing args
3362 tmi desc_done-*ic skip if there are extra args
3363 tze desc_done-*ic skip if none
3364 adlx2 2du update descriptor counter
3365 adlx6 2du update arg ptr counter
3366 eaa 05 init rpt loop
3367 ars 9
3368 eax0 rpt_bitsal
3369 ldaq dummy_arg-*ic get dummy arg pointer
3370 vfd 18/012/rpt6/2 fill missing positions
3371 staq sp|06
3372 eaa 05 init rpt loop
3373 ars 9
3374 eax0 rpt_bitsal
3375 ldaq dummy_desc-*ic get dummy desc pointer
3376 vfd 18/012/rpt6/2 fill missing positions
3377 staq sp|02
3378 "
3379 desc_done:
3380 epplp sp|temp_pt* restore lp
3381 tra save_link-*ic and join standard sequence
3382 "
3383 int_entry_desc:
3384 ldx5 ap|0 get number of args actually passed
3385 tra 2ic and go do save
3386 "
3387 desc_int_entry:
3388 lxl5 bp|0 get number of args expected
3389 "
3390 spribp sb|stack_header.stack_end_ptr* save pointer to entry
3391 eppbp sb|stack_header.stack_end_ptr* get ptr to next stack frame
3392 sprisp bp|stack_frame.prev_sp set back ptr of new frame
3393 spriap bp|stack_frame.arg_ptr save arg pointer
3394 eax7 157 make sure stack size is 0 mod 16
3395 anx7 =o777760du ..
3396 eppap bp|07 get ptr to end of frame
3397 spriap bp|stack_frame.next_sp set next pointer of new frame
3398 spriap sb|stack_header.stack_end_ptr update end ptr
3399 eppsp bp|0 update sp
3400 eppap sp|stack_frame.arg_ptr* restore arg pointer
3401 lda ap|0 get 2*n_args in au
3402 eppbp ap|2au* get display pointer
3403 spribp sp|display_ptr and save
3404 eax7 -3 this is int entry
3405 tra desc_ce-*ic join common section
3406 "
3407 val_entry_desc:
3408 eax0 ved-*ic get destination
3409 tra 4ic go to save sequence
3410 "
3411 desc_val_entry:
3412 eax0 dev-*ic get destination
3413 tra 2ic go to save sequence
3414 "
3415 val_entry:
3416 eax0 ee-*ic get destination
3417 spribp sb|stack_header.stack_end_ptr* save pointer to entry
3418 eppbp sb|stack_header.stack_end_ptr* get ptr to next stack frame
3419 sprisp bp|stack_frame.prev_sp set back ptr of new frame
3420 spriap bp|stack_frame.arg_ptr save arg pointer
3421 eax7 157 make sure stack size is 0 mod 16
3422 anx7 =o777760du ..
3423 eppap bp|07 get ptr to end of frame
3424 spriap bp|stack_frame.next_sp set next pointer of new frame
3425 spriap sb|stack_header.stack_end_ptr update end ptr
3426 eppsp bp|0 update sp
3427 eppbp sp|0* reload ptr to entry
3428 eppbp bp|-3 get pointer to first instruction of entry
3429 spribp sp|stack_frame.entry_ptr store entry pointer in its frame debugging
3430 eppbp sp|0* get entry ptr again
3431 eppap sp|stack_frame.arg_ptr get ptr to arg pointer
3432 spriap sp|arg_list+2 set as arg of val call
3433 fld 2*1024dl set head of arg list
3434 staq sp|arg_list ..
3435 eppap sp|arg_list get ptr to arg list
3436 sprilp sp|stack_frame.lp_ptr store a valid ptr so returning pgm can
3437 " load valid info from here in standard return sequence
3438 spri sp|0 save bases and regs
3439 sreg sp|stack_frame.regs ..
3440 ldx1 bp|1 get offset of link to val proc
3441 stcd sp|stack_frame.return_ptr call validate procedure
3442 tra lp|01* ..
3443 lpri sp|0 restore bases and regs
3444 lreg sp|stack_frame.regs ..
3445 spribp sp|0 save pointer to entry again
3446 tra 00 and transfer to ee|dev|ved
3447 "
3448 dev: lxl5 bp|0 get number of args expected
3449 tra eed-*ic and enter standard sequence
3450 "
3451 ved: ldx5 ap|0 get number of args passed
3452 tra eed-*ic and enter standard sequence
3453 "
3454 get_desc:
3455 cmpa sp|free_amt is there enough room
3456 tmi gd_ok-*ic yes
3457 tze gd_ok-*ic yes
3458 ldx4 8du no extend stack by eight words
3459 asx4 sb|stack_header.stack_end_ptr+1 ..
3460 asx4 sp|stack_frame.next_sp+1 ..
3461 asx4 sp|free_amt ..
3462 gd_ok: epplp sp|free_pt* return value of free_pt
3463 eppbp bp|2* get ptr to dope
3464 asa sp|free_pt+1 update free_pt
3465 neg
3466 asa sp|free_amt and free_AMT
3467 tra 03 return to caller
3468 "
3469 even
3470 null: its -11n
3471 dummy_arg:
3472 oct 077777000043700000000000
3473 dummy_desc:
3474 oct 00
3475 "
3476 link sig<signal_>|signal_
3477 link io_sig<signal_>|io_signal
3478 "
3479 " The following line must appear after everything in text segment
3480 "
3481 pl1_operators_end:
3482 zero 0* marks end of pl1_operators
3483 end