perm filename BB.MAC[LSP,BGB] blob
sn#001387 filedate 1972-11-05 generic text, type T, neo UTF8
00100 SUBTTL TYI AND TYO --- PAGE 6
00200 ;INPOT
00300 ITYI: PUSHJ P,TYI
00400 FIXI: ADDI A,INUM0
00500 POPJ P,
00600
00700 TYI: MOVEI AR1,1
00800 PUSHJ P,TYIA
00900 JUMPE A,.-1
01000 CAME A,IGSTRT ;start of comment or ignored cr-lf
01100 POPJ P,
01200 PUSHJ P,COMMENT
01300 JRST TYI+1
01400
01500 TYIA: SKIPE A,OLDCH
01600 JRST TYI1
01700 TYID:
01800 TYI2: JRST TTYI+X ;sosg x for other device INPOT
01900 ;other device INPOT
02000 JRST TYI2X
02100 TYI3: ILDB A,X ;pointer
02200 TYI3A: TDNN AR1,@X ;pointer
02300 POPJ P,
02400 LAC A,@TYI3A
02500 CAMN A,[<ASCII / />+1] ;page mark for stopgap
02600 AOSA PGNUM ;increment page number
02700 DAC A,LINUM
02800 MOVNI A,5
02900 ADDM A,@TYI2 ;adjust character count for line number
03000 AOS @TYI3 ;increment byte pointer over line number and tab
03100 JRST TYI2
03200
03300 TYI2X: INPUT X,
03400 TYI2Y: STATZ X,740000
03500 ERR1 AIN.8 ;INPOT error
03600 TYI2Z: STATO X,20000
03700 JRST TYI3 ;continue with file
03800 PUSH P,T ;end of file
03900 PUSH P,C
04000 PUSH P,R
04100 PUSH P,AR1
04200 LAC A,INCH
04300 LAPZ C,CHTAB(A) ;get location of data for this channel
04400 LIPZ T,CHTAB(A) ;inlst -- remaining files to INPOT
04500 JUMPE T,TYI2E ;none left -- stop
04600 PUSHJ P,SETIN ;start next INPOT
04700 POP P,AR1
04800 POP P,R
04900 POP P,C
05000 POP P,T
05100 JRST TYI
05200
05300 TYI2E: PUSHJ P,INCNT ;(inc nil t)
05400 TALK ;turn off control o
05500 FOO MOVEI A,$EOF$ ;we are done
05600 JRST ERR
05700
05800 PGLINE: LAC C,[POINT 7,LINUM]
05900 PUSHJ P,NUM10 ;convert ascii line number to a integer
06000 PUSHJ P,FIX1A
06100 LAC B,PGNUM
06200 ADDI B,INUM0+1
06300 JRST XCONS
06400
06500 OLDCH: 0
06600 PGNUM: 0
06700 LINUM: 0
06800 0 ;zero to terminate num10
06900 ;teletype INPOT
07100
07200 TTYI: SKIPE DDTIFG
07300 JRST TTYID
07400 INCHSL A ;single char if line has been typed
07500 JRST [TALK ;turn off control O, this
07600 ;can be omitted when TTYSER is fixed
07700 OUTCHR ["*"] ;output *
07800 INCHWL A ;wait for a line
07900 JRST .+1]
08000 TTYXIT: CAIN A,BELL
08100 JRST LSPRET ;bell returns to top level
08200 POPJ P,
08300
08400 TTYID: TALK ;turn off control O, remove this when TTYSER works
08500 INCHRW A ;single character INPOT DDT submode style
08600 CAIE A,RUBOUT
08700 JRST TTYXIT
08800 OUTCHR ["\"] ;echo backslash
08900 SKIPE PSAV
09000 JRST RDRUB ;rubout in read resets to top level of read
09100 MOVEI A,RUBOUT
09200 POPJ P,
09300 ;output
09400 ITYO: SUBI A,INUM0
09500 PUSHJ P,TYO
09600 JRST FIXI
09700
09800 TYO: CAIG A,CR
09900 JRST TYO3
10000 SOSGE CHCT
10100 JRST TYO1
10200 TYOD: JRST TTYO+X ;sosg x for other device
10300 ;other device output
10400 JRST TYO2X
10500 TYO5: IDPB A,X
10600 POPJ P,
10700
10800 TYO2X: OUT X,
10900 JRST TYO5
11000 ERR1 [SIXBIT /OUTPUT ERROR!/]
11100
11200 TYO1: PUSH P,A ;linelength exceeded
11300 MOVEI A,IGCRLF ;inored cr-lf
11400 PUSHJ P,TYOD
11500 PUSHJ P,TERPRI ;force out a cr-lf, with special mark
11600 POP P,A
11700 SOSA CHCT
11800 TYO4: POP P,B
11900 JRST TYOD
12000
12100 TYO3: CAIGE A,TAB
12200 JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
12300 PUSH P,B
12400 LAC B,LINL
12500 CAIN A,TAB
12600 JRST [ SUB B,CHCT
12700 IORI B,7 ;simulate tab effect on chct
12800 SUB B,LINL
12900 SETCAM B,CHCT
13000 JRST TYO4]
13100 CAIN A,CR
13200 DAC B,CHCT ;reset chct after a cr
13300 JRST TYO4
13400
13500 LINELENGTH:
13600 JUMPE A,LINEL1
13700 SUBI A,INUM0
13800 DAC A,CHCT
13900 EXCH A,LINL
14000 JRST FIXI
14100 LINEL1: LAC A,LINL
14200 JRST FIXI
14300
14400 CHRCT: LAC A,CHCT
14500 JRST FIXI
14600
14700 LINL: TTYLL ;*
14800 CHCT: TTYLL ;*
14900
15000 ;teletype output
15100 TTYO: OUTCHR A ;output single character in a
15200 POPJ P,
15400 DDTIFG: TRUTH
15500 DDTIN: EXCH A,DDTIFG
15600 POPJ P,
15700
15800
15900 TTYRET: PUSHJ P,OUTCNT
16000 JRST INCNT
16100
16200 ;all of this crap is to turn off control O. lose-lose-lose
16300 TTYCLR: RELEASE TTCH,
16400 INIT TTCH,1
16500 SIXBIT /TTY/
16600 XWD TOBUF,0
16700 HALT
16800 PUSH P,A
16900 MOVEI A,TTOBUF-1
17000 DAC A,JOBFF
17100 OUTBUF TTCH,1
17200 OUTPUT TTCH, ;set up buffer
17300 MOVEI A,0
17400 IDPB A,TOBUF+1 ;plant a null character
17500 AOS TOBUF+2
17600 OUTPUT TTCH, ;output it
17700 JRST POPAJ
17800
17900 TOBUF: BLOCK 3
18000
18100 TTOBUF: BLOCK 33
18200
18300 TTOCH: 0 ;*
18400 0 ;tty page number always zero
18500 0 ;tty line number -- always zero
18600
18700 TTOLL: TTYLL ;*
18800 TTOHP: TTYLL ;*
00100 SUBTTL INPOT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
00200 ;convert ascii to sixbit for device initialization routines
00300 SIXMAK: SETZM SIXMK2#
00400 LAC AR1,[POINT 6,SIXMK2]
00500 HRROI R,SIXMK1
00600 PUSHJ P,PRINTA ;use print to unpack ascii characters
00700 LAC A,SIXMK2
00800 POPJ P,
00900
01000 SIXMK1: ADDI A,40
01100 TLNN AR1,770000
01200 POPJ P, ;last character position -- ignore remaining chars
01300 CAIN A,"."+40
01400 MOVEI A,0 ;ignore dots at end of numbers for decimal base
01500 CAIN A,":"+40
01600 HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
01700 IDPB A,AR1
01800 POPJ P,
01900
02000 ;subroutine to process next item in file name list
02100 INXTIO: JUMPE T,NXTIO
02200 LAPZ T,(T)
02300 NXTIO: LIPZ A,(T)
02400 PUSHJ P,ATOM
02500 JUMPE A,CPOPJ ;non-atomic
02600 LIPZ A,(T)
02700 JRST SIXMAK ;make sixbit if atomic
02800
02900 ;right normalize sixbit
03000 LSH A,-6
03100 SIXRT: TRNN A,77
03200 JRST .-2
03300 POPJ P,
03500 IOSUB: PUSHJ P,NXTIO
03600 DAC T,DEVDAT#
03700 LDB B,[POINT 6,A,35]
03800 JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
03900 CAIE B,":"-40
04000 JRST IOFIL ;not a device name -- must be file name
04100 TRZ A,77 ;clear out the :
04200 SETZM PPN
04300 IODEV2: DAC A,DEV
04400 PUSHJ P,INXTIO
04500 IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
04600 PUSHJ P,PPNEXT
04700 JUMPN A,IOEXT ;(fil.ext)
04800 LIPZ A,(T)
04900 LIPZ A,(A) ;caar is project number
05000 PUSHJ P,SIXMAK
05100 PUSHJ P,SIXRT
05200 DIP A,PPN ;project number
05300 LIPZ A,(T)
05400 PUSHJ P,CADR ;cadar is programmer number
05500 PUSHJ P,SIXMAK
05600 PUSHJ P,SIXRT
05700 DAP A,PPN ;programmer number
05800 HRLZI A,(SIXBIT /DSK/) ;disk is assumed
05900 JRST IODEV2
06000
06100 IOFIL: SKIPN DEV
06200 JRST AIN.1 ;no device named
06300 JUMPN A,IOFIL2 ;was it an atom
06400 JUMPE T,CPOPJ ;no, was it nil (end)
06500 PUSHJ P,PPNEXT
06600 JUMPE A,CPOPJ ;see a ppn, no file named
06700 IOEXT: LIPZ A,(T) ;(file.ext)
06800 LAPZ A,(A) ;get cdr == extension
06900 PUSHJ P,SIXMAK
07000 HLLM A,EXT
07100 LIPZ A,(T)
07200 LIPZ A,(A) ;get car = file name
07300 PUSHJ P,SIXMAK
07400 FIL: PUSH P,A
07500 PUSHJ P,INXTIO
07600 JRST POPAJ
07700
07800 IOFIL2: CAIN B,":"-40
07900 POPJ P, ;saw a :,not file name
08000 SETZM EXT ;file name -- clear extension
08100 JRST FIL
08200
08300 PPNEXT: JUMPE T,CPOPJ ;end of file name list
08400 LIPZ A,(T)
08500 LAPZ A,(A) ;cdar
08600 JRST ATOM ;ppn iff (not(atom(cdar l)))
08700
08800 CHNSUB: LAC T,A
08900 LIPZ A,(T)
09000 PUSHJ P,ATOM
09100 JUMPE A,TRUE ;non-atomic head of list -- no channel named
09200 LIPZ A,(T)
09300 PUSHJ P,SIXMAK
09400 ANDI A,77
09500 CAIN A,":"-40
09600 JRST TRUE ;device name, assume channel name t
09700 LIPZ A,(T) ;channel name -- return it
09800 LAPZ T,(T)
09900 POPJ P,
10000
10100 CHTAB=.-FSTCH
10200 BLOCK NIOCH ;*
10300
10400 ;channel data
10500 CHNAM==0 ;name of channel
10600 CHDEV==1 ;name of device
10700 CHPPN==2 ;ppn for INPOT channel
10800 CHOCH==3 ;oldch for INPOT channels
10900 CHPAGE==4 ;page number for INPOT
11000 CHLINE==5 ;line number for INPOT
11100 CHDAT==6 ;device data
11200 POINTR==7 ;byte pointer for device buffer
11300 COUNT==10 ;character count for device buffer
11400 CHLL==2 ;linelength for output channel
11500 CHHP==3 ;hposit for output channels
11700 ;search for channel name in chtab
11800 TABSR1: LAC A,[XWD -NIOCH,FSTCH]
11900 LAC C,CHTAB(A)
12000 CAME B,CHNAM(C)
12100 AOBJN A,.-2
12200 CAMN B,CHNAM(C)
12300 POPJ P, ;found it!!!
12400 JRST FALSE ;lost
12500
12600 ;search for channel name in chtab, and if not there find a free channel, and
12700 ;if no free channel, allocate a new buffer and channel
12800 TABSRC: LAC B,A
12900 PUSHJ P,TABSR1
13000 JUMPN A,DEVCLR ;found the channel
13100 PUSH P,B
13200 LAC B,0
13300 PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
13400 JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
13500 POP P,B
13600 JUMPN C,DEVCLR ;found free channel which had buffer space previously
13700 PUSH P,A ;must allocate new buffer
13800 MOVEI A,BLKSIZ
13900 PUSHJ P,MORCOR ;Get space for buffer.
14000 LAC C,A
14100 POP P,A
14200 DAP C,CHTAB(A)
14300 DEVCLR: LAPZ C,CHTAB(A)
14400 DAPZ B,CHNAM(C) ;store name
14500 DAPZ A,CHANNEL#
14600 POPJ P,
14700
14800 ;subroutine to reset all i/o channels -- used by excise and realloc
14900 IOBRST: X ;jsr location
15000 ;LAPZ A,JOBREL
15100 ;DIP A,JOBSA
15200 ;DAC A,CORUSE#
15300 ;DAC A,JOBSYM
15400 ;SETZM CHTAB+FSTCH
15500 ;LAC A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
15600 ;BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
15700 JRST @IOBRST
15900 INPOT: PUSHJ P,CHNSUB ;determine channel name
16000 PUSH P,A
16100 PUSHJ P,TABSRC ;get physical channel number
16200 PUSHJ P,SETIN ;init device
16300 JRST POPAJ
16400
16500 SETIN: DAC A,CHANNEL
16600 LAC A,CHDEV(C)
16700 DAC A,DEV
16800 LAC A,CHPPN(C)
16900 DAC A,PPN
17000 PUSHJ P,IOSUB ;get device and file name
17100 DAC A,LOOKIN ;file name
17200 LAC A,DEV
17300 CALLI A,DEVCHR
17400 TLNN A,INB
17500 JRST AIN.2 ;not INPOT device
17600 TLNN A,AVLB
17700 JRST AIN.4 ;not available
17800 LAC A,CHANNEL
17900 DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
18000 DPB A,[POINT 4,INLOOK,ACFLD]
18100 DPB A,[POINT 4,ININBF,ACFLD]
18200 LAPZ B,CHTAB(A)
18300 DIP T,CHTAB(A) ;save remaining file name list
18400 MOVEI A,CHDAT(B)
18500 DAC A,DEV+1 ;pointer to bufdat
18600 ININIT: INIT X,
18700 DEV: X
18800 X
18900 JRST AIN.7 ;cant init
19000 PUSH B,DEV
19100 PUSH B,PPN
19200 INLOOK: LOOKUP X,LOOKIN
19300 JRST AIN.7 ;cant find file
19400 PUSH B,[0] ;oldch
19500 PUSH B,[0] ;line number
19600 PUSH B,[0] ;page number
19700 ADDI B,4
19800 DAP B,JOBFF
19900 ININBF: INBUF X,NIOB
20000 JRST TRUE
20100
20200 ENTR:
20300 LOOKIN: BLOCK 4
20400 EXT=LOOKIN+1
20500 PPN=LOOKIN+3
20700 OUTPUT: PUSHJ P,CHNSUB ;get channel name
20800 PUSH P,A
20900 TRO A,400000 ;set bit for output
21000 PUSHJ P,TABSRC ;get physical channel nuber
21100 PUSHJ P,IOSUB ;get device and file name
21200 DAC A,ENTR ;file name
21300 SETZM ENTR+2 ;zero creation date
21400 LAC A,CHANNEL
21500 DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
21600 DPB A,[POINT 4,OUTENT,ACFLD]
21700 DPB A,[POINT 4,OUTOBF,ACFLD]
21800 LAPZ B,CHTAB(A)
21900 MOVEI A,CHDAT(B)
22000 DIP A,AOUT3+1
22100 LAC A,DEV
22200 DAC A,AOUT3
22300 CALLI A,DEVCHR
22400 TLNN A,OUTB
22500 JRST AOUT.2 ;not output device
22600 TLNN A,AVLB
22700 JRST AOUT.4 ;not available
22800 AOUT2: INIT X,
22900 AOUT3: X
23000 X
23100 JRST AOUT.4 ;cant init
23200 PUSH B,DEV
23300 OUTENT: ENTER X,ENTR
23400 JRST OUTERR ;cant enter
23500 PUSH B,[LPTLL] ;linelength
23600 PUSH B,[LPTLL] ;chrct
23700 ADDI B,6
23800 DAP B,JOBFF
23900 OUTOBF: OUTBUF X,NIOB
24000 JRST POPAJ
24100
24200 OUTERR: PUSHJ P,AIOP
24300 LDB A,[POINT 3,ENTR+1,35]
24400 CAIE A,2
24500 ERR1 [SIXBIT /DIRECTORY FULL !/]
24600 ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
24800 IOSEL: LAC C,-1(P)
24900 JUMPE C,CPOPJ ;tty
25000 JUMPE B,IOSELZ ;dont release
25100 DPB C,[POINT 4,.+1,ACFLD]
25200 RELEASE X, ;release channel
25300 HRRZS CHTAB(C) ;release channel table entry
25400 DAC 0,@CHTAB(C) ;blast channel name
25500 SETZM -1(P)
25600 IOSELZ: LAPZ C,CHTAB(C)
25700 POPJ P,
25900 INCNT: MOVEI A,NIL ;(INC NIL T)
26000 MOVEI B,TRUTH
26100
26200 INC: PUSH P,INCH#
26300 PUSHJ P,IOSEL
26400 JUMPN B,INC2 ;released channel
26500 SKIPN C
26600 MOVEI C,TTOCH-CHOCH ;tty deselect
26700 MOVEI B,CHOCH(C)
26800 HRLI B,OLDCH
26900 BLT B,CHLINE(C) ;save channel data
27000 INC2: JUMPE A,ITTYRE ;select tty
27100 LAC B,A
27200 PUSHJ P,TABSR1 ;determine physical channel number
27300 JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
27400 DAPZ A,INCH
27500 DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
27600 DPB A,[POINT 4,TYI2Y,ACFLD]
27700 DPB A,[POINT 4,TYI2Z,ACFLD]
27800 LAPZ A,CHTAB(A)
27900 MOVEI T,COUNT(A)
28000 HRLI T,(SOSG)
28100 MOVEI B,POINTR(A)
28200 DAP B,TYI3 ;set up tyi parameters
28300 DAP B,TYI3A
28400 INC3: MOVSI B,CHOCH(A)
28500 HRRI B,OLDCH
28600 BLT B,LINUM ;restore channel data
28700 DAC T,TYID
28800 IOEND: POP P,A
28900 JUMPE A,CPOPJ
29000 LAC A,CHTAB(A) ;get channel name
29100 LAPZ A,(A)
29200 TRZ A,400000 ;clear output bit
29300 POPJ P,
29400
29500 ITTYRE: SETZM INCH
29600 LAC T,[JRST TTYI] ;reselect tty
29700 MOVEI A,TTOCH-CHOCH
29800 JRST INC3
30000 OUTCNT: MOVEI A,0 ;(outc nil t)
30100 MOVEI B,1
30200
30300 OUTC: PUSH P,OUTCH#
30400 PUSHJ P,IOSEL
30500 JUMPN B,OUTC2 ;closed this file
30600 SKIPN C
30700 MOVEI C,TTOLL-CHLL ;tty deselect
30800 LAC B,CHCT
30900 DAC B,CHHP(C) ;save channel data
31000 LAC B,LINL
31100 DAC B,CHLL(C)
31200 OUTC2: JUMPE A,OTTYRE ;return to tty
31300 TRO A,400000 ;set output bit
31400 LAC B,A
31500 PUSHJ P,TABSR1 ;determine physical channel number
31600 JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
31700 DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
31800 DAPZ A,OUTCH
31900 LAPZ A,CHTAB(A)
32000 MOVEI B,POINTR(A)
32100 DAP B,TYO5 ;set up tyo2 parameters
32200 MOVEI T,COUNT(A)
32300 HRLI T,(SOSG)
32400 OUTC3: LAC B,CHLL(A)
32500 DAC B,LINL
32600 LAC B,CHHP(A)
32700 DAC B,CHCT
32800 DAC T,TYOD
32900 JRST IOEND
33000
33100 OTTYRE: SETZM OUTCH
33200 LAC T,[JRST TTYO]
33300 MOVEI A,TTOLL-CHLL ;tty reselect
33400 JRST OUTC3
33600 AIN.1: PUSHJ P,AIOP
33700 ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
33800 AOUT.2:
33900 AIN.2: PUSHJ P,AIOP
34000 ERR1 [SIXBIT /ILLEGAL DEVICE!/]
34100 AOUT.4:
34200 AIN.4: PUSHJ P,AIOP
34300 ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
34400 AIN.7: PUSHJ P,AIOP
34500 ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
34600
34700 AIN.8: SIXBIT /INPUT ERROR!/
34800
34900 AIOP: LAC A,DEVDAT
35000 JRST EPRINT
00100 SUBTTL PRINT --- PAGE 8
00200
00300 EPRINT: SKIPN ERRSW
00400 POPJ P,
00500 PUSHJ P,ERRIO
00600 PUSHJ P,PRINT
00700 JRST OUTRET
00800
00900 PRINT: MOVEI R,TYO
01000 PUSHJ P,TERPRI
01100 PUSHJ P,PRIN1
01200 XCT " ",CTY
01300 POPJ P,
01400
01500 PRINC: SKIPA R,.+1
01600 PRIN1: HRRZI R,TYO
01700 PUSH P,A
01800 PUSHJ P,PRINTA
01900 JRST POPAJ
02000
02100 PRINTA: PUSH P,A
02200 MOVEI B,PRIN3
02300 SKIPGE R
02400 MOVEI B,PRIN4
02500 DAP B,PRIN5
02600 PUSHJ P,PATOM
02700 JUMPN A,PRINT1
02800 XCT "(",CTY
02900 PRINT3: LIPZ A,@(P)
03000 PUSHJ P,PRINTA
03100 LAPZ A,@(P)
03200 JUMPE A,PRINT2
03300 DAC A,(P)
03400 XCT " ",CTY
03500 PUSHJ P,PATOM
03600 JUMPE A,PRINT3
03700 XCT ".",CTY
03800 XCT " ",CTY
03900 PUSHJ P,PRIN1A
04000 PRINT2: XCT ")",CTY
04100 JRST POPAJ
04200
04300 PRINT1: PUSHJ P,PRIN1A
04400 JRST POPAJ
04600 PRIN1A: LAC A,-1(P)
04700 CAILE A,INUMIN
04800 JRST PRINIC
04900 JUMPE A,PRIN1B
05000 CAMGE A,orgFWS
05100 CAMGE A,orgHWS
05200 JRST PRINL
05300 PRIN1B: LAPZ A,(A)
05400 JUMPE A,PRINL
05500 LIPZ B,(A)
05600 LAPZ A,(A)
05700 FOO CAIN B,PNAME
05800 JRST PRINN
05900 FOO CAIN B,FIXNUM
06000 JRST PRINI1
06100 FOO CAIN B,FLONUM
06200 JRST PRINO
06300 BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
06400 JRST PRIN1B
06500
06600 PRINL2: MOVEI R,TYO
06700 JRST PRINL1
06800
06900 PRINL: XCT "#",CTY
07000 LAPZ A,-1(P)
07100 PRINL1: MOVEI C,8
07200 JRST PRINI3
07300
07400 PRINI1: SKIPA A,(A)
07500 PRINIC: SUBI A,INUM0
07600 FOO LAPZ C,VBASE
07700 SUBI C,INUM0
07800 JUMPGE A,PRINI2
07900 XCT "-",CTY
08000 MOVNS A
08100 PRINI2: MOVEI B,"."-"0"
08200 DIP B,(P)
08300 CAIN C,TEN
08400 FOO SKIPE %NOPOINT
08500 JRST .+2
08600 PUSH P,PRINI4
08700 PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
08800 MOVEI A,1
08900 DIVI A,(C)
09000 JRST .+2]
09100 IDIVI A,0(C)
09200 DIP B,(P)
09300 SKIPE A
09400 PUSHJ P,.-3
09500 PRINI4: JRST FP7A1
09600
09700 PRINN: LIPZ A,(A)
09800 MOVEI C,2(SP)
09900 PUSHJ P,PNAMU3
10000 PUSH C,[0]
10100 HRLI C,(POINT 7,0,35)
10200 HRRI C,2(SP)
10300 ILDB A,C
10400 JUMPE A,CPOPJ ;special case of null character
10500 CAIN A,DBLQT
10600 JRST PSTR ;string
10700 PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
10800 JUMPL R,PRIN4 ;never slash
10900 JRST PRIN2(B) ;1 for no slash
11000
11100 PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
11200 PRIN2: XCT "/",CTY
11300 PRIN4: PUSHJ P,(R)
11400 ILDB A,C
11500 PRIN5: JUMPN A,PRIN3 ;prin4 for never slash
11600 POPJ P,
11700
11800 PSTR: MOVS B,(C)
11900 CAIN B,(<ASCII /"/>)
12000 JRST PRIN2X ;special case of /"
12100 PSTR3: SKIPL R ;dont print " if no slashify
12200 PSTR2: PUSHJ P,(R)
12300 ILDB A,C
12400 CAIE A,DBLQT
12500 JUMPN A,PSTR2
12600 JUMPN A,PSTR3
12700 POPJ P,
12800
12900 TERPRI: PUSH P,A
13000 MOVEI A,CR
13100 PUSHJ P,TYO
13200 MOVEI A,LF
13300 PUSHJ P,TYO
13400 JRST POPAJ
13500
13600 CTY: JSA A,TYOI
13700 TYOI: X
13800 PUSH P,A
13900 LDB A,[POINT 6,-1(A),ACFLD]
14000 PUSHJ P,(R)
14100 POP P,A
14200 JRA A,(A)
14300
14400 PRINO: LAC A,(A)
14500 CLEARB B,C
14600 JUMPG A,FP1
14700 JUMPE A,FP3
14800 MOVNS A
14900 XCT "-",CTY
15000 FP1: CAMGE A,FT01
15100 JRST FP4
15200 CAML A,FT8
15300 AOJA B,FP4
15400
15500 FP3: MULI A,400
15600 ASHC B,-243(A)
15700 LAC A,B
15800 CLEARM FPTEM#
15900 PUSHJ P,FP7
16000 XCT ".",CTY
16100 MOVNI T,8
16200 ADD T,FPTEM
16300 LAC B,C
16400
16500 FP3A: LAC A,B
16600 MULI A,TEN
16700 PUSHJ P,FP7B
16800 SKIPE B
16900 AOJL T,FP3A
17000 POPJ P,
17100
17200 FP4: MOVNI C,6
17300 MOVEI TT,0
17400 FP4A: ADDI TT,1(TT)
17500 XCT FCP(B)
17600 TRZA TT,1
17700 FMPR A,@FCP+1(B)
17800 AOJN C,FP4A
17900 PUSH P,TT
18000 MOVNI B,-2(B)
18100 DPB B,[POINT 2,FP4C,11]
18200 PUSHJ P,FP3
18300 MOVEI A,"E"
18400 PUSHJ P,(R)
18500 FP4C: XCT "+"+X,CTY
18600 POP P,A
18700 FP7: JUMPE A,FP7A1
18800 IDIVI A,TEN
18900 AOS FPTEM
19000 DIP B,(P)
19100 JUMPE A,FP7A1
19200 PUSHJ P,FP7
19300
19400 FP7A1: HLRE A,(P)
19500 FP7B: ADDI A,"0"
19600 JRST (R)
19700
19800 353473426555 ;1e32
19900 266434157116 ;1e16
20000 FT8: 1.0E8
20100 1.0E4
20200 1.0E2
20300 1.0E1
20400 FT: 1.0E0
20500 026637304365 ;1e-32
20600 113715126246 ;1e-16
20700 146527461671 ;1e-8
20800 163643334273 ;1e-4
20900 172507534122 ;1e-2
21000 FT01: 175631463146 ;1e-1
21100 FT0:
21200 FCP: CAMLE A,FT0(C)
21300 CAMGE A,FT(C)
21400 XWD C,FT0
21500
00100 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
00200
00300 ;magic scanner table bit definitions
00400
00500 ;bit 0=0 iff slashified as 1st id character
00600 ;bit 1=0 iff slashified as nth id character
00700 ;bits 2-5 ratab index
00800 ;bits 6-8 dotab index
00900 ;bits 9-10 strtab index
01000 ;bits 11-13 idtab index
01100 ;bits 14-16 exptab index
01200 ;bits 17-19 rdtab index
01300 ;bits 20-25 ascii to radix 50 conversion
01400
01500 IGSTRT: IGCRLF
01600 IGEND: LF
01700
01800 RATFLD: POINT 4,CHRTAB(A),5
01900 STRFLD: POINT 2,CHRTAB(A),10
02000 IDFLD: POINT 3,CHRTAB(A),13
02100 DOTFLD:
02200 NUMFLD: POINT 3,CHRTAB(A),8
02300 EXPFLD: POINT 3,CHRTAB(A),16
02400 RDFLD: POINT 3,CHRTAB(A),19
02500 R50FLD: POINT 6,CHRTAB(A),25
02600
02700 ;magic state flags in t
02800 EXP==1 ;exponent
02900 NEXP==2 ;negative exponent
03000 SAWDOT==4 ;saw a dot (.)
03100 MINSGN==10 ;negative number
03200
03300 IDCLS==0 ;identifier
03400 STRCLS==1 ;string
03500 NUMCLS==2 ;number
03600 DELCLS==3 ;delimiter
03700
03900 ;macros for scanner table
04000
04100 DEFINE RAD50 (X)<
04200 IFB <X>,<R50VAL=0>
04300 IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
04400 IFIDN <"X"><".">,<R50VAL=45>
04500 IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
04600
04700 DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
04800 XLIST
04900 IRPC R50< RAD50 (R50)
05000 BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
05100 LIST>
05200
05300 DEFINE LET (X)<
05400 TABIN (1,1,5,2,3,4,2,0,X)>
05500
05600 DEFINE DELIMIT (X,Y)<
05700 TABIN (0,0,2,2,3,2,2,Y,X)>
05800
05900 DEFINE IGNORE (X)<
06000 TABIN (0,0,3,2,3,2,2,0,X)>
06200 CHRTAB:
06300 TABIN (0,0,1,1,1,1,1,0,< >)
06400 ;null
06500 LET (< >)
06600 IGNORE (< >)
06700 ;tab,lf,vtab,ff,cr
06800 LET (< >)
06900 ;16 to 31
07000 TABIN (0,0,0,0,0,0,0,0,< >)
07100 ;igmrk
07200 LET (< >)
07300 ;33 to 37
07400 IGNORE (< >)
07500 ;space
07600 LET (< >)
07700 ;!
07800 TABIN (0,0,9,2,2,2,2,0,< >)
07900 ;"
08000 LET (< $% >)
08100 ;#$%&'
08200 DELIMIT (< >,0)
08300 DELIMIT (< >,1)
08400 ;()
08500 LET (< >)
08600 ;*
08700 TABIN (1,0,3,2,3,4,2,0,< >)
08800 ;+
08900 IGNORE (< >)
09000 ;,
09100 TABIN (1,0,6,2,3,4,2,0,< >)
09200 ;-
09300 TABIN (0,0,7,3,3,2,2,4,<.>)
09400 TABIN (0,0,4,2,3,3,2,0,< >)
09500 ;/
09600 TABIN (1,0,8,5,3,4,3,0,<0123456789>)
09700 LET (< >)
09800 ;:;<=>?
09900 TABIN (1,0,2,2,3,4,2,5,< >)
10000 ;@
10100 LET (<ABCD>)
10200 TABIN (1,1,5,4,3,4,2,0,<E>)
10300 LET (<FGHIJKLMNOPQRSTUVWXYZ>)
10400 DELIMIT (< >,2)
10500 ;[
10600 LET (< >)
10700 ;\
10800 DELIMIT (< >,3)
10900 ;]
11000 LET (< >)
11100 ;↑←`
11200 LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
11300 ;lower case
11400 LET (< >)
11500 ;{¬
11600 DELIMIT (< >,3)
11700 ;altmode
11800 LET (< >)
11900 ;}
12000 DELIMIT (< >,6)
12100 ;rubout
12300 READCH: PUSHJ P,TYI
12400 MOVSI AR1,AR1
12500 PUSHJ P,EXPL1
12600 JRST CAR
12700
12800 READP1: SETZM NOINFG
12900 READ0: PUSH P,TYID
13000 PUSH P,OLDCH
13100 SETZM OLDCH#
13200 HRLI A,(JRST)
13300 DAC A,TYID
13400 PUSHJ P,READ+1
13500 POP P,OLDCH
13600 POP P,TYID
13700 POPJ P,
13800
13900 RDRUB: MOVEI A,CR
14000 PUSHJ P,TTYO
14100 MOVEI A,LF
14200 PUSHJ P,TTYO
14300 SKIPA P,PSAV#
14400 READ: SETZM NOINFG# ;0 means intern
14500 DAC P,PSAV
14600 PUSHJ P,READ1
14700 SETZM PSAV
14800 POPJ P,
14900
15000 READ1: PUSHJ P,RATOM
15100 POPJ P, ;atom
15200 XCT RDTAB2(B)
15300 JRST READ1 ;try again
15400
15500 RDTAB2: JRST READ2 ;0 (
15600 JFCL ;1 )
15700 JRST READ4 ;2 [
15800 JFCL ;3 ],$
15900 JFCL ;4 .
16000 JRST RDQT ;5 @
16100
16200 READ2: PUSHJ P,RATOM
16300 JRST READ2A ;atom
16400 XCT RDTAB(B)
16500
16600 READ2A: PUSH P,A
16700 PUSHJ P,READ2
16800 POP P,B
16900 JRST XCONS
17000
17100 RDTAB: PUSHJ P,READ2 ;0 (
17200 JRST FALSE ;1 )
17300 PUSHJ P,READ4 ;2 [
17400 JRST READ5 ;3 ],$
17500 JRST RDT ;4 .
17600 PUSHJ P,RDQT ;5 @
17700
17800 RDTX: PUSHJ P,RATOM
17900 POPJ P, ;atom
18000 XCT RDTAB2(B)
18100 JRST DOTERR ;dot context error
18200
18300 RDT: PUSHJ P,RDTX
18400 PUSH P,A
18500 PUSHJ P,RATOM
18600 JRST DOTERR
18700 CAIN B,1
18800 JRST POPAJ
18900 CAIE B,3
19000 JRST DOTERR
19100 DAC A,OLDCH
19200 JRST POPAJ
19300
19400
19500 READ4: PUSHJ P,READ2
19600 LAC B,OLDCH
19700 CAIE B,ALTMOD
19800 TYI1: SETZM OLDCH ;kill the ]
19900 POPJ P,
20000
20100 READ5: DAC A,OLDCH ;save ] or $
20200 JRST FALSE ;and return nil
20300
20400
20500 RDQT: PUSHJ P,READ1
20600 JRST QTIFY
20800 ;atom parser
20900
21000 COMMENT: PUSHJ P,TYID
21100 CAME A,IGEND
21200 JRST COMMENT
21300 POPJ P,
21400
21500 RATOM: SETZB T,R
21600 HRLI C,(POINT 7,0,35)
21700 HRRI C,(SP)
21800 MOVEI AR1,1
21900 RATOM2: PUSHJ P,TYIA
22000 LDB B,RATFLD
22100 JRST RATAB(B)
22200
22300 RATAB: PUSHJ P,COMMENT ;0 comment
22400 JRST RATOM2 ;1 null
22500 JRST RATOM3 ;2 delimit
22600 JRST RATOM2 ;3 ignore
22700 PUSHJ P,TYI ;4 /
22800 JRST RDID ;5 letter
22900 JRST RDNMIN ;6 -
23000 JRST RDOT ;7 .
23100 JRST RDNUM ;8 digit
23200 JRST RDSTR ;9 string
23300
23400 ;a real dotted pair
23500 RDOT2: DAC A,OLDCH
23600 MOVEI A,"."
23700 RATOM3: LDB B,RDFLD
23800 HRRI R,DELCLS ;delimiter
23900 AOS (P) ;non-atom (ie a delimiter)
24000 POPJ P,
24100
24200 ;dot handler
24300 RDOT: PUSHJ P,TYID
24400 LDB B,DOTFLD
24500 JRST DOTAB(B)
24600
24700 DOTAB: PUSHJ P,COMMENT ;0 comment
24800 JRST RDOT ;1 null
24900 JRST RDOT2 ;2 delimit
25000 JRST RDOT2 ;3 dot
25100 JRST RDOT2 ;4 e
25200 MOVEI B,0 ;5 digit
25300 IDPB B,C
25400 TLO T,SAWDOT
25500 JRST RDNUM
25700 ;string scanner
25800 STRTAB: PUSHJ P,COMMENT ;0 comment
25900 JRST RDSTR+1 ;1 null
26000 JRST STR2 ;2 delimit
26100 RDSTR: IDPB A,C ;3 string element
26200 PUSHJ P,TYID
26300 LDB B,STRFLD
26400 JRST STRTAB(B)
26500
26600 STR2: MOVEI A,DBLQT
26700 HRRI R,STRCLS ;string
26800 IDPB A,C
26900 NOINTR: PUSHJ P,IDEND ;no intern
27000 PUSHJ P,IDSUB
27100 JRST PNAMAK
27200
27300
27400 ;identifier scanner
27500 IDTAB: PUSHJ P,COMMENT ;0
27600 JRST RDID+1 ;1 null
27700 JRST MAKID ;2 delimit
27800 PUSHJ P,TYI ;3 /
27900 RDID: IDPB A,C ;4 letter or digit
28000 PUSHJ P,TYID
28100 LDB B,IDFLD
28200 JRST IDTAB(B)
28300
28500 ;number scanner
28600 NUMTAB: PUSHJ P,COMMENT ;0 comment
28700 JRST RDNUM+1 ;1 null
28800 JRST NUMAK ;2 delimit
28900 JRST RDNDOT ;3 dot
29000 JRST RDE ;4 e
29100 RDNUM: IDPB A,C ;5 digit
29200 PUSHJ P,TYID
29300 LDB B,NUMFLD
29400 JRST NUMTAB(B)
29500
29600 RDNDOT: TLOE T,SAWDOT
29700 JRST NUMAK ;two dots - delimit
29800 MOVEI A,0
29900 JRST RDNUM
30000
30100 RDNMIN: TLO T,MINSGN
30200 JRST RDNUM+1
30300
30400 ;exponent scanner
30500 RDE: TLO T,EXP
30600 MOVEI A,0
30700 IDPB A,C
30800 PUSHJ P,TYID
30900 CAIN A,"-"
31000 TLOA T,NEXP
31100 CAIN A,"+"
31200 JRST RDE2+1
31300 JRST RDE2+2
31400
31500 EXPTAB: PUSHJ P,COMMENT ;0
31600 JRST RDE2+1 ;1 null
31700 JRST NUMAK ;2 delimit
31800 RDE2: IDPB A,C ;3 digit
31900 PUSHJ P,TYID
32000 LDB B,EXPFLD
32100 JRST EXPTAB(B)
32300 ;semantic routines
32400 ;identifier interner and builder
32500
32600 IDEND: TDZA A,A
32700 IDEND1: IDPB A,C
32800 TLNE C,760000
32900 JRST IDEND1
33000 POPJ P,
33100
33200 MAKID: DAC A,OLDCH
33300 PUSHJ P,IDEND
33400 SKIPE NOINFG
33500 JRST NOINTR ;dont intern it
33600 INTER0: PUSHJ P,IDSUB
33700 PUSHJ P,INTER1 ;is it in oblist
33800 POPJ P, ;found
33900 PUSHJ P,PNAMAK ;not there
34000 MAKID2: LAC C,CURBUC ;
34100 LIPZ B,@RHX2
34200 PUSHJ P,CONS ;cons it into the oblist
34300 DIP A,@RHX2
34400 JRST CAR
34500 CURBUC: 0
34600
34700 ;pname unmaker
34800 PNAMUK:
34900 FOO MOVEI B,PNAME
35000 PUSHJ P,GET
35100 JUMPE A,NOPNAM
35200 LAC C,SP
35300 PNAMU3: LIPZ B,(A)
35400 PUSH C,(B)
35500 LAPZ A,(A)
35600 JUMPN A,PNAMU3
35700 POPJ P,
35800
35900 ;idsub constructs a iowd pointer for a print name
36000 IDSUB: HRRZS C
36100 CAML C,endSPD ;top of spec pdl
36200 JRST SPDLOV
36300 MOVNS C
36400 ADDI C,(SP)
36500 HRLI C,1(SP)
36600 MOVSM C,IDPTR#
36700 POPJ P,
36800
36900 ;identifier interner
37000 INTER1: LAC B,1(SP) ;get first word of pname
37100 LSH B,-1 ;right justify it
37200 INT1: IDIVI B,BCKETS+X ;compute hash code
37300 RHX2:
37400 FOO LIPZ TT,OBTBL(B+1) ;get bucket
37500 DAC B+1,CURBUC ;save bucket number
37600 LAC T,TT
37700 JRST MAKID1
37800
37900 MAKID3: LAC TT,T ;save previous atom
38000 LAPZ T,(T) ;get next atom
38100 MAKID1: JUMPE T,CPOPJ1 ;not in oblist
38200 LIPZ A,(T) ;next id in oblist
38300 MAKID4: LAPZ A,(A)
38400 JUMPE A,NOPNAM ;no print name
38500 LAC A,(A)
38600 LIPZ C,A
38700 FOO CAIE C,PNAME
38800 JRST MAKID4
38900 LAC C,IDPTR ;found pname
39000 LIPZ A,(A)
39100 MAKID5: JUMPE A,MAKID3 ;not the one
39200 MOVS A,(A)
39300 LAC B,(A)
39400 ANDCAM AR1,(C) ;clear low bit
39500 CAME B,(C)
39600 JRST MAKID3 ;not the one
39700 LIPZ A,A ;ok so far
39800 AOBJN C,MAKID5
39900 JUMPN A,MAKID3 ;not the one
40000 LIPZ A,(T) ;this is it
40100 LIPZ B,(TT)
40200 DIP A,(TT)
40300 DIP B,(T)
40400 POPJ P,
40500
40600 ;pname builder
40700 PNAMAK: LAC T,IDPTR
40800 PUSHJ P,NCONS
40900 LAC TT,A
41000 LAC C,A
41100 PNAMB: LAC A,(T)
41200 TRZ A,1 ;clear low bit!!!!!
41300 PUSHJ P,FWCONS
41400 PUSHJ P,NCONS
41500 DAP A,(TT)
41600 LAC TT,A
41700 AOBJN T,PNAMB
41800 LAC A,C
41900 HRLZS (A)
42000 JRST PNGNK1+1
42200 ;number builder
42300 NUMAK: DAC A,OLDCH
42400 HRRI R,NUMCLS ;number
42500 MOVEI A,0
42600 IDPB A,C
42700 IDPB A,C
42800 HRRZS C
42900 CAML C,endSPD ;top of spec pdl
43000 JRST SPDLOV
43100 MOVSI C,(POINT 7,0,35)
43200 HRRI C,(SP)
43300 TLNE T,SAWDOT+EXP
43400 JRST NUMAK2 ;decimal number or flt pt
43500 FOO LAC A,VIBASE ;ibase integrer
43600 SUBI A,INUM0
43700 PUSHJ P,NUM
43800 NUMAK4:
43900 FOO MOVEI B,FIXNUM
44000 NUMAK6: TLNE T,MINSGN
44100 MOVNS A
44200 JRST MAKNUM
44300
44400 NUMAK2: PUSHJ P,NUM10
44500 DAC A,TT
44600 TLNN T,SAWDOT
44700 JRST [ PUSHJ P,FLOAT ;flt pt without fraction
44800 LAC TT,A
44900 JRST NUMAK3]
45000 PUSHJ P,NUM10 ;fraction part
45100 EXCH A,TT
45200 TLNN T,EXP
45300 JUMPE AR2A,NUMAK4 ;no exponent and no fraction
45400 PUSHJ P,FLOAT
45500 EXCH A,TT
45600 PUSHJ P,FLOAT
45700 MOVEI AR1,FT01
45800 PUSHJ P,FLOSUB
45900 FMPR A,B
46000 FADRM A,TT
46100 NUMAK3: PUSHJ P,NUM10 ;exponent part
46200 LAC AR2A,A
46300 MOVEI AR1,FT-1
46400 TLNE T,NEXP
46500 MOVEI AR1,FT01 ;-exponent
46600 PUSHJ P,FLOSUB
46700 FMPR TT,B ;positive exponent
46800 FOO MOVEI B,FLONUM
46900 LAC A,TT
47000 JFCL 10,FLOOV
47100 JRST NUMAK6
47200
47300 FLOSUB: MOVSI B,(1.0)
47400 TRZE AR2A,1
47500 FMPR B,(AR1)
47600 JUMPE AR2A,CPOPJ
47700 LSH AR2A,-1
47800 SOJA AR1,FLOSUB+1
47900
48000 ;variable radix integer builder
48100
48200 NUM10: MOVEI A,TEN
48300 NUM: DAP A,NUM1
48400 JFCL 10,.+1 ;clear CARRY0 flag
48500 SETZB A,AR2A
48600 NUM2: ILDB B,C
48700 JUMPE B,CPOPJ ;done
48800 NUM1: IMULI A,X
48900 ADDI A,-"0"(B)
49000 NUM3: JFCL 10,FIXOV ;bignums change this to JFCL 10,RDBNM
49100 AOJA AR2A,NUM2
49300 INTERN: DAC A,AR2A
49400 PUSHJ P,PNAMUK
49500 PUSHJ P,IDSUB
49600 MOVEI AR1,1
49700 PUSHJ P,INTER1 ;is it in oblist
49800 POPJ P, ;found it
49900 LAC A,AR2A ;not there
50000 JRST MAKID2 ;put it there
50100
50200 REMOB: JUMPE A,FALSE
50300 MOVEI AR1,1
50400 PUSH P,A
50500 LIPZ A,(A)
50600 PUSHJ P,INTERN
50700 LIPZ B,@(P)
50800 CAME A,B
50900 JRST REMOB2
51000 LAPZ B,CURBUC
51100 RHX5:
51200 FOO LIPZ C,OBTBL+X(B)
51300 LIPZ T,(C)
51400 CAMN T,A
51500 JRST [ LAPZ TT,(C)
51600 DIP TT,@RHX5
51700 JRST REMOB2]
51800 REMOB3: LAC TT,C
51900 LAPZ C,(C)
52000 LIPZ T,(C)
52100 CAME T,A
52200 JRST REMOB3
52300 LAPZ T,(C)
52400 DAP T,(TT)
52500 REMOB2: POP P,A
52600 LAPZ A,(A)
52700 JRST REMOB