--- /dev/null
+TITLE PRINTER ROUTINE FOR MUDDLE
+RELOCATABLE
+.INSRT DSK:MUDDLE >
+.GLOBAL IPNAME,TYO,FIXB,FLOATB
+.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,NONSPC
+
+FLAGS==0 ;REGISTER USED TO STORE FLAGS
+CARRET==15 ;CARRIAGE RETURN CHARACTER
+ESCHAR=="\ ;ESCAPE CHARACTER
+SPACE==40 ;SPACE CHARACTER
+ATMBIT=200000 ;BIT SWITCH FOR ATOM-NAME PRINT
+NOQBIT=020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
+SEGBIT=010000 ;SWITCH TO INDICATE PRINTING A SEGMENT
+SPCBIT=004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
+FLTBIT=002000 ;SWITCH TO INDICATE "FLATSIZE" CALL
+HSHBIT=001000 ;SWITCH TO INDICATE "PHASH" CALL
+TERBIT=000400 ;SWITCH TO INDICATE "TERPRI" CALL
+
+P.STUF: 0
+
+PSYM:
+ EXCH A,P.STUFF
+ .VALUE [ASCIZ \1c\17.=P.STUF!\eQîP.STUF/\eQ!:VP \1c]
+ PUSH TP, (A)
+ PUSH TP, 1(A)
+ MCALL 1,PRINT
+ EXCH A,P.STUFF
+ POPJ P,
+
+P.=PUSHJ P, PSYM
+
+\fMFUNCTION FLATSIZE,SUBR
+ DEFINE FLTMAX
+ 2(AB)TERMIN
+ DEFINE FLTSIZ
+ 0(TB)TERMIN
+;FLATSIZE TAKES TWO ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
+ ENTRY 2
+ HLRZ A,2(AB)
+ CAIN A,TFIX
+ JRST FLAT1
+;IF THE SECOND ARGUMENT IS NOT FIXED POINT LOSE
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE WRONG-TYPE
+ JRST CALER1
+
+FLAT1: PUSH TP,$TFIX
+ PUSH TP,[0] ;THE VALUE IS ACCUMULATED IN FLTSIZ
+ PUSH P,FLAGS
+ MOVSI FLAGS,FLTBIT
+ MOVE A,(AB) ;IPRINT TAKES ITS ARGUMENT A AND B
+ MOVE B,1(AB)
+ PUSHJ P,IPRINT
+ MOVE A,FLTSIZ
+ MOVE B,FLTSIZ+1
+ JRST FINIS
+
+MFUNCTION PHASH,SUBR
+ DEFINE HSHMAX
+ 2(AB)TERMIN
+ DEFINE HSHNUM
+ 0(TB)TERMIN
+;PHASH TAKES TWO ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS THE HASH NUMBER
+ ENTRY 2
+ HLRZ A,2(AB)
+ CAIN A,TFIX
+ JRST HASH1
+;IF THE SECOND ARGUMENT IS NOT FIXED POINT LOSE
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE WRONG-TYPE
+ JRST CALER1
+
+HASH1: PUSH TP,$TFIX
+ PUSH TP,[0] ;THE VALUE IS ACCUMULATED IN HASHNUM
+ PUSH P,FLAGS
+ MOVSI FLAGS,HSHBIT
+ MOVE A,(AB) ;IPRINT TAKES ITS ARGUMENT A AND B
+ MOVE B,1(AB)
+ PUSHJ P,IPRINT
+ MOVE A,HSHNUM
+ MOVE B,HSHNUM+1
+ JRST FINIS
+
+\fMFUNCTION PRINT,SUBR
+ ENTRY
+ PUSH P,FLAGS ;SAVE THE FLAGS REGISTER
+ MOVSI FLAGS,SPCBIT ;INDICATE PRINTING OF SPACE WHEN DONE
+ JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF
+
+MFUNCTION PRINC,SUBR
+ ENTRY
+ PUSH P,FLAGS ;SAVE THE FLAGS REGISTER
+ MOVSI FLAGS,NOQBIT ;INDICATE PRINC (NO QUOTES OR ESCAPES)
+ JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF
+
+MFUNCTION PRIN1,SUBR
+ ENTRY
+ PUSH P,FLAGS ;SAVE FLAGS REGISTER
+ MOVEI FLAGS,0 ;ZERO (TURN OFF) ALL FLAGS
+ JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF
+
+
+MFUNCTION TERPRI,SUBR
+ ENTRY
+ MOVSI FLAGS,TERBIT+SPCBIT
+ JUMPGE AB,DEFCHN ;IF NO ARG GO GET CURRENT OUT-CHANNEL BINDING
+ CAMG AB,[-2,,0]
+ JRST WNA
+ PUSH TP,$TFIX ;SAVE ROOM ON STACK FOR ONE CHANNEL
+ PUSH TP,[0]
+ MOVE A,(AB)
+ MOVE B,(AB)+1
+ JRST COMPT
+
+\fPRIN01: PUSH P,C ;SAVE REGISTERS C,D, AND E
+ PUSH P,D
+ PUSH P,E
+ PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL
+ PUSH TP,[0]
+
+ HLRZ C,AB ;GET THE AOBJN COUNT FROM AB
+ CAIN C,-2 ;SKIP IF NOT JUST ONE ARGUMENT GIVEN
+ JRST DEFCHN ;ELSE USE EXISTING BINDING OF "OUTCHAN"
+ CAIE C,-4 ;ELSE, THERE MUST BE ONLY TWO ARGUMENTS
+ JRST ARGERR ;MORE ARGUMENTS IS AN ERROR
+ MOVE A,(AB)+2
+ MOVE B,(AB)+3
+COMPT: CAME A,$TLIST
+ JRST BINDPT
+ SKIPN C,(AB)3 ;EMPTY LIST ?
+ JRST FINIS ;IF SO, NO NEED TO CONTINUE
+LISTCK: HRRZ C,(C) ;REST OF LIST
+ JUMPE C,BINDPT ;FINISHED ?
+ PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR THIS ADDITIONAL CHANNEL
+ PUSH TP,[0]
+ JRST LISTCK
+
+BINDPT: PUSH TP,[TATOM,,-1]
+ PUSH TP,MQUOTE OUTCHAN
+ PUSH TP,A ;PUSH NEW OUT-CHANNEL
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSH P,FLAGS ;THESE WILL GET CLOBBERED BY SPECBIND
+ PUSHJ P,SPECBIND
+ POP P,FLAGS
+
+DEFCHN: MOVE B,MQUOTE OUTCHAN
+ MOVSI A,TATOM
+ PUSHJ P,IDVAL ;GET VALUE OF CHANNEL
+ SETZ E, ;CLEAR E FOR SINGLE CHANNEL ARGUMENTS
+ CAMN A,$TCHAN ;SKIP IF IT ISN'T A VALID SINGLE CHANNEL
+ JRST SAVECH
+ CAME A,$TLIST ;SKIP IF IT IS A LIST OF CHANNELS
+ JRST CHNERR ;CAN'T HANDLE ANYTHING ELSE (FOR NOW)
+ SKIPA E,B ;SAVE LIST POINTER IN E
+LOOPCH: ADDI FLAGS,2 ;INCREMENT NUMBER OF CHANNELS COLLECTED
+ HLLZ A,(E) ;GET TYPE (SHOULD BE CHANNEL)
+ CAME A,$TCHAN
+ JRST CHNERR
+ MOVE B,(E)+1 ;GET VALUE
+ HRRZ E,(E) ;UPDATE LIST POINTER
+
+SAVECH: HRRZ C,FLAGS ;GET CURRENT CHANNEL COUNT
+ ADDI C,(TB) ;APPROPRIATE STACK LOCATION
+ CAIN C,(TP)+1 ;NEED MORE ROOM ON STACK FOR LIST ELEMENT CHANNELS ?
+ ADD TP,[2,,2] ;IF SO, GET MORE STACK ROOM
+ MOVEM A,(C) ;SAVE CHANNEL POINTER ON STACK
+ MOVEM B,(C)+1
+ SKIPN IOINS(B) ;SKIP IF I/O INSTRUCTION IS NON-ZERO
+ PUSHJ P,OPNCHN ;ELSE TRY TO OPEN THE CHANNEL
+ JUMPE B,CHNERR ;ERROR IF IT CANNOT BE OPENED
+ MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION
+ PUSHJ P,CHRWRD
+ JFCL
+ CAME B,[ASCII /PRINT/] ;IS IT PRINT
+ JRST CHNERR ;ELSE IT IS AN ERROR
+ JUMPN E,LOOPCH ;IF MORE CHANNELS ON LIST, GO CONSIDER THEM
+ ADDI FLAGS,2 ;MAKE FINAL UPDATE OF COUNT
+\f MOVEI A,CARRET ;GET A CARRIAGE RETURN
+ TLNE FLAGS,SPCBIT ;TYPE IT ONLY IF BIT IS ONE (PRINT)
+ PUSHJ P,PITYO
+ TLNE FLAGS,TERBIT ;IF A CALL TO "TERPRI" YOU ARE THROUGH
+ JRST RFALSE
+
+ MOVE A,(AB) ;FIRST WORD OF ARGUMENT GOES INTO REG A
+ MOVE B,1(AB) ;SECOND WORD INTO REG B
+ PUSHJ P,IPRINT ;CALL INTERNAL ROUTINE TO PRINT IT
+
+ MOVEI A,SPACE
+ TLNE FLAGS,SPCBIT ;SKIP (PRINT A TRAILING SPACE) IF SPCBIT IS ON
+ PUSHJ P,PITYO
+
+ MOVE A,(AB) ;GET FIRST ARGUMENT TO RETURN AS PRINT'S VALUE
+ MOVE B,1(AB)
+
+ POP P,E ;RESTORE REGISTERS C,D, AND E
+ POP P,D
+ POP P,C
+ POP P,FLAGS ;RESTORE THE FLAGS REGISTER
+ JRST FINIS
+
+
+
+
+
+
+RFALSE: MOVSI A,TFALSE
+ MOVEI B,0
+ JRST FINIS
+\fIPRINT: PUSH P,C ;SAVE REGISTER C ON THE P-STACK
+ PUSH P,FLAGS ;SAVE PREVIOUS FLAGS
+ PUSH TP,A ;SAVE ARGUMENT ON TP-STACK
+ PUSH TP,B
+
+ INTGO ;ALLOW INTERRUPTS HERE
+
+ HLRZ A,-1(TP) ;GET THE TYPE CODE OF THE ITEM
+
+ CAILE A,NUMPRI ;SKIP IF TYPE NOT OUTSIDE OF VALID RANGE
+ JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
+ JRST @PTBL(A) ;USE IT AS INDEX TO TRANSFER TABLE TO PRINT ITEM
+
+DISTBL PTBL,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
+[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
+[TARGS,PARGS],[TFRAME,PFRAME],[TUVEC,PUVEC],[TDEFER,PDEFER]
+[TUNAS,PUNAS]]
+
+PUNK: MOVE C,TYPVEC+1(TVP) ;GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
+ HLRZ B,-1(TP) ;GET THE TYPE CODE INTO REG B
+ LSH B,1 ;MULTIPLY BY TWO
+ HRL B,B ;DUPLICATE IT IN THE LEFT HALF
+ ADD C,B ;INCREMENT THE AOBJN-POINTER
+ JUMPGE C,PRERR ;IF POSITIVE, INDEX > VECTOR SIZE
+
+ PUSHJ P,RETIF1 ;START NEW LINE IF NO ROOM
+ MOVEI A,"# ;INDICATE TYPE-NAME FOLLOWS
+ PUSHJ P,PITYO
+ MOVE A,(C) ;GET TYPE-ATOM
+ MOVE B,1(C)
+ PUSHJ P,IPRINT ;PRINT ATOM-NAME
+ MOVE B,(TP) ;RESET THE REAL ARGUMENT POINTER
+ MOVEI A,SPACE ;PRINT A SEPARATING SPACE
+ PUSHJ P,PITYO
+
+ HRRZ A,(C) ;GET THE STORAGE-TYPE
+ JRST @UKTBL(A) ;USE DISPATCH TABLE ON STORAGE TYPE
+
+DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC]
+[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP]]
+
+
+
+\f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
+;
+;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
+PITYO: TLNN FLAGS,FLTBIT
+ JRST PITYO1
+ AOS FLTSIZE+1 ;FLATSIZE DOESN'T PRINT
+ ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
+ SOSL FLTMAX+1 ;UNLESS THE MAXIMUM IS EXCEEDED
+ POPJ P,
+ MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
+ MOVEI B,0
+ JRST FINIS
+
+PITYO1: TLNN FLAGS,HSHBIT
+ JRST ITYO
+ EXCH A,HSHNUM+1
+ ROT A,-7
+ XOR A,HSHNUM+1
+ EXCH A,HSHNUM+1
+ SOSL HSHMAX+1
+ POPJ P,
+ MOVSI A,TFIX
+ MOVE B,HSHNUM+1
+ JRST FINIS
+
+\f;THE REAL THING
+;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
+;CHARACTER STRINGS
+; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
+ITYO: PUSH P,FLAGS ;SAVE STUFF
+ PUSH P,B
+ PUSH P,C
+ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER
+
+ HRRZ B,FLAGS ;GET CURRENT CHANNEL COUNT
+ ADDI B,(TB)-1
+ MOVE B,(B) ;GET THE CHANNEL POINTER
+
+ CAIE A,^L ;SKIP IF THIS IS A FORM-FEED
+ JRST NOTFF
+ SETZM LINPOS(B) ;ZERO THE LINE NUMBER
+ SETZM CHRPOS(B) ; AND CHARACTER NUMBER.
+ XCT IOINS(B) ;FIRST DO A CARRIAGE RETURN-LINE FEED
+ MOVEI A,^L
+ JRST ITYXT
+
+NOTFF: CAIE A,^M ;SKIP IF IT IS A CARRIAGE RETURN
+ JRST NOTCR
+ SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION
+ XCT IOINS(B) ;OUTPUT THE C-R
+ MOVEI A,^J ;FOLLOW WITTH A LINE-FEED
+ AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER
+ CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END
+ JRST ITYXT
+
+ SETZM LINPOS(B) ;ZERO THE LINE POSITION
+ XCT IOINS(B) ;OUTPUT THE LINE FEED
+ MOVEI A,^L ;GET A FORM FEED
+ JRST ITYXT
+
+NOTCR: CAIN A,^I ;SKIP IF NOT TAB
+ JRST TABCNT
+ CAIN A,^J ;SKIP IF NOT LINE FEED
+ JRST ITYXT ;ELSE, DON'T COUNT (JUST OUTPUT IT)
+ AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER
+
+ITYXT: XCT IOINS(B) ;OUTPUT THE CHARACTER
+ POP P,A ;RESTORE THE ORIGINAL CHARACTER
+ SUBI FLAGS,2 ;DECREMENT CHANNEL COUNT
+ TRNE FLAGS,-1 ;ANY MORE CHANNELS ?
+ JRST ITYOCH ;IF SO GO OUTPUT TO THEM
+
+ POP P,C ;RESTORE REGS & RETURN
+ POP P,B
+ POP P,FLAGS
+ POPJ P,
+
+TABCNT: PUSH P,D
+ MOVE C,CHRPOS(B)
+ ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
+ IDIVI C,8.
+ IMULI C,8.
+ MOVEM C,CHRPOS(B) ;REPLACE COUNT
+ POP P,D
+ JRST ITYXT
+
+\fRETIF1: MOVEI A,1
+
+RETIF: TLNE FLAGS,FLTBIT
+ POPJ P, ;IF WE ARE IN FLATSIZE THEN ESCAPE
+ TLNE FLAGS,HSHBIT ;ALSO ESCAPE IF IN HASH
+ POPJ P,
+ PUSH P,FLAGS
+ PUSH P,B
+RETCH: PUSH P,A
+
+ HRRZ B,FLAGS ;GET THE CURRENT CHANNEL COUNT
+ ADDI B,(TB)-1 ;CORRECT PLACE ON STACK
+ MOVE B,(B) ;GET THE CHANNEL POINTER
+ ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION
+ CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH
+ JRST RETXT
+
+ MOVEI A,^M ;FORCE A CARRIAGE RETURN
+ SETZM CHRPOS(B)
+ XCT IOINS(B)
+ MOVEI A,^J ;AND FORCE A LINE FEED
+ XCT IOINS(B)
+ AOS A,LINPOS(B)
+ CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?
+ JRST RETXT
+ MOVEI A,^L ;IF SO FORCE A FORM FEED
+ XCT IOINS(B)
+ SETZM LINPOS(B)
+
+RETXT: POP P,A
+ SUBI FLAGS,2 ;DECREMENT CHANNEL COUNT
+ TRNE FLAGS,-1 ;ANY MORE CHANNELS ?
+ JRST RETCH ;IF SO GO CONSIDER THEM
+
+ POP P,B
+ POP P,FLAGS
+ POPJ P, ;RETURN
+
+PRETIF: PUSH P,A ;SAVE CHAR
+ PUSHJ P,RETIF1
+ POP P,A
+ JRST PITYO
+
+\f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
+;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
+;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
+PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
+ PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
+ MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
+ PUSHJ P,PITYO ;TYPE IT
+
+ MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT
+ ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
+ MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD
+OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE
+ IORI A,60 ;OR-IN 60 FOR ASCII DIGIT
+ PUSHJ P,PITYO ;PRINT IT
+ SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS
+
+PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD
+ PUSHJ P,PITYO
+
+ HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD
+ ;INDEXED OFF TP
+ MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD
+OCTLP2: LDB A,E ;GET 3 BITS
+ IORI A,60 ;CONVERT TO ASCII
+ PUSHJ P,PITYO ;PRINT IT
+ IBP E ;INCREMENT POINTER TO NEXT BYTE
+ SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS
+
+ MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT
+ PUSHJ P,PITYO ;REPRINT IT
+
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+
+POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
+ PUSHJ P,RETIF
+ JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"
+
+\f;PRINT BINARY INTEGERS IN DECIMAL.
+;
+PFIX: MOVEI E,FIXB ;GET ADDRESS OF FIXED POINT CONVERSION ROUTINE
+ MOVE D,[4,,4] ;PUT # WORDS RESERVED ON STACK INTO REG F
+ JRST PNUMB ;PRINT THE NUMBER
+
+;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
+;
+PFLOAT: MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
+ MOVE D,[6,,6] ;# WORDS TO GET FROM STACK
+
+PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK
+ HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM
+ HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B
+ ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP
+ JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW
+ PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E
+
+ MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED
+ MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE
+ PUSHJ P,RETIF ;START NEW LINE IF IT WON'T
+
+ HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE
+PNUM01: ILDB A,B ;GET NEXT BYTE
+ PUSHJ P,PITYO ;PRINT IT
+ SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO
+
+ SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN
+ JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER
+
+\f;PRINT SHORT (ONE WORD) CHARACTER STRINGS.
+;
+PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)
+ TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED
+ MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE
+ PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
+ TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE
+ JRST PCASIS
+ MOVEI A,"! ;TYPE A EXCL
+ PUSHJ P,PITYO
+ MOVEI A,"" ;AND A DOUBLE QUOTE
+ PUSHJ P,PITYO
+
+PCASIS: LDB A,[350700,,(TP)] ;GET NEXT BYTE FROM WORD
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+ CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
+ JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER
+
+ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
+ PUSHJ P,PITYO
+
+PCPRNT: LDB A,[350700,,(TP)] ;GET THE CHARACTER AGAIN
+ PUSHJ P,PITYO ;PRINT IT
+ JRST PNEXT
+
+
+\f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
+;
+PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM
+ MOVE B,1(B) ;GET SECOND
+ PUSHJ P,IPRINT ;PRINT IT
+ JRST PNEXT ;GO EXIT
+
+;PRINT ATOM NAMES.
+;
+PATOM: TLO FLAGS,ATMBIT ;INDICATE ATOM-NAME PRINT OUT
+ HRRZ B,(TP) ;GET ADDRESS OF ATOM
+ ADDI B,2 ;POINT TO FIRST P-NAME WORD
+ HRLI B,350700 ;MAKE INTO A BYTE POINTER
+ HLRE A,(TP) ;GET LENGTH
+ MOVMS A ;ABSOLUTE VALUE
+ ADDI A,-1(B) ;POINT TO LAST WORD
+ HRLI A,TCHSTR ;CHANGE TYPE
+ PUSH TP,A ;PUT STRING ON STACK
+ PUSH TP,B
+
+ MOVE D,[AOS E] ;GET COUNTING INSTRUCTION
+ SETZM E ;ZERO COUNT
+ PUSHJ P,PCHRST ;COUNT CHARACTERS & ESCAPES
+ MOVE A,E ;GET RETURNED COUNT
+ PUSHJ P,RETIF ;DO A CARRIAGE RETURN IF NOT ENOUGH ROOM ON THIS LINE
+
+ MOVEM B,(TP) ;RESET BYTE POINTER
+ MOVE D,[PUSHJ P,PITYO] ;GET OUTPUT INSTRUCTION
+ PUSHJ P,PCHRST ;PRINT STRING
+
+ SUB TP,[2,,2] ;REMOVE CHARACTER STRING ITEM
+ JRST PNEXT
+
+\f;PRINT LONG CHARACTER STRINGS.
+;
+PCHSTR: TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
+
+ MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS
+ SETZM E ;ZERO COUNT
+ PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
+ MOVE A,E ;PUT COUNT RETURNED IN REG A
+ TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
+ ADDI A,2 ;PLUS TWO FOR QUOTES
+ PUSHJ P,RETIF ;START NEW LINE IF NO SPACE
+
+ TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
+ JRST PCHS01 ;OTHERWISE, DON'T QUOTE
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE
+ PUSHJ P,PITYO
+
+PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
+ MOVEM B,(TP) ;RESET BYTE POINTER
+ PUSHJ P,PCHRST ;TYPE STRING
+
+ TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+
+\f;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
+;
+;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
+;
+PCHRST: PUSH P,A ;SAVE REGS
+ PUSH P,B
+ PUSH P,C
+ LDB A,(TP) ;GET FIRST BYTE
+ SKIPA
+
+PCHR02: ILDB A,(TP) ;GET THE NEXT CHARACTER
+ JUMPE A,PCSOUT ;ZERO BYTE TERMINATES
+ HRRZ C,-1(TP) ;GET ADDRESS OF DOPE WORD
+ HRRZ B,(TP) ;GET WORD ADDRESS OF LAST BYTE
+ CAIL B,-1(C) ;SKIP IF IT IS AT LEAST TWO BEFORE DOPE WORD
+ JRST PCSOUT ;ELSE, STRING IS FINISHED
+
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+ CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
+ JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER
+ CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE
+ JRST ESCPRN ;OTHERWISE, ESCAPE THE """
+ IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
+ LDB B,BYTPNT(B) ; "
+ CAIG B,NONSPC ;SKIP IF ATOM-BREAKER
+ JRST PCSPRT ;OTHERWISE, PRINT IT
+ TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
+ JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE
+
+ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
+ XCT D
+
+PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN
+ XCT D ;PRINT IT
+ JRST PCHR02 ;LOOP THROUGH STRING
+
+PCSOUT: POP P,C ;RESTORE REGS & RETURN
+ POP P,B
+ POP P,A
+ POPJ P,
+
+
+\f;PRINT AN ARGUMENT LIST
+;CHECK FOR TIME ERRORS
+
+PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER
+ PUSHJ P,CHARGS ;AND CHECK THEM
+ JRST PVEC ; CHEAT TEMPORARILY
+
+
+
+;PRINT A FRAME
+PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER
+ PUSHJ P,CHFRM
+ HRRZ B,(TP) ;POINT TO FRAME ITSELF
+ HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE
+ MOVE B,@-1(B) ;PICKUP ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B ;SAVE IT
+ MOVSI A,TATOM
+ MOVE B,MQUOTE -STACK-FRAME-FOR-
+ PUSHJ P,IPRINT ;PRINT IT
+ POP TP,B
+ POP TP,A
+ PUSHJ P,IPRINT ;PRINT FUNCTION NAME
+ JRST PNEXT
+
+PPVP: MOVE B,MQUOTE -PROCESS-
+ MOVSI A,TATOM
+ PUSHJ P,IPRINT
+ MOVE B,(TP) ;GET PVP
+ MOVE A,PROCID(B)
+ MOVE B,PROCID+1(B) ;GET ID
+ PUSHJ P,IPRINT
+ JRST PNEXT
+\f;PRINT UNIFORM VECTORS.
+;
+PUVEC: MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET
+ PUSHJ P,PRETIF
+ MOVEI A,"[
+ PUSHJ P,PRETIF
+
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
+ TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO
+ JRST NULVEC ;ELSE, VECTOR IS EMPTY
+
+ HLRE A,C ;GET NEG COUNT
+ MOVEI D,(C) ;COPY POINTER
+ SUB D,A ;POINT TO DOPE WORD
+ HLLZ A,(D) ;GET TYPE
+ PUSH P,A ;AND SAVE IT
+
+PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A
+ MOVE B,(C) ;PUT DATUM INTO REG B
+ PUSHJ P,IPRINT ;TYPE IT
+
+ MOVE C,(TP) ;GET AOBJN POINTER
+ AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO
+ MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK
+
+ MOVEI A,SPACE ;TYPE A BLANK
+ PUSHJ P,PITYO
+ JRST PUVE02 ;LOOP THROUGH VECTOR
+
+NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP
+NULVEC: MOVEI A,"! ;TYPE CLOSE BRACKET
+ PUSHJ P,PRETIF
+ MOVEI A,"]
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+\f;PRINT A GENERALIZED VECTOR.
+;
+PVEC: PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [
+ MOVEI A,"[ ;PRINT A LEFT-BRACKET
+ PUSHJ P,PITYO
+
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
+ TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR
+PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
+ MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B
+ PUSHJ P,IPRINT ;PRINT THAT ELEMENT
+
+ MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK
+ AOBJP C,PDLERR ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
+ AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR
+ MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK
+
+ MOVEI A," ;PRINT A SPACE
+ PUSHJ P,PITYO
+ JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
+
+PVCEND: PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]
+ MOVEI A,"] ;PRINT A RIGHT-BRACKET
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+;PRINT A LIST.
+;
+PLIST: PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("
+ MOVEI A,"( ;TYPE AN OPEN PAREN
+ PUSHJ P,PITYO
+ PUSHJ P,LSTPRT ;PRINT THE INSIDES
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
+ MOVEI A,") ;TYPE A CLOSE PAREN
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+
+
+;PRINT AN UNASSIGNED
+
+PUNAS: PUSHJ P,RETIF1
+ MOVEI A,"?
+ PUSHJ P,PITYO
+ JRST PLIST\fPSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)
+
+PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT
+
+PLMNT3: MOVE C,(TP)
+ JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY
+ MOVE B,1(C)
+ MOVEI D,0
+ CAMN B,MQUOTE LVAL
+ MOVEI D,".
+ CAMN B,MQUOTE GVAL
+ MOVEI D,",
+ CAMN B,MQUOTE QUOTE
+ MOVEI D,"'
+ CAMN B,MQUOTE GIVEN
+ MOVEI D,"?
+ CAMN B,MQUOTE ALTER
+ MOVEI D,"_
+ JUMPE D,PLMNT1 ;NEITHER, LEAVE
+
+;ITS A SPECIAL HACK
+ HRRZ C,(C)
+ JUMPE C,PLMNT1 ;NIL BODY?
+
+;ITS VALUE OF AN ATOM
+ HLLZ A,(C)
+ MOVE B,1(C)
+ HRRZ C,(C)
+ JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY
+
+ PUSH P,D ;PUSH THE CHAR
+ PUSH TP,A
+ PUSH TP,B
+ TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT
+ JRST PLMNT4 ;ELSE DON'T PRINT THE "."
+
+;ITS A SEGMENT CALL
+ PUSHJ P,RETIF1
+ MOVEI A,"!
+ PUSHJ P,PITYO
+
+PLMNT4: PUSHJ P,RETIF1
+ POP P,A ;RESTORE CHAR
+ PUSHJ P,PITYO
+ POP TP,B
+ POP TP,A
+ PUSHJ P,IPRINT
+ JRST PNEXT
+
+\f
+PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT
+ JRST PLMNT5 ;ELSE DON'T TYPE THE "!"
+
+;ITS A SEGMENT CALL
+ PUSHJ P,RETIF1
+ MOVEI A,"!
+ PUSHJ P,PITYO
+\rPLMNT5: PUSHJ P,RETIF1
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ PUSHJ P,LSTPRT
+ MOVEI A,"!
+ TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT
+ PUSHJ P,PRETIF
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+\fLSTPRT: INTGO ;WATCH OUT FOR GARBAGE COLLECTION!
+ SKIPN C,(TP)
+ POPJ P,
+ HLLZ A,(C) ;GET NEXT ELEMENT
+ MOVE B,1(C)
+ HRRZ C,(C) ;CHOP THE LIST
+ JUMPN C,PLIST1
+ PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT
+ POPJ P,
+
+PLIST1: MOVEM C,(TP)
+ PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT
+ PUSHJ P,RETIF1
+ MOVEI A,"
+ PUSHJ P,PITYO ;PRINT THE SPACE AFTER THE NEXT ELEMENT
+ JRST LSTPRT ;REPEAT
+
+PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS
+ SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK
+ POP P,C ;RESTORE REG C
+ POPJ P,
+
+PDLERR: .VALUE 0 ;P-STACK OVERFLOW, VERY SERIOUS, MUDDLE DIES!
+
+CHNERR: PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-CHANNEL
+ JRST CALER1
+
+ARGERR: PUSH TP,$TATOM ;TYPE WRONG # ARGUMENTS
+ PUSH TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
+ JRST CALER1
+
+END
+\f\f\ 3\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff