MUDDLE/nprint.8

   1 TITLE   PRINTER ROUTINE FOR MUDDLE
   2 RELOCATABLE
   3 .INSRT DSK:MUDDLE >
   4 .GLOBAL IPNAME,TYO,FIXB,FLOATB
   5 .GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,NONSPC
   6
   7 FLAGS==0        ;REGISTER USED TO STORE FLAGS
   8 CARRET==15      ;CARRIAGE RETURN CHARACTER
   9 ESCHAR=="\      ;ESCAPE CHARACTER
  10 SPACE==40       ;SPACE CHARACTER
  11 ATMBIT=200000   ;BIT SWITCH FOR ATOM-NAME PRINT
  12 NOQBIT=020000   ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
  13 SEGBIT=010000   ;SWITCH TO INDICATE PRINTING A SEGMENT
  14 SPCBIT=004000   ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
  15 FLTBIT=002000   ;SWITCH TO INDICATE "FLATSIZE" CALL
  16 HSHBIT=001000   ;SWITCH TO INDICATE "PHASH" CALL
  17 TERBIT=000400   ;SWITCH TO INDICATE "TERPRI" CALL
  18
  19 P.STUF: 0
  20
  21 PSYM:
  22         EXCH A,P.STUFF
  23         .VALUE [ASCIZ \1c\17.=P.STUF!\eQîP.STUF/\eQ!:VP \1c]
  24         PUSH TP, (A)
  25         PUSH TP, 1(A)
  26         MCALL 1,PRINT
  27         EXCH A,P.STUFF
  28         POPJ P,
  29
  30 P.=PUSHJ P, PSYM
  31
  32 \fMFUNCTION      FLATSIZE,SUBR
  33         DEFINE FLTMAX
  34                 2(AB)TERMIN
  35         DEFINE FLTSIZ
  36                 0(TB)TERMIN
  37 ;FLATSIZE TAKES TWO ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
  38 ;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
  39         ENTRY   2
  40         HLRZ    A,2(AB)
  41         CAIN    A,TFIX
  42         JRST    FLAT1
  43 ;IF THE SECOND ARGUMENT IS NOT FIXED POINT LOSE
  44         PUSH    TP,$TATOM
  45         PUSH    TP,MQUOTE WRONG-TYPE
  46         JRST    CALER1
  47
  48 FLAT1:  PUSH    TP,$TFIX
  49         PUSH    TP,[0]  ;THE VALUE IS ACCUMULATED IN FLTSIZ
  50         PUSH    P,FLAGS
  51         MOVSI   FLAGS,FLTBIT
  52         MOVE    A,(AB)  ;IPRINT TAKES ITS ARGUMENT A AND B
  53         MOVE    B,1(AB)
  54         PUSHJ   P,IPRINT
  55         MOVE    A,FLTSIZ
  56         MOVE    B,FLTSIZ+1
  57         JRST    FINIS
  58
  59 MFUNCTION       PHASH,SUBR
  60         DEFINE HSHMAX
  61                 2(AB)TERMIN
  62         DEFINE HSHNUM
  63                 0(TB)TERMIN
  64 ;PHASH TAKES TWO ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
  65 ;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS THE HASH NUMBER
  66         ENTRY   2
  67         HLRZ    A,2(AB)
  68         CAIN    A,TFIX
  69         JRST    HASH1
  70 ;IF THE SECOND ARGUMENT IS NOT FIXED POINT LOSE
  71         PUSH    TP,$TATOM
  72         PUSH    TP,MQUOTE WRONG-TYPE
  73         JRST    CALER1
  74
  75 HASH1:  PUSH    TP,$TFIX
  76         PUSH    TP,[0]  ;THE VALUE IS ACCUMULATED IN HASHNUM
  77         PUSH    P,FLAGS
  78         MOVSI   FLAGS,HSHBIT
  79         MOVE    A,(AB)  ;IPRINT TAKES ITS ARGUMENT A AND B
  80         MOVE    B,1(AB)
  81         PUSHJ   P,IPRINT
  82         MOVE    A,HSHNUM
  83         MOVE    B,HSHNUM+1
  84         JRST    FINIS
  85
  86 \fMFUNCTION      PRINT,SUBR
  87         ENTRY
  88         PUSH    P,FLAGS ;SAVE THE FLAGS REGISTER
  89         MOVSI   FLAGS,SPCBIT    ;INDICATE PRINTING OF SPACE WHEN DONE
  90         JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF
  91
  92 MFUNCTION       PRINC,SUBR
  93         ENTRY
  94         PUSH    P,FLAGS ;SAVE THE FLAGS REGISTER
  95         MOVSI   FLAGS,NOQBIT    ;INDICATE PRINC (NO QUOTES OR ESCAPES)
  96         JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF
  97
  98 MFUNCTION       PRIN1,SUBR
  99         ENTRY
 100         PUSH    P,FLAGS ;SAVE FLAGS REGISTER
 101         MOVEI   FLAGS,0 ;ZERO (TURN OFF) ALL FLAGS
 102         JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF
 103
 104
 105 MFUNCTION       TERPRI,SUBR
 106         ENTRY
 107         MOVSI   FLAGS,TERBIT+SPCBIT
 108         JUMPGE  AB,DEFCHN       ;IF NO ARG GO GET CURRENT OUT-CHANNEL BINDING
 109         CAMG    AB,[-2,,0]
 110         JRST    WNA
 111         PUSH    TP,$TFIX        ;SAVE ROOM ON STACK FOR ONE CHANNEL
 112         PUSH    TP,[0]
 113         MOVE    A,(AB)
 114         MOVE    B,(AB)+1
 115         JRST    COMPT
 116
 117 \fPRIN01:        PUSH    P,C     ;SAVE REGISTERS C,D, AND E
 118         PUSH    P,D
 119         PUSH    P,E
 120         PUSH    TP,$TFIX        ;LEAVE ROOM ON STACK FOR ONE CHANNEL
 121         PUSH    TP,[0]
 122
 123         HLRZ    C,AB    ;GET THE AOBJN COUNT FROM AB
 124         CAIN    C,-2    ;SKIP IF NOT JUST ONE ARGUMENT GIVEN
 125         JRST    DEFCHN  ;ELSE USE EXISTING BINDING OF "OUTCHAN"
 126         CAIE    C,-4    ;ELSE, THERE MUST BE ONLY TWO ARGUMENTS
 127         JRST    ARGERR  ;MORE ARGUMENTS IS AN ERROR
 128         MOVE    A,(AB)+2
 129         MOVE    B,(AB)+3
 130 COMPT:  CAME    A,$TLIST
 131         JRST    BINDPT
 132         SKIPN   C,(AB)3 ;EMPTY LIST ?
 133         JRST    FINIS   ;IF SO, NO NEED TO CONTINUE
 134 LISTCK: HRRZ    C,(C)   ;REST OF LIST
 135         JUMPE   C,BINDPT        ;FINISHED ?
 136         PUSH    TP,$TFIX        ;LEAVE ROOM ON STACK FOR THIS ADDITIONAL CHANNEL
 137         PUSH    TP,[0]
 138         JRST    LISTCK
 139
 140 BINDPT: PUSH    TP,[TATOM,,-1]
 141         PUSH    TP,MQUOTE OUTCHAN
 142         PUSH    TP,A    ;PUSH NEW OUT-CHANNEL
 143         PUSH    TP,B
 144         PUSH    TP,[0]
 145         PUSH    TP,[0]
 146         PUSH    P,FLAGS ;THESE WILL GET CLOBBERED BY SPECBIND
 147         PUSHJ   P,SPECBIND
 148         POP     P,FLAGS
 149
 150 DEFCHN: MOVE    B,MQUOTE OUTCHAN
 151         MOVSI   A,TATOM
 152         PUSHJ   P,IDVAL ;GET VALUE OF CHANNEL
 153         SETZ    E,      ;CLEAR E FOR SINGLE CHANNEL ARGUMENTS
 154         CAMN    A,$TCHAN        ;SKIP IF IT ISN'T A VALID SINGLE CHANNEL
 155         JRST    SAVECH
 156         CAME    A,$TLIST        ;SKIP IF IT IS A LIST OF CHANNELS
 157         JRST    CHNERR  ;CAN'T HANDLE ANYTHING ELSE (FOR NOW)
 158         SKIPA   E,B     ;SAVE LIST POINTER IN E
 159 LOOPCH: ADDI    FLAGS,2 ;INCREMENT NUMBER OF CHANNELS COLLECTED
 160         HLLZ    A,(E)   ;GET TYPE (SHOULD BE CHANNEL)
 161         CAME    A,$TCHAN
 162         JRST    CHNERR
 163         MOVE    B,(E)+1 ;GET VALUE
 164         HRRZ    E,(E)   ;UPDATE LIST POINTER
 165
 166 SAVECH: HRRZ    C,FLAGS ;GET CURRENT CHANNEL COUNT
 167         ADDI    C,(TB)  ;APPROPRIATE STACK LOCATION
 168         CAIN    C,(TP)+1        ;NEED MORE ROOM ON STACK FOR LIST ELEMENT CHANNELS ?
 169         ADD     TP,[2,,2]       ;IF SO, GET MORE STACK ROOM
 170         MOVEM   A,(C)   ;SAVE CHANNEL POINTER ON STACK
 171         MOVEM   B,(C)+1
 172         SKIPN   IOINS(B)        ;SKIP IF I/O INSTRUCTION IS NON-ZERO
 173         PUSHJ   P,OPNCHN        ;ELSE TRY TO OPEN THE CHANNEL
 174         JUMPE   B,CHNERR        ;ERROR IF IT CANNOT BE OPENED
 175         MOVEI   B,DIRECT-1(B)   ;POINT TO DIRECTION
 176         PUSHJ   P,CHRWRD
 177         JFCL
 178         CAME    B,[ASCII /PRINT/]       ;IS IT PRINT
 179         JRST    CHNERR  ;ELSE IT IS AN ERROR
 180         JUMPN   E,LOOPCH        ;IF MORE CHANNELS ON LIST, GO CONSIDER THEM
 181         ADDI    FLAGS,2 ;MAKE FINAL UPDATE OF COUNT
 182 \f       MOVEI   A,CARRET        ;GET A CARRIAGE RETURN
 183         TLNE    FLAGS,SPCBIT    ;TYPE IT ONLY IF BIT IS ONE (PRINT)
 184         PUSHJ   P,PITYO
 185         TLNE    FLAGS,TERBIT    ;IF A CALL TO "TERPRI" YOU ARE THROUGH
 186         JRST    RFALSE
 187
 188         MOVE    A,(AB)  ;FIRST WORD OF ARGUMENT GOES INTO REG A
 189         MOVE    B,1(AB) ;SECOND WORD INTO REG B
 190         PUSHJ   P,IPRINT        ;CALL INTERNAL ROUTINE TO PRINT IT
 191
 192         MOVEI   A,SPACE
 193         TLNE    FLAGS,SPCBIT    ;SKIP (PRINT A TRAILING SPACE) IF SPCBIT IS ON
 194         PUSHJ   P,PITYO
 195
 196         MOVE    A,(AB)  ;GET FIRST ARGUMENT TO RETURN AS PRINT'S VALUE
 197         MOVE    B,1(AB)
 198
 199         POP     P,E     ;RESTORE REGISTERS C,D, AND E
 200         POP     P,D
 201         POP     P,C
 202         POP     P,FLAGS ;RESTORE THE FLAGS REGISTER
 203         JRST    FINIS
 204
 205
 206
 207
 208
 209
 210 RFALSE: MOVSI   A,TFALSE
 211         MOVEI   B,0
 212         JRST    FINIS
 213 \fIPRINT:        PUSH    P,C     ;SAVE REGISTER C ON THE P-STACK
 214         PUSH    P,FLAGS ;SAVE PREVIOUS FLAGS
 215         PUSH    TP,A    ;SAVE ARGUMENT ON TP-STACK
 216         PUSH    TP,B
 217
 218         INTGO           ;ALLOW INTERRUPTS HERE
 219
 220         HLRZ    A,-1(TP)        ;GET THE TYPE CODE OF THE ITEM
 221
 222         CAILE   A,NUMPRI        ;SKIP IF TYPE NOT OUTSIDE OF VALID RANGE
 223         JRST    PUNK    ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
 224         JRST    @PTBL(A)        ;USE IT AS INDEX TO TRANSFER TABLE TO PRINT ITEM
 225
 226 DISTBL  PTBL,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
 227 [TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
 228 [TARGS,PARGS],[TFRAME,PFRAME],[TUVEC,PUVEC],[TDEFER,PDEFER]
 229 [TUNAS,PUNAS]]
 230
 231 PUNK:   MOVE    C,TYPVEC+1(TVP) ;GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
 232         HLRZ    B,-1(TP)        ;GET THE TYPE CODE INTO REG B
 233         LSH     B,1     ;MULTIPLY BY TWO
 234         HRL     B,B     ;DUPLICATE IT IN THE LEFT HALF
 235         ADD     C,B     ;INCREMENT THE AOBJN-POINTER
 236         JUMPGE  C,PRERR ;IF POSITIVE, INDEX > VECTOR SIZE
 237
 238         PUSHJ   P,RETIF1        ;START NEW LINE IF NO ROOM
 239         MOVEI   A,"#    ;INDICATE TYPE-NAME FOLLOWS
 240         PUSHJ   P,PITYO
 241         MOVE    A,(C)   ;GET TYPE-ATOM
 242         MOVE    B,1(C)
 243         PUSHJ   P,IPRINT        ;PRINT ATOM-NAME
 244         MOVE    B,(TP)  ;RESET THE REAL ARGUMENT POINTER
 245         MOVEI   A,SPACE ;PRINT A SEPARATING SPACE
 246         PUSHJ   P,PITYO
 247
 248         HRRZ    A,(C)   ;GET THE STORAGE-TYPE
 249         JRST    @UKTBL(A)       ;USE DISPATCH TABLE ON STORAGE TYPE
 250
 251 DISTBS  UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC]
 252 [SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP]]
 253
 254
 255
 256 \f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
 257 ;
 258 ;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
 259 PITYO:  TLNN    FLAGS,FLTBIT
 260         JRST    PITYO1
 261         AOS     FLTSIZE+1       ;FLATSIZE DOESN'T PRINT
 262                         ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
 263         SOSL    FLTMAX+1        ;UNLESS THE MAXIMUM IS EXCEEDED
 264         POPJ    P,
 265         MOVSI   A,TFALSE        ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
 266         MOVEI   B,0
 267         JRST    FINIS
 268
 269 PITYO1: TLNN FLAGS,HSHBIT
 270         JRST ITYO
 271         EXCH A,HSHNUM+1
 272         ROT A,-7
 273         XOR A,HSHNUM+1
 274         EXCH A,HSHNUM+1
 275         SOSL HSHMAX+1
 276         POPJ P,
 277         MOVSI A,TFIX
 278         MOVE B,HSHNUM+1
 279         JRST FINIS
 280
 281 \f;THE REAL THING
 282 ;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
 283 ;CHARACTER STRINGS
 284 ; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
 285 ITYO:   PUSH    P,FLAGS ;SAVE STUFF
 286         PUSH    P,B
 287         PUSH    P,C
 288 ITYOCH: PUSH    P,A     ;SAVE OUTPUT CHARACTER
 289
 290         HRRZ    B,FLAGS ;GET CURRENT CHANNEL COUNT
 291         ADDI    B,(TB)-1
 292         MOVE    B,(B)   ;GET THE CHANNEL POINTER
 293
 294         CAIE    A,^L    ;SKIP IF THIS IS A FORM-FEED
 295         JRST    NOTFF
 296         SETZM   LINPOS(B)       ;ZERO THE LINE NUMBER
 297         SETZM   CHRPOS(B)       ;       AND CHARACTER NUMBER.
 298         XCT     IOINS(B)        ;FIRST DO A CARRIAGE RETURN-LINE FEED
 299         MOVEI   A,^L
 300         JRST    ITYXT
 301
 302 NOTFF:  CAIE    A,^M    ;SKIP IF IT IS A CARRIAGE RETURN
 303         JRST    NOTCR
 304         SETZM   CHRPOS(B)       ;ZERO THE CHARACTER POSITION
 305         XCT     IOINS(B)        ;OUTPUT THE C-R
 306         MOVEI   A,^J    ;FOLLOW WITTH A LINE-FEED
 307         AOS     C,LINPOS(B)     ;ADD ONE TO THE LINE NUMBER
 308         CAMG    C,PAGLN(B)      ;SKIP IF THIS TAKES US PAST PAGE END
 309         JRST    ITYXT
 310
 311         SETZM   LINPOS(B)       ;ZERO THE LINE POSITION
 312         XCT     IOINS(B)        ;OUTPUT THE LINE FEED
 313         MOVEI   A,^L    ;GET A FORM FEED
 314         JRST    ITYXT
 315
 316 NOTCR:  CAIN    A,^I    ;SKIP IF NOT TAB
 317         JRST    TABCNT
 318         CAIN    A,^J    ;SKIP IF NOT LINE FEED
 319         JRST    ITYXT   ;ELSE, DON'T COUNT (JUST OUTPUT IT)
 320         AOS     CHRPOS(B)       ;ADD TO CHARACTER NUMBER
 321
 322 ITYXT:  XCT     IOINS(B)        ;OUTPUT THE CHARACTER
 323         POP     P,A     ;RESTORE THE ORIGINAL CHARACTER
 324         SUBI    FLAGS,2 ;DECREMENT CHANNEL COUNT
 325         TRNE    FLAGS,-1        ;ANY MORE CHANNELS ?
 326         JRST    ITYOCH  ;IF SO GO OUTPUT TO THEM
 327
 328         POP     P,C     ;RESTORE REGS & RETURN
 329         POP     P,B
 330         POP     P,FLAGS
 331         POPJ    P,
 332
 333 TABCNT: PUSH    P,D
 334         MOVE    C,CHRPOS(B)
 335         ADDI    C,8.    ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
 336         IDIVI   C,8.
 337         IMULI   C,8.
 338         MOVEM   C,CHRPOS(B)     ;REPLACE COUNT
 339         POP     P,D
 340         JRST    ITYXT
 341
 342 \fRETIF1:        MOVEI   A,1
 343
 344 RETIF:  TLNE    FLAGS,FLTBIT
 345         POPJ    P,      ;IF WE ARE IN FLATSIZE THEN ESCAPE
 346         TLNE    FLAGS,HSHBIT    ;ALSO ESCAPE IF IN HASH
 347         POPJ    P,
 348         PUSH    P,FLAGS
 349         PUSH    P,B
 350 RETCH:  PUSH    P,A
 351
 352         HRRZ    B,FLAGS ;GET THE CURRENT CHANNEL COUNT
 353         ADDI    B,(TB)-1        ;CORRECT PLACE ON STACK
 354         MOVE    B,(B)   ;GET THE CHANNEL POINTER
 355         ADD     A,CHRPOS(B)     ;ADD THE CHARACTER POSITION
 356         CAMG    A,LINLN(B)      ;SKIP IF GREATER THAN LINE LENGTH
 357         JRST    RETXT
 358
 359         MOVEI   A,^M    ;FORCE A CARRIAGE RETURN
 360         SETZM   CHRPOS(B)
 361         XCT     IOINS(B)
 362         MOVEI   A,^J    ;AND FORCE A LINE FEED
 363         XCT     IOINS(B)
 364         AOS     A,LINPOS(B)
 365         CAMG    A,PAGLN(B)      ;AT THE END OF THE PAGE ?
 366         JRST    RETXT
 367         MOVEI   A,^L    ;IF SO FORCE A FORM FEED
 368         XCT     IOINS(B)
 369         SETZM   LINPOS(B)
 370
 371 RETXT:  POP     P,A
 372         SUBI    FLAGS,2 ;DECREMENT CHANNEL COUNT
 373         TRNE    FLAGS,-1        ;ANY MORE CHANNELS ?
 374         JRST    RETCH   ;IF SO GO CONSIDER THEM
 375
 376         POP     P,B
 377         POP     P,FLAGS
 378         POPJ    P,      ;RETURN
 379
 380 PRETIF: PUSH    P,A     ;SAVE CHAR
 381         PUSHJ   P,RETIF1
 382         POP     P,A
 383         JRST    PITYO
 384
 385 \f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
 386 ;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
 387 ;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
 388 PRERR:  MOVEI   A,21.   ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
 389         PUSHJ   P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
 390         MOVEI   A,"*    ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
 391         PUSHJ   P,PITYO ;TYPE IT
 392
 393         MOVE    E,[000300,,-2(TP)]      ;GET POINTER INDEXED OFF TP SO THAT
 394                                 ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
 395         MOVEI   D,6     ;# OF OCTAL DIGITS IN HALF WORD
 396 OCTLP1: ILDB    A,E     ;GET NEXT 3-BIT BYTE OF TYPE CODE
 397         IORI    A,60    ;OR-IN 60 FOR ASCII DIGIT
 398         PUSHJ   P,PITYO ;PRINT IT
 399         SOJG    D,OCTLP1        ;REPEAT FOR SIX CHARACTERS
 400
 401 PRE01:  MOVEI   A,"*    ;DELIMIT TYPE CODE FROM VALUE FIELD
 402         PUSHJ   P,PITYO
 403
 404         HRLZI   E,(410300,,(TP))        ;BYTE POINTER TO SECOND WORD
 405                                 ;INDEXED OFF TP
 406         MOVEI   D,12.   ;# OF OCTAL DIGITS IN A WORD
 407 OCTLP2: LDB     A,E     ;GET 3 BITS
 408         IORI    A,60    ;CONVERT TO ASCII
 409         PUSHJ   P,PITYO ;PRINT IT
 410         IBP     E       ;INCREMENT POINTER TO NEXT BYTE
 411         SOJG    D,OCTLP2        ;REPEAT FOR 12. CHARS
 412
 413         MOVEI   A,"*    ;DELIMIT END OF ERROR TYPEOUT
 414         PUSHJ   P,PITYO ;REPRINT IT
 415
 416         JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
 417
 418 POCTAL: MOVEI   A,14.   ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
 419         PUSHJ   P,RETIF
 420         JRST    PRE01   ;PRINT VALUE AS "*XXXXXXXXXXXX*"
 421
 422 \f;PRINT BINARY INTEGERS IN DECIMAL.
 423 ;
 424 PFIX:   MOVEI   E,FIXB  ;GET ADDRESS OF FIXED POINT CONVERSION ROUTINE
 425         MOVE    D,[4,,4]        ;PUT # WORDS RESERVED ON STACK INTO REG F
 426         JRST    PNUMB   ;PRINT THE NUMBER
 427
 428 ;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
 429 ;
 430 PFLOAT: MOVEI   E,FLOATB        ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
 431         MOVE    D,[6,,6]        ;# WORDS TO GET FROM STACK
 432
 433 PNUMB:  HRLI    A,1(P)  ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK
 434         HRR     A,TP    ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM
 435         HLRZ    B,A     ;SAVE RETURN AREA ADDRESS IN REG B
 436         ADD     P,D     ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP
 437         JUMPGE  P,PDLERR        ;PLUS OR ZERO STACK POINTER IS OVERFLOW
 438         PUSHJ   P,(E)   ;CALL ROUTINE WHOSE ADDRESS IS IN REG E
 439
 440         MOVE    C,(B)   ;GET COUNT 0F # CHARS RETURNED
 441         MOVE    A,C     ;MAKE SURE THAT # WILL FIT ON PRINT LINE
 442         PUSHJ   P,RETIF ;START NEW LINE IF IT WON'T
 443
 444         HRLI    B,000700        ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE
 445 PNUM01: ILDB    A,B     ;GET NEXT BYTE
 446         PUSHJ   P,PITYO ;PRINT IT
 447         SOJG    C,PNUM01        ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO
 448
 449         SUB     P,D     ;SUBTRACT # WORDS USED ON STACK FOR RETURN
 450         JRST    PNEXT   ;STORE REGS & POP UP ONE LEVEL TO CALLER
 451
 452 \f;PRINT SHORT (ONE WORD) CHARACTER STRINGS.
 453 ;
 454 PCHRS:  MOVEI   A,3     ;MAX # CHARS PLUS 2 (LESS ESCAPES)
 455         TLNE    FLAGS,NOQBIT    ;SKIP IF QUOTES WILL BE USED
 456         MOVEI   A,1     ;ELSE, JUST ONE CHARACTER POSSIBLE
 457         PUSHJ   P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
 458         TLNE    FLAGS,NOQBIT    ;DON'T QUOTE IF IN PRINC MODE
 459         JRST    PCASIS
 460         MOVEI   A,"!    ;TYPE A EXCL
 461         PUSHJ   P,PITYO
 462         MOVEI   A,""            ;AND A DOUBLE QUOTE
 463         PUSHJ   P,PITYO
 464
 465 PCASIS: LDB     A,[350700,,(TP)]        ;GET NEXT BYTE FROM WORD
 466         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
 467         JRST    PCPRNT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING
 468         CAIE    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER
 469         JRST    PCPRNT  ;ESCAPE THE ESCAPE CHARACTER
 470
 471 ESCPRT: MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER
 472         PUSHJ   P,PITYO
 473
 474 PCPRNT: LDB     A,[350700,,(TP)]        ;GET THE CHARACTER AGAIN
 475         PUSHJ   P,PITYO ;PRINT IT
 476         JRST    PNEXT
 477
 478
 479 \f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
 480 ;
 481 PDEFER: MOVE    A,(B)   ;GET FIRST WORD OF ITEM
 482         MOVE    B,1(B)  ;GET SECOND
 483         PUSHJ   P,IPRINT        ;PRINT IT
 484         JRST    PNEXT   ;GO EXIT
 485
 486 ;PRINT ATOM NAMES.
 487 ;
 488 PATOM:  TLO     FLAGS,ATMBIT    ;INDICATE ATOM-NAME PRINT OUT
 489         HRRZ    B,(TP)  ;GET ADDRESS OF ATOM
 490         ADDI    B,2     ;POINT TO FIRST P-NAME WORD
 491         HRLI    B,350700        ;MAKE INTO A BYTE POINTER
 492         HLRE    A,(TP)  ;GET LENGTH
 493         MOVMS   A       ;ABSOLUTE VALUE
 494         ADDI    A,-1(B) ;POINT TO LAST WORD
 495         HRLI    A,TCHSTR        ;CHANGE TYPE
 496         PUSH    TP,A    ;PUT STRING ON STACK
 497         PUSH    TP,B
 498
 499         MOVE    D,[AOS E]       ;GET COUNTING INSTRUCTION
 500         SETZM   E       ;ZERO COUNT
 501         PUSHJ   P,PCHRST        ;COUNT CHARACTERS & ESCAPES
 502         MOVE    A,E     ;GET RETURNED COUNT
 503         PUSHJ   P,RETIF ;DO A CARRIAGE RETURN IF NOT ENOUGH ROOM ON THIS LINE
 504
 505         MOVEM   B,(TP)  ;RESET BYTE POINTER
 506         MOVE    D,[PUSHJ P,PITYO]       ;GET OUTPUT INSTRUCTION
 507         PUSHJ   P,PCHRST        ;PRINT STRING
 508
 509         SUB     TP,[2,,2]       ;REMOVE CHARACTER STRING ITEM
 510         JRST    PNEXT
 511
 512 \f;PRINT LONG CHARACTER STRINGS.
 513 ;
 514 PCHSTR: TLZ     FLAGS,ATMBIT    ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
 515
 516         MOVE    D,[AOS E]       ;GET INSTRUCTION TO COUNT CHARACTERS
 517         SETZM   E       ;ZERO COUNT
 518         PUSHJ   P,PCHRST        ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
 519         MOVE    A,E     ;PUT COUNT RETURNED IN REG A
 520         TLNN    FLAGS,NOQBIT    ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
 521         ADDI    A,2     ;PLUS TWO FOR QUOTES
 522         PUSHJ   P,RETIF ;START NEW LINE IF NO SPACE
 523
 524         TLNE    FLAGS,NOQBIT    ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
 525         JRST    PCHS01  ;OTHERWISE, DON'T QUOTE
 526         MOVEI   A,""    ;PRINT A DOUBLE QUOTE
 527         PUSHJ   P,PITYO
 528
 529 PCHS01: MOVE    D,[PUSHJ P,PITYO]       ;OUTPUT INSTRUCTION
 530         MOVEM   B,(TP)  ;RESET BYTE POINTER
 531         PUSHJ   P,PCHRST        ;TYPE STRING
 532
 533         TLNE    FLAGS,NOQBIT    ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
 534         JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
 535         MOVEI   A,""    ;PRINT A DOUBLE QUOTE
 536         PUSHJ   P,PITYO
 537         JRST    PNEXT
 538
 539
 540 \f;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
 541 ;
 542 ;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
 543 ;
 544 PCHRST: PUSH    P,A     ;SAVE REGS
 545         PUSH    P,B
 546         PUSH    P,C
 547         LDB     A,(TP)  ;GET FIRST BYTE
 548         SKIPA
 549
 550 PCHR02: ILDB    A,(TP)  ;GET THE NEXT CHARACTER
 551         JUMPE   A,PCSOUT        ;ZERO BYTE TERMINATES
 552         HRRZ    C,-1(TP)        ;GET ADDRESS OF DOPE WORD
 553         HRRZ    B,(TP)  ;GET WORD ADDRESS OF LAST BYTE
 554         CAIL    B,-1(C) ;SKIP IF IT IS AT LEAST TWO BEFORE DOPE WORD
 555         JRST    PCSOUT  ;ELSE, STRING IS FINISHED
 556
 557         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
 558         JRST    PCSPRT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING
 559         CAIN    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER
 560         JRST    ESCPRN  ;ESCAPE THE ESCAPE CHARACTER
 561         CAIN    A,""    ;SKIP IF NOT A DOUBLE QUOTE
 562         JRST    ESCPRN  ;OTHERWISE, ESCAPE THE """
 563         IDIVI   A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
 564         LDB     B,BYTPNT(B)     ; "
 565         CAIG    B,NONSPC                ;SKIP IF ATOM-BREAKER
 566         JRST    PCSPRT  ;OTHERWISE, PRINT IT
 567         TLNN    FLAGS,ATMBIT    ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
 568         JRST    PCSPRT  ;OTHERWISE, NO OTHER CHARS TO ESCAPE
 569
 570 ESCPRN: MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER
 571         XCT     D
 572
 573 PCSPRT: LDB     A,(TP)  ;GET THE CHARACTER AGAIN
 574         XCT     D       ;PRINT IT
 575         JRST    PCHR02  ;LOOP THROUGH STRING
 576
 577 PCSOUT: POP     P,C     ;RESTORE REGS & RETURN
 578         POP     P,B
 579         POP     P,A
 580         POPJ    P,
 581
 582
 583 \f;PRINT AN ARGUMENT LIST
 584 ;CHECK FOR TIME ERRORS
 585
 586 PARGS:  MOVEI   B,-1(TP)                ;POINT TO ARGS POINTER
 587         PUSHJ   P,CHARGS                ;AND CHECK THEM
 588         JRST    PVEC    ; CHEAT TEMPORARILY
 589
 590
 591
 592 ;PRINT A FRAME
 593 PFRAME: MOVEI   B,-1(TP)                ;POINT TO FRAME POINTER
 594         PUSHJ   P,CHFRM
 595         HRRZ    B,(TP)          ;POINT TO FRAME ITSELF
 596         HRRZ    B,FSAV(B)               ;GET POINTER TO SUBROUTINE
 597         MOVE    B,@-1(B)                ;PICKUP ATOM
 598         PUSH    TP,$TATOM
 599         PUSH    TP,B            ;SAVE IT
 600         MOVSI   A,TATOM
 601         MOVE    B,MQUOTE -STACK-FRAME-FOR-
 602         PUSHJ   P,IPRINT                ;PRINT IT
 603         POP     TP,B
 604         POP     TP,A
 605         PUSHJ   P,IPRINT                ;PRINT FUNCTION NAME
 606         JRST    PNEXT
 607
 608 PPVP:   MOVE    B,MQUOTE -PROCESS-
 609         MOVSI   A,TATOM
 610         PUSHJ   P,IPRINT
 611         MOVE    B,(TP)          ;GET PVP
 612         MOVE    A,PROCID(B)
 613         MOVE    B,PROCID+1(B)   ;GET ID
 614         PUSHJ   P,IPRINT
 615         JRST    PNEXT
 616 \f;PRINT UNIFORM VECTORS.
 617 ;
 618 PUVEC:  MOVEI   A,"!    ;TYPE AN ! AND OPEN SQUARE BRACKET
 619         PUSHJ   P,PRETIF
 620         MOVEI   A,"[
 621         PUSHJ   P,PRETIF
 622
 623         MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR
 624         TLNN    C,777777        ;SKIP ONLY IF COUNT IS NOT ZERO
 625         JRST    NULVEC  ;ELSE, VECTOR IS EMPTY
 626
 627         HLRE    A,C     ;GET NEG COUNT
 628         MOVEI   D,(C)   ;COPY POINTER
 629         SUB     D,A     ;POINT TO DOPE WORD
 630         HLLZ    A,(D)   ;GET TYPE
 631         PUSH    P,A     ;AND SAVE IT
 632
 633 PUVE02: MOVE    A,(P)   ;PUT TYPE CODE IN REG A
 634         MOVE    B,(C)   ;PUT DATUM INTO REG B
 635         PUSHJ   P,IPRINT        ;TYPE IT
 636
 637         MOVE    C,(TP)  ;GET AOBJN POINTER
 638         AOBJP   C,NULVE1        ;JUMP IF COUNT IS ZERO
 639         MOVEM   C,(TP)  ;PUT POINTER BACK ONTO STACK
 640
 641         MOVEI   A,SPACE ;TYPE A BLANK
 642         PUSHJ   P,PITYO
 643         JRST    PUVE02  ;LOOP THROUGH VECTOR
 644
 645 NULVE1: SUB     P,[1,,1]        ;REMOVE STACK CRAP
 646 NULVEC: MOVEI   A,"!    ;TYPE CLOSE BRACKET
 647         PUSHJ   P,PRETIF
 648         MOVEI   A,"]
 649         PUSHJ   P,PRETIF
 650         JRST    PNEXT
 651
 652 \f;PRINT A GENERALIZED VECTOR.
 653 ;
 654 PVEC:   PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR [
 655         MOVEI   A,"[    ;PRINT A LEFT-BRACKET
 656         PUSHJ   P,PITYO
 657
 658         MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR
 659         TLNN    C,777777        ;SKIP IF POINTER-COUNT IS NON-ZERO
 660         JRST    PVCEND  ;ELSE, FINISHED WITH VECTOR
 661 PVCR01: MOVE    A,(C)   ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
 662         MOVE    B,1(C)  ;SECOND WORD OF LIST INTO REG B
 663         PUSHJ   P,IPRINT        ;PRINT THAT ELEMENT
 664
 665         MOVE    C,(TP)  ;GET AOBJN POINTER FROM TP-STACK
 666         AOBJP   C,PDLERR        ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
 667         AOBJN   C,.+2   ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
 668         JRST    PVCEND  ;ELSE, FINISHED WITH VECTOR
 669         MOVEM   C,(TP)  ;PUT INCREMENTED POINTER BACK ON TP-STACK
 670
 671         MOVEI   A,"     ;PRINT A SPACE
 672         PUSHJ   P,PITYO
 673         JRST    PVCR01  ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
 674
 675 PVCEND: PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR ]
 676         MOVEI   A,"]    ;PRINT A RIGHT-BRACKET
 677         PUSHJ   P,PITYO
 678         JRST    PNEXT
 679
 680 ;PRINT A LIST.
 681 ;
 682 PLIST:  PUSHJ   P,RETIF1        ;NEW LINE IF NO SPACE LEFT FOR "("
 683         MOVEI   A,"(    ;TYPE AN OPEN PAREN
 684         PUSHJ   P,PITYO
 685         PUSHJ   P,LSTPRT        ;PRINT THE INSIDES
 686         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
 687         MOVEI   A,")    ;TYPE A CLOSE PAREN
 688         PUSHJ   P,PITYO
 689         JRST    PNEXT
 690
 691
 692
 693 ;PRINT AN UNASSIGNED
 694
 695 PUNAS:  PUSHJ   P,RETIF1
 696         MOVEI   A,"?
 697         PUSHJ   P,PITYO
 698         JRST    PLIST\fPSEG:     TLOA    FLAGS,SEGBIT    ;PRINT A SEGMENT (& SKIP)
 699
 700 PFORM:  TLZ     FLAGS,SEGBIT    ;PRINT AN ELEMENT
 701
 702 PLMNT3: MOVE    C,(TP)
 703         JUMPE   C,PLMNT1        ;IF THE CALL IS EMPTY GO AWAY
 704         MOVE    B,1(C)
 705         MOVEI   D,0
 706         CAMN    B,MQUOTE LVAL
 707         MOVEI   D,".
 708         CAMN    B,MQUOTE GVAL
 709         MOVEI   D,",
 710         CAMN    B,MQUOTE QUOTE
 711         MOVEI   D,"'
 712         CAMN    B,MQUOTE GIVEN
 713         MOVEI   D,"?
 714         CAMN    B,MQUOTE ALTER
 715         MOVEI   D,"_
 716         JUMPE   D,PLMNT1                ;NEITHER, LEAVE
 717
 718 ;ITS A SPECIAL HACK
 719         HRRZ    C,(C)
 720         JUMPE   C,PLMNT1        ;NIL BODY?
 721
 722 ;ITS VALUE OF AN ATOM
 723         HLLZ    A,(C)
 724         MOVE    B,1(C)
 725         HRRZ    C,(C)
 726         JUMPN   C,PLMNT1        ;IF TERE ARE EXTRA ARGS GO AWAY
 727
 728         PUSH    P,D             ;PUSH THE CHAR
 729         PUSH    TP,A
 730         PUSH    TP,B
 731         TLNN    FLAGS,SEGBIT    ;SKIP (CONTINUE) IF THIS IS A SEGMENT
 732         JRST    PLMNT4  ;ELSE DON'T PRINT THE "."
 733
 734 ;ITS A SEGMENT CALL
 735         PUSHJ   P,RETIF1
 736         MOVEI   A,"!
 737         PUSHJ   P,PITYO
 738
 739 PLMNT4: PUSHJ   P,RETIF1
 740         POP     P,A             ;RESTORE CHAR
 741         PUSHJ   P,PITYO
 742         POP     TP,B
 743         POP     TP,A
 744         PUSHJ   P,IPRINT
 745         JRST    PNEXT
 746
 747 \f
 748 PLMNT1: TLNN    FLAGS,SEGBIT    ;SKIP IF THIS IS A SEGMENT
 749         JRST    PLMNT5  ;ELSE DON'T TYPE THE "!"
 750
 751 ;ITS A SEGMENT CALL
 752         PUSHJ   P,RETIF1
 753         MOVEI   A,"!
 754         PUSHJ   P,PITYO
 755 \rPLMNT5:        PUSHJ   P,RETIF1
 756         MOVEI   A,"<
 757         PUSHJ   P,PITYO
 758         PUSHJ   P,LSTPRT
 759         MOVEI   A,"!
 760         TLNE    FLAGS,SEGBIT    ;SKIP IF NOT SEGEMNT
 761         PUSHJ   P,PRETIF
 762         MOVEI   A,">
 763         PUSHJ   P,PRETIF
 764         JRST    PNEXT
 765
 766 \fLSTPRT:        INTGO   ;WATCH  OUT FOR GARBAGE COLLECTION!
 767         SKIPN   C,(TP)
 768         POPJ    P,
 769         HLLZ    A,(C)   ;GET NEXT ELEMENT
 770         MOVE    B,1(C)
 771         HRRZ    C,(C)   ;CHOP THE LIST
 772         JUMPN   C,PLIST1
 773         PUSHJ   P,IPRINT        ;PRINT THE LAST ELEMENT
 774         POPJ    P,
 775
 776 PLIST1: MOVEM   C,(TP)
 777         PUSHJ   P, IPRINT       ;PRINT THE NEXT ELEMENT
 778         PUSHJ   P,RETIF1
 779         MOVEI   A,"
 780         PUSHJ   P,PITYO ;PRINT THE SPACE AFTER THE NEXT ELEMENT
 781         JRST    LSTPRT  ;REPEAT
 782
 783 PNEXT:  POP     P,FLAGS ;RESTORE PREVIOUS FLAG BITS
 784         SUB     TP,[2,,2]       ;REMOVE INPUT ELEMENT FROM TP-STACK
 785         POP     P,C     ;RESTORE REG C
 786         POPJ    P,
 787
 788 PDLERR: .VALUE  0       ;P-STACK OVERFLOW, VERY SERIOUS, MUDDLE DIES!
 789
 790 CHNERR: PUSH    TP,$TATOM
 791         PUSH    TP,MQUOTE BAD-CHANNEL
 792         JRST    CALER1
 793
 794 ARGERR: PUSH    TP,$TATOM       ;TYPE WRONG # ARGUMENTS
 795         PUSH    TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
 796         JRST    CALER1
 797
 798 END
 799 \f\f\ 3\f