github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-14 23:55:40 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/mudsys/print.346
Adam Sampson a81db26a7a Rename to ITS conventions. 
MIDAS and Muddle source get version numbers (as in the 1973 Muddle
source); the build files don't.
2018-04-25 09:32:25 +01:00

2711 lines
59 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

TITLE PRINTER ROUTINE FOR MUDDLE
RELOCATABLE
.INSRT DSK:MUDDLE >
.GLOBAL IPNAME,MTYO,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL
.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT
.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID
.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT
.GLOBAL TMPLNT,TD.LNT,BADTPL,MPOPJ,SSPEC1,GLOTOP,GTLPOS,SPSTOR,PVSTOR
.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR
.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH,CPCH1,CICRLF,NONSPC
BUFLNT==100 ; BUFFER LENGTH IN WORDS
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
UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL
ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL
BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL
CNTLPC==000020 ;SWITCH TO INDICATE USING ^P CODE IOT
PJBIT==400000
C.BUF==1
C.PRIN==2
C.BIN==4
C.OPN==10
C.READ==40
MFUNCTION FLATSIZE,SUBR
DEFINE FLTMAX
4(B) TERMIN
DEFINE FLTSIZ
2(B)TERMIN
;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX
ENTRY
CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS
CAMG AB,[-6,,0]
JRST WNA
PUSH P,3(AB)
GETYP A,2(AB)
CAIE A,TFIX
JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE
CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT
JRST .+3 ; RADIX SUPPLIED
PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN
JRST FLTGO
GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX
CAIE A,TFIX
JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE
MOVE C,5(AB)
PUSHJ P,GETARG ; GET ARGS INTO A AND B
FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM
PUSHJ P,CIFLTZ
JFCL
JRST FINIS
MFUNCTION UNPARSE,SUBR
DEFINE UPB
0(B) TERMIN
ENTRY
JUMPGE AB,TFA
MOVE E,TP ;SAVE TP POINTER
;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE
;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED
CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED
JRST .+3
PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN
JRST UNPRGO
CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY
JRST TMA
GETYP 0,2(AB)
CAIE 0,TFIX ;SEE IF RADIX IS FIXED
JRST WTYP2
MOVE C,3(AB) ;GET RADIX
PUSHJ P,GETARG ;GET ARGS INTO A AND B
UNPRGO: PUSHJ P,CIUPRS
JRST FINIS
JRST FINIS
GTRADX: MOVE B,IMQUOTE OUTCHAN
PUSH P,0 ;SAVE FLAGS
PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN
POP P,0
GETYP A,A ;CHECK TYPE OF CHANNEL
CAIE A,TCHAN
JRST FUNCH1-1 ;IT IS A TP-POINTER
MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN
JRST FUNCH1
MOVE C,(B)+6 ;GET RADIX FROM STACK
FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX
MOVEI C,10. ;DEFAULT IF THIS IS THE CASE
GETARG: MOVE A,(AB)
MOVE B,1(AB)
POPJ P,
IMFUNCTION PRINT,SUBR
ENTRY
PUSHJ P,AGET ; GET ARGS
PUSHJ P,CIPRIN
JRST FINIS
MFUNCTION PRINC,SUBR
ENTRY
PUSHJ P,AGET ; GET ARGS
PUSHJ P,CIPRNC
JRST FINIS
MFUNCTION PRIN1,SUBR
ENTRY
PUSHJ P,AGET
PUSHJ P,CIPRN1
JRST FINIS
MFUNCTION CRLF,SUBR
ENTRY
PUSHJ P,AGET1
PUSHJ P,CICRLF
JRST FINIS
MFUNCTION TERPRI,SUBR
ENTRY
PUSHJ P,AGET1
PUSHJ P,CITERP
JRST FINIS
CICRLF: SKIPA E,.
CITERP: MOVEI E,0
SUBM M,(P)
MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS
PUSH P,E
PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL
MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN
PUSHJ P,PITYO ; PRINT IT OUT
MOVEI A,12 ; LINE-FEED
PUSHJ P,PITYO
POP P,0
JUMPN 0,.+4
MOVSI A,TFALSE ; RETURN A FALSE
MOVEI B,0
JRST MPOPJ ; RETURN
MOVSI A,TATOM
MOVE B,IMQUOTE T
JRST MPOPJ
TESTR: GETYP E,A
CAIN E,TCHAN ; CHANNEL?
JRST TESTR1 ; OK?
CAIE E,TTP
JRST BADCHN
HLRZS 0
IOR 0,A ; RESTORE FLAGS
HRLZS 0
POPJ P,
TESTR1: HRRZ E,-2(B) ; GET IN FLAGS FROM CHANNEL
SKIPN IOINS(B)
PUSHJ P,OPENIT
TRNN E,C.OPN ; SKIP IF OPEN
JRST CHNCLS
TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD
TRNE E,C.PRIN+C.OPN
JRST BADCHN ; ITS A LOSER
TRNE E,C.BIN
JRST PSHNDL ; DON'T HANDLE BINARY
TLO ASCBIT ; ITS ASCII
POPJ P, ; ITS A WINNER
PSHNDL: PUSH TP,C ; SAVE ARGS
PUSH TP,D
PUSH TP,A ; PUSH CHANNEL ONTO STACK
PUSH TP,B
PUSHJ P,BPRINT ; CHECK BUFFER
POP TP,B
POP TP,A
POP TP,D
POP TP,C
POPJ P,
;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B
CIUPRS: SUBM M,(P) ; MODIFY M-POINTER
MOVE E,TP ; SAVE TP-POINTER
PUSH TP,[0] ; SLOT FOR FIRST STRING COPY
PUSH TP,[0]
PUSH TP,[0] ; AND SECOND STRING
PUSH TP,[0]
PUSH TP,A ; SAVE OBJECTS
PUSH TP,B
PUSH TP,$TTP ; SAVE TP POINTER
PUSH TP,E
PUSH P,C
MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE
PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING
FATAL UNPARSE BLEW IT
MOVEI A,4(B)
PUSH P,B
IDIVI A,5
PUSHJ P,IBLOCK ; GET A BLOCK
POP P,A
HRLI A,TCHSTR
HRLI B,010700
SUBI B,1
POP TP,E ; RESTORE TP-POINTER
SUB TP,[1,,1] ;GET RID OF TYPE WORD
MOVEM A,1(E) ; SAVE RESULTS
MOVEM A,3(E)
MOVEM B,2(E)
MOVEM B,4(E)
POP TP,B ; RESTORE THE WORLD
POP TP,A
POP P,C
MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS
PUSHJ P,CUSET
JRST MPOPJ ; RETURN
; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,
; A,B THE TYPE-OBJECT PAIR
CIFLTZ: SUBM M,(P)
MOVE E,TP ; SAVE POINTER
PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT
PUSH TP,[0]
PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM
PUSH TP,D
MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG
PUSHJ P,CUSET ; CONTINUE
JRST MPOPJ
SOS (P) ; SKIP RETURN
JRST MPOPJ ; RETURN
; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING
; NEEDED TO GET A RESULT.
CUSET: PUSH TP,$TFIX ; PUSH ON RADIX
PUSH TP,C
PUSH TP,$TPDL
PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE
PUSH TP,A ; SAVE OBJECTS
PUSH TP,B
MOVSI C,TTP ; CONSTRUCT TP-POINTER
HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER
MOVE D,E
PUSH TP,C ; PUSH ON CHANNEL
PUSH TP,D
PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER
POP TP,B ; GET IN TP POINTER
MOVE TP,B ; RESTORE POINTER
TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL
JRST FLTGEN ; ITS A FLATSIZE
MOVE A,UPB+3 ; RETURN STRING
MOVE B,UPB+4
POPJ P, ; DONE
FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT
MOVE B,FLTSIZ
AOS (P)
POPJ P, ; EXIT
; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME
; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL
CIPRIN: SUBM M,(P)
MOVSI 0,SPCBIT ; SET UP FLAGS
PUSHJ P,TPRT ; PRINT INITIALIZATION
PUSHJ P,IPRINT
JRST TPRTE ; EXIT
CIPRN1: SUBM M,(P)
MOVEI FLAGS,0 ; SET UP FLAGS
PUSHJ P,TPR1 ; INITIALIZATION
PUSHJ P,IPRINT ; PRINT IT OUT
JRST TPR1E ; EXIT
CIPRNC: SUBM M,(P)
MOVSI FLAGS,NOQBIT ; SET UP FLAGS
PUSHJ P,TPR1 ; INITIALIZATION
PUSHJ P,IPRINT
JRST TPR1E ; EXIT
; INITIALIZATION FOR PRINT ROUTINES
TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
PUSH TP,C ; SAVE ARGUMENTS
PUSH TP,D
PUSH TP,A ; SAVE CHANNEL
PUSH TP,B
MOVEI A,CARRET ; PRINT CARRIAGE RETURN
PUSHJ P,PITYO
MOVEI A,12 ; AND LF
PUSHJ P,PITYO
MOVE A,-3(TP) ; MOVE IN ARGS
MOVE B,-2(TP)
POPJ P,
; EXIT FOR PRINT ROUTINES
TPRTE: POP TP,B ; RESTORE CHANNEL
MOVEI A,SPACE ; PRINT TRAILING SPACE
PUSHJ P,PITYO
SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD
POP TP,B ; RETURN WHAT WAS PASSED
POP TP,A
JRST MPOPJ ; EXIT
; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES
TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
PUSH TP,C ; SAVE ARGS
PUSH TP,D
PUSH TP,A ; SAVE CHANNEL
PUSH TP,B
MOVE A,-3(TP) ; GET ARGS
MOVE B,-2(TP)
POPJ P,
; EXIT FOR PRIN1 AND PRINC ROUTINES
TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL
POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN
POP TP,A
JRST MPOPJ ; EXIT
CPATM: SUBM M,(P)
MOVSI C,TATOM ; GET TYPE FOR BINARY
MOVEI 0,SPCBIT ; SET UP FLAGS
PUSHJ P,TPRT ; PRINT INITIALIZATION
PUSHJ P,CPATOM ; PRINT IT OUT
JRST TPRTE ; EXIT
CP1ATM: SUBM M,(P)
MOVE C,$TATOM
MOVEI FLAGS,0 ; SET UP FLAGS
PUSHJ P,TPR1 ; INITIALIZATION
PUSHJ P,CPATOM ; PRINT IT OUT
JRST TPR1E ; EXIT
CPCATM: SUBM M,(P)
MOVE C,$TATOM
MOVSI FLAGS,NOQBIT ; SET UP FLAGS
PUSHJ P,TPR1 ; INITIALIZATION
PUSHJ P,CPATOM ; PRINT IT OUT
JRST TPR1E ; EXIT
; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE
; CHARACTER IS IN C.
CPCH1: TDZA 0,0
CPCH: MOVEI 0,1
SUBM M,(P)
PUSH P,0
MOVSI FLAGS,NOQBIT
MOVE C,$TCHRS
PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD
EXCH D,(P) ; CHAR TO STACK, IND TO D
MOVE A,(P) ; MOVE IN CHARACTER FOR PITYO
JUMPE D,.+3
PUSHJ P,PRETIF
JRST .+2
PUSHJ P,PITYO
MOVE A,$TCHRST ; RETURN THE CHARACTER
POP P,B
JRST MPOPJ
CPSTR: SUBM M,(P)
HRLI C,TCHSTR
MOVSI 0,SPCBIT ; SET UP FLAGS
PUSHJ P,TPRT ; PRINT INITIALIZATION
PUSHJ P,CPCHST ; PRINT IT OUT
JRST TPRTE ; EXIT
CP1STR: SUBM M,(P)
HRLI C,TCHSTR
MOVEI FLAGS,0 ; SET UP FLAGS
PUSHJ P,TPR1 ; INITIALIZATION
PUSHJ P,CPCHST ; PRINT IT OUT
JRST TPR1E ; EXIT
CPCSTR: SUBM M,(P)
HRLI C,TCHSTR
MOVSI FLAGS,NOQBIT ; SET UP FLAGS
PUSHJ P,TPR1 ; INITIALIZATION
PUSHJ P,CPCHST ; PRINT IT OUT
JRST TPR1E ; EXIT
CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE
PUSH TP,B
PUSH P,0 ; ATOM CALLER ROUTINE
PUSH P,C
SKIPN C,PRNTYP+1
JRST PATOM
ADDI C,TATOM+TATOM
SKIPE (C) ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH
JRST PRDIS1
SKIPN C,1(C)
JRST PATOM
JRST (C)
CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE
PUSH TP,B
PUSH P,C ; STRING CALLER ROUTINE
PUSH P,FLAGS
SKIPN C,PRNTYP+1
JRST PATOM
ADDI C,TCHSTR+TCHSTR
SKIPE (C) ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH
JRST PRDIS1
SKIPN C,1(C)
JRST PCHSTR
JRST (C)
AGET: MOVEI FLAGS,0
SKIPL E,AB ; COPY ARG POINTER
JRST TFA ;NO ARGS IS AN ERROR
ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL
JRST COMPT
AGET1: MOVE E,AB ; GET COPY OF AB
MOVSI FLAGS,TERBIT
COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL
PUSH TP,[0]
JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING
CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR
JRST TMA
MOVE A,(E) ;GET CHANNEL
MOVE B,(E)+1
JRST NEWCHN
DEFCHN: MOVE B,IMQUOTE OUTCHAN
MOVSI A,TATOM
PUSH P,FLAGS ;SAVE FLAGS
PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN
POP P,0
NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI
POPJ P,
MOVE C,(AB) ; GET ARGS
MOVE D,1(AB)
POPJ P,
; HERE IF USING A PRINTB CHANNEL
BPRINT: TLO FLAGS,BINBIT
SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?
POPJ P,
; HERE TO GENERATE A STRING BUFFER
PUSH P,FLAGS
MOVEI A,BUFLNT ; GET BUFFER LENGTH
PUSHJ P,IBLOCK ; MAKE A BUFFER
MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE
MOVEM 0,BUFLNT(B)
SETOM (B) ; -1 THE BUFFER
MOVEI C,1(B)
HRLI C,(B)
BLT C,BUFLNT-1(B)
HRLI B,010700
SUBI B,1
MOVE C,(TP)
MOVEM B,BUFSTR(C) ; STOR BYTE POINTER
MOVE 0,[TCHSTR,,BUFLNT*5]
MOVEM 0,BUFSTR-1(C)
POP P,FLAGS
MOVE B,(TP)
POPJ P,
IPRINT: PUSH P,C ; SAVE C
PUSH P,FLAGS ;SAVE PREVIOUS FLAGS
PUSH TP,A ;SAVE ARGUMENT ON TP-STACK
PUSH TP,B
INTGO ;ALLOW INTERRUPTS HERE
GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM
SKIPE C,PRNTYP+1 ; USER TYPE TABLE?
JRST PRDISP
NORMAL: CAILE A,NUMPRI ;PRIMITIVE?
JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
HRRO A,PRTYPE(A) ;YES-DISPATCH
JRST (A)
; HERE FOR USER PRINT DISPATCH
PRDISP: ADDI C,(A) ; POINT TO SLOT
ADDI C,(A)
SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
JRST PRDIS1 ; APPLY EVALUATOR
SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
JRST NORMAL
JRST (C)
PRDIS1: SUB C,PRNTYP+1
PUSH P,C
PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND
PUSH TP,IMQUOTE OUTCHAN
PUSH TP,-5(TP)
PUSH TP,-5(TP)
PUSH TP,[0]
PUSH TP,[0]
PUSHJ P,SPECBIND
POP P,C ; RESTORE C
ADD C,PRNTYP+1 ; RESTORE C
PUSH TP,(C) ; PUSH ARGS FOR APPLY
PUSH TP,1(C)
PUSH TP,-9(TP)
PUSH TP,-9(TP)
MCALL 2,APPLY ; APPLY HACKER TO OBJECT
MOVEI E,-8(TP)
PUSHJ P,SSPEC1 ;UNBIND OUTCHAN
SUB TP,[6,,6] ; POP OFF STACK
JRST PNEXT
; PRINT DISPATCH TABLE
IF2,PUNKS==400000,,PUNK
DISTBL PRTYPE,PUNKS,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]
[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]
[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1],[TLOCR,LOCRPT],[TQRSUB,PRSUBR]
[TQENT,PENTRY],[TSATC,PSATC],[TBYTE,PBYTE]
[TOFFS,POFFSE]]
PUNK: MOVE C,TYPVEC+1 ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
GETYP 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
MOVE B,-2(TP) ; MOVE IN CHANNEL
PUSH TP,$TVEC ; SAVE ALLTYPES VECTOR
PUSH TP,C
PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM
MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS
PUSHJ P,PITYO
POP TP,C
SUB TP,[1,,1]
MOVE A,(C) ; GET TYPE-ATOM
MOVE B,1(C)
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT ATOM-NAME
SUB TP,[2,,2] ; POP STACK
MOVE B,-2(TP) ; MOVE IN CHANNEL
PUSHJ P,SPACEQ ; MAYBE SPACE
MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER
HRRZ A,(C) ; GET THE STORAGE-TYPE
ANDI A,SATMSK
CAILE A,NUMSAT ; SKIP IF TEMPLATE
JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE
HRRO A,UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE
JRST (A)
DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]
[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]
[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]
[SLOCT,LOCP],[SLOCB,LOCP],[SBYTE,PBYTE],[SOFFS,POFFSE]]
; SELECK AN ILLEGAL
ILLCH: MOVEI B,-1(TP)
JRST ILLCHO
; PRINT INTERRUPT HANDLER
PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B
PUSHJ P,RETIF1
MOVEI A,"#
PUSHJ P,PITYO ; SAY "FUNNY TYPE"
MOVSI A,TATOM
MOVE B,MQUOTE HANDLER
PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT THE TYPE NAME
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVE B,-2(TP) ; GET CHANNEL
PUSHJ P,SPACEQ ; SPACE MAYBE
SKIPN B,(TP) ; GET ARG BACK
JRST PNEXT
MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW
MOVE B,INTFCN+1(B)
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT THE INT FUNCTION
SUB TP,[2,,2] ; POP CHANNEL OFF
JRST PNEXT
; PRINT INT HEADER
PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF1
MOVEI A,"#
PUSHJ P,PITYO
MOVSI A,TATOM ; AND NAME
MOVE B,MQUOTE IHEADER
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ ; MAYBE SPACE
SKIPN B,-2(TP) ; INT HEADER BACK
JRST PINTH1
MOVE A,INAME(B) ; GET NAME
MOVE B,INAME+1(B)
PUSHJ P,IPRINT
PINTH1: SUB TP,[2,,2] ; CLEAN OFF STACK
JRST PNEXT
; PRINT ASSOCIATION BLOCK
ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF ; MAKE ROOM AND PRINT
SKIPA C,[-3,,0] ; # OF FIELDS
ASSLP: PUSHJ P,SPACEQ
MOVE D,(TP) ; RESTORE GOODIE
ADD D,ASSOFF(C) ; POINT TO FIELD
MOVE A,(D) ; GET IT
MOVE B,1(D)
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; AND PRINT IT
SUB TP,[2,,2] ; POP OFF CHANNEL
MOVE B,-2(TP) ; GET CHANNEL
AOBJN C,ASSLP
MOVEI A,")
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF ; CLOSE IT
JRST PNEXT
ASSOFF: ITEM
INDIC
VAL
; PRINT TYPE-C AND TYPE-W
PTYPEW: HRRZ A,(TP) ; POSSIBLE RH
HLRZ B,(TP)
MOVE C,MQUOTE TYPE-W
JRST PTYPEX
PTYPEC: HRRZ B,(TP)
MOVEI A,0
MOVE C,MQUOTE TYPE-C
PTYPEX: PUSH P,B
PUSH P,A
PUSH TP,$TATOM
PUSH TP,C
MOVEI A,2
MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF ; ROOM TO START?
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
POP TP,B ; GET NAME
POP TP,A
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT
SUB TP,[2,,2] ; POP OFF CHANNEL
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ ; MAYBE SPACE
MOVE A,-1(P) ; TYPE CODE
ASH A,1
HRLI A,(A) ; MAKE SURE WINS
ADD A,TYPVEC+1
JUMPL A,PTYPX1 ; JUMP FOR A WINNER
ERRUUO EQUOTE BAD-TYPE-CODE
PTYPX1: MOVE B,1(A) ; GET TYPE NAME
HRRZ A,(A) ; AND SAT
ANDI A,SATMSK
MOVEM A,-1(P) ; AND SAVE IT
MOVSI A,TATOM
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; OUT IT GOES
SUB TP,[2,,2] ; POP OFF CHANNEL
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ ; MAYBE SPACE
MOVE A,-1(P) ; GET SAT BACK
MOVE B,IMQUOTE TEMPLATE
CAIGE A,NUMSAT
MOVE B,@STBL(A)
MOVSI A,TATOM ; AND PRINT IT
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP OFF STACK
SKIPN B,(P) ; ANY EXTRA CRAP?
JRST PTYPX2
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ
MOVE B,(P)
MOVSI A,TFIX
PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT EXTRA
SUB TP,[2,,2] ; POP OFF CHANNEL
PTYPX2: MOVEI A,">
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF
SUB P,[2,,2] ; FLUSH CRUFT
JRST PNEXT
; PRIMTYPE CODE
; PRINT PURE CODE POINTER
PSATC: MOVEI A,2
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM ; PRINT SUBR CALL
MOVE B,MQUOTE PRIMTYPE-C
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ ; MAYBE SPACE?
MOVE A,-2(TP)
CAILE A,NUMSAT
JRST TMPPTY
MOVE B,@STBL(A)
JRST PSATC1
TMPPTY: MOVE B,TYPVEC+1
PSATC3: HRRZ C,(B)
ANDI C,SATMSK
CAIN A,(C)
JRST PSATC2
ADD B,[2,,2]
JUMPL B,PSATC3
ERRUUO EQUOTE BAD-PRIMTYPEC
PSATC2: MOVE B,1(B)
PSATC1: MOVSI A,TATOM
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVEI A,">
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF ; CLOSE THE FORM
JRST PNEXT
PPCODE: MOVEI A,2
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM ; PRINT SUBR CALL
MOVE B,MQUOTE PCODE
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ ; MAYBE SPACE?
HLRZ A,-2(TP) ; OFFSET TO VECTOR
ADD A,PURVEC+1 ; SLOT TO A
MOVE A,(A) ; SIXBIT NAME
PUSH P,FLAGS
PUSHJ P,6TOCHS ; TO A STRING
POP P,FLAGS
PUSHJ P,IPRINT
MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ
HRRZ B,-2(TP) ; GET OFFSET
MOVSI A,TFIX
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVEI A,">
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF ; CLOSE THE FORM
JRST PNEXT
; PRINT SUB-ENTRY TO RSUBR
PENTRY: MOVE B,(TP) ; GET BLOCK
GETYP A,(B) ; TYPE OF 1ST ELEMENT
CAIE A,TRSUBR ; RSUBR, OK
JRST PENT1
PENT2: MOVEI A,2 ; CHECK ROOM
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF
MOVEI A,"% ; SETUP READ TIME MACRO
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM
MOVE B,IMQUOTE RSUBR-ENTRY
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
MOVE B,-4(TP)
PUSHJ P,SPACEQ ; MAYBE SPACE
MOVEI A,"' ; QUOTE TO AVOID EVALING IT
PUSHJ P,PRETIF
MOVEI A,"[ ; OPEN SQUARE BRAKET
PUSHJ P,PRETIF
MOVE B,-2(TP)
GETYP A,(B)
CAIN A,TRSUBR
JRST PENT3
MOVE A,(B)
MOVE B,1(B)
PUSHJ P,IPRINT
MOVE B,-4(TP) ; MOVE IN CHANNEL
JRST PENT4
PENT3: MOVE A,1(B)
MOVE B,3(A)
MOVSI A,TATOM ; FOOL EVERYBODY AND SEND OUT ATOM
PUSHJ P,IPRINT
MOVE B,-4(TP) ; PRINT SPACE
PENT4: PUSHJ P,SPACEQ
MOVE B,-2(TP) ; GET PTR BACK TO VECTOR
MOVE A,2(B) ; THE NAME OF THE ENTRY
MOVE B,3(B)
PUSHJ P,IPRINT ; OUT IT GOES
HLRZ B,-2(TP)
CAIL B,-4 ; SEE IF DONE
JRST EXPEN
MOVE B,-4(TP) ; PRINT SPACE
PUSHJ P,SPACEQ
MOVE B,-2(TP) ; GET POINTER
MOVE A,4(B) ; DECL
MOVE B,5(B)
PUSHJ P,IPRINT
EXPEN: MOVE B,-4(TP) ; GET CHANNEL INTO B
MOVEI A,"] ; CLOSE SQUARE BRAKET
PUSHJ P,PRETIF
MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ
MOVE B,-2(TP)
HRRZ B,2(B)
MOVSI A,TFIX
PUSHJ P,IPRINT
MOVEI A,">
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF
JRST PNEXT
PENT1: CAIN A,TATOM
JRST PENT2
ERRUUO EQUOTE BAD-ENTRY-BLOCK
; HERE TO PRINT TEMPLATED DATA STRUCTURE
TMPRNT: PUSH P,FLAGS ; SAVE FLAGS
MOVE A,(TP) ; GET POINTER
GETYP A,(A) ; GET SAT
PUSH P,A ; AND SAVE IT
MOVEI A,"{ ; OPEN SQUIGGLE
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PRETIF ; PRINT WITH CHECKING
HLRZ A,(TP) ; GET AMOUNT RESTED OFF
SUBI A,1
PUSH P,A ; AND SAVE IT
MOVE A,-1(P) ; GET SAT
SUBI A,NUMSAT+1 ; FIXIT UP
HRLI A,(A)
ADD A,TD.LNT+1 ; CHECK FOR WINNAGE
JUMPGE A,BADTPL ; COMPLAIN
HRRZS C,(TP) ; GET LENGTH
XCT (A) ; INTO B
SUB B,(P) ; FUDGE FOR RESTS
MOVEI B,-1(B) ; FUDGE IT
PUSH P,B ; AND SAVE IT
TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST
SOSGE (P) ; CHECK FOR ANY LEFT
JRST TMPRN2 ; ALL DONE
MOVE B,(TP) ; POINTER
HRRZ 0,-2(P) ; SAT
PUSHJ P,TMPLNT ; GET THE ITEM
MOVE FLAGS,-3(P) ; RESTORE FLAGS
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT THIS ELEMENT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVE B,-2(TP) ; GET CHANNEL INTO B
SKIPE (P) ; IF NOT LAST ONE THEN
PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE
JRST TMPRN1
TMPRN2: SUB P,[4,,4]
MOVE B,-2(TP)
MOVEI A,"} ; CLOSE THIS GUY
PUSHJ P,PRETIF
JRST PNEXT
; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT
; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII
PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION
GETYP A,(A) ; CHECK FOR PURE RSUBR
CAIN A,TPCODE
JRST PRSBRP ; PRINT IT SPECIAL WAY
TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT
JRST ARSUBR
PUSH P,FLAGS
MOVSI A,TRSUBR ; FIND FIXUPS
MOVE B,(TP)
HLRE D,1(B) ; -LENGTH OF CODE VEC
PUSH P,D ; SAVE SAME
MOVSI C,TATOM
MOVE D,IMQUOTE RSUBR
PUSHJ P,IGET ; GO GET THEM
JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES
PUSH TP,A ; SAVE FIXUP LIST
PUSH TP,B
MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR
MOVE FLAGS,-1(P) ; RESTORE FLAGS
MOVE B,-4(TP) ; GET CHANNEL FOR PITYO
PUSHJ P,PITYO ; OUT IT GOES
PRSBR1: MOVE B,-4(TP)
PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER
MOVE B,-4(TP) ; CHANNEL BACK
MOVN E,(P) ; LENGTH OF CODE
PUSH P,E
HRROI A,(P) ; POINT TO SAME
PUSHJ P,DOIOTO ; OUT GOES COUNT
MOVSI C,TCODE
MOVE PVP,PVSTOR+1
MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS
MOVE A,-2(TP) ; GET POINTER TO CODE
MOVE A,1(A)
PUSHJ P,DOIOTO ; IOT IT OUT
POP P,E
ADDI E,1 ; UPDATE ACCESS
ADDM E,ACCESS(B)
MOVE PVP,PVSTOR+1
SETZM ASTO(PVP) ; UNSCREW A
; NOW PRINT OUT NORMAL RSUBR VECTOR
MOVE FLAGS,-1(P) ; RESTORE FLAGS
SUB P,[1,,1]
MOVE B,-2(TP) ; GET RSUBR VECTOR
PUSHJ P,PRBODY ; PRINT ITS BODY
; HERE TO PRINT BINARY FIXUPS
MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS
SKIPN A,(TP) ; LIST TO A
JRST PRSBR5 ; EMPTY, DONE
JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM
ADDI E,1 ; FOR VERS
PRSBR6: HRRZ A,(A) ; NEXT?
JUMPE A,PRSBR5
GETYP B,(A)
CAIE B,TDEFER ; POSSIBLE STRING
JRST PRSBR7 ; COULD BE ATOM
MOVE B,1(A) ; POSSIBLE STRINGER
GETYP C,(B)
CAIE C,TCHSTR ; YES!!!
JRST BADFXU ; LOSING FIXUPS
HRRZ C,(B) ; # OF CHARS TO C
ADDI C,5+5 ; ROUND AND ADD FOR COUNT
IDIVI C,5 ; TO WORDS
ADDI E,(C)
JRST FIXLST ; COUNT FOR USE LIST ETC.
PRSBR7: GETYP B,(A) ; GET TYPE
CAIE B,TATOM
JRST BADFXU
ADDI E,1
FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL
JUMPE A,BADFXU
GETYP B,(A) ; FIX?
CAIE B,TFIX
JRST BADFXU
MOVEI D,1
HRRZ A,(A) ; TO USE LIST
JUMPE A,BADFXU
GETYP B,(A)
CAIE B,TLIST
JRST BADFXU ; LOSER
MOVE C,1(A) ; GET LIST
PRSBR8: JUMPE C,PRSBR9
GETYP B,(C) ; TYPE OK?
CAIE B,TFIX
JRST BADFXU
HRRZ C,(C)
AOJA D,PRSBR8 ; LOOP
PRSBR9: ADDI D,2 ; ROUND UP
ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD
ADDI E,(D)
JRST PRSBR6
PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS
PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER
PUSH TP,[0]
PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS
PUSHJ P,BFCLS1 ; FLUSH BUFFER
MOVE B,-6(TP) ; CHANNEL BACK
MOVEI C,BUFSTR-1(B) ; SETUP BUFFER
PUSHJ P,BYTDOP ; FIND D.W.
SUBI A,BUFLNT+1
HRLI A,-BUFLNT
MOVEM A,(TP)
MOVE E,(P) ; LENGTH OF FIXUPS
SETZB C,D ; FOR EOUT
PUSHJ P,EOUT
MOVE C,-2(TP) ; FIXUP LIST
MOVE E,1(C) ; HAVE VERS
PUSHJ P,EOUT ; OUT IT GOES
PFIXU2: HRRZ C,(C) ; FIRST THING
JUMPE C,PFIXU3 ; DONE?
GETYP A,(C) ; STRING OR ATOM
CAIN A,TATOM ; MUST BE STRING
JRST PFIXU4
MOVE A,1(C) ; POINT TO POINTER
HRRZ D,(A) ; LENGTH
IDIVI D,5
PUSH P,E ; SAVE REMAINDER
MOVEI E,1(D)
MOVNI D,(D)
MOVSI D,(D)
PUSH P,D
PUSHJ P,EOUT
MOVEI D,0
PFXU1A: MOVE A,1(C) ; RESTORE POINTER
HRRZ A,1(A) ; BYTE POINTER
ADD A,(P)
MOVE E,(A)
PUSHJ P,EOUT
MOVE A,[1,,1]
ADDB A,(P)
JUMPL A,PFXU1A
MOVE D,-1(P) ; LAST WORD
MOVE A,1(C)
HRRZ A,1(A)
ADD A,(P)
SKIPE E,D
MOVE E,(A) ; LAST WORD OF CHARS
IOR E,PADS(D)
PUSHJ P,EOUT ; OUT
SUB P,[1,,1]
JRST PFIXU5
PADS: ASCII /#####/
ASCII /####/
ASCII /###/
ASCII /##/
ASCII /#/
PFIXU4: HRRZ E,(C) ; GET CURRENT VAL
MOVE E,1(E)
MOVEM C,-2(TP)
PUSHJ P,ATOSQ ; GET SQUOZE
JRST BADFXU
TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING
PUSHJ P,EOUT
MOVE C,-2(TP)
; HERE TO WRITE OUT LISTS
PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE
HRLZ E,1(C)
HRRZ C,(C) ; POINT TO USES LIST
HRRZ D,1(C) ; GET IT
MOVEM C,-2(TP)
PFIXU6: TLCE D,400000 ; SKIP FOR RH
HRLZ E,1(D) ; SETUP LH
JUMPG D,.+3
HRR E,1(D)
PUSHJ P,EOUT ; WRITE IT OUT
HRR D,(D)
TRNE D,-1 ; SKIP IF DONE
JRST PFIXU6
TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS
MOVEI E,0
PUSHJ P,EOUT
MOVE C,-2(TP)
JRST PFIXU2 ; DO NEXT
PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER
MOVN D,C ; PLUS SAME
ADDI C,BUFLNT ; WORDS USED TO C
JUMPE C,PFIXU7 ; NONE USED, LEAVE
MOVSS C ; START SETTING UP BTB
MOVN A,C ; ALSO FINAL IOT POINTER
HRR C,(TP) ; PDL POINTER PART OF BTB
SUBI C,1
HRLI D,400000+C ; CONTINUE SETTING UP BTB (400000 IS FOR MULTI
; SEGS
POP C,@D ; MOVE 'EM DOWN
TLNE C,-1
JRST .-2
HRRI A,@D ; OUTPUT POINTER
ADDI A,1
MOVSI B,TUVEC
MOVE PVP,PVSTOR+1
MOVEM B,ASTO(PVP)
MOVE B,-6(TP)
PUSHJ P,DOIOTO ; WRITE IT OUT
MOVE PVP,PVSTOR+1
SETZM ASTO(PVP)
PFIXU7: SUB TP,[4,,4]
SUB P,[2,,2]
JRST PNEXT
; ROUTINE TO OUTPUT CONTENTS OF E
EOUT: MOVE B,-6(TP) ; CHANNEL
AOS ACCESS(B)
MOVE A,(TP) ; BUFFER POINTER
MOVEM E,(A)
AOBJP A,.+3 ; COUNT AND GO
MOVEM A,(TP)
POPJ P,
SUBI A,BUFLNT ; SET UP IOT POINTER
HRLI A,-BUFLNT
MOVEM A,(TP) ; RESET SAVED POINTER
MOVSI 0,TUVEC
MOVE PVP,PVSTOR+1
MOVEM 0,ASTO(PVP)
MOVSI 0,TLIST
MOVEM 0,DSTO(PVP)
MOVEM 0,CSTO(PVP)
PUSHJ P,DOIOTO ; OUT IT GOES
MOVE PVP,PVSTOR+1
SETZM ASTO(PVP)
SETZM CSTO(PVP)
SETZM DSTO(PVP)
POPJ P,
; HERE IF UVECOR FORM OF FIXUPS
UFIXES: PUSH TP,$TUVEC
PUSH TP,A ; SAVE IT
UFIX1: MOVE B,-6(TP) ; GET SAME
PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER
HLRE C,(TP) ; GET LENGTH
MOVMS C
PUSH P,C
HRROI A,(P) ; READY TO ZAP IT OUT
PUSHJ P,DOIOTO ; ZAP!
SUB P,[1,,1]
HLRE C,(TP) ; LENGTH BACK
MOVMS C
ADDI C,1
ADDM C,ACCESS(B) ; UPDATE ACCESS
MOVE A,(TP) ; NOW THE UVECTOR
MOVSI C,TUVEC
MOVE PVP,PVSTOR+1
MOVEM C,ASTO(PVP)
PUSHJ P,DOIOTO ; GO
MOVE PVP,PVSTOR+1
SETZM ASTO(PVP)
SUB P,[1,,1]
SUB TP,[4,,4]
JRST PNEXT
RCANT: ERRUUO EQUOTE RSUBR-LACKS-FIXUPS
BADFXU: ERRUUO EQUOTE BAD-FIXUPS
PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE
PRBOD1: MOVEI C,1 ; PRINT CODE ALSO
PUSH P,FLAGS
PUSH TP,$TRSUBR
PUSH TP,B
PUSH P,C
MOVEI A,"[ ; START VECTOR TEXT
MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
PUSHJ P,PITYO
POP P,C
MOVE B,(TP) ; RSUBR BACK
JUMPN C,PRSON ; GO START PRINTING
MOVEI A,"0 ; PLACE SAVER FOR CODE VEC
MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
PUSHJ P,PITYO
PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR
ADDB B,(TP)
JUMPGE B,PRSBR3 ; NO SPACE IF LAST
MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ
PUSHJ P,SPACEQ
SKIPA B,(TP) ; GET BACK POINTER
PRSON: JUMPGE B,PRSBR3
GETYP 0,(B) ; SEE IF RSUBR POINTED TO
CAIE 0,TQENT
CAIN 0,TENTER
JRST .+5 ; JUMP IF RSUBR ENTRY
CAIN 0,TQRSUB
JRST .+3
CAIE 0,TRSUBR ; YES!
JRST PRSB10 ; COULD BE SUBR/FSUBR
MOVE C,1(B) ; GET RSUBR
PUSH P,0 ; SAVE TYPE FOUND
GETYP 0,2(C) ; SEE IF ATOM
CAIE 0,TATOM
JRST PRSBR4
MOVE B,3(C) ; GET ATOM NAME
PUSHJ P,IGVAL ; GO LOOK
MOVE C,(TP) ; ORIG RSUBR BACK
GETYP A,A
POP P,0 ; DESIRED TYPE
CAIE 0,(A) ; SAME TYPE
JRST PRSBR4
MOVE D,1(C)
MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION
CAME 0,3(B) ; WIN?
JRST PRSBR4
HRRZ E,C
MOVSI A,TATOM
MOVE B,0 ; GET ATOM
MOVE FLAGS,(P)
JRST PRS101
PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS
MOVE B,(TP)
MOVE A,(B)
MOVE B,1(B) ; PRINT IT
PRS101: PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT
PUSH TP,-7(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP OFF CHANNEL
MOVE B,-2(TP) ; MOVE IN CHANNEL
JRST PRSBR2
PRSB10: CAIE 0,TSUBR ; SUBR?
CAIN 0,TFSUBR
JRST .+2
JRST PRSBR4
MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR
MOVE B,@-1(C) ; NAME OF IT
MOVSI A,TATOM ; AND TYPE
JRST PRS101
PRSBR3: MOVEI A,"]
MOVE B,-6(TP)
PUSHJ P,PRETIF ; CLOSE IT UP
SUB TP,[2,,2] ; FLUSH CRAP
POP P,FLAGS
POPJ P,
; HERE TO PRINT PURE RSUBRS
PRSBRP: MOVEI A,2 ; WILL "%<" FIT?
MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
PUSHJ P,RETIF
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM
MOVE B,IMQUOTE RSUBR
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT IT OUT
SUB TP,[2,,2] ; POP OFF CHANNEL
MOVE B,-2(TP)
PUSHJ P,SPACEQ ; MAYBE SPACE
MOVEI A,"' ; QUOTE THE VECCTOR
PUSHJ P,PRETIF
MOVE B,(TP) ; GET RSUBR BODY BACK
PUSH TP,$TFIX ; STUFF THE STACK
PUSH TP,[0]
PUSHJ P,PRBOD1 ; PRINT AND UNLINK
SUB TP,[2,,2] ; GET JUNK OFF STACK
MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
MOVEI A,">
PUSHJ P,PRETIF
JRST PNEXT
; HERE TO PRINT ASCII RSUBRS
ARSUBR: PUSH P,FLAGS ; SAVE FROM GET
MOVSI A,TRSUBR
MOVE B,(TP)
MOVSI C,TATOM
MOVE D,IMQUOTE RSUBR
PUSHJ P,IGET ; TRY TO GET FIXUPS
POP P,FLAGS
JUMPE B,PUNK ; NO FIXUPS LOSE
GETYP A,A
CAIE A,TLIST ; ARE FIXUPS A LIST?
JRST PUNK ; NO, AGAIN LOSE
PUSH TP,$TLIST
PUSH TP,B ; SAVE FIXUPS
MOVEI A,17.
MOVE B,-4(TP)
PUSHJ P,RETIF
PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]
AL1: ILDB A,(P) ; GET CHAR
JUMPE A,.+3
PUSHJ P,PITYO
JRST AL1
SUB P,[1,,1]
PUSHJ P,SPACEQ
MOVEI A,"'
PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL
MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE
PUSHJ P,PRBOD1
MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ
PUSHJ P,SPACEQ
MOVEI A,"' ; DONT EVAL FIXUPS EITHER
PUSHJ P,PRETIF
POP TP,B
POP TP,A
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVE B,-2(TP) ; GET CHANNEL INTO B
MOVEI A,">
PUSHJ P,PRETIF
JRST PNEXT
; HERE TO DO OFFSETS: %<OFFSET N '<VECTOR FIX FLOAT>>
POFFSE: MOVEI A,2
MOVE B,-2(TP)
PUSHJ P,RETIF
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM
MOVE B,MQUOTE OFFSET
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; RESTORE CHANNEL
PUSHJ P,SPACEQ
MOVSI A,TFIX
HRRE B,(TP) ; PICK UPTHE FIX
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; RESTORE CHANNEL
PUSHJ P,SPACEQ
HLRZ A,(TP)
JUMPE A,POFFS2
GETYP B,(A)
CAIE B,TFORM ; FORMS HAVE TO BE QUOTED
JRST POFFS1
MOVEI A,"'
MOVE B,-2(TP)
PUSHJ P,PRETIF
POFFS1: HLRZ B,(TP)
MOVE A,(B)
MOVE B,1(B)
POFFPT: PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; RESTORE CHANNEL
MOVEI A,">
PUSHJ P,PRETIF
JRST PNEXT
; PRINT 'ANY' IF 0
POFFS2: MOVSI A,TATOM
MOVE B,IMQUOTE ANY
JRST POFFPT
; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)
LOCP: PUSH TP,-1(TP)
PUSH TP,-1(TP)
PUSH P,0
MCALL 1,IN ; GET ITS CONTENTS FROM "IN"
POP P,0
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ; PRINT IT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
JRST PNEXT
;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
;B CONTAINS CHANNEL
;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
PITYO: TLNN FLAGS,FLTBIT
JRST ITYO
PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER
PUSH TP,B
TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
JRST ITYO+2
AOS FLTSIZ ;FLATSIZE DOESN'T PRINT
;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED
JRST .+4
POP TP,B ; GET CHANNEL BACK
SUB TP,[1,,1]
POPJ P,
MOVEI E,(B) ; GET POINTER FOR UNBINDING
PUSHJ P,SSPEC1
MOVE P,UPB+8 ; RESTORE P
POP TP,B ; GET BACK TP POINTER
PUSH P,0 ; SAVE FLAGS
MOVE TP,B ; RESTORE TP
MOVEI C,(TB) ; SEE IF TB IS CORRECT
CAIG C,1(TP) ; SKIP IF NEEDS UNWINDING
JRST PITYO4
PITYO3: MOVEI C,(TB)
CAILE C,1(TP)
JRST PITYO2
MOVEI A,PITYO4 ; SET UP PARAMETERS TO BE RESTORED BY FINIS
HRRM A,PCSAV(C)
MOVEM TP,TPSAV(C)
MOVE SP,SPSTOR+1
MOVEM SP,SPSAV(C)
MOVEM P,PSAV(C)
MOVE TB,D ; SET TB TO ONE FRAME AHEAD
JRST FINIS
PITYO4: POP P,0 ; RESTORE FLAGS
MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
MOVEI B,0
POPJ P,
PITYO2: MOVE D,TB ; SAVE ONE FRAME AHEAD
HRR TB,OTBSAV(TB) ; RESTORE TB
JRST PITYO3
;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 TP,$TCHAN
PUSH TP,B
PUSH P,FLAGS ;SAVE STUFF
PUSH P,C
PUSH P,A ;SAVE OUTPUT CHARACTER
TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING
CAIN A,^J
PUSHJ P,INTCHK
PUSH P,A
PUSHJ P,WXCT
POP P,A
CAIE A,^L ;SKIP IF THIS IS A FORM-FEED
JRST NOTFF
SETZM LINPOS(B) ;ZERO THE LINE NUMBER
JRST ITYXT
NOTFF: CAIE A,15 ;SKIP IF IT IS A CR
JRST NOTCR
SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION
PUSHJ P,AOSACC ; BUMP COUNT
JRST ITYXT1
NOTCR: CAIN A,^I ;SKIP IF NOT TAB
JRST TABCNT
CAIE A,10 ; BACK SPACE
JRST .+3
SOS CHRPOS(B) ; BACK UP ONE
JRST ITYXT
CAIE A,^J ;SKIP IF LINE FEED
JRST NOTLF
AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER
CAMLE C,PAGLN(B) ;SKIP IF THIS DOESN'T TAKES US PAST PAGE END
SETZM LINPOS(B)
MOVE FLAGS,-2(P)
JRST ITYXT
INTCHK: HRRZ 0,-2(B) ; GET CHANNELS FLAGS
TRNN 0,C.INTL ; LOSER INTERESTED IN LFS?
POPJ P, ; LEAVE IF NOTHING TO DO
PUSH TP,$TCHAN
PUSH TP,B ; SAVE CHANNEL
PUSH P,C
PUSH P,E
PUSHJ P,GTLPOS ; READ SYSTEMS VERSION OF LINE #
PUSH TP,$TATOM
PUSH TP,MQUOTE CHAR,CHAR,INTRUP
PUSH TP,$TFIX
PUSH TP,A
PUSH TP,$TCHAN
PUSH TP,B
MCALL 3,INTERRUPT
POP P,E ; RESTORE POSSIBLE COUNTS
POP P,C
POP TP,B ; RESTORE CHANNEL
SUB TP,[1,,1]
MOVEI A,^J
POPJ P,
NOTLF: CAIGE A,40
AOS CHRPOS(B) ; FOR CONTROL CHARS THAT NEED 2 SPACES
AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER
ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS
ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER
ITYRET: POP P,C ;RESTORE REGS & RETURN
POP P,FLAGS
POP TP,B ; GET CHANNEL BACK
SUB TP,[1,,1]
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
UNPROUT: POP P,A ;GET BACK THE ORIG CHAR
IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO
SOS UPB+1
JRST ITYRET ;RETURN
AOSACC: TLNN FLAGS,BINBIT
JRST NRMACC
AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD
CAMN C,[TFIX,,1]
AOS ACCESS(B)
CAMN C,[TFIX,,5]
HLLZS ACCESS-1(B)
POPJ P,
NRMACC: AOS ACCESS(B)
POPJ P,
SPACEQ: MOVEI A,40
TLNE FLAGS,FLTBIT+BINBIT
JRST PITYO ; JUST OUTPUT THE SPACE
PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE
MOVEI A,1
JRST RETIF2
RETIF1: MOVEI A,1
RETIF: PUSH P,[0]
TLNE FLAGS,FLTBIT+BINBIT
JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE
RETIF2: PUSH P,FLAGS
RETCH: PUSH P,A
RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION
SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN
JRST RETXT
CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH
JRST RETXT1
MOVEI A,^M ;FORCE A CARRIAGE RETURN
SETZM CHRPOS(B)
PUSHJ P,WXCT
PUSHJ P,AOSACC ; BUMP CHAR COUNT
MOVEI A,^J ;AND FORCE A LINE FEED
PUSHJ P,INTCHK ; CHECK FOR ^J INTERRUPTS
PUSHJ P,WXCT
PUSHJ P,AOSACC ; BUMP CHAR COUNT
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
; PUSHJ P,WXCT
; PUSHJ P,AOSACC ; BUMP CHAR COUNT
SETZM LINPOS(B)
RETXT: POP P,A
POP P,FLAGS
SPOPJ: SUB P,[1,,1]
POPJ P, ;RETURN
PRETIF: PUSH P,A ;SAVE CHAR
PUSHJ P,RETIF1
POP P,A
JRST PITYO
RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE
POPJ P,
PUSH P,[0]
PUSH P,FLAGS
HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL
PUSH P,A
JRST RETCH1
RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK
JRST RETXT
MOVEI A,40
PUSHJ P,WXCT
AOS CHRPOS(B)
PUSH P,C
PUSHJ P,AOSACC
POP P,C
JRST RETXT
;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
MOVE B,-2(TP) ; GET CHANNEL INTO B
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
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF
JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"
;PRINT BINARY INTEGERS IN DECIMAL.
;
PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)
JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ
PUSH P,FLAGS
PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B
PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX
TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE
JRST PFIXU
MOVE D,RADX(B) ; GET OUTPUT RADIX
PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX
MOVEI D,10. ; IF IN DOUBT USE 10.
PUSH P,D
MOVEI A,1 ; START A COUNTER
SKIPGE B,(TP) ; CHECK SIGN
MOVEI A,2 ; NEG, NEED CHAR FOR SIGN
IDIV B,D ; START COUNTING
JUMPE B,.+2
AOJA A,.-2
MOVE B,-2(TP) ; CHANNEL TO B
TLNN FLAGS,FLTBIT+BINBIT
PUSHJ P,RETIF3 ; CHECK FOR C.R.
MOVE B,-2(TP) ; RESTORE CHANNEL
MOVEI A,"- ; GET SIGN
SKIPGE (TP) ; SKIP IF NOT NEEDED
PUSHJ P,PITYO
MOVM C,(TP) ; GET MAGNITUDE OF #
MOVE B,-2(TP) ; RESTORE CHANNEL
POP P,E ; RESTORE RADIX
PUSHJ P,FIXTYO ; WRITE OUT THE #
MOVE FLAGS,-1(P)
SUB P,[1,,1] ; FLUSH P STUFF
JRST PNEXT
FIXTYO: IDIV C,E
PUSH P,D ; SAVE REMAINDER
SKIPE C
PUSHJ P,FIXTYO
POP P,A ; START GETTING #'S BACK
ADDI A,60
MOVE B,-2(TP) ; CHANNEL BACK
JRST PITYO
;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
;
PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO
; SPECIAL HACK FOR ZERO)
JRST PFLT0 ; HACK THAT ZERO
MOVM E,A ; CHECK FOR NORMALIZED
TLNN E,400 ; NORMALIZED
JRST PUNK
MOVE E,[SETZ 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
PDLWIN: PUSHJ P,(E) ; CALL ROUTINE WHOSE ADDRESS IS IN REG E
MOVE C,(B) ; GET COUNT 0F # CHARS RETURNED
PFLT1: MOVE A,B
HRR B,P ; GET PSTACK POINTER AND PRODUCE RELATAVIZED
SUB A,B
HRLS A ; ADD TO AOBJN
ADD A,P ; PRODUCE PDL POINTER
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSH TP,$TPDL ; PUSH PDL POINTER
PUSH TP,A
MOVE A,C ; MAKE SURE THAT # WILL FIT ON PRINT LINE
PUSH P,D ; WATCH THAT MCALL
PUSHJ P,RETIF ; START NEW LINE IF IT WON'T
POP P,D
POP TP,B ; RESTORE B
SUB TP,[1,,1] ; CLEAN OFF STACK
HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR
; LESS ONE
PNUM01: ILDB A,B ; GET NEXT BYTE
PUSH P,B ; SAVE B
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PITYO ; PRINT IT
POP P,B ; RESTORE B
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
PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000
MOVEI C,9. ; SEE ABOVE
MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING
MOVEI B,[ASCII /0.0000000/]
SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE
PDLERR: SUB P,D ;REST STACK POINTER
REPEAT 6,PUSH P,[0]
JRST PDLWIN
; FLOATING POINT PRINTER STOLEN FROM DDT
F==E+1
G==F+1
H==G+1
I==H+1
J==I+1
TEM1==I
FLOATB: PUSH P,B
PUSH P,C
PUSH P,D
PUSH P,F
PUSH P,G
PUSH P,H
PUSH P,I
PUSH P,0
PUSH P,J
MOVSI 0,440700 ; BUILD BYTEPNTR
HLRZ J,A ; POINT TO BUFFER
HRRI 0,1(J)
ANDI A,-1
MOVE A,(A) ; GET NUMBER
MOVE D,A
SETZM (J) ; Clear counter
PUSHJ P,NFLOT
POP P,J
POP P,0
POP P,I
POP P,H
POP P,G
POP P,F
POP P,D
POP P,C
POP P,B
POPJ P,
; at this point we enter code abstracted from DDT.
NFLOT: JUMPG A,TFL1
JUMPE A,FP1A
MOVNS A
PUSH P,A
MOVEI A,"-
PUSHJ P,CHRO
POP P,A
TLZE A,400000
JRST FP1A
TFL1: MOVEI B,0
TFLX: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP1A:
FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION
MULI A,400
ASHC B,-243(A)
MOVE A,B
PUSHJ P,FP7
PUSH P,A
MOVEI A,".
PUSHJ P,CHRO
POP P,A
MOVNI A,10
ADD A,TEM1
MOVE E,C
FP3A: MOVE D,E
MULI D,12
PUSHJ P,FP7B
SKIPE E
AOJL A,FP3A
POPJ P, ; ONE return from OFLT here
FP4: MOVNI C,6
MOVEI F,0
FP4A: ADDI F,1(F)
XCT FCP(B)
SOSA F
FMPR A,@FXP+1(B)
AOJN C,FP4A
PUSH P,EXPSGN(B)
PUSHJ P,FP3
PUSH P,A
MOVEI A,"E
PUSHJ P,CHRO
POP P,A
POP P,D
PUSHJ P,FDIGIT
MOVE A,F
FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT
AOS TEM1
IDIVI A,12
PUSH P,B
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: POP P,D
FP7B: ADDI D,"0
; type digit
FDIGIT: PUSH P,A
MOVE A,D
PUSHJ P,CHRO
POP P,A
POPJ P,
CHRO: AOS (J) ; COUNT CHAR
IDPB A,0 ; STUFF CHAR
POPJ P,
; constants
1.0^32.
1.0^16.
FT8: 1.0^8
1.0^4
1.0^2
1.0^1
FT: 1.0^0
1.0^-32.
1.0^-16.
1.0^-8
1.0^-4
1.0^-2
FT01: 1.0^-1
FT0=FT01+1
; instructions
FCP: CAMLE A, FT0(C)
CAMGE A, FT(C)
0, FT0(C)
FXP: SETZ FT0(C)
SETZ FT(C)
SETZ FT0(C)
EXPSGN: "-
"+
;PRINT SHORT (ONE WORD) CHARACTER STRINGS
PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)
MOVE B,-2(TP) ; GET CHANNEL INTO B
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 BACK SLASH
PUSHJ P,PITYO
PCASIS: MOVE A,(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: MOVE A,(TP) ;GET THE CHARACTER AGAIN
TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
TLO FLAGS,CNTLPC ;SWITCH ON ^P MODE TEMPORARY
PUSHJ P,PITYO ;PRINT IT
TLZ FLAGS,CNTLPC ;SWITCH OFF ^P MODE
JRST PNEXT
;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
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ;PRINT IT
SUB TP,[2,,2] ; POP OFF CHANNEL
JRST PNEXT ;GO EXIT
; Print an ATOM. TRAILERS are added if the atom is not in the current
; lexical path. Also escaping of charactets is performed to allow READ
; to win.
PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING
SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0
HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH
PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC
PUSH TP,P
LDB A,[301400,,(P)] ; GET BYTE PTR POSITION
DPB A,[301400,,E] ; SAVE IN E
MOVE C,-2(TP) ; GET ATOM POINTER
ADD C,[3,,3] ; POINT TO PNAME
JUMPGE C,BADPNM ; NO PNAME, ERROR
HLRE A,C ; -# WORDS TO A
PUSH P,A ; PUSH THAT FOR "AOSE"
MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO
JSP B,DOIDPB
HRLI C,440700 ; BUILD BYTE POINTER
ILDB A,C ; GET FIRST BYTE
JUMPE A,BADPNM ; NULL PNAME, ERROR
SKIPA
PATOM1: ILDB A,C ; GET A CHAR
JUMPE A,PATDON ; END OF PNAME?
TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY
AOS (P) ; COUNT WORD
JRST PENTCH ; ENTER THE CHAR INTO OUTPUT
PATDON: LDB A,[220600,,E] ; GET "STATE"
LDB A,STABYT+NONSPC+1 ; SIMULATE "END" CHARACTER
DPB A,[220600,,E] ; AND STORE
MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR
TLZ B,77
HRR B,(TP) ; POINT
SUB TP,[2,,2] ; FLUSH SAVED PDL
MOVE C,-1(P) ; GET BYE POINTER
SUB P,[2,,2] ; FLUSH
PUSH P,D
MOVEI A,0
IDPB A,B
AOS -1(TP) ; COUNT ATOMS
TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"
JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS
MOVEI A,"\ ; GET QUOTER
TLNN E,2 ; SKIP IF NEEDED
JRST PATDO1
SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH
DPB A,B ; CLOBBER
PATDO1: MOVEI E,(E) ; CLEAR LH(E)
PUSH P,C ; SAVE BYTER
PUSH P,E ; ALSO CHAR COUNT
MOVE B,IMQUOTE OBLIST
PUSH P,FLAGS
PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE
POP P,FLAGS ; AND RESTORES FLAGS
MOVE C,(TP) ; GET ATOM BACK
HRRZ C,2(C) ; GET ITS OBLIST
SKIPN C
AOJA A,NOOBL1 ; NONE, USE FALSE
CAMG C,VECBOT ; JUMP IF REAL OBLIST
MOVE C,(C)
HRROS C
CAME A,$TLIST ; SKIP IF A LIST
CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE
JRST CHOBL ; WINS, NOW LOCATE IT
CHROOT: CAME C,ROOT+1 ; IS THIS ROOT?
JRST FNDOBL ; MUST FIND THE PATH NAME
POP P,E ; RESTORE CHAR COUNT
MOVE D,(P) ; AND PARTIAL WORD
EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD
MOVEI A,"! ; PUT OUT MAGIC
JSP B,DOIDPB ; INTO BUFFER
MOVEI A,"-
JSP B,DOIDPB
MOVEI A,40
JSP B,DOIDPB
NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER
PUSH P,D ; PUSH NEXT WORD IF ANY
JRST NOLEX4
NOLEX: MOVE E,(P) ; GET COUNT
SUB P,[2,,2]
NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)
MOVE A,E ; COUNT TO A
SKIPN (P) ; FLUSH 0 WORD
SUB P,[1,,1]
HRRZ C,-1(TP) ; GET # OF ATOMS
SUBI A,(C) ; FIX COUNT
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF ; MAY NEED C.R.
MOVEI C,-1(E) ; COMPUTE WORDS-1
IDIVI C,5 ; WORDS-1 TO C
HRLI C,(C)
MOVE D,P
SUB D,C ; POINTS TO 1ST WORD OF CHARS
MOVSI C,440700+D ; BYTEPOINTER TO STRING
PUSH TP,$TPDL ; SAVE FROM GC
PUSH TP,D
PATOUT: ILDB A,C ; READ A CHAR
SKIPE A ; IGNORE NULS
PUSHJ P,PITYO ; PRINT IT
MOVE D,(TP) ; RESTORE POINTER
SOJG E,PATOUT
NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK
MOVE P,D ; RESTORE P
SUB P,[1,,1]
JRST PNEXT
PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?
JRST PENTC1 ; YES, AVOID SLASHING
IDIVI A,CHRWD ; GET CHARS TYPE
LDB B,BYTPNT(B)
CAILE B,NONSPC ; SKIP IF NOT SPECIAL
JRST PENTC2 ; SLASH IMMEDIATE
LDB A,[220600,,E] ; GET "STATE"
LDB A,STABYT-1(B) ; GET NEW STATE
DPB A,[220600,,E] ; AND SAVE IT
PENTC3: LDB A,C ; RESTORE CHARACTER
PENTC1: JSP B,DOIDPB
SKIPGE (P) ; SKIP IF DONE
JRST PATOM1 ; CONTINUE
JRST PATDON
PENTC2: MOVEI A,"\ ; GET CHAR QUOTER
JSP B,DOIDPB ; NEEDED, DO IT
MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED
JRST PENTC3-1
; ROUTINE TO PUT ONE CHAR ON STACK BUFFER
DOIDPB: IDPB A,-1(P) ; DEPOSIT
TRNN D,377 ; SKIP IF D FULL
AOJA E,(B)
PUSH P,(P) ; MOVE TOP OF STACK UP
MOVEM D,-2(P) ; SAVE WORDS
MOVE D,[440700,,D]
MOVEM D,-1(P)
MOVEI D,0
AOJA E,(B)
; CHECK FOR UNIQUENESS LOOKING INTO PATH
CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?
JRST LSTOBL ; NO, AL LIST THEREOF
CAME B,C ; THE RIGTH ONE?
JRST CHROOT ; NO, CHECK ROOT
JRST NOLEX ; WINNER, NO TRAILERS!
LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS
PUSH TP,B
PUSH TP,A
PUSH TP,B
PUSH TP,$TOBLS
PUSH TP,C
NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE
SKIPN C,-2(TP) ; SKIP IF NOT DONE
JRST CHROO1 ; EMPTY, CHECK ROOT
MOVE B,1(C) ; GET ONE
CAME B,(TP) ; WINNER?
JRST NXTOBL ; NO KEEP LOOKING
CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST
JRST NOLEX1
MOVE A,-6(TP) ; GET ATOM BACK
MOVEI D,0
ADD A,[3,,3] ; POINT TO PNAME
PUSH P,0 ; SAVE FROM RLOOKU
PUSH P,(A)
ADDI D,5
AOBJN A,.-2 ; PUSH THE PNAME
PUSH P,D ; AND CHAR COUNT
MOVSI A,TLIST ; TELL RLOOKU WE WIN
MOVE B,-4(TP) ; GET BACK OBLIST LIST
SUB TP,[6,,6] ; FLUSH CRAP
PUSHJ P,RLOOKU ; FIND IT
POP P,0
CAMN B,(TP) ; SKIP IF NON UNIQUE
JRST NOLEX ; UNIQUE , NO TRAILER!!
JRST CHROO2 ; CHECK ROOT
NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST
MOVEM B,-2(TP)
JRST NXTOB2
FNDOBL: MOVE C,(TP) ; GET ATOM
MOVSI A,TOBLS
HRRZ B,2(C)
CAMG B,VECBOT
MOVE B,(B)
HRLI B,-1
MOVSI C,TATOM
MOVE D,IMQUOTE OBLIST
PUSH P,0
PUSHJ P,IGET
POP P,0
NOOBL1: POP P,E ; RESTORE CHAR COUNT
MOVE D,(P) ; GET PARTIAL WORD
EXCH D,-1(P) ; AND BYTE POINTER
CAME A,$TATOM ; IF NOT ATOM, USE FALSE
JRST NOOBL
MOVEM B,(TP) ; STORE IN ATOM SLOT
MOVEI A,"!
JSP B,DOIDPB ; WRITE IT OUT
MOVEI A,"-
JSP B,DOIDPB
SUB P,[1,,1]
JRST PATOM0 ; AND LOOP
NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]
ILDB A,C
JUMPE A,NOLEX0
JSP B,DOIDPB
JRST .-3
NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF
JRST NOLEX
CHROO1: SUB TP,[6,,6]
CHROO2: MOVE C,(TP) ; GET ATOM
HRRZ C,2(C) ; AND ITS OBLIST
CAMG C,VECBOT
MOVE C,(C)
HRROS C
JRST CHROOT
BADPNM: ERRUUO EQUOTE BAD-PNAME
; STATE TABLES FOR \ OF FIRST CHAR
; Each word is a state and each 4 bit byte tells where to go based on the input
; type. The types are defined in READER >. The input type selects a byte pointer
; into the table which is indexed by the current state.
RADIX 16.
STATS: 431192440 ; INITIAL STATE (0)
434444444 ; HERE ON INIT +- (1)
222222242 ; HERE ON INIT . (2)
434445642 ; HERE ON INIT DIGIT (3)
444444444 ; HERE IF NO \ NEEDE (4)
454444642 ; HERE ON DDDD. (5)
487744444 ; HERE ON E (6)
484444444 ; HERE ON E+- (7)
484444442 ; HERE ON E+-DDD (8)
494444444+<1_28.> ; HERE ON * (HACK IS TO GET A 10 IN THERE) (9)
494494444+<1_28.>+<2_16.> ; HERE ON *DDDDD (10)
444444442
RADIX 8.
STABYT: 400400,,STATS(A) ; LETTERS
340400,,STATS(A) ; NUMBERS
300400,,STATS(A) ; PLUS SIGN +
240400,,STATS(A) ; MINUS SIGN -
200400,,STATS(A) ; asterick *
140400,,STATS(A) ; PERIOD .
100400,,STATS(A) ; LETTER E
040400,,STATS(A) ; extra
000400,,STATS(A) ; HERE ON RAP UP
;PRINT LONG CHARACTER STRINGS.
;
PCHSTR: MOVE B,(TP)
TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS
SETZM E ;ZERO COUNT
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSH TP,-3(TP) ;GIVE PCHRST SOME GOODIES TO PLAY WITH
PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
SUB TP,[4,,4] ;FLUSH MUNGED GOODIES
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
MOVE B,-2(TP) ; GET CHANNEL INTO B
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
MOVE B,-2(TP)
PUSHJ P,PITYO
PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
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
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,PITYO
JRST PNEXT
;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
PUSH P,D
PCHR02: INTGO ; IN CASE VERY LONG STRING
HRRZ C,-1(TP) ;GET COUNT
SOJL C,PCSOUT ; DONE?
HRRM C,-1(TP)
ILDB A,(TP) ; GET CHAR
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 NOT A NUMBER/LETTER
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
PUSH P,B ; SAVE B
MOVE B,-2(TP) ; GET CHANNEL INTO B
XCT (P)-1
POP P,B ; RESTORE B
PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN
PUSH P,B ; SAVE B
MOVE B,-2(TP) ; GET CHANNEL INTO B
TLNE FLAGS,NOQBIT ; SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
TLO FLAGS,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
XCT (P)-1 ;PRINT IT
TLZ FLAGS,CNTLPC ; SWITCH OFF ^P MODE
POP P,B ; RESTORE B
JRST PCHR02 ;LOOP THROUGH STRING
PCSOUT: POP P,D
POP P,C ;RESTORE REGS & RETURN
POP P,B
POP P,A
POPJ P,
; PRINT AN ARBITRARY BYTE STRING
PBYTE: PUSH TP,-3(TP)
PUSH TP,-3(TP)
MOVEI A,"#
MOVE B,(TP)
PUSHJ P,PRETIF
LDB B,[300600,,-2(TP)]
MOVSI A,TFIX
PUSHJ P,IPRINT
MOVE B,(TP)
PUSHJ P,SPACEQ
MOVEI A,"{
MOVE B,(TP)
PUSHJ P,PRETIF
HRRZ A,-3(TP) ; CHAR COUNT
JUMPE A,CLSBYT
BYTLP: SOS -3(TP)
ILDB B,-2(TP) ; GET A BYTE
MOVSI A,TFIX
PUSHJ P,IPRINT
HRRZ A,-3(TP)
JUMPE A,CLSBYT
MOVE B,(TP)
PUSHJ P,SPACEQ
JRST BYTLP
CLSBYT: MOVEI A,"}
MOVE B,(TP)
PUSHJ P,PRETIF
SUB TP,[2,,2]
JRST PNEXT
;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
CAIL B,HIBOT
SKIPA B,@-1(B) ; SUBRS AND FSUBRS
MOVE B,3(B) ; FOR RSUBRS
MOVSI A,TATOM
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ;PRINT FUNCTION NAME
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
JRST PNEXT
PPVP: MOVE B,(TP) ; PROCESS TO B
MOVSI A,TFIX
JUMPE B,.+3
MOVE A,PROCID(B)
MOVE B,PROCID+1(B) ;GET ID
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
JRST PNEXT
; HERE TO PRINT LOCATIVES
LOCPT1: HRRZ A,-1(TP)
JUMPN A,PUNK
LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK
PUSHJ P,CHLOCI
HRRZ A,-1(TP)
JUMPE A,GLOCPT
MOVE B,(TP)
MOVE A,(B)
MOVE B,1(B)
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
JRST PNEXT
GLOCPT: MOVEI A,2
MOVE B,-2(TP) ; GET CHANNEL
PUSHJ P,RETIF
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM
MOVE B,MQUOTE GLOC
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; MOVE IN CHANNEL
PUSHJ P,SPACEQ
MOVE B,(TP)
MOVSI A,TATOM
MOVE B,-1(B)
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; MOVE IN CHANNEL
PUSHJ P,SPACEQ
MOVSI A,TATOM
MOVE B,IMQUOTE T
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; MOVE IN CHANNEL
MOVEI A,">
PUSHJ P,PRETIF
JRST PNEXT
LOCRPT: MOVEI A,2
MOVE B,-2(TP) ; GET CHANNEL
PUSHJ P,RETIF
MOVEI A,"%
PUSHJ P,PITYO
MOVEI A,"<
PUSHJ P,PITYO
MOVSI A,TATOM
MOVE B,MQUOTE RGLOC
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; MOVE IN CHANNEL
PUSHJ P,SPACEQ
MOVE B,(TP)
MOVSI A,TATOM
ADD B,GLOTOP+1 ; GET TO REAL ATOM
MOVE B,-1(B)
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; MOVE IN CHANNEL
PUSHJ P,SPACEQ
MOVSI A,TATOM
MOVE B,IMQUOTE T
PUSH TP,-3(TP)
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2]
MOVE B,-2(TP) ; MOVE IN CHANNEL
MOVEI A,">
PUSHJ P,PRETIF
JRST PNEXT
;PRINT UNIFORM VECTORS.
;
PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?
PUSHJ P,RETIF
MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET
PUSHJ P,PITYO
MOVEI A,"[
PUSHJ P,PITYO
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
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ;TYPE IT
SUB TP,[2,,2] ; POP CHANNEL OF STACK
MOVE C,(TP) ;GET AOBJN POINTER
AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO
MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ
MOVE C,(TP)
JRST PUVE02 ;LOOP THROUGH VECTOR
NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP
NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
MOVEI A,"! ;TYPE CLOSE BRACKET
PUSHJ P,PRETIF
MOVEI A,"]
PUSHJ P,PRETIF
JRST PNEXT
;PRINT A GENERALIZED VECTOR
;
PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
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
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ;PRINT THAT ELEMENT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK
AOBJP C,PVCEND ;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
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ
MOVE C,(TP) ; RESTORE REGISTER C
JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]
MOVEI A,"] ; PRINT A RIGHT-BRACKET
PUSHJ P,PITYO
JRST PNEXT
;PRINT A LIST.
;
PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B
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
MOVE B,-2(TP) ; RESTORE CHANNEL TO B
PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
MOVEI A,") ;TYPE A CLOSE PAREN
PUSHJ P,PITYO
JRST PNEXT
PSEG: 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,IMQUOTE LVAL
MOVEI D,".
CAMN B,IMQUOTE GVAL
MOVEI D,",
CAMN B,IMQUOTE QUOTE
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
MOVE B,-4(TP) ; GET CHANNEL INTO B
MOVEI A,2 ; ROOM FOR ! AND . OR ,
PUSHJ P,RETIF
MOVEI A,"!
PUSHJ P,PITYO
PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B
PUSHJ P,RETIF1
POP P,A ;RESTORE CHAR
PUSHJ P,PITYO
POP TP,B
POP TP,A
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
JRST PNEXT
PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT
JRST PLMNT5 ;ELSE DON'T TYPE THE "!"
;ITS A SEGMENT CALL
MOVE B,-2(TP) ; GET CHANNEL INTO B
MOVEI A,2 ; ROOM FOR ! AND <
PUSHJ P,RETIF
MOVEI A,"!
PUSHJ P,PITYO
PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B
PUSHJ P,RETIF1
MOVEI A,"<
PUSHJ P,PITYO
PUSHJ P,LSTPRT
MOVEI A,"!
MOVE B,-2(TP) ; GET CHANNEL INTO B
TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT
PUSHJ P,PRETIF
MOVEI A,">
PUSHJ P,PRETIF
JRST PNEXT
LSTPRT: SKIPN C,(TP)
POPJ P,
HLLZ A,(C) ;GET NEXT ELEMENT
MOVE B,1(C)
HRRZ C,(C) ;CHOP THE LIST
JUMPN C,PLIST1
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
POPJ P,
PLIST1: MOVEM C,(TP)
PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
PUSH TP,-3(TP)
PUSHJ P,IPRINT ;PRINT THE NEXT ELEMENT
SUB TP,[2,,2] ; POP CHANNEL OFF STACK
MOVE B,-2(TP) ; GET CHANNEL INTO B
PUSHJ P,SPACEQ
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,
OPENIT: PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,D
PUSH P,FLAGS
PUSHJ P,OPNCHN
POP P,FLAGS
POP P,D
POP P,C
POP P,B
POP P,A
JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED
HRRZ E,-2(B)
POPJ P,
END
Reference in New Issue View Git Blame Copy Permalink