1 * ***********************************************************
2 * * *
3 * * Copyright, C Honeywell Information Systems Inc., 1982 *
4 * * *
5 * * Copyright c 1972 by Massachusetts Institute of *
6 * * Technology and Honeywell Information Systems, Inc. *
7 * * *
8 * ***********************************************************
9
10 ttl intp -- control table interpreter for mcs/fnp
11 lbl ,interpreter
12 rem
13 ********************************************************************************
14 *
15 * modified 79 jul 29 by art beattie to use real tib address in trace calls
16 * and call 'setptw' in 'itmout' routine.
17 * modified 81 jan 16 by robert coren to add metering op blocks
18 *
19 ********************************************************************************
20 rem
21 rem
22 pcc on
23 pmc off
24 editp on
25 symdef intp
26 symdef itmout,itest,iwrite,istat,istbrk
27 symdef globsw
28 symdef cvaddr
29 symdef adbyte
30 symdef getcmt
31 symdef intend end of interpreter
32 symdef -mcall
33 symdef -mcal2
34 pmc save,on
35 comreg
36 tib
37 meters
38 sfcm hsla
39 devtab
40 buffer
41 ttls symbol definitions
42 symref ctrl
43 symref secdsp,setime,frelbf
44 symref denq,meterc
45 symref hdcw,ldcw
46 symref hgeti
47 symref hcfg
48 symref trace
49 symref getbuf,frebuf
50 symref getbfh,frebfh
51 symref getmem,fremem
52 symref brkhit
53 symref lctlck
54 symref setcct
55 symref puteco
56 symref setptw set up variable cpu page table word
57 symref setbpt set up buffer page table word
58 symref cvabs convert virtual address to absolute
59 symref gettib
60 symref mincs,mincd,mupdat,mmsg
61 rem
62 statop bool 777004 status op code
63 waitop bool 777003 wait op code
64 accin equ 74 accept input mailbox op code
65 sndout bool 105 send output mailbox op code
66 sparms bool 104 send params opcode
67 space bool 040 ascii space char
68 cr bool 015 ascii carriage return
69 upshft bool 034 ebcdic up-shift
70 dnshft bool 037 ebcdic down-shift
71 ibmeot bool 074 ebcdic eot
72 ntfwrt bool /tfwrit for turning tfwrit off
73 ntfrpn bool /tfrpon for turning tfrpon off
74 hslafl bool 001000
75 rem
76 rem
77 rem memory trace types
78 rem
79 mt.tst equ 1
80 mt.wrt equ 2
81 mt.sta equ 3
82 mt.tim equ 4
83 mt.blk equ 5
84 rem
85 rem tracing switches
86 rem
87 tr.ent bool 040
88 tr.blk bool 100
89 rem
90 ct.dev equ 1 offset in control tables of pointer
91 rem to device table entry pointers
92 intp null
93 start intp,3
94 pmc restore
95 rem
96 globsw oct 0 "global swtches" word
97 ttls itest entry for test-state
98 rem
99 * this entry called by dia_man for test-state
100 *
101 * input:
102 * x1 - virtual tib address
103 rem
104 itest subr ite,x1x2x3aq
105 rem
106 lda t.line,1 get line number
107 tsy a.c002-*,* gettib get real tib address in a
108 cax2 put in x2 for trace
109 rem
110 trace mt.tst,tr.ent,x2t.cur1
111 *
112 tsy iinchk-*,* make sure entry is valid
113 tra ite001-* at breakpoint, ignore call
114 ldx2 3,2 get branch point for test-state
115 tze ite001-* never mind if there isn't one
116 tsy iintrp-*,* call interp to do work
117 ite001 return itest
118 ttls iwrite entry for output
119 rem
120 * entry for write, called by dia_man when output is to be sent
121 *
122 * input:
123 * x1 - virtual tib address
124 rem
125 iwrite subr iwr,x1x2x3aq
126 rem
127 lda t.line,1 get line number
128 tsy a.c002-*,* gettib get real tib address in a
129 cax2 put in x2 for trace
130 rem
131 trace mt.wrt,tr.ent,x2t.cur1
132 *
133 tsy iinchk-*,*
134 tra iwr001-* at breakpoint, ignore call
135 ldx2 2,2 get branch point for write
136 tze 2 if any
137 tsy iintrp-*,*
138 iwr001 return iwrite
139 *
140 ttls istat entry to process status
141 *
142 * entry called by hsla_man or lsla_man with standard
143 * status word in a register and virtual tib address in x1.
144 * checks op blocks following current wait to see if any
145 * status tests succeed, and if so, calls interp to proceed.
146 * if a non-status block is encountered before any of the status
147 * matches, then return, doing nothing.
148 *
149 istat subr ist,x1x2x3aq
150 sta istsav-* hang on to status word
151 rem
152 lda t.line,1 get line number
153 tsy a.c002-*,* gettib get real tib address in a
154 cax2 put in x2 for trace
155 rem
156 trace mt.sta,tr.ent,x2t.cur1istsav
157 tsy iinchk-*,* make sure its ok
158 tra istbak-* at breakpoint, ignore call
159 ist010 null
160 iacx2 4 get next op block
161 lda 0,2 get type code
162 cmpa l.a001-* check against status op code
163 tze ist020-* okay, go ahead
164 rem
165 tra istbak-* no status blocks to check
166 *
167 ist020 null
168 lda istsav-* get status back in a
169 cana 3,2 check "off" bits
170 tnz ist010-* if not all off, get next status
171 ana 2,2 ok, get "on" bits
172 cmpa 2,2 are they all on?
173 tnz ist010-* that didn't work either
174 *
175 * fell through, get branch point and call
176 trace mt.blk,tr.blk,x2l.a002
177 ldx2 1,2 interp
178 tsy iintrp-*,*
179 istbak null
180 return istat
181 *
182 l.a001 vfd o18/statop
183 l.a002 oct 4 constant for status op block type
184 istsav bss 1 saved status
185 *
186 ttls itmout entry for processing timeouts
187 *
188 * called by secondary dispatcher
189 *
190 * input:
191 * x1 - real tib address
192 rem
193 itmout null
194 rem
195 cx1a get real tib address in a
196 sta itmtib-* save real tib address for trace
197 tsy a.c001-*,* setptw virtualize it
198 cax1 put virtual tib address in x1
199 rem
200 trace mt.tim,tr.ent,itmtibt.cur1
201 rem
202 tsy iinchk-*,* set up
203 tra iscdsp-*,* in breakpoint, ignore call
204 *
205 ldx2 1,2 get timeout branch if any
206 tze 2
207 tsy iintrp-*,* and do it
208 tra iscdsp-*,* back to secondary dispatcher
209 *
210 iscdsp ind secdsp secondary dispatcher
211 iinchk ind inchek interpreter entry validation
212 iintrp ind interp main interpreter subroutine
213 rem
214 itmtib bss 1 saves real tib address
215 ttls istbrk entry for restarting from breakpoint
216 rem
217 istbrk subr ibk,x1x2x3
218 sta brkopc-* may contain the real op to execute
219 tsy iinchk-*,* do std setup
220 tra ibk001-* at breakpoint, good
221 stz brkopc-* not at breakpoint, cleanup
222 tra ibkret-* and return
223 rem
224 ibk001 lda l.c003-* =^tfbkpt
225 ansa t.flg3,1 not at break anymore
226 tsy iintrp-*,* call intpreter
227 ibkret return istbrk
228 rem
229 brkopc oct 0 real op to exec when starting from break
230 ttls inchek subroutine to validate and set up at entry
231 *
232 * this subroutine makes sure everything is legal at entry to
233 * interpreter, and puts address of current wait block in x2
234 *
235 inchek subr inc,a
236 *
237 cx1a make sure x1 is non-zero
238 tnz 2
239 die 1
240 *
241 ldx2 t.cur,1 get pointer to current wait blk
242 tnz 2 which had better be non-zero
243 die 2
244 rem
245 lda t.flg3,1 see if at break
246 cana l.c002-* =tfbkpt
247 tnz incret-* at break, take nonskip return
248 *
249 lda 0,2 get op block type
250 cmpa l.c001-* which should be "wait"
251 tze 2
252 die 3
253 aos inchek-* take skip return
254 *
255 incret return inchek
256 *
257 a.c001 ind setptw set up variable cpu page table word
258 a.c002 ind gettib
259 rem
260 l.c001 vfd o18/waitop
261 l.c002 vfd o18/tfbkpt
262 l.c003 vfd o18//tfbkpt
263 ttls interp subroutine processes most control blocks
264 *
265 * interp: main subroutine of control table interpreter, called
266 * tib address in x1 and pointer to first block to process in
267 * x2. starts at top for every fresh op block
268 *
269 interp subr int,x2x3
270 rem
271 szn brkopc-* op to exec from bkpt restart?
272 tze int010-* no
273 lda brkopc-* yes, pick it up
274 stz brkopc-*
275 tra int011-*
276 *
277 int010 null head of main loop
278 lda 0,2 get op block type
279 int011 lrs 9 extend high-order 9 bits
280 icmpa -1 which must be all on
281 tze 2
282 die 4
283 * isolate type so as to use
284 * jump table
285 qrl 9 get it in low-order
286 cqa of a
287 tze int020-* zero is not allowed
288 icmpa maxop it can't be too big either
289 tmi 2
290 int020 null
291 die 8
292 * now we'll load type into x3 and use it
293 * to index jump table
294 cax3
295 trace mt.blk,tr.blk,x2x3
296 adcx3 int030-* add address of head of jump table
297 tra 0,3* and go through indirect word
298 *
299 int030 zero * address of jump table
300 * jump table follows
301 ind int100 01 goto
302 ind int200 02 iftyp
303 ind int300 03 wait
304 ind int400 04 status
305 ind int500 05 dcwlst
306 ind int600 06 setime
307 ind int700 07 gotype
308 ind int800 10 setflg
309 ind int900 11 clrflg
310 ind in1000 12 tstflg
311 ind in1100 13 dmpout
312 ind in1200 14 signal
313 ind in1300 15 meter
314 ind intbak 16 waitm just returns
315 ind in1500 17 sendin
316 ind in1600 20 tstwrt
317 ind in1700 21 tstglb
318 ind in1800 22 setype
319 ind in1900 23 scntr
320 ind in2000 24 acntr
321 ind in2100 25 tcntr
322 ind in2200 26 getext
323 ind in2300 27 retext
324 ind in2400 30 inscan
325 ind in2500 31 outscn
326 ind in2600 32 bldmsg
327 ind in2700 33 dumpin
328 ind in2800 34 setchr
329 ind in2900 35 cmpchr
330 ind in3000 36 calsub
331 ind in3100 37 retsub
332 ind in3200 40 holdot
333 ind in3300 41 ifhsla
334 ind in3400 42 config
335 ind in3500 43 ckinpt
336 ind in3600 44 gtinpt
337 ind in3700 45 replay
338 ind in3800 46 dmprpy
339 ind in3900 47 prepnl
340 ind in4000 50 tstrpy
341 ind in4100 51 echo
342 ind in4200 52 setcct
343 ind in4300 53 dmpmsg
344 ind in4400 54 setlcl
345 ind in4500 55 addlcl
346 ind in4600 56 tstlcl
347 ind in4700 57 setlcf
348 ind in4800 60 clrlcf
349 ind in4900 61 tstlcf
350 ind in5000 62 setlcv
351 ind in5100 63 calasm
352 ind in5200 64 bkptop
353 ind in5300 65 linctl
354 ind in5400 66 linsta
355 ind in5500 67 tstlcv
356 ind in5600 70 nullop
357 ind in5700 71 unwind
358 ind in5800 72 settmv
359 ind in5600 73 retpms obsolete ind to nullop
360 ind in6000 74 gotov
361 ind in6100 75 gocase
362 ind in6200 76 setfld
363 ind in6300 77 addfld
364 ind in6400 100 tstfld
365 ind in6500 101 meter1
366 ind in6600 102 meter2
367 ind in6700 103 meteru
368 ind in6800 104 meterm
369 ind in2620 105 bldims
370 maxop equ *-int030 defines end of table
371 *
372 intbak null return point
373 return interp
374 *
375 *
376 *
377 *
378 int100 null goto
379 ldx2 1,2 get address from block
380 tra int010-* and go around again
381 *
382 * test terminal type
383 * iftype <terminal type test value>,<ptg on equal>
384 *
385 int200 null
386 lda 1,2 get terminal type test value
387 cmpa t.type,1 vs tib terminal type
388 tze int210-* equal
389 iacx2 3 go to next block
390 tra int010-*
391 int210 ldx2 2,2 get new block address
392 tra int010-*
393 *
394 *
395 int300 null wait
396 szn incall-* check if still in called subroutine
397 tze 2
398 die 13 wait block executed between call and retu
399 stx2 t.cur,1 store pointer to wait block in
400 tra intbak-* tib and return
401 *
402 *
403 int400 null status is illegal except after wait
404 die 5
405 *
406 *
407 int500 null dcwlst, handled by subroutine
408 tsy idcwc-*,*
409 tra int010-*
410 *
411 idcwc ind dcwcnt
412 *
413 *
414 int600 null setime
415 lda 1,2 get interval
416 int601 tsy istime-*,*
417 iacx2 2 bump to next block
418 tra int010-*
419 istime ind setime scheduler entry to set timer
420 *
421 *
422 int700 null gotype
423 ldq t.type,1 make sure terminal type code
424 tze int710-* is positive
425 tpl 2
426 int710 null
427 die 12
428 *
429 int720 iacx2 1 advance to branch point
430 lda 0,2 get branch point
431 tmi int710-* end of list
432 iaq -1 decrement count
433 tze int730-* found branch point
434 tra int720-* loop
435 int730 cax2 get new address
436 tra int010-* and process it
437 *
438 *
439 int800 null setflg
440 lda 1,2 get word of flags to turn on
441 orsa t.flg,1 and do it
442 lda 2,2 same for second word
443 orsa t.flg2,1
444 iacx2 3 bump to next block
445 tra int010-*
446 *
447 *
448 int900 null clrflg
449 lda 1,2 get word of flags to turn off
450 iera -1 complement it
451 ansa t.flg,1 turn off specified tib flags
452 lda 2,2 get second word
453 iera -1 complement it
454 ansa t.flg2,1 turn these off,too
455 iacx2 3 on to the next
456 tra int010-*
457 *
458 *
459 in1000 null tstflg
460 lda 2,2 get flags to test
461 ana t.flg,1 isolate them from tib flag word
462 cmpa 2,2 are they all on?
463 tnz in1010-*
464 lda 3,2 get second word to test
465 ana t.flg2,1
466 cmpa 3,2 are they all on too?
467 tnz in1010-*
468 ldx2 1,2 yes, get new op block address
469 tra int010-*
470 in1010 null
471 iacx2 4 no, bump to next block
472 tra int010-*
473 *
474 *
475 in1100 null dmpout
476 stz sndflg-* initialize this
477 lda t.ocp,1 get output chain pointer
478 tze in1110-* and if its non-zero, free chain
479 sta in1190-* save address
480 tsy a.d005-*,* setbpt
481 cax3 get addressable pointer
482 lda bf.flg,3 get buffer flags
483 cana l.d007-* =hold output buffers flag
484 tze in1108-* no - normal dmpout
485 in1104 cana l.d006-* =last buffer in message flag
486 tnz in1106-* yes - release partial chain
487 lda bf.nxt,3 get forward link
488 tze in1107-* end of chain - treat as normal dmpout
489 tsy a.d005-*,* setbpt
490 cax3 as above
491 lda bf.flg,3 get buffer flags
492 tra in1104-*
493 in1106 lda bf.nxt,3 get forward link
494 stz bf.nxt,3 unlink rest of chain
495 ldx3 t.ocp,1 get output chain pointer
496 sta t.ocp,1 establish new output chain
497 cx3a
498 tsy ifrel-*,* release first message in chain
499 stz t.ocur,1 void current buffer stuff
500 stz t.olst,1
501 tra in1140-*
502 rem
503 in1107 aos sndflg-* make sure about sndout
504 lda t.ocp,1 get ptr to chain
505 tsy ifrel-*,* free chain
506 stz t.ocp,1 zero ptr
507 stz t.ocur,1
508 stz t.olst,1
509 tra in1120-*
510 rem
511 in1108 lda in1190-* get absolute chain address
512 tsy ifrel-*,*
513 stz t.ocp,1
514 aos sndflg-* we must do "send output" if t.ocp chain was freed
515 in1110 null
516 rem do the same for chain being
517 lda t.ocur,1 output currently
518 tze in1120-*
519 tsy ifrel-*,*
520 stz t.ocur,1
521 stz t.olst,1
522 lda t.line,1 hsla line?
523 cana l.d010-* =hslafl
524 tze in1120-* no
525 ldx3 t.sfcm,1 yes, we'll need sfcm address
526 stz sf.noc,3 not partway through an output buffer now
527 rem
528 in1120 null
529 szn sndflg-* did we free t.ocp chain?
530 tnz in1125-* yes, queue "send output"
531 ila bufthr if we threw away more than "threshold" buffers,
532 cmpa t.ocnt,1 we'll have to ask for more output
533 tpl in1130-*
534 in1125 null
535 ilq sndout
536 tsy idenq-*,* dia enqueueing routine
537 in1130 null
538 stz t.ocnt,1 no buffers in write chain now
539 lda l.d002-* ^tfwrit
540 ansa t.flg,1 tfwrit must be turned off
541 in1140 null
542 iacx2 1 bump to next block
543 tra int010-*
544 rem
545 in1190 bss 1
546 ifrel ind frelbf free buffer chain subroutine
547 *
548 *
549 in1200 null signal
550 ldq 1,2 get signal type
551 tsy idenq-*,* call dia queuing routine
552 iacx2 2 bump to next block
553 tra int010-*
554 idenq ind denq dia enqueuing routine
555 *
556 *
557 in1300 null meter
558 ldq 1,2 get meter type
559 tsy imetrc-*,* and call metering utility
560 iacx2 2 next block
561 tra int010-*
562 imetrc ind meterc
563 *
564 *
565 in1500 null sendin
566 lda t.icp,1 get input chain pointer
567 tze in1520-* forget it if zero
568 cmpa t.ilst,1 see if there's only 1 buffer
569 tnz in1510-* no, send the chain
570 tsy a.d005-*,* setbpt
571 cax3
572 lda bf.tly,3 otherwise make sure tally
573 ana l.d001-* is non-zero
574 tze in1520-*
575 *
576 in1510 null
577 ilq accin put "accept input" opcode in q
578 tsy idenq-*,* for dia enqueuing routine
579 *
580 in1520 null
581 iacx2 1 next block
582 tra int010-*
583 *
584 *
585 *
586 in1600 null tstwrt
587 szn t.ocp,1 is there an output chain
588 tnz in1605-*
589 szn t.ocur,1 or is there one we're working on now?
590 tze in1610-*
591 in1605 null
592 ldx2 1,2 yes, get branch address
593 tra int010-*
594 in1610 null no, go to next block
595 iacx2 2
596 tra int010-*
597 *
598 *
599 in1700 null tstglb
600 lda iglob-*,* pick up global switches
601 ana 1,2 isolate the ones we're testing
602 cmpa 1,2 all on?
603 tnz in1710-*
604 ldx2 2,2 yes, get new op block addr.
605 tra int010-*
606 in1710 iacx2 3 fail, get next block
607 tra int010-*
608 iglob ind globsw
609 *
610 *
611 in1800 null setype
612 lda 1,2 get new type from op block
613 sta t.type,1 set it in tib
614 ldx3 a.d004-* addr ctrl
615 ldx3 ct.dev,3 get pointer to device tables
616 adcx3 t.type,1 indexed by line type
617 ldx3 -1,3 subtract 1 for 0 origin
618 iacx3 dt.brk add in offset of break table
619 stx3 t.brkp,1 update break table address
620 iacx2 2 next block
621 tra iin010-*,*
622 *
623 in1900 null scntr set counter
624 lda 1,2 get new value
625 sta t.cntr,1 store it in counter
626 iacx2 2 next block
627 tra iin010-*,*
628 *
629 in2000 null acntr add to counter
630 lda t.cntr,1 origional value
631 ldq 1,2 increment
632 tsy a.d001-*,* =addnov
633 sta t.cntr,1
634 iacx2 2 next block
635 tra iin010-*,*
636 *
637 in2100 null tcntr test counter
638 lda 1,2 get test value
639 cmpa t.cntr,1 same as counter?
640 tze in2110-*
641 iacx2 3 no, go to next block
642 tra iin010-*,*
643 in2110 null
644 ldx2 2,2 yes, get new block address
645 tra iin010-*,*
646 rem
647 rem
648 rem
649 a.d001 ind addnov
650 a.d002 ind getmem
651 a.d003 ind fremem
652 a.d004 ind ctrl
653 a.d005 ind setbpt
654 a.d006 ind cvabs
655 rem
656 l.d001 vfd 18/buftmk buffer tally mask
657 l.d002 vfd 18/ntfwrt
658 l.d003 oct 400000 extension buffer in use flag
659 l.d004 oct 77 sub-buffer tally mask
660 l.d005 oct 777 mask for right half
661 l.d006 vfd 18/bfflst last buffer in message flag
662 l.d007 vfd 18/bffhld hold output buffers flag
663 *l.d008 unused
664 *l.d009 unused
665 l.d010 vfd 18/hslafl
666 rem
667 incall oct 0 hold area - return point from called subr
668 ifrlbf ind frelbf free linked chain of buffers subroutine
669 rem
670 rem
671 sndflg bss 1 indicates whether to do "send output" on dmpout
672 *
673 * get tib extension
674 * getext < # words needed>,<ptg on failure>
675 *
676 in2200 szn t.elnk,1 does line have extension?
677 tze 2 no
678 die 14 die
679 ldq 1,2 number of words needed
680 iaq 1 +1 for length word
681 tsy a.d002-*,* =getmem
682 tra in2210-* no room
683 lda 1,2 length requested
684 sta 0,3 save in extension
685 stx3 t.elnk,1 save extension address
686 iacx2 3 skip 3 words for this opblock
687 tra iin010-*,* and go to next
688 in2210 ldx2 2,2 take failure return
689 tra iin010-*,*
690 *
691 * return a tib extension
692 * retext
693 *
694 in2300 ldx3 t.elnk,1 get address
695 tze in2310-* none, do nothing
696 stz t.elnk,1 no longer has ext
697 ldq 0,3 length
698 iaq 1 plus control word
699 tsy a.d003-*,* =fremem
700 in2310 iacx2 1
701 tra iin010-*,*
702 *
703 * input scan
704 * inscan <address of control string>,<ptg on failure>
705 *
706 in2400 ila 0 get input scan indicator
707 tsy iscnop-*,* call scan subroutine
708 tra iin010-*,*
709 iscnop ind scanop
710 *
711 * output scan
712 * outscn <address of control string>,<ptg on failure>
713 *
714 in2500 ila 1 get output scan indicator
715 tsy iscnop-*,* call scan subroutine
716 tra iin010-*,*
717 *
718 *
719 *
720 iin010 ind int010
721 ibldut ind bldutl
722 iadbyt ind adbyte
723 *
724 * build output message
725 * bldmsg <address of control string>,<ptg on failure>
726 *
727 in2600 null
728 tsy ibldut-*,* =bldutl build the message
729 tra in2670-* failed
730 lda t.ocp,1 get output chain pointer
731 sta bf.nxt,3 chain it to this one
732 cx3a get our absolute address
733 tsy a.d006-*,* cvabs
734 sta t.ocp,1 replace output chain pointer
735 rem
736 in2605 iacx2 3 go to next block
737 tra iin010-*,*
738 *
739 * build input message
740 * bldims <address of control string>,<ptg on failure>
741 *
742 in2620 null
743 tsy ibldut-*,* =bldutl build the message
744 tra in2670-* failed
745 lda t.icp,1 get input chain pointer
746 sta bf.nxt,3 chain it to current one
747 cx3a
748 tsy a.d006-*,* cvabs
749 sta t.icp,1 place input chain pointer
750 tra in2605-* return
751 *
752 * Here for failing bldmsg
753 *
754 in2670 ldx2 2,2 get failure block address
755 tra iin010-*,*
756 *
757 * dump input chain
758 * dumpin
759 *
760 in2700 lda t.icp,1 get input chain ptr
761 tze in2710-* no chain
762 tsy ifrlbf-*,* free input chain
763 stz t.icp,1 zero chain pointer
764 stz t.ilst,1 zero pointer to last buffer
765 stz t.icpl,1
766 in2710 iacx2 1 go to next block
767 tra iin010-*,*
768 *
769 * set byte value in tib extension
770 * setchr <destination>,<source>
771 *
772 in2800 lda 1,2 get byte positions
773 arl 9 isolate dest byte
774 tsy iadbyt-*,* get its byte adress
775 die 15 not tib extension byte
776 stx3 in2850-* save - dest address
777 lda 1,2
778 ana l.d005-* =o777 - isolate source byte
779 tsy iadbyt-*,* get its address
780 tra in2810-* not 46x value
781 lda 0,3,b.0 get source byte
782 in2810 ldx3 in2850-* get dest byte address
783 sta 0,3,b.0 place in tib byte
784 iacx2 2 go to next block
785 tra iin010-*,*
786 in2850 bss 1 destination byte address
787 in2860 bss 1 source byte address
788 *
789 * compare bytes
790 * cmpchr <source>,<test value>,<ptg on equal>
791 *
792 in2900 lda 1,2 get byte positions
793 arl 9 isolate source byte
794 tsy iadbyt-*,* get its byte address
795 tra in2910-* not 46x value
796 lda 0,3,b.0 get source byte
797 in2910 sta in2860-* save for compare
798 lda 1,2
799 ana l.d005-* =o777 - isolate test value
800 tsy iadbyt-*,* get its address
801 tra in2920-* not 46x value
802 lda 0,3,b.0 get test value
803 in2920 cmpa in2860-* vs source byte
804 tze in2930-* equal
805 iacx2 3 go to next block
806 tra iin010-*,*
807 in2930 ldx2 2,2 get equal block address
808 tra iin010-*,*
809 *
810 * call subroutine
811 * calsub <subroutine entry point>
812 *
813 in3000 szn incall-* check return point
814 tze 2 ok - not in use
815 die 13 multiple subroutine calls
816 lda 1,2 get entry point block address
817 iacx2 2
818 szn t.reta,1 tib return addr used yet?
819 tnz in3001-* yes
820 stx2 t.reta,1
821 tra in3002-*
822 in3001 stx2 incall-* save return point
823 in3002 cax2 go to subroutine
824 tra iin010-*,*
825 *
826 * return from subroutine
827 * retsub
828 *
829 in3100 szn incall-* check second return point
830 tze in3101-* not in use
831 ldx2 incall-*
832 stz incall-*
833 tra iin010-*,*
834 in3101 szn t.reta,1 check first return point
835 tnz 2
836 die 13
837 ldx2 t.reta,1
838 stz t.reta,1
839 tra iin010-*,*
840 *
841 * set hold output buffer flag
842 * holdot
843 *
844 in3200 lda t.ocp,1 get output chain pointer
845 tnz in3220-*
846 in3210 iacx2 1 go to next block
847 tra iin010-*,*
848 in3220 tsy a.g015-*,* setbpt
849 cax3
850 lda in3290-* get hold output buffer flag
851 orsa bf.flg,3 set on in buffer
852 lda bf.flg,3
853 ana in3280-* check for last buffer in message
854 tnz in3210-* yes
855 lda bf.nxt,3 get forward pointer
856 tze in3210-*
857 tra in3220-*
858 rem
859 in3280 vfd 18/bfflst last buffer in message flag
860 in3290 vfd 18/bffhld hold output buffer flag
861 *
862 * test for hsla line
863 * ifhsla
864 *
865 in3300 null ifhsla
866 lda t.line,1 get line number to find out if hsla line
867 arl 9 get hsla bit down at end
868 tze in3310-* not hsla
869 ldx2 1,2 is hsla, get branch point
870 tra iin010-*,* go get new block
871 in3310 null not hsla
872 iacx2 2 go to next block
873 tra iin010-*,*
874 *
875 * reconfigure operation for hsla's
876 * config
877 *
878 in3400 null config
879 lda t.line,1 be sure hsla
880 arl 9
881 tnz 2
882 die 16
883 iacx2 1 point at first sub-op
884 tsy icnfg-*,* config block processed by subroutine
885 tra iin010-*,* and continue with next op block
886 rem
887 icnfg ind hcfg subroutine to process config block
888 *
889 * check for partial input line for channel
890 * ckinpt
891 *
892 in3500 null ckinpt
893 lda t.icp,1 is there an input chain?
894 tze in3510-* no, check for hsla
895 tsy a.g015-*,* setbpt
896 cax3
897 lda bf.tly,3 yes, see if it's more than just cr
898 ana l.g001-* =buftmk isolate tally in first buffer
899 iaa -2 is it more than 1?
900 tpl in3595-* yes, there's a partial line
901 rem otherwise result would have been negative
902 cx3a no, get pointer to first character
903 ada l.g007-* bf.dta,b.0
904 cax3 in order to
905 tra in3520-* check to see if it's carriage return
906 rem
907 in3510 lda t.line,1
908 arl 9 is it an hsla line?
909 tze in3590-* no, there's no input
910 rem
911 ldx3 a.g001-* =indblk 2 word arg blk for hgeti
912 tsy a.g002-*,* =hgeti call routine to check input
913 lda indblk+1-* any chars in buffer?
914 tze in3590-* no, at left margin
915 icmpa 1 more than one char?
916 tnz in3595-* yes, we have partial input
917 ldx3 indblk-* no, look at character
918 in3520 lda 0,3,b.0 pick up the char
919 iana 127 strip off parity
920 sta tmpchr-* hang on to it
921 icmpa cr is it carriage return?
922 tze in3590-* yes, no partial input
923 icmpa upshft case shift character?
924 tze in3590-* yes, doesn't count
925 icmpa dnshft or lower shift?
926 tze in3590-* yes, don't count it either
927 lda t.flg2,1 check for output flow control chars
928 cana l.g008-* tfofc
929 tze in3540-* mode not on, skip it
930 ldq t.ofch,1 get the chars
931 cana l.g009-* tfblak
932 tnz in3530-* if block ack, don't check 1st char
933 cqa
934 arl 9 suspend character
935 cmpa tmpchr-* got it?
936 tze in3590-* yes, doesn't count
937 in3530 lls 27 isolate resume/ack char
938 arl 9
939 cmpa tmpchr-*
940 tze in3590-* it is one, don't count it
941 in3540 lda t.type,1 is this a 2741?
942 icmpa 3
943 tnz in3595-* no, don't check further
944 lda tmpchr-* get character back into a
945 iana 63 mask off shift
946 icmpa ibmeot is it an eot?
947 tnz in3595-* no, we have partial input
948 rem
949 in3590 ldx2 1,2 get fail addr, no partial line
950 tra a.g003-*,* =int010 return
951 rem
952 in3595 iacx2 2 all well, partial input ready
953 tra a.g003-*,* =int010 return
954 *
955 * routine to scoop up input and make output chain at t.rcp
956 * gtinpt
957 *
958 in3600 null
959 stx2 in3694-* save x2 value
960 rem
961 tsy a.g006-*,* =getcmt get pointer to cmt
962 rem returned in x2
963 lda 1,2,b.0 get tab from cmt
964 sta a.g007-*,* tabchr save for copybf
965 lda 1,2,b.1 likewise backspace
966 sta a.g008-*,* bschar
967 rem
968 lda t.type,1 is it a 1050 or 2741?
969 icmpa 2 1050
970 tze in3602-*
971 icmpa 3 2741
972 tnz in3603-*
973 in3602 ila 61 yes, use ebcdic pad
974 tra in3604-*
975 rem
976 in3603 ila 0 no, use ascii pad
977 in3604 sta a.g008-*,* delchr save for copybf
978 stz t.rcp,1 to initialize
979 rem
980 lda t.icp,1 get ptr to head of input chain
981 tze in3650-* none, check hsla
982 rem
983 in3610 tsy a.g015-*,* setbpt
984 cax2
985 lda bf.tly,2 get the output buffer tally
986 ana l.g001-* =buftmk mask tally
987 caq hold on to it
988 stx2 in3695-* save original buffer pointer
989 cx2a move pointer to first char
990 ada l.g007-* bf.dta,b.0
991 cax2
992 cqa get tally back
993 tsy a.g010-*,* copybf copy it into replay chain
994 rem
995 ldx2 in3695-* restore x2 with buffer pointer
996 lda bf.nxt,2 get fwd ptr in this buffer
997 tnz in3610-* enter copy loop if another buffer
998 stx3 in3693-* save pointer to last buffer
999 rem
1000 in3650 lda t.line,1 special code for hsla's
1001 arl 9 we are done if its an lsla
1002 tze in3680-* we are.
1003 rem
1004 ldx3 a.g001-* =indblk 2 word arg blk
1005 tsy a.g002-*,* =hgeti get input ptrs and tally
1006 szn indblk+1-* any input at all?
1007 tze in3680-* no, done
1008 rem
1009 lda indblk+1-* get the tally
1010 rem
1011 ldx2 indblk-* get ptr to input bffr
1012 tsy a.g010-*,* copybf copy this stuff
1013 tra 2 buffer address is in x3 already
1014 rem
1015 in3680 ldx3 in3693-* get ptr to last buffer in chain
1016 lda a.g016-*,* ctpte get target pte back
1017 sta a.g017-*,* .crbpe,*
1018 lda l.g004-* =bffrpy get replay flag
1019 orsa bf.flg,3 set in buffer
1020 rem
1021 ldx2 in3694-*
1022 iacx2 1 skip this block
1023 tra a.g003-*,* =int010
1024 rem
1025 in3693 bss 1
1026 rem
1027 in3694 bss 1
1028 in3695 bss 1
1029 indblk bss 2
1030 rem
1031 a.g001 ind indblk
1032 a.g002 ind hgeti
1033 a.g003 ind int010
1034 a.g004 ind getbfh
1035 a.g005 ind frelbf
1036 a.g006 ind getcmt
1037 a.g007 ind tabchr in copybf
1038 a.g008 ind delchr in copybf
1039 a.g009 ind bschar in copybf
1040 a.g010 ind copybf subroutine to copy input buffer into replay buffer
1041 a.g011 ind addnov
1042 a.g012 ind puteco
1043 a.g013 ind frebfh
1044 a.g014 ind setcct hsla mans cct setter
1045 a.g015 ind setbpt
1046 a.g016 ind ctpte in copybf
1047 a.g017 ind .crbpe,*
1048 rem
1049 l.g001 vfd 18/buftmk
1050 l.g002 ind 0,b.0
1051 l.g003 oct 000777
1052 l.g004 vfd 18/bffrpy
1053 l.g005 vfd 18/ntfrpn
1054 l.g006 vfd 18/bffbrk
1055 l.g007 zero bf.dta,b.0
1056 l.g008 vfd 18/tfofc
1057 l.g009 vfd 18/tfblak
1058 rem
1059 tmpchr bss 1 temporary storage for test char
1060 *
1061 * op to make gtinpt chain the real output chain
1062 * replay
1063 *
1064 in3700 null replay
1065 ldx3 t.rcp,1 get replay chain ptr
1066 szn t.ocp,1 make sure no output ready now
1067 tze 2
1068 die 17
1069 rem
1070 stx3 t.ocp,1 set as head of chain
1071 stz t.rcp,1 zero replay chain ptr
1072 rem
1073 iacx2 1 next block please
1074 tra a.g003-*,* =int010
1075 *
1076 * dump the replay chain, if any
1077 * dmprpy
1078 *
1079 in3800 null dmprpy
1080 lda t.rcp,1 get ptr
1081 tze in3810-* none, done
1082 rem
1083 tsy a.g005-*,* =frelbf
1084 stz t.rcp,1 freed
1085 rem
1086 in3810 iacx2 1 next block
1087 lda l.g005-* =^tfrpon
1088 ansa t.flg2,1 replay not on now
1089 tra a.g003-*,* =int010
1090 *
1091 * op to prepare newline and delays for output now
1092 * prepnl
1093 *
1094 in3900 null
1095 ilq bufsiz allocate buffer for the nl
1096 tsy a.g004-*,* =getbfh
1097 die 18
1098 rem
1099 sta in3994-* save absolute address of buffer
1100 stx3 in3991-* save virtual addr of buffer
1101 stx2 in3992-* save x2 for awhile
1102 rem
1103 stz in3993-* init the tally for the buffer
1104 rem
1105 cx3a setup x3 with char addressing too
1106 iaa bf.dta offset of data in buffer
1107 ora l.g002-* =0b.0 char bits
1108 cax3 back into x3
1109 rem
1110 tsy a.g006-*,* getcmt get cmt pointer
1111 lda 0,2,b.1 get the cr char from the cmt
1112 cmpa l.g003-* =000777 no char?
1113 tze in3910-* yes, dont use it
1114 rem
1115 sta 0,3,b.0 put cr into buffer
1116 iacx3 0,b.1 bump ptr
1117 aos in3993-* bump tally
1118 rem
1119 in3910 lda 0,2,b.0 get the nl char
1120 sta 0,3,b.0 put the char into the buffer
1121 iacx3 0,b.1 bump the ptr
1122 aos in3993-* bump the tally
1123 rem
1124 ilq 0 get the pad for ascii null
1125 rem
1126 lda t.type,1 get the type of this guy
1127 icmpa 2 is it 1050?
1128 tze in3913-* yes
1129 icmpa 3 is it 2741?
1130 tnz in3915-* no
1131 in3913 ila -17 more delays for ebcdic types
1132 ilq 61 octal 75 is idle for 1050/2741
1133 tra in3920-*
1134 rem
1135 in3915 ila -8 get the count of pads to send
1136 in3920 stq 0,3,b.0 deposit for idle
1137 iacx3 0,b.1 bump ptr
1138 aos in3993-* count tally
1139 iaa 1 decrement count
1140 tnz in3920-* loop
1141 rem
1142 ldx3 in3991-* reload ptr to buffer
1143 lda in3993-* get the correct tally
1144 sta bf.tly,3 save in buffer
1145 rem
1146 lda t.ocp,1 get head of chain
1147 sta bf.nxt,3 make head ptr nxt in our buffer
1148 ldx3 in3994-* get absolute address back
1149 stx3 t.ocp,1 make us head now
1150 rem
1151 ldx2 in3992-* reload op block ptr
1152 iacx2 1 skip the block
1153 tra a.g003-*,* =int010
1154 rem
1155 in3991 bss 1
1156 in3992 bss 1
1157 in3993 bss 1
1158 in3994 bss 1
1159 *
1160 * op to test replay chain ptr
1161 * tstrpy
1162 *
1163 in4000 null
1164 szn t.rcp,1 any replay chain?
1165 tnz in4010-* yes
1166 rem
1167 ldx2 1,2 no, take fail addr
1168 tra a.g003-*,* =int010
1169 rem
1170 in4010 iacx2 2 ok skip block
1171 tra a.g003-*,* =int010
1172 *
1173 * op to insert char in echo buffer
1174 * echo
1175 *
1176 in4100 null
1177 ldq 1,2 get character
1178 tsy a.g012-*,* =puteco
1179 iacx2 2 next op block
1180 tra a.g003-*,* =int010
1181 *
1182 * initialize cct to specific table
1183 * setcct <addr of cct to be used>
1184 *
1185 h.baw equ 8 base address word in hwcm
1186 *
1187 in4200 lda t.line,1 be sure it is hsla
1188 arl 9
1189 tze in4201-* lsla, ignore
1190 lda 1,2 get arg
1191 tsy a.g014-*,* =setcct
1192 in4201 iacx2 2 go to next op block
1193 tra a.g003-*,* =int010
1194 *
1195 * dump input message up to break char
1196 * dmpmsg
1197 *
1198 in4300 lda t.icp,1 get head of input chain
1199 tze in4310-* there isn't any, we're done
1200 sta in4391-* save absolute address
1201 tsy a.g015-*,* setbpt
1202 cax3
1203 lda bf.flg,3 find out if this is end
1204 ana l.g006-* =bffbrk
1205 sta in4390-* save for later
1206 lda bf.nxt,3 get forward pointer
1207 sta t.icp,1 new head of chain
1208 lda bf.siz,3 get buffer size
1209 arl 15 size-1
1210 iera -1 add 1 and negate
1211 asa t.icpl,1 subtract from chain length
1212 lda in4391-* get absolute address for freeing
1213 ilq 0
1214 tsy a.g013-*,* frebfh
1215 szn in4390-* was it last in message?
1216 tze in4300-* no, look at new head
1217 in4310 szn t.icp,1 is head of chain zero?
1218 tnz 2 no, that's cool
1219 stz t.ilst,1 make sure no one thinks there's a chain
1220 iacx2 1 done, go to next block
1221 tra a.g003-*,* =int010
1222 rem
1223 in4390 bss 1 used to hold latest value of bffbrk
1224 in4391 bss 1 holds absolute buffer address
1225 *
1226 * setlcl - set a local variable
1227 *
1228 in4400 ldx3 1,2 addr of variable
1229 tsy cvaddr-* get real address
1230 lda 2,2 new value
1231 sta 0,3 this is the job
1232 iacx2 3
1233 tra a.g003-*,* =int010
1234 *
1235 * addlcl - add value to a local variable
1236 *
1237 in4500 ldx3 1,2 addr of variable
1238 tsy cvaddr-*
1239 lda 0,3 starting value
1240 ldq 2,2 increvemt
1241 tsy a.g011-*,* addnov do the add
1242 sta 0,3 and store result
1243 iacx2 3
1244 tra a.g003-*,* =int010
1245 *
1246 * tstlcl - test local variable and goto if equal
1247 *
1248 in4600 ldx3 1,2 addr of variable
1249 tsy cvaddr-*
1250 lda 2,2 test val
1251 cmpa 0,3
1252 tze in4601-* do the goto
1253 iacx2 4
1254 tra a.g003-*,* =int010
1255 in4601 ldx2 3,2 get branch addr
1256 tra a.g003-*,* =int010
1257 *
1258 * setlcf - set flag in local variable
1259 *
1260 in4700 ldx3 1,2 addr of variable
1261 tsy cvaddr-*
1262 lda 2,2 new bits to set
1263 orsa 0,3 set them
1264 iacx2 3
1265 tra a.g003-*,* =int010
1266 *
1267 * clrlcf - clear flag in local variable
1268 *
1269 in4800 ldx3 1,2 addr of variable
1270 tsy cvaddr-*
1271 ila -1
1272 era 2,2 get invverted mask
1273 ansa 0,3 turn off bits
1274 iacx2 3
1275 tra a.g003-*,* =int010
1276 *
1277 * tstlcf - test flag in local variable and goto if on
1278 *
1279 in4900 ldx3 1,2 addr of variable
1280 tsy cvaddr-*
1281 lda 2,2 bits to test
1282 ana 0,3 test them
1283 cmpa 2,2 all on?
1284 tze in4901-* yes
1285 iacx2 4
1286 tra a.g003-*,* =int010
1287 in4901 ldx2 3,2 get place to go
1288 tra a.g003-*,* =int010
1289 *
1290 * setlcv - set local variable from another one
1291 *
1292 in5000 ldx3 1,2 address of target
1293 tsy cvaddr-*
1294 stx3 in5001-*
1295 ldx3 2,2 address of source
1296 tsy cvaddr-*
1297 lda 0,3 pick up data
1298 sta in5001-*,*
1299 iacx2 3
1300 tra a.g003-*,* =int010
1301 in5001 bss 1
1302 *
1303 * subroutine to get address of local variables.
1304 * a positve number is a real address.
1305 * a negative number is a tib externion offset, and is converted
1306 * to a real address.
1307 * entered with address in x3
1308 *
1309 cvaddr subr cva
1310 cx3a
1311 icmpa 0 test for minus
1312 tpl cvaret-* normal address
1313 szn t.elnk,1 be sure there is tib extension
1314 tnz 2
1315 die 14
1316 iera -1 invert offset
1317 iaa 1
1318 ada t.elnk,1 now have real address
1319 cax3
1320 cvaret return cvaddr
1321 *
1322 * calasm - call an assembler subr from control tables
1323 *
1324 in5100 cx2a
1325 iaa 3 get param list addr
1326 cax3 store here for call
1327 ada 2,2 get addr of opblock after params
1328 sta in5101-* save for return
1329 ldx2 2,2 load param count
1330 tsy -2,3* and call subr
1331 cx2a check return value
1332 tnz a.g003-*,* subr set return addr
1333 ldx2 in5101-* continue in line
1334 tra a.g003-*,* =int010
1335 in5101 bss 1
1336 *
1337 * bkptop - breakpoint ecountered
1338 *
1339 in5200 tsy a.h002-*,* =brkhit, see what to do
1340 tra a.h003-*,* =int011, dont break, a contains op
1341 lda l.h002-* =tfbkpt, set break flag
1342 orsa t.flg3,1
1343 tra a.h004-*,* =int300, exit thru wait opblock
1344 *
1345 * linctl - checks to see if test state call was caused
1346 * by a line_control order from cs
1347 *
1348 in5300 tsy a.h005-*,* =lctlck, dia man entry to check
1349 tra in5301-* not a line control call
1350 stx3 in5302-* save temporarily
1351 ldx3 1,2 where to store data
1352 tsy cvaddr-*
1353 cx2a save opblock addr
1354 ldx2 in5302-* address of line_control data
1355 ldq 0,2 copy 4 words
1356 stq 0,3
1357 ldq 1,2
1358 stq 1,3
1359 ldq 2,2
1360 stq 2,3
1361 ldq 3,2
1362 stq 3,3
1363 iaa 3 address of next opblock
1364 cax2
1365 tra a.g003-*,* =int010
1366 in5301 ldx2 2,2 take failuure addr
1367 tra a.g003-*,*
1368 in5302 bss 1
1369 *
1370 * linsta - line status to send signal to cs
1371 *
1372 in5400 ldx3 1,2 addr of data
1373 tsy cvaddr-*
1374 stx2 in5302-* save opblock addr
1375 cx3a
1376 cax2
1377 ldq l.h003-* =004124, linsta code with wordcount=4
1378 tsy a.h006-*,* =denq
1379 ldx2 in5302-* current opblock
1380 iacx2 2 advance to next
1381 tra a.g003-*,*
1382 *
1383 * tstlcv - compares two variables and does goto if equal
1384 *
1385 in5500 ldx3 1,2 addr of first
1386 tsy cvaddr-*
1387 stx3 in5501-* save first addr
1388 ldx3 2,2 addr of second
1389 tsy cvaddr-*
1390 lda 0,3 get second value
1391 cmpa in5501-*,* compare to first
1392 tze in5502-* got a match
1393 iacx2 4 on to next op
1394 tra a.h009-*,* =int010
1395 in5502 ldx2 3,2 get success addr
1396 tra a.h009-*,* =int010
1397 in5501 bss 1
1398 *
1399 * nullop - a no-operation, do nothing
1400 *
1401 in5600 iacx2 1
1402 tra a.h009-*,* =int010
1403 *
1404 * unwind - zeores all subroutine return addresses to return
1405 * highest level.
1406 *
1407 in5700 stz a.h007-*,* =incall
1408 stz t.reta,1
1409 tra in5600-*
1410 *
1411 * settmv - set time from a variable
1412 *
1413 in5800 ldx3 1,2 get variable address
1414 tsy cvaddr-*
1415 lda 0,3 pick up time
1416 tra a.h008-*,* =int601, join setime path
1417 *
1418 * retpms - return parameters
1419 *
1420 * in5900 null return parameters
1421 * ilq sparms put return params opcode in q
1422 * tsy idenk-*,* for dia enqueueing routine
1423 * iacx2 1 skip this block
1424 * tra a.h009-*,* =int010
1425 idenk ind denq dia enqueueing routine
1426 *
1427 * gotov - go to a variable
1428 *
1429 in6000 ldx3 1,2 get variable address
1430 tsy cvaddr-*
1431 ldx2 0,3 get target address
1432 tra a.h009-*,* =int010
1433 rem
1434 *
1435 * gocase - goto computed on case basis
1436 *
1437 in6100 null goto computed on case
1438 stx2 gocsva-* save opblock table IC
1439 lda 1,2 get varriable addr
1440 sta gocval-* save this addr in temp loc
1441 ana gocmsk-* see if tib ext is char or word
1442 cmpa gocmsk-* see if o760
1443 tnz in6101-* if not char in tib
1444 lda gocval-* word, so get addr from cvaddr
1445 ora gocend-* get this to a full o777XXX
1446 cax3 move this addr to x3
1447 tsy cvaddr-* go get the real address
1448 lda 0,3 get value of this varriable
1449 tra in6102-* have addr so go do rest
1450 in6101 lda gocval-* char so go get that addr
1451 tsy goctib-*,* get real addr
1452 tra in6102-* literal, so have value
1453 lda 0,3,b.0 go get value from tib
1454 in6102 sta gocval-* so store it
1455 lda 2,2 get addr compare list
1456 ora gocbyt-* set for byte addressing
1457 sta gocvls-* save addr in word
1458 ldx3 3,2 get addr of jmp list
1459 ldx2 gocvls-* get addr of cmp list to an index
1460 in6103 lda gocend-* get ond of list marker
1461 cmpa 0,3 check for end of string
1462 tze in6107-* if end return
1463 lda 0,2,b.0 get char from cmp list
1464 cmpa goclsn-* see if end of value list
1465 tze in6107-* end so return
1466 stx3 gocjls-* save our jmp addr, we need x3
1467 ana gocmsk-* o760, see if char or word
1468 cmpa gocmsk-* see if word o760
1469 tnz in6104-* if not char, tib ext word
1470 lda 0,2,b.0 word so get value back to get
1471 ora gocend-* get to a full o777XXX
1472 cax3 move addr to x3 for cvaddr
1473 tsy cvaddr-* go get real addr
1474 lda 0,3 get value of varriable
1475 tra in6105-* go do it
1476 in6104 lda 0,2,b.0 char so go get it.
1477 tsy goctib-*,* get tib ext addr if needed
1478 tra in6105-* literal so have it
1479 lda 0,3,b.0 get real value from tib ext
1480 in6105 null do rest of this entry
1481 ldx3 gocjls-* load our jmp list back
1482 cmpa gocval-* compare two values
1483 tze in6106-* if equal found it
1484 iacx2 0,b.1 incr x2 to next character
1485 iacx3 1 incr our index counter
1486 tra in6103-* try next value to compare
1487 in6106 null found our value
1488 ldx2 0,3 set x2 to the jmp addr
1489 tra a.h009-*,* go return =int010
1490 in6107 null value not in our table
1491 ldx2 gocsva-* get old opblock table IC
1492 iacx2 4 incr x2 to next opblock in table
1493 tra a.h009-*,* go return =int010
1494 gocsva bss 1 temp of old x2
1495 gocvls bss 1 varriable list addr
1496 gocjls bss 1 jump list addr
1497 gocend oct 777000 end of list records
1498 gocmsk oct 760 mask for char or word tib ext
1499 gocval bss 1 store value to match
1500 goclsn oct 000777 end of chrstr list
1501 goctib ind adbyte get character from tib
1502 gocsvt bss 1 save area
1503 gocbyt zero 0,b.0 set to byte addressing
1504 rem
1505 rem
1506 in6200 null setfld
1507 lda 2,2 get value to set
1508 sta 1,2* store it op block indirects through x1
1509 iacx2 3 on to next
1510 tra a.h009-*,* int010
1511 rem
1512 in6300 null addfld
1513 lda 1,2* get contents of tib field
1514 ldq 2,2 get increment
1515 tsy a.h010-*,* addnov
1516 sta 1,2* result to tib field op block indirects through x1
1517 iacx2 3 on to next
1518 tra a.h009-*,* int010
1519 rem
1520 in6400 null tstfld
1521 lda 2,2 get value to test against
1522 cmpa 1,2* compare it to field
1523 tze in6410-* equal, branch
1524 iacx2 4 else advance to next block
1525 tra a.h009-*,* int010
1526 in6410 ldx2 3,2 get branch address
1527 tra a.h009-*,* int010 go to it
1528 rem
1529 in6500 null meter1 add to single-word meter
1530 lda a.h011-* addr mincs
1531 tra mjoin-*
1532 rem
1533 in6600 null meter2 add to double-word meter
1534 lda a.h012-* addrmincd
1535 tra mjoin-*
1536 rem
1537 in6700 null meteru update meter & meter count
1538 lda a.h013-* addr mupdat
1539 mjoin null a contains address of subroutine
1540 mcall tra mret-* patched to nop by bind_fnp if metering enabled
1541 sta mentry-*
1542 lda t.metr,1 get pointer to metering area
1543 ada 1,2 plus offset of specified meter
1544 ldq 2,2 get increment from op block
1545 tsy mentry-*,* call subroutine
1546 mret iacx2 3 next op block
1547 tra a.h009-*,* int010
1548 rem
1549 in6800 null meterm meter synchronous message
1550 mcal2 tra mret2-* ***see note at mcall
1551 lda t.metr,1 get pointer to metering area
1552 szn 1,2 input or output?
1553 tnz in6810-* output
1554 iaa m.nim input, get correct offset
1555 ldx3 t.icp,1 and buffer pointer
1556 tra in6820-*
1557 in6810 iaa m.nom get offset for output metering
1558 ldx3 t.ocp,1 and buffer pointer
1559 in6820 tsy a.h014-*,* mmsg
1560 mret2 iacx2 2 next op block
1561 tra a.h009-*,* int010
1562 rem
1563 rem
1564 mentry ind 0 set to address of appropriate metering routine
1565 ttls subroutine to get address of carriage movement table
1566 rem
1567 getcmt subr get
1568 rem
1569 ldx2 a.h001-* =ctrl get addr of base of ctrl
1570 lda ct.dev,2 to get ptr to device tables
1571 ada t.type,1 add in the type of this guy
1572 iaa -1 correct for zero offset
1573 cax2 get ptr to ptr to correct devtbl
1574 lda 0,2 now have ptr to devtbl
1575 iaa dt.cmt add in offset of cmt
1576 ora l.h001-* =0b.0 add in char addressing
1577 cax2 put into x2
1578 return getcmt
1579 rem
1580 l.h001 zero 0,b.0
1581 l.h002 vfd o18/tfbkpt
1582 l.h003 oct 004124
1583 l.h004 oct 004000
1584 l.h005 oct 400000
1585 l.h006 oct 377777
1586 a.h001 ind ctrl
1587 a.h002 ind brkhit
1588 a.h003 ind int011
1589 a.h004 ind int300
1590 a.h005 ind lctlck
1591 a.h006 ind denq
1592 a.h007 ind incall
1593 a.h008 ind int601
1594 a.h009 ind int010
1595 a.h010 ind addnov
1596 a.h011 ind mincs
1597 a.h012 ind mincd
1598 a.h013 ind mupdat
1599 a.h014 ind mmsg
1600 ttls addnov - add the q to the a without causing overflow
1601 rem
1602 addnov subr ano,i
1603 sta anosva-* save "a" temporarily
1604 lda anosi-* get indicators
1605 ora l.h004-* =004000, inhibit overflow
1606 sta anotmp-*
1607 ldi anotmp-*
1608 stq anotmp-* the addend
1609 lda anosva-*
1610 ada anotmp-* why we're here
1611 tov 2 failed
1612 tra anoret-* add ok, return
1613 iaa 0
1614 tmi annovp-* answer was minus, set to +infinity
1615 lda l.h005-* =400000
1616 tra anoret-*
1617 annovp lda l.h006-* =377777
1618 anoret return addnov
1619 anotmp bss 1
1620 anosva bss 1
1621 ttls dcwcnt subroutine counts words in dcwlst op block
1622 *
1623 dcwcnt subr dcw
1624 *
1625 * calculates number of words in dcwlst op block and calls
1626 * appropriate subroutine to process it
1627 *
1628 maxdcw equ 6
1629 rem
1630 rem
1631 iacx2 1 point to first subop
1632 stx2 t.dcwa,1 store starting address
1633 *
1634 dcw010 null head of word-counting loop
1635 lda 0,2 get next word
1636 arl 9 isolate subop code
1637 cmpa l.e005-* =o777 are all 9 bits on?
1638 tze dcw080-* yes, all through with dcwlst
1639 arl 6 isolate 3 high-order bits
1640 icmpa 1 die if less than 1
1641 tmi dcw020-*
1642 icmpa 3 if output, handle specifically
1643 tze dcw030-*
1644 icmpa maxdcw check against maximum value
1645 tmi 2 less is okay
1646 dcw020 null unrecognizable subop
1647 die 6
1648 rem here if 1, 2, 4, or 5, just go to next word
1649 iacx2 1
1650 tra dcw010-*
1651 *
1652 dcw030 null output subop, count chars.
1653 cx2a switch x2 to 9-bit byte addr.
1654 ora l.e001-* 0,b.0
1655 cax2
1656 dcw040 null
1657 iacx2 0,b.1 next character
1658 dcw050 null
1659 lda 0,2,b.0 pick up char.
1660 cmpa l.e002-* =o000477
1661 tze dcw070-* end of output subop
1662 cmpa l.e003-* =o000400 literal?
1663 tmi dcw040-* yes, get next char.
1664 era l.e003-* else turn off high-order bit
1665 icmpa 1 check for printer
1666 tze dcw040-* or keyboard addressing
1667 icmpa 2 and go to next char
1668 tze dcw040-* in either case
1669 *
1670 icmpa 3 splice in output chain?
1671 tnz dcw060-*
1672 iacx2 0,b.1 if so, next char. must be
1673 lda 0,2,b.0 "end f output" or we die
1674 cmpa l.e002-* =o000477
1675 tze dcw070-*
1676 die 7
1677 *
1678 dcw060 null
1679 icmpa 4 repeat?
1680 tze 2 it had better be
1681 die 6
1682 iacx2 1,b.1 bump x2 by 3 chars
1683 tra dcw050-*
1684 *
1685 dcw070 null end of output subop
1686 cx2a restore word addressing to x2
1687 ana l.e004-* =o077777
1688 cax2
1689 iacx2 1 go to next word
1690 tra dcw010-*
1691 *
1692 dcw080 null end of dcwlst
1693 lda l.e007-* o777000
1694 ansa t.dcwl,1 zero t.dcwl but preserve skip count in upper char
1695 cx2a calculate dcwlst length
1696 sba t.dcwa,1
1697 orsa t.dcwl,1 and put it in tib
1698 lda t.line,1 get high-order bit of
1699 arl 9 line number
1700 tze dcw090-*
1701 tsy ihdcw-*,* hsla
1702 tra dcwbak-*
1703 dcw090 null
1704 tsy ildcw-*,* lsla
1705 *
1706 dcwbak return dcwcnt
1707 *
1708 *
1709 ihdcw ind hdcw hsla dcwlst processor
1710 ildcw ind ldcw lsla dcwlst processor
1711 *
1712 l.e001 zero 0,b.0 to switch to char addressing
1713 l.e002 oct 477
1714 l.e003 oct 400
1715 l.e004 oct 77777
1716 l.e005 oct 777
1717 l.e006 oct 514 control string byte - seteom
1718 l.e007 oct 777000
1719 ttls subroutines for copying into replay chain
1720 rem
1721 copybf subr cop,x2
1722 rem
1723 rem this routine is called to copy an input buffer
1724 rem into the replay chain
1725 rem inputs:
1726 rem x2 contains virtual pointer to input buffer
1727 rem a contains buffer tally
1728 rem
1729 rem outputs:
1730 rem x3 points to last buffer in replay chain
1731 rem but buffer ptw is restored to its original
1732 rem value
1733 rem
1734 iera -1 negate the tally
1735 iaa 1
1736 sta citly-* save it
1737 lda a.i002-*,* .crbpe,*
1738 sta cspte-* save "source" page table entry
1739 ldq 0,2,b.0 get first character now x2 will be
1740 rem temporarily invalid
1741 rem
1742 szn t.rcp,1 have we started building the chain yet?
1743 tnz cop010-* yes
1744 tsy cgetbf-* no, get a buffer to start it with
1745 rem
1746 stz cpos-* column position starts at zero
1747 ila 10 first tab stop is 10
1748 sta ctab-*
1749 tra cop030-*
1750 rem
1751 cop010 ldx3 clchar-* get pointer to next place to store char
1752 rem
1753 cop030 cmpq tabchr-* is it a tab?
1754 tnz cop070-* no
1755 lda t.flg,1 yes, are we in tab echo?
1756 cana l.i003-* =tftbec
1757 tnz cop050-* yes
1758 tsy cpchar-* no, put tab in buffer
1759 ldq delchr-* now we'll put in delays for the real tab
1760 ila 3 three of 'em
1761 rem
1762 cop040 tsy cpchar-* put one in replay buffer
1763 iaa -1
1764 tnz cop040-* do another if not finished
1765 rem
1766 tra cop090-* ok, done with this char
1767 rem
1768 cop050 lda ctab-* we're in tab echo, how many spaces?
1769 sba cpos-* this many
1770 ilq space
1771 cop060 tsy cpchar-* put it in
1772 iaa -1 more?
1773 tnz cop060-* yes
1774 rem
1775 lda ctab-* update column position
1776 sta cpos-*
1777 iaa 10
1778 sta ctab-* and next tab stop
1779 tra cop090-*
1780 rem
1781 cop070 tsy cpchar-* not a tab, store it
1782 lda t.flg,1 tab echo?
1783 cana l.i003-* =tftbec
1784 tze cop090-*
1785 lda cpos-* yes, update position
1786 cmpq bschar-* which way did we go?
1787 tnz cop080-*
1788 iaa -1 backspace
1789 tra 2
1790 cop080 iaa 1 forward
1791 sta cpos-*
1792 cmpa ctab-* did we reach next tab stop?
1793 tmi cop090-*
1794 ila 10 yes, update tab stop
1795 asa ctab-*
1796 rem
1797 cop090 lda cspte-* restore source pte
1798 sta a.i002-*,* .crbpe,*
1799 iacx2 0,b.1 bump input pointer
1800 ldq 0,2,b.0 get next character
1801 aos citly-* have we done it all?
1802 tnz cop030-* no, process next char
1803 rem
1804 stx3 clchar-* done, save character position in buffer
1805 ldx3 clast-* return buffer pointer for gtinpt
1806 return copybf
1807 eject
1808 cpchar subr cpc,aqx2
1809 rem
1810 rem this subroutine stores the character
1811 rem passed in the q into the replay chain
1812 rem pointed into by x3, updating x3 as appropriate
1813 rem
1814 lda ctpte-* use target pte
1815 sta a.i002-*,* .crbpe,*
1816 rem
1817 szn cotly-* is there room?
1818 tnz cpc010-* yes
1819 tsy cgetbf-* no, get a buffer
1820 rem x3, cotly, and clast are also updated now
1821 cpc010 stq 0,3,b.0
1822 iacx3 0,b.1
1823 aos cotly-*
1824 ldx2 clast-* get buffer pointer
1825 aos bf.tly,2 keep tally accurate
1826 return cpchar
1827 eject
1828 cgetbf subr cge,qx2
1829 rem
1830 rem this subroutine allocates a buffer
1831 rem for adding to the replay chain
1832 rem address at which first char is to be stored
1833 rem is returned in x3
1834 rem
1835 ilq bufsiz
1836 tsy a.i001-*,* getbfh
1837 die 18 bad news if we couldn't get one
1838 rem
1839 ilq -bufnch initialize negative tally
1840 stq cotly-*
1841 ldq a.i002-*,* .crbpe* hang on to pte
1842 rem set by getbfh
1843 rem
1844 szn t.rcp,1 is there a chain already?
1845 tnz cge010-* yes, ok
1846 sta t.rcp,1 no, this is the beginning of it
1847 tra cge020-*
1848 cge010 ldx2 ctpte-* use old target pte
1849 stx2 a.i002-*,* .crbpe,*
1850 sta clast-*,* set forward pointer in preceding buffer
1851 stq a.i002-*,* .crbpe* restore latest pte
1852 cge020 stx3 clast-* this is last one now
1853 stq ctpte-* and this is corresponding pte
1854 rem
1855 cx3a point to beginning of data
1856 ada l.i001-* =bf.dta,b.0
1857 cax3
1858 return cgetbf
1859 rem
1860 rem
1861 a.i001 ind getbfh
1862 a.i002 ind .crbpe,*
1863 rem
1864 l.i001 zero bf.dta,b.0
1865 *l.i002 unused
1866 l.i003 vfd 18/tftbec
1867 rem
1868 citly bss 1 residual source tally negative
1869 cotly bss 1 residual target tally negative
1870 cpos bss 1 current column position
1871 ctab bss 1 next tab stop
1872 clast bss 1 pointer to last buffer in replay chain
1873 clchar bss 1 pointer to next place for replay character
1874 cspte bss 1 source page table entry
1875 ctpte bss 1 target page table entry
1876 rem
1877 tabchr bss 1 tab character for this terminal
1878 delchr bss 1 pad character
1879 bschar bss 1 backspace
1880 ttls scanop subroutine processes both inscan and outscn block
1881 *
1882 scanop subr sca
1883 *
1884 sta isctyp-*,* set scan type
1885 stx2 iscsx2-*,* save x2 value during scan
1886 lda a.a014-*,* sccbpe
1887 sta a.a012-*,* .crbpe* get previous buffer pte so that
1888 rem saved value of pbufp will work
1889 lda 1,2 get control string address
1890 ora l.u001-* 0,b.0
1891 sta iscstr-*,* save control string byte address
1892 sca000 null get next byte from control string
1893 tsy iscnxt-*,* via subroutine
1894 tra a.a004-*,* sca260 end of control string
1895 tra sca004-* control byte = 5xx
1896 tra sca001-* error - literal in control string
1897 rem
1898 sca004 ana l.u002-* =o77 - isolate scan subop
1899 tnz 2 zero not allowed
1900 die 15 error in control string
1901 rem
1902 icmpa sca003 check for max subop
1903 tmi 2
1904 die 15 error in control string
1905 cax3
1906 adcx3 sca002-* add address of jump table
1907 tra 0,3* go to subop routine
1908 sca002 zero * address of jump table
1909 * subop jump table
1910 ind sca010 match for equal
1911 ind sca020 search for char
1912 ind sca030 ignore
1913 ind sca040 start bcc computation
1914 ind sca050 find end of chain
1915 ind sca060 compare bcc
1916 ind sca070 compare with mask
1917 ind sca080 rescan
1918 ind sca090 start lrc computation
1919 ind sca100 insert lrc
1920 ind sca110 compare lrc
1921 ind sca120 set last buffer in message flag
1922 ind sca130 replace current char
1923 ind sca140 compare with list
1924 ind sca150 move byte
1925 ind sca160 move byte with mask
1926 ind sca170 count chars
1927 ind sca180 search for match on either of two values
1928 ind sca190 turn on bits in char
1929 ind sca200 turn off bits in char
1930 ind sca210 check sync termination char
1931 ind sca220 move last two chars in message to tib extension
1932 ind sca230 skip to next char, update block check
1933 sca003 equ *-sca002 defines end of jump table
1934 rem
1935 sca001 die 15 error in control string
1936 eject
1937 sca010 null match for equal
1938 tsy ischkc-*,* get compare value
1939 die 15 error in control string
1940 sta scwrk1-* save byte for compare
1941 tsy isgtch-*,* pick up char.
1942 tra a.a005-*,* =sca300 no char, forget it
1943 *
1944 cmpa scwrk1-* see if it's the match char
1945 tnz a.a005-*,* =sca300 no
1946 tra sca000-* yes
1947 *
1948 *
1949 *
1950 *
1951 sca020 null search for char
1952 tsy ischkc-*,* get search value
1953 die 15 error in control string
1954 sta scwrk1-* save for compare
1955 tsy isgtch-*,* get char, without bumping pointer
1956 tra a.a005-*,* =sca300 if any
1957 sca022 null
1958 szn a.a009-*,* =scbccf are we in process of block check
1959 tze 2
1960 ersa a.a008-*,* =scbcc yes, do it
1961 cmpa scwrk1-* check against search char.
1962 tze sca000-* got it
1963 szn a.a007-*,* =sccntf are we in process of char count
1964 tze 2 no
1965 tsy a.a006-*,* =scount go ahead and count this char
1966 tsy iscnex-*,* no match, bump pointer
1967 tra a.a005-*,* =sca300 if not possible, fail
1968 tra sca022-* else, go look at char
1969 *
1970 *
1971 *
1972 sca230 null skip char, but update block check
1973 szn a.a009-*,* =scbccf block check in progress ?
1974 tze sca030-* no
1975 tsy isgtch-*,* get current char
1976 tra a.a005-*,* =sca300 end of data
1977 ersa a.a008-*,* =scbcc update block check
1978 rem
1979 sca030 null ignore
1980 tsy iscnex-*,* skip over next char.
1981 tra sca032-* trying to skip past end, add more room
1982 sca031 szn a.a007-*,* =sccntf are we in process of char count
1983 tze 2 no
1984 tsy a.a006-*,* =scount go ahead and count this char
1985 tra sca000-*
1986 rem
1987 sca032 szn isctyp-*,* check scan type
1988 tze a.a005-*,* =sca300 inscan, fail can't add
1989 rem
1990 ldx3 a.a001-*,* =pbufp
1991 lda bf.tly,3 get buffer tally
1992 ana l.k001-* =buftmk leave only tally
1993 icmpa bufnch compare to max tally
1994 tmi sca033-* ok, will fit here
1995 rem
1996 lda bf.flg,3 get buffer flags
1997 ana l.k002-* =bfflst save last flag
1998 sta scasva-*
1999 iera -1 invert it
2000 ansa bf.flg,3 make sure it's off
2001 rem
2002 cx3a we will save its absolute address
2003 tsy a.a011-*,* cvabs
2004 sta scaprv-*
2005 lda bf.nxt,3
2006 sta scasvn-* save forward pointer from current last buffer
2007 ilq bufsiz get a new one
2008 tsy a.i001-*,* =getbuf
2009 tra a.a005-*,* =sca300, scan fails
2010 sta scacur-* save absolute address of new buffer
2011 lda scasvn-* forward pointer from old last pointer
2012 sta bf.nxt,3 chain after current buffer
2013 ldq a.a012-*,* .crbpe* hang on to pte protect from setbpt
2014 lda scaprv-* get previous buffer back
2015 tsy a.a013-*,* setbpt
2016 cax2
2017 lda scacur-*
2018 sta bf.nxt,2 make old last buffer point at current
2019 stq a.a012-*,* .crbpe* restore pte
2020 rem
2021 lda scasva-* get saved a
2022 sta bf.flg,3 set last flag same as before
2023 rem
2024 ila 1
2025 sta a.a002-*,* =ptally and set to one
2026 cx3a get ptr to buffer
2027 iaa bf.dta add offset to data
2028 ora l.k003-* point to data
2029 sta a.a003-*,* =pdatp store
2030 stx3 a.a001-*,* =pbufp save buffer addr too
2031 rem
2032 aos bf.tly,3 bump tally up one
2033 tra sca031-*
2034 rem
2035 sca033 aos bf.tly,3
2036 tsy iscnex-*,* now bump pointers, we made room
2037 die 15 die if room not found
2038 tra sca031-*
2039 rem
2040 l.k001 vfd 18/buftmk
2041 l.k002 vfd 18/bfflst
2042 l.k003 zero 0,b.0 for character addressing
2043 a.a001 ind pbufp
2044 a.a002 ind ptally
2045 a.a003 ind pdatp
2046 a.a004 ind sca260
2047 a.a005 ind sca300
2048 a.a006 ind scount
2049 a.a007 ind sccntf
2050 a.a008 ind scbcc
2051 a.a009 ind scbccf
2052 a.a010 ind scend
2053 a.a011 ind cvabs
2054 a.a012 ind .crbpe,*
2055 a.a013 ind setbpt
2056 a.a014 ind sccbpe
2057 rem
2058 scaprv bss 1
2059 scacur bss 1
2060 scasvn bss 1
2061 scasva bss 1
2062 *
2063 *
2064 *
2065 sca040 null start bcc computation
2066 sca090 null start lrc computation
2067 aos a.u003-*,* scbccf turn flag on
2068 stz a.u004-*,* scbcc initialize block check char
2069 tra sca000-* all done
2070 *
2071 scwrk1 bss 1 work area
2072 *
2073 *
2074 *
2075 sca050 null find end of chain
2076 tsy a.a010-*,* scend
2077 tra sca300-* wasn't any chain
2078 tra sca000-* ok, get next byte
2079 *
2080 *
2081 *
2082 sca060 null compare bcc
2083 sca110 null compare lrc
2084 szn a.u003-*,* scbccf make sure we were doing it
2085 tnz 2
2086 die 10
2087 *
2088 stz a.u003-*,* scbccf turn off flag
2089 tsy a.u002-*,* =sgtchr get next char
2090 tra sca300-* if any
2091 *
2092 cmpa a.u004-*,* scbcc is block check correct?
2093 tnz sca300-* no
2094 tra sca000-* yes
2095 *
2096 *
2097 *
2098 sca070 null compare with mask
2099 tsy a.u001-*,* =schkcc get compare value
2100 die 15 error in control string
2101 sta scwrk2-* save compare value
2102 tsy a.u001-*,* =schkcc get mask value
2103 die 15 error in control string
2104 sta scwrk3-* save mask value
2105 ansa scwrk2-* mask compare value
2106 *
2107 tsy a.u002-*,* =sgtchr get next char
2108 tra sca300-* if we can
2109 ana scwrk3-* apply the mask
2110 cmpa scwrk2-* match?
2111 tnz sca300-* no, fail
2112 tra sca000-*
2113 *
2114 l.u001 zero 0,b.0
2115 l.u002 oct 77
2116 rem
2117 a.u001 ind schkcc
2118 a.u002 ind sgtchr
2119 a.u003 ind scbccf
2120 a.u004 ind scbcc
2121 rem
2122 scwrk2 bss 1 work area
2123 scwrk3 bss 1
2124 scwrk4 bss 1
2125 rem
2126 ipbufp ind pbufp
2127 iscstr ind sccstr
2128 iscnxt ind sccnxt
2129 iscsx2 ind scsvx2
2130 isctyp ind scntyp
2131 ischkc ind schkcc
2132 isgtch ind sgtchr
2133 iscnex ind scnext
2134 *
2135 *
2136 *
2137 sca080 null rescan - initialize pointers and flags
2138 tsy scinit-* call scan init subroutine
2139 tra sca000-*
2140 *
2141 *
2142 *
2143 sca100 null insert lrc
2144 rem
2145 szn scbccf-* were we doing bcc?
2146 tnz 2 ok
2147 die 15 no, kill it
2148 rem
2149 stz scbccf-* clear flag, used bcc value
2150 tsy isgtch-*,* get addr of byte
2151 die 15 error in control string
2152 rem
2153 lda scbcc-* get bcc value
2154 sta 0,3,b.0 put into msg
2155 tra sca000-*
2156 *
2157 *
2158 *
2159 sca120 null set last buffer in message flag
2160 ldx3 a.a001-*,* =pbufp get addr of current buffer
2161 lda l.s008-* =bfflst get last buffer in message flag
2162 orsa bf.flg,3 turn it on
2163 tra sca000-*
2164 *
2165 *
2166 *
2167 sca130 null replace current char
2168 tsy isgtch-*,* get byte address of next char in chain
2169 tra sca300-* none
2170 tsy ischkc-*,* get replace value
2171 die 15 error in control string
2172 sta 0,3,b.0 replace current char
2173 tra sca000-*
2174 *
2175 *
2176 *
2177 sca140 null compare with list
2178 tsy sgtchr-* get next char in chain
2179 tra sca300-* none - failure
2180 sta scwrk3-* save for compare
2181 sca144 tsy a.s003-*,* =sccnxt get value from control string
2182 tra sca300-* end of control string - failure
2183 tra sca300-* 5xx - failure
2184 tsy a.s002-*,* =adbyte check for 46x
2185 tra sca148-* not 46x
2186 lda 0,3,b.0 get tib byte value
2187 sca148 cmpa scwrk3-* match?
2188 tze sca146-* yes
2189 tra sca144-* keep looking
2190 sca146 tsy a.s003-*,* =sccnxt just pass by values
2191 tra sca260-* end of control string
2192 tra sca004-* 5xx
2193 tra sca146-*
2194 *
2195 *
2196 *
2197 sca150 null move byte
2198 tsy a.s003-*,* =sccnxt get 46x value
2199 tra 1
2200 sca152 die 15 error - must be 46x
2201 tsy a.s002-*,* =adbyte get byte address
2202 tra sca152-* not 46x
2203 stx3 scwrk2-* save byte address
2204 ila -1
2205 sca154 sta scwrk3-* prime mask area
2206 tsy sgtchr-* get next char and address
2207 tra sca300-* none
2208 ana scwrk3-* mask char
2209 ldx3 scwrk2-* get byte address
2210 sta 0,3,b.0 place in tib
2211 tra sca000-*
2212 *
2213 *
2214 *
2215 sca160 null move byte with mask
2216 tsy iscnxt-*,* get 46x value
2217 tra 1
2218 sca162 die 15 error - must be 46x
2219 tsy a.s002-*,* =adbyte get byte address
2220 tra sca162-* not 46x
2221 stx3 scwrk2-* save byte address
2222 tsy schkcc-* get mask value
2223 tra sca162-* error - in control string
2224 tra sca154-* same as move byte
2225 *
2226 *
2227 *
2228 sca170 null count chars
2229 tsy iscnxt-*,* get 46x value
2230 tra 1
2231 sca172 die 15 error - must be 46x
2232 tsy a.s002-*,* =adbyte get byte address
2233 tra sca172-* not 46x
2234 stx3 sccnta-* save byte address for count accumulation
2235 stz 0,3,b.0 zero count in tib
2236 aos sccntf-* set count flag
2237 tra sca000-*
2238 *
2239 *
2240 *
2241 sca180 null search for match on either of two values
2242 tsy schkcc-* get first search value
2243 die 15 error in control string
2244 sta scwrk3-* save for compare
2245 tsy schkcc-* get second search value
2246 die 15
2247 sta scwrk4-*
2248 tsy sgtchr-* get char, w/o bumping ptr
2249 tra sca300-* fail if none
2250 sca182 null
2251 szn scbccf-* are we in process of block check
2252 tze 2
2253 ersa scbcc-* yes, do it
2254 cmpa scwrk3-* check vs first value
2255 tze a.s001-*,* sca000 got it
2256 cmpa scwrk4-* check vs second value
2257 tze a.s001-*,* sca000 got it
2258 szn sccntf-* are we in process of char count
2259 tze 2
2260 tsy scount-* go ahead and count this char
2261 tsy iscnex-*,* no match, bump ptr
2262 tra sca300-* fail, no more chars
2263 tra sca182-* else, go look at char
2264 *
2265 *
2266 *
2267 sca190 null turn on bits in char
2268 tsy schkcc-* get bit pattern
2269 die 15 error - in control string
2270 sta scwrk2-* save
2271 tsy sgtchr-* get next char address
2272 tra sca300-* no next char
2273 lda scwrk2-* get bit pattern
2274 orsa 0,3,b.0 turn on bits
2275 tra a.s001-*,* =sca000 done
2276 *
2277 *
2278 *
2279 sca200 null turn off bits in char
2280 tsy schkcc-* get bit pattern
2281 die 15 error in control string
2282 sta scwrk2-* save
2283 tsy sgtchr-* get next char address
2284 tra sca300-* no next char
2285 lda scwrk2-* get bit pattern
2286 orsa 0,3,b.0 turn bits on
2287 ersa 0,3,b.0 now really turn them off
2288 tra a.s001-*,* =sca000
2289 *
2290 *
2291 *
2292 sca210 tsy schkcc-* get char from control string
2293 die 15 error in control string
2294 sta scwrk4-* save for compare
2295 stz sca216-* reset flag
2296 rem
2297 sca215 ldx3 a.s007-*,* pbufp get ptr to head of list
2298 stz sccbuf-* zero prev buf ptr
2299 sca211 lda bf.flg,3 get flag bits
2300 cana l.s008-* =bfflst last buffer in msg?
2301 tnz sca212-* yes, use this buffer
2302 rem
2303 szn bf.nxt,3 more in chain?
2304 tze sca212-* no, use this one
2305 rem
2306 cx3a get absolute address
2307 tsy a.s005-*,* cvabs
2308 sta sccbuf-* save ptr to this buffer
2309 lda bf.nxt,3 bump to next
2310 tsy a.s004-*,* setbpt
2311 cax3
2312 tra sca211-*
2313 rem
2314 sca212 stx3 a.s007-*,* pbufp remember where we are
2315 cx3a copy to a
2316 iaa bf.dta point at data
2317 ora l.s002-* with char addressing
2318 sta a.s008-*,* pdatp save
2319 rem
2320 lda bf.tly,3 get tally in buffer
2321 ana l.s001-* =buftmk only tally
2322 icmpa 2 at least two chars in this buffer?
2323 tmi sca214-* no, must use prev buffer
2324 rem
2325 iaa -2 backup to look at term char
2326 lrl 1 divide by two save bit
2327 asa pdatp-* add into ptr
2328 ldx3 pdatp-* get it
2329 rem
2330 lls 1 get bit back
2331 icana 1 on?
2332 tze sca213-* ok as is
2333 rem
2334 iacx3 0,b.1 bump ptr to odd char
2335 stx3 pdatp-* save ptr always
2336 sca213 szn sca216-* check flag
2337 tnz sca224-* move 2 chars
2338 lda 0,3,b.0 get the supposed term char
2339 cmpa scwrk4-* is this it?
2340 tze a.s001-*,* =sca000 yes, we got it...
2341 rem
2342 tra sca300-* fail
2343 rem
2344 rem since we know bcc was in last buffer, etx must be
2345 rem last char in this buffer.
2346 rem
2347 sca214 lda sccbuf-* get ptr to next-to-last buffer
2348 tze sca300-* fail - not two chars in message
2349 tsy a.s004-*,* setbpt
2350 sta sccntl-* save virtual address of buffer
2351 iaa bufsiz-1 point to last word
2352 ada l.s009-* =0b.1 and last char
2353 cax3 copy to index reg
2354 szn sca216-* check flag
2355 tnz sca226-* move 2 chars
2356 ldq 0,3,b.0 else get character for comparison
2357 ldx3 sccntl-* get address of buffer
2358 lda bf.nxt,3 get address of last buffer again
2359 tsy a.s004-*,* setbpt restore pte
2360 cmpq scwrk4-* now test the character
2361 tze a.s001-*,* =sca000 success
2362 tra sca300-* failure
2363 *
2364 sca216 bss 1 flag for move last two chars to tib
2365 *
2366 *
2367 *
2368 sca220 null move last two chars to tib extension
2369 stz sca216-* reset flag
2370 tsy sccnxt-* get 46x value
2371 tra 1 not 46x
2372 sca222 die 15 error in control string
2373 tsy adbyte-* get byte address
2374 tra sca222-* not 46x
2375 stx3 scwrk3-* save first char addr
2376 tsy sccnxt-* get second 46x value
2377 tra sca222-* not 46x
2378 tra sca222-* not 46x
2379 tsy adbyte-* get byte addr
2380 tra sca222-* not 46x
2381 stx3 scwrk4-* save second char addr
2382 aos sca216-* set flag
2383 tra sca215-* do search for last chars
2384 sca224 null return from search
2385 lda 0,3,b.0 get second to last char
2386 iacx3 0,b.1 bump to next char
2387 stx3 pdatp-* always save current ptr
2388 ldq 0,3,b.0 get last char
2389 tra sca227-* store into tib ext
2390 sca226 null return - last two chars split between buffers
2391 ldx2 0,3,b.0 get second to last char
2392 ldx3 sccntl-* get pointer to beginning of next-to-last
2393 lda bf.nxt,3 get last
2394 tsy a.s004-*,* setbpt restore pte
2395 cx2a get character into a
2396 ldx3 pdatp-* get data ptr - last buffer
2397 ldq 0,3,b.0 get last char
2398 sca227 null store two chars into tib ext
2399 ldx3 scwrk3-* place to store next to last
2400 sta 0,3,b.0 into tib ext
2401 ldx3 scwrk4-* and last char
2402 stq 0,3,b.0 into tib ext, too
2403 tra a.s001-*,* =sca000done
2404 *
2405 *
2406 *
2407 sca260 null scan was a success
2408 ldx2 scsvx2-* get scan block address
2409 iacx2 3 go to next block
2410 scabak null
2411 lda a.s006-*,* .crbpe,*
2412 sta sccbpe-* save pte in case of another scan
2413 return scanop
2414 *
2415 *
2416 *
2417 sca300 null general scan failure
2418 ldx2 scsvx2-* get scan block address
2419 ldx2 2,2 get branch point
2420 tra scabak-*
2421 *
2422 *
2423 l.s001 vfd 18/buftmk buffer tally mask
2424 l.s002 zero 0,b.0 for char addressing
2425 l.s003 oct 77777 for word addressing
2426 l.s004 oct 77 mask for 5xx values
2427 l.s005 oct 777 end of control string designator
2428 l.s006 oct 700 5xx mask
2429 l.s007 oct 500 test value
2430 l.s008 vfd 18/bfflst last buffer in message flag
2431 l.s009 ind 0,b.1
2432 rem
2433 a.s001 ind sca000
2434 a.s002 ind adbyte
2435 a.s003 ind sccnxt
2436 a.s004 ind setbpt
2437 a.s005 ind cvabs
2438 a.s006 ind .crbpe,*
2439 a.s007 ind pbufp
2440 a.s008 ind pdatp
2441 rem
2442 sccbpe bss 1 safe store for pte
2443 scbcc bss 1 cumulative block check char
2444 scbccf bss 1 block check in progress flag
2445 tmask bss 1 place to save masked char.
2446 scntyp bss 1 input or output scan indicator
2447 rem =0, input scan
2448 rem =1, output scan
2449 scsvx2 bss 1 save area for scan block address
2450 sccstr bss 1 control string byte address
2451 sccnta bss 1 byte address - char count accumulation
2452 sccntf bss 1 char count in progress flag
2453 sccbuf bss 1 absolute ptr to next-to-last buffer
2454 sccntl bss 1 virtual pointer to same
2455 ttls utilities for scan
2456 *
2457 * scount increments tib extension byte designated by count scan subop
2458 * max accumulated count = 511
2459 *
2460 scount subr sco,ax3
2461 ldx3 sccnta-* get accumulation byte address
2462 lda 0,3,b.0 get accumulation byte
2463 iaa 1 increment it
2464 ana l.s005-* =o777
2465 tze 2 overflow
2466 sta 0,3,b.0 place it back in tib
2467 return scount
2468 *
2469 * scinit subroutine initializes scan pointers
2470 *
2471 scinit subr sci
2472 lda t.icp,1 get input chain pointer
2473 szn scntyp-* check scan type - input or output
2474 tze sci010-* input
2475 lda t.ocp,1 get output chain pointer
2476 sci010 null
2477 tsy a.s004-*,* setbpt
2478 sta pbufp-* save virtual address
2479 szn pbufp-*
2480 tze scibak-* no chain, forget it
2481 stz ptally-* zero out scan tallies
2482 aos ptally-* pointing at char now
2483 iaa bf.dta point to data
2484 ora l.s002-* 0,b.0
2485 sta pdatp-* save data pointers
2486 scibak null
2487 stz scbccf-* zero block check flag
2488 stz sccntf-* zero char count in progress flag
2489 return scinit
2490 *
2491 * sgtchr uses pointers to find current char and return it in a
2492 * it does not advance the pointers
2493 * output - return1 = no more chars
2494 * return2 = current char in a
2495 *
2496 sgtchr subr sgt
2497 szn pbufp-* check buffer pointer
2498 tze sgtbak-* none exists
2499 rem
2500 ldx3 pdatp-*
2501 lda 0,3,b.0
2502 aos sgtchr-* did it
2503 rem
2504 sgtbak return sgtchr
2505 *
2506 * schkcc gets next byte from control string and checks for 777,5xx values
2507 * if byte = 46x then its tib value is returned in a
2508 * output - return1 = byte in a = 777 or 5xx
2509 * return2 = byte in a
2510 *
2511 schkcc subr sch,x3
2512 tsy sccnxt-* get control string byte
2513 tra schbak-* 777
2514 tra schbak-* 5xx
2515 tsy adbyte-* check for 46x
2516 tra sch020-* not 46x
2517 lda 0,3,b.0 get byte value
2518 sch020 aos schkcc-* return2
2519 schbak null
2520 return schkcc
2521 *
2522 * scnext bumps character pointers
2523 * returns to location after call if no more chars,
2524 * otherwise puts char in a and returns two locations past call
2525 *
2526 scnext subr scn,x3
2527 *
2528 ldx3 pbufp-* any buffer at all?
2529 tze scnbak-* no, done
2530 rem
2531 lda bf.tly,3 get the buffer tally
2532 ana l.s001-* =buftmk only tally
2533 cmpa ptally-* any chars left to look at?
2534 tmi 2 no, over the limit now
2535 tnz scn020-* yes, process
2536 rem
2537 lda bf.flg,3 get flag bits
2538 cana l.s008-* =bfflst last buffer in msg?
2539 tnz scnbak-* yes, done
2540 rem
2541 lda bf.nxt,3 get fwd ptr
2542 tze scnbak-* none, give up
2543 rem
2544 tsy a.s004-*,* setbpt
2545 sta pbufp-* new buffer
2546 iaa bf.dta nake ptr to data
2547 ora l.s002-* add in char addressing
2548 sta pdatp-* save ptr
2549 stz ptally-*
2550 cax3 copy ptr to x3
2551 tra scn030-* finish up
2552 rem
2553 scn020 ldx3 pdatp-* load ptr to char
2554 iacx3 0,b.1 bump it
2555 stx3 pdatp-* save
2556 scn030 aos ptally-* bump tally
2557 lda 0,3,b.0 load char
2558 rem
2559 aos scnext-* indicate good bump
2560 scnbak return scnext
2561 *
2562 * sccnxt places next byte from scan control string into a
2563 * output - return1 = end of control string - byte in a = 777
2564 * return2 = byte in a = 5xx
2565 * return3 = byte in a = xxx
2566 *
2567 sccnxt subr scc,x2
2568 ldx2 sccstr-* get control string byte address
2569 lda 0,2,b.0 get control string byte
2570 cmpa l.s005-* =o777
2571 tze sccbak-* end of control string
2572 iacx2 0,b.1 advance to next byte
2573 stx2 sccstr-* save
2574 caq
2575 ana l.s006-* =o700
2576 cmpa l.s007-* =o500 - scan subop designator
2577 tze scc010-*
2578 aos sccnxt-* return 3
2579 scc010 aos sccnxt-* return 2
2580 cqa retrieve control string byte
2581 sccbak return sccnxt
2582 *
2583 *
2584 * scend implements the end-of-chain subop, setting
2585 * the pointers to the last character in the chain
2586 * output - return1 = no chain
2587 * return2 = found it
2588 *
2589 scend subr sce
2590 ldx3 pbufp-* get buffer pointer
2591 tze scebak-* fail if no chain
2592 sce010 lda bf.flg,3 see if this is last one
2593 cana l.t006-* bfflst
2594 tnz sce020-* yes it is
2595 szn bf.nxt,3 not marked as such, is there another?
2596 tze sce020-* no, use this one
2597 lda bf.nxt,3 yes, on to next
2598 tsy a.s004-*,* setbpt
2599 cax3
2600 tra sce010-*
2601 sce020 null
2602 stx3 pbufp-* this is current one now
2603 lda bf.tly,3 get tally
2604 ana l.t007-* buftmk
2605 sta ptally-*
2606 rem
2607 iaa -1 less one for last char
2608 lrl 1 divide by two to get word offset
2609 ada pbufp-* make a pointer out of it
2610 ada l.t008-* bf.dta,b.0
2611 cax3 put into x3 for now
2612 lls 1 get low order bit back
2613 icana 1 is low order bit on?
2614 tze 2 nope, ok
2615 iacx3 0,b.1 bump by one char
2616 stx3 pdatp-*
2617 aos scend-* bump return pointer
2618 scebak return scend
2619 *
2620 *
2621 *
2622 even
2623 rem permanent scan pointers
2624 pbufp bss 1 virtual address of current buffer
2625 ptally bss 1
2626 pdatp bss 1 virtual address of current character
2627 *
2628 * subroutine to form an address in q of a byte in tib extension
2629 * input - a = char value from scan control string
2630 * output - return1 = char value not 46x
2631 * return2 = x3 contains byte address
2632 *
2633 adbyte subr adb,a
2634 caq save input value
2635 ana l.t001-* =o760 - check for 46x
2636 cmpa l.t002-* =o460
2637 tze adb010-* ok - form byte address
2638 tra adbbak-* input not 46x
2639 adb010 ldx3 t.elnk,1 get tib extension address
2640 tnz 2 one exists
2641 adb020 die 14
2642 lda 0,3 get length
2643 als 1 times 2 = char count
2644 sta adb100-*
2645 cqa
2646 ana l.t004-* =o17 - isolate byte designator
2647 cmpa adb100-* vs max + 1 byte position
2648 tmi 2 ok - within range
2649 tra adb020-*
2650 caq
2651 cx3a
2652 ora l.t005-* =0,b.1 - make into byte address
2653 cax3
2654 adb030 iacx3 0,b.1 advance address - one byte
2655 iaq -1 decrement byte position
2656 tmi adb040-* all done
2657 tra adb030-*
2658 adb040 null
2659 aos adbyte-* advance return point
2660 adbbak return adbyte
2661 adb100 bss 1 work area
2662 rem
2663 rem
2664 l.t001 oct 760 mask
2665 l.t002 oct 460 byte position designator
2666 l.t003 oct 77 sub-buffer tally mask
2667 l.t004 oct 17 byte position mask
2668 l.t005 zero 0,b.1 address advance value
2669 l.t006 vfd 18/bfflst
2670 l.t007 vfd 18/buftmk
2671 l.t008 zero bf.dta,b.0
2672 l.t009 zero 0,b.0
2673 l.t010 oct 514 seteom
2674 *
2675 * Utility to build a message
2676 *
2677 bldutl subr bld
2678 ilq bufsiz
2679 tsy a.m003-*,* =getbfh get a bufsiz buffer
2680 tra bldret-* no buffers available
2681 sta bld099-* save absolute
2682 stx3 bld092-* and virtual address
2683 rem
2684 cx3a
2685 ada l.t008-* =bf.dtab.0 point to data
2686 sta bld096-* save
2687 rem
2688 lda 1,2 get control string address
2689 ora l.t009-* =0b.0
2690 sta a.m001-*,* =sccstr save for sccnxt subroutine
2691 rem
2692 ila -bufnch max number chars in buffer
2693 sta bld098-* save for count down
2694 stz bld090-* zero tally count
2695 bld010 tsy a.m002-*,* =sccnxt get next byte from control string
2696 tra bld040-* end of control string
2697 tra bld030-* control byte = 5xx
2698 tsy adbyte-* literal or tib byte?
2699 tra bld020-* must be a literal, store it
2700 lda 0,3,b.0 get the char from the tib
2701 bld020 ldx3 bld096-* get ptr to data in buffer
2702 sta 0,3,b.0 store char in buffer
2703 iacx3 0,b.1 bump ptr
2704 stx3 bld096-*
2705 rem
2706 aos bld090-* bump tally
2707 aos bld098-* decrement max tally
2708 tze bld050-* control string too long
2709 tra bld010-* ok, get next byte
2710 rem
2711 bld030 cmpa l.t010-* =o514 - check for seteom
2712 tnz bld050-* error - not seteom
2713 rem
2714 ldx3 bld092-* get buffer address
2715 lda l.t006-* =bfflst get last buffer in message flag
2716 orsa bf.flg,3 set on in buffer
2717 tra bld010-*
2718 rem
2719 bld040 ldx3 bld092-* get buffer address
2720 lda bld090-* get tally count
2721 tze bld050-* no chars placed in buffer
2722 orsa bf.tly,3 place tally in buffer
2723 aos bldutl-* successful return
2724 bldret return bldutl
2725 rem
2726 bld050 lda bld099-* get buffer address
2727 ilq 0
2728 tsy a.m004-*,* =frebfh return buffer - error or not used
2729 tra bldret-*
2730 rem
2731 bld090 bss 1 tally count
2732 bld092 bss 1 save area - virtual buffer address
2733 bld096 bss 1 save area - data pointer
2734 bld098 bss 1 max tally count
2735 bld099 bss 1 absolute buffer address
2736 rem
2737 a.m001 ind sccstr
2738 a.m002 ind sccnxt
2739 a.m003 ind getbfh
2740 a.m004 ind frebfh
2741 *
2742 intend null
2743 end