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