perm filename LISPIO.FAI[LSP,BGB] blob
sn#049117 filedate 1973-06-18 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00028 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00004 00002 TYI AND TYO --- PAGE 6
00007 00003 teletype INPUT
00008 00004 output
00010 00005 DDTIFG: TRUTH
00011 00006 INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
00013 00007 IOSUB: PUSHJ P,NXTIO
00017 00008 search for channel name in chtab
00019 00009
00020 00010 INPUT: PUSHJ P,CHNSUB determine channel name
00022 00011 OUTPUT: PUSHJ P,CHNSUB get channel name
00024 00012 IOSEL: LAC C,-1(P)
00025 00013 INCNT: MOVEI A,NIL (INC NIL T)
00027 00014 OUTCNT: MOVEI A,0 (outc nil t)
00029 00015 AIN.1: PUSHJ P,AIOP
00030 00016 PRINT --- PAGE 8
00031 00017 PRIN1A: LAC A,-1(P)
00036 00018 TABLE DRIVEN READ 14-MAY-69 PAGE 9
00038 00019 macros for scanner table
00039 00020 CHRTAB:
00041 00021 READCH: PUSHJ P,TYI
00043 00022 atom parser
00045 00023 string scanner
00046 00024 number scanner
00047 00025 semantic routines
00049 00026 identifier interner
00051 00027 number builder
00054 00028 INTERN: DAC A,AR2A
00055 ENDMK
⊗;
SUBTTL TYI AND TYO --- PAGE 6
;INPUT
ITYI: PUSHJ P,TYI
FIXI: ADDI A,INUM0
POPJ P,
TYI: MOVEI AR1,1
PUSHJ P,TYIA
JUMPE A,.-1
CAME A,IGSTRT ;start of comment or ignored cr-lf
POPJ P,
PUSHJ P,COMMENT
JRST TYI+1
TYIA: SKIPE A,OLDCH
JRST TYI1
TYID:
TYI2: JRST TTYI+X ;sosg x for other device INPUT
;other device INPUT
JRST TYI2X
TYI3: ILDB A,X ;pointer
TYI3A: TDNN AR1,@X ;pointer
POPJ P,
LAC A,@TYI3A
CAMN A,[<ASCII / />+1] ;page mark for stopgap
AOSA PGNUM ;increment page number
DAC A,LINUM
MOVNI A,5
ADDM A,@TYI2 ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYI2
TYI2X: INPUT X,
TYI2Y: STATZ X,740000
ERR1 AIN.8 ;INPUT error
TYI2Z: STATO X,20000
JRST TYI3 ;continue with file
PUSH P,T ;end of file
PUSH P,C
PUSH P,R
PUSH P,AR1
LAC A,INCH
CDR C,CHTAB(A) ;get location of data for this channel
CAR T,CHTAB(A) ;inlst -- remaining files to INPUT
JUMPE T,TYI2E ;none left -- stop
PUSHJ P,SETIN ;start next INPUT
POP P,AR1
POP P,R
POP P,C
POP P,T
JRST TYI
TYI2E: PUSHJ P,INCNT ;(inc nil t)
TALK ;turn off control o
FOO MOVEI A,$EOF$ ;we are done
JRST ERR
PGLINE: LAC C,[POINT 7,LINUM]
PUSHJ P,NUM10 ;convert ascii line number to a integer
PUSHJ P,FIX1A
LAC B,PGNUM
ADDI B,INUM0+1
JRST XCONS
OLDCH: 0
PGNUM: 0
LINUM: 0
0 ;zero to terminate num10
;teletype INPUT
TTYI: SKIPE DDTIFG
JRST TTYID
INCHSL A ;single char if line has been typed
JRST [TALK ;turn off control O, this
;can be omitted when TTYSER is fixed
OUTCHR ["*"] ;output *
INCHWL A ;wait for a line
JRST .+1]
TTYXIT: CAIN A,BELL
JRST LSPRET ;bell returns to top level
POPJ P,
TTYID: TALK ;turn off control O, remove this when TTYSER works
INCHRW A ;single character INPUT DDT submode style
CAIE A,RUBOUT
JRST TTYXIT
OUTCHR ["\"] ;echo backslash
SKIPE PSAV
JRST RDRUB ;rubout in read resets to top level of read
MOVEI A,RUBOUT
POPJ P,
;output
ITYO: SUBI A,INUM0
PUSHJ P,TYO
JRST FIXI
TYO: CAIG A,CR
JRST TYO3
SOSGE CHCT
JRST TYO1
TYOD: JRST TTYO+X ;sosg x for other device
;other device output
JRST TYO2X
TYO5: IDPB A,X
POPJ P,
TYO2X: OUT X,
JRST TYO5
ERR1 [SIXBIT /OUTPUT ERROR!/]
TYO1: PUSH P,A ;linelength exceeded
MOVEI A,IGCRLF ;inored cr-lf
PUSHJ P,TYOD
PUSHJ P,TERPRI ;force out a cr-lf, with special mark
POP P,A
SOSA CHCT
TYO4: POP P,B
JRST TYOD
TYO3: CAIGE A,TAB
JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
PUSH P,B
LAC B,LINL
CAIN A,TAB
JRST [ SUB B,CHCT
IORI B,7 ;simulate tab effect on chct
SUB B,LINL
SETCAM B,CHCT
JRST TYO4]
CAIN A,CR
DAC B,CHCT ;reset chct after a cr
JRST TYO4
LINELENGTH:
JUMPE A,LINEL1
SUBI A,INUM0
DAC A,CHCT
EXCH A,LINL
JRST FIXI
LINEL1: LAC A,LINL
JRST FIXI
CHRCT: LAC A,CHCT
JRST FIXI
LINL: TTYLL ;*
CHCT: TTYLL ;*
;teletype output
TTYO: OUTCHR A ;output single character in a
POPJ P,
DDTIFG: TRUTH
DDTIN: EXCH A,DDTIFG
POPJ P,
TTYRET: PUSHJ P,OUTCNT
JRST INCNT
;all of this crap is to turn off control O. lose-lose-lose
TTYCLR: RELEASE TTCH,
INIT TTCH,1
SIXBIT /TTY/
XWD TOBUF,0
HALT
PUSH P,A
MOVEI A,TTOBUF-1
DAC A,JOBFF
OUTBUF TTCH,1
OUTPUT TTCH, ;set up buffer
MOVEI A,0
IDPB A,TOBUF+1 ;plant a null character
AOS TOBUF+2
OUTPUT TTCH, ;output it
JRST POPAJ
TOBUF: BLOCK 3
TTOBUF: BLOCK 33
TTOCH: 0 ;*
0 ;tty page number always zero
0 ;tty line number -- always zero
TTOLL: TTYLL ;*
TTOHP: TTYLL ;*
SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
;convert ascii to sixbit for device initialization routines
SIXMAK: SETZM SIXMK2#
LAC AR1,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA ;use print to unpack ascii characters
LAC A,SIXMK2
POPJ P,
SIXMK1: ADDI A,40
TLNN AR1,770000
POPJ P, ;last character position -- ignore remaining chars
CAIN A,"."+40
MOVEI A,0 ;ignore dots at end of numbers for decimal base
CAIN A,":"+40
HRLI AR1,(<POINT 6,0,29>) ;deposit : in last char
IDPB A,AR1
POPJ P,
;subroutine to process next item in file name list
INXTIO: JUMPE T,NXTIO
CDR T,(T)
NXTIO: CAR A,(T)
PUSHJ P,ATOM
JUMPE A,CPOPJ ;non-atomic
CAR A,(T)
JRST SIXMAK ;make sixbit if atomic
;right normalize sixbit
LSH A,-6
SIXRT: TRNN A,77
JRST .-2
POPJ P,
IOSUB: PUSHJ P,NXTIO
DAC T,DEVDAT#
LDB B,[POINT 6,A,35]
JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
CAIE B,":"-40
JRST IOFIL ;not a device name -- must be file name
TRZ A,77 ;clear out the :
SETZM PPN
IODEV2: DAC A,DEV
PUSHJ P,INXTIO
IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
PUSHJ P,PPNEXT
JUMPN A,IOEXT ;(fil.ext)
CAR A,(T)
CAR A,(A) ;caar is project number
PUSHJ P,SIXMAK
PUSHJ P,SIXRT
DIP A,PPN ;project number
CAR A,(T)
PUSHJ P,CADR ;cadar is programmer number
PUSHJ P,SIXMAK
PUSHJ P,SIXRT
DAP A,PPN ;programmer number
HRLZI A,(<SIXBIT /DSK/>) ;disk is assumed
JRST IODEV2
IOFIL: SKIPN DEV
JRST AIN.1 ;no device named
JUMPN A,IOFIL2 ;was it an atom
JUMPE T,CPOPJ ;no, was it nil (end)
PUSHJ P,PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: CAR A,(T) ;(file.ext)
CDR A,(A) ;get cdr ←← extension
PUSHJ P,SIXMAK
HLLM A,EXT
CAR A,(T)
CAR A,(A) ;get car = file name
PUSHJ P,SIXMAK
FIL: PUSH P,A
PUSHJ P,INXTIO
JRST POPAJ
IOFIL2: CAIN B,":"-40
POPJ P, ;saw a :,not file name
SETZM EXT ;file name -- clear extension
JRST FIL
PPNEXT: JUMPE T,CPOPJ ;end of file name list
CAR A,(T)
CDR A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
CHNSUB: LAC T,A
CAR A,(T)
PUSHJ P,ATOM
JUMPE A,TRUE ;non-atomic head of list -- no channel named
CAR A,(T)
PUSHJ P,SIXMAK
ANDI A,77
CAIN A,":"-40
JRST TRUE ;device name, assume channel name t
CAR A,(T) ;channel name -- return it
CDR T,(T)
POPJ P,
CHTAB←.-FSTCH
BLOCK NIOCH ;*
;channel data
CHNAM←←0 ;name of channel
CHDEV←←1 ;name of device
CHPPN←←2 ;ppn for INPUT channel
CHOCH←←3 ;oldch for INPUT channels
CHPAGE←←4 ;page number for INPUT
CHLINE←←5 ;line number for INPUT
CHDAT←←6 ;device data
POINTR←←7 ;byte pointer for device buffer
COUNT←←10 ;character count for device buffer
CHLL←←2 ;linelength for output channel
CHHP←←3 ;hposit for output channels
;search for channel name in chtab
TABSR1: LAC A,[XWD -NIOCH,FSTCH]
LAC C,CHTAB(A)
CAME B,CHNAM(C)
AOBJN A,.-2
CAMN B,CHNAM(C)
POPJ P, ;found it!!!
JRST FALSE ;lost
;search for channel name in chtab, and if not there find a free channel, and
;if no free channel, allocate a new buffer and channel
TABSRC: LAC B,A
PUSHJ P,TABSR1
JUMPN A,DEVCLR ;found the channel
PUSH P,B
LAC B,0
PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
POP P,B
JUMPN C,DEVCLR ;found free channel which had buffer space previously
PUSH P,A ;must allocate new buffer
MOVEI A,BLKSIZ
PUSHJ P,MORCOR ;Get space for buffer.
LAC C,A
POP P,A
DAP C,CHTAB(A)
DEVCLR: CDR C,CHTAB(A)
DAPZ B,CHNAM(C) ;store name
DAPZ A,CHANNEL#
POPJ P,
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST: X ;jsr location
;CDR A,JOBREL
;DIP A,JOBSA
;DAC A,CORUSE#
;DAC A,JOBSYM
;SETZM CHTAB+FSTCH
;LAC A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
;BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
JRST @IOBRST
INPUT: PUSHJ P,CHNSUB ;determine channel name
PUSH P,A
PUSHJ P,TABSRC ;get physical channel number
PUSHJ P,SETIN ;init device
JRST POPAJ
SETIN: DAC A,CHANNEL
LAC A,CHDEV(C)
DAC A,DEV
LAC A,CHPPN(C)
DAC A,PPN
PUSHJ P,IOSUB ;get device and file name
DAC A,LOOKIN ;file name
LAC A,DEV
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not INPUT device
TLNN A,AVLB
JRST AIN.4 ;not available
LAC A,CHANNEL
DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
DPB A,[POINT 4,INLOOK,ACFLD]
DPB A,[POINT 4,ININBF,ACFLD]
CDR B,CHTAB(A)
DIP T,CHTAB(A) ;save remaining file name list
MOVEI A,CHDAT(B)
DAC A,DEV+1 ;pointer to bufdat
ININIT: INIT X,
DEV: X
X
JRST AIN.7 ;cant init
PUSH B,DEV
PUSH B,PPN
INLOOK: LOOKUP X,LOOKIN
JRST AIN.7 ;cant find file
PUSH B,[0] ;oldch
PUSH B,[0] ;line number
PUSH B,[0] ;page number
ADDI B,4
DAP B,JOBFF
ININBF: INBUF X,NIOB
JRST TRUE
ENTR:
LOOKIN: BLOCK 4
EXT←LOOKIN+1
PPN←LOOKIN+3
OUTPUT: PUSHJ P,CHNSUB ;get channel name
PUSH P,A
TRO A,400000 ;set bit for output
PUSHJ P,TABSRC ;get physical channel nuber
PUSHJ P,IOSUB ;get device and file name
DAC A,ENTR ;file name
SETZM ENTR+2 ;zero creation date
LAC A,CHANNEL
DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
CDR B,CHTAB(A)
MOVEI A,CHDAT(B)
DIP A,AOUT3+1
LAC A,DEV
DAC A,AOUT3
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
AOUT2: INIT X,
AOUT3: X
X
JRST AOUT.4 ;cant init
PUSH B,DEV
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
PUSH B,[LPTLL] ;linelength
PUSH B,[LPTLL] ;chrct
ADDI B,6
DAP B,JOBFF
OUTOBF: OUTBUF X,NIOB
JRST POPAJ
OUTERR: PUSHJ P,AIOP
LDB A,[POINT 3,ENTR+1,35]
CAIE A,2
ERR1 [SIXBIT /DIRECTORY FULL !/]
ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
IOSEL: LAC C,-1(P)
JUMPE C,CPOPJ ;tty
JUMPE B,IOSELZ ;dont release
DPB C,[POINT 4,.+1,ACFLD]
RELEASE X, ;release channel
HRRZS CHTAB(C) ;release channel table entry
DAC 0,@CHTAB(C) ;blast channel name
SETZM -1(P)
IOSELZ: CDR C,CHTAB(C)
POPJ P,
INCNT: MOVEI A,NIL ;(INC NIL T)
MOVEI B,TRUTH
INC: PUSH P,INCH#
PUSHJ P,IOSEL
JUMPN B,INC2 ;released channel
SKIPN C
MOVEI C,TTOCH-CHOCH ;tty deselect
MOVEI B,CHOCH(C)
HRLI B,OLDCH
BLT B,CHLINE(C) ;save channel data
INC2: JUMPE A,ITTYRE ;select tty
LAC B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
DAPZ A,INCH
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
CDR A,CHTAB(A)
MOVEI T,COUNT(A)
HRLI T,(<SOSG>)
MOVEI B,POINTR(A)
DAP B,TYI3 ;set up tyi parameters
DAP B,TYI3A
INC3: MOVSI B,CHOCH(A)
HRRI B,OLDCH
BLT B,LINUM ;restore channel data
DAC T,TYID
IOEND: POP P,A
JUMPE A,CPOPJ
LAC A,CHTAB(A) ;get channel name
CDR A,(A)
TRZ A,400000 ;clear output bit
POPJ P,
ITTYRE: SETZM INCH
LAC T,[JRST TTYI] ;reselect tty
MOVEI A,TTOCH-CHOCH
JRST INC3
OUTCNT: MOVEI A,0 ;(outc nil t)
MOVEI B,1
OUTC: PUSH P,OUTCH#
PUSHJ P,IOSEL
JUMPN B,OUTC2 ;closed this file
SKIPN C
MOVEI C,TTOLL-CHLL ;tty deselect
LAC B,CHCT
DAC B,CHHP(C) ;save channel data
LAC B,LINL
DAC B,CHLL(C)
OUTC2: JUMPE A,OTTYRE ;return to tty
TRO A,400000 ;set output bit
LAC B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
DAPZ A,OUTCH
CDR A,CHTAB(A)
MOVEI B,POINTR(A)
DAP B,TYO5 ;set up tyo2 parameters
MOVEI T,COUNT(A)
HRLI T,(<SOSG>)
OUTC3: LAC B,CHLL(A)
DAC B,LINL
LAC B,CHHP(A)
DAC B,CHCT
DAC T,TYOD
JRST IOEND
OTTYRE: SETZM OUTCH
LAC T,[JRST TTYO]
MOVEI A,TTOLL-CHLL ;tty reselect
JRST OUTC3
AIN.1: PUSHJ P,AIOP
ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2: PUSHJ P,AIOP
ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: PUSHJ P,AIOP
ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7: PUSHJ P,AIOP
ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
AIN.8: SIXBIT /INPUT ERROR!/
AIOP: LAC A,DEVDAT
JRST EPRINT
SUBTTL PRINT --- PAGE 8
EPRINT: SKIPN ERRSW
POPJ P,
PUSHJ P,ERRIO
PUSHJ P,PRINT
JRST OUTRET
PRINT: MOVEI R,TYO
PUSHJ P,TERPRI
PUSHJ P,PRIN1
XCT " ",CTY
POPJ P,
PRINC: SKIPA R,.+1
PRIN1: HRRZI R,TYO
PUSH P,A
PUSHJ P,PRINTA
JRST POPAJ
PRINTA: PUSH P,A
MOVEI B,PRIN3
SKIPGE R
MOVEI B,PRIN4
DAP B,PRIN5
PUSHJ P,PATOM
JUMPN A,PRINT1
XCT "(",CTY
PRINT3: CAR A,@(P)
PUSHJ P,PRINTA
CDR A,@(P)
JUMPE A,PRINT2
DAC A,(P)
XCT " ",CTY
PUSHJ P,PATOM
JUMPE A,PRINT3
XCT ".",CTY
XCT " ",CTY
PUSHJ P,PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PRINT1: PUSHJ P,PRIN1A
JRST POPAJ
PRIN1A: LAC A,-1(P)
CAILE A,INUMIN
JRST PRINIC
JUMPE A,PRIN1B
CAMGE A,orgFWS
CAMGE A,orgHWS
JRST PRINL
PRIN1B: CDR A,(A)
JUMPE A,PRINL
CAR B,(A)
CDR A,(A)
FOO CAIN B,PNAME
JRST PRINN
FOO CAIN B,FIXNUM
JRST PRINI1
FOO CAIN B,FLONUM
JRST PRINO
BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
JRST PRIN1B
PRINL2: MOVEI R,TYO
JRST PRINL1
PRINL: XCT "#",CTY
CDR A,-1(P)
PRINL1: MOVEI C,8
JRST PRINI3
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
FOO CDR C,VBASE
SUBI C,INUM0
JUMPGE A,PRINI2
XCT "-",CTY
MOVNS A
PRINI2: MOVEI B,"."-"0"
DIP B,(P)
CAIN C,TEN
FOO SKIPE %NOPOINT
JRST .+2
PUSH P,PRINI4
PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C)
DIP B,(P)
SKIPE A
PUSHJ P,.-3
PRINI4: JRST FP7A1
PRINN: CAR A,(A)
MOVEI C,2(SP)
PUSHJ P,PNAMU3
PUSH C,[0]
HRLI C,(<POINT 7,0,35>)
HRRI C,2(SP)
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
CAIN A,DBLQT
JRST PSTR ;string
PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
JUMPL R,PRIN4 ;never slash
JRST PRIN2(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2: XCT "/",CTY
PRIN4: PUSHJ P,(R)
ILDB A,C
PRIN5: JUMPN A,PRIN3 ;prin4 for never slash
POPJ P,
PSTR: MOVS B,(C)
CAIN B,(<ASCII /"/>)
JRST PRIN2X ;special case of /"
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PUSHJ P,(R)
ILDB A,C
CAIE A,DBLQT
JUMPN A,PSTR2
JUMPN A,PSTR3
POPJ P,
TERPRI: PUSH P,A
MOVEI A,CR
PUSHJ P,TYO
MOVEI A,LF
PUSHJ P,TYO
JRST POPAJ
CTY: JSA A,TYOI
TYOI: X
PUSH P,A
LDB A,[POINT 6,-1(A),ACFLD]
PUSHJ P,(R)
POP P,A
JRA A,(A)
PRINO: LAC A,(A)
SETZB B,C
JUMPG A,FP1
JUMPE A,FP3
MOVNS A
XCT "-",CTY
FP1: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP3: MULI A,400
ASHC B,-243(A)
LAC A,B
SETZM FPTEM#
PUSHJ P,FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
LAC B,C
FP3A: LAC A,B
MULI A,TEN
PUSHJ P,FP7B
SKIPE B
AOJL T,FP3A
POPJ P,
FP4: MOVNI C,6
MOVEI TT,0
FP4A: ADDI TT,1(TT)
XCT FCP(B)
TRZA TT,1
FMPR A,@FCP+1(B)
AOJN C,FP4A
PUSH P,TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,11]
PUSHJ P,FP3
MOVEI A,"E"
PUSHJ P,(R)
FP4C: XCT "+"+X,CTY
POP P,A
FP7: JUMPE A,FP7A1
IDIVI A,TEN
AOS FPTEM
DIP B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
353473426555 ;1e32
266434157116 ;1e16
FT8: 1.0E8
1.0E4
1.0E2
1.0E1
FT: 1.0E0
026637304365 ;1e-32
113715126246 ;1e-16
146527461671 ;1e-8
163643334273 ;1e-4
172507534122 ;1e-2
FT01: 175631463146 ;1e-1
FT0:
FCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
XWD C,FT0
SUBTTL TABLE DRIVEN READ 14-MAY-69 PAGE 9
;magic scanner table bit definitions
;bit 0=0 iff slashified as 1st id character
;bit 1=0 iff slashified as nth id character
;bits 2-5 ratab index
;bits 6-8 dotab index
;bits 9-10 strtab index
;bits 11-13 idtab index
;bits 14-16 exptab index
;bits 17-19 rdtab index
;bits 20-25 ascii to radix 50 conversion
IGSTRT: IGCRLF
IGEND: LF
RATFLD: POINT 4,CHRTAB(A),5
STRFLD: POINT 2,CHRTAB(A),10
IDFLD: POINT 3,CHRTAB(A),13
DOTFLD:
NUMFLD: POINT 3,CHRTAB(A),8
EXPFLD: POINT 3,CHRTAB(A),16
RDFLD: POINT 3,CHRTAB(A),19
R50FLD: POINT 6,CHRTAB(A),25
;magic state flags in t
EXP←←1 ;exponent
NEXP←←2 ;negative exponent
SAWDOT←←4 ;saw a dot (.)
MINSGN←←10 ;negative number
IDCLS←←0 ;identifier
STRCLS←←1 ;string
NUMCLS←←2 ;number
DELCLS←←3 ;delimiter
;macros for scanner table
DEFINE RAD50 (X){
R50VAL←0
IFE ("X"-" "),{R50VAL←0}
IFLE ("X"-"9"),{IFGE ("X"-"0"),{R50VAL←"X"-"0"+1}}
IFE ("X"-"."),{R50VAL←45}
IFGE ("X"-"A"),{R50VAL←"X"-"A"+13}
}
DEFINE TABIN (S1,SN,R,D,S,I,E,RD,STR){
XLIST
FOR CHRε{STR}{RAD50(CHR)
BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL
}
LIST}
DEFINE LET (X){
TABIN (1,1,5,2,3,4,2,0,X)}
DEFINE DELIMIT (X,Y){
TABIN (0,0,2,2,3,2,2,Y,X)}
DEFINE IGNORE (X){
TABIN (0,0,3,2,3,2,2,0,X)}
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,{ })
;null
LET ({ })
IGNORE ({ })
;tab,lf,vtab,ff,cr
LET ({ })
;16 to 31
TABIN (0,0,0,0,0,0,0,0,{ })
;igmrk
LET ({ })
;33 to 37
IGNORE ({ })
;space
LET ({ })
;!
TABIN (0,0,9,2,2,2,2,0,{ })
;"
LET ({ $% })
;#$%&'
DELIMIT ({ },0)
DELIMIT ({ },1)
;()
LET ({ })
;*
TABIN (1,0,3,2,3,4,2,0,{ })
;+
IGNORE ({ })
;,
TABIN (1,0,6,2,3,4,2,0,{ })
;-
TABIN (0,0,7,3,3,2,2,4,{.})
TABIN (0,0,4,2,3,3,2,0,{ })
;/
TABIN (1,0,8,5,3,4,3,0,{0123456789})
LET ({ })
;:;<=>?
TABIN (1,0,2,2,3,4,2,5,{ })
;@
LET ({ABCD})
TABIN (1,1,5,4,3,4,2,0,{E})
LET ({FGHIJKLMNOPQRSTUVWXYZ})
DELIMIT ({ },2)
;[
LET ({ })
;\
DELIMIT ({ },3)
;]
LET ({ })
;↑←`
LET ({ABCDEFGHIJKLMNOPQRSTUVWXYZ})
;lower case
LET ({ })
;{¬
DELIMIT ({ },3)
;altmode
LET ({ })
;}
DELIMIT ({ },6)
;rubout
READCH: PUSHJ P,TYI
MOVSI AR1,AR1
PUSHJ P,EXPL1
JRST CAR.
READP1: SETZM NOINFG
READ0: PUSH P,TYID
PUSH P,OLDCH
SETZM OLDCH#
HRLI A,(<JRST>)
DAC A,TYID
PUSHJ P,READ+1
POP P,OLDCH
POP P,TYID
POPJ P,
RDRUB: MOVEI A,CR
PUSHJ P,TTYO
MOVEI A,LF
PUSHJ P,TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
DAC P,PSAV
PUSHJ P,READ1
SETZM PSAV
POPJ P,
READ1: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 [
JFCL ;3 ],$
JFCL ;4 .
JRST RDQT ;5 @
READ2: PUSHJ P,RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PUSH P,A
PUSHJ P,READ2
POP P,B
JRST XCONS
RDTAB: PUSHJ P,READ2 ;0 (
JRST FALSE ;1 )
PUSHJ P,READ4 ;2 [
JRST READ5 ;3 ],$
JRST RDT ;4 .
PUSHJ P,RDQT ;5 @
RDTX: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST DOTERR ;dot context error
RDT: PUSHJ P,RDTX
PUSH P,A
PUSHJ P,RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
DAC A,OLDCH
JRST POPAJ
READ4: PUSHJ P,READ2
LAC B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the ]
POPJ P,
READ5: DAC A,OLDCH ;save ] or $
JRST FALSE ;and return nil
RDQT: PUSHJ P,READ1
JRST QTIFY
;atom parser
COMMENT: PUSHJ P,TYID
CAME A,IGEND
JRST COMMENT
POPJ P,
RATOM: SETZB T,R
HRLI C,(<POINT 7,0,35>)
HRRI C,(SP)
MOVEI AR1,1
RATOM2: PUSHJ P,TYIA
LDB B,RATFLD
JRST RATAB(B)
RATAB: PUSHJ P,COMMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PUSHJ P,TYI ;4 /
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
;a real dotted pair
RDOT2: DAC A,OLDCH
MOVEI A,"."
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
AOS (P) ;non-atom (ie a delimiter)
POPJ P,
;dot handler
RDOT: PUSHJ P,TYID
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PUSHJ P,COMMENT ;0 comment
JRST RDOT ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 e
MOVEI B,0 ;5 digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
;string scanner
STRTAB: PUSHJ P,COMMENT ;0 comment
JRST RDSTR+1 ;1 null
JRST STR2 ;2 delimit
RDSTR: IDPB A,C ;3 string element
PUSHJ P,TYID
LDB B,STRFLD
JRST STRTAB(B)
STR2: MOVEI A,DBLQT
HRRI R,STRCLS ;string
IDPB A,C
NOINTR: PUSHJ P,IDEND ;no intern
PUSHJ P,IDSUB
JRST PNAMAK
;identifier scanner
IDTAB: PUSHJ P,COMMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PUSHJ P,TYI ;3 /
RDID: IDPB A,C ;4 letter or digit
PUSHJ P,TYID
LDB B,IDFLD
JRST IDTAB(B)
;number scanner
NUMTAB: PUSHJ P,COMMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
RDNUM: IDPB A,C ;5 digit
PUSHJ P,TYID
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
JRST RDNUM+1
;exponent scanner
RDE: TLO T,EXP
MOVEI A,0
IDPB A,C
PUSHJ P,TYID
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PUSHJ P,COMMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PUSHJ P,TYID
LDB B,EXPFLD
JRST EXPTAB(B)
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
POPJ P,
MAKID: DAC A,OLDCH
PUSHJ P,IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PUSHJ P,IDSUB
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found
PUSHJ P,PNAMAK ;not there
MAKID2: LAC C,CURBUC ;
CAR B,(C)
PUSHJ P,CONS ;cons it into the oblist
DIP A,(C)
JRST CAR.
CURBUC: 0
;pname unmaker
PNAMUK:
FOO MOVEI B,PNAME
PUSHJ P,GET
JUMPE A,NOPNAM
LAC C,SP
PNAMU3: CAR B,(A)
PUSH C,(B)
CDR A,(A)
JUMPN A,PNAMU3
POPJ P,
;idsub constructs a iowd pointer for a print name
IDSUB: HRRZS C
CAML C,endSPD ;top of spec pdl
JRST SPDLOV
MOVNS C
ADDI C,(SP)
HRLI C,1(SP)
MOVSM C,IDPTR#
POPJ P,
;identifier interner
INTER1: LAC B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
INT1: IDIVI B,BCKETS+X ;compute hash code
RHX2: ADD C,ORGHWS
CAR TT,(C) ;get bucket
DAC C,CURBUC ;save bucket number
LAC T,TT
JRST MAKID1
MAKID3: LAC TT,T ;save previous atom
CDR T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
CAR A,(T) ;next id in oblist
MAKID4: CDR A,(A)
JUMPE A,NOPNAM ;no print name
LAC A,(A)
CAR C,A
FOO CAIE C,PNAME
JRST MAKID4
LAC C,IDPTR ;found pname
CAR A,(A)
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
LAC B,(A)
ANDCAM AR1,(C) ;clear low bit
CAME B,(C)
JRST MAKID3 ;not the one
CAR A,A ;ok so far
AOBJN C,MAKID5
JUMPN A,MAKID3 ;not the one
CAR A,(T) ;this is it
CAR B,(TT)
DIP A,(TT)
DIP B,(T)
POPJ P,
;pname builder
PNAMAK: LAC T,IDPTR
PUSHJ P,NCONS
LAC TT,A
LAC C,A
PNAMB: LAC A,(T)
TRZ A,1 ;clear low bit!!!!!
PUSHJ P,FWCONS
PUSHJ P,NCONS
DAP A,(TT)
LAC TT,A
AOBJN T,PNAMB
LAC A,C
HRLZS (A)
JRST PNGNK1+1
;number builder
NUMAK: DAC A,OLDCH
HRRI R,NUMCLS ;number
MOVEI A,0
IDPB A,C
IDPB A,C
HRRZS C
CAML C,endSPD ;top of spec pdl
JRST SPDLOV
MOVSI C,(<POINT 7,0,35>)
HRRI C,(SP)
TLNE T,SAWDOT+EXP
JRST NUMAK2 ;decimal number or flt pt
FOO LAC A,VIBASE ;ibase integrer
SUBI A,INUM0
PUSHJ P,NUM
NUMAK4:
FOO MOVEI B,FIXNUM
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PUSHJ P,NUM10
DAC A,TT
TLNN T,SAWDOT
JRST [ PUSHJ P,FLOAT ;flt pt without fraction
LAC TT,A
JRST NUMAK3]
PUSHJ P,NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR2A,NUMAK4 ;no exponent and no fraction
PUSHJ P,FLOAT
EXCH A,TT
PUSHJ P,FLOAT
MOVEI AR1,FT01
PUSHJ P,FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PUSHJ P,NUM10 ;exponent part
LAC AR2A,A
MOVEI AR1,FT-1
TLNE T,NEXP
MOVEI AR1,FT01 ;-exponent
PUSHJ P,FLOSUB
FMPR TT,B ;positive exponent
FOO MOVEI B,FLONUM
LAC A,TT
JFCL 10,FLOOV
JRST NUMAK6
FLOSUB: MOVSI B,(1.0)
TRZE AR2A,1
FMPR B,(AR1)
JUMPE AR2A,CPOPJ
LSH AR2A,-1
SOJA AR1,FLOSUB+1
;variable radix integer builder
NUM10: MOVEI A,TEN
NUM: DAP A,NUM1
JFCL 10,.+1 ;clear CARRY0 flag
SETZB A,AR2A
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
NUM1: IMULI A,X
ADDI A,-"0"(B)
NUM3: JFCL 10,FIXOV ;bignums change this to JFCL 10,RDBNM
AOJA AR2A,NUM2
INTERN: DAC A,AR2A
PUSHJ P,PNAMUK
PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found it
LAC A,AR2A ;not there
JRST MAKID2 ;put it there
REMOB: JUMPE A,FALSE
MOVEI AR1,1
PUSH P,A
CAR A,(A)
PUSHJ P,INTERN
CAR B,@(P)
CAME A,B
JRST REMOB2
CDR B,CURBUC
CAR C,(B)
CAR T,(C)
CAMN T,A
JRST [ CDR TT,(C)
DIP TT,(B)
JRST REMOB2]
REMOB3: LAC TT,C
CDR C,(C)
CAR T,(C)
CAME T,A
JRST REMOB3
CDR T,(C)
DAP T,(TT)
REMOB2: POP P,A
CDR A,(A)
JRST REMOB