1 TITLE PRINTER ROUTINE FOR MUDDLE
\r
7 .GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL
\r
8 .GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT
\r
9 .GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID
\r
10 .GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT
\r
11 .GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1
\r
12 .GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR
\r
13 .GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH
\r
15 BUFLNT==100 ; BUFFER LENGTH IN WORDS
\r
17 FLAGS==0 ;REGISTER USED TO STORE FLAGS
\r
18 CARRET==15 ;CARRIAGE RETURN CHARACTER
\r
19 ESCHAR=="\ ;ESCAPE CHARACTER
\r
20 SPACE==40 ;SPACE CHARACTER
\r
21 ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT
\r
22 NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
\r
23 SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT
\r
24 SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
\r
25 FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL
\r
26 HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL
\r
27 TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL
\r
28 UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL
\r
29 ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL
\r
30 BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL
\r
39 \fMFUNCTION FLATSIZE,SUBR
\r
44 ;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
\r
45 ;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
\r
46 ;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX
\r
48 CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS
\r
55 JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE
\r
57 CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT
\r
58 JRST .+3 ; RADIX SUPPLIED
\r
59 PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN
\r
61 GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX
\r
63 JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE
\r
65 PUSHJ P,GETARG ; GET ARGS INTO A AND B
\r
66 FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM
\r
73 MFUNCTION UNPARSE,SUBR
\r
80 MOVE E,TP ;SAVE TP POINTER
\r
84 ;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE
\r
85 ;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED
\r
86 CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED
\r
88 PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN
\r
90 CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY
\r
93 CAIE 0,TFIX ;SEE IF RADIX IS FIXED
\r
95 MOVE C,3(AB) ;GET RADIX
\r
96 PUSHJ P,GETARG ;GET ARGS INTO A AND B
\r
97 UNPRGO: PUSHJ P,CIUPRS
\r
102 GTRADX: MOVE B,IMQUOTE OUTCHAN
\r
103 PUSH P,0 ;SAVE FLAGS
\r
104 PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN
\r
106 GETYP A,A ;CHECK TYPE OF CHANNEL
\r
108 JRST FUNCH1-1 ;IT IS A TP-POINTER
\r
109 MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN
\r
111 MOVE C,(B)+6 ;GET RADIX FROM STACK
\r
113 FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX
\r
114 MOVEI C,10. ;DEFAULT IF THIS IS THE CASE
\r
115 GETARG: MOVE A,(AB)
\r
120 MFUNCTION PRINT,SUBR
\r
122 PUSHJ P,AGET ; GET ARGS
\r
126 MFUNCTION PRINC,SUBR
\r
128 PUSHJ P,AGET ; GET ARGS
\r
132 MFUNCTION PRIN1,SUBR
\r
137 JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF
\r
140 MFUNCTION TERPRI,SUBR
\r
148 MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS
\r
149 PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL
\r
150 MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN
\r
151 PUSHJ P,PITYO ; PRINT IT OUT
\r
152 MOVEI A,12 ; LINE-FEED
\r
154 MOVSI A,TFALSE ; RETURN A FALSE
\r
156 JRST MPOPJ ; RETURN
\r
160 CAIN E,TCHAN ; CHANNEL?
\r
165 IOR 0,A ; RESTORE FLAGS
\r
168 TESTR1: HRRZ E,-4(B) ; GET IN FLAGS FROM CHANNEL
\r
169 TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD
\r
170 TRNE E,C.PRIN+C.OPN
\r
171 JRST BADCHN ; ITS A LOSER
\r
173 JRST PSHNDL ; DON'T HANDLE BINARY
\r
174 TLO ASCBIT ; ITS ASCII
\r
175 POPJ P, ; ITS A WINNER
\r
177 PSHNDL: PUSH TP,C ; SAVE ARGS
\r
179 PUSH TP,A ; PUSH CHANNEL ONTO STACK
\r
181 PUSHJ P,BPRINT ; CHECK BUFFER
\r
189 \f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B
\r
191 CIUPRS: SUBM M,(P) ; MODIFY M-POINTER
\r
192 MOVE E,TP ; SAVE TP-POINTER
\r
193 PUSH TP,[0] ; SLOT FOR FIRST STRING COPY
\r
195 PUSH TP,[0] ; AND SECOND STRING
\r
197 PUSH TP,A ; SAVE OBJECTS
\r
199 PUSH TP,$TTP ; SAVE TP POINTER
\r
202 MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE
\r
203 PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING
\r
204 FATAL UNPARSE BLEW IT
\r
205 PUSH TP,$TFIX ; MOVE IN ARGUMENT FOR ISTRING
\r
208 POP TP,E ; RESTORE TP-POINTER
\r
209 SUB TP,[1,,1] ;GET RID OF TYPE WORD
\r
210 MOVEM A,1(E) ; SAVE RESULTS
\r
214 POP TP,B ; RESTORE THE WORLD
\r
217 MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS
\r
219 JRST MPOPJ ; RETURN
\r
223 ; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,
\r
224 ; A,B THE TYPE-OBJECT PAIR
\r
227 MOVE E,TP ; SAVE POINTER
\r
228 PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT
\r
230 PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM
\r
232 MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG
\r
233 PUSHJ P,CUSET ; CONTINUE
\r
235 SOS (P) ; SKIP RETURN
\r
236 JRST MPOPJ ; RETURN
\r
238 ; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING
\r
239 ; NEEDED TO GET A RESULT.
\r
241 CUSET: PUSH TP,$TFIX ; PUSH ON RADIX
\r
244 PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE
\r
245 PUSH TP,A ; SAVE OBJECTS
\r
247 MOVSI C,TTP ; CONSTRUCT TP-POINTER
\r
248 HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER
\r
250 PUSH TP,C ; PUSH ON CHANNEL
\r
252 PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER
\r
253 POP TP,B ; GET IN TP POINTER
\r
254 MOVE TP,B ; RESTORE POINTER
\r
255 TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL
\r
256 JRST FLTGEN ; ITS A FLATSIZE
\r
257 MOVE A,UPB+3 ; RETURN STRING
\r
260 FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT
\r
266 ; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME
\r
267 ; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL
\r
270 MOVSI 0,SPCBIT ; SET UP FLAGS
\r
271 PUSHJ P,TPRT ; PRINT INITIALIZATION
\r
276 MOVEI FLAGS,0 ; SET UP FLAGS
\r
277 PUSHJ P,TPR1 ; INITIALIZATION
\r
278 PUSHJ P,IPRINT ; PRINT IT OUT
\r
282 MOVSI FLAGS,NOQBIT ; SET UP FLAGS
\r
283 PUSHJ P,TPR1 ; INITIALIZATION
\r
287 ; INITIALIZATION FOR PRINT ROUTINES
\r
289 TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
\r
290 PUSH TP,C ; SAVE ARGUMENTS
\r
292 PUSH TP,A ; SAVE CHANNEL
\r
294 MOVEI A,CARRET ; PRINT CARRIAGE RETURN
\r
296 MOVEI A,12 ; AND LF
\r
298 MOVE A,-3(TP) ; MOVE IN ARGS
\r
302 ; EXIT FOR PRINT ROUTINES
\r
304 TPRTE: POP TP,B ; RESTORE CHANNEL
\r
305 MOVEI A,SPACE ; PRINT TRAILING SPACE
\r
307 SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD
\r
308 POP TP,B ; RETURN WHAT WAS PASSED
\r
312 ; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES
\r
314 TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
\r
315 PUSH TP,C ; SAVE ARGS
\r
317 PUSH TP,A ; SAVE CHANNEL
\r
319 MOVE A,-3(TP) ; GET ARGS
\r
323 ; EXIT FOR PRIN1 AND PRINC ROUTINES
\r
325 TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL
\r
326 POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN
\r
333 MOVSI C,TATOM ; GET TYPE FOR BINARY
\r
334 MOVE 0,$SPCBIT ; SET UP FLAGS
\r
335 PUSHJ P,TPRT ; PRINT INITIALIZATION
\r
336 PUSHJ P,CPATOM ; PRINT IT OUT
\r
341 MOVEI FLAGS,0 ; SET UP FLAGS
\r
342 PUSHJ P,TPR1 ; INITIALIZATION
\r
343 PUSHJ P,CPATOM ; PRINT IT OUT
\r
348 MOVSI FLAGS,NOQBIT ; SET UP FLAGS
\r
349 PUSHJ P,TPR1 ; INITIALIZATION
\r
350 PUSHJ P,CPATOM ; PRINT IT OUT
\r
354 ; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE
\r
355 ; CHARACTER IS IN C.
\r
359 PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD
\r
361 MOVE A,D ; MOVE IN CHARACTER FOR PITYO
\r
363 MOVE A,$TCHRST ; RETURN THE CHARACTER
\r
372 MOVSI 0,SPCBIT ; SET UP FLAGS
\r
373 PUSHJ P,TPRT ; PRINT INITIALIZATION
\r
374 PUSHJ P,CPCHST ; PRINT IT OUT
\r
379 MOVEI FLAGS,0 ; SET UP FLAGS
\r
380 PUSHJ P,TPR1 ; INITIALIZATION
\r
381 PUSHJ P,CPCHST ; PRINT IT OUT
\r
386 MOVSI FLAGS,NOQBIT ; SET UP FLAGS
\r
387 PUSHJ P,TPR1 ; INITIALIZATION
\r
388 PUSHJ P,CPCHST ; PRINT IT OUT
\r
392 CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE
\r
394 PUSH P,0 ; ATOM CALLER ROUTINE
\r
398 CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE
\r
400 PUSH P,0 ; STRING CALLER ROUTINE
\r
406 AGET: MOVEI FLAGS,0
\r
407 SKIPL E,AB ; COPY ARG POINTER
\r
408 JRST TFA ;NO ARGS IS AN ERROR
\r
409 ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL
\r
411 AGET1: MOVE E,AB ; GET COPY OF AB
\r
414 COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL
\r
416 JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING
\r
417 CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR
\r
419 MOVE A,(E) ;GET CHANNEL
\r
423 DEFCHN: MOVE B,IMQUOTE OUTCHAN
\r
425 PUSH P,FLAGS ;SAVE FLAGS
\r
426 PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN
\r
429 NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI
\r
431 MOVE C,(AB) ; GET ARGS
\r
435 ; HERE IF USING A PRINTB CHANNEL
\r
437 BPRINT: TLO FLAGS,BINBIT
\r
438 SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?
\r
441 ; HERE TO GENERATE A STRING BUFFER
\r
444 MOVEI A,BUFLNT ; GET BUFFER LENGTH
\r
445 PUSHJ P,IBLOCK ; MAKE A BUFFER
\r
446 MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE
\r
448 SETOM (B)) ; -1 THE BUFFER
\r
454 MOVEM B,BUFSTR(C) ; STOR BYTE POINTER
\r
455 MOVE 0,[TCHSTR,,BUFLNT*5]
\r
456 MOVEM 0,BUFSTR-1(C)
\r
463 IPRINT: PUSH P,C ; SAVE C
\r
464 PUSH P,FLAGS ;SAVE PREVIOUS FLAGS
\r
465 PUSH TP,A ;SAVE ARGUMENT ON TP-STACK
\r
468 INTGO ;ALLOW INTERRUPTS HERE
\r
470 GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM
\r
471 SKIPE C,PRNTYP+1(TVP) ; USER TYPE TABLE?
\r
473 NORMAL: CAIG A,NUMPRI ;PRIMITIVE?
\r
474 JRST @PRTYPE(A) ;YES-DISPATCH
\r
475 JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
\r
477 ; HERE FOR USER PRINT DISPATCH
\r
479 PRDISP: ADDI C,(A) ; POINT TO SLOT
\r
481 SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
\r
482 JRST PRDIS1 ; APPLY EVALUATOR
\r
483 SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
\r
487 PRDIS1: PUSH P,C ; SAVE C
\r
488 PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND
\r
489 PUSH TP,IMQUOTE OUTCHAN
\r
495 POP P,C ; RESTORE C
\r
496 PUSH TP,(C) ; PUSH ARGS FOR APPLY
\r
500 MCALL 2,APPLY ; APPLY HACKER TO OBJECT
\r
502 PUSHJ P,SSPEC1 ;UNBIND OUTCHAN
\r
503 SUB TP,[6,,6] ; POP OFF STACK
\r
506 ; PRINT DISPATCH TABLE
\r
508 DISTBL PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
\r
509 [TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
\r
510 [TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]
\r
511 [TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]
\r
512 [TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]]
\r
514 PUNK: MOVE C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
\r
515 GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B
\r
516 LSH B,1 ; MULTIPLY BY TWO
\r
517 HRL B,B ; DUPLICATE IT IN THE LEFT HALF
\r
518 ADD C,B ; INCREMENT THE AOBJN-POINTER
\r
519 JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE
\r
521 MOVE B,-2(TP) ; MOVE IN CHANNEL
\r
522 PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM
\r
523 MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS
\r
525 MOVE A,(C) ; GET TYPE-ATOM
\r
527 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
529 PUSHJ P,IPRINT ; PRINT ATOM-NAME
\r
530 SUB TP,[2,,2] ; POP STACK
\r
531 MOVE B,-2(TP) ; MOVE IN CHANNEL
\r
532 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
533 MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER
\r
534 HRRZ A,(C) ; GET THE STORAGE-TYPE
\r
536 CAIG A,NUMSAT ; SKIP IF TEMPLATE
\r
537 JRST @UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE
\r
538 JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE
\r
540 DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]
\r
541 [SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]
\r
542 [SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]
\r
545 ; SELECK AN ILLEGAL
\r
547 ILLCH: MOVEI B,-1(TP)
\r
550 \f; PRINT INTERRUPT HANDLER
\r
552 PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B
\r
555 PUSHJ P,PITYO ; SAY "FUNNY TYPE"
\r
557 MOVE B,MQUOTE HANDLER
\r
558 PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT
\r
560 PUSHJ P,IPRINT ; PRINT THE TYPE NAME
\r
561 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
562 MOVE B,-2(TP) ; GET CHANNEL
\r
563 PUSHJ P,SPACEQ ; SPACE MAYBE
\r
564 SKIPN B,(TP) ; GET ARG BACK
\r
566 MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW
\r
568 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
570 PUSHJ P,IPRINT ; PRINT THE INT FUNCTION
\r
571 SUB TP,[2,,2] ; POP CHANNEL OFF
\r
576 PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
580 MOVSI A,TATOM ; AND NAME
\r
581 MOVE B,MQUOTE IHEADER
\r
582 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
585 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
586 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
587 SKIPN B,-2(TP) ; INT HEADER BACK
\r
589 MOVE A,INAME(B) ; GET NAME
\r
592 SUB TP,[2,,2] ; CLEAN OFF STACK
\r
596 ; PRINT ASSOCIATION BLOCK
\r
598 ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)
\r
599 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
600 PUSHJ P,PRETIF ; MAKE ROOM AND PRINT
\r
601 SKIPA C,[-3,,0] ; # OF FIELDS
\r
602 ASSLP: PUSHJ P,SPACEQ
\r
603 MOVE D,(TP) ; RESTORE GOODIE
\r
604 ADD D,ASSOFF(C) ; POINT TO FIELD
\r
605 MOVE A,(D) ; GET IT
\r
607 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
609 PUSHJ P,IPRINT ; AND PRINT IT
\r
610 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
614 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
615 PUSHJ P,PRETIF ; CLOSE IT
\r
621 \f; PRINT TYPE-C AND TYPE-W
\r
623 PTYPEW: HRRZ A,(TP) ; POSSIBLE RH
\r
625 MOVE C,MQUOTE TYPE-W
\r
628 PTYPEC: HRRZ B,(TP)
\r
630 MOVE C,MQUOTE TYPE-C
\r
637 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
638 PUSHJ P,RETIF ; ROOM TO START?
\r
643 POP TP,B ; GET NAME
\r
645 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
647 PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT
\r
648 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
649 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
650 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
651 MOVE A,-1(P) ; TYPE CODE
\r
653 HRLI A,(A) ; MAKE SURE WINS
\r
654 ADD A,TYPVEC+1(TVP)
\r
655 JUMPL A,PTYPX1 ; JUMP FOR A WINNER
\r
657 PUSH TP,EQUOTE BAD-TYPE-CODE
\r
660 PTYPX1: MOVE B,1(A) ; GET TYPE NAME
\r
661 HRRZ A,(A) ; AND SAT
\r
663 MOVEM A,-1(P) ; AND SAVE IT
\r
665 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
667 PUSHJ P,IPRINT ; OUT IT GOES
\r
668 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
669 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
670 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
671 MOVE A,-1(P) ; GET SAT BACK
\r
673 MOVSI A,TATOM ; AND PRINT IT
\r
674 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
677 SUB TP,[2,,2] ; POP OFF STACK
\r
678 SKIPN B,(P) ; ANY EXTRA CRAP?
\r
681 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
685 PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT
\r
687 PUSHJ P,IPRINT ; PRINT EXTRA
\r
688 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
691 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
693 SUB P,[2,,2] ; FLUSH CRUFT
\r
696 \f; PRINT PURE CODE POINTER
\r
699 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
705 MOVSI A,TATOM ; PRINT SUBR CALL
\r
706 MOVE B,MQUOTE PCODE
\r
707 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
710 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
711 PUSHJ P,SPACEQ ; MAYBE SPACE?
\r
712 HLRZ A,-2(TP) ; OFFSET TO VECTOR
\r
713 ADD A,PURVEC+1(TVP) ; SLOT TO A
\r
714 MOVE A,(A) ; SIXBIT NAME
\r
716 PUSHJ P,6TOCHS ; TO A STRING
\r
719 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
721 HRRZ B,-2(TP) ; GET OFFSET
\r
724 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
726 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
727 PUSHJ P,PRETIF ; CLOSE THE FORM
\r
731 \f; PRINT SUB-ENTRY TO RSUBR
\r
733 PENTRY: MOVE B,(TP) ; GET BLOCK
\r
734 GETYP A,(B) ; TYPE OF 1ST ELEMENT
\r
735 CAIE A,TRSUBR ; RSUBR, OK
\r
737 MOVSI A,TATOM ; UNLINK
\r
742 PENT2: MOVEI A,2 ; CHECK ROOM
\r
743 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
745 MOVEI A,"% ; SETUP READ TIME MACRO
\r
750 MOVE B,MQUOTE RSUBR-ENTRY
\r
751 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
755 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
756 MOVEI A,"' ; QUOTE TO AVOID EVALING IT
\r
761 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
768 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
769 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
773 PENT1: CAIN A,TATOM
\r
776 PUSH TP,EQUOTE BAD-ENTRY-BLOCK
\r
779 \f; HERE TO PRINT TEMPLATED DATA STRUCTURE
\r
781 TMPRNT: PUSH P,FLAGS ; SAVE FLAGS
\r
782 MOVE A,(TP) ; GET POINTER
\r
783 GETYP A,(A) ; GET SAT
\r
784 PUSH P,A ; AND SAVE IT
\r
785 MOVEI A,"{ ; OPEN SQUIGGLE
\r
786 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
787 PUSHJ P,PRETIF ; PRINT WITH CHECKING
\r
788 HLRZ A,(TP) ; GET AMOUNT RESTED OFF
\r
790 PUSH P,A ; AND SAVE IT
\r
791 MOVE A,-1(P) ; GET SAT
\r
792 SUBI A,NUMSAT+1 ; FIXIT UP
\r
794 ADD A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE
\r
795 JUMPGE A,BADTPL ; COMPLAIN
\r
796 HRRZS C,(TP) ; GET LENGTH
\r
798 SUB B,(P) ; FUDGE FOR RESTS
\r
799 MOVEI B,-1(B) ; FUDGE IT
\r
800 PUSH P,B ; AND SAVE IT
\r
802 TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST
\r
803 SOSGE (P) ; CHECK FOR ANY LEFT
\r
804 JRST TMPRN2 ; ALL DONE
\r
806 MOVE B,(TP) ; POINTER
\r
808 PUSHJ P,TMPLNT ; GET THE ITEM
\r
809 MOVE FLAGS,-3(P) ; RESTORE FLAGS
\r
810 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
812 PUSHJ P,IPRINT ; PRINT THIS ELEMENT
\r
813 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
814 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
815 SKIPE (P) ; IF NOT LAST ONE THEN
\r
816 PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE
\r
819 TMPRN2: SUB P,[4,,4]
\r
821 MOVEI A,"} ; CLOSE THIS GUY
\r
826 \f; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT
\r
827 ; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII
\r
829 PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION
\r
830 GETYP A,(A) ; CHECK FOR PURE RSUBR
\r
832 JRST PRSBRP ; PRINT IT SPECIAL WAY
\r
834 TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT
\r
838 MOVSI A,TRSUBR ; FIND FIXUPS
\r
840 HLRE D,1(B) ; -LENGTH OF CODE VEC
\r
841 PUSH P,D ; SAVE SAME
\r
843 MOVE D,MQUOTE RSUBR
\r
844 PUSHJ P,IGET ; GO GET THEM
\r
845 JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES
\r
846 PUSH TP,A ; SAVE FIXUP LIST
\r
849 MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR
\r
850 MOVE FLAGS,-1(P) ; RESTORE FLAGS
\r
851 MOVE B,-4(TP) ; GET CHANNEL FOR PITYO
\r
852 PUSHJ P,PITYO ; OUT IT GOES
\r
854 PRSBR1: MOVE B,-4(TP)
\r
855 PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER
\r
857 MOVE B,-4(TP) ; CHANNEL BACK
\r
858 MOVN E,(P) ; LENGTH OF CODE
\r
860 HRROI A,(P) ; POINT TO SAME
\r
861 PUSHJ P,DOIOTO ; OUT GOES COUNT
\r
863 MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS
\r
864 MOVE A,-2(TP) ; GET POINTER TO CODE
\r
866 PUSHJ P,DOIOTO ; IOT IT OUT
\r
868 ADDI E,1 ; UPDATE ACCESS
\r
870 SETZM ASTO(PVP) ; UNSCREW A
\r
872 ; NOW PRINT OUT NORMAL RSUBR VECTOR
\r
874 MOVE FLAGS,-1(P) ; RESTORE FLAGS
\r
876 MOVE B,-2(TP) ; GET RSUBR VECTOR
\r
877 PUSHJ P,PRBODY ; PRINT ITS BODY
\r
879 ; HERE TO PRINT BINARY FIXUPS
\r
881 MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS
\r
882 SKIPN A,(TP) ; LIST TO A
\r
883 JRST PRSBR5 ; EMPTY, DONE
\r
884 JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM
\r
885 ADDI E,1 ; FOR VERS
\r
887 PRSBR6: HRRZ A,(A) ; NEXT?
\r
890 CAIE B,TDEFER ; POSSIBLE STRING
\r
891 JRST PRSBR7 ; COULD BE ATOM
\r
892 MOVE B,1(A) ; POSSIBLE STRINGER
\r
894 CAIE C,TCHSTR ; YES!!!
\r
895 JRST BADFXU ; LOSING FIXUPS
\r
896 HRRZ C,(B) ; # OF CHARS TO C
\r
897 ADDI C,5+5 ; ROUND AND ADD FOR COUNT
\r
898 IDIVI C,5 ; TO WORDS
\r
900 JRST FIXLST ; COUNT FOR USE LIST ETC.
\r
902 PRSBR7: GETYP B,(A) ; GET TYPE
\r
907 FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL
\r
913 HRRZ A,(A) ; TO USE LIST
\r
917 JRST BADFXU ; LOSER
\r
918 MOVE C,1(A) ; GET LIST
\r
920 PRSBR8: JUMPE C,PRSBR9
\r
921 GETYP B,(C) ; TYPE OK?
\r
925 AOJA D,PRSBR8 ; LOOP
\r
927 PRSBR9: ADDI D,2 ; ROUND UP
\r
928 ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD
\r
932 PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS
\r
933 PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER
\r
936 PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS
\r
937 PUSHJ P,BFCLS1 ; FLUSH BUFFER
\r
938 MOVE B,-6(TP) ; CHANNEL BACK
\r
939 MOVEI C,BUFSTR-1(B) ; SETUP BUFFER
\r
940 PUSHJ P,BYTDOP ; FIND D.W.
\r
944 MOVE E,(P) ; LENGTH OF FIXUPS
\r
945 SETZB C,D ; FOR EOUT
\r
947 MOVE C,-2(TP) ; FIXUP LIST
\r
948 MOVE E,1(C) ; HAVE VERS
\r
949 PUSHJ P,EOUT ; OUT IT GOES
\r
951 PFIXU2: HRRZ C,(C) ; FIRST THING
\r
952 JUMPE C,PFIXU3 ; DONE?
\r
953 GETYP A,(C) ; STRING OR ATOM
\r
954 CAIN A,TATOM ; MUST BE STRING
\r
956 MOVE A,1(C) ; POINT TO POINTER
\r
957 HRRZ D,(A) ; LENGTH
\r
959 PUSH P,E ; SAVE REMAINDER
\r
966 PFXU1A: MOVE A,1(C) ; RESTORE POINTER
\r
967 HRRZ A,1(A) ; BYTE POINTER
\r
974 MOVE D,-1(P) ; LAST WORD
\r
979 MOVE E,(A) ; LAST WORD OF CHARS
\r
985 PADS: ASCII /#####/
\r
991 PFIXU4: HRRZ E,(C) ; GET CURRENT VAL
\r
993 PUSHJ P,ATOSQ ; GET SQUOZE
\r
995 TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING
\r
998 ; HERE TO WRITE OUT LISTS
\r
1000 PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE
\r
1002 HRRZ C,(C) ; POINT TO USES LIST
\r
1003 HRRZ D,1(C) ; GET IT
\r
1005 PFIXU6: TLCE D,400000 ; SKIP FOR RH
\r
1006 HRLZ E,1(D) ; SETUP LH
\r
1009 PUSHJ P,EOUT ; WRITE IT OUT
\r
1011 TRNE D,-1 ; SKIP IF DONE
\r
1014 TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS
\r
1017 JRST PFIXU2 ; DO NEXT
\r
1019 PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER
\r
1020 MOVN D,C ; PLUS SAME
\r
1021 ADDI C,BUFLNT ; WORDS USED TO C
\r
1022 JUMPE C,PFIXU7 ; NONE USED, LEAVE
\r
1023 MOVSS C ; START SETTING UP BTB
\r
1024 MOVN A,C ; ALSO FINAL IOT POINTER
\r
1025 HRR C,(TP) ; PDL POINTER PART OF BTB
\r
1027 HRLI D,C ; CONTINUE SETTING UP BTB
\r
1028 POP C,@D ; MOVE 'EM DOWN
\r
1031 HRRI A,@D ; OUTPUT POINTER
\r
1036 PUSHJ P,DOIOTO ; WRITE IT OUT
\r
1039 PFIXU7: SUB TP,[4,,4]
\r
1043 ; ROUTINE TO OUTPUT CONTENTS OF E
\r
1045 EOUT: MOVE B,-6(TP) ; CHANNEL
\r
1047 MOVE A,(TP) ; BUFFER POINTER
\r
1049 AOBJP A,.+3 ; COUNT AND GO
\r
1053 SUBI A,BUFLNT ; SET UP IOT POINTER
\r
1055 MOVEM A,(TP) ; RESET SAVED POINTER
\r
1061 PUSHJ P,DOIOTO ; OUT IT GOES
\r
1067 ; HERE IF UVECOR FORM OF FIXUPS
\r
1069 UFIXES: PUSH TP,$TUVEC
\r
1070 PUSH TP,A ; SAVE IT
\r
1072 UFIX1: MOVE B,-6(TP) ; GET SAME
\r
1073 PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER
\r
1074 HLRE C,(TP) ; GET LENGTH
\r
1077 HRROI A,(P) ; READY TO ZAP IT OUT
\r
1078 PUSHJ P,DOIOTO ; ZAP!
\r
1080 HLRE C,(TP) ; LENGTH BACK
\r
1083 ADDM C,ACCESS(B) ; UPDATE ACCESS
\r
1084 MOVE A,(TP) ; NOW THE UVECTOR
\r
1087 PUSHJ P,DOIOTO ; GO
\r
1093 RCANT: PUSH TP,$TATOM
\r
1094 PUSH TP,EQUOTE RSUBR-LACKS-FIXUPS
\r
1098 BADFXU: PUSH TP,$TATOM
\r
1099 PUSH TP,EQUOTE BAD-FIXUPS
\r
1102 PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE
\r
1103 PRBOD1: MOVEI C,1 ; PRINT CODE ALSO
\r
1108 MOVEI A,"[ ; START VECTOR TEXT
\r
1109 MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
\r
1112 MOVE B,(TP) ; RSUBR BACK
\r
1113 JUMPN C,PRSON ; GO START PRINTING
\r
1114 MOVEI A,"0 ; PLACE SAVER FOR CODE VEC
\r
1115 MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
\r
1118 PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR
\r
1120 JUMPGE B,PRSBR3 ; NO SPACE IF LAST
\r
1121 MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ
\r
1123 SKIPA B,(TP) ; GET BACK POINTER
\r
1124 PRSON: JUMPGE B,PRSBR3
\r
1125 GETYP 0,(B) ; SEE IF RSUBR POINTED TO
\r
1127 JRST .+3 ; JUMP IF RSUBR ENTRY
\r
1128 CAIE 0,TRSUBR ; YES!
\r
1129 JRST PRSB10 ; COULD BE SUBR/FSUBR
\r
1130 MOVE C,1(B) ; GET RSUBR
\r
1131 PUSH P,0 ; SAVE TYPE FOUND
\r
1132 GETYP 0,2(C) ; SEE IF ATOM
\r
1135 MOVE B,3(C) ; GET ATOM NAME
\r
1136 PUSHJ P,IGVAL ; GO LOOK
\r
1137 MOVE C,(TP) ; ORIG RSUBR BACK
\r
1139 POP P,0 ; DESIRED TYPE
\r
1140 CAIE 0,(A) ; SAME TYPE
\r
1143 MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION
\r
1144 CAME 0,3(B) ; WIN?
\r
1148 MOVEM A,(C) ; UNLINK
\r
1150 PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS
\r
1153 MOVE B,1(B) ; PRINT IT
\r
1154 PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT
\r
1157 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
1160 PRSB10: CAIE 0,TSUBR ; SUBR?
\r
1164 MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR
\r
1165 MOVE C,@-1(C) ; NAME OF IT
\r
1166 MOVEM C,1(B) ; SMASH
\r
1167 MOVSI C,TATOM ; AND TYPE
\r
1171 PRSBR3: MOVEI A,"]
\r
1173 PUSHJ P,PRETIF ; CLOSE IT UP
\r
1174 SUB TP,[2,,2] ; FLUSH CRAP
\r
1179 \f; HERE TO PRINT PURE RSUBRS
\r
1181 PRSBRP: MOVEI A,2 ; WILL "%<" FIT?
\r
1182 MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
\r
1189 MOVE B,MQUOTE RSUBR
\r
1190 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
1192 PUSHJ P,IPRINT ; PRINT IT OUT
\r
1193 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
1195 PUSHJ P,SPACEQ ; MAYBE SPACE
\r
1196 MOVEI A,"' ; QUOTE THE VECCTOR
\r
1198 MOVE B,(TP) ; GET RSUBR BODY BACK
\r
1199 PUSH TP,$TFIX ; STUFF THE STACK
\r
1201 PUSHJ P,PRBOD1 ; PRINT AND UNLINK
\r
1202 SUB TP,[2,,2] ; GET JUNK OFF STACK
\r
1203 MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
\r
1208 ; HERE TO PRINT ASCII RSUBRS
\r
1210 ARSUBR: PUSH P,FLAGS ; SAVE FROM GET
\r
1214 MOVE D,MQUOTE RSUBR
\r
1215 PUSHJ P,IGET ; TRY TO GET FIXUPS
\r
1217 JUMPE B,PUNK ; NO FIXUPS LOSE
\r
1219 CAIE A,TLIST ; ARE FIXUPS A LIST?
\r
1220 JRST PUNK ; NO, AGAIN LOSE
\r
1222 PUSH TP,B ; SAVE FIXUPS
\r
1227 PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]
\r
1229 AL1: ILDB A,(P) ; GET CHAR
\r
1238 PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL
\r
1239 MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE
\r
1241 MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ
\r
1243 MOVEI A,"' ; DONT EVAL FIXUPS EITHER
\r
1247 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
1250 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
1251 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1256 \f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)
\r
1258 LOCP: PUSH TP,-1(TP)
\r
1261 MCALL 1,IN ; GET ITS CONTENTS FROM "IN"
\r
1263 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
1265 PUSHJ P,IPRINT ; PRINT IT
\r
1266 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
1268 \f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
\r
1269 ;B CONTAINS CHANNEL
\r
1270 ;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
\r
1271 PITYO: TLNN FLAGS,FLTBIT
\r
1273 PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER
\r
1275 TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
\r
1277 AOS FLTSIZ ;FLATSIZE DOESN'T PRINT
\r
1278 ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
\r
1279 SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED
\r
1281 POP TP,B ; GET CHANNEL BACK
\r
1284 MOVEI E,(B) ; GET POINTER FOR UNBINDING
\r
1286 MOVE P,UPB+8 ; RESTORE P
\r
1287 POP TP,B ; GET BACK TP POINTER
\r
1288 PUSH P,0 ; SAVE FLAGS
\r
1289 MOVE TP,B ; RESTORE TP
\r
1290 PITYO3: MOVEI C,(TB)
\r
1293 POP P,0 ; RESTORE FLAGS
\r
1294 MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
\r
1298 PITYO2: HRR TB,OTBSAV(TB) ; RESTORE TB
\r
1303 ;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
\r
1304 ;CHARACTER STRINGS
\r
1305 ; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
\r
1306 ITYO: PUSH TP,$TCHAN
\r
1308 PUSH P,FLAGS ;SAVE STUFF
\r
1310 ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER
\r
1313 ITYO1: TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
\r
1314 JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING
\r
1315 CAIE A,^L ;SKIP IF THIS IS A FORM-FEED
\r
1317 SETZM LINPOS(B) ;ZERO THE LINE NUMBER
\r
1320 NOTFF: CAIE A,15 ;SKIP IF IT IS A CR
\r
1322 SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION
\r
1323 PUSHJ P,WXCT ;OUTPUT THE C-R
\r
1324 PUSHJ P,AOSACC ; BUMP COUNT
\r
1325 AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER
\r
1326 CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END
\r
1329 SETZM LINPOS(B) ;ZERO THE LINE POSITION
\r
1330 ; PUSHJ P,WXCT ; REMOVED FOR NOW
\r
1332 ; MOVEI A,^L ; DITTO
\r
1335 NOTCR: CAIN A,^I ;SKIP IF NOT TAB
\r
1337 CAIE A,10 ; BACK SPACE
\r
1339 SOS CHRPOS(B) ; BACK UP ONE
\r
1341 CAIE A,^J ;SKIP IF LINE FEED
\r
1342 AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER
\r
1344 ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS
\r
1345 ITYXTA: PUSHJ P,WXCT ;OUTPUT THE CHARACTER
\r
1346 ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER
\r
1348 ITYRET: POP P,C ;RESTORE REGS & RETURN
\r
1350 POP TP,B ; GET CHANNEL BACK
\r
1356 ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
\r
1359 MOVEM C,CHRPOS(B) ;REPLACE COUNT
\r
1363 UNPROUT: POP P,A ;GET BACK THE ORIG CHAR
\r
1364 IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO
\r
1366 JRST ITYRET ;RETURN
\r
1368 AOSACC: TLNN FLAGS,BINBIT
\r
1370 AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD
\r
1377 NRMACC: AOS ACCESS(B)
\r
1380 SPACEQ: MOVEI A,40
\r
1381 TLNE FLAGS,FLTBIT+BINBIT
\r
1382 JRST PITYO ; JUST OUTPUT THE SPACE
\r
1383 PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE
\r
1390 TLNE FLAGS,FLTBIT+BINBIT
\r
1391 JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE
\r
1392 RETIF2: PUSH P,FLAGS
\r
1395 RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION
\r
1396 SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN
\r
1398 CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH
\r
1401 MOVEI A,^M ;FORCE A CARRIAGE RETURN
\r
1404 PUSHJ P,AOSACC ; BUMP CHAR COUNT
\r
1405 MOVEI A,^J ;AND FORCE A LINE FEED
\r
1407 PUSHJ P,AOSACC ; BUMP CHAR COUNT
\r
1409 CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?
\r
1411 ; MOVEI A,^L ;IF SO FORCE A FORM FEED
\r
1413 ; PUSHJ P,AOSACC ; BUMP CHAR COUNT
\r
1419 SPOPJ: SUB P,[1,,1]
\r
1422 PRETIF: PUSH P,A ;SAVE CHAR
\r
1427 RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE
\r
1431 HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL
\r
1435 RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK
\r
1445 \f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
\r
1446 ;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
\r
1447 ;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
\r
1448 PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
\r
1449 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1450 PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
\r
1451 MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
\r
1452 PUSHJ P,PITYO ;TYPE IT
\r
1454 MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT
\r
1455 ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
\r
1456 MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD
\r
1457 OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE
\r
1458 IORI A,60 ;OR-IN 60 FOR ASCII DIGIT
\r
1459 PUSHJ P,PITYO ;PRINT IT
\r
1460 SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS
\r
1462 PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD
\r
1465 HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD
\r
1467 MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD
\r
1468 OCTLP2: LDB A,E ;GET 3 BITS
\r
1469 IORI A,60 ;CONVERT TO ASCII
\r
1470 PUSHJ P,PITYO ;PRINT IT
\r
1471 IBP E ;INCREMENT POINTER TO NEXT BYTE
\r
1472 SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS
\r
1474 MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT
\r
1475 PUSHJ P,PITYO ;REPRINT IT
\r
1477 JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
\r
1479 POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
\r
1480 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1482 JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"
\r
1484 \f;PRINT BINARY INTEGERS IN DECIMAL.
\r
1486 PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)
\r
1487 JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ
\r
1490 PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1491 PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX
\r
1492 TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE
\r
1494 MOVE D,RADX(B) ; GET OUTPUT RADIX
\r
1495 PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX
\r
1496 MOVEI D,10. ; IF IN DOUBT USE 10.
\r
1498 MOVEI A,1 ; START A COUNTER
\r
1499 SKIPGE B,(TP) ; CHECK SIGN
\r
1500 MOVEI A,2 ; NEG, NEED CHAR FOR SIGN
\r
1502 IDIV B,D ; START COUNTING
\r
1506 MOVE B,-2(TP) ; CHANNEL TO B
\r
1507 TLNN FLAGS,FLTBIT+BINBIT
\r
1508 PUSHJ P,RETIF3 ; CHECK FOR C.R.
\r
1509 MOVE B,-2(TP) ; RESTORE CHANNEL
\r
1510 MOVEI A,"- ; GET SIGN
\r
1511 SKIPGE (TP) ; SKIP IF NOT NEEDED
\r
1513 MOVM C,(TP) ; GET MAGNITUDE OF #
\r
1514 MOVE B,-2(TP) ; RESTORE CHANNEL
\r
1515 POP P,E ; RESTORE RADIX
\r
1516 PUSHJ P,FIXTYO ; WRITE OUT THE #
\r
1518 SUB P,[1,,1] ; FLUSH P STUFF
\r
1522 HRLM D,(P) ; SAVE REMAINDER
\r
1525 HLRZ A,(P) ; START GETTING #'S BACK
\r
1527 MOVE B,-2(TP) ; CHANNEL BACK
\r
1530 \f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
\r
1532 PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO)
\r
1533 JRST PFLT0 ; HACK THAT ZERO
\r
1534 MOVM E,A ; CHECK FOR NORMALIZED
\r
1535 TLNN E,400 ; NORMALIZED
\r
1537 MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
\r
1538 MOVE D,[6,,6] ;# WORDS TO GET FROM STACK
\r
1540 PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK
\r
1541 HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM
\r
1542 HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B
\r
1543 ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP
\r
1544 JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW
\r
1545 PDLWIN: PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E
\r
1547 MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED
\r
1548 MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE
\r
1549 PFLT1: PUSH P,B ; SAVE B
\r
1550 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1551 PUSHJ P,RETIF ;START NEW LINE IF IT WON'T
\r
1552 POP P,B ; RESTORE B
\r
1554 HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE
\r
1555 PNUM01: ILDB A,B ;GET NEXT BYTE
\r
1557 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1558 PUSHJ P,PITYO ;PRINT IT
\r
1561 SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO
\r
1563 SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN
\r
1564 JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER
\r
1567 PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000
\r
1568 MOVEI C,9. ; SEE ABOVE
\r
1569 MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING
\r
1570 MOVEI B,[ASCII /0.0000000/]
\r
1571 SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE
\r
1576 PDLERR: SUB P,D ;REST STACK POINTER
\r
1577 REPEAT 6,PUSH P,[0]
\r
1579 \f;PRINT SHORT (ONE WORD) CHARACTER STRINGS
\r
1581 PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)
\r
1582 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1583 TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED
\r
1584 MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE
\r
1585 PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
\r
1586 TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE
\r
1588 MOVEI A,"! ;TYPE A EXCL
\r
1590 MOVEI A,"" ;AND A DOUBLE QUOTE
\r
1593 PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD
\r
1594 TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
\r
1595 JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
\r
1596 CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
\r
1597 JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER
\r
1599 ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
\r
1602 PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN
\r
1603 PUSHJ P,PITYO ;PRINT IT
\r
1607 \f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
\r
1609 PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM
\r
1610 MOVE B,1(B) ;GET SECOND
\r
1611 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
1613 PUSHJ P,IPRINT ;PRINT IT
\r
1614 SUB TP,[2,,2] ; POP OFF CHANNEL
\r
1615 JRST PNEXT ;GO EXIT
\r
1618 ; Print an ATOM. TRAILERS are added if the atom is not in the current
\r
1619 ; lexical path. Also escaping of charactets is performed to allow READ
\r
1622 PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING
\r
1623 SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0
\r
1624 HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH
\r
1626 PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC
\r
1628 LDB A,[301400,,(P)] ; GET BYTE PTR POSITION
\r
1629 DPB A,[301400,,E] ; SAVE IN E
\r
1630 MOVE C,-2(TP) ; GET ATOM POINTER
\r
1631 ADD C,[3,,3] ; POINT TO PNAME
\r
1632 HLRE A,C ; -# WORDS TO A
\r
1633 PUSH P,A ; PUSH THAT FOR "AOSE"
\r
1634 MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO
\r
1636 HRLI C,440700 ; BUILD BYET POINTER
\r
1638 PATOM1: ILDB A,C ; GET A CHAR
\r
1639 JUMPE A,PATDON ; END OF PNAME?
\r
1640 TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY
\r
1641 AOS (P) ; COUNT WORD
\r
1642 JRST PENTCH ; ENTER THE CHAR INTO OUTPUT
\r
1644 PATDON: LDB A,[220600,,E] ; GET "STATE"
\r
1645 LDB A,STABYT+6 ; SIMULATE "END" CHARACTER
\r
1646 DPB A,[220600,,E] ; AND STORE
\r
1647 MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR
\r
1649 HRR B,(TP) ; POINT
\r
1650 SUB TP,[2,,2] ; FLUSH SAVED PDL
\r
1651 MOVE C,-1(P) ; GET BYE POINTER
\r
1652 SUB P,[2,,2] ; FLUSH
\r
1656 AOS -1(TP) ; COUNT ATOMS
\r
1657 TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"
\r
1658 JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS
\r
1659 MOVEI A,"\ ; GET QUOTER
\r
1660 TLNN E,2 ; SKIP IF NEEDED
\r
1662 SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH
\r
1664 PATDO1: MOVEI E,(E) ; CLEAR LH(E)
\r
1665 PUSH P,C ; SAVE BYTER
\r
1666 PUSH P,E ; ALSO CHAR COUNT
\r
1668 MOVE B,IMQUOTE OBLIST
\r
1670 PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE
\r
1671 POP P,FLAGS ; AND RESTORES FLAGS
\r
1672 MOVE C,(TP) ; GET ATOM BACK
\r
1673 SKIPN C,2(C) ; GET ITS OBLIST
\r
1674 AOJA A,NOOBL1 ; NONE, USE FALSE
\r
1675 JUMPL C,.+3 ; JUMP IF REAL OBLIST
\r
1676 ADDI C,(TVP) ; ELSE MUST BE OFFSET
\r
1678 CAME A,$TLIST ; SKIP IF A LIST
\r
1679 CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE
\r
1680 JRST CHOBL ; WINS, NOW LOCATE IT
\r
1682 CHROOT: CAME C,ROOT+1(TVP) ; IS THIS ROOT?
\r
1683 JRST FNDOBL ; MUST FIND THE PATH NAME
\r
1684 POP P,E ; RESTORE CHAR COUNT
\r
1685 MOVE D,(P) ; AND PARTIAL WORD
\r
1686 EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD
\r
1687 MOVEI A,"! ; PUT OUT MAGIC
\r
1688 JSP B,DOIDPB ; INTO BUFFER
\r
1694 NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER
\r
1695 PUSH P,D ; PUSH NEXT WORD IF ANY
\r
1698 NOLEX: MOVE E,(P) ; GET COUNT
\r
1700 NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)
\r
1701 MOVE A,E ; COUNT TO A
\r
1702 SKIPN (P) ; FLUSH 0 WORD
\r
1704 HRRZ C,-1(TP) ; GET # OF ATOMS
\r
1705 SUBI A,(C) ; FIX COUNT
\r
1706 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1707 PUSHJ P,RETIF ; MAY NEED C.R.
\r
1708 MOVEI C,-1(E) ; COMPUTE WORDS-1
\r
1709 IDIVI C,5 ; WORDS-1 TO C
\r
1712 SUB D,C ; POINTS TO 1ST WORD OF CHARS
\r
1713 MOVSI C,440700+D ; BYTEPOINTER TO STRING
\r
1714 PUSH TP,$TPDL ; SAVE FROM GC
\r
1717 PATOUT: ILDB A,C ; READ A CHAR
\r
1718 SKIPE A ; IGNORE NULS
\r
1719 PUSHJ P,PITYO ; PRINT IT
\r
1720 MOVE D,(TP) ; RESTORE POINTER
\r
1723 NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK
\r
1724 MOVE P,D ; RESTORE P
\r
1729 PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?
\r
1730 JRST PENTC1 ; YES, AVOID SLASHING
\r
1731 IDIVI A,CHRWD ; GET CHARS TYPE
\r
1733 CAIL B,6 ; SKIP IF NOT SPECIAL
\r
1734 JRST PENTC2 ; SLASH IMMEDIATE
\r
1735 LDB A,[220600,,E] ; GET "STATE"
\r
1736 LDB A,STABYT-1(B) ; GET NEW STATE
\r
1737 DPB A,[220600,,E] ; AND SAVE IT
\r
1738 PENTC3: LDB A,C ; RESTORE CHARACTER
\r
1739 PENTC1: JSP B,DOIDPB
\r
1740 SKIPGE (P) ; SKIP IF DONE
\r
1741 JRST PATOM1 ; CONTINUE
\r
1744 PENTC2: MOVEI A,"\ ; GET CHAR QUOTER
\r
1745 JSP B,DOIDPB ; NEEDED, DO IT
\r
1746 MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED
\r
1749 ; ROUTINE TO PUT ONE CHAR ON STACK BUFFER
\r
1751 DOIDPB: IDPB A,-1(P) ; DEPOSIT
\r
1752 TRNN D,377 ; SKIP IF D FULL
\r
1754 PUSH P,(P) ; MOVE TOP OF STACK UP
\r
1755 MOVEM D,-2(P) ; SAVE WORDS
\r
1756 MOVE D,[440700,,D]
\r
1761 ; CHECK FOR UNIQUENESS LOOKING INTO PATH
\r
1763 CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?
\r
1764 JRST LSTOBL ; NO, AL LIST THEREOF
\r
1765 CAME B,C ; THE RIGTH ONE?
\r
1766 JRST CHROOT ; NO, CHECK ROOT
\r
1767 JRST NOLEX ; WINNER, NO TRAILERS!
\r
1769 LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS
\r
1776 NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE
\r
1777 SKIPN C,-2(TP) ; SKIP IF NOT DONE
\r
1778 JRST CHROO1 ; EMPTY, CHECK ROOT
\r
1779 MOVE B,1(C) ; GET ONE
\r
1780 CAME B,(TP) ; WINNER?
\r
1781 JRST NXTOBL ; NO KEEP LOOKING
\r
1782 CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST
\r
1784 MOVE A,-6(TP) ; GET ATOM BACK
\r
1786 ADD A,[3,,3] ; POINT TO PNAME
\r
1787 PUSH P,0 ; SAVE FROM RLOOKU
\r
1790 AOBJN A,.-2 ; PUSH THE PNAME
\r
1791 PUSH P,D ; AND CHAR COUNT
\r
1792 MOVSI A,TLIST ; TELL RLOOKU WE WIN
\r
1793 MOVE B,-4(TP) ; GET BACK OBLIST LIST
\r
1794 SUB TP,[6,,6] ; FLUSH CRAP
\r
1795 PUSHJ P,RLOOKU ; FIND IT
\r
1797 CAMN B,(TP) ; SKIP IF NON UNIQUE
\r
1798 JRST NOLEX ; UNIQUE , NO TRAILER!!
\r
1799 JRST CHROO2 ; CHECK ROOT
\r
1801 NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST
\r
1806 FNDOBL: MOVE C,(TP) ; GET ATOM
\r
1813 MOVE D,IMQUOTE OBLIST
\r
1817 NOOBL1: POP P,E ; RESTORE CHAR COUNT
\r
1818 MOVE D,(P) ; GET PARTIAL WORD
\r
1819 EXCH D,-1(P) ; AND BYTE POINTER
\r
1820 CAME A,$TATOM ; IF NOT ATOM, USE FALSE
\r
1822 MOVEM B,(TP) ; STORE IN ATOM SLOT
\r
1824 JSP B,DOIDPB ; WRITE IT OUT
\r
1828 JRST PATOM0 ; AND LOOP
\r
1830 NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]
\r
1837 NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF
\r
1840 CHROO1: SUB TP,[6,,6]
\r
1841 CHROO2: MOVE C,(TP) ; GET ATOM
\r
1842 SKIPGE C,2(C) ; AND ITS OBLIST
\r
1849 \f; STATE TABLES FOR \ OF FIRST CHAR
\r
1865 STABYT: 400400,,STATS(A)
\r
1873 \f;PRINT LONG CHARACTER STRINGS.
\r
1875 PCHSTR: MOVE B,(TP)
\r
1876 TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
\r
1877 PUSH P,-1(TP) ; PUSH CHAR COUNT
\r
1878 MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS
\r
1879 SETZM E ;ZERO COUNT
\r
1880 PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
\r
1881 MOVE A,E ;PUT COUNT RETURNED IN REG A
\r
1882 TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
\r
1883 ADDI A,2 ;PLUS TWO FOR QUOTES
\r
1885 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1886 PUSHJ P,RETIF ;START NEW LINE IF NO SPACE
\r
1887 POP P,B ; RESTORE B
\r
1888 TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
\r
1889 JRST PCHS01 ;OTHERWISE, DON'T QUOTE
\r
1890 MOVEI A,"" ;PRINT A DOUBLE QUOTE
\r
1894 POP P,B ; RESTORE B
\r
1896 PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
\r
1897 MOVEM B,(TP) ;RESET BYTE POINTER
\r
1898 POP P,-1(TP) ; RESET CHAR COUNT
\r
1899 PUSHJ P,PCHRST ;TYPE STRING
\r
1901 TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
\r
1902 JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
\r
1903 MOVEI A,"" ;PRINT A DOUBLE QUOTE
\r
1904 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1906 MOVE B,-2(TP) ; GET CHANNEL
\r
1908 POP P,B ;RESTORE B
\r
1912 ;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
\r
1914 ;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
\r
1916 PCHRST: PUSH P,A ;SAVE REGS
\r
1921 PCHR02: INTGO ; IN CASE VERY LONG STRING
\r
1922 HRRZ C,-1(TP) ;GET COUNT
\r
1923 SOJL C,PCSOUT ; DONE?
\r
1925 ILDB A,(TP) ; GET CHAR
\r
1927 TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
\r
1928 JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
\r
1929 CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
\r
1930 JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER
\r
1931 CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE
\r
1932 JRST ESCPRN ;OTHERWISE, ESCAPE THE """
\r
1933 IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
\r
1934 LDB B,BYTPNT(B) ; "
\r
1935 CAIGE B,6 ;SKIP IF NOT A NUMBER/LETTER
\r
1936 JRST PCSPRT ;OTHERWISE, PRINT IT
\r
1937 TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
\r
1938 JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE
\r
1940 ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
\r
1942 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1944 POP P,B ; RESTORE B
\r
1946 PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN
\r
1948 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
1949 XCT (P)-1 ;PRINT IT
\r
1950 POP P,B ; RESTORE B
\r
1951 JRST PCHR02 ;LOOP THROUGH STRING
\r
1954 POP P,C ;RESTORE REGS & RETURN
\r
1960 \f;PRINT AN ARGUMENT LIST
\r
1961 ;CHECK FOR TIME ERRORS
\r
1963 PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER
\r
1964 PUSHJ P,CHARGS ;AND CHECK THEM
\r
1965 JRST PVEC ; CHEAT TEMPORARILY
\r
1970 PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER
\r
1972 HRRZ B,(TP) ;POINT TO FRAME ITSELF
\r
1973 HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE
\r
1976 SKIPA B,@-1(B) ; SUBRS AND FSUBRS
\r
1977 MOVE B,3(B) ; FOR RSUBRS
\r
1979 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
1981 PUSHJ P,IPRINT ;PRINT FUNCTION NAME
\r
1982 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
1985 PPVP: MOVE B,(TP) ; PROCESS TO B
\r
1989 MOVE B,PROCID+1(B) ;GET ID
\r
1990 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
1993 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
1996 ; HERE TO PRINT LOCATIVES
\r
1998 LOCPT1: HRRZ A,-1(TP)
\r
2000 LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK
\r
2007 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
2010 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
2014 MOVE B,-2(TP) ; GET CHANNEL
\r
2021 MOVE B,MQUOTE GLOC
\r
2045 \f;PRINT UNIFORM VECTORS.
\r
2047 PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2048 MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?
\r
2050 MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET
\r
2055 MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
\r
2056 TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO
\r
2057 JRST NULVEC ;ELSE, VECTOR IS EMPTY
\r
2059 HLRE A,C ;GET NEG COUNT
\r
2060 MOVEI D,(C) ;COPY POINTER
\r
2061 SUB D,A ;POINT TO DOPE WORD
\r
2062 HLLZ A,(D) ;GET TYPE
\r
2063 PUSH P,A ;AND SAVE IT
\r
2065 PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A
\r
2066 MOVE B,(C) ;PUT DATUM INTO REG B
\r
2067 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
2069 PUSHJ P,IPRINT ;TYPE IT
\r
2070 SUB TP,[2,,2] ; POP CHANNEL OF STACK
\r
2071 MOVE C,(TP) ;GET AOBJN POINTER
\r
2072 AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO
\r
2073 MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK
\r
2075 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2077 JRST PUVE02 ;LOOP THROUGH VECTOR
\r
2079 NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP
\r
2080 NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2081 MOVEI A,"! ;TYPE CLOSE BRACKET
\r
2087 \f;PRINT A GENERALIZED VECTOR
\r
2089 PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2090 PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [
\r
2091 MOVEI A,"[ ;PRINT A LEFT-BRACKET
\r
2094 MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
\r
2095 TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO
\r
2096 JRST PVCEND ;ELSE, FINISHED WITH VECTOR
\r
2097 PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
\r
2098 MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B
\r
2099 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
2101 PUSHJ P,IPRINT ;PRINT THAT ELEMENT
\r
2102 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
2104 MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK
\r
2105 AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
\r
2106 AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
\r
2107 JRST PVCEND ;ELSE, FINISHED WITH VECTOR
\r
2108 MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK
\r
2110 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2112 JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
\r
2114 PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2115 PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]
\r
2116 MOVEI A,"] ;PRINT A RIGHT-BRACKET
\r
2122 PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2123 PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("
\r
2124 MOVEI A,"( ;TYPE AN OPEN PAREN
\r
2126 PUSHJ P,LSTPRT ;PRINT THE INSIDES
\r
2127 MOVE B,-2(TP) ; RESTORE CHANNEL TO B
\r
2128 PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
\r
2129 MOVEI A,") ;TYPE A CLOSE PAREN
\r
2133 PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)
\r
2135 PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT
\r
2137 PLMNT3: MOVE C,(TP)
\r
2138 JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY
\r
2141 CAMN B,MQUOTE LVAL
\r
2143 CAMN B,MQUOTE GVAL
\r
2145 CAMN B,MQUOTE QUOTE
\r
2147 JUMPE D,PLMNT1 ;NEITHER, LEAVE
\r
2149 ;ITS A SPECIAL HACK
\r
2151 JUMPE C,PLMNT1 ;NIL BODY?
\r
2153 ;ITS VALUE OF AN ATOM
\r
2157 JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY
\r
2159 PUSH P,D ;PUSH THE CHAR
\r
2162 TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT
\r
2163 JRST PLMNT4 ;ELSE DON'T PRINT THE "."
\r
2165 ;ITS A SEGMENT CALL
\r
2166 MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
2167 MOVEI A,2 ; ROOM FOR ! AND . OR ,
\r
2172 PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B
\r
2174 POP P,A ;RESTORE CHAR
\r
2178 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
2181 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
2185 PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT
\r
2186 JRST PLMNT5 ;ELSE DON'T TYPE THE "!"
\r
2188 ;ITS A SEGMENT CALL
\r
2189 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2190 MOVEI A,2 ; ROOM FOR ! AND <
\r
2195 PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B
\r
2201 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2202 TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT
\r
2210 LSTPRT: SKIPN C,(TP)
\r
2212 HLLZ A,(C) ;GET NEXT ELEMENT
\r
2214 HRRZ C,(C) ;CHOP THE LIST
\r
2216 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
2218 PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT
\r
2219 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
2222 PLIST1: MOVEM C,(TP)
\r
2223 PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
\r
2225 PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT
\r
2226 SUB TP,[2,,2] ; POP CHANNEL OFF STACK
\r
2227 MOVE B,-2(TP) ; GET CHANNEL INTO B
\r
2229 JRST LSTPRT ;REPEAT
\r
2231 PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS
\r
2232 SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK
\r
2233 POP P,C ;RESTORE REG C
\r
2241 JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED
\r