1
0
mirror of https://github.com/PDP-10/its.git synced 2026-01-17 08:43:21 +00:00
PDP-10.its/src/l/reader.282

2884 lines
64 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.

;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** READ AND RELATED FUNCTIONS **************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT [RDR]
SUBTTL HIRSUTE READER AND INPUT PACKAGE
SUBTTL HAIRY READER BIT DESCRIPTIONS
;OBJECT FLAGS - AS AN OBJECT ACCUMULATES, THE LH OF ACC T
; HAS BITS SET TO DESCRIBE THE STATE OF THE OBJECT
;BIT VALUE MEANING
;3.1 1 TOP LEVEL OBJECT
;3.2 2 FIRST OBJECT OF A LIST
;3.3 4 DOTTED PAIR OBJECT - SECOND HALF
;3.4 10 DELAYED DOT READ
;3.5 20 ALPHA ATOM (I.E., NON-NUMBER ATOM)
;3.6 40 NUMBER ATOM
;3.7 100 DECIMAL NUMBER
;3.8 200 FLOATING NUMBER
;3.9 400 NEGATIVE NUMBER
;4.1 1000 EXPONENT-MODIFIED NUMBER, E.G. ^ OR E (OR SPLICING, IF MACRO)
;4.2 2000 LSH-ED NUMBER, I.E. _
;4.3 4000 LIST-TYPE OBJECT
;4.4 10000 SIGNED NUMBER ATOM, E.G. +A
;4.5 20000 MACRO-PRODUCED OBJECT
;4.6 40000 BIGNUM BASE 10.
;4.7 100000 BIGNUM BASE IBASE
;4.8 200000 HUNK
;4.9 400000 A form has been seen after a dot. For error checking
; splicing macros.
;CHARACTER FLAGS - THE RH OF AN ENTRY IN THE RCT TABLE
; GENERALLY HAS THE ASCII TRANSLATION FOR THE CHARACTER,
; EXCEPT MACRO-CHARACTERS, WHICH HOLD A FUNCTION TO EXECUTE
; THE LH HAS DESCRIPTOR BITS AS FOLLOWS:
;BIT VALUE MEANING
;3.1 1 ALPHABETIC, I.E. A,B,C,...,Z
;3.2 2 EXTENDED ALPHABETIC, E.G., !,",#,$, ETC. AND LOWERCASE
;3.3 4 DECIMAL DIGIT, I.E. 0,1,2,...,9
;3.4 10 + OR -
;3.5 20 ^ OR _
;3.6 40 SECOND CHOICE DENOTER FOR 3.4, 3.5, 4.1, AND 4.3
;3.7 100 PRINT SHOULD SLASHIFY IF NOT FIRST CHAR
;3.8 200 . <DECIMAL POINT> KIND OF DOT
;3.9 400 PRINT SHOULD SLASHIFY WHEN IN FIRST POSITION
;4.1 1000 THE RUBOUT CHARACTER, OR THE TTY FORCE FEED CHAR
;4.2 2000 THE READ "QUOTE" CHARACTER, I.E. /
;4.3 4000 MACRO CHARACTER, E.G. ', OR SPLICING MACRO
;4.4 10000 )
;4.5 20000 . <DOTTED-PAIR> KIND OF DOT
;4.6 40000 (
;4.7 100000 <SPACE> OR <TAB>
;4.8 200000 CHARACTER OBJECT
;4.9 400000 WORTHLESS CHARACTERS, AND ANY WITH BIT 3.8
; OR BITS 4.1-4.8 ON.
IFN NEWRD,[
;;;DEFINE READER-SYNTAX BITS
;;;THESE BITS OCCUPY 2.1-3.8. DO NOT USE 3.9 (SEE TYIPEEK)
RS.FF==004000,, ;FORCE-FEED CHARACTER
RS.VMO==002000,, ;VERTICAL MOTION (LF, FF)
RS.SQX==001000,, ;EXPONENT MARKER, STRING QUOTE
RS.BRK==000400,, ;SPECIAL ACTION NEEDED ON INPUT
RS.SCO==000200,, ;SINGLE-CHARACTER OBJECT
RS.WSP==000100,, ;WHITE SPACE - SPACE, TAB, COMMA, CR
RS.LP ==000040,, ;LEFT PARENTHESIS
RS.DOT==000020,, ;DOTTED-PAIR DOT
RS.RP ==000010,, ;RIGHT PARENTHESIS
RS.MAC==000004,, ;MACRO-CHARACTER (RS.ALT = SPLICING)
RS.SLS==000002,, ;SLASHIFIER
RS.RBO==000001,, ;RUBOUT, FORCEFEED
RS.SL1==400000 ;SLASH IF FIRST IN PNAME
RS.PNT==200000 ;DECIMAL POINT (FOR NUMBERS)
RS.SL9==100000 ;SLASH IF NOT FIRST IN PNAME
RS.ALT==040000 ;CHANGE MEANING OF OTHER BITS
RS.ARR==020000 ;NUMBER MODIFIERS _ AND ^
RS.SGN==010000 ;NUMBERS SIGNS + AND -
RS.DIG==004000 ;DIGITS 0 THROUGH 9
RS.XLT==002000 ;EXTENDED LETTERS (LIKE :)
RS.LTR==001000 ;REGULAR LETTERS (LIKE X)
IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO]
RS%!A==<RS.!A>_22
TERMIN
NWTNE==:TRNE
NWTNN==:TRNN
DEFINE NWTN ZP,AC,SX
TDN!ZP AC,[RS.!SX]
TERMIN
] ;END IFN NEWRD
IFE NEWRD,[
;;;DEFINE READER-STYNTAX BITS
RS.FF==0
RS.VMO==0
RS.SQX==0
RS.BRK==400000
RS.SCO==200000
RS.WSP==100000
RS.LP==40000
RS.DOT==20000
RS.RP==10000
RS.MAC==4000
RS.SLS==2000
RS.RBO==1000
RS.SL1==400
RS.PNT==200
RS.SL9==100
RS.ALT==40
RS.ARR==20
RS.SGN==10
RS.DIG==4
RS.XLT==2
RS.LTR==1
IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO]
RS%!A==RS.!A
TERMIN
NWTNE==:TLNE
NWTNN==:TLNN
DEFINE NWTN ZP,AC,SX
TLN!ZP AC,RS.!SX
TERMIN
] ;END OF IFE NEWRD
RS.CMS==RS.<BRK+SL1+SL9+MAC> ;CHARACTER-MACRO SYNTAX
RS.SCS==RS.<BRK+SL1+SL9+SCO> ;SINGLE-CHAR-OBJ SYNTAX
;SYNTAX FOR CHARS THAT BEGIN OBJECTS
RS.OBB==RS.<SQX+SCO+LP+MAC+SLS+PNT+SGN+DIG+XLT+LTR>
RS.WTH==RS.<OBB+DOT+RP+ARR> ;PRETTY MUCH, ANY WORTHY CHAR
RS.SEE==RS.<WTH+WSP+RBO+FF> ;ALMOST ANY CHAR THAT YOU REALLY SEE
SUBTTL READCH AND ASCII FUNCTIONS,
$READCH: JSP D,INCALL
Q$READCH
RDCH$:
READCH: PUSHJ P,TYI
RDCH3: MOVE TT,A
JRST RDCH2
$ASCII: JSP T,FXNV1
RDCH2:
CAIN TT,203 ;RARE CASE WHEN READCH IS CALLED FROM WITHIN
JRST READCH ; A READLIST - MAY SEE A PSEUDO-SPACE.
SA$ CAIN TT,315 ;NORMALIZE CR FOR SAIL
SA$ MOVEI TT,15
ANDI TT,177
MOVE B,TT
MOVE D,VOBARRAY
ADDI TT,OBTSIZ+1
ROT TT,-1
JUMPL TT,.+3
HLRZ A,@1(D)
JRST .+2
HRRZ A,@1(D)
JUMPN A,CPOPJ
MOVEI T,1
MOVEI TT,RDCHO
RDCH4: PUSH P,T
PUSH FXP,PNBUF-1(T)
SOJG T,.-1
PUSH FXP,LPNF
PUSHJ P,(TT)
POP FXP,LPNF
POP P,T
MOVNS T
HRLZS T
POP FXP,PNBUF(T)
AOBJN T,.-1
POPJ P,
SUBTTL NEWIO INPUT FUNCTION ARGS PROCESSOR
;;; JSP D,INCALL
;;; Q<FNNAME>
;;; PROCESSES ARGUMENTS FOR AN INPUT FUNCTION TAKING STANDARD
;;; ARGUMENTS (EOF VALUE AND/OR FILE ARRAY). SAVES F.
;;; JSP D,XINCALL
;;; Q<FNNAME>
;;; IS SIMILAR, BUT INSISTS ON A FIXNUM RESULT (FOR TYI, TYIPEEK),
;;; AND EXPECTS F TO CONTAIN EITHER "FIX1" OR "CPOPJ".
;;; SAVES AR2A (SEE TYIPEEK).
XINCALL:
JUMPN T,XINCA1
PUSH P,F
SFA% JRST 1(D)
IFN SFA,[
INCAST: PUSHJ P,SINFGET ;GETS VINFILE IN AR1, STANDARDIZED FOR "T"
HRLZI T,AS.SFA ;CHECK FOR AN SFA
TDNN T,ASAR(AR1) ;FOUND AN SFA?
JRST 1(D) ;NOPE, RETURN RIGHT AWAY
HLRZ TT,(D) ;GET POINTER TO OP BIT
MOVE T,(TT) ;GET THE ACTUAL BIT
MOVEI TT,SR.WOM ;CHECK AGAINST KNOWN THINGS
TDNN T,@TTSAR(AR1) ;CAN IT DO THIS SPECIFIC OPERATION?
JRST 1(D) ;NO, RETURN AS NORMAL
INCSEO: TLNE T,SO.TIP ;FOO! TYIPEEK IS DIFFERENT!
TDZA C,C ; BUT IF NOT TYIPEEK THEN USE
MOVEI C,INCSEO ; NEW EOF VALUE, SOMETHING UNIQUE
PUSH FXP,D ;MAY NEED TO RETURN IF OVER-RUBOUT
PUSH P,AR1 ;REMEMBER THE SFA
PUSHJ P,ISTCAL ;YES, PROCESS IT
POP FXP,D
POP P,AR1
CAIE A,INCSEO ;DID THE SFA RETURN EOF?
JRST .+3
PUSHJ P,EOF ;HANDLE EOF
JRST INCAST ;IF RETURN THEN PROCEED AROUND AGAIN
MOVE TT,(A)
POPJ P, ;NO, RETURN
] ;END IFN SFA
XINCA1: TLOA D,1 ;MUST HAVE FIXNUM RESULT
INCALL:
SFA$ JUMPE T,INCAST ;ZERO ARGS
SFA% JUMPE T,1(D)
AOJL T,INCAL2
SETZ AR1,
EXCH AR1,(P) ;DEFAULT NIL FOR EOF VALUE
INCAL4: JUMPE AR1,EOFBN0 ;NOT IF NIL
JSP TT,XFOSP ;FILE OR SFA?
JRST EOFBN0 ;NOT IF T, OR IF NOT FILE
IFN SFA,[
JRST INCAL5
INCST2: HLRZ TT,(D) ;GET POINTER TO OP BIT
MOVE T,(TT) ;GET THE ACTUAL BIT
MOVEI TT,SR.WOM ;CHECK AGAINST KNOWN THINGS
TDNN T,@TTSAR(AR1) ;CAN IT DO THIS SPECIFIC OPERATION?
JRST INCALZ ;NO, HANDLE NORMALLY: LOWER LEVEL WILL TRAP
POP P,C ;GET EOF VALUE
TLNN D,1 ;EXPECTING A FIXNUM RESULT?
JRST ISTCAL ;NOPE, CALL THE STREAM AND GO ON
PUSH P,C ;REMEMBER EOF VALUE AGAIN
INCST3: TLNE T,SO.TIP ;FOO! TYIPEEK IS DIFFERENT!
TDZA C,C ; BUT IF NOT TYIPEEK THEN USE
MOVEI C,INCST3 ; NEW EOF VALUE, SOMETHING UNIQUE
PUSHJ P,ISTCAL ;CALL THE SFA
POP P,C ;RESTORE EOF VALUE
CAIN A,INCST3 ;DID THE SFA RETURN EOF?
JRST INCST4 ;YES, HANDLE IT
JSP T,FXNV1 ;ELSE THE VALUE RETURNED MUST BE A FIXNUM
POPJ P,
INCST4: SKIPN A,C ;FOR A NULL EOF VALUE, SNEAKILY
MOVEI A,IN0-1 ; SLIP IN -1
JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED
POPJ P, ; MUST BE A FIXNUM
] ;END IFN SFA
INCAL5: MOVE A,TTSAR(AR1) ;GET ARRAY TYPE BITS
TLNN A,TTS<IO> ;MUST BE INPUT
JRST INCAL1
EXCH A,AR1
PUSHJ P,[IOL [NOT AN INPUT FILESPEC!]]
EXCH A,AR1
JRST INCAL4
INCAL1: TLNN A,TTS<TY> ;IF TTY ALLOW BINARY MODE
TLNN A,TTS<BN> ;MUST NOT BE BINARY FILE
JRST INCALZ
EXCH A,AR1
PUSHJ P,[IOL [NOT ASCII FILE!]]
EXCH A,AR1
JRST INCAL4
INCALZ: POP P,A ;RESTORE EOF VALUE
INBIND: SKIPE B,AR1
JRST INBN4
PUSHJ P,INFGET ;GETS VINFILE IN AR1
MOVEI B,(AR1)
INBN4: CAIN B,TRUTH
TDZA C,C
SKIPA C,[TRUTH]
HRRZ AR1,V%TYI
; PUSHJ P,ATIFOK
; UNLOCKI
MOVSI T,-LINBN9 ;OPEN-CODING OF SPECBIND
MOVEM SP,SPSV
INBN1: HRRZ TT,INBN9(T)
HRRZ R,(TT)
HRLI R,(TT)
PUSH SP,R
HLRZ R,INBN9(T)
TRNN R,777760
HRRZ R,(R)
MOVEM R,(TT)
AOBJN T,INBN1
JSP T,SPECX ;END OF SPECBIND
PUSH P,CUNBIND
JRST EOFBIND
INBN9: C,,TAPRED ;TABLE OF VALUE CELLS FOR INBIND
B,,VINFILE ; EACH ENTRY IS OF FORM:
NIL,,VINSTACK ; <NEW VALUE>,,<VALUE CELL>
$DEVICE,,TYIMAN ; IF NEW VALUE IS AN AC, THEN
IUNTYI,,UNTYIMAN ; THE AC CONTAINS THE REAL
;; UNRD,,UNREADMAN ; NEW VALUE.
;; READP,,READPMAN
LINBN9==.-INBN9
INCAL2: AOJL T,INCAL7
POP P,A ;TWO ARGS
POP P,AR1
JUMPE AR1,INBIND
CAIN AR1,TRUTH
JRST INBIND
PUSH P,A ;SAVE EOF VALUE
JSP TT,XFOSP
SFA% SKIPA
SFA% JRST INCAL5
IFN SFA,[
JRST INCST1
JRST INCAL5
JRST INCST2
INCST1: ] ;END IFN SFA
EXCH A,AR1 ;OTHER MUST BE FILE ARRAY
MOVEM A,(P) ;STORE NEW EOF VALUE
JRST INCAL4 ;MAKE SURE OTHER IS CORRECT
INCAL7: HRRZ D,(D) ;MORE THAN TWO ARGS: FOOEY.
JRST S2WNAL
EOFBN0: POPI P,1 ;GET EOF VALUE OFF STACK
MOVEI A,(AR1)
EOFBIND:
TLNN D,1 ;BIND FOR INPUT EOF TRAP
JRST EOFBN3
PUSH P,F ;FOR NUMERICAL INPUT FN, FIX1 OR CPOPJ
TLO A,400000
EOFBN3: PUSH P,A
PUSH P,CEOFBN5
JSP T,ERSTP ;SET UP A FRAME
MOVEM P,EOFRTN ;THIS IS AN EOF FRAME
SETZM BFPRDP .SEE EOF2
SFA% PUSHJ P,1(D) ;RUN CALLING FUNCTION
SFA$ MOVEI C,(A) ;THIS IS THE EOF VALUE FOR SFAS
SFA$ PUSHJ P,INCAST ;HANDLE AN SFA, ELSE RUN THE CALLER
MOVSI D,-LEP1+1(P) ;RESTORE FRAME STUFF
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,[LERSTP+2,,LERSTP+2] ;FLUSH FRAME
POPJ P, ;RETURN (RESULT IN A OR TT)
EOFBN5: POP P,A ;COME HERE ON EOF
TLZN A,400000
CEOFBN5:
POPJ P,EOFBN5
SKIPN A ;FOR A NULL EOF VALUE, SNEAKILY
SKIPA TT,XC-1 ; SLIP IN A -1 INSTEAD
JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED
POPJ P, ; MUST BE A FIXNUM
SUBTTL NEWIO END-OF-FILE HANDLING
;;; HANDLE EOF ON STANDARD FILE ARRAY IN AR1.
EOF: PUSHJ FXP,SAV5
HRRZ T,BFPRDP ;CHECK WHETHER IN READ
JUMPN T,EOFER
EOF2:
SFA$ MOVSI TT,AS.SFA
SFA$ TDNE TT,ASAR(AR1) ;DID AN SFA GET EOF?
SFA$ JRST EOFZ ;YES, NEVER ANY EOFFN
MOVEI TT,FI.EOF
HRRZ B,@TTSAR(AR1)
JUMPE B,EOF5
EXCH B,AR1
SKIPE A,EOFRTN
HRRZ A,-LERSTP-1(A) .SEE EOFBIND
EXCH A,B
CALLF 2,(AR1)
JUMPN A,EOF4
EOF8: SKIPE TAPRED ;READING FROM INFILE?
PUSHJ P,INPOP ;YES, POP THE INPUT STACK
PUSHJ P,EOF7
EOF1: JSP R,PDLA2-5
POPJ P,
EOF7: HRRZ A,-2(P) ;SAVED AR1
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY> ;DON'T CLOSE TTY INPUT,
PUSHJ P,ICLOSE ; FOR THAT WAS MERELY OVER-RUBOUT
POPJ P,
EOF4: CAIN A,TRUTH
JRST EOF1
SKIPN T,EOFRTN
JRST EOF8
HRRM A,-LERSTP-1(T) .SEE EOFBIND
EOF9: MOVE P,EOFRTN .SEE TYPK9
JRST ERR1
EOF5: PUSHJ P,EOF7
EOFZ: SKIPE TAPRED ;NO EOF FUNCTION. READING FROM INFILE?
PUSHJ P,INPOP ;YES, POP THE STACK
SKIPN EOFRTN
JRST EOF1
JRST EOF9
SUBTTL NEWIO INPUSH FUNCTION
;;; HAIRY INPUSH FUNCTION. PUSHES FILE ONTO INSTACK,
;;; OR MAYBE PUSHES INFILE, OR MAYBE POPS.
;;; INPOP POPS INSTACK INTO INFILE ONCE.
INPUSH: CAIN A,TRUTH ;SUBR 1
HRRZ A,V%TYI
IFN SFA,[
JSP TT,AFOSP ;DO WE HAVE AN SFA?
JRST INPU2 ;Nope, nothing
JRST INPU1A ;Ah, a file.
MOVEI T,SO.TYI+SO.RED+SO.RDL
TDNN T,@TTSAR(AR1) ;Can this SFA do any of these operations?
JRST INFLZE ; NO? then can't put it into INFILE
JRST INPU1B
INPU1A:] ;END OF IFN SFA
IFE SFA,[
JSP TT,AFILEP
JRST INPU2
] ;END OF IFN SFA
PUSHJ P,ATIFOK
UNLOCKI
INPU1B: EXCH A,VINFILE
HRRZ B,VINSTACK
PUSHJ P,CONS
MOVEM B,VINSTACK
INPU1: SKIPN A,VINFILE
JRST INFLZE
CAIN A,TRUTH
SETZM TAPRED
POPJ P,
INFLZE: PUSHJ P,INFLUZ
JRST INPU1
INPU2: SKOTT A,FX
JRST INFLZE
SKIPN TT,(A)
JRST INPU1
JUMPL TT,INPU5
INPU3: HRRZ A,VINFILE ;AN INPUSH LOOP
HRRZ B,VINSTACK
PUSHJ P,CONS
MOVEM A,VINSTACK
SOJG TT,INPU3
JRST INPU1
INPOP: MOVNI TT,1
PUSH P,A ;MUST SAVE A (E.G., SEE LOAD)
PUSH P,CPOPAJ
INPU5: PUSH FXP,TT
INPU6: SKIPN A,VINSTACK
JRST INPU8
HLRZ AR1,(A)
; PUSHJ P,ATIFOK
; UNLOCKI
HLRZ AR1,(A)
MOVEM AR1,VINFILE
HRRZ A,(A)
MOVEM A,VINSTACK
AOSGE (FXP)
JRST INPU6
INPU7: SUB FXP,R70+1
JRST INPU1
INPU8: MOVEI A,TRUTH
MOVEM A,VINFILE
JRST INPU7
SUBTTL TYI FUNCTION AND RELATED ROUTINES
TYI$: SKIPA F,CFIX1 ;SUBR (NIL . 0) NCALLABLE, FOR *TYI FUNCTION
MOVEI F,CPOPJ
PUSH P,F
JRST TYI
%TYI: SKIPA F,CFIX1 ;LSUBR (0 . 2) NCALLABLE, FOR TYI FUNCTION
MOVEI F,CPOPJ
JSP D,XINCALL
SFA% Q%TYI
SFA$ [SO.TYI,,],,Q%TYI
TYI: MOVEI A,Q%TYI
PUSH FXP,BFPRDP
HRLZM A,BFPRDP
PUSHJ P,@TYIMAN
POP FXP,BFPRDP
MOVEI A,(TT) ;BARF
POPJ P,
PTYI: PUSH P,CFIX1 ; +TYI: SUBR 1 (NCALLABLE)
CAIN A,TRUTH
MOVE A,V%TYI ;IF T, THEN MAKE IT TYI
SKIPE V.RSET
JRST PTYI2
MOVEI AR1,(A)
PTYI1:
IFN SFA,[
MOVSI T,AS.SFA ;CHECK IF AN SFA (SFA BIT SET IN ASAR?)
TDNE T,ASAR(A) ; GO DO FAST SFACALL IF SO
JRST PTYI3
] ;END OF IFN SFA
MOVEI D,2 ;SIGNAL TO $DEVICE TO JUST RETURN -1 ON EOF
MOVEI R,Q%TYI ;THIS IS TO BE A "TYI-LIKE" OPERATION
JRST .$DEV
PTYI2: MOVEI AR1,(A)
IFN SFA,[
JSP TT,XFOSP ;CHECK FOR AN SFA
JFCL
SKIPA ;NOPE
JRST PTYI3 ;YUP, SO CALL IT
] ;END IFN SFA
PUSHJ P,ATIFOK
UNLOCKI
JRST PTYI1
IFN SFA,[
PTYI3: MOVEI C,NIL ;DO FAST INTERNAL SFA CALL WITH
MOVSI T,SO.TYI ;TYI OPERATION
PUSHJ P,ISTCAL
JSP T,FXNV1 ;BE SURE IT RETURNS A FIXNUM VALUE
POPJ P,
] ;END IFN SFA
;;; MAIN UNTYI ROUTINE
;;; ACCEPTS CHARACTER IN A AND INPUT FILE IN B
;;; STICKS CHARACTER BACK INTO CHARACTER BUFFER.
;;; CLOBBERS A,B,AR1,T,TT,D. MUST SAVE C (SEE READ).
;; UNDO THE FORMER TYI OPERATION. -- user interface.
UNTYI: CAIN B,TRUTH
MOVE B,V%TYI ;IF T, THEN MAKE IT TYI
MOVEI AR1,(B)
SKIPN V.RSET
JRST UNTYI2
JSP TT,XFOSP
JFCL ;FOR RANDOM OBJS, AND FOR FILE ARRAYS,
PUSHJ P,[ PUSHJ P,ATIFOK ; CHECK FOR ASCII INPUT FILE
JRST INTREL ]
UNTYI2: JSP T,FXNV1
MOVE A,TT ;GET ACTUAL FIXNUM VALUE INTO A
PUSHJ P,UNTYI1
JRST TRUE
IUNTYI: PUSHJ P,SINFGET ;INTERNAL UNTYI'ER -- GETS VINFILE IN AR1
UNTYI1:
IFN SFA,[
MOVSI TT,AS.SFA ;HANDLE DIFFERENTLY IF AN SFA
TDNE TT,ASAR(AR1) ;SKIP IF NOT AN SFA
JRST SUNTYI ;SFA UNTYI
] ;END IFN SFA
MOVEI D,300000(A) ;USE 200000 BIT (IN CASE OF ^@)
MOVEI TT,FI.BBC ;THE 100000 BIT IS A CROCK FOR PRATT
;THAT MEANS DO NOT PUT CHAR OUT ON ECHOFILES
HLRZ T,@TTSAR(AR1) ;GET SINGLE BUFFERED CHAR
JUMPE T,UNTYI3 ;THERE IS NONE - THIS IS EASY
HRRZ B,@TTSAR(AR1) ;FOOEY - WE MUST CONS THE
MOVEI TT,-200000(T) ; OLD BUFFERED BACK CHAR
JSP T,FXCONS ; INTO THE LIST TO LEAVE ROOM
PUSHJ P,CONS ; FOR THE NEW ONE
MOVEI TT,FI.BBC
HRRZM A,@TTSAR(AR1)
UNTYI3: HRLM D,@TTSAR(AR1) ;BUFFER BACK NEW CHAR
POPJ P,
IFN SFA,[
SUNTYI: PUSH P,C ;CANNOT BASH C
MOVEI TT,(A) ;CHARACTER INTO TT
JSP T,FXCONS ;GENERATE A LISP FIXNUM (really won't "cons")
MOVSI T,SO.UNT ;UNTYI OPERATION
MOVEI C,(A) ;ARGUMENT INTO C (CHARACTER TO UNTYI)
PUSHJ P,ISTCAL ;GO TO THE SFA CALLER
POP P,C
POPJ P,
] ;END IFN SFA
;;; MAIN INPUT FILE ARRAY HANDLER
;;; FILE ARRAY IN VINFILE.
;;; SAVES A,B,C,AR2A; CLOBBERS AR1.
;;; RETURNS CHARACTER IN TT.
;;; ACCUMULATOR D IS ZERO FOR PEEKING, 1 FOR NORMAL INPUT, AND 2 FOR
;;; INPUT WHICH MERELY RETURNS -1 AT EOF.
$PEEK: TDZA D,D
$DEVICE: MOVEI D,1
$DEV$: PUSHJ P,SINFGET ;GETS VINFILE IN AR1
IFN SFA,[
MOVSI T,AS.SFA ;BREAK AWAY HERE IF SFA
TDNE T,ASAR(AR1) ;SFA?
JRST $DEVSFA ;NOPE, CONTINUE AS USUAL
] ;END OF IFN SFA
MOVSI T,TTS<CL>
TDNE T,TTSAR(AR1)
JRST $DVLUZ ;INPUT (FILE) CLOSED LOSSAGE!
$DEV0: HLRZ R,BFPRDP
.$DEV: .SEE .TYI
LOCKI ;ALREADY HAVE MOST ACS SETUP WITH INFO
MOVE T,TTSAR(AR1) ; SUCH AS FILE-ARRAY IN AR1, "TYPE" IN R
SKIPN TT,FI.BBC(T)
JRST $DEV2 ;ANY "BUFFERED-BACK" CHARS?
JUMPE R,$DEV1
TLNN T,TTS<TY> ;IF THIS FILE-ARRAY ISN'T A TTY, THEN WE CAN
JRST $DEV1 ; JUST TAKE THE BUFFERED BACK CHAR
CAIE R,Q%TYI ;FOR "READ" OR "READLINE" REQUESTS, WE MAY WANT
JRST $DEV2A ; TO RUN THE TTYBUF FUNCTION.
$DEV1: TLZN TT,200000
JRST $DEV1A
HLRZ TT,TT
SKIPE D
HRRZS FI.BBC(T)
JRST $DEV1B
$DEV1A: MOVS TT,(TT) ;THERE IS A BUFFER-BACK LIST
SKIPE D
HLRZM TT,FI.BBC(T) ;"CDR" IT IF NOT MERELY PEEKING
MOVE TT,(TT) ;AND TAKE TOP CHAR
$DEV1B: TRZN TT,100000 ;100000 MEANS DON'T OUTPUT TO ECHOFILES
JRST $DEVECO
UNLKPOPJ .SEE UNTYI
;;; NO CHARS BUFFERED BACK, SO DISPATCH ON FILE TYPE
$DEV2: TLNN T,TTS<TY> ;IF THIS ISN'T A TTY,
JRST $DEV4 ; THEN FORGET CLEVER HACKS
CAIN R,Q%TYI ;IF THIS IS "TYI", THEN
JRST $DEVAH ; PULL CLEVER ACTIVATION HACK
$DEV2A: MOVE F,F.MODE(T)
JUMPE R,$DEV4 ;NIL MEANS NO CLEVERNESS AT ALL
HRRZ R,TI.BFN(T)
JUMPN R,$DEVPS
TLNN F,FBT<FU> ;NO PRE-SCAN FUNCTION IN FILE
JRST $DEV4
UNLOCKI ;CANT "PRESCAN" FROM TTY WITH 12.-BIT CHARS
PUSHJ P,INFLUZ
JRST $DEV$
;;; MOBY WINNING PRESCAN READER FOR TTYs
$DEVPS:
IFN D20,[
SKIPN TENEXP ;No RDTTY on TENEX, and SIN doesn't do rubouts
TLNN F,FBT<LN>
SKIPA
JRST $DEVLM
] ;END OF INF D20
HRLM D,(P) ;INVOKE THE PRE-SCAN FUNCTION
PUSHJ FXP,SAV5 ;FIRST, SAVE THE WORLD THEN CALL THE SCANNER
MOVEI AR2A,(R) ;FUNCTION WITH 3 ARGUMENTS:
MOVEI A,(AR1) ; (1) THE FILE ARRAY
HLRZ B,BFPRDP ; (2) THE FUNCTION TO BUFFER FOR
LDB T,[002100,,BFPRDP] ; (3) IF (2) IS 'READ, THE
UNLOCKI
PUSH FXP,T ; NUMBER OF HANGING OPEN
MOVEI C,(FXP) ; PARENTHESES
PUSH FXP,BFPRDP
PUSH FXP,LPNF
CALLF 3,(AR2A)
POP FXP,LPNF
POP FXP,BFPRDP
HRRZS BFPRDP
SUB FXP,R70+1
HRRZ AR1,-1(P)
JUMPE A,$DVEF0 ;NIL MEANS OVER-RUBOUT, ERGO EOF
MOVEI C,(A)
SKIPE V.RSET
CAIN R,QTTYBUF ;DON'T NEED TO CHECK RESULT IF
JRST $DVPS1 ; IT WAS OUR OLD FRIEND TTYBUF
MOVEI B,(C)
HLRZ A,(B) ;LOOP TO VERIFY THAT RESULTS FROM TTY
JSP F,TYOARG ; PRESCAN ARE INDEED ASCII VALUES
HRRZ B,(B)
JUMPN B,.-3
$DVPS1: LOCKI
$DVPS0: HRRZ AR1,-1(P)
MOVE T,TTSAR(AR1)
EXCH C,FI.BBC(T) ;SO ADD LIST OF CHARS TO BUFFER-BACK
JUMPN C,$DVPS2 ; OOPS, SOME "SNEAKED" IN
$DVPSX: JSP R,PDLA2-5
HLRZ D,(P)
UNLOCKI
JRST $DEV$ ;AND TRY AGAIN!
$DVPS2: TLZE C,200000
JRST $DVPS3
MOVE A,FI.BBC(T)
MOVEI B,(C) ;BUFFER-BACK LIST "SNEAKED" UP IN THE MEANTIME
PUSHJ P,.NCONC ; JUST TACK IT ON END (SINCE IT WAS "LATER")
JRST $DVPSX
$DVPS3: LDB TT,[221400,,C] ;BUFFER-BACK CHAR "SNEAKED" UP IN THE MEANTIME
MOVEI C,0
EXCH C,FI.BBC(T) ;LIST FROM TTYSCAN PLACED IN C
UNLOCKI ;FOO! PERMIT CONSING. FOO! FOO! FOO!
JSP T,FXCONS
MOVE B,C
PUSHJ P,CONS
MOVE C,A
JRST $DVPS1
;;; LINEMODE FOR TTYs
IFN D20,[
$DEVLM: SKIPE TT,FI.BBC(T) ;It may happen, for re-entrant READs, that
JRST $DEV1 ; there is dispatch to "Pre-Scan", even though
HRLM D,(P) ; there are already chars in the buffer.
POP FXP,TT ;POP THE LOCKI WORD
PUSHJ FXP,SAV5
PUSHN FXP,80.
;;; THIS IS SUBOPTIMAL BEHAVIOR -- SEE ABOVE
;; SKIPE TENEXP
;; JRST $DVLMX
MOVEI 1,-80.+1(FXP)
HRLI 1,440700
MOVE 2,[RD%RND+RD%BEL 400.]
SETZ 3,
MOVE R,1 ;SAVE BP IN R
HRROM TT,INHIBIT ;make up .5LOCKI
RDTTY
ERJMP IIOERR
HRREI F,-400.(2)
$DVLMQ: JUMPN F,$DVLM0
POPI FXP,80.
PUSH FXP,TT ;RESTORE LOCKI WORD
JRST $DVPSX ;EXIT AND TRY AGAIN IF NOTHING INPUT
$DVLM0: PUSH FXP,TT ;RESTORE LOCKI WORD
UNLOCKI ;UNLOCK TO PERMIT CONSING
MOVEI B,NIL
$DVLM1: ILDB TT,R
;;; SEE ABOVE -- SIN LOSSAGE, WILL NEVER GET HERE ON TENEX
;; SKIPN TENEXP ;IF NOT TENEX
;; CAIE TT,37 ;OR NOT <NEWLINE>
;; SKIPA ;THEN LEAVE AS IS
;; MOVEI TT,15 ;ELSE CONVERT TO ^M
JSP T,FXCONS
PUSHJ P,CONS
MOVE B,A
AOJL F,$DVLM1
POPI FXP,80.
PUSHJ P,NREVERSE ;CONS UP THE LIST
MOVE C,A
JRST $DVPS1 ; AND JOIN "PRESCANNER" CODE
;;$DVLMX:
;; MOVEI 2,-80.+1(FXP)
;; HRLI 2,440700
;; MOVEI 3,400.
;; MOVEI 4,37
;; MOVEI 1,-1
;; HRROM TT,INHIBIT
;; MOVE R,2
;; SIN
;; ERJMP IIOERR
;; HRREI F,-400.(3)
;; MOVE 1,2
;; HRR 2,3
;; JRST $DVLMQ
] ;END OF IFN D20
<EFBFBD>
;;; UNIT INPUT ON REAL DEVICE - INCLUDING "TTY" IN CASE OF CALL TO TYI FUNCT
$DEV4: SKIPL F,F.MODE(T) .SEE FBT.CM
JRST $DEV5
HRRO TT,(FXP) ;This had better get the saved INHIBIT
.SEE $DEV0
MOVEM TT, INHIBIT ;TURN THE LOCKI INTO A .5LOCKI
IFN ITS,[
MOVE R,F.CHAN(T)
LSH R,27
IOR R,[.IOT 0,TT]
SPECPRO INTTYX
TYIXCT: XCT R ;INPUT CHARACTER
NOPRO
$DEV4B: JUMPL TT,$DEVEF ;JUMP ON EOF
AOS F.FPOS(T) ;OTHERWISE INCREMENT FILE POSITION (OK EVEN IF F.FLEN NEG)
JRST $DEV6
] ;END OF IFN ITS
IFN D20,[
$DEV4C: PUSHJ FXP,SAV3
HRRZ 1,F.JFN(T)
SPECPRO INTTYX
TYIXCT: BIN ;INPUT CHARACTER
ERJMP $DEV4T
NOPRO
MOVE TT,2
PUSHJ FXP,RST3
AOS F.FPOS(T) ;OTHERWISE INCREMENT FILE POSITION (OK EVEN IF F.FLEN NEG)
SKIPN TENEXP
JRST $DEV6
TRNN F,10 ;SAIL DOES THIS TOO?
TLNE F,FBT<FU> ;I DON'T UNDERSTAND THIS
JRST $DEV6
CAIN TT,37 ;TENEX ^_ IS CR, BARF
MOVEI TT,^M ;^_ -> CR
JRST $DEV6
] ;END OF IFN D20
IFN D10,[
SA$ $DEV4C: ;SAIL WANT'S LINMOD CHECK EVEN FOR TYI
MOVE R,[INCHWL TT]
TLNN F,FBT<LN>
SA% $DEV4C:
MOVE R,[INCHRW TT]
SPECPRO INTTYX
TYIXCT: XCT R
NOPRO
IFN SAIL,[
TRNE F,10 ;FORGET THIS HACK FOR IMAGE MODE
JRST $DEV6
MOVEI R,(TT) ;CANONICALIZE ASCII CODES
TLNE F,FBT<FU> ;I DON'T UNDERSTAND THIS
JRST $DEVS4 ;BUT CONVERT IN NON-FULL MODE
CAIN R,32 ;TILDE: 32 => 176
HRROI R,176
CAIN R,176 ;RIGHT BRACE: 176 => 175
HRROI R,175
CAIN R,175 ;ALTMODE: 175 => 33
HRROI R,33
CAIN R,33 ;NOT EQUALS: 33 => 32
HRROI R,32
$DEVS4: ANDI TT,600
IORI TT,(R)
TLNE F,FBT<FU> ;IF FULL CHARACTER SET (BUCKY BITS),
JRST $DEV4S ; DON'T DO ANY CONVERSIONS
CAIN TT,33 ;ALTMODE?
JRST $DEV4S ;YUP! SO LEAVE IT ALONE
CAIGE TT,40 ;A CONTROL CHARACTER?
ADDI TT,%TXCTL+"@ ;YES, CONVERT TO EXTENDED ASCII FORMAT
$DEV4S: TRNN TT,%TXCTL+%TXMTA ;USE PRESENCE OF CONTROL BIT TO CHECK FOR INT
JRST $DEV6
; PUSH FXP,TT ;SAVE THE ACTUAL CHARACTER
; SUBI TT,%TXCTL+"@
; CAIL TT,"a-"@ ;IS IT A LOWER CASE LETTER?
; CAILE TT,"z-"@
; SKIPA ;NOPE, LEAVE ALONE
; SUBI TT,"a-"@-1 ;ELSE CONVERT TO REAL CONTROL CHARACTER
; SKIPL TT
; CAILE TT,"_ ;IS IT A REAL "CONTROL" CHARACTER?
; JRST $DEV4V ;NO, FIXUP THE WORLD AND PROCEED
] ;END OF IFN SAIL
SA% CAIL TT,40 ;CONTROL CHARS CAUSE AN INTERRUPT WHEN READ
SA% JRST $DEV6
$DEV4U: HRLM D,(P)
MOVEI D,(TT) ;ONLY INTERRUPT IF INT FUNCTION EXISTS
ROT D,-1 ;CLEVER ARRAY ACCESS AS PER TTYICH
ADDI D,FB.BUF(T)
PUSH FXP,R
HLRZ R,(D)
SKIPGE D
HRRZ R,(D)
JUMPE R,$DEV4Z
MOVEI D,400000(TT)
HRLI D,(AR1) ;THERE IS NO OBVIOUS NEED FOR THIS NOW
PUSHJ P,UCHINT ;GIVE USER INTERRUPT FOR TTY INT CHAR
$DEV4Z: POP FXP,R
HLRZ D,(P)
; SA$ $DEV4V: POP FXP,TT ;RESTORE THE CONTROL CHARACTER
JRST $DEV6
] ;END OF IFN D10
IFN D20,[
$DEV4T: GTSTS
TLNN 2,(GS%EOF)
JRST IIOERR
JRST $DEVEF
] ;END OF IFN D20
;;; A TRICKY HACK TO BE CLEVER ABOUT IMMEDIATE ACTIVATION
;;; WHEN TYI (OR READCH, OR WHATEVER) IS INVOLVED.
$DEVAH: SKIPL F,F.MODE(T) ;MUST BE THE TTY FOR THIS TO WORK
JRST $DEV5
HRRO TT,(FXP) ;This had better get the saved INHIBIT
.SEE $DEV0
MOVEM TT,INHIBIT ;TURN THE LOCKI INTO A .5LOCKI
IT% JRST $DEV4C ;IGNORE LINE MODE, AND USE CHARACTER INPUT UUO
IFN ITS,[
SPECPRO INTTYX
TYICAL: .CALL $DEV4M ;GOBBLE CHAR, EVEN IF NOT ACTIVATED
NOPRO
.LOSE 1400
MOVE TT,TTSAR(AR1)
SKIPN R,FT.CNS(TT)
JRST $DVAH1 ;DONE IF NO ASSOCIATED OUTPUT TTY
HRLM D,(P)
MOVE TT,TTSAR(R) ;UPDATE CHARPOS AND LINENUM FROM CURSOR
PUSH FXP,T
PUSHJ FXP,CLRO4 ; POSITION OF ASSOCIATED OUTPUT TTY
POP FXP,T
HLRZ D,(P)
MOVE TT,TTSAR(AR1)
$DVAH1: EXCH T,TT
JRST $DEV4B
$DEV4M: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
5000,,%TIACT ;READ CHARACTER IMMEDIATELY EVEN IF NOT ACTIVATOR
,,F.CHAN(T) ;CHANNEL #
402000,,T ;SINGLE CHAR RETURNED HERE (T, NOT TT!)
] ;END OF IFN ITS
;;; CODE FOR FILE ARRAYS WITH A BUFFER
$DEV5A: PUSHJ P,$DEVBUF ;GET A NEW BUFFER LOAD. WATCH OUT FOR EOF
JRST $DEVEF
$DEV5: ;BASIC GET-1-CHAR FROM BUFFERED FILE
10$ HRRZ TT,FB.HED(T)
10$ SOSGE 2(TT)
10% SOSGE FB.CNT(T) ;GOBBLE NEXT INPUT CHAR
JRST $DEV5A ;MAY NEED TO GET NEW BUFFER
10$ ILDB TT,1(TT)
10% ILDB TT,FB.BP(T)
10$ TLNN T,TTS<IM> ;IN IMAGE MODE, WHAT YOU SEES IS WHAT YOU GETS
10$ JUMPE TT,$DEV5 ;IN ASCII MODE, A NULL IS LITTERA NON GRATA
JRST $DEV6W
;;; READ IN A NEW BUFFERLOAD - SKIP RETURN ON SUCCESS, NO SKIP ON EOF
;;; EXPECTS ARRAY PTR IN AR1, TTSAR IN T - SAVES D AND F
.SEE FPOS5
$DEV5K: ;LOSING SYMBOL FOR DSK:JLK;LISPT PATCH
$DEVBUF: PUSH FXP,D
MOVE D,FB.BVC(T)
ADDM D,F.FPOS(T) ;UPDATE FILEPOS BY NUMBER OF VALID BYTES
SETZM FB.BVC(T)
IFN ITS,[
EXCH T,TT
MOVE D,FB.BFL(TT) ;BYTE COUNT
MOVE T,FB.IBP(TT) ;BYTE POINTER
TYICA1: .CALL SIOT
.LOSE 1400
EXCH T,TT
SUB D,FB.BFL(T) ;NEGATIVE OF NUMBERS OF BYTES READ
MOVNM D,FB.CNT(T)
MOVNM D,FB.BVC(T)
] ;END OF IFN ITS
IFN D20,[
PUSHJ FXP,SAV3 ;PRESERVE LOW THREE AC'S
HRRZ 1,F.JFN(T)
MOVE 2,FB.IBP(T)
MOVN 3,FB.BFL(T)
SIN ;READ A BUFFERFUL
ADD 3,FB.BFL(T)
MOVEM 3,FB.CNT(T) ;STORE COUNT OF BYTES READ IN FILE OBJECT
MOVEM 3,FB.BVC(T)
MOVE D,3
PUSHJ FXP,RST3
] ;END OF IFN D20
IFN D10,[
MOVE TT,F.CHAN(T)
LSH TT,27
IFE SAIL,[
TLNN T,TTS.BM
JRST $DEV5R
HRRZ TT,FB.HED(T) ;MAYBE BUFFER HAS BEEN RELOCATED? THEN FOR
MOVSI D,(BF.IOU)
ANDCAB D,@(TT) ;TURNS OFF BUFFER-IN-USE BIT AND ADVANCES BUFFER
SKIPGE (D) ;BF.IOU MUST BE BIT 4.9 FOR THIS TO WORK
JRST $DEV5S
MOVSI TT,TTS.BM
ANDCAM TT,TTSAR(AR1) ;TURN OFF "BUFFER-MOVED" BIT, BUT LEAVE BUF ADDR IN D
MOVE TT,F.CHAN(T)
LSH TT,27
HRR TT,D
] ;END OF IFE SAIL
$DEV5R: TLO TT,(IN 0,)
XCT TT ;READ A NEW BUFFERFUL
JRST $DEV5M ;SUCCESS!
SA% ANDCMI TT,-1
XOR TT,[<STATO 0,IO.EOF>#<IN 0,>]
XCT TT
JRST IIOERR ;LOSEY,LOSEY
IFN SAIL,[
MOVE D,FB.HED(T)
MOVE D,2(D)
MOVEM D,FB.BVC(T)
JUMPG D,$DEV5M
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN ITS+D20, JUMPN D,$DEV5M ;D HOLDS "NOT-EOF-P"
POP FXP,D ;FALLS THRU TO HERE ON EOF CONDITION
POPJ P, ; AND EXITS WITHOUT SKIPPING
IFN D10*<1-SAIL>,[
$DEV5S: HRRZ TT,FB.HED(T)
HRRZM D,(TT) ;STORE CURRENT BUFFER ADDR IN CONTROL BLOCK
TLZ D,-1
ADD D,[0700,,1]
TLNE T,TTS.BN
TLC D,0700#4400
MOVEM D,1(TT) ;CONSTRUCT NEW BP FOR BUFFER
MOVE D,(D)
TLNN T,TTS.BN
IMULI D,5
MOVEM D,2(TT) ;STORE NEW BYTE COUNT INITO BUFFERCONTROL-BLOCK
;FALL THRU TO $DEV5M
] ;END OF IFN D10*<1-SAIL>
$DEV5M: ;MORE INPUT WAS OBTAINED BY BUFFERED INPUT
IFN D10,[
MOVE D,FB.HED(T)
MOVE D,2(D) ;NUMBER OF VALID BYTES
MOVEM D,FB.BVC(T)
] ;END OF IFN D10
.ELSE,[
MOVE TT,FB.IBP(T)
MOVEM TT,FB.BP(T) ;INITIALIZE BUFFER POINTER
] ;END OF .ELSE
POP FXP,D
JRST POPJ1 ;SKIP RETURN ON SUCCESS
;;; WRAP UP, WITH NEW CHAR IN TT. UPDATE "PAGENUM" AND "LINENUM", AND ECHO
$DEV6: SETOM INHIBIT ;RECONVERT .5LOCKI TO LOCKI
SKIPN F,FI.BBC(T)
JRST $DEV6W
HRLM D,(P)
MOVE R,T
PUSHJ FXP,SAV5
JSP T,FXCONS
PUSHJ P,NCONS
MOVE C,A
JRST $DVPS0
$DEV6W: JUMPN D,$DEV6B
MOVEI D,(TT)
ANDI D,177+%TXCTL ;? THIS MAY SCREW CONTROL CHARS ON SAIL
TRZN D,%TXCTL
JRST $DEV6A
CAIE D,177
TRZ D,140
$DEV6A: TRO D,200000
HRLM D,FI.BBC(T)
SETZ D,
$DEV6B: CAIN TT,^J
AOS AT.LNN(T)
CAIE TT,^L
JRST $DEVECO
SETZM AT.LNN(T)
AOS AT.PGN(T)
$DEVECO: SKIPE AR1,VECHOFILES ;SKIP UNLESS ECHO FILES
SKIPN D ;DON'T ECHO PEEKED-AT CHARS
UNLKPOPJ
SA$ CAIN TT,203
SA$ UNLKPOPJ
SA$ CAIE TT,%TXCTL+"M
SA$ CAIN TT,%TXCTL+"m
SA$ MOVEI TT,15
HRLI AR1,200000 ;LIST OF FILES, NO TTY
HRLM TT,AR2A
PUSH P,AR2A
JSP T,GTRDTB ;GET READTABLE
LDB TT,[220700,,(P)] ;WATCHIT! CHAR COULD BE 12. BITS
UNLOCKI
PUSHJ P,TYO6 ;PUSH CHAR INTO ALL ECHO FILES
HLRZ TT,(P)
POP P,AR2A
POPJ P,
$DEVEF: UNLOCKI ;COME HERE ON EOF
$DVEF1: MOVNI TT,1
TRNN D,1 .SEE .TYI ;0 SAYS ONLY PEEKING, SO RETURN -1
POPJ P, ; 2 SAYS DON'T DO EOF, SO RETURN -1
PUSHJ P,EOF ;SIGNAL EOF
JRST $DEVICE ;RETRY IF WE SURVIVE
$DVEF0: JSP R,PDLA2-5 ;EOF AFTER TTYSCANNING
JRST $DVEF1
;;; LOSING CODE FOR "$DEVICE"ING A SFA
IFN SFA,[
$DEVSFA: PUSHJ FXP,SAV5
PUSH FXP,D ;SAVE D OVER CALL
SETZ C, ;NIL AS OP DEPENDENT ARGS
JUMPE D,$DEVPE ;PEEKING, MIGHT HANDLE THE SFA DIFFERENTLY
HRLZI T,SO.TYI ;WE ARE DOING A TYI
$DEVP1: PUSHJ P,ISTCAL ;INTERNAL SFA CALL, SFA IN AR1
$DEVP2: PUSHJ FXP,RST5M1
POP FXP,D
SKIPE A ;ALLOW NIL
JSP T,FXNV1 ;INSURE FIXNUM AND GET INTO TT
JUMPN A,POPAJ ;IF NON-NIL THEN GOT SOMETHING, SO RETURN IT
MOVNI TT,1
JUMPE D,POPAJ ;ONLY PEEKING, SO MERELY RETURN -1
PUSHJ P,EOF ;SIGNAL EOF
POP P,A
JRST $DEVICE ;RETRY IF WE SURVIVE
$DEVPE: MOVEI TT,SR.WOM ;CHECK THE WHICH-OPERATIONS MASK FOR TYIPEEK
MOVSI T,SO.TIP
TDNE T,@TTSAR(AR1) ;CAN IT DO IT?
JRST $DEVP1 ;YES, DO IT DIRECTLY
MOVSI T,SO.TYI ;ELSE DO IT AS TYI/UNTYI
PUSHJ P,ISTCAL ;DO THE TYI
JUMPE A,$DEVP2 ;HIT EOF
PUSH P,A ;REMEMBER THE CHAR WE WERE HANDED
MOVSI T,SO.UNT ;NOW UNTYI THE CHARACTER
MOVEI C,(A) ;THE ARG IS THE CHARACTER
MOVE AR1,-2(P) ;GET THE SFA AS FIRST ARG
PUSHJ P,ISTCAL ;DO THE UNTYI
POP P,A ;FUDGE THE CHARACTER AS THE RETURNED VALUE
JRST $DEVP2
] ;END IFN SFA
INFGT0: PUSHJ P,INFLUZ
INFGET: SKIPN AR1,VINFILE ;GET VINFILE IN AR1
JRST INFGT0
POPJ P,
SINFGET: SKIPN AR1,VINFILE ;Standardizing INFile GETter
PUSHJ P,INFGET ;GETS VINFILE IN AR1
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
POPJ P,
$DVLUZ: PUSH P,[$DEV$]
INFLZZ: SKIPA T,[[SIXBIT \INFILE CLOSED!\]]
INFLUZ: MOVEI T,[SIXBIT \BAD VALUE FOR INFILE!\]
PUSH P,A
MOVEI A,TRUTH ;INFILE IS A LOSER!
EXCH A,VINFILE
PUSH P,CPOPAJ
%FAC (T)
SUBTTL READLIST, IMPLODE, MAKNAM
BYTEAC==TT
MKNR6C: MOVEM T,MKNCH
JSP TT,IRDA
SKIPA
MKR6DB: IDPB BYTEAC,C
PUSHJ P,@MKNCH
JRST RDAEND
SOJGE D,MKR6DB
PUSH FXP,BYTEAC
PUSHJ FXP,RDA4
JSP TT,IRDA1
POP FXP,BYTEAC
SOJA D,MKR6DB
READLIST:
JUMPE A,RDL12
MOVEI B,RDLTYI
MOVEI C,RDLUNTYI
JSP T,SPECBIND
0 A,RDLARG
0 B,TYIMAN
0 C,UNTYIMAN
MOVEI A,RDIN
MOVEI TT,READ0A
MOVEI T,LPNBUF
PUSHJ P,RDCH4
SKIPE T,RDLARG ;REALLY OUGHT TO ALLOW
CAIN T,-1 ; A TRAILING SPACE
JRST UNBIND
LERR RDRM1 ;TOO MANY CHARS
READ0A: PUSHJ P,REKRD ;READ AS IF "RE-ENTRANT", BUT
TLNN T,4060 ; DON'T PERMIT TOP-LEVEL SPLICING MACROS
JRST RMCER
POPJ P,
;;; READLIST PEEK AND TYI ROUTINES. (CF. $DEVICE).
;;; SAVES A,B,C,AR2A; CLOBBERS AR1. RETURNS CHARACTER IN TT.
RDLPEK: JRST RDLPK1 ;RDLTYI-1 IS FOR PEEKING (SEE TYIPEEK)
RDLTYI: PUSH P,A
SKIPN A,RDLARG
JRST RDLTY2
CAIN A,-1
LERR RDRM3 ;TOO FEW CHARS
HRRZ AR1,(A)
MOVEM AR1,RDLARG
RDLTY1: HLRZ A,(A)
RDLTY3: JSP T,CHNV1
JRST POPAJ
RDLTY9: SIXBIT \NOT ASCII CHAR!\
RDLTY2: HLLOS RDLARG
MOVEI TT,203 ;PSEUDO-SPACE
JRST POPAJ
RDLPK1: SKIPE TT,RDLARG
CAIN TT,-1
JRST M1TTPJ ;RETURN -1 FOR PEEKING AT "EOF"
PUSH P,A
HLRZ A,@RDLARG
JRST RDLTY3 ;ELSE RETURN CHAR, BUT DON'T FLUSH
RDLUNTYI:
MOVEI TT,(A)
JSP T,FXCONS
HRRZ B,RDLARG
PUSHJ P,CONS
MOVEM A,RDLARG
POPJ P,
READ6C: PUSH FXP,A
MOVEI T,R6C1
PUSHJ FXP,MKNR6C
SUB FXP,R70+1
JRST RINTERN
R6C1: ILDB TT,-1(FXP)
JUMPE TT,CPOPJ
ADDI TT,40
JRST POPJ1
SUBTTL READ FUNCTION
;;; ********** HIRSUTE READER **********
READ$: MOVEI T,0 ;FOR "*READ", WHICH IS "READ" WITH NO ARGS
JRST READ
OREAD: JSP D,INCALL
SFA% QOREAD
SFA$ [SO.RED,,],,QOREAD
READ: MOVEI A,QOREAD ;ENABLE TTY PRE-SCAN
HRLM A,BFPRDP
MOVEI A,RDIN
HRRZ T,BFPRDP
JUMPN T,READ0 ;OOOOPS, A RE-ENTRANT CALL TO READ
PUSHJ P,READ0B ;TOP-LEVEL READ
HLLZS BFPRDP
SKIPA B,RDBKC
READ0: PUSHJ P,REKRD ;RE-ENTRANT READ
TLC T,21000 ;LOSING SPLICING MACROS AT TOP LEVEL
TLCN T,21000
JRST READST ;JUST GO AROUND AND TRY AGAIN
READS0: TLNE B,100000 ;IF WE ENDED WITH A PSEUDO-SPACE
TLNN B,40 ; (40-BIT SET IN SPACE SYNTAX),
TLNN T,60 ; OR IF OBJECT WASN'T AN ATOM,
POPJ P, ; THEN DO NOT BUFFER BACK A CHAR
;;; READS0: TLNN B,100000 ;IF WE ENDED WITH A "WHITE-SPACE" CHARACTER
;;; TLNN T,60 ; OR IF OBJECT WASN'T AN ATOM,
;;; POPJ P, ; THEN DO NOT BUFFER BACK A CHAR
JSP R,RVRCT ;OTHERWISE MUST UNTYI A CHARACTER
EXCH A,C
PUSHJ P,@UNTYIMAN
JRST CRETJ
;We got a splicing macro at top level. If it's NIL, we go around again
;Otherwise, we just CDR it.
READST: JUMPE A,READ ;If we have NIL, we have nothing!
PUSHJ P,RDSMCK ;Check for it being a legal frob w/ CDR null
HLRZ A,(A) ;Take the CAR of it.
JRST READS0 ;and finish up as if it were what we'd read
;;; ***** HERE IT IS FANS, THE BASIC READER *****
READ0B: HRRZM A,RDINCH ;READ-IN CHANNEL FILTER
RD0B1: JSP T,RDIBGT
JSP T,RSXST
RD0B2A:
BG$ SUBI TT,10.
BG$ MOVEM TT,NRD10FL
MOVSI T,3 ;TOP LEVEL, FIRST OF LIST FLAGS
PUSHJ P,RDOBJ1 ;READ ONE OBJECT
HRRZS A
SETZB C,AR1
MOVEI AR2A,0
POPJ P,
;; PRE-FETCH VALUE OF IBASE, CHECK FOR CONSISTENCY, AND SAVE IN "RDIBS"
RDIBGT: HRRZ TT,VIBASE
IFN USELESS,[
CAIN TT,QROMAN
JRST RD0BRM
] ;END OF IFN USELESS
SKOTT TT,FX
JRST IBSERR
MOVE TT,@VIBASE
JUMPLE TT,IBSERR
CAIL TT,200
JRST IBSERR
IFN USELESS, SETZM RDROMP
MOVEM TT,RDIBS
JRST (T)
IFN USELESS,[
RD0BRM: MOVEI TT,10.
SETOM RDROMP
JRST (T)
] ;END OF IFN USELESS
RVRCT: MOVE C,VREADTABLE
MOVSI TT,-LRCT+2
CAME B,@TTSAR(C)
AOBJN TT,.-1
JUMPGE TT,ER3 ;BLAST? - READ
MOVEI C,(TT)
JRST (R)
REKRD: SOVE RDINCH RDIBS
PUSHJ P,READ0B
REKRD1: RSTR RDIBS RDINCH
POPJ P,
RDOBJ3: TLNE B,RS%WSP ;TAB,SPACE,COMMA
JRST RDOBJ1
TLNN T,1
POPJ P,
HRRZ TT,BFPRDP
JUMPN TT,RMCER
RDOBJ1: JSP TT,RDCHAR ;*** READ ONE OBJECT ROUTINE ***
RDOBJ: NWTN N,B,OBB ;OBJECT BEGIN CHAR - NOT USAGE AT TYIPEEK
JRST RDOBJ3
MOVEI TT,400000
IORM TT,BFPRDP
TLNE B,RS%MAC
JRST RDOBM2 ;MACRO CHAR.
TLNE B,RS%SCO
JRST RDCHO1 ;SINGLE CHAR OBJ.
NWTNE B,RS.<LTR+XLT>
JRST RDALPH ;RDOBJ WILL EXIT WITH OBJECT READ
TLNE B,RS%LP ;IN ACC A, AND RCT ENTRY OF BREAK
JRST RDLST ;CHARACTER IN ACC B
NWTNE B,RS.DIG
JRST RDNUM
NWTNE B,RS.SGN
JRST RDOBJ6 ;+,-
MOVE AR1,B
JSP TT,RDCHAR ;DEFAULT IS . <DOT>
TLNN AR1,RS.PNT
JRST RDOBJ0 ;WAS DOTTED PAIR POINT ONLY
NWTNE B,RS.DIG ;IS NEXT CHAR A DIGIT?
JRST RDOBJ5 ;IF SO, THEN MUST BE FLOATING NUM COMING UP
TLNN AR1,RS%DOT
JRST RDJ2A ;IF NOT DOTTED PAIR, THEN TRY ALPHABETIC
RDOBJ0: TLNE AR1,RS%DOT ;*** DOT IS DOTTED-PAIR DOT ***
TLNE T,1
JRST ER2
TLOE T,4 ;LOSE IF ALREADY IN DOTTED PAIR
JRST ER2
TLNN T,200000 ;SO GET SECOND PART OF DOTTED PAIR
JRST RDOBJ ; BUT IF HUNK, THEN DO SOME CHECKING FIRST
PUSHJ P,RDSKWH
POPJ P, ;ENCOUNTERED %RP, EXIT LOOKING LIKE SECOND
TLZ T,4 ; PART OF DOT-PAIR TO SIGNAL HUNK ENDING
JRST RDOBJ
;;;. WITH DECIMAL SYNTAX ONLY TURNS INTO SCO, IF FOLLOWED BY BREAK
;;;OR BEGINNING OF ALPHA IF FOLLOWED BY ALPHA
RDJ2A: TLNN B,RS%<BRK+SCO+WSP+LP+DOT+RP+MAC+SLS+RBO>
NWTNN B,RS.<PNT+ARR+SGN+XLT+LTR>
JRST RDCHO4
JRST RDJ2A1
RDOBJ5: TLOA T,200 ;FOUND FLOATING NUM
RDOBJ2: TLO T,10000 ;NUM FORCED WITH "+"
RDJ2A1: JSP TT,IRDA
IDPB AR1,C
AOS D
JRST RDNUM2
RDOBJ6: JSP TT,IRDA ;PROCESS OBJ BEGINNING WITH + OR -
IDPB B,C
SOS D
NWTNE B,RS.ALT
TLO T,400 ;-
JSP TT,RDCHAR
JRST @RDOBJ8 ;CHECK FOR WHITE'S + HAC, USING RD8W, OR DONT BOTHER, USING RD8N
RDJ6A: TLNE B,RS%<MAC+RP+LP+SCO+WSP>
JRST RDOBJ4
NWTNN B,RS.PNT
JRST ER1
MOVE AR1,B
JSP TT,RDCHAR
TLNE T,4
JRST ER1
JRST RDOBJ5 ;+.D DECIMAL FLOATING FORMAT
RDOBJ7: NWTNE B,RS.DIG
JRST RDNUM2 ;+<DECIMAL DIGIT>
TLO T,20 ;+<ALPHA CHARA> OR +<EXTENDED ALPHA>
JRST RDA1
ER1: LERR RDRM2
RDOBJ4: TLO T,20 ;SINGLE CHARA "+" OR "-"
JRST RDBK
RD8W: NWTNE B,RS.<DIG+LTR>
JRST RDOBJ2
JRST RDJ6A
RD8N: NWTNE B,RS.<SGN+DIG+LTR+XLT>
JRST RDOBJ7
JRST RDJ6A
RDNUM: JSP TT,IRDA ;*** NUMBER ATOM ***
RDNUM2:
IFE BIGNUM, SETZM AR1 ;FLAG INDICATES HOW MANY DIGITS BEYOND OVERFLOW
RDNM10: SETZB F,R ;BASE 10. NUMBER IN R, BASE IBASE IN F
TLOA T,40
RDNUM1: JSP TT,RDCHAR
NWTNE B,RS.PNT
JRST RDNUM4 ;DECIMAL POINT [WITHOUT BREAK BIT SET]
SOSLE D
IDPB B,C
NWTNE B,RS.DIG
JRST RDNUM5
TLNE T,300 ;ALPHA CHAR SEEN
JRST RDNUM8
NWTNN B,RS.LTR
JRST RDNUM7
TLNN T,10000
JRST RDNUM6
NW% MOVEI TT,(B) ;GET CHTRAN
NW$ HRRZ TT,B
NW$ ANDI TT,177
CAIL TT,"a ;ALLOW FOR LOWER CASE LETTERS
SUBI B,"a-"A
SUBI B,"A-"0-10. ;LETTERS ARE SUPRA-DECIMAL:
JRST RDNUM5 ; A=10., B=11., ..., Z=35.
RDNUM8:
NW% CAIE A,"E ;UPPER AND LOWER CASE E ALLOWED
NW% CAIN A,"e ;MUST TIDY THIS UP SOMEDAY
NW$ TLNE B,RS%SQX ;EXPONENT OR (SOMEDAY) STRING-QUOTE
JRST RDNM8A
NWTNN B,RS.XLT
JRST ER1
RDNUM7: TLNE T,37000 ;EXTENDED ALPHA CHAR SEEN
JRST ER1
NWTNN B,RS.ARR
JRST RDNUM6
NWTNE B,RS.ALT
TLOA T,2000 ;_
TLO T,1000 ;^
BG$ SKIPN NRD10FL ;IF WE ARE READING IN BASE 10., THEN
BG$ TLO T,100 ; F HAS NOTHING IN IT - SO MUST TAKE R
RDNUM9: TLNN T,140000
JRST RDNM9E
TLNE T,300 ;FOR EXPONENT-IFIED BIGNUMS, RDNSV WILL
HRR AR2A,AR1 ;BE MEANINGLESS
HRLI AR2A,0
TLNE T,400 ;BIGNUM OF CORRECT BASE AND SIGN IS PUT IN AR2A
TLO AR2A,-1
JRST RDNM9B
RDNM9E: TLNE T,300
MOVE F,R
TLNE T,400
MOVNS F
MOVEM F,RDNSV
RDNM9B: TLZ T,500 ;ZERO OUT SIGN AND DECIMAL BITS
MOVEI D,BYTSWD*LPNBUF
JSP TT,RDCHAR
RDNM9C: NWTNN B,RS.<DIG+SGN>
JRST ER1
NWTNN B,RS.SGN
JRST RDNM10
NWTNE B,RS.ALT ;SKIP IF +
TLO T,400
JSP TT,RDCHAR
JRST RDNM10
RDNUM0: IDPB B,C
RDNUM6: TLZ T,340 ;TWAS REALLY AN ALPHA ATOM
TLO T,20
JRST RDA3
RDNM8A: TLZ T,100
TLO T,1200
MOVEM D,RDDSV
JRST RDNUM9
RDNMF: JRST 2,@[.+1] ;CLEAR OUT ALL ARITHMETIC OVERFLOW BITS
MOVE B,T
MOVE TT,F ;FINISHED WITH NUMBER READ, SO PICK UP NUMBER IN BASE IBASE
BG$ SKIPN NRD10FL
BG$ TLO T,100
TLNN T,300
JRST RDNM2
MOVE TT,R ;PICK UP NUMBER IN BASE 10.
IFE BIGNUM,[
JUMPE AR1,RDNM2 ;NUMBER OF OVERFLOW DIGITS IN AR1
TLNN T,200
JRST RDNMER
ADDM AR1,D
ADDM AR1,RDDSV
]
RDNM2: TLNE T,400
MOVNS TT ;NEGATIVE NUMBER, IF INDICATED
BG$ TLNE T,140000
BG$ JRST RDBIGN
RDNM2A: TLNE T,200
JRST RDFLNM
RDFXNM: TLNE T,3000
JRST RDFXEX
RDFX1: JSP T,FXCONS
RDFL1: MOVE T,B
JRST RDNMX
RDNUM5: JFCL 8.,.+1 ;BASIC LOOP THAT INCREMENTALLY ADDS IN ONE DIGIT
IFE BIGNUM, JUMPN AR1,RDNUMC
IFN BIGNUM,[
TLNE T,40000
JRST RDBG10
]
RDNUMD: MOVE TT,R ;BASE 10. VALUE ACCUMULATES IN R
IMULI R,10. ;BASE IBASE VALUE IN F
NW% ADDI R,-"0(B)
NW$ LDB A,[001100,,B]
NW$ ADD R,A
JFCL 8,RD10OV
IFN BIGNUM,[
TLNE T,100000 ;BIGNUM VALUE BASE 10. HELD IN AR1
JRST RDBGIB ;BIGNUM VALUE BASE IBASE HELD IN AR2A
RDNUMB: SKIPN NRD10FL
JRST RDNUM1
]
IFE BIGNUM, RDNUMB:
JFCL 8,.+1 ;MIGHT BE SET IF OVFL ON BASE 10. READIN, WENT TO RD10OV, DID A C1CONS,
MOVE TT,F ;DID A GC, HACKED AROUND AND SET IT AGAIN!
IMUL F,RDIBS
NW% ADDI F,-"0(B)
NW$ LDB A,[001100,,B]
NW$ ADD F,A
JFCL 8,RDIBOV
JRST RDNUM1
IFE BIGNUM,[
RDIBOV: MOVE F,T
MOVE T,TT ;OVERFLOW WHILE ACCUMULATING NUMBER
MUL T,RDIBS ;IN BASE IBASE. TRY TO RECUPERATE
LSH T+1,1 ;TO ALLOW, FOR EXAMPLE, 400000000000
LSHC T,35.
NW% ADDI T,-"0(B)
NW$ ADD T,A
EXCH T,F
JRST RDNUM1
RD10OV: MOVE R,TT
RDNUMC: AOJA AR1,RDNUMB
]
RDFXEX:
IFN BIGNUM, CAIG A,77
TLNE T,600
JRST ER1
ANDI TT,777
EXCH TT,RDNSV
TLNN T,2000
JRST .+3
LSH TT,@RDNSV
JRST RDFX1
IFN BIGNUM,[
SKIPGE TT
TLO T,400
MOVMS TT
RX1: SOSGE RDNSV
JRST RDFX2
TLNE T,100000
JRST RDEX3
]
IFE BIGNUM,[
RX1: SOSGE RDNSV
JRST RDFX1
]
MUL TT,RDIBS
IFN BIGNUM,JUMPN TT,RDEXOF
LSH TT+1,1
LSHC TT,35.
JRST RX1
IFN BIGNUM,[
RDFX2: TLNE T,100000
JRST RDBIGM
TLNE T,400
MOVNS TT
JRST RDFX1
]
RDFLNM: TLNN T,1000
JRST RDFL3
MOVE D,RDDSV
ADD D,TT
AOS D
MOVE TT,RDNSV
RDFL3: HRREI R,-BYTSWD*LPNBUF-1(D)
IFN BIGNUM,[
TLZE T,140000
JRST RDFL3A
]
IDIVI TT,400000
SKIPE TT
TLC TT,254000
TLC TT+1,233000
SKIPE KA10P
JRST .+7
PUSH FLP,TT+1
SETZ TT+1,
PUSH FLP,TT+1
DFAD TT,-1(FLP)
POPI FLP,2
JRST .+2
FADL TT,TT+1
RDFL3A: MOVM T,R
RDFL2A: JUMPGE R,RDL2A2
RDFL2D: SETZ R,
CAIG T,30.
JRST RDL2D3
FSC TT,54. ;SCALE, SO THERE WONT BE UNDERFLOWS
MOVNI R,54.
RDL2D0: SKIPN KA10P
JRST .+5
FDVL TT,D1.0E8 ;LOOP FOR MULTIPLYING-IN NEGATIVE POWER OF 10.0
FDVR TT+1,D1.0E8
FADL TT,TT+1
JRST .+2
DFDV TT,D1.0E8
SUBI T,8
RDL2D3: CAILE T,8
JRST RDL2D0
JUMPE T,RDFL2E
RDL2D1: SKIPN KA10P
JRST .+5
FDVL TT,D10.0
FDVR TT+1,D10.0
FADL TT,TT+1
JRST .+2
DFDV TT,D10.0
SOJG T,RDL2D1
RDFL2E: SKIPE KA10P
JRST RDL2EB
SKIPGE T,TT ;REMEMBER SIGN IN T
DMOVN TT,TT ;NEGATE SO THAT "ROUNDP" TEST CAN BE EASY.
TLNE TT+1,200000 ;DECIDE WHAT EFFECT, IF ANY, ROUNDING WILL HAVE
TRON TT,1 ; LSB WAS 0, SO JUST SET IT
JRST RDL2EC ; OR NO EFFECT AT ALL
MOVE TT+1,TT ;"HEAVY" CASE. CREATE A FLONUM IN TT+1 WHOSE
AND TT+1,[777000,,1] ; VALUE IS 1 LSB OF FRACTION (ACCOUNTING FOR
JUMPGE T,RDL2EB ; A PROPOGATED CARRY).
MOVNS TT ;RE-NEGATE BACK, IF NECESSARY
MOVNS TT+1
RDL2EB: FADR TT,TT+1 ;ADD IN THE ROUNDING BIT
RDL2EA: FSC TT,(R)
JFCL 8,RDL2E1
RDL2E0: JSP T,FPCONS
JRST RDFL1
RDL2E1: JSP T,.+1
SKIPE VZUNDERFLOW
TLNN T,100 ;RANDOM FP UNDERFLOW BIT
JRST RDNMER
MOVEI TT,0
JRST RDL2E0
RDL2EC: SKIPG T
MOVNS TT
JRST RDL2EA
RDL2A0: SKIPN KA10P ;LOOP FOR MULTIPLYING-IN POSITIVE POWER OF 10.0
JRST .+7
MOVE TT+2,TT+1
FMPR TT+2,D1.0E8
FMPL TT,D1.0E8
UFA TT+1,TT+2
FADL TT,TT+2
JRST .+2
DFMP TT,D1.0E8
SUBI T,8
RDL2A2: CAIL T,8
JRST RDL2A0
JUMPE T,RDL2A3
RDL2A1: SKIPN KA10P
JRST .+7
MOVE TT+2,TT+1
FMPRI TT+2,(10.0)
FMPL TT,D10.0
UFA TT+1,TT+2
FADL TT,TT+2
JRST .+2
DFMP TT,D10.0
SOJG T,RDL2A1
RDL2A3: SETZ R,
JRST RDFL2E
RDLST: AOS BFPRDP
PUSH P,T ;*** READ LIST ***
PUSH P,R70 ;POINTER TO LAST OF FORMING LIST
HRLZI T,2
JRST RDLST3
RDLSTA: TLZE T,2 ;"ADD" AN ITEM TO A FORMING LIST
JRST RDLSAA
HLR B,(P) ;IFN NEWRD,??
HRRM A,(B)
JRST (TT)
RDLSAA: MOVEM A,(P)
JRST (TT)
RDHNK1: TLZN T,4060 ;IF THE NULL ITEM, FOLLOWED BY %RP
JRST RDLSX ; FOR HUNK, THEN EXIT.
RDLST1: PUSHJ P,NCONS ;GOT NEXT ITEM FOR LIST (OR HUNK)
JSP TT,RDLSTA
HRLM A,(P)
RDLST0: MOVE B,AR2A ;ZAP OUT OBJECT BITS, EXCEPT FOR "HUNK" AND
RDHNKA: TLZA T,-1#200002; "FIRST OBJECT" (MAYBE null splicing macro
RDLST3: JSP TT,RDCHAR ; causes return to here with nothing accumulated).
RDLS3Y: PUSHJ P,RDOBJ
TLZE T,4
JRST RDLST4 ;OJBECT JUST READ WAS PRECEEDED BY A DOT
MOVEM B,AR2A
TLZE T,20000
JRST RDLS3D ;MACRO-PRODUCED OBJ RETURNED
TLNE T,200000
JRST RDHNK1 ;CONTINUING WITH A HUNK
TLNE T,24060 ;EXIT IF NO OBJECT READ
JRST RDLST1
RDLSX: TLNN B,RS%RP
LERR RDRM6 ;BLAST, MISSING ")"
SOS BFPRDP
POP P,A
TLZE T,200000
PUSHJ P,MAKHUNK
POP P,T
RDLSX1: MOVSI B,RS%<BRK+WSP> ;THROWAWAY BREAK-CHARACTER
TLO T,4000
POPJ P,
RDLS3D: TLNN T,4060 ;MACRO-OBJECT RETURNED WITHIN A LIST, HENCE
RMCER: LERR RDRM5 ;READ MACRO CONTEXT ERROR
TLNN T,1000
JRST RDLST1 ;NORMAL MACRO OBJECT
TLZ T,-1#200002 ;DONT FLUSH "HUNK" OR "1ST OBJ OF LIST" BITS
JUMPE A,RDLST0 ;NIL is just ignored
MOVEI TT,(A) ;Let's check this out, is this an atom?
LSH TT,-SEGLOG ;Get the segment number
SKIPL ST(TT) ;Is it a CARCDRable?
JRST RDSMER ; yes, let him know he lost
JSP TT,RDLSTA
JSP AR1,RLAST ;SPLICING MACRO OBJECT
HRLM A,(P)
JRST RDLST0
RDLST4: JUMPN T,RDLS4A ;OJBECT JUST READ WAS PRECEEDED BY A DOT
SKIPN VMAKHUNK
JRST ER2
TLO T,200000 ; BUT NOTHING AFTER THE DOT EXCEPT A %RP
JRST RDLSX
RDLS4A: TLNE T,2 ;*** DOT PAIR ***
JRST ER2
TLZ T,60
TLNE T,200000 ;COMBINATION OF "HUNK" AND "DOT" BITS ON
JRST RDLSX ; WHEN EXITING FROM RDOBJ MEANS ".)" CASE
MOVS TT,(P)
HRRM A,(TT)
TLZE T,20000
TLZN T,1000 ;OJBECT IMMEDIATELY FOLLOWING "DOT" IS
JRST RDLS4B
MOVE AR2A,RCT0+". ;MACRO-PRODUCED SPLICING OBJECT AS "DOT"+OBJ
JUMPE A,RDLST0 ;THROW AWAY IF RETURN ()
HRRZ AR2A,(A)
JUMPN AR2A,ER2
HLRZ A,(A)
HRRM A,(TT)
RDLS4B: PUSHJ P,RDSKWH ;SCAN CHARS FOLLOWING OBJ TO RIGHT OF DOT
JRST RDLSX ; HOPEFULLY, NEXT INTERESTING ONE IS A %RP
TLNE B,RS%DOT
JRST RDHNK ;IF ITS ANOTHER DOT, THEN WE HAVE A HUNK
TLNE B,RS%MAC
NWTNN B,RS.ALT
JRST ER2
PUSHJ P,RDOBJM ;SPLICING MACRO AFTER "DOT"+OBJECT
JUMPE A,RDLS4B ;THROW AWAY IF RETURN ()
JRST RDSME2 ;Otherwise, it's gotta be an error!
RDHNK: SKIPN VMAKHUNK
JRST ER2
TLO T,200000 ;BEGIN NOTICING THAT THIS IS A HUNK
MOVS TT,(P)
HRRZ A,(TT) ;UNDO THE CDR OF THE CELL
PUSHJ P,NCONS
HRRM A,(TT)
HRLM A,(P)
PUSHJ P,RDSKWX ;SCAN CHARS FOLLOWING OBJ TO RIGHT OF DOT
JRST RDLSX ; HOPEFULLY, NEXT INTERESTING ONE IS A %RP
JRST RDHNKA
RDSKWH: TLNE B,RS%RP ;RIGHT PAREN? THEN EXIT NORMALLY
POPJ P,
NWTN E,B,WTH
JRST POPJ1 ;EXIT BY SKIPPING IF "INTERESTING" CHAR IS NOT PARENS
RDSKWX: JSP TT,RDCHAR ;IF CHAR IS UNWORTHY, THEN FLUSH IT AND TRY AGAIN
JRST RDSKWH
RDOBM2: PUSHJ P,RDOBJM ;Get the object.
TLNE T,4 ;Was this proceeded by a .?
TLNN T,1000 ; And splicing?
POPJ P, ; NO
JRST RDSMCK ;Yes, do error checking and return
RDOBJM: TLO T,20000 ;*** MACRO CHARACTER ***
NWTNE B,RS.ALT ;SPLICING?
TLO T,1000 ;SPLICING MACRO
PUSH P,T
PUSH FXP,BFPRDP
NW% CALLF 0,(B) ;MACRO CHARACTER HAS LINK IN RH OF
IFN NEWRD,[
LDB D, [001100,,B]
PUSHJ P, GETMAC
HRRZ A, (A)
CALLF 0, (A)
] ;END OF IFN NEWRD
POP FXP,BFPRDP
JSP T,RDIBGT ;RE-CACHE THE IBASE DATA
JSP T,RSXST ;RE-CACHE THE READTABLE DATA
POP P,T
JRST RDLSX1
RDSMCK: JUMPE A,CPOPJ ;NIL is always OK
PUSH FXP,T ;Temp
MOVEI T,(A) ;Copy
LSH T,-SEGLOG ;Get the type bits
SKIPL ST(T) ;Can it be CARCDRed?
JRST RDSME1 ; No, barf about it (ILLEGAL RETURN VALUE FROM ...)
POP FXP,T
HRRZ B,(A) ;CDR the frob
JUMPN B,RDSMER ; Error if more than one
POPJ P,
RDALPH: TLO T,20 ;*** PNAME ATOM ***
SETOM LPNF
RDA0: JSP TT,IRDA1
RDA1: IDPB B,C
RDA3: JSP TT,RDCHAR
SOJG D,RDA1
MOVEM B,AR2A
PUSHJ FXP,RDA4
MOVE B,AR2A
JRST RDA0
RDA4: PUSHJ P,PNCONS ;ADDS ANOTHER SEGMENT TO A LONG PNAME LIST
AOSN LPNF
PUSH P,R70
MOVE B,(P)
EXCH A,B
PUSHJ P,.NCONC
MOVEM A,(P)
POPJ FXP,
RLAST: JUMPE A,(AR1)
RLAST1: HRRZ TT,(A)
JUMPE TT,(AR1)
LSH TT,-SEGLOG
SKIPL ST(TT)
JRST RMCER
HRRZ A,(A)
JRST RLAST1
RDCHO1: MOVE AR1,B
NWTNN B,RS.PNT
JRST RDCHO3
JSP TT,RDCHAR ;. AS SCO ALSO HAS DECIMAL PT. SYNTAX
NWTNE B,RS.DIG
JRST RDOBJ5 ;WILL TAKE AS FLOTING PT. NUM
NWTN N,B,WTH ;SKIP IF WORTHY CHAR
JRST RDCHO3 ;CAN TOSS OUT NEXT UNWORTHY CHAR
RDCHO4: PUSH FXP,B ;OTHERWISE, SAVE NEXT CHAR AS IF IT WERE IMPORTANT BREAK CHAR
SKIPA C,[RDCHO2]
RDCHO3: MOVEI C,RDLSX1
MOVE B,AR1
PUSH P,C
RDCHO: JSP TT,IRDA ;*** SINGLE CHARA OBJECT ***
SETZM PNBUF
IDPB B,C
JRST RINTERN
RDCHO2: POP FXP,B ;AFTER MAKING UP . AS SCO,
MOVEM B,RDBKC ;MAKE NEXT CHAR LOOK LIKE
TLO T,20 ;IMPORTANT BREAK CHAR
POPJ P,
IFN BIGNUM,[
RD10OV: TLO T,40000
JSP A,RDRGSV
PUSHJ P,C1CONS
MOVE AR1,A
JRST RDBG1A
RDIBOV: TLO T,100000
JSP A,RDRGSV
PUSHJ P,C1CONS
MOVE AR2A,A
JRST RDBGIA
RDBG10: TLNE T,3000
JRST RDNUMD ;GETTING EXPONENT MODIFIER
JSP A,RDRGSV
RDBG1A: MOVE T,AR1
MOVEI D,-"0(B)
NW$ ANDI D,177
MOVEI TT,10.
PUSHJ P,.TM.PL
MOVE T,TSAVE
TLNE T,100000
JRST RDBGIA
JSP A,RDRGRS
JRST RDNUMB
RDBGIB: TLNE T,3000
JRST RDNUMB ;GETTING EXPONENT MODIFIER
JSP A,RDRGSV
RDBGIA: MOVE T,AR2A
MOVE TT,RDIBS
MOVEI D,-"0(B)
NW$ ANDI D,177
PUSHJ P,.TM.PL
JSP A,RDRGRS
JRST RDNUM1
.RDMULP: SKIPA T,A
.TIMER: MOVEI D,0 ;T IS LIST OF DIGITS, TT IS MULTIPLIER,
.TM.PL: HLRZ A,(T) ;D IS CARRY.
MOVE R,(A)
MUL R,TT
ADD R+1,D
TLZE R+1,400000
AOS R
MOVEM R+1,(A)
MOVE D,R
HRRZ A,(T)
JUMPN A,.RDMULP
JUMPE D,CPOPJ
MOVE TT,D
PUSHJ P,C1CONS
HRRM A,(T)
POPJ P,
;;; IFN BIGNUM
RDRGSV: MOVEM T,TSAVE
MOVEM D,DSAVE
MOVEM R,RSAVE
MOVEM F,FSAVE
JRST (A)
RDRGRS: MOVE T,TSAVE
MOVE D,DSAVE
MOVE R,RSAVE
MOVE F,FSAVE
JRST (A)
RDEXOF: TLO T,100000
PUSH FXP,TT+1
PUSHJ P,C1CONS
MOVE B,A
POP FXP,TT
PUSHJ P,C1CONS
HRRM B,(A)
TLNE T,400
TLO A,-1
JRST RX1
RDEX3: PUSH P,A
MOVEM T,TSAVE
MOVE T,A
MOVE TT,RDIBS
PUSHJ P,.TIMER
MOVE T,TSAVE
POP P,A
JRST RX1
RDBIGN: TLNE T,3000
JRST RDBGEX
HRLI A,0 ;CREATE BIGNUM SIGN
TLNE T,400
TLO A,-1
TLNE T,100000
TLNE T,300
JRST RDCBG
HRR A,AR2A
RDBIGM: PUSHJ P,BNTRSZ
MOVE TT,[400000,,0]
JRST RDFX1
PUSHJ P,BNCONS
MOVE B,RDBKC
POPJ P,
;;; IFN BIGNUM
RDBGEX: TLNE T,200
JRST RDBXFL
MOVEI D,1
TLNE T,2000
JRST RDBFSH
JUMPLE TT,RDBGXM
IMUL D,RDIBS ;<BIGNUM>^(TT)
SOJG TT,.-1
RDBGXM: MOVE TT,D
MOVEM T,TSAVE
HRRZ T,AR2A
PUSHJ P,.TIMER
MOVE A,AR2A
MOVE T,TSAVE
JRST RDBIGM
RDBFSH: LSH D,(TT) ;<BIGNUM>_(TT)
JRST RDBGXM
RDBXFL: ADD TT,RDDSV
SUBI TT,BYTSWD*LPNBUF
MOVE A,AR2A
JRST RDCBG1
RDCBG: TLNN T,300
JRST RDNM2B
HRR A,AR1
TLNN T,200
JRST RDBIGM
HRREI TT,-BYTSWD*LPNBUF-1(D)
RDCBG1: PUSH FXP,TT ;THIS IS THE POWER-OF-TEN EXPONENT
MOVE TT,A
PUSHJ P,FLBIGZ
POP FXP,R
JFCL 8.,RDNMER
JUMPGE A,RDFL3A
DFN TT,TT+1
JRST RDFL3A
RDNM2B: TLZ T,140000 ;A BIGNUMBER BASE 10. WAS REALLY A REGNUM
JRST RDNM2A ;BASE IBASE, BUT BIG ENOUGH TO OVFLO BASE 10. CALC
] ;END OF IFN BIGNUM
SUBTTL READER SINGLE-CHARACTER FILTER
;;; ***** READ ONE CHARACTER (FOR READ) *****
RDCHAR: PUSHJ P,@RDINCH
MOVE B,@RSXTB
RDCH1:
NW% JUMPGE B,(TT)
NW$ NWTNE B,RS%BRK
NW$ JRST (TT)
NWTN E,B,[<SQX+SCO+WSP+LP+DOT+RP+MAC+PNT>]
JRST RDBK ;BREAKING CHAR FOUND
NWTN N,B,WTH
JRST RDCHAR ;WORTHLESS CHAR
TLNN B,RS%SLS
JRST (TT) ;ALPHABETIC CHAR WITH BREAK BIT SOMEHOW SET
PUSHJ P,@RDINCH ;/
NW% HRR B,A ;PUT EXTENDED ALPHABETIC SYNTAX ON THIS CHAR
NW% HRLI B,2
NW$ MOVEI B,RS.XLT(A)
JRST (TT)
RDBK: MOVEM B,RDBKC
TLNN T,60
JRST (TT)
TLNN T,20 ;From here down, we're reading literal token
JRST RDNUM4
PUSHJ FXP,RDAEND ;Symbol
IFN USELESS, SKIPE RDROMP
IFN USELESS, PUSHJ P,RDROM
PUSHJ P,RINTERN
RDNMX: MOVE B,RDBKC
POPJ P,
RDNUM4: TLNN T,300
TLNN B,200
JRST RDNM4A
PUSHJ P,@RDINCH ;. FOUND
MOVE B,@RSXTB
NWTN N,B,SEE
JRST .-3 ;CONTROL-CHARS ARE IGNORED
MOVEI D,BYTSWD*LPNBUF+1
NWTNE B,RS.DIG
TLOA T,200
TLO T,100
JRST RDCH1
RDNM4A: TLNE B,RS.SGN
TLNN T,3000
JRST RDNMF ;TERMINATES A NUMBER TOKEN, UNLESS A SIGN IS
JRST (TT) ;FOLLOWING AN EXPONENTIATOR
IFN USELESS,[
RDROM: SKIPGE LPNF
SKIPN PNBUF
POPJ P,
MOVEI D,(C)
CAIL D,PNBUF+LPNBUF-1 ;TOO BIG TO DO ANOTHER ILDB ?
POPJ P,
PUSH FXP,C
SETZB TT,D
IDPB D,C
MOVE C,[440700,,PNBUF]
RDROM1: ILDB F,C
JUMPN F,RDROM2
PUSH FXP,T
JSP T,FXCONS
POP FXP,T
SUB FXP,R70+1
JRST POPJ1
RDROM2: SETZ R,
IRP X,,[M,D,C,L,X,V,I]N,,[1000.,500.,100.,50.,10.,5,1]
CAIN F,"X
MOVEI R,N
TERMIN
JUMPE R,RDROM7
ADDI TT,(R)
CAIG R,(D)
JRST RDROM3
REPEAT 2, SUBI TT,(D)
RDROM3: MOVEI D,(R)
JRST RDROM1
RDROM7: POP FXP,C
POPJ P,
] ;END OF IFN USELESS
RDAEND: LSHC B,6
DPB B,[360600,,C]
SETZM B
LSHC B,-6
DPB B,C
SKIPGE LPNF
POPJ FXP,
PUSHJ P,PNCONS ;DESTROYS TT
POP P,B
EXCH A,B
PUSHJ P,.NCONC
POPJ FXP,
IRDA: SETOM LPNF ;INITIALIZE FOR READING PNAME-TYPE ATOM
IRDA1: MOVE C,PNBP
MOVEI D,BYTSWD*LPNBUF
JRST (TT)
RDIN: PUSHJ FXP,SAV5M1
PUSHJ P,SAVX5
PUSHJ P,@TYIMAN
MOVEI A,(TT) ;***** GRUMBLE *****
PUSHJ FXP,RST5M1
JRST RSTX5
;;;; ERROR MSGS ETC
ER2: LERR RDRM4 ;CONTEXT ERROR WITH DOT NOTATION -READ
ER3: LERR RDRM7 ;BLAST?
RDNMER: LERR RDRM8 ;NUMERIC OVERFLOW
RDSME2: LER3 RDRM9 ;MULTIPLE SPLICING MACROS RETURNED NON-NIL AFTER "."
RDSME1: POP FXP,T
RDSMER: LER3 RDRM11 ;ILLEGAL RETURN VALUE FROM SPLICING MACR
SUBTTL BUILT-IN MACRO CHARACTER PROCESSORS
;;; SINGLE QUOTE PROCESSOR:
;;; 'FOO => (QUOTE FOO)
RDQTE: MOVEI T,0
PUSHJ P,OREAD ;FOR THE WHITE SINGLE-QUOTE HAC
PUSHJ P,NCONS
MOVEI B,QQUOTE
JRST XCONS
;;; SEMICOLON COMMENT PROCESSOR: (SPLICING)
;;; ; -- ANYTHING -- <CR> => NIL, HENCE IGNORED
RDSEMI: PUSHJ P,RDSMI0
JUMPE A,CPOPJ ;OK, FOUND CR
JRST RDLNER
RDSMI0: PUSH P,[,,-1]
MOVNI T,1
JSP D,INCALL
QRDSEMI ;THIS SHOULD NEVER [!!] BE USED
RDSMI1: PUSHJ P,TYI
SA$ CAIE A,%TXCTL+"M
SA$ CAIN A,%TXCTL+"m
SA$ JRST FALSE ;YET ANOTHER GODDAM SAIL CHARACTER SET SCREWUP
CAIE A,15 ;CR
JRST RDSMI1
JRST FALSE
;;; VERTICAL BAR PROCESSOR:
;;; |ANYTHING| => /A/N/Y/T/H/I/N/G
;;; I.E. IT IS A SUPER SYMBOL QUOTER (ALMOST LIKE ""'S)
RDVBAR: SKIPA T,["|]
RDDBLQ: MOVEI T,""
PUSH FXP,T
PUSH FXP,R70 ;WATCH OUT - THESE SLOTS USED BY RDVB2
PUSHJ P,RDVB0
SUB FXP,R70+1
POP FXP,T
CAIN A,-1
JRST EOFER
CAIN T,"|
JRST RINTERN
PUSHJ P,PNGNK1 ;FOR "
MOVE AR1,A
JSP T,.SET ;HAPPILY, THE RESULT IS ALSO IN A
RDVB5: MOVEI C,Q%ISM
MOVEI B,TRUTH
PUSHJ P,PUTPROP
MOVE A,AR1
POPJ P,
RDVB0: PUSH P,[,,-1]
MOVNI T,1
JSP D,INCALL
QRDVBAR ;THIS SHOULD NEVER [!!] BE USED
JSP T,GTRDTB
MOVEI T,RDVB3
PUSHJ FXP,MKNR6C
POPJ P,
RDVB2: SETOM -1(FXP)
RDVB3: PUSH FXP,D
PUSHJ P,TYI
POP FXP,D
CAIN TT,203 ;RARE CASE WHEN | IS CALLED FROM WITHIN
JRST RDVB3 ; A READLIST - MAY SEE A PSEUDO-SPACE.
SA$ CAIE TT,%TXCTL+"M
SA$ CAIN TT,%TXCTL+"m
SA$ MOVEI TT,15
CAIN TT,^J
SKIPN -1(FXP)
JRST RDVB4
SETZM -1(FXP)
JRST RDVB3
RDVB4: SETZM -1(FXP)
CAMN TT,-2(FXP)
POPJ P,
SKIPGE T,@TTSAR(AR2A)
TLNN T,2000
JRST POPJ1
PUSH FXP,D
PUSHJ P,TYI
POP FXP,D
CAIN TT,^M
SETOM -1(FXP)
JRST POPJ1
IFN ITS+SAIL,[
;;; SPLICING MACRO CHARACTER FUNCTIONS FOR ^Q AND ^S.
CTRLQ: MOVEI A,TRUTH
MOVEM A,TAPRED
JRST FALSE
CTRLS: SETZM TTYOFF
JRST TERPRI
] ;END OF IFN ITS+SAIL
SUBTTL NEWIO TTY PRESCAN, RUBOUT HANDLER, AND READLINE
;;; INITIAL TTY CHARACTER BUFFERING ROUTINE.
;;; BUFFERS UP A LIST OF CHARACTERS FOR TTY INPUT.
;;; HANDLES ALL APPROPRIATE RUBOUT PROCESSING.
;;; ARGUMENTS ARE A TTY INPUT FILE ARRAY IN A,
;;; THE FUNCTION TO BUFFER FOR IN B (E.G. QOREAD),
;;; AND THE COUNT OF UNMATCHED LEFT PARENS IN C.
;;; RUBOUT ECHOING IS PERFORMED ON THE ASSOCIATED OUTPUT
;;; TTY, IF ANY. HAIRY ERASING RUBOUT IS DONE FOR DISPLAYS.
;;; NO RUBOUT HACKING IS DONE IF THERE IS NO ECHO FILE.
;;; THESE ARE COMPATIBLE WITH THE ITS DEFINITIONS:
%TXMTA==:400 ;META BIT
%TXCTL==:200 ;CONTROL BIT
%TXASC==:177 ;ASCII CODE
TTYBUF:
IFN SFA,[
JSP TT,AFOSP
JFCL
JRST .+2
JRST [ CALLF 3,QLIST
HRRZ C,(A)
HLRZ A,(A)
MOVEI B,QTTYBUF
JRST ISTCSH ]
] ;END OF IFN SFA
JSP T,SPECBIND
VECHOFILES
0 A,VINFILE
CAIN A,TRUTH
HRRZ A,V%TYI
PUSH FXP,(C)
CAIE C,QOREAD
SETZM (FXP)
JSP T,GTRDTB ;GET READTABLE;AR2A 4.9 = USEFULP
CAIN B,Q%READLINE ;AR2A 4.9 => USEFULP
TLO AR2A,200000 ;AR2A 4.8 => READLINE
MOVEI TT,LRCT-2 ;AR2A 4.7 => (STATUS TTYREAD) = T
HLRZ C,@TTSAR(AR2A)
SKIPE C
TLO AR2A,100000
MOVE C,A
MOVEI TT,FT.CNS ;GET ASSOCIATED OUTPUT TTY
SKIPE C,@TTSAR(A) ; (THE SIGN BIT TELLS TYO6 THIS IS ONE FILE)
PUSHJ P,TTYBRC ;MAYBE GET CURCOR POSITION IN D
PUSH FXP,D
PUSH FXP,-1(FXP) ;PARENS COUNT
MOVEI TT,F.MODE
MOVE R,@TTSAR(A) ;GET INPUT FILE MODE BITS
PUSH FXP,R
PUSH FXP,XC-1 ;PUSH -1 (NOT IN STRING YET)
SETZ B, ;B HOLDS LIST OF CHARACTERS
HRRZS BFPRDP ;WE WANT NO CLEVERNESS FROM $DEVICE
;STATE OF THE WORLD:
; B HAS LIST OF BUFFERED CHARS (IN REVERSE ORDER)
; C HAS TTY OUTPUT FILE ARRAY
; AR2A HAS READTABLE
; 4.9 => USEFUL CHAR SEEN
; 4.8 => READLINE INSTEAD OF READ
; 4.7 => (STATUS TTYREAD) = T
; VINFILE HAS TTY INPUT FILE ARRAY
; FXP: STRING TERMINATOR CHAR (-1 IF NOT IN STRING)
; MODE BITS FOR INPUT FILE
; PARENTHESIS COUNT
; SAVED CURSOR POSITION
; ORIGINAL PARENS COUNT
TTYB1: PUSHJ P,TTYBCH ;GET A CHARACTER
MOVE D,@TTSAR(AR2A) ;GET READTABLE SYNTAX
MOVE R,-1(FXP) ;GET MODE BITS
IFN SAIL,[
CAIE TT,%TXCTL+"M
CAIN TT,%TXCTL+"m
JRST TTYB1E
] ;END IFN SAIL
CAIE TT,^M
JRST TTYB7
TTYB1E: TLNE AR2A,200000 ;CR TERMINATES READLINE
JRST TTYB9
TLNN R,FBT<LN> ;SKIP IF LINE MODE
JRST TTYB2
MOVEI TT,203 ;PSEUDO-SPACE
TLNN AR2A,200000 ;SKIP IF HACKING A STRING
JSP R,TTYPSH ;ELSE PUSH CHAR ONTO BUFFER
SA% MOVEI TT,^M
SA$ MOVEI TT,%TXCTL+"M
JRST TTYB9 ;ALL DONE
TTYB7:
IFN SAIL,[
CAIE TT,%TXCTL+"K
CAIN TT,%TXCTL+"k ;LOWER CASE K
JRST TTYB7E
; TLNN R,FBT<FU>
] ;END OF IFN SAIL
20$ CAIE TT,^R ;FOR A ^R (ON TWENEX) WE RETYPE THE BUFFER
CAIN TT,^K ;FOR A ^K, WE TERPRI AND RETYPE THE BUFFER
JRST TTYB7E
TTYB7F:
IFN SAIL,[
CAIE TT,%TXCTL+"L
CAIN TT,%TXCTL+"l ;LOWER CASE L
JRST TTYB7E
; TLNN R,FBT<FU>
] ;END OF IFN SAIL
CAIE TT,^L ;RPUSH FXP FOR ^L, WE CLEAR THE SCREEN,
JRST TTYB2 ; THEN RETYPE THE BUFFER
SKIPN AR1,C
JRST TTYB1
MOVEI TT,F.MODE
MOVE R,@TTSAR(AR1)
TLNN R,FBT<CP> ;IF WE CAN'T CLEAR THE SCREEN,
JRST TTYB7G ; WE JUST MAKE LIKE ^K
PUSHJ P,CLRSRN
TTYB7N: PUSHJ P,TTYBRC ;READ THE TTY CURSOR POSITION
MOVEM D,-3(FXP)
PUSHJ P,TTYBLT ;ZAP OUT TTY BUFFER
JRST TTYB1
TTYB7E: SKIPN AR1,C
JRST TTYB1
TTYB7G: PUSHJ P,ITERPRI
JRST TTYB7N
CLRSRN: ;CLEAR THE "SCREEN"
IFN ITS\D20,[
MOVEI D,"C
JRST CNPCOD
] ;END OF IFN ITS\D20
IFN D10,[
PUSH P,A ;SAVE A OVER TYO
MOVEI A,14 ;^L
PUSHJ P,$TYO ;AT THIS POINT, THE FILE MUST BE A TTY
JRST POPAJ
];END IFN D10
IFE ITS\D20\D10, WARN [SAY, YOU WILL LOSE WITH ITS\D20\D10 = 0]
TTYB2: TLNN AR2A,200000 ;READLINE IGNORES SLASHES
TLNN D,2000 .SEE SYNTAX ;SLASH
JRST TTYB4
JSP R,TTYPSH
PUSHJ P,TTYBCH
TLO TT,400000 ;SLASHIFIED CHAR
TTYB3: TLO AR2A,400000 ;USEFUL FROB SEEN
TTYB3A: JSP R,TTYPSH
JRST TTYB1
TTYB4: TLNE D,1000 .SEE SYNTAX ;RUBOUT
TLNE D,40 .SEE SYNTAX ;NOT SECOND CHOICE
JRST TTYB5
JUMPN B,TTYB4C
HRRZ T,BFPRDP
JUMPE T,TTYB9J ;RETURN TO CALLER FOR EOF
SKIPE AR1,C ;OOPS! INSIDE READ ALREADY!
PUSHJ P,ITERPRI ; WE MUST SIMPLY TERPRI
JRST TTYB1 ; (IF POSSIBLE) AND TRY IT AGAIN
TTYB4C: PUSHJ P,RUB1CH ;RUB OUT CHAR
SKIPL TT,(A) ;SKIP IF CHAR WAS SLASHIFIED
JRST TTYB4G
PUSHJ P,RUB1CH ;RUB OUT SLASH TOO
JRST TTYB1
RUB1CH: HLRZ A,(B) ;DELETE CHAR FROM BUFFERED LIST
HRRZ B,(B)
JUMPE C,CPOPJ ;THAT'S IT IF NO ECHO FILE
PUSH P,A
HRRZ A,(A) ;GET CHARACTER IN A
MOVEI AR1,(C)
PUSHJ P,RUB1C1
JRST POPAJ ;NORMAL RETURN: DONE IT
20$ JRST RUB2CH ;SINGLE SKIP: RETYPE ON "DUMB" OPERATING SYSTEM
20% JFCL ;CAN'T GET HERE ON ITS
IFN ITS\D20, PUSHJ P,RSTCUR ;MUST RETYPE WHOLE STRING IN PLACE
PUSHJ P,TTYBLT
IFN ITS\D20, PUSHJ P,CNPL
JRST POPAJ
IFN D20,[
RUB2CH: PUSHJ P,TTYBLT ;RETYPE INPUT
JRST POPAJ
] ;END IFN D20
TTYB4G: SKIPL (FXP) ;SKIP UNLESS IN STRING
JRST TTYB4J
TLNE TT,100000
JRST TTYB4M
MOVE D,@TTSAR(AR2A) ;GET CHARACTER SYNTAX
TLNE D,40000 .SEE SYNTAX ;OPEN PAREN
SOS -2(FXP)
TLNN D,10000 .SEE SYNTAX ;CLOSE PAREN
JRST TTYB1
SKIPLE -2(FXP)
AOS -2(FXP)
JRST TTYB1
TTYB4J: TLNE TT,200000 ;RUBBED OUT BACK OUT OF STRING
SETOM (FXP)
JRST TTYB1
TTYB4M: HRRZM TT,(FXP) ;RUBBED OUT BACK INTO A STRING
JRST TTYB1
TTYB5: TLNE AR2A,200000 ;GO BACK AROUND IF READLINE
JRST TTYB3A
SKIPGE R,(FXP) ;SKIP IF IN STRING
JRST TTYB5H
CAIE R,(TT)
JRST TTYB3A
TLO TT,100000 ;MARK AS STRING END
SETOM (FXP)
JRST TTYB3A
TTYB5H: TLNE D,1000 .SEE SYNTAX ;FORCE FEED
TLNN D,40 .SEE SYNTAX ;SECOND CHOICE
JRST TTYB5K
JSP R,TTYPSH
JRST TTYB9A
TTYB5K: TLNN D,100000 .SEE SYNTAX ;SPACE
JRST TTYB6
TTYB5M: JSP T,TTYATM
JRST TTYB3A
TTYB6: TLNN D,200000 .SEE SYNTAX ;SINGLE CHAR OBJECT
JRST TTYB6C
TLO AR2A,400000 ;USEFUL THING SEEN
JRST TTYB5M
TTYB6C: TLNN D,4000
JRST TTYB6J ;NOT A MACRO CHAR
HRRZ R,VTSCSR ; ((#/; . #\CR) (#/| . #/|) (#/" . #/"))
MOVS F,(R)
MOVS T,(F)
CAMN TT,(T)
JRST .+4
HLRZ R,F
JUMPN R,.-5
JRST TTYB6J ;NOT A STRING-LIKE MACRO CHAR
MOVSS T
MOVE F,(T)
TLO AR2A,400000 ;USEFUL FROB SEEN
TLO TT,200000 ;STRING BEGIN
MOVEM F,(FXP)
JRST TTYB3
TTYB6J: TLNN D,40000 .SEE SYNTAX ;OPEN PAREN
JRST TTYB6Q
AOS -2(FXP)
JRST TTYB3
TTYB6Q: TLNN D,10000 .SEE SYNTAX ;CLOSE PAREN
JRST TTYB8
JSP T,TTYATM
SOSLE T,-2(FXP)
JRST TTYB3
JUMPE T,TTYB9 ;AHA, PARENS BALANCE
TLNE AR2A,400000 ;IF NOTHING USEFUL HAS COME IN SO FAR, THEN
JRST TTYB9
SETZM -2(FXP) ;THROW AWAY A STRAY TOP-LEVEL RIGHT PARENS
JRST TTYB3A
TTYB9: JSP R,TTYPSH
TLNN AR2A,100000
JRST TTYB1 ;ONLY FORCE-FEED ENDS TTYSCAN
TTYB9A: JUMPE C,TTYB9B
PUSHJ P,TTYBRC
MOVEI TT,AT.LNN ;UPDATE LINENUM AND CHARPOS
HLRZM D,@TTSAR(C) ; OF ASSOCIATED OUTPUT FILE
MOVEI TT,AT.CHS
HRRZM D,@TTSAR(C)
TTYB9B: MOVEI A,(B)
PUSHJ P,NREVERSE
MOVEI B,(A)
MOVEI C,(A)
TTYB9D: JUMPE C,TTYB9J
HLRZ A,(C)
MOVE TT,(A)
TLZE TT,-1
JSP T,FXCONS
HRLM A,(C)
HRRZ C,(C)
JRST TTYB9D
TTYB9J: POPI FXP,5
MOVEI A,(B)
JRST UNBIND
TTYB8: TLNE D,277237 .SEE SYNTAX ;SKIP IF NOT WORTHY CHAR
JRST TTYB3
JRST TTYB3A
TTYBRC: HRROS AR1,C
TTYBR1: MOVE TT,TTSAR(AR1) ;GET CURSOR POSITION OF FILE FROM (AR1) INTO D
PUSHJ P,IFORCE
IFE ITS\D20, JRST TTYBR2 ;? WHAT TO DO?
IFN ITS\D20,[
MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1) ;C HAS OUTPUT FILE FOR ECHOING
PUSHJ FLP,RCPOS
TLNE F,FBT<EC>
MOVE D,R ;MAYBE NEED ECHO AREA CURSOR
POPJ P,
] ;END OF IFN ITS\D20
TTYBR2: SETZ D,
POPJ P,
TTYPSH:
IFN 0,[
ANDI TT,%TXCTL+%TXASC ;? FOLD CHARACTER DOWN TO 7 BITS
TRZN TT,%TXCTL
JRST TTYPS1
CAIE TT,177
TRZ TT,140
TTYPS1:
] ;END OF IFN 0
JSP T,FXCONS ;PUSH CHAR IN TT ON FRONT
PUSHJ P,CONS ; OF LIST OF BUFFERED CHARS
MOVEI B,(A)
JRST (R)
TTYATM: JUMPGE AR2A,(T) ;DECIDE WHETHER WE MAY HAVE
MOVE R,-1(FXP) ; TERMINATED A TOP LEVEL ATOM,
SKIPG -2(FXP) ; AND IF SO GO TO TTYB9 AND OUT
TLNE R,FBT<LN> ;WE HAVE *NOT* TERMINATED IF:
JRST (T) ; NO USEFUL CHARS SEEN YET
TLNN AR2A,100000 ; (STATUS TTYREAD) = NIL
JRST (T) ; OPEN PARENS ARE HANGING
JRST TTYB9 ; TTY INPUT IS IN LINE MODE
TTYBCH: PUSHJ P,$DEVICE ;GOBBLE A CHARACTER
IFN ITS,[
ANDI TT,%TXCTL+%TXASC ;FOLD CHARACTER TO 7 BITS
TRZN TT,%TXCTL
POPJ P,
CAIE TT,177
TRZ TT,140
MOVEI D,(TT) ;ATTEMPT TO FLUSH INTERRUPT CHARS
ROT TT,-1
ADDI TT,FB.BUF ;REALLY SHOULD BE MORE CLEVER
HRRZ AR1,VINFILE
HLRZ R,@TTSAR(AR1)
SKIPGE TT
HRRZ R,@TTSAR(AR1)
JUMPN R,TTYBCH
MOVEI TT,(D)
] ;END OF IFN ITS
POPJ P,
TTYBLT: SKIPN AR1,C
POPJ P,
MOVEI A,(B) ;TYPE OUT ALL BUFFERED CHARS
PUSHJ P,NREVERSE ; ONTO THE ECHO OUTPUT FILE
MOVEI B,(A)
SKIPG -4(FXP) ;IF WE ENTERED WITH HANGING
JRST TTYBL1 ; PARENS, PRINT THEM
PUSH FXP,-4(FXP)
TTYBL4: MOVEI TT,"(
PUSHJ P,TYOFIL
SOSLE (FXP)
JRST TTYBL4
SUB FXP,R70+1
MOVEI TT,40
PUSHJ P,TYOFIL
TTYBL1: JUMPE B,TTYBL2 ;ECHO ALL CHARS TO ECHO TTY
HLRZ C,(B)
HRRZ TT,(C)
PUSHJ P,TYOFIL
HRRZ B,(B)
JRST TTYBL1
TTYBL2: PUSHJ P,NREVERSE
MOVEI B,(A) ;RESTORE BACKWARDS LIST OF CHARS
MOVE C,AR1 ;RESTORE C (NREVERSE CLOBBERED)
POPJ P,
RUBOUT: MOVEI D,QRUBOUT ;LSUBR (1 . 2)
CAMGE T,XC-2
JRST WNALOSE ;MORE THAN 2 ARGS
JUMPE T,WNALOSE ; 0 ARGS
CAME T,XC-2
SKIPA AR1,V%TYO
POP P,AR1
POP P,A
JSP F,TYOARG
IFN SFA,[
JSP TT,XFOSP
JRST RUBOU1
JRST RUBOU1
MOVEI T,SO.RUB
MOVEI TT,SR.WOM
TDNN T,@TTSAR(AR1) ;CAN IT DO THE RUBOUT OPERATION?
JRST FALSE ; NO, SO JUST RETURN ()
MOVE C,A
JRST ISTCAL
RUBOU1:] ;END IFN SFA
MOVE A,(A) ;RE-FETCH NUMERICAL ASCII VALUE
PUSHJ P,TOFLOK
PUSHJ P,RUB1C1
JRST UNLKTRUE
JFCL ;DOUBLE SKIP LIKE SINGLE SKIP HERE
SETZ A,
UNLKPOPJ
;;; ROUTINE WHICH ATTEMPTS TO RUB OUT A CHARACTER ON A TTY.
;;; SKIPS ON *FAILURE* TO RUB IT OUT.
;;; OUTPUT TTY FILE ARRAY MUST BE IN AR1.
RUB1C1: MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
TLNE F,FBT<SE> ;IF CAN'T SELECTIVELY ERASE
TLNN F,FBT<CP> ; AND MOVE CURSOR AROUND FREELY,
20% JRST TYOFA ; MERELY ECHO RUBBED-OUT CHAR
20$ JRST RUB1C2
IFE ITS\D20, HALT
IFN ITS\D20,[
CAIN A,177 ;RUBOUT DOESN'T PRINT, HENCE NEEDN'T KILL
POPJ P,
MOVEI T,1
CAILE A,^_ ;CHARS FROM 40 TO 176 ARE ONE
JRST RUB1C3 ; POSITION WIDE, SO BACK UP AND ERASE
CAIN A,^I ;TABS ARE VARIABLE - MUST RETYPE
JRST RUB1C4
CAIN A,^J ;LINE FEED IS DOWNWARD MOTION -
JRST CNPU ; ERASE BY MOVING UP
CAIN A,^H ;BACKSPACE IS ERASED BY
JRST CNPF ; MOVING FORWARD
CAIE A,^M ;FOR CR, DON'T KNOW LENGTH OF PREVIOUS LINE
CAIN A,^_ ;FOR ^_, MAY OR MAY NOT HAVE BEEN DOUBLED
JRST RUB1C4
CAIE A,33 ;ALTMODE IS ALWAYS 1 WIDE
TLNE F,FBT<SA> ;OTHER CONTROLS ONE WIDE IF IN SAIL MODE
JRST RUB1C3
MOVEI T,2 ;OTHERWISE CONTROL CHARS ARE TWO WIDE
RUB1C3:
;; PUSHJ FLP,RCPOS
;; TLNE F,FBT<EC>
;; MOVE D,R
MOVEI R,(T)
;; CAILE T,(D) ;CLAIM IS, AS OF 1980, THAT THAT ^PB AND ^PX
;; PUSHJ P,CNPU ; KNOW ENOUGH TO DO THIS ALREADY
CAIE R,2
JRST CNPBL
JRST CNPBBL
RUB1C4: AOS (P) ;DOUBLE SKIP RETURN, RETYPE ON SMART TTY
AOS (P)
POPJ P,
] ;END OF IFN ITS\D20
IFN D20,[
RUB1C2: SKIPN TENEXP ;ONLY TENICIES HAVE DELCH JSYS
JRST TYOFA ;SO ON TOPS-20 CAN ONLY REECHO CHARACTER
MOVE TT,A ;SAVE RUBBED OUT CHARACTER
LOCKI ;LOCK OVER SYSTEM CALL
MOVE T,TTSAR(AR1)
HRRZ A,F.JFN(T)
RUB1C8: DELCH
JRST RUB1C5 ;NOT TTY?? JUST PRINT CHARACTER
JRST RUB1C6 ;AT BEGINNING OF LINE, RETYPE INPUT
JRST RUB1C7 ;DID IT, JUST RETURN
;;; HERE IF NON-DISPLAY, NOT TTY, OR IF DELCH GOT AN ILLEGAL INSTRUCTION TRAP
.SEE INTILO
RUB1C5: UNLOCKI ;RELEASE LOCK
MOVE A,TT ;PUT SOMETHING SAFE IN A
JRST TYOFIL ;THEN OUTPUT CHARACTER FROM TT
RUB1C6: AOS (P) ;SKIP RETURN MEANS REECHO
UNLKPOPJ
RUB1C7: CAIL TT,^H ;PROBABLY ^ FORMAT
JRST RUB1C9
RUB1CA: MOVEI TT,"^ ;TURN CHARACTER UNTO AN UPARROW
JRST RUB1C8 ;THEN GET RID OF IT TOO
RUB1C9: CAIG TT,^M ;OUT OF MAGIC CHARACTER RANGE?
JRST RUB1CC ;NOPE, PROBABLY BE BETTER TO RETYPE THEN
CAIN TT,33 ;ESCAPE IS MAGIC, AS IT PRINTS AS ONLY ONE CHAR
UNLKPOPJ
CAIGE TT,40 ;SOME OTHER CONTROL CHAR?
JRST RUB1CA ;YES, GET RID OF THE PRECEEDING UPARROW
MOVE A,TT
UNLKPOPJ ;ELSE JUST RETURN, THE WORK IS DONE
RUB1CC: UNLOCKI
AOS (P) ;SETUP FOR SKIP (RETYPE) RETURN
MOVEI A,15 ;BUT FIRST GET TO A NEW LINE
JRST TYOFA
] ;END IFN D20
;;; READLINE TAKES STANDARD FILE/EOF INPUT ARGUMENTS AND READS
;;; ONE LINE FROM A FILE. IT INVOKES PRE-SCANNING FOR TTY'S.
;;; THE RESULT IS RETURNED AS AN ATOMIC SYMBOL, EXCLUDING THE
;;; CARRIAGE RETURN WHICH TERMINATES THE LINE. LINE FEEDS
;;; ARE IGNORED (NECESSARY FOR SUCCESSIVE READLINE'S).
%READLINE:
JSP D,INCALL
SFA% Q%READLINE
SFA$ [SO.RDL,,],,Q%READLINE
MOVEI A,Q%READLINE
HRLZM A,BFPRDP ;PERMIT TTY PRE-SCAN
MOVEI T,%RDLN5
PUSHJ FXP,MKNR6C ;PART OF MAKNAM
JRST PNGNK1 ;CREATE NON-INTERNED SYMBOL
%RDLN5: PUSH FXP,D
%RDLN6: PUSHJ P,@TYIMAN
IFN SAIL,[
ANDI TT,%TXCTL+%TXASC ;FOLD CHARACTER DOWN TO 7 BITS
TRZN TT,%TXCTL
JRST %RDLNZ
CAIE TT,177
TRZ TT,140
%RDLNZ:
] ;END IFN SAIL
CAIN TT,^J ;IGNORE LINE FEEDS
JRST %RDLN6
POP FXP,D
CAIN TT,^M ;CR TERMINATES
POPJ P,
MOVEI A,(TT)
JRST POPJ1
PGTOP RDR,[HIRSUTE READER, MAKNAM, ETC.]