<mdl.int>/print.mid.346

   1 TITLE   PRINTER ROUTINE FOR MUDDLE
   2
   3 RELOCATABLE
   4
   5 .INSRT DSK:MUDDLE >
   6
   7 .GLOBAL IPNAME,MTYO,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL
   8 .GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT
   9 .GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID
  10 .GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT
  11 .GLOBAL TMPLNT,TD.LNT,BADTPL,MPOPJ,SSPEC1,GLOTOP,GTLPOS,SPSTOR,PVSTOR
  12 .GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR
  13 .GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH,CPCH1,CICRLF,NONSPC
  14
  15 BUFLNT==100             ; BUFFER LENGTH IN WORDS
  16
  17 FLAGS==0        ;REGISTER USED TO STORE FLAGS
  18 CARRET==15      ;CARRIAGE RETURN CHARACTER
  19 ESCHAR=="\      ;ESCAPE CHARACTER
  20 SPACE==40       ;SPACE CHARACTER
  21 ATMBIT==200000  ;BIT SWITCH FOR ATOM-NAME PRINT
  22 NOQBIT==020000  ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
  23 SEGBIT==010000  ;SWITCH TO INDICATE PRINTING A SEGMENT
  24 SPCBIT==004000  ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
  25 FLTBIT==002000  ;SWITCH TO INDICATE "FLATSIZE" CALL
  26 HSHBIT==001000  ;SWITCH TO INDICATE "PHASH" CALL
  27 TERBIT==000400  ;SWITCH TO INDICATE "TERPRI" CALL
  28 UNPRSE==000200  ;SWITCH TO INDICATE "UNPARSE" CALL
  29 ASCBIT==000100  ;SWITCH TO INDICATE USING A "PRINT" CHANNEL
  30 BINBIT==000040  ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL
  31 CNTLPC==000020  ;SWITCH TO INDICATE USING ^P CODE IOT
  32 PJBIT==400000
  33 C.BUF==1
  34 C.PRIN==2
  35 C.BIN==4
  36 C.OPN==10
  37 C.READ==40
  38
  39
  40 \fMFUNCTION      FLATSIZE,SUBR
  41         DEFINE FLTMAX
  42                 4(B) TERMIN
  43         DEFINE FLTSIZ
  44                 2(B)TERMIN
  45 ;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
  46 ;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
  47 ;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX
  48         ENTRY
  49         CAMG    AB,[-2,,0]      ;CHECK NUMBER OF ARGS
  50         CAMG    AB,[-6,,0]
  51         JRST    WNA
  52         PUSH    P,3(AB)
  53
  54         GETYP   A,2(AB)
  55         CAIE    A,TFIX
  56         JRST    WTYP2           ;SECOND ARG NOT FIX THEN LOSE
  57 \r       CAMG    AB,[-4,,0]      ;SEE IF THERE IS A RADIX ARGUMENT
  58         JRST    .+3             ; RADIX SUPPLIED
  59         PUSHJ   P,GTRADX        ; GET THE RADIX FROM OUTCHAN
  60         JRST    FLTGO
  61         GETYP   A,4(AB)         ;CHECK TO SEE THAT RADIX IS FIX
  62         CAIE    A,TFIX
  63         JRST    WTYP            ;ERROR THIRD ARGUMENT WRONG TYPE
  64         MOVE    C,5(AB)
  65         PUSHJ   P,GETARG        ; GET ARGS INTO A AND B
  66 FLTGO:  POP     P,D             ; RESTORE FLATSIZE MAXIMUM
  67         PUSHJ   P,CIFLTZ
  68         JFCL
  69         JRST    FINIS
  70
  71
  72
  73 MFUNCTION UNPARSE,SUBR
  74         DEFINE UPB
  75                 0(B) TERMIN
  76
  77         ENTRY
  78
  79         JUMPGE  AB,TFA
  80         MOVE    E,TP            ;SAVE TP POINTER
  81
  82
  83
  84 ;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE
  85 ;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED
  86         CAMG    AB,[-2,,0]      ;SKIP IF RADIX SUPPLIED
  87         JRST    .+3
  88         PUSHJ   P,GTRADX        ;GET THE RADIX FROM OUTCHAN
  89         JRST    UNPRGO
  90         CAMGE   AB,[-5,,0]      ;CHECK FOR TOO MANY
  91         JRST    TMA
  92         GETYP   0,2(AB)
  93         CAIE    0,TFIX          ;SEE IF RADIX IS FIXED
  94         JRST    WTYP2
  95         MOVE    C,3(AB)         ;GET RADIX\r
  96         PUSHJ   P,GETARG        ;GET ARGS INTO A AND B
  97 UNPRGO: PUSHJ   P,CIUPRS
  98         JRST    FINIS
  99         JRST    FINIS
 100
 101
 102 GTRADX: MOVE    B,IMQUOTE OUTCHAN
 103         PUSH    P,0             ;SAVE FLAGS
 104         PUSHJ   P,IDVAL         ;GET VALUE FOR OUTCHAN
 105         POP     P,0
 106         GETYP   A,A             ;CHECK TYPE OF CHANNEL
 107         CAIE    A,TCHAN
 108         JRST    FUNCH1-1        ;IT IS A TP-POINTER
 109         MOVE    C,RADX(B)       ;GET RADIX FROM OUTCHAN
 110         JRST    FUNCH1
 111         MOVE    C,(B)+6         ;GET RADIX FROM STACK
 112
 113 FUNCH1: CAIG    C,1             ;CHECK FOR STRANGE RADIX
 114         MOVEI   C,10.           ;DEFAULT IF THIS IS THE CASE
 115 GETARG: MOVE    A,(AB)
 116         MOVE    B,1(AB)
 117         POPJ    P,
 118
 119
 120 IMFUNCTION      PRINT,SUBR
 121         ENTRY
 122         PUSHJ   P,AGET          ; GET ARGS
 123         PUSHJ   P,CIPRIN
 124         JRST    FINIS
 125
 126 MFUNCTION       PRINC,SUBR
 127         ENTRY
 128         PUSHJ   P,AGET          ; GET ARGS
 129         PUSHJ   P,CIPRNC
 130         JRST    FINIS
 131
 132 MFUNCTION       PRIN1,SUBR
 133         ENTRY
 134         PUSHJ   P,AGET
 135         PUSHJ   P,CIPRN1
 136         JRST    FINIS
 137
 138
 139 MFUNCTION CRLF,SUBR
 140         ENTRY
 141         PUSHJ   P,AGET1
 142         PUSHJ   P,CICRLF
 143         JRST    FINIS
 144
 145 MFUNCTION       TERPRI,SUBR
 146         ENTRY
 147         PUSHJ   P,AGET1
 148         PUSHJ   P,CITERP
 149         JRST    FINIS
 150
 151 \f
 152 CICRLF: SKIPA   E,.
 153 CITERP: MOVEI   E,0
 154         SUBM    M,(P)
 155         MOVSI   0,TERBIT+SPCBIT ; SET UP FLAGS
 156         PUSH    P,E
 157         PUSHJ   P,TESTR         ; TEST FOR GOOD CHANNEL
 158         MOVEI   A,CARRET        ; MOVE IN CARRIAGE-RETURN
 159         PUSHJ   P,PITYO         ; PRINT IT OUT
 160         MOVEI   A,12            ; LINE-FEED
 161         PUSHJ   P,PITYO
 162         POP     P,0
 163         JUMPN   0,.+4
 164         MOVSI   A,TFALSE        ; RETURN A FALSE
 165         MOVEI   B,0
 166         JRST    MPOPJ           ; RETURN
 167
 168         MOVSI   A,TATOM
 169         MOVE    B,IMQUOTE T
 170         JRST    MPOPJ
 171
 172 TESTR:  GETYP   E,A
 173         CAIN    E,TCHAN         ; CHANNEL?
 174         JRST    TESTR1          ; OK?
 175         CAIE    E,TTP
 176         JRST    BADCHN
 177         HLRZS   0
 178         IOR     0,A             ; RESTORE FLAGS
 179         HRLZS   0
 180         POPJ    P,
 181 TESTR1: HRRZ    E,-2(B)         ; GET IN FLAGS FROM CHANNEL
 182         SKIPN   IOINS(B)
 183         PUSHJ   P,OPENIT
 184         TRNN    E,C.OPN         ; SKIP IF OPEN
 185         JRST    CHNCLS
 186         TRC     E,C.PRIN+C.OPN  ; CHECK TO SEE THAT CHANNEL IS GOOD
 187         TRNE    E,C.PRIN+C.OPN
 188         JRST    BADCHN          ; ITS A LOSER
 189         TRNE    E,C.BIN
 190         JRST    PSHNDL          ; DON'T HANDLE BINARY
 191         TLO     ASCBIT          ; ITS ASCII
 192         POPJ    P,              ; ITS A WINNER
 193
 194 PSHNDL: PUSH    TP,C            ; SAVE ARGS
 195         PUSH    TP,D
 196         PUSH    TP,A            ; PUSH CHANNEL ONTO STACK
 197         PUSH    TP,B
 198         PUSHJ   P,BPRINT        ; CHECK BUFFER
 199         POP     TP,B
 200         POP     TP,A
 201         POP     TP,D
 202         POP     TP,C
 203         POPJ    P,
 204
 205
 206 \f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B
 207
 208 CIUPRS: SUBM    M,(P)           ; MODIFY M-POINTER
 209         MOVE    E,TP            ; SAVE TP-POINTER
 210         PUSH    TP,[0]          ; SLOT FOR FIRST STRING COPY
 211         PUSH    TP,[0]
 212         PUSH    TP,[0]          ; AND SECOND STRING
 213         PUSH    TP,[0]
 214         PUSH    TP,A            ; SAVE OBJECTS
 215         PUSH    TP,B
 216         PUSH    TP,$TTP         ; SAVE TP POINTER
 217         PUSH    TP,E
 218         PUSH    P,C
 219         MOVE    D,[377777,,-1]  ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE
 220         PUSHJ   P,CIFLTZ        ; FIND LENGTH OF STRING
 221         FATAL UNPARSE BLEW IT
 222         MOVEI   A,4(B)
 223         PUSH    P,B
 224         IDIVI   A,5
 225         PUSHJ   P,IBLOCK        ; GET A BLOCK
 226         POP     P,A
 227         HRLI    A,TCHSTR
 228         HRLI    B,010700
 229         SUBI    B,1
 230         POP     TP,E            ; RESTORE TP-POINTER
 231         SUB     TP,[1,,1]       ;GET RID OF TYPE WORD
 232         MOVEM   A,1(E)          ; SAVE RESULTS
 233         MOVEM   A,3(E)
 234         MOVEM   B,2(E)
 235         MOVEM   B,4(E)
 236         POP     TP,B            ; RESTORE THE WORLD
 237         POP     TP,A
 238         POP     P,C
 239         MOVSI   0,FLTBIT+UNPRSE ; SET UP FLAGS
 240         PUSHJ   P,CUSET
 241         JRST    MPOPJ           ; RETURN
 242
 243
 244
 245 ; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,
 246 ; A,B THE TYPE-OBJECT PAIR
 247
 248 CIFLTZ: SUBM    M,(P)
 249         MOVE    E,TP            ; SAVE POINTER
 250         PUSH    TP,$TFIX        ; PUSH ON FLATSIZE COUNT
 251         PUSH    TP,[0]
 252         PUSH    TP,$TFIX        ; PUSH ON FLATSIZE MAXIMUM
 253         PUSH    TP,D
 254         MOVSI   0,FLTBIT        ; MOVE ON FLATSIZE FLAG
 255         PUSHJ   P,CUSET         ; CONTINUE
 256         JRST    MPOPJ
 257         SOS     (P)             ; SKIP RETURN
 258         JRST    MPOPJ           ; RETURN
 259
 260 ; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING
 261 ; NEEDED TO GET A RESULT.
 262
 263 CUSET:  PUSH    TP,$TFIX        ; PUSH ON RADIX
 264         PUSH    TP,C
 265         PUSH    TP,$TPDL
 266         PUSH    TP,P            ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE
 267         PUSH    TP,A            ; SAVE OBJECTS
 268         PUSH    TP,B
 269         MOVSI   C,TTP           ; CONSTRUCT TP-POINTER
 270         HLR     C,FLAGS         ; SAVE FLAGS IN TP-POINTER
 271         MOVE    D,E
 272         PUSH    TP,C            ; PUSH ON CHANNEL
 273         PUSH    TP,D
 274         PUSHJ   P,IPRINT        ; GO TO INTERNAL PRINTER
 275         POP     TP,B            ; GET IN TP POINTER
 276         MOVE    TP,B            ; RESTORE POINTER
 277         TLNN    FLAGS,UNPRSE    ; SEE IF UNPARSE CALL
 278         JRST    FLTGEN          ; ITS A FLATSIZE
 279         MOVE    A,UPB+3         ; RETURN STRING
 280         MOVE    B,UPB+4
 281         POPJ    P,              ; DONE
 282 FLTGEN: MOVE    A,FLTSIZ-1      ; GET IN COUNT
 283         MOVE    B,FLTSIZ
 284         AOS     (P)
 285         POPJ    P,              ; EXIT
 286
 287 \f
 288 ; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME
 289 ; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL
 290
 291 CIPRIN: SUBM    M,(P)
 292         MOVSI   0,SPCBIT        ; SET UP FLAGS
 293         PUSHJ   P,TPRT          ; PRINT INITIALIZATION
 294         PUSHJ   P,IPRINT
 295         JRST    TPRTE           ; EXIT
 296
 297 CIPRN1: SUBM    M,(P)
 298         MOVEI   FLAGS,0         ; SET UP FLAGS
 299         PUSHJ   P,TPR1          ; INITIALIZATION
 300         PUSHJ   P,IPRINT        ; PRINT IT OUT
 301         JRST    TPR1E           ; EXIT
 302
 303 CIPRNC: SUBM    M,(P)
 304         MOVSI   FLAGS,NOQBIT    ; SET UP FLAGS
 305         PUSHJ   P,TPR1          ; INITIALIZATION
 306         PUSHJ   P,IPRINT
 307         JRST    TPR1E           ; EXIT
 308 \f
 309 ; INITIALIZATION FOR PRINT ROUTINES
 310
 311 TPRT:   PUSHJ   P,TESTR         ; SEE IF CHANNEL IS OK
 312         PUSH    TP,C            ; SAVE ARGUMENTS
 313         PUSH    TP,D
 314         PUSH    TP,A            ; SAVE CHANNEL
 315         PUSH    TP,B
 316         MOVEI   A,CARRET        ; PRINT CARRIAGE RETURN
 317         PUSHJ   P,PITYO
 318         MOVEI   A,12            ; AND LF
 319         PUSHJ   P,PITYO
 320         MOVE    A,-3(TP)        ; MOVE IN ARGS
 321         MOVE    B,-2(TP)
 322         POPJ    P,
 323
 324 ; EXIT FOR PRINT ROUTINES
 325
 326 TPRTE:  POP     TP,B            ; RESTORE CHANNEL
 327         MOVEI   A,SPACE         ; PRINT TRAILING SPACE
 328         PUSHJ   P,PITYO
 329         SUB     TP,[1,,1]       ; GET RID OF CHANNEL TYPE-WORD
 330         POP     TP,B            ; RETURN WHAT WAS PASSED
 331         POP     TP,A
 332         JRST    MPOPJ           ; EXIT
 333
 334 ; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES
 335
 336 TPR1:   PUSHJ   P,TESTR         ; SEE IF CHANNEL IS OK
 337         PUSH    TP,C            ; SAVE ARGS
 338         PUSH    TP,D
 339         PUSH    TP,A            ; SAVE CHANNEL
 340         PUSH    TP,B
 341         MOVE    A,-3(TP)                ; GET ARGS
 342         MOVE    B,-2(TP)
 343         POPJ    P,
 344
 345 ; EXIT FOR PRIN1 AND PRINC ROUTINES
 346
 347 TPR1E:  SUB     TP,[2,,2]       ; REMOVE CHANNEL
 348         POP     TP,B            ; RETURN ARGUMENTS THAT WERE GIVEN
 349         POP     TP,A
 350         JRST    MPOPJ           ; EXIT
 351
 352
 353 \f
 354 CPATM:  SUBM    M,(P)
 355         MOVSI   C,TATOM         ; GET TYPE FOR BINARY
 356         MOVEI   0,SPCBIT        ; SET UP FLAGS
 357         PUSHJ   P,TPRT          ; PRINT INITIALIZATION
 358         PUSHJ   P,CPATOM        ; PRINT IT OUT
 359         JRST    TPRTE           ; EXIT
 360
 361 CP1ATM: SUBM    M,(P)
 362         MOVE    C,$TATOM
 363         MOVEI   FLAGS,0         ; SET UP FLAGS
 364         PUSHJ   P,TPR1          ; INITIALIZATION
 365         PUSHJ   P,CPATOM        ; PRINT IT OUT
 366         JRST    TPR1E           ; EXIT
 367
 368 CPCATM: SUBM    M,(P)
 369         MOVE    C,$TATOM
 370         MOVSI   FLAGS,NOQBIT    ; SET UP FLAGS
 371         PUSHJ   P,TPR1          ; INITIALIZATION
 372         PUSHJ   P,CPATOM        ; PRINT IT OUT
 373         JRST    TPR1E           ; EXIT
 374
 375
 376 ; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE
 377 ; CHARACTER IS IN C.
 378 CPCH1:  TDZA    0,0
 379 CPCH:   MOVEI   0,1
 380         SUBM    M,(P)
 381         PUSH    P,0
 382         MOVSI   FLAGS,NOQBIT
 383         MOVE    C,$TCHRS
 384         PUSHJ   P,TESTR         ; SEE IF CHANNEL IS GOOD
 385         EXCH    D,(P)           ; CHAR TO STACK, IND TO D
 386         MOVE    A,(P)           ; MOVE IN CHARACTER FOR PITYO
 387         JUMPE   D,.+3
 388         PUSHJ   P,PRETIF
 389         JRST    .+2
 390         PUSHJ   P,PITYO
 391         MOVE    A,$TCHRST       ; RETURN THE CHARACTER
 392         POP     P,B
 393         JRST    MPOPJ
 394
 395
 396
 397
 398 CPSTR:  SUBM    M,(P)
 399         HRLI    C,TCHSTR
 400         MOVSI   0,SPCBIT        ; SET UP FLAGS
 401         PUSHJ   P,TPRT          ; PRINT INITIALIZATION
 402         PUSHJ   P,CPCHST        ; PRINT IT OUT
 403         JRST    TPRTE           ; EXIT
 404
 405 CP1STR: SUBM    M,(P)
 406         HRLI    C,TCHSTR
 407         MOVEI   FLAGS,0         ; SET UP FLAGS
 408         PUSHJ   P,TPR1          ; INITIALIZATION
 409         PUSHJ   P,CPCHST        ; PRINT IT OUT
 410         JRST    TPR1E           ; EXIT
 411
 412 CPCSTR: SUBM    M,(P)
 413         HRLI    C,TCHSTR
 414         MOVSI   FLAGS,NOQBIT    ; SET UP FLAGS
 415         PUSHJ   P,TPR1          ; INITIALIZATION
 416         PUSHJ   P,CPCHST        ; PRINT IT OUT
 417         JRST    TPR1E           ; EXIT
 418
 419
 420 CPATOM: PUSH    TP,A            ; COPY ARGS FOR INTERNAL SAKE\r
 421         PUSH    TP,B
 422         PUSH    P,0             ; ATOM CALLER ROUTINE
 423         PUSH    P,C
 424         SKIPN   C,PRNTYP+1
 425          JRST   PATOM
 426         ADDI    C,TATOM+TATOM
 427         SKIPE   (C)             ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH
 428          JRST   PRDIS1
 429         SKIPN   C,1(C)
 430          JRST   PATOM
 431           JRST  (C)
 432
 433 CPCHST: PUSH    TP,A            ; COPY ARGS FOR INTERNAL SAKE\r
 434         PUSH    TP,B
 435         PUSH    P,C             ; STRING CALLER ROUTINE
 436         PUSH    P,FLAGS
 437         SKIPN   C,PRNTYP+1
 438          JRST   PATOM
 439         ADDI    C,TCHSTR+TCHSTR
 440         SKIPE   (C)             ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH
 441          JRST   PRDIS1
 442         SKIPN   C,1(C)
 443          JRST   PCHSTR
 444           JRST  (C)
 445
 446
 447 \f\r
 448 AGET:   MOVEI   FLAGS,0
 449         SKIPL   E,AB            ; COPY ARG POINTER
 450         JRST    TFA             ;NO ARGS IS AN ERROR
 451         ADD     E,[2,,2]        ;POINT AT POSSIBLE CHANNEL
 452         JRST    COMPT
 453 AGET1:  MOVE    E,AB            ; GET COPY OF AB
 454         MOVSI   FLAGS,TERBIT
 455
 456 COMPT:  PUSH    TP,$TFIX        ;LEAVE ROOM ON STACK FOR ONE CHANNEL
 457         PUSH    TP,[0]
 458         JUMPGE  E,DEFCHN        ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING
 459         CAMG    E,[-2,,0]       ;IF MORE ARGS THEN ERROR
 460         JRST    TMA
 461         MOVE    A,(E)           ;GET CHANNEL
 462         MOVE    B,(E)+1
 463         JRST    NEWCHN
 464
 465 DEFCHN: MOVE    B,IMQUOTE OUTCHAN
 466         MOVSI   A,TATOM
 467         PUSH    P,FLAGS         ;SAVE FLAGS
 468         PUSHJ   P,IDVAL         ;GET VALUE OF OUTCHAN
 469         POP     P,0
 470
 471 NEWCHN: TLNE    FLAGS,TERBIT    ; SEE IF TERPRI
 472         POPJ    P,
 473         MOVE    C,(AB)  ; GET ARGS
 474         MOVE    D,1(AB)
 475         POPJ    P,
 476
 477 ; HERE IF USING A PRINTB CHANNEL
 478
 479 BPRINT: TLO     FLAGS,BINBIT
 480         SKIPE   BUFSTR(B)       ; ANY OUTPUT BUFFER?
 481         POPJ    P,
 482
 483 ; HERE TO GENERATE A STRING BUFFER
 484
 485         PUSH    P,FLAGS
 486         MOVEI   A,BUFLNT        ; GET BUFFER LENGTH
 487         PUSHJ   P,IBLOCK        ; MAKE A BUFFER
 488         MOVSI   0,TWORD+.VECT.  ; CLOBBER U TYPE
 489         MOVEM   0,BUFLNT(B)
 490         SETOM   (B)             ; -1 THE BUFFER
 491         MOVEI   C,1(B)
 492         HRLI    C,(B)
 493         BLT     C,BUFLNT-1(B)
 494         HRLI    B,010700
 495         SUBI    B,1
 496         MOVE    C,(TP)
 497         MOVEM   B,BUFSTR(C)     ; STOR BYTE POINTER
 498         MOVE    0,[TCHSTR,,BUFLNT*5]
 499         MOVEM   0,BUFSTR-1(C)
 500         POP     P,FLAGS
 501         MOVE    B,(TP)
 502         POPJ    P,
 503 \f
 504
 505 IPRINT: PUSH    P,C             ; SAVE C
 506         PUSH    P,FLAGS ;SAVE PREVIOUS FLAGS
 507         PUSH    TP,A    ;SAVE ARGUMENT ON TP-STACK
 508         PUSH    TP,B
 509
 510         INTGO           ;ALLOW INTERRUPTS HERE
 511
 512         GETYP   A,-1(TP)        ;GET THE TYPE CODE OF THE ITEM
 513         SKIPE   C,PRNTYP+1      ; USER TYPE TABLE?
 514         JRST    PRDISP
 515 NORMAL: CAILE   A,NUMPRI        ;PRIMITIVE?
 516         JRST    PUNK            ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
 517         HRRO    A,PRTYPE(A)     ;YES-DISPATCH
 518         JRST    (A)
 519
 520 ; HERE FOR USER PRINT DISPATCH
 521
 522 PRDISP: ADDI    C,(A)           ; POINT TO SLOT
 523         ADDI    C,(A)
 524         SKIPE   (C)             ; SKIP EITHER A LOSER OR JRST DISP
 525         JRST    PRDIS1          ; APPLY EVALUATOR
 526         SKIPN   C,1(C)          ; GET ADDR OR GO TO PURE DISP
 527         JRST    NORMAL
 528         JRST    (C)
 529
 530 PRDIS1: SUB     C,PRNTYP+1
 531         PUSH    P,C
 532         PUSH    TP,[TATOM,,-1]  ; PUSH ON OUTCHAN FOR SPECBIND
 533         PUSH    TP,IMQUOTE OUTCHAN
 534         PUSH    TP,-5(TP)
 535         PUSH    TP,-5(TP)
 536         PUSH    TP,[0]
 537         PUSH    TP,[0]
 538         PUSHJ   P,SPECBIND
 539         POP     P,C             ; RESTORE C
 540         ADD     C,PRNTYP+1              ; RESTORE C
 541         PUSH    TP,(C)          ; PUSH ARGS FOR APPLY
 542         PUSH    TP,1(C)
 543         PUSH    TP,-9(TP)
 544         PUSH    TP,-9(TP)
 545         MCALL   2,APPLY         ; APPLY HACKER TO OBJECT
 546         MOVEI   E,-8(TP)
 547         PUSHJ   P,SSPEC1        ;UNBIND OUTCHAN
 548         SUB     TP,[6,,6]       ; POP OFF STACK
 549         JRST    PNEXT
 550
 551 ; PRINT DISPATCH TABLE
 552
 553 IF2,PUNKS==400000,,PUNK
 554
 555 DISTBL  PRTYPE,PUNKS,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
 556 [TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
 557 [TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]
 558 [TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]
 559 [TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1],[TLOCR,LOCRPT],[TQRSUB,PRSUBR]
 560 [TQENT,PENTRY],[TSATC,PSATC],[TBYTE,PBYTE]
 561 [TOFFS,POFFSE]]
 562
 563 PUNK:   MOVE    C,TYPVEC+1      ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
 564         GETYP   B,-1(TP)        ; GET THE TYPE CODE INTO REG B
 565         LSH     B,1             ; MULTIPLY BY TWO
 566         HRL     B,B             ; DUPLICATE IT IN THE LEFT HALF
 567         ADD     C,B             ; INCREMENT THE AOBJN-POINTER
 568         JUMPGE  C,PRERR         ; IF POSITIVE, INDEX > VECTOR SIZE
 569
 570         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
 571         PUSH    TP,$TVEC                ; SAVE ALLTYPES VECTOR
 572         PUSH    TP,C
 573         PUSHJ   P,RETIF1        ; START NEW LINE IF NO ROOM
 574         MOVEI   A,"#            ; INDICATE TYPE-NAME FOLLOWS
 575         PUSHJ   P,PITYO
 576         POP     TP,C
 577         SUB     TP,[1,,1]
 578         MOVE    A,(C)           ; GET TYPE-ATOM
 579         MOVE    B,1(C)
 580         PUSH    TP,-3(TP)               ; GET CHANNEL FOR IPRINT
 581         PUSH    TP,-3(TP)
 582         PUSHJ   P,IPRINT        ; PRINT ATOM-NAME
 583         SUB     TP,[2,,2]       ; POP STACK
 584         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
 585         PUSHJ   P,SPACEQ        ;  MAYBE SPACE
 586         MOVE    B,(B)           ; RESET THE REAL ARGUMENT POINTER
 587         HRRZ    A,(C)           ; GET THE STORAGE-TYPE
 588         ANDI    A,SATMSK
 589         CAILE   A,NUMSAT        ; SKIP IF TEMPLATE
 590         JRST    TMPRNT          ; PRINT TEMPLATED DATA STRUCTURE
 591         HRRO    A,UKTBL(A)      ; USE DISPATCH TABLE ON STORAGE TYPE
 592         JRST    (A)
 593
 594 DISTBS  UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]
 595 [SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]
 596 [SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]
 597 [SLOCT,LOCP],[SLOCB,LOCP],[SBYTE,PBYTE],[SOFFS,POFFSE]]
 598         ; SELECK AN ILLEGAL
 599
 600 ILLCH:  MOVEI   B,-1(TP)
 601         JRST    ILLCHO
 602
 603 \f; PRINT INTERRUPT HANDLER
 604
 605 PHAND:  MOVE    B,-2(TP)        ; MOVE CHANNEL INTO B
 606         PUSHJ   P,RETIF1
 607         MOVEI   A,"#
 608         PUSHJ   P,PITYO         ; SAY "FUNNY TYPE"
 609         MOVSI   A,TATOM
 610         MOVE    B,MQUOTE HANDLER
 611         PUSH    TP,-3(TP)       ; PUSH CHANNEL ON FOR IPRINT
 612         PUSH    TP,-3(TP)
 613         PUSHJ   P,IPRINT                ; PRINT THE TYPE NAME
 614         SUB     TP,[2,,2]               ; POP CHANNEL OFF STACK
 615         MOVE    B,-2(TP)        ; GET CHANNEL
 616         PUSHJ   P,SPACEQ                ; SPACE MAYBE
 617         SKIPN   B,(TP)          ; GET ARG BACK
 618         JRST    PNEXT
 619         MOVE    A,INTFCN(B)     ; PRINT FUNCTION FOR NOW
 620         MOVE    B,INTFCN+1(B)
 621         PUSH    TP,-3(TP)               ; GET CHANNEL FOR IPRINT
 622         PUSH    TP,-3(TP)
 623         PUSHJ   P,IPRINT        ; PRINT THE INT FUNCTION
 624         SUB     TP,[2,,2]       ; POP CHANNEL OFF
 625         JRST    PNEXT
 626
 627 ; PRINT INT HEADER
 628
 629 PINTH:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 630         PUSHJ   P,RETIF1
 631         MOVEI   A,"#
 632         PUSHJ   P,PITYO
 633         MOVSI   A,TATOM         ; AND NAME
 634         MOVE    B,MQUOTE IHEADER
 635         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 636         PUSH    TP,-3(TP)
 637         PUSHJ   P,IPRINT
 638         MOVE    B,-4(TP)        ; GET CHANNEL INTO B
 639         PUSHJ   P,SPACEQ        ; MAYBE SPACE
 640         SKIPN   B,-2(TP)                ; INT HEADER BACK
 641         JRST    PINTH1
 642         MOVE    A,INAME(B)      ; GET NAME
 643         MOVE    B,INAME+1(B)
 644         PUSHJ   P,IPRINT
 645 PINTH1: SUB     TP,[2,,2]       ; CLEAN OFF STACK
 646         JRST    PNEXT
 647
 648
 649 ; PRINT ASSOCIATION BLOCK
 650
 651 ASSPNT: MOVEI   A,"(            ; MAKE IT BE (ITEN INDIC VAL)
 652         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 653         PUSHJ   P,PRETIF                ; MAKE ROOM AND PRINT
 654         SKIPA   C,[-3,,0]       ; # OF FIELDS
 655 ASSLP:  PUSHJ   P,SPACEQ
 656         MOVE    D,(TP)          ; RESTORE GOODIE
 657         ADD     D,ASSOFF(C)     ; POINT TO FIELD
 658         MOVE    A,(D)           ; GET IT
 659         MOVE    B,1(D)
 660         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 661         PUSH    TP,-3(TP)
 662         PUSHJ   P,IPRINT        ; AND PRINT IT
 663         SUB     TP,[2,,2]       ; POP OFF CHANNEL
 664         MOVE    B,-2(TP)        ; GET CHANNEL
 665         AOBJN   C,ASSLP
 666
 667         MOVEI   A,")
 668         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 669         PUSHJ   P,PRETIF        ; CLOSE IT
 670         JRST    PNEXT
 671
 672 ASSOFF: ITEM
 673         INDIC
 674         VAL
 675 \f; PRINT TYPE-C AND TYPE-W
 676
 677 PTYPEW: HRRZ    A,(TP)  ; POSSIBLE RH
 678         HLRZ    B,(TP)
 679         MOVE    C,MQUOTE TYPE-W
 680         JRST    PTYPEX
 681
 682 PTYPEC: HRRZ    B,(TP)
 683         MOVEI   A,0
 684         MOVE    C,MQUOTE TYPE-C
 685
 686 PTYPEX: PUSH    P,B
 687         PUSH    P,A
 688         PUSH    TP,$TATOM
 689         PUSH    TP,C
 690         MOVEI   A,2
 691         MOVE    B,-4(TP)        ; GET CHANNEL INTO B
 692         PUSHJ   P,RETIF         ; ROOM TO START?
 693         MOVEI   A,"%
 694         PUSHJ   P,PITYO
 695         MOVEI   A,"<
 696         PUSHJ   P,PITYO
 697         POP     TP,B            ; GET NAME
 698         POP     TP,A
 699         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 700         PUSH    TP,-3(TP)
 701         PUSHJ   P,IPRINT        ; AND PRINT IT AS 1ST ELEMENT
 702         SUB     TP,[2,,2]       ; POP OFF CHANNEL
 703         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 704         PUSHJ   P,SPACEQ        ; MAYBE SPACE
 705         MOVE    A,-1(P)         ; TYPE CODE
 706         ASH     A,1
 707         HRLI    A,(A)           ; MAKE SURE WINS
 708         ADD     A,TYPVEC+1
 709         JUMPL   A,PTYPX1        ; JUMP FOR A WINNER
 710         ERRUUO  EQUOTE BAD-TYPE-CODE
 711
 712 PTYPX1: MOVE    B,1(A)          ; GET TYPE NAME
 713         HRRZ    A,(A)           ; AND SAT
 714         ANDI    A,SATMSK
 715         MOVEM   A,-1(P)         ; AND SAVE IT
 716         MOVSI   A,TATOM
 717         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 718         PUSH    TP,-3(TP)
 719         PUSHJ   P,IPRINT        ; OUT IT GOES
 720         SUB     TP,[2,,2]       ; POP OFF CHANNEL
 721         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 722         PUSHJ   P,SPACEQ        ; MAYBE SPACE
 723         MOVE    A,-1(P)         ; GET SAT BACK
 724         MOVE    B,IMQUOTE TEMPLATE
 725         CAIGE   A,NUMSAT
 726         MOVE    B,@STBL(A)
 727         MOVSI   A,TATOM         ; AND PRINT IT
 728         PUSH    TP,-3(TP)               ; GET CHANNEL FOR IPRINT
 729         PUSH    TP,-3(TP)
 730         PUSHJ   P,IPRINT
 731         SUB     TP,[2,,2]       ; POP OFF STACK
 732         SKIPN   B,(P)           ; ANY EXTRA CRAP?
 733         JRST    PTYPX2
 734
 735         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 736         PUSHJ   P,SPACEQ
 737         MOVE    B,(P)
 738         MOVSI   A,TFIX
 739         PUSH    TP,-3(TP)       ; PUSH CHANNELS FOR IPRINT
 740         PUSH    TP,-3(TP)
 741         PUSHJ   P,IPRINT        ; PRINT EXTRA
 742         SUB     TP,[2,,2]       ; POP OFF CHANNEL
 743
 744 PTYPX2: MOVEI   A,">
 745         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 746         PUSHJ   P,PRETIF
 747         SUB     P,[2,,2]        ; FLUSH CRUFT
 748         JRST    PNEXT
 749
 750 \f; PRIMTYPE CODE
 751
 752 ; PRINT PURE CODE POINTER
 753
 754 PSATC:  MOVEI   A,2
 755         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 756         PUSHJ   P,RETIF
 757         MOVEI   A,"%
 758         PUSHJ   P,PITYO
 759         MOVEI   A,"<
 760         PUSHJ   P,PITYO
 761         MOVSI   A,TATOM         ; PRINT SUBR CALL
 762         MOVE    B,MQUOTE PRIMTYPE-C
 763         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 764         PUSH    TP,-3(TP)
 765         PUSHJ   P,IPRINT
 766         MOVE    B,-4(TP)        ; GET CHANNEL INTO B
 767         PUSHJ   P,SPACEQ        ; MAYBE SPACE?
 768         MOVE    A,-2(TP)
 769         CAILE   A,NUMSAT
 770         JRST    TMPPTY
 771
 772         MOVE    B,@STBL(A)
 773         JRST    PSATC1
 774
 775 TMPPTY: MOVE    B,TYPVEC+1
 776 PSATC3: HRRZ    C,(B)
 777         ANDI    C,SATMSK
 778         CAIN    A,(C)
 779         JRST    PSATC2
 780         ADD     B,[2,,2]
 781         JUMPL   B,PSATC3
 782
 783         ERRUUO  EQUOTE BAD-PRIMTYPEC
 784
 785 PSATC2: MOVE    B,1(B)
 786 PSATC1: MOVSI   A,TATOM
 787         PUSHJ   P,IPRINT
 788         SUB     TP,[2,,2]
 789         MOVEI   A,">
 790         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 791         PUSHJ   P,PRETIF        ; CLOSE THE FORM
 792         JRST    PNEXT
 793
 794
 795 PPCODE: MOVEI   A,2
 796         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 797         PUSHJ   P,RETIF
 798         MOVEI   A,"%
 799         PUSHJ   P,PITYO
 800         MOVEI   A,"<
 801         PUSHJ   P,PITYO
 802         MOVSI   A,TATOM         ; PRINT SUBR CALL
 803         MOVE    B,MQUOTE PCODE
 804         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 805         PUSH    TP,-3(TP)
 806         PUSHJ   P,IPRINT
 807         MOVE    B,-4(TP)        ; GET CHANNEL INTO B
 808         PUSHJ   P,SPACEQ        ; MAYBE SPACE?
 809         HLRZ    A,-2(TP)                ; OFFSET TO VECTOR
 810         ADD     A,PURVEC+1      ; SLOT TO A
 811         MOVE    A,(A)           ; SIXBIT NAME
 812         PUSH    P,FLAGS
 813         PUSHJ   P,6TOCHS        ; TO A STRING
 814         POP     P,FLAGS
 815         PUSHJ   P,IPRINT
 816         MOVE    B,-4(TP)        ; GET CHANNEL INTO B
 817         PUSHJ   P,SPACEQ
 818         HRRZ    B,-2(TP)        ; GET OFFSET
 819         MOVSI   A,TFIX\r
 820         PUSHJ   P,IPRINT
 821         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
 822         MOVEI   A,">
 823         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 824         PUSHJ   P,PRETIF        ; CLOSE THE FORM
 825         JRST    PNEXT
 826
 827
 828 \f; PRINT SUB-ENTRY TO RSUBR
 829
 830 PENTRY: MOVE    B,(TP)          ; GET BLOCK
 831         GETYP   A,(B)           ; TYPE OF 1ST ELEMENT
 832         CAIE    A,TRSUBR        ; RSUBR, OK
 833         JRST    PENT1
 834 PENT2:  MOVEI   A,2             ; CHECK ROOM
 835         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 836         PUSHJ   P,RETIF
 837         MOVEI   A,"%            ; SETUP READ TIME MACRO
 838         PUSHJ   P,PITYO
 839         MOVEI   A,"<
 840         PUSHJ   P,PITYO
 841         MOVSI   A,TATOM
 842         MOVE    B,IMQUOTE RSUBR-ENTRY
 843         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 844         PUSH    TP,-3(TP)
 845         PUSHJ   P,IPRINT
 846         MOVE    B,-4(TP)
 847         PUSHJ   P,SPACEQ        ; MAYBE SPACE
 848         MOVEI   A,"'            ; QUOTE TO AVOID EVALING IT
 849         PUSHJ   P,PRETIF
 850         MOVEI   A,"[            ; OPEN SQUARE BRAKET
 851         PUSHJ   P,PRETIF
 852         MOVE    B,-2(TP)
 853         GETYP   A,(B)
 854         CAIN    A,TRSUBR
 855         JRST    PENT3
 856         MOVE    A,(B)
 857         MOVE    B,1(B)
 858         PUSHJ   P,IPRINT
 859         MOVE    B,-4(TP)                ; MOVE IN CHANNEL
 860         JRST    PENT4
 861 PENT3:  MOVE    A,1(B)
 862         MOVE    B,3(A)
 863         MOVSI   A,TATOM         ; FOOL EVERYBODY AND SEND OUT ATOM
 864         PUSHJ   P,IPRINT
 865         MOVE    B,-4(TP)                ; PRINT SPACE
 866 PENT4:  PUSHJ   P,SPACEQ
 867         MOVE    B,-2(TP)                ; GET PTR BACK TO VECTOR
 868         MOVE    A,2(B)          ; THE NAME OF THE ENTRY
 869         MOVE    B,3(B)
 870         PUSHJ   P,IPRINT        ; OUT IT GOES
 871         HLRZ    B,-2(TP)
 872         CAIL    B,-4            ; SEE IF DONE
 873         JRST    EXPEN
 874         MOVE    B,-4(TP)                ; PRINT SPACE
 875         PUSHJ   P,SPACEQ
 876         MOVE    B,-2(TP)        ; GET POINTER
 877         MOVE    A,4(B)          ; DECL
 878         MOVE    B,5(B)
 879         PUSHJ   P,IPRINT
 880 EXPEN:  MOVE    B,-4(TP)        ; GET CHANNEL INTO B
 881         MOVEI   A,"]            ; CLOSE SQUARE BRAKET
 882         PUSHJ   P,PRETIF
 883         MOVE    B,-4(TP)                ; GET CHANNEL INTO B
 884         PUSHJ   P,SPACEQ
 885         MOVE    B,-2(TP)
 886         HRRZ    B,2(B)
 887         MOVSI   A,TFIX
 888         PUSHJ   P,IPRINT
 889         MOVEI   A,">
 890         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
 891         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 892         PUSHJ   P,PRETIF
 893         JRST    PNEXT
 894
 895 PENT1:  CAIN    A,TATOM
 896         JRST    PENT2
 897         ERRUUO  EQUOTE BAD-ENTRY-BLOCK
 898
 899 \f; HERE TO PRINT TEMPLATED DATA STRUCTURE
 900
 901 TMPRNT: PUSH    P,FLAGS         ; SAVE FLAGS
 902         MOVE    A,(TP)          ; GET POINTER
 903         GETYP   A,(A)           ; GET SAT
 904         PUSH    P,A             ; AND SAVE IT
 905         MOVEI   A,"{            ; OPEN SQUIGGLE
 906         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 907         PUSHJ   P,PRETIF        ; PRINT WITH CHECKING
 908         HLRZ    A,(TP)          ; GET AMOUNT RESTED OFF
 909         SUBI    A,1
 910         PUSH    P,A             ; AND SAVE IT
 911         MOVE    A,-1(P)         ; GET SAT
 912         SUBI    A,NUMSAT+1      ; FIXIT UP
 913         HRLI    A,(A)
 914         ADD     A,TD.LNT+1      ; CHECK FOR WINNAGE
 915         JUMPGE  A,BADTPL        ; COMPLAIN
 916         HRRZS   C,(TP)          ; GET LENGTH
 917         XCT     (A)             ;  INTO B
 918         SUB     B,(P)           ; FUDGE FOR RESTS
 919         MOVEI   B,-1(B)         ; FUDGE IT
 920         PUSH    P,B             ; AND SAVE IT
 921
 922 TMPRN1: AOS     C,-1(P)         ; GET ELEMENT OF INTEREST
 923         SOSGE   (P)             ; CHECK FOR ANY LEFT
 924         JRST    TMPRN2          ; ALL DONE
 925
 926         MOVE    B,(TP)          ; POINTER
 927         HRRZ    0,-2(P)         ; SAT
 928         PUSHJ   P,TMPLNT        ; GET THE ITEM
 929         MOVE    FLAGS,-3(P)     ; RESTORE FLAGS
 930         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
 931         PUSH    TP,-3(TP)
 932         PUSHJ   P,IPRINT        ; PRINT THIS ELEMENT
 933         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
 934         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
 935         SKIPE   (P)             ; IF NOT LAST ONE THEN
 936         PUSHJ   P,SPACEQ        ;   SEPARATE WITH A SPACE
 937         JRST    TMPRN1
 938
 939 TMPRN2: SUB     P,[4,,4]
 940         MOVE    B,-2(TP)
 941         MOVEI   A,"}            ; CLOSE THIS GUY
 942         PUSHJ   P,PRETIF
 943         JRST    PNEXT
 944
 945
 946 \f; RSUBR PRINTING ROUTINES.  ON PRINTB CHANNELS, WRITES OUT
 947 ; COMPACT BINARY.  ON PRINT CHANNELS ALL IS ASCII
 948
 949 PRSUBR: MOVE    A,(TP)          ; GET RSUBR IN QUESTION
 950         GETYP   A,(A)           ; CHECK FOR PURE RSUBR
 951         CAIN    A,TPCODE
 952         JRST    PRSBRP          ; PRINT IT SPECIAL WAY
 953
 954         TLNN    FLAGS,BINBIT    ; SKIP IF BINARY OUTPUT
 955         JRST    ARSUBR
 956
 957         PUSH    P,FLAGS
 958         MOVSI   A,TRSUBR        ; FIND FIXUPS
 959         MOVE    B,(TP)
 960         HLRE    D,1(B)          ; -LENGTH OF CODE VEC
 961         PUSH    P,D             ; SAVE SAME
 962         MOVSI   C,TATOM
 963         MOVE    D,IMQUOTE RSUBR
 964         PUSHJ   P,IGET          ; GO GET THEM
 965         JUMPE   B,RCANT         ; NO FIXUPS, BINARY LOSES
 966         PUSH    TP,A            ; SAVE FIXUP LIST
 967         PUSH    TP,B
 968
 969         MOVNI   A,1             ; USE ^C AS MARKER FOR RSUBR
 970         MOVE    FLAGS,-1(P)     ; RESTORE FLAGS
 971         MOVE    B,-4(TP)        ; GET CHANNEL FOR PITYO
 972         PUSHJ   P,PITYO         ; OUT IT GOES
 973
 974 PRSBR1: MOVE    B,-4(TP)
 975         PUSHJ   P,BFCLS1        ; FLUSH OUT CURRENT BUFFER
 976
 977         MOVE    B,-4(TP)                ; CHANNEL BACK
 978         MOVN    E,(P)           ; LENGTH OF CODE
 979         PUSH    P,E
 980         HRROI   A,(P)           ; POINT TO SAME
 981         PUSHJ   P,DOIOTO        ; OUT GOES COUNT
 982         MOVSI   C,TCODE
 983         MOVE    PVP,PVSTOR+1
 984         MOVEM   C,ASTO(PVP)     ; FOR IOT INTERRUPTS
 985         MOVE    A,-2(TP)        ; GET POINTER TO CODE
 986         MOVE    A,1(A)
 987         PUSHJ   P,DOIOTO        ; IOT IT OUT
 988         POP     P,E
 989         ADDI    E,1             ; UPDATE ACCESS
 990         ADDM    E,ACCESS(B)
 991         MOVE    PVP,PVSTOR+1
 992         SETZM   ASTO(PVP)       ; UNSCREW A
 993
 994 ; NOW PRINT OUT NORMAL RSUBR VECTOR
 995
 996         MOVE    FLAGS,-1(P)     ; RESTORE FLAGS
 997         SUB     P,[1,,1]
 998         MOVE    B,-2(TP)        ; GET RSUBR VECTOR
 999         PUSHJ   P,PRBODY        ; PRINT ITS BODY
1000
1001 ; HERE TO PRINT BINARY FIXUPS
1002
1003         MOVEI   E,0             ; 1ST COMPUTE LENGTH OF FIXUPS
1004         SKIPN   A,(TP)  ; LIST TO A
1005         JRST    PRSBR5          ; EMPTY, DONE
1006         JUMPL   A,UFIXES        ; JUMP IF FIXUPS IN UVECTOR FORM
1007         ADDI    E,1             ; FOR VERS
1008
1009 PRSBR6: HRRZ    A,(A)           ; NEXT?
1010         JUMPE   A,PRSBR5
1011         GETYP   B,(A)
1012         CAIE    B,TDEFER        ; POSSIBLE STRING
1013         JRST    PRSBR7          ; COULD BE ATOM
1014         MOVE    B,1(A)          ; POSSIBLE STRINGER
1015         GETYP   C,(B)
1016         CAIE    C,TCHSTR        ; YES!!!
1017         JRST    BADFXU          ; LOSING FIXUPS
1018         HRRZ    C,(B)           ; # OF CHARS TO C
1019         ADDI    C,5+5           ; ROUND AND ADD FOR COUNT
1020         IDIVI   C,5             ; TO WORDS
1021         ADDI    E,(C)
1022         JRST    FIXLST          ; COUNT FOR USE LIST ETC.
1023
1024 PRSBR7: GETYP   B,(A)           ; GET TYPE
1025         CAIE    B,TATOM
1026         JRST    BADFXU
1027         ADDI    E,1
1028
1029 FIXLST: HRRZ    A,(A)           ; REST IT TO OLD VAL
1030         JUMPE   A,BADFXU
1031         GETYP   B,(A)           ; FIX?
1032         CAIE    B,TFIX
1033         JRST    BADFXU
1034         MOVEI   D,1
1035         HRRZ    A,(A)           ; TO USE LIST
1036         JUMPE   A,BADFXU
1037         GETYP   B,(A)
1038         CAIE    B,TLIST
1039         JRST    BADFXU          ; LOSER
1040         MOVE    C,1(A)          ; GET LIST
1041
1042 PRSBR8: JUMPE   C,PRSBR9
1043         GETYP   B,(C)           ; TYPE OK?
1044         CAIE    B,TFIX
1045         JRST    BADFXU
1046         HRRZ    C,(C)
1047         AOJA    D,PRSBR8        ; LOOP
1048
1049 PRSBR9: ADDI    D,2             ; ROUND UP
1050         ASH     D,-1            ; DIV BY 2 FOR TWO GOODIES PER HWORD
1051         ADDI    E,(D)
1052         JRST    PRSBR6
1053
1054 PRSBR5: PUSH    P,E             ; SAVE LENGTH OF FIXUPS
1055         PUSH    TP,$TUVEC       ; SLOT FOR BUFFER POINTER
1056         PUSH    TP,[0]
1057
1058 PFIXU1: MOVE    B,-6(TP)                ; START LOOPING THROUGH CHANNELS
1059         PUSHJ   P,BFCLS1        ; FLUSH BUFFER
1060         MOVE    B,-6(TP)                ; CHANNEL BACK
1061         MOVEI   C,BUFSTR-1(B)   ; SETUP BUFFER
1062         PUSHJ   P,BYTDOP        ; FIND D.W.
1063         SUBI    A,BUFLNT+1
1064         HRLI    A,-BUFLNT
1065         MOVEM   A,(TP)
1066         MOVE    E,(P)           ; LENGTH OF FIXUPS
1067         SETZB   C,D             ; FOR EOUT
1068         PUSHJ   P,EOUT
1069         MOVE    C,-2(TP)        ; FIXUP LIST
1070         MOVE    E,1(C)          ; HAVE VERS
1071         PUSHJ   P,EOUT          ; OUT IT GOES
1072
1073 PFIXU2: HRRZ    C,(C)           ; FIRST THING
1074         JUMPE   C,PFIXU3        ; DONE?
1075         GETYP   A,(C)           ; STRING OR ATOM
1076         CAIN    A,TATOM         ; MUST BE STRING
1077         JRST    PFIXU4
1078         MOVE    A,1(C)          ; POINT TO POINTER
1079         HRRZ    D,(A)           ; LENGTH
1080         IDIVI   D,5
1081         PUSH    P,E             ; SAVE REMAINDER
1082         MOVEI   E,1(D)
1083         MOVNI   D,(D)
1084         MOVSI   D,(D)
1085         PUSH    P,D
1086         PUSHJ   P,EOUT
1087         MOVEI   D,0
1088 PFXU1A: MOVE    A,1(C)          ; RESTORE POINTER
1089         HRRZ    A,1(A)          ; BYTE POINTER
1090         ADD     A,(P)
1091         MOVE    E,(A)
1092         PUSHJ   P,EOUT
1093         MOVE    A,[1,,1]
1094         ADDB    A,(P)
1095         JUMPL   A,PFXU1A
1096         MOVE    D,-1(P)         ; LAST WORD
1097         MOVE    A,1(C)
1098         HRRZ    A,1(A)
1099         ADD     A,(P)
1100         SKIPE   E,D
1101         MOVE    E,(A)           ; LAST WORD OF CHARS
1102         IOR     E,PADS(D)
1103         PUSHJ   P,EOUT          ; OUT
1104         SUB     P,[1,,1]
1105         JRST    PFIXU5
1106
1107 PADS:   ASCII /#####/
1108         ASCII /####/
1109         ASCII /\ 2###/
1110         ASCII /\ 2##/
1111         ASCII /\ 2\ 2#/
1112
1113 PFIXU4: HRRZ    E,(C)           ; GET CURRENT VAL
1114         MOVE    E,1(E)
1115         MOVEM   C,-2(TP)
1116         PUSHJ   P,ATOSQ         ; GET SQUOZE
1117         JRST    BADFXU
1118         TLO     E,400000        ; USE TO DIFFERENTIATE BETWEEN STRING
1119         PUSHJ   P,EOUT
1120         MOVE    C,-2(TP)
1121
1122 ; HERE TO WRITE OUT LISTS
1123
1124 PFIXU5: HRRZ    C,(C)           ; POINT TO CURRENT VALUE
1125         HRLZ    E,1(C)
1126         HRRZ    C,(C)           ; POINT TO USES LIST
1127         HRRZ    D,1(C)          ; GET IT
1128         MOVEM   C,-2(TP)
1129
1130 PFIXU6: TLCE    D,400000        ; SKIP FOR RH
1131         HRLZ    E,1(D)          ; SETUP LH
1132         JUMPG   D,.+3
1133         HRR     E,1(D)
1134         PUSHJ   P,EOUT          ; WRITE IT OUT
1135         HRR     D,(D)
1136         TRNE    D,-1            ; SKIP IF DONE
1137         JRST    PFIXU6
1138
1139         TRNE    E,-1            ; SKIP IF ZERO BYTE EXISTS
1140         MOVEI   E,0
1141         PUSHJ   P,EOUT
1142         MOVE    C,-2(TP)
1143         JRST    PFIXU2          ; DO NEXT
1144
1145 PFIXU3: HLRE    C,(TP)          ; -AMNT LEFT IN BUFFER
1146         MOVN    D,C             ; PLUS SAME
1147         ADDI    C,BUFLNT        ; WORDS USED TO C
1148         JUMPE   C,PFIXU7        ; NONE USED, LEAVE
1149         MOVSS   C               ; START SETTING UP BTB
1150         MOVN    A,C             ; ALSO FINAL IOT POINTER
1151         HRR     C,(TP)          ; PDL POINTER PART OF BTB
1152         SUBI    C,1
1153         HRLI    D,400000+C      ; CONTINUE SETTING UP BTB (400000 IS FOR MULTI
1154                                 ;       SEGS
1155         POP     C,@D            ; MOVE 'EM DOWN
1156         TLNE    C,-1
1157         JRST    .-2
1158         HRRI    A,@D            ; OUTPUT POINTER
1159         ADDI    A,1
1160         MOVSI   B,TUVEC
1161         MOVE    PVP,PVSTOR+1
1162         MOVEM   B,ASTO(PVP)
1163         MOVE    B,-6(TP)
1164         PUSHJ   P,DOIOTO        ; WRITE IT OUT
1165         MOVE    PVP,PVSTOR+1
1166         SETZM   ASTO(PVP)
1167
1168 PFIXU7:         SUB     TP,[4,,4]
1169         SUB     P,[2,,2]
1170         JRST    PNEXT
1171
1172 ; ROUTINE TO OUTPUT CONTENTS OF E
1173
1174 EOUT:   MOVE    B,-6(TP)        ; CHANNEL
1175         AOS     ACCESS(B)
1176         MOVE    A,(TP)          ; BUFFER POINTER
1177         MOVEM   E,(A)
1178         AOBJP   A,.+3           ; COUNT AND GO
1179         MOVEM   A,(TP)
1180         POPJ    P,
1181
1182         SUBI    A,BUFLNT        ; SET UP IOT POINTER
1183         HRLI    A,-BUFLNT
1184         MOVEM   A,(TP)          ; RESET SAVED POINTER
1185         MOVSI   0,TUVEC
1186         MOVE    PVP,PVSTOR+1
1187         MOVEM   0,ASTO(PVP)
1188         MOVSI   0,TLIST
1189         MOVEM   0,DSTO(PVP)
1190         MOVEM   0,CSTO(PVP)
1191         PUSHJ   P,DOIOTO        ; OUT IT GOES
1192         MOVE    PVP,PVSTOR+1
1193         SETZM   ASTO(PVP)
1194         SETZM   CSTO(PVP)
1195         SETZM   DSTO(PVP)
1196         POPJ    P,
1197
1198 ; HERE IF UVECOR FORM OF FIXUPS
1199
1200 UFIXES: PUSH    TP,$TUVEC
1201         PUSH    TP,A            ; SAVE IT
1202
1203 UFIX1:          MOVE    B,-6(TP)                ; GET SAME
1204         PUSHJ   P,BFCLS1        ; FLUSH OUT BUFFER
1205         HLRE    C,(TP)  ; GET LENGTH
1206         MOVMS   C
1207         PUSH    P,C
1208         HRROI   A,(P)           ; READY TO ZAP IT OUT
1209         PUSHJ   P,DOIOTO        ; ZAP!
1210         SUB     P,[1,,1]
1211         HLRE    C,(TP)          ; LENGTH BACK
1212         MOVMS   C
1213         ADDI    C,1
1214         ADDM    C,ACCESS(B)     ; UPDATE ACCESS
1215         MOVE    A,(TP)          ; NOW THE UVECTOR
1216         MOVSI   C,TUVEC
1217         MOVE    PVP,PVSTOR+1
1218         MOVEM   C,ASTO(PVP)
1219         PUSHJ   P,DOIOTO        ; GO
1220         MOVE    PVP,PVSTOR+1
1221         SETZM   ASTO(PVP)
1222         SUB     P,[1,,1]
1223         SUB     TP,[4,,4]
1224         JRST    PNEXT
1225
1226 RCANT:  ERRUUO  EQUOTE RSUBR-LACKS-FIXUPS
1227
1228
1229 BADFXU: ERRUUO  EQUOTE BAD-FIXUPS
1230
1231 PRBODY: TDZA    C,C             ; FLAG SAYING FLUSH CODE
1232 PRBOD1: MOVEI   C,1             ; PRINT CODE ALSO
1233         PUSH    P,FLAGS
1234         PUSH    TP,$TRSUBR
1235         PUSH    TP,B
1236         PUSH    P,C
1237         MOVEI   A,"[            ; START VECTOR TEXT
1238         MOVE    B,-6(TP)        ; GET CHANNEL FOR PITYO
1239         PUSHJ   P,PITYO
1240         POP     P,C
1241         MOVE    B,(TP)          ; RSUBR BACK
1242         JUMPN   C,PRSON         ; GO START PRINTING
1243         MOVEI   A,"0            ; PLACE SAVER FOR CODE VEC
1244         MOVE    B,-6(TP)        ; GET CHANNEL FOR PITYO
1245         PUSHJ   P,PITYO
1246
1247 PRSBR2: MOVE    B,[2,,2]        ; BUMP VECTOR
1248         ADDB    B,(TP)
1249         JUMPGE  B,PRSBR3        ; NO SPACE IF LAST
1250         MOVE    B,-6(TP)        ; GET CHANNEL FOR SPACEQ
1251         PUSHJ   P,SPACEQ
1252         SKIPA   B,(TP)          ; GET BACK POINTER
1253 PRSON:  JUMPGE  B,PRSBR3
1254         GETYP   0,(B)           ; SEE IF RSUBR POINTED TO
1255         CAIE    0,TQENT
1256         CAIN    0,TENTER
1257         JRST    .+5             ; JUMP IF RSUBR ENTRY
1258         CAIN    0,TQRSUB
1259         JRST    .+3
1260         CAIE    0,TRSUBR        ; YES!
1261         JRST    PRSB10          ; COULD BE SUBR/FSUBR
1262         MOVE    C,1(B)          ; GET RSUBR
1263         PUSH    P,0             ; SAVE TYPE FOUND
1264         GETYP   0,2(C)          ; SEE IF ATOM
1265         CAIE    0,TATOM
1266         JRST    PRSBR4
1267         MOVE    B,3(C)          ; GET ATOM NAME
1268         PUSHJ   P,IGVAL         ; GO LOOK
1269         MOVE    C,(TP)          ; ORIG RSUBR BACK
1270         GETYP   A,A
1271         POP     P,0             ; DESIRED TYPE
1272         CAIE    0,(A)           ; SAME TYPE
1273         JRST    PRSBR4
1274         MOVE    D,1(C)
1275         MOVE    0,3(D)          ; NAME OF RSUBR IN QUESTION
1276         CAME    0,3(B)          ; WIN?
1277         JRST    PRSBR4
1278         HRRZ    E,C
1279         MOVSI   A,TATOM
1280         MOVE    B,0             ; GET ATOM
1281         MOVE    FLAGS,(P)
1282         JRST    PRS101
1283
1284 PRSBR4: MOVE    FLAGS,(P)       ; RESTORE FLAGS
1285         MOVE    B,(TP)
1286         MOVE    A,(B)
1287         MOVE    B,1(B)          ; PRINT IT
1288 PRS101: PUSH    TP,-7(TP)       ; PUSH CHANNEL FOR IPRINT
1289         PUSH    TP,-7(TP)
1290         PUSHJ   P,IPRINT
1291         SUB     TP,[2,,2]       ; POP OFF CHANNEL
1292         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
1293         JRST    PRSBR2
1294
1295 PRSB10: CAIE    0,TSUBR         ; SUBR?
1296         CAIN    0,TFSUBR
1297         JRST    .+2
1298         JRST    PRSBR4
1299         MOVE    C,1(B)          ; GET LOCN OF SUBR OR FSUBR
1300         MOVE    B,@-1(C)        ; NAME OF IT
1301         MOVSI   A,TATOM         ; AND TYPE
1302         JRST    PRS101
1303
1304 PRSBR3: MOVEI   A,"]
1305         MOVE    B,-6(TP)
1306         PUSHJ   P,PRETIF        ; CLOSE IT UP
1307         SUB     TP,[2,,2]       ; FLUSH CRAP
1308         POP     P,FLAGS
1309         POPJ    P,
1310
1311
1312 \f; HERE TO PRINT PURE RSUBRS
1313
1314 PRSBRP: MOVEI   A,2             ; WILL "%<" FIT?
1315         MOVE    B,-2(TP)        ; GET CHANNEL FOR RETIF
1316         PUSHJ   P,RETIF
1317         MOVEI   A,"%
1318         PUSHJ   P,PITYO
1319         MOVEI   A,"<
1320         PUSHJ   P,PITYO
1321         MOVSI   A,TATOM
1322         MOVE    B,IMQUOTE RSUBR
1323         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
1324         PUSH    TP,-3(TP)
1325         PUSHJ   P,IPRINT        ; PRINT IT OUT
1326         SUB     TP,[2,,2]       ; POP OFF CHANNEL
1327         MOVE    B,-2(TP)
1328         PUSHJ   P,SPACEQ        ; MAYBE SPACE
1329         MOVEI   A,"'            ; QUOTE THE VECCTOR
1330         PUSHJ   P,PRETIF
1331         MOVE    B,(TP)          ; GET RSUBR BODY BACK
1332         PUSH    TP,$TFIX                ; STUFF THE STACK
1333         PUSH    TP,[0]
1334         PUSHJ   P,PRBOD1        ; PRINT AND UNLINK
1335         SUB     TP,[2,,2]       ; GET JUNK OFF STACK
1336         MOVE    B,-2(TP)        ; GET CHANNEL FOR RETIF
1337         MOVEI   A,">
1338         PUSHJ   P,PRETIF
1339         JRST    PNEXT
1340
1341 ; HERE TO PRINT ASCII RSUBRS
1342
1343 ARSUBR: PUSH    P,FLAGS         ; SAVE FROM GET
1344         MOVSI   A,TRSUBR
1345         MOVE    B,(TP)
1346         MOVSI   C,TATOM
1347         MOVE    D,IMQUOTE RSUBR
1348         PUSHJ   P,IGET          ; TRY TO GET FIXUPS
1349         POP     P,FLAGS
1350         JUMPE   B,PUNK          ; NO FIXUPS LOSE
1351         GETYP   A,A
1352         CAIE    A,TLIST         ; ARE FIXUPS A LIST?
1353         JRST    PUNK            ; NO, AGAIN LOSE
1354         PUSH    TP,$TLIST
1355         PUSH    TP,B            ; SAVE FIXUPS
1356         MOVEI   A,17.
1357         MOVE    B,-4(TP)
1358         PUSHJ   P,RETIF
1359         PUSH    P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]
1360
1361 AL1:    ILDB    A,(P)           ; GET CHAR
1362         JUMPE   A,.+3
1363         PUSHJ   P,PITYO
1364         JRST    AL1
1365
1366         SUB     P,[1,,1]
1367         PUSHJ   P,SPACEQ
1368
1369         MOVEI   A,"'
1370         PUSHJ   P,PRETIF        ; QUOTE TO AVOID ADDITIONAL EVAL
1371         MOVE    B,-2(TP)        ; PRINT ACTUAL KLUDGE
1372         PUSHJ   P,PRBOD1
1373         MOVE    B,-4(TP)        ; GET CHANNEL FOR SPACEQ
1374         PUSHJ   P,SPACEQ
1375         MOVEI   A,"'            ; DONT EVAL FIXUPS EITHER
1376         PUSHJ   P,PRETIF
1377         POP     TP,B
1378         POP     TP,A
1379         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
1380         PUSH    TP,-3(TP)
1381         PUSHJ   P,IPRINT
1382         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
1383         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
1384         MOVEI   A,">
1385         PUSHJ   P,PRETIF
1386         JRST    PNEXT
1387 \f
1388 ; HERE TO DO OFFSETS:  %<OFFSET N '<VECTOR FIX FLOAT>>
1389
1390 POFFSE: MOVEI   A,2
1391         MOVE    B,-2(TP)
1392         PUSHJ   P,RETIF
1393         MOVEI   A,"%
1394         PUSHJ   P,PITYO
1395         MOVEI   A,"<
1396         PUSHJ   P,PITYO
1397         MOVSI   A,TATOM
1398         MOVE    B,MQUOTE OFFSET
1399         PUSH    TP,-3(TP)
1400         PUSH    TP,-3(TP)
1401         PUSHJ   P,IPRINT
1402         SUB     TP,[2,,2]
1403         MOVE    B,-2(TP)        ; RESTORE CHANNEL
1404         PUSHJ   P,SPACEQ
1405         MOVSI   A,TFIX
1406         HRRE    B,(TP)          ; PICK UPTHE FIX
1407         PUSH    TP,-3(TP)
1408         PUSH    TP,-3(TP)
1409         PUSHJ   P,IPRINT
1410         SUB     TP,[2,,2]
1411         MOVE    B,-2(TP)        ; RESTORE CHANNEL
1412         PUSHJ   P,SPACEQ
1413         HLRZ    A,(TP)
1414         JUMPE   A,POFFS2
1415         GETYP   B,(A)
1416         CAIE    B,TFORM         ; FORMS HAVE TO BE QUOTED
1417          JRST   POFFS1
1418         MOVEI   A,"'
1419         MOVE    B,-2(TP)
1420         PUSHJ   P,PRETIF
1421 POFFS1: HLRZ    B,(TP)
1422         MOVE    A,(B)
1423         MOVE    B,1(B)
1424 POFFPT: PUSH    TP,-3(TP)
1425         PUSH    TP,-3(TP)
1426         PUSHJ   P,IPRINT
1427         SUB     TP,[2,,2]
1428         MOVE    B,-2(TP)        ; RESTORE CHANNEL
1429         MOVEI   A,">
1430         PUSHJ   P,PRETIF
1431         JRST    PNEXT
1432 ; PRINT 'ANY' IF 0
1433 POFFS2: MOVSI   A,TATOM
1434         MOVE    B,IMQUOTE ANY
1435         JRST    POFFPT
1436
1437 \f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)
1438
1439 LOCP:   PUSH    TP,-1(TP)
1440         PUSH    TP,-1(TP)
1441         PUSH    P,0
1442         MCALL   1,IN            ; GET ITS CONTENTS FROM "IN"
1443         POP     P,0
1444         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
1445         PUSH    TP,-3(TP)
1446         PUSHJ   P,IPRINT        ; PRINT IT
1447         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
1448         JRST    PNEXT
1449 \f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
1450 ;B CONTAINS CHANNEL
1451 ;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
1452 PITYO:  TLNN    FLAGS,FLTBIT
1453         JRST    ITYO
1454 PITYO1: PUSH    TP,[TTP,,0]     ; PUSH ON TP POINTER
1455         PUSH    TP,B
1456         TLNE    FLAGS,UNPRSE    ;SKIPS UNPRSE NOT SET
1457         JRST    ITYO+2
1458         AOS     FLTSIZ  ;FLATSIZE DOESN'T PRINT
1459                         ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
1460         SOSGE   FLTMAX  ;UNLESS THE MAXIMUM IS EXCEEDED
1461         JRST    .+4
1462         POP     TP,B            ; GET CHANNEL BACK
1463         SUB     TP,[1,,1]
1464         POPJ    P,
1465         MOVEI   E,(B)           ; GET POINTER FOR UNBINDING
1466         PUSHJ   P,SSPEC1
1467         MOVE    P,UPB+8         ; RESTORE P
1468         POP     TP,B            ; GET BACK TP POINTER
1469         PUSH    P,0             ; SAVE FLAGS
1470         MOVE    TP,B            ; RESTORE TP
1471         MOVEI   C,(TB)          ; SEE IF TB IS CORRECT
1472         CAIG    C,1(TP)         ; SKIP IF NEEDS UNWINDING
1473         JRST    PITYO4
1474 PITYO3: MOVEI   C,(TB)
1475         CAILE   C,1(TP)
1476         JRST    PITYO2
1477         MOVEI   A,PITYO4        ; SET UP PARAMETERS TO BE RESTORED BY FINIS
1478         HRRM    A,PCSAV(C)
1479         MOVEM   TP,TPSAV(C)
1480         MOVE    SP,SPSTOR+1
1481         MOVEM   SP,SPSAV(C)
1482         MOVEM   P,PSAV(C)
1483         MOVE    TB,D            ; SET TB TO ONE FRAME AHEAD
1484         JRST    FINIS
1485 PITYO4: POP     P,0             ; RESTORE FLAGS
1486         MOVSI   A,TFALSE        ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
1487         MOVEI   B,0
1488         POPJ    P,
1489
1490 PITYO2: MOVE    D,TB            ; SAVE ONE FRAME AHEAD
1491         HRR     TB,OTBSAV(TB)   ; RESTORE TB
1492         JRST    PITYO3
1493
1494
1495 \f;THE REAL THING
1496 ;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
1497 ;CHARACTER STRINGS
1498 ; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
1499 ITYO:   PUSH    TP,$TCHAN
1500         PUSH    TP,B
1501         PUSH    P,FLAGS         ;SAVE STUFF
1502         PUSH    P,C
1503         PUSH    P,A             ;SAVE OUTPUT CHARACTER
1504
1505
1506         TLNE    FLAGS,UNPRSE    ;SKIPS UNPRSE NOT SET
1507          JRST   UNPROUT         ;IF FROM UNPRSE, STASH IN STRING
1508         CAIN    A,^J
1509          PUSHJ  P,INTCHK
1510         PUSH    P,A
1511         PUSHJ   P,WXCT
1512         POP     P,A
1513         CAIE    A,^L            ;SKIP IF THIS IS A FORM-FEED
1514          JRST   NOTFF
1515         SETZM   LINPOS(B)       ;ZERO THE LINE NUMBER
1516         JRST    ITYXT
1517
1518 NOTFF:  CAIE    A,15            ;SKIP IF IT IS A CR
1519          JRST   NOTCR
1520         SETZM   CHRPOS(B)       ;ZERO THE CHARACTER POSITION
1521         PUSHJ   P,AOSACC        ; BUMP COUNT
1522         JRST    ITYXT1
1523
1524 NOTCR:  CAIN    A,^I            ;SKIP IF NOT TAB
1525          JRST   TABCNT
1526         CAIE    A,10            ; BACK SPACE
1527          JRST   .+3
1528         SOS     CHRPOS(B)       ; BACK UP ONE
1529         JRST    ITYXT
1530         CAIE    A,^J            ;SKIP IF LINE FEED
1531          JRST   NOTLF
1532         AOS     C,LINPOS(B)     ;ADD ONE TO THE LINE NUMBER
1533         CAMLE   C,PAGLN(B)      ;SKIP IF THIS DOESN'T TAKES US PAST PAGE END
1534          SETZM  LINPOS(B)
1535         MOVE    FLAGS,-2(P)
1536         JRST    ITYXT
1537
1538 INTCHK: HRRZ    0,-2(B)         ; GET CHANNELS FLAGS
1539         TRNN    0,C.INTL        ; LOSER INTERESTED IN LFS?
1540          POPJ   P,              ; LEAVE IF NOTHING TO DO
1541         PUSH    TP,$TCHAN
1542         PUSH    TP,B            ; SAVE CHANNEL
1543         PUSH    P,C
1544         PUSH    P,E
1545         PUSHJ   P,GTLPOS                ; READ SYSTEMS VERSION OF LINE #
1546         PUSH    TP,$TATOM
1547         PUSH    TP,MQUOTE CHAR,CHAR,INTRUP
1548         PUSH    TP,$TFIX
1549         PUSH    TP,A
1550         PUSH    TP,$TCHAN
1551         PUSH    TP,B
1552         MCALL   3,INTERRUPT
1553         POP     P,E             ; RESTORE POSSIBLE COUNTS
1554         POP     P,C
1555         POP     TP,B            ; RESTORE CHANNEL
1556         SUB     TP,[1,,1]
1557         MOVEI   A,^J
1558         POPJ    P,
1559
1560 NOTLF:  CAIGE   A,40
1561         AOS     CHRPOS(B)       ; FOR CONTROL CHARS THAT NEED 2 SPACES
1562         AOS     CHRPOS(B)       ;ADD TO CHARACTER NUMBER
1563
1564 ITYXT:  PUSHJ   P,AOSACC        ; BUMP ACCESS
1565 ITYXT1: POP     P,A             ;RESTORE THE ORIGINAL CHARACTER
1566
1567 ITYRET: POP     P,C             ;RESTORE REGS & RETURN
1568         POP     P,FLAGS
1569         POP     TP,B            ; GET CHANNEL BACK
1570         SUB     TP,[1,,1]
1571         POPJ    P,
1572
1573 TABCNT: PUSH    P,D
1574         MOVE    C,CHRPOS(B)
1575         ADDI    C,8.            ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
1576         IDIVI   C,8.
1577         IMULI   C,8.
1578         MOVEM   C,CHRPOS(B)     ;REPLACE COUNT
1579         POP     P,D
1580         JRST    ITYXT
1581
1582 UNPROUT: POP    P,A     ;GET BACK THE ORIG CHAR
1583         IDPB    A,UPB+2         ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO
1584         SOS     UPB+1
1585         JRST    ITYRET  ;RETURN
1586
1587 AOSACC: TLNN    FLAGS,BINBIT
1588         JRST    NRMACC
1589         AOS     C,ACCESS-1(B)   ; COUNT CHARS IN WORD
1590         CAMN    C,[TFIX,,1]
1591         AOS     ACCESS(B)
1592         CAMN    C,[TFIX,,5]
1593         HLLZS   ACCESS-1(B)
1594         POPJ    P,
1595
1596 NRMACC: AOS     ACCESS(B)
1597         POPJ    P,
1598
1599 SPACEQ: MOVEI   A,40
1600         TLNE    FLAGS,FLTBIT+BINBIT
1601         JRST    PITYO           ; JUST OUTPUT THE SPACE
1602         PUSH    P,[1]           ; PRINT SPACE IF NOT END OF LINE
1603         MOVEI   A,1
1604         JRST    RETIF2
1605
1606 RETIF1: MOVEI   A,1
1607
1608 RETIF:  PUSH    P,[0]
1609         TLNE    FLAGS,FLTBIT+BINBIT
1610         JRST    SPOPJ           ; IF WE ARE IN FLATSIZE THEN ESCAPE
1611 RETIF2: PUSH    P,FLAGS
1612 RETCH:  PUSH    P,A
1613
1614 RETCH1: ADD     A,CHRPOS(B)     ;ADD THE CHARACTER POSITION
1615         SKIPN   CHRPOS(B)       ; IF JUST RESET, DONT DO IT AGAIN
1616         JRST    RETXT
1617         CAMG    A,LINLN(B)      ;SKIP IF GREATER THAN LINE LENGTH
1618         JRST    RETXT1
1619
1620         MOVEI   A,^M            ;FORCE A CARRIAGE RETURN
1621         SETZM   CHRPOS(B)
1622         PUSHJ   P,WXCT
1623         PUSHJ   P,AOSACC        ; BUMP CHAR COUNT
1624         MOVEI   A,^J            ;AND FORCE A LINE FEED
1625         PUSHJ   P,INTCHK        ; CHECK FOR ^J INTERRUPTS
1626         PUSHJ   P,WXCT
1627         PUSHJ   P,AOSACC        ; BUMP CHAR COUNT
1628         AOS     A,LINPOS(B)
1629         CAMG    A,PAGLN(B)      ;AT THE END OF THE PAGE ?
1630         JRST    RETXT
1631 ;       MOVEI   A,^L    ;IF SO FORCE A FORM FEED
1632 ;       PUSHJ   P,WXCT
1633 ;       PUSHJ   P,AOSACC        ; BUMP CHAR COUNT
1634         SETZM   LINPOS(B)
1635
1636 RETXT:  POP     P,A
1637
1638         POP     P,FLAGS
1639 SPOPJ:  SUB     P,[1,,1]
1640         POPJ    P,      ;RETURN
1641
1642 PRETIF: PUSH    P,A     ;SAVE CHAR
1643         PUSHJ   P,RETIF1
1644         POP     P,A
1645         JRST    PITYO
1646
1647 RETIF3: TLNE    FLAGS,FLTBIT    ; NOTHING ON FLATSIZE
1648         POPJ    P,
1649         PUSH    P,[0]
1650         PUSH    P,FLAGS
1651         HRRI    FLAGS,2         ; PRETEND ONLY 1 CHANNEL
1652         PUSH    P,A
1653         JRST    RETCH1
1654
1655 RETXT1: SKIPN   -2(P)           ; SKIP IF SPACE HACK
1656         JRST    RETXT
1657         MOVEI   A,40
1658         PUSHJ   P,WXCT
1659         AOS     CHRPOS(B)
1660         PUSH    P,C
1661         PUSHJ   P,AOSACC
1662         POP     P,C
1663         JRST    RETXT
1664
1665 \f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
1666 ;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
1667 ;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
1668 PRERR:  MOVEI   A,21.   ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
1669         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
1670         PUSHJ   P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
1671         MOVEI   A,"*    ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
1672         PUSHJ   P,PITYO ;TYPE IT
1673
1674         MOVE    E,[000300,,-2(TP)]      ;GET POINTER INDEXED OFF TP SO THAT
1675                                 ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
1676         MOVEI   D,6     ;# OF OCTAL DIGITS IN HALF WORD
1677 OCTLP1: ILDB    A,E     ;GET NEXT 3-BIT BYTE OF TYPE CODE
1678         IORI    A,60    ;OR-IN 60 FOR ASCII DIGIT
1679         PUSHJ   P,PITYO ;PRINT IT
1680         SOJG    D,OCTLP1        ;REPEAT FOR SIX CHARACTERS
1681
1682 PRE01:  MOVEI   A,"*    ;DELIMIT TYPE CODE FROM VALUE FIELD
1683         PUSHJ   P,PITYO
1684
1685         HRLZI   E,(410300,,(TP))        ;BYTE POINTER TO SECOND WORD
1686                                 ;INDEXED OFF TP
1687         MOVEI   D,12.   ;# OF OCTAL DIGITS IN A WORD
1688 OCTLP2: LDB     A,E     ;GET 3 BITS
1689         IORI    A,60    ;CONVERT TO ASCII
1690         PUSHJ   P,PITYO ;PRINT IT
1691         IBP     E       ;INCREMENT POINTER TO NEXT BYTE
1692         SOJG    D,OCTLP2        ;REPEAT FOR 12. CHARS
1693
1694         MOVEI   A,"*    ;DELIMIT END OF ERROR TYPEOUT
1695         PUSHJ   P,PITYO ;REPRINT IT
1696
1697         JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
1698
1699 POCTAL: MOVEI   A,14.   ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
1700         MOVE    B,-2(TP)                ; GET CHANNEL INTO B
1701         PUSHJ   P,RETIF
1702         JRST    PRE01   ;PRINT VALUE AS "*XXXXXXXXXXXX*"
1703
1704 \f;PRINT BINARY INTEGERS IN DECIMAL.
1705 ;
1706 PFIX:   MOVM    E,(TP)          ; GET # (MAFNITUDE)
1707         JUMPL   E,POCTAL        ; IF ABS VAL IS NEG, MUST BE SETZ
1708         PUSH    P,FLAGS
1709
1710 PFIX1:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B
1711 PFIX2:  MOVE    D,UPB+6         ; IF UNPARSE, THIS IS RADIX
1712         TLNE    FLAGS,UNPRSE+FLTBIT     ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE
1713         JRST    PFIXU
1714         MOVE    D,RADX(B)       ; GET OUTPUT RADIX
1715 PFIXU:  CAIG    D,1             ; DONT ALLOW FUNNY RADIX
1716         MOVEI   D,10.           ; IF IN DOUBT USE 10.
1717         PUSH    P,D
1718         MOVEI   A,1             ; START A COUNTER
1719         SKIPGE  B,(TP)          ; CHECK SIGN
1720         MOVEI   A,2             ; NEG, NEED CHAR FOR SIGN
1721
1722         IDIV    B,D             ; START COUNTING
1723         JUMPE   B,.+2
1724         AOJA    A,.-2
1725
1726         MOVE    B,-2(TP)        ; CHANNEL TO B
1727         TLNN    FLAGS,FLTBIT+BINBIT
1728         PUSHJ   P,RETIF3        ; CHECK FOR C.R.
1729         MOVE    B,-2(TP)                ; RESTORE CHANNEL
1730         MOVEI   A,"-            ; GET SIGN
1731         SKIPGE  (TP)            ; SKIP IF NOT NEEDED
1732         PUSHJ   P,PITYO
1733         MOVM    C,(TP)  ; GET MAGNITUDE OF #
1734         MOVE    B,-2(TP)        ; RESTORE CHANNEL
1735         POP     P,E             ; RESTORE RADIX
1736         PUSHJ   P,FIXTYO        ; WRITE OUT THE #
1737         MOVE    FLAGS,-1(P)
1738         SUB     P,[1,,1]        ; FLUSH P STUFF
1739         JRST    PNEXT
1740
1741 FIXTYO: IDIV    C,E
1742         PUSH    P,D             ; SAVE REMAINDER
1743         SKIPE   C
1744         PUSHJ   P,FIXTYO
1745         POP     P,A             ; START GETTING #'S BACK
1746         ADDI    A,60
1747         MOVE    B,-2(TP)                ; CHANNEL BACK
1748         JRST    PITYO
1749
1750 \f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
1751 ;
1752 PFLOAT: SKIPN   A,(TP)          ; SKIP IF NUMBER IS NON-ZERO
1753                                 ;       SPECIAL HACK FOR ZERO)
1754         JRST    PFLT0           ; HACK THAT ZERO
1755         MOVM    E,A             ; CHECK FOR NORMALIZED
1756         TLNN    E,400           ; NORMALIZED
1757         JRST    PUNK
1758         MOVE    E,[SETZ FLOATB] ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
1759         MOVE    D,[6,,6]        ;# WORDS TO GET FROM STACK
1760
1761 PNUMB:  HRLI    A,1(P)          ; LH(A) TO CONTAIN ADDRESS OF RETURN AREA
1762                                 ;       ON STACK
1763         HRR     A,TP            ; RH(A) TO CONTAIN ADDRESS OF DATA ITEM
1764         HLRZ    B,A             ; SAVE RETURN AREA ADDRESS IN REG B
1765         ADD     P,D             ; ADD # WORDS OF RETURN AREA TO BOTH HALVES OF
1766                                 ;       SP
1767         JUMPGE  P,PDLERR        ; PLUS OR ZERO STACK POINTER IS OVERFLOW
1768 PDLWIN: PUSHJ   P,(E)           ; CALL ROUTINE WHOSE ADDRESS IS IN REG E
1769
1770         MOVE    C,(B)           ; GET COUNT 0F # CHARS RETURNED
1771 PFLT1:  MOVE    A,B
1772         HRR     B,P             ; GET PSTACK POINTER AND PRODUCE RELATAVIZED
1773         SUB     A,B
1774         HRLS    A                       ; ADD TO AOBJN
1775         ADD     A,P             ; PRODUCE PDL POINTER
1776         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
1777         PUSH    TP,$TPDL                ; PUSH PDL POINTER
1778         PUSH    TP,A
1779         MOVE    A,C             ; MAKE SURE THAT # WILL FIT ON PRINT LINE
1780         PUSH    P,D             ; WATCH THAT MCALL
1781         PUSHJ   P,RETIF         ; START NEW LINE IF IT WON'T
1782         POP     P,D
1783         POP     TP,B            ; RESTORE B
1784         SUB     TP,[1,,1]               ; CLEAN OFF STACK
1785
1786         HRLI    B,000700        ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR
1787                                 ;       LESS ONE
1788 PNUM01: ILDB    A,B             ; GET NEXT BYTE
1789         PUSH    P,B             ; SAVE B
1790         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
1791         PUSHJ   P,PITYO         ; PRINT IT
1792         POP     P,B             ; RESTORE B
1793         SOJG    C,PNUM01        ; DECREMENT CHAR COUNT: LOOP IF NON-ZERO
1794
1795         SUB     P,D     ;SUBTRACT # WORDS USED ON STACK FOR RETURN
1796         JRST    PNEXT   ;STORE REGS & POP UP ONE LEVEL TO CALLER
1797
1798
1799 PFLT0:  MOVEI   A,9.    ; WIDTH OF 0.0000000
1800         MOVEI   C,9.    ; SEE ABOVE
1801         MOVEI   D,0     ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING
1802         MOVEI   B,[ASCII /0.0000000/]
1803         SOJA    B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE
1804
1805
1806
1807
1808 PDLERR: SUB     P,D             ;REST STACK POINTER
1809 REPEAT 6,PUSH   P,[0]
1810         JRST PDLWIN
1811 \f
1812 ; FLOATING POINT PRINTER STOLEN FROM DDT
1813
1814 F==E+1
1815 G==F+1
1816 H==G+1
1817 I==H+1
1818 J==I+1
1819 TEM1==I
1820
1821 FLOATB: PUSH    P,B
1822         PUSH    P,C
1823         PUSH    P,D
1824         PUSH    P,F
1825         PUSH    P,G
1826         PUSH    P,H
1827         PUSH    P,I
1828         PUSH    P,0
1829         PUSH    P,J
1830         MOVSI   0,440700        ; BUILD BYTEPNTR
1831         HLRZ    J,A             ; POINT TO BUFFER
1832         HRRI    0,1(J)
1833         ANDI    A,-1
1834         MOVE    A,(A)           ; GET NUMBER
1835         MOVE    D,A
1836         SETZM   (J)             ; Clear counter
1837         PUSHJ   P,NFLOT
1838         POP     P,J
1839         POP     P,0
1840         POP     P,I
1841         POP     P,H
1842         POP     P,G
1843         POP     P,F
1844         POP     P,D
1845         POP     P,C
1846         POP     P,B
1847         POPJ    P,
1848
1849 ; at this point we enter code abstracted from DDT.
1850 NFLOT:  JUMPG   A,TFL1
1851         JUMPE   A,FP1A
1852         MOVNS   A
1853         PUSH    P,A
1854         MOVEI   A,"-
1855         PUSHJ   P,CHRO
1856         POP     P,A
1857         TLZE    A,400000
1858         JRST    FP1A
1859
1860 TFL1:   MOVEI   B,0
1861 TFLX:   CAMGE   A,FT01
1862         JRST    FP4
1863         CAML    A,FT8
1864         AOJA    B,FP4
1865 FP1A:
1866 FP3:    SETZB   C,TEM1          ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION
1867         MULI    A,400
1868         ASHC    B,-243(A)
1869         MOVE    A,B
1870         PUSHJ   P,FP7
1871         PUSH    P,A
1872         MOVEI   A,".
1873         PUSHJ   P,CHRO
1874         POP     P,A
1875         MOVNI   A,10
1876         ADD     A,TEM1
1877         MOVE    E,C
1878 FP3A:   MOVE    D,E
1879         MULI    D,12
1880         PUSHJ   P,FP7B
1881         SKIPE   E
1882         AOJL    A,FP3A
1883         POPJ    P,              ; ONE return from OFLT here
1884
1885 FP4:    MOVNI   C,6
1886         MOVEI   F,0
1887 FP4A:   ADDI    F,1(F)
1888         XCT     FCP(B)
1889         SOSA    F
1890         FMPR    A,@FXP+1(B)
1891         AOJN    C,FP4A
1892         PUSH    P,EXPSGN(B)
1893         PUSHJ   P,FP3
1894         PUSH    P,A
1895         MOVEI   A,"E
1896         PUSHJ   P,CHRO
1897         POP     P,A
1898         POP     P,D
1899         PUSHJ   P,FDIGIT
1900         MOVE    A,F
1901
1902 FP7:    SKIPE   A       ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT
1903         AOS     TEM1
1904         IDIVI   A,12
1905         PUSH    P,B
1906         JUMPE   A,FP7A1
1907         PUSHJ   P,FP7
1908
1909 FP7A1:  POP     P,D
1910 FP7B:   ADDI    D,"0
1911
1912 ; type digit
1913 FDIGIT: PUSH    P,A
1914         MOVE    A,D
1915         PUSHJ   P,CHRO
1916         POP     P,A
1917         POPJ    P,
1918
1919 CHRO:   AOS     (J)     ; COUNT CHAR
1920         IDPB    A,0     ; STUFF CHAR
1921         POPJ    P,
1922
1923 ; constants
1924         1.0^32.
1925         1.0^16.
1926 FT8:    1.0^8
1927         1.0^4
1928         1.0^2
1929         1.0^1
1930 FT:     1.0^0
1931         1.0^-32.
1932         1.0^-16.
1933         1.0^-8
1934         1.0^-4
1935         1.0^-2
1936 FT01:   1.0^-1
1937 FT0=FT01+1
1938
1939 ; instructions
1940 FCP:    CAMLE   A, FT0(C)
1941         CAMGE   A, FT(C)
1942         0, FT0(C)
1943 FXP:    SETZ FT0(C)
1944         SETZ FT(C)
1945         SETZ FT0(C)
1946 EXPSGN: "-
1947         "+
1948
1949 \f
1950 ;PRINT SHORT (ONE WORD) CHARACTER STRINGS
1951
1952 PCHRS:  MOVEI   A,3     ;MAX # CHARS PLUS 2 (LESS ESCAPES)
1953         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
1954         TLNE    FLAGS,NOQBIT    ;SKIP IF QUOTES WILL BE USED
1955         MOVEI   A,1     ;ELSE, JUST ONE CHARACTER POSSIBLE
1956         PUSHJ   P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
1957         TLNE    FLAGS,NOQBIT    ;DON'T QUOTE IF IN PRINC MODE
1958         JRST    PCASIS
1959         MOVEI   A,"!    ;TYPE A EXCL
1960         PUSHJ   P,PITYO
1961         MOVEI   A,"\            ;AND A BACK SLASH
1962         PUSHJ   P,PITYO
1963
1964 PCASIS: MOVE    A,(TP)          ;GET NEXT BYTE FROM WORD
1965         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
1966         JRST    PCPRNT          ;IF BIT IS ON, PRINT WITHOUT ESCAPING
1967         CAIE    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER
1968         JRST    PCPRNT          ;ESCAPE THE ESCAPE CHARACTER
1969
1970 ESCPRT: MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER
1971         PUSHJ   P,PITYO
1972 PCPRNT: MOVE    A,(TP)          ;GET THE CHARACTER AGAIN
1973         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
1974         TLO     FLAGS,CNTLPC    ;SWITCH ON ^P MODE TEMPORARY
1975         PUSHJ   P,PITYO         ;PRINT IT
1976         TLZ     FLAGS,CNTLPC    ;SWITCH OFF ^P MODE
1977         JRST    PNEXT
1978
1979
1980 \f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
1981 ;
1982 PDEFER: MOVE    A,(B)   ;GET FIRST WORD OF ITEM
1983         MOVE    B,1(B)  ;GET SECOND
1984         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
1985         PUSH    TP,-3(TP)
1986         PUSHJ   P,IPRINT        ;PRINT IT
1987         SUB     TP,[2,,2]       ; POP OFF CHANNEL
1988         JRST    PNEXT   ;GO EXIT
1989
1990
1991 ; Print an ATOM.  TRAILERS are added if the atom is not in the current
1992 ; lexical path.  Also escaping of charactets is performed to allow READ
1993 ; to win.
1994
1995 PATOM:  PUSH    P,[440700,,D]   ; PUSH BYE POINTER TO FINAL STRING
1996         SETZB   D,E             ; SET CHARCOUNT AD DESTINATION TO 0
1997         HLLZS   -1(TP)          ; RH OF TATOM,, WILL COUNT ATOMS IN PATH
1998
1999 PATOM0: PUSH    TP,$TPDL        ; SAVE CURRENT STAKC FOR \ LOGIC
2000         PUSH    TP,P
2001         LDB     A,[301400,,(P)] ; GET BYTE PTR POSITION
2002         DPB     A,[301400,,E]   ; SAVE IN E
2003         MOVE    C,-2(TP)        ; GET ATOM POINTER
2004         ADD     C,[3,,3]        ; POINT TO PNAME
2005         JUMPGE  C,BADPNM        ; NO PNAME, ERROR
2006         HLRE    A,C             ; -# WORDS TO A
2007         PUSH    P,A             ; PUSH THAT FOR "AOSE"
2008         MOVEI   A,177           ; PUT RUBOUT WHERE \ MIGHT GO
2009         JSP     B,DOIDPB
2010         HRLI    C,440700        ; BUILD BYTE POINTER
2011         ILDB    A,C             ; GET FIRST BYTE
2012         JUMPE   A,BADPNM        ; NULL PNAME, ERROR
2013         SKIPA
2014 PATOM1: ILDB    A,C             ; GET A CHAR
2015         JUMPE   A,PATDON        ; END OF PNAME?
2016         TLNN    C,760000        ; SKIP IF NOT WORD BOUNDARY
2017         AOS     (P)             ; COUNT WORD
2018         JRST    PENTCH          ; ENTER THE CHAR INTO OUTPUT
2019
2020 PATDON: LDB     A,[220600,,E]   ; GET "STATE"
2021         LDB     A,STABYT+NONSPC+1       ; SIMULATE "END" CHARACTER
2022         DPB     A,[220600,,E]   ; AND STORE
2023         MOVE    B,E             ; SETUP BYTE POINTER TO 1ST CHAR
2024         TLZ     B,77
2025         HRR     B,(TP)  ; POINT
2026         SUB     TP,[2,,2]       ; FLUSH SAVED PDL
2027         MOVE    C,-1(P)         ; GET BYE POINTER
2028         SUB     P,[2,,2]        ; FLUSH
2029         PUSH    P,D
2030         MOVEI   A,0
2031         IDPB    A,B
2032         AOS     -1(TP)          ; COUNT ATOMS
2033         TLNE    FLAGS,NOQBIT    ; SKIP IF NOT "PRINC"
2034         JRST    NOLEX4          ; NEEDS NO LEXICAL TRAILERS
2035         MOVEI   A,"\            ; GET QUOTER
2036         TLNN    E,2             ; SKIP IF NEEDED
2037         JRST    PATDO1
2038         SOS     -1(TP)          ; DONT COUNT BECAUSE OF SLASH
2039         DPB     A,B             ; CLOBBER
2040 PATDO1: MOVEI   E,(E)           ; CLEAR LH(E)
2041         PUSH    P,C             ; SAVE BYTER
2042         PUSH    P,E             ; ALSO CHAR COUNT
2043
2044         MOVE    B,IMQUOTE OBLIST
2045         PUSH    P,FLAGS
2046         PUSHJ   P,IDVAL         ; GET LOCAL/GLOBAL VALUE
2047         POP     P,FLAGS         ; AND RESTORES FLAGS
2048         MOVE    C,(TP)          ; GET ATOM BACK
2049         HRRZ    C,2(C)          ; GET ITS OBLIST
2050         SKIPN   C
2051         AOJA    A,NOOBL1        ; NONE, USE FALSE
2052         CAMG    C,VECBOT        ; JUMP IF REAL OBLIST
2053         MOVE    C,(C)
2054         HRROS   C
2055         CAME    A,$TLIST        ; SKIP IF  A LIST
2056         CAMN    A,$TOBLS        ; SKIP IF UNREASONABLE VALUE
2057         JRST    CHOBL           ; WINS, NOW LOCATE IT
2058
2059 CHROOT: CAME    C,ROOT+1        ; IS THIS ROOT?
2060         JRST    FNDOBL          ; MUST FIND THE PATH NAME
2061         POP     P,E             ; RESTORE CHAR COUNT
2062         MOVE    D,(P)           ; AND PARTIAL WORD
2063         EXCH    D,-1(P)         ; STORE BYTE POINTER AND GET PARTIAL WORD
2064         MOVEI   A,"!            ; PUT OUT MAGIC
2065         JSP     B,DOIDPB        ; INTO BUFFER
2066         MOVEI   A,"-
2067         JSP     B,DOIDPB
2068         MOVEI   A,40
2069         JSP     B,DOIDPB
2070
2071 NOLEX0: SUB     P,[2,,2]        ; REMOVE COUNTER AND BYTE POINTER
2072         PUSH    P,D             ; PUSH NEXT WORD IF ANY
2073         JRST    NOLEX4
2074
2075 NOLEX:  MOVE    E,(P)           ; GET COUNT
2076         SUB     P,[2,,2]
2077 NOLEX4: MOVEI   E,(E)           ; CLOBBER LH(E)
2078         MOVE    A,E             ; COUNT TO A
2079         SKIPN   (P)             ; FLUSH 0 WORD
2080         SUB     P,[1,,1]
2081         HRRZ    C,-1(TP)        ; GET # OF ATOMS
2082         SUBI    A,(C)           ; FIX COUNT
2083         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2084         PUSHJ   P,RETIF         ; MAY NEED C.R.
2085         MOVEI   C,-1(E)         ; COMPUTE WORDS-1
2086         IDIVI   C,5             ; WORDS-1 TO C
2087         HRLI    C,(C)
2088         MOVE    D,P
2089         SUB     D,C             ; POINTS TO 1ST WORD OF CHARS
2090         MOVSI   C,440700+D      ; BYTEPOINTER TO STRING
2091         PUSH    TP,$TPDL                ; SAVE FROM GC
2092         PUSH    TP,D
2093
2094 PATOUT: ILDB    A,C             ; READ A CHAR
2095         SKIPE   A               ; IGNORE NULS
2096         PUSHJ   P,PITYO         ; PRINT IT
2097         MOVE    D,(TP)          ; RESTORE POINTER
2098         SOJG    E,PATOUT
2099
2100 NOLEXD: SUB     TP,[2,,2]       ; FLUSH TP JUNK
2101         MOVE    P,D             ; RESTORE P
2102         SUB     P,[1,,1]
2103         JRST    PNEXT
2104
2105
2106 PENTCH: TLNE    FLAGS,NOQBIT    ; "PRINC"?
2107         JRST    PENTC1          ; YES, AVOID SLASHING
2108         IDIVI   A,CHRWD ; GET CHARS TYPE
2109         LDB     B,BYTPNT(B)
2110         CAILE   B,NONSPC        ; SKIP IF NOT SPECIAL
2111         JRST    PENTC2          ; SLASH IMMEDIATE
2112         LDB     A,[220600,,E]   ; GET "STATE"
2113         LDB     A,STABYT-1(B)   ; GET NEW STATE
2114         DPB     A,[220600,,E]   ; AND SAVE IT
2115 PENTC3: LDB     A,C             ; RESTORE CHARACTER
2116 PENTC1: JSP     B,DOIDPB
2117         SKIPGE  (P)             ; SKIP IF DONE
2118         JRST    PATOM1          ; CONTINUE
2119         JRST    PATDON
2120
2121 PENTC2: MOVEI   A,"\            ; GET CHAR QUOTER
2122         JSP     B,DOIDPB        ; NEEDED, DO IT
2123         MOVEI   A,4             ; PATCH FOR ATOMS ALREADY BACKSLASHED
2124         JRST    PENTC3-1
2125
2126 ; ROUTINE TO PUT ONE CHAR ON STACK BUFFER
2127
2128 DOIDPB: IDPB    A,-1(P)         ; DEPOSIT
2129         TRNN    D,377           ; SKIP IF D FULL
2130         AOJA    E,(B)
2131         PUSH    P,(P)           ; MOVE TOP OF STACK UP
2132         MOVEM   D,-2(P)         ; SAVE WORDS
2133         MOVE    D,[440700,,D]
2134         MOVEM   D,-1(P)
2135         MOVEI   D,0
2136         AOJA    E,(B)
2137
2138 ; CHECK FOR UNIQUENESS LOOKING INTO PATH
2139
2140 CHOBL:  CAME    A,$TOBLS        ; SINGLE OBLIST?
2141         JRST    LSTOBL          ; NO, AL LIST THEREOF
2142         CAME    B,C             ; THE RIGTH ONE?
2143         JRST    CHROOT          ; NO, CHECK ROOT
2144         JRST    NOLEX           ; WINNER, NO TRAILERS!
2145
2146 LSTOBL: PUSH    TP,A            ; SCAN A LIST OF OBLISTS
2147         PUSH    TP,B
2148         PUSH    TP,A
2149         PUSH    TP,B
2150         PUSH    TP,$TOBLS
2151         PUSH    TP,C
2152
2153 NXTOB2: INTGO                   ; LIST LOOP, PREVENT LOSSAGE
2154         SKIPN   C,-2(TP)                ; SKIP IF NOT DONE
2155         JRST    CHROO1          ; EMPTY, CHECK ROOT
2156         MOVE    B,1(C)          ; GET ONE
2157         CAME    B,(TP)          ; WINNER?
2158         JRST    NXTOBL          ; NO KEEP LOOKING
2159         CAMN    C,-4(TP)        ; SKIP IF NOT FIRST ON  LIST
2160         JRST    NOLEX1
2161         MOVE    A,-6(TP)        ; GET ATOM BACK
2162         MOVEI   D,0
2163         ADD     A,[3,,3]        ; POINT TO PNAME
2164         PUSH    P,0             ; SAVE FROM RLOOKU
2165         PUSH    P,(A)
2166         ADDI    D,5
2167         AOBJN   A,.-2           ; PUSH THE PNAME
2168         PUSH    P,D             ; AND CHAR COUNT
2169         MOVSI   A,TLIST         ; TELL RLOOKU WE WIN
2170         MOVE    B,-4(TP)        ; GET BACK OBLIST LIST
2171         SUB     TP,[6,,6]       ; FLUSH CRAP
2172         PUSHJ   P,RLOOKU        ; FIND IT
2173         POP     P,0
2174         CAMN    B,(TP)          ; SKIP IF NON UNIQUE
2175         JRST    NOLEX           ; UNIQUE , NO TRAILER!!
2176         JRST    CHROO2          ; CHECK ROOT
2177
2178 NXTOBL: HRRZ    B,@-2(TP)       ; STEP THE LIST
2179         MOVEM   B,-2(TP)
2180         JRST    NXTOB2
2181
2182
2183 FNDOBL: MOVE    C,(TP)          ; GET ATOM
2184         MOVSI   A,TOBLS
2185         HRRZ    B,2(C)
2186         CAMG    B,VECBOT
2187         MOVE    B,(B)
2188         HRLI    B,-1
2189         MOVSI   C,TATOM
2190         MOVE    D,IMQUOTE OBLIST
2191         PUSH    P,0
2192         PUSHJ   P,IGET
2193         POP     P,0
2194 NOOBL1: POP     P,E             ; RESTORE CHAR COUNT
2195         MOVE    D,(P)           ; GET PARTIAL WORD
2196         EXCH    D,-1(P)         ; AND BYTE POINTER
2197         CAME    A,$TATOM        ; IF NOT ATOM, USE FALSE
2198         JRST    NOOBL
2199         MOVEM   B,(TP)          ; STORE IN ATOM SLOT
2200         MOVEI   A,"!
2201         JSP     B,DOIDPB        ; WRITE IT OUT
2202         MOVEI   A,"-
2203         JSP     B,DOIDPB
2204         SUB     P,[1,,1]
2205         JRST    PATOM0          ; AND LOOP
2206
2207 NOOBL:  MOVE    C,[440700,,[ASCIZ /!-#FALSE ()/]]
2208         ILDB    A,C
2209         JUMPE   A,NOLEX0
2210         JSP     B,DOIDPB
2211         JRST    .-3
2212
2213
2214 NOLEX1: SUB     TP,[6,,6]       ; FLUSH STUFF
2215         JRST    NOLEX
2216
2217 CHROO1: SUB     TP,[6,,6]
2218 CHROO2: MOVE    C,(TP)          ; GET ATOM
2219         HRRZ    C,2(C)          ; AND ITS OBLIST
2220         CAMG    C,VECBOT
2221         MOVE    C,(C)
2222         HRROS   C
2223         JRST    CHROOT
2224 BADPNM: ERRUUO  EQUOTE BAD-PNAME
2225
2226
2227 \f; STATE TABLES FOR \ OF FIRST CHAR
2228 ;       Each word is a state and each 4 bit byte tells where to go based on the input
2229 ; type.  The types are defined in READER >.  The input type selects a byte pointer
2230 ; into the table which is indexed by the current state.
2231
2232 RADIX 16.
2233
2234 STATS:  431192440               ; INITIAL STATE (0)
2235         434444444               ; HERE ON INIT +- (1)
2236         222222242               ; HERE ON INIT . (2)
2237         434445642               ; HERE ON INIT DIGIT (3)
2238         444444444               ; HERE IF NO \ NEEDE (4)
2239         454444642               ; HERE ON DDDD. (5)
2240         487744444               ; HERE ON E (6)
2241         484444444               ; HERE ON E+- (7)
2242         484444442               ; HERE ON E+-DDD (8)
2243         494444444+<1_28.>       ; HERE ON * (HACK IS TO GET A 10 IN THERE) (9)
2244         494494444+<1_28.>+<2_16.>       ; HERE ON *DDDDD (10)
2245         444444442
2246
2247 RADIX 8.
2248
2249 STABYT: 400400,,STATS(A)        ; LETTERS
2250         340400,,STATS(A)        ; NUMBERS
2251         300400,,STATS(A)        ; PLUS SIGN +
2252         240400,,STATS(A)        ; MINUS SIGN -
2253         200400,,STATS(A)        ; asterick *
2254         140400,,STATS(A)        ; PERIOD .
2255         100400,,STATS(A)        ; LETTER E
2256         040400,,STATS(A)        ; extra
2257         000400,,STATS(A)        ; HERE ON RAP UP
2258
2259 \f;PRINT LONG CHARACTER STRINGS.
2260 ;
2261 PCHSTR: MOVE    B,(TP)
2262         TLZ     FLAGS,ATMBIT    ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
2263         MOVE    D,[AOS E]       ;GET INSTRUCTION TO COUNT CHARACTERS
2264         SETZM   E               ;ZERO COUNT
2265         PUSH    TP,-3(TP)
2266         PUSH    TP,-3(TP)
2267         PUSH    TP,-3(TP)
2268         PUSH    TP,-3(TP)       ;GIVE PCHRST SOME GOODIES TO PLAY WITH
2269         PUSHJ   P,PCHRST        ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
2270         SUB     TP,[4,,4]       ;FLUSH MUNGED GOODIES
2271         MOVE    A,E             ;PUT COUNT RETURNED IN REG A
2272         TLNN    FLAGS,NOQBIT    ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
2273          ADDI   A,2             ;PLUS TWO FOR QUOTES
2274         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2275         PUSHJ   P,RETIF         ;START NEW LINE IF NO SPACE
2276         TLNE    FLAGS,NOQBIT    ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
2277          JRST   PCHS01          ;OTHERWISE, DON'T QUOTE
2278         MOVEI   A,""            ;PRINT A DOUBLE QUOTE
2279         MOVE    B,-2(TP)
2280         PUSHJ   P,PITYO
2281
2282 PCHS01: MOVE    D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
2283         PUSHJ   P,PCHRST        ;TYPE STRING
2284
2285         TLNE    FLAGS,NOQBIT    ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
2286          JRST   PNEXT           ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
2287         MOVEI   A,""            ;PRINT A DOUBLE QUOTE
2288         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2289         PUSHJ   P,PITYO
2290         JRST    PNEXT
2291
2292
2293 ;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
2294 ;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
2295 PCHRST: PUSH    P,A     ;SAVE REGS
2296         PUSH    P,B
2297         PUSH    P,C
2298         PUSH    P,D
2299
2300 PCHR02: INTGO                   ; IN CASE VERY LONG STRING
2301         HRRZ    C,-1(TP)        ;GET COUNT
2302         SOJL    C,PCSOUT        ; DONE?
2303         HRRM    C,-1(TP)
2304         ILDB    A,(TP)          ; GET CHAR
2305
2306         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
2307         JRST    PCSPRT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING
2308         CAIN    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER
2309         JRST    ESCPRN  ;ESCAPE THE ESCAPE CHARACTER
2310         CAIN    A,""    ;SKIP IF NOT A DOUBLE QUOTE
2311         JRST    ESCPRN  ;OTHERWISE, ESCAPE THE """
2312         IDIVI   A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
2313         LDB     B,BYTPNT(B)     ; "
2314         CAIG    B,NONSPC        ;SKIP IF NOT A NUMBER/LETTER
2315         JRST    PCSPRT  ;OTHERWISE, PRINT IT
2316         TLNN    FLAGS,ATMBIT    ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
2317         JRST    PCSPRT  ;OTHERWISE, NO OTHER CHARS TO ESCAPE
2318
2319 ESCPRN: MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER
2320         PUSH    P,B             ; SAVE B
2321         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2322         XCT     (P)-1
2323         POP     P,B             ; RESTORE B
2324
2325 PCSPRT: LDB     A,(TP)  ;GET THE CHARACTER AGAIN
2326         PUSH    P,B             ; SAVE B
2327         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2328         TLNE    FLAGS,NOQBIT    ; SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
2329         TLO     FLAGS,CNTLPC    ; SWITCH ON TEMPORARY ^P MODE
2330         XCT     (P)-1           ;PRINT IT
2331         TLZ     FLAGS,CNTLPC    ; SWITCH OFF ^P MODE
2332         POP     P,B             ; RESTORE B
2333         JRST    PCHR02          ;LOOP THROUGH STRING
2334
2335 PCSOUT: POP     P,D
2336         POP     P,C     ;RESTORE REGS & RETURN
2337         POP     P,B
2338         POP     P,A
2339         POPJ    P,
2340
2341
2342 \f
2343 ; PRINT AN ARBITRARY BYTE STRING
2344
2345 PBYTE:  PUSH    TP,-3(TP)
2346         PUSH    TP,-3(TP)
2347         MOVEI   A,"#
2348         MOVE    B,(TP)
2349         PUSHJ   P,PRETIF
2350         LDB     B,[300600,,-2(TP)]
2351         MOVSI   A,TFIX
2352         PUSHJ   P,IPRINT
2353         MOVE    B,(TP)
2354         PUSHJ   P,SPACEQ
2355         MOVEI   A,"{
2356         MOVE    B,(TP)
2357         PUSHJ   P,PRETIF
2358         HRRZ    A,-3(TP)                ; CHAR COUNT
2359         JUMPE   A,CLSBYT
2360
2361 BYTLP:  SOS     -3(TP)
2362         ILDB    B,-2(TP)                ; GET A BYTE
2363         MOVSI   A,TFIX
2364         PUSHJ   P,IPRINT
2365         HRRZ    A,-3(TP)
2366         JUMPE   A,CLSBYT
2367         MOVE    B,(TP)
2368         PUSHJ   P,SPACEQ
2369         JRST    BYTLP
2370
2371 CLSBYT: MOVEI   A,"}
2372         MOVE    B,(TP)
2373         PUSHJ   P,PRETIF
2374         SUB     TP,[2,,2]
2375         JRST    PNEXT
2376
2377
2378 ;PRINT AN ARGUMENT LIST
2379 ;CHECK FOR TIME ERRORS
2380
2381 PARGS:  MOVEI   B,-1(TP)        ;POINT TO ARGS POINTER
2382         PUSHJ   P,CHARGS        ;AND CHECK THEM
2383         JRST    PVEC            ; CHEAT TEMPORARILY
2384
2385
2386
2387 ;PRINT A FRAME
2388 PFRAME: MOVEI   B,-1(TP)        ;POINT TO FRAME POINTER
2389         PUSHJ   P,CHFRM
2390         HRRZ    B,(TP)          ;POINT TO FRAME ITSELF
2391         HRRZ    B,FSAV(B)       ;GET POINTER TO SUBROUTINE
2392         CAIL    B,HIBOT
2393         SKIPA   B,@-1(B)        ; SUBRS AND FSUBRS
2394         MOVE    B,3(B)          ; FOR RSUBRS
2395         MOVSI   A,TATOM
2396         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2397         PUSH    TP,-3(TP)
2398         PUSHJ   P,IPRINT        ;PRINT FUNCTION NAME
2399         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2400         JRST    PNEXT
2401
2402 PPVP:   MOVE    B,(TP)          ; PROCESS TO B
2403         MOVSI   A,TFIX
2404         JUMPE   B,.+3
2405         MOVE    A,PROCID(B)
2406         MOVE    B,PROCID+1(B)   ;GET ID
2407         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2408         PUSH    TP,-3(TP)
2409         PUSHJ   P,IPRINT
2410         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2411         JRST    PNEXT
2412
2413 ; HERE TO PRINT LOCATIVES
2414
2415 LOCPT1: HRRZ    A,-1(TP)
2416         JUMPN   A,PUNK
2417 LOCPT:  MOVEI   B,-1(TP)        ; VALIDITY CHECK
2418         PUSHJ   P,CHLOCI
2419         HRRZ    A,-1(TP)
2420         JUMPE   A,GLOCPT
2421         MOVE    B,(TP)
2422         MOVE    A,(B)
2423         MOVE    B,1(B)
2424         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2425         PUSH    TP,-3(TP)
2426         PUSHJ   P,IPRINT
2427         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2428         JRST    PNEXT
2429
2430 GLOCPT: MOVEI   A,2
2431         MOVE    B,-2(TP)                ; GET CHANNEL
2432         PUSHJ   P,RETIF
2433         MOVEI   A,"%
2434         PUSHJ   P,PITYO
2435         MOVEI   A,"<
2436         PUSHJ   P,PITYO
2437         MOVSI   A,TATOM
2438         MOVE    B,MQUOTE GLOC
2439         PUSH    TP,-3(TP)
2440         PUSH    TP,-3(TP)
2441         PUSHJ   P,IPRINT
2442         SUB     TP,[2,,2]
2443         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
2444         PUSHJ   P,SPACEQ
2445         MOVE    B,(TP)
2446         MOVSI   A,TATOM
2447         MOVE    B,-1(B)
2448         PUSH    TP,-3(TP)
2449         PUSH    TP,-3(TP)
2450         PUSHJ   P,IPRINT
2451         SUB     TP,[2,,2]
2452         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
2453         PUSHJ   P,SPACEQ
2454         MOVSI   A,TATOM
2455         MOVE    B,IMQUOTE T
2456         PUSH    TP,-3(TP)
2457         PUSH    TP,-3(TP)
2458         PUSHJ   P,IPRINT
2459         SUB     TP,[2,,2]
2460         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
2461         MOVEI   A,">
2462         PUSHJ   P,PRETIF
2463         JRST    PNEXT
2464
2465 LOCRPT: MOVEI   A,2
2466         MOVE    B,-2(TP)                ; GET CHANNEL
2467         PUSHJ   P,RETIF
2468         MOVEI   A,"%
2469         PUSHJ   P,PITYO
2470         MOVEI   A,"<
2471         PUSHJ   P,PITYO
2472         MOVSI   A,TATOM
2473         MOVE    B,MQUOTE RGLOC
2474         PUSH    TP,-3(TP)
2475         PUSH    TP,-3(TP)
2476         PUSHJ   P,IPRINT
2477         SUB     TP,[2,,2]
2478         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
2479         PUSHJ   P,SPACEQ
2480         MOVE    B,(TP)
2481         MOVSI   A,TATOM
2482         ADD     B,GLOTOP+1              ; GET TO REAL ATOM
2483         MOVE    B,-1(B)
2484         PUSH    TP,-3(TP)
2485         PUSH    TP,-3(TP)
2486         PUSHJ   P,IPRINT
2487         SUB     TP,[2,,2]
2488         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
2489         PUSHJ   P,SPACEQ
2490         MOVSI   A,TATOM
2491         MOVE    B,IMQUOTE T
2492         PUSH    TP,-3(TP)
2493         PUSH    TP,-3(TP)
2494         PUSHJ   P,IPRINT
2495         SUB     TP,[2,,2]
2496         MOVE    B,-2(TP)                ; MOVE IN CHANNEL
2497         MOVEI   A,">
2498         PUSHJ   P,PRETIF
2499         JRST    PNEXT
2500
2501 \f;PRINT UNIFORM VECTORS.
2502 ;
2503 PUVEC:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2504         MOVEI   A,2             ; ROOM FOR ! AND SQ BRACK?
2505         PUSHJ   P,RETIF
2506         MOVEI   A,"!    ;TYPE AN ! AND OPEN SQUARE BRACKET
2507         PUSHJ   P,PITYO
2508         MOVEI   A,"[
2509         PUSHJ   P,PITYO
2510
2511         MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR
2512         TLNN    C,777777        ;SKIP ONLY IF COUNT IS NOT ZERO
2513         JRST    NULVEC  ;ELSE, VECTOR IS EMPTY
2514
2515         HLRE    A,C     ;GET NEG COUNT
2516         MOVEI   D,(C)   ;COPY POINTER
2517         SUB     D,A     ;POINT TO DOPE WORD
2518         HLLZ    A,(D)   ;GET TYPE
2519         PUSH    P,A     ;AND SAVE IT
2520
2521 PUVE02: MOVE    A,(P)   ;PUT TYPE CODE IN REG A
2522         MOVE    B,(C)   ;PUT DATUM INTO REG B
2523         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2524         PUSH    TP,-3(TP)
2525         PUSHJ   P,IPRINT        ;TYPE IT
2526         SUB     TP,[2,,2]       ; POP CHANNEL OF STACK
2527         MOVE    C,(TP)  ;GET AOBJN POINTER
2528         AOBJP   C,NULVE1        ;JUMP IF COUNT IS ZERO
2529         MOVEM   C,(TP)  ;PUT POINTER BACK ONTO STACK
2530
2531         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2532         PUSHJ   P,SPACEQ
2533         MOVE    C,(TP)
2534         JRST    PUVE02  ;LOOP THROUGH VECTOR
2535
2536 NULVE1: SUB     P,[1,,1]        ;REMOVE STACK CRAP
2537 NULVEC: MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2538         MOVEI   A,"!    ;TYPE CLOSE BRACKET
2539         PUSHJ   P,PRETIF
2540         MOVEI   A,"]
2541         PUSHJ   P,PRETIF
2542         JRST    PNEXT
2543
2544 \f;PRINT A GENERALIZED VECTOR
2545 ;
2546 PVEC:   MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2547         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR [
2548         MOVEI   A,"[            ;PRINT A LEFT-BRACKET
2549         PUSHJ   P,PITYO
2550
2551         MOVE    C,(TP)          ;GET AOBJN POINTER TO VECTOR
2552         TLNN    C,777777        ;SKIP IF POINTER-COUNT IS NON-ZERO
2553         JRST    PVCEND          ;ELSE, FINISHED WITH VECTOR
2554 PVCR01: MOVE    A,(C)           ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
2555         MOVE    B,1(C)          ;SECOND WORD OF LIST INTO REG B
2556         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2557         PUSH    TP,-3(TP)
2558         PUSHJ   P,IPRINT        ;PRINT THAT ELEMENT
2559         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2560
2561         MOVE    C,(TP)          ;GET AOBJN POINTER FROM TP-STACK
2562         AOBJP   C,PVCEND        ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
2563         AOBJN   C,.+2           ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
2564         JRST    PVCEND          ;ELSE, FINISHED WITH VECTOR
2565         MOVEM   C,(TP)          ;PUT INCREMENTED POINTER BACK ON TP-STACK
2566
2567         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2568         PUSHJ   P,SPACEQ
2569         MOVE    C,(TP)          ; RESTORE REGISTER C
2570         JRST    PVCR01          ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
2571
2572 PVCEND: MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2573         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR ]
2574         MOVEI   A,"]            ; PRINT A RIGHT-BRACKET
2575         PUSHJ   P,PITYO
2576         JRST    PNEXT
2577
2578 \f;PRINT A LIST.
2579 ;
2580 PLIST:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2581         PUSHJ   P,RETIF1        ;NEW LINE IF NO SPACE LEFT FOR "("
2582         MOVEI   A,"(            ;TYPE AN OPEN PAREN
2583         PUSHJ   P,PITYO
2584         PUSHJ   P,LSTPRT        ;PRINT THE INSIDES
2585         MOVE    B,-2(TP)                ; RESTORE CHANNEL TO B
2586         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
2587         MOVEI   A,")    ;TYPE A CLOSE PAREN
2588         PUSHJ   P,PITYO
2589         JRST    PNEXT
2590
2591 PSEG:   TLOA    FLAGS,SEGBIT    ;PRINT A SEGMENT (& SKIP)
2592
2593 PFORM:  TLZ     FLAGS,SEGBIT    ;PRINT AN ELEMENT
2594
2595 PLMNT3: MOVE    C,(TP)
2596         JUMPE   C,PLMNT1        ;IF THE CALL IS EMPTY GO AWAY
2597         MOVE    B,1(C)
2598         MOVEI   D,0
2599         CAMN    B,IMQUOTE LVAL
2600         MOVEI   D,".
2601         CAMN    B,IMQUOTE GVAL
2602         MOVEI   D,",
2603         CAMN    B,IMQUOTE QUOTE
2604         MOVEI   D,"'
2605         JUMPE   D,PLMNT1                ;NEITHER, LEAVE
2606
2607 ;ITS A SPECIAL HACK
2608         HRRZ    C,(C)
2609         JUMPE   C,PLMNT1        ;NIL BODY?
2610
2611 ;ITS VALUE OF AN ATOM
2612         HLLZ    A,(C)
2613         MOVE    B,1(C)
2614         HRRZ    C,(C)
2615         JUMPN   C,PLMNT1        ;IF TERE ARE EXTRA ARGS GO AWAY
2616
2617         PUSH    P,D             ;PUSH THE CHAR
2618         PUSH    TP,A
2619         PUSH    TP,B
2620         TLNN    FLAGS,SEGBIT    ;SKIP (CONTINUE) IF THIS IS A SEGMENT
2621         JRST    PLMNT4  ;ELSE DON'T PRINT THE "."
2622
2623 ;ITS A SEGMENT CALL
2624         MOVE    B,-4(TP)        ; GET CHANNEL INTO B
2625         MOVEI   A,2             ; ROOM FOR ! AND . OR ,
2626         PUSHJ   P,RETIF
2627         MOVEI   A,"!
2628         PUSHJ   P,PITYO
2629
2630 PLMNT4: MOVE    B,-4(TP)                ; GET CHANNEL INTO B
2631         PUSHJ   P,RETIF1
2632         POP     P,A             ;RESTORE CHAR
2633         PUSHJ   P,PITYO
2634         POP     TP,B
2635         POP     TP,A
2636         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2637         PUSH    TP,-3(TP)
2638         PUSHJ   P,IPRINT
2639         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2640         JRST    PNEXT
2641
2642
2643 PLMNT1: TLNN    FLAGS,SEGBIT    ;SKIP IF THIS IS A SEGMENT
2644         JRST    PLMNT5  ;ELSE DON'T TYPE THE "!"
2645
2646 ;ITS A SEGMENT CALL
2647         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2648         MOVEI   A,2             ; ROOM FOR ! AND <
2649         PUSHJ   P,RETIF
2650         MOVEI   A,"!
2651         PUSHJ   P,PITYO
2652
2653 PLMNT5: MOVE    B,-2(TP)        ; GET CHANNEL FOR B
2654         PUSHJ   P,RETIF1
2655         MOVEI   A,"<
2656         PUSHJ   P,PITYO
2657         PUSHJ   P,LSTPRT
2658         MOVEI   A,"!
2659         MOVE    B,-2(TP)                ; GET CHANNEL INTO B
2660         TLNE    FLAGS,SEGBIT    ;SKIP IF NOT SEGEMNT
2661         PUSHJ   P,PRETIF
2662         MOVEI   A,">
2663         PUSHJ   P,PRETIF
2664         JRST    PNEXT
2665
2666
2667 \f
2668 LSTPRT: SKIPN   C,(TP)
2669         POPJ    P,
2670         HLLZ    A,(C)   ;GET NEXT ELEMENT
2671         MOVE    B,1(C)
2672         HRRZ    C,(C)   ;CHOP THE LIST
2673         JUMPN   C,PLIST1
2674         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2675         PUSH    TP,-3(TP)
2676         PUSHJ   P,IPRINT        ;PRINT THE LAST ELEMENT
2677         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2678         POPJ    P,
2679
2680 PLIST1: MOVEM   C,(TP)
2681         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT
2682         PUSH    TP,-3(TP)
2683         PUSHJ   P,IPRINT        ;PRINT THE NEXT ELEMENT
2684         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK
2685         MOVE    B,-2(TP)        ; GET CHANNEL INTO B
2686         PUSHJ   P,SPACEQ
2687         JRST    LSTPRT  ;REPEAT
2688
2689 PNEXT:  POP     P,FLAGS ;RESTORE PREVIOUS FLAG BITS
2690         SUB     TP,[2,,2]       ;REMOVE INPUT ELEMENT FROM TP-STACK
2691         POP     P,C     ;RESTORE REG C
2692         POPJ    P,
2693
2694 OPENIT: PUSH    P,A
2695         PUSH    P,B
2696         PUSH    P,C
2697         PUSH    P,D
2698         PUSH    P,FLAGS
2699         PUSHJ   P,OPNCHN
2700         POP     P,FLAGS
2701         POP     P,D
2702         POP     P,C
2703         POP     P,B
2704         POP     P,A
2705         JUMPGE  B,FNFFL         ;ERROR IF IT CANNOT BE OPENED
2706         HRRZ    E,-2(B)
2707         POPJ    P,
2708
2709
2710 END
2711 \f