;******	COMMON ROUTINES ALL ALL SEGMENTS

	SEARCH	S

IFNDEF	BASEDT,<BASEDT==0>		;EDIT PHASE
IFNDEF	BASCOM,<BASCOM==0>		;COMPILE PHASE
IFNDEF	BASXCT,<BASXCT==0>		;EXECUTE PHASE

IFNDEF	BASEC,<BASEC==BASEDT!BASCOM>
IFNDEF	BASEX,<BASEX==BASEDT!BASXCT>
IFNDEF	BASCX,<BASCX==BASCOM!BASXCT>

IFN	BASEDT,<TITLE	EDTLIB>
IFN	BASCOM,<TITLE	COMLIB>
IFN	BASXCT,<TITLE	XCTLIB>

	EXTERN INLNFG,INPFLA,LIBFLG
	EXTERN CEIL,CHAFL2,COPFLG,CURBAS,CURDEV,CUREXT,CURNAM,DEVBAS
	EXTERN DRMBUF,FILDIR,FLOOR,HPOS,IFIFG,ODF,RENFLA,RENDON
	EXTERN SAVE1,STARFL,TTYBUF,TTYIN,TYI,TYO
	EXTERN .JBFF,.JBREL

	XLIST
	IFN	BASEDT,<
	LIST
	EXTERN EDTXIT,LRUNNH
	UXIT=EDTXIT
	RUNNH=LRUNNH

	EXTERN BASIC,COMM1,FIXUP,LINROL,RTIME,RUNFLA
	EXTERN SAVFIL,TEMLOC,UNSATP,UNSER

	INTERN ERACOM,SCN2,CLOSUP,QST,BUMPRL,SCN3,RPUSH
	INTERN PANIC1,CTTAB,GETNU,OUTCNT,PTXER1,LINPT
	INTERN OUTPT,EOFFL,GOSR2,GOSR3,DPBSTR
	INTERN EOFFAL,INERR,OUCHX
	INTERN NOGETD,ERASE,INLSYS,XXXXXX,PRTOCT
	INTERN INLB1,INLINE,INLGEN,EDTXT1,DATTBL
	INTERN OUTERR,OUTLMS,OUTQMS,DSKOT,DOS
	INTERN SCNLT1,CPOPJ1,CPOPJ,NXCHD2,SCNLT3,NXCHD,CLOB,QSA
	INTERN INLMES,INLME1,NXCHS,PRINT,PRNSIX,NXCH,ATOMSZ,FILNAM
	INTERN PRNNAM,PANIC,OUCH,FILNM1,SEARCH,SCNLT2,FILNMO,ERRMS2
	INTERN OPENUP,QSAX,ERRMS3,ERRMSG,PRESS,GETNUM,GTNUMB,LOCKON
	INTERN SKIPDA,DATCHK,DECFLO,DECTAB,D1EM4,QSELS,QSKIP,FIXCON
	INTERN EVANUM,D1EM18,D1E14,DECCEI
	INTERN LOCKOF,ALPHSX

	DEFINE	FAIL(A,AC)<
	XWD	001000+AC'00,[ASCIZ /A/]
>


	DEFINE	INLEMS(C,A,B),<
	JRST	[MOVEI	T,B
		JRST	ERRMSG]
>
	DEFINE	INLERR(C,A,B),<
	PUSHJ	P,INLMES
	ASCIZ	B
>
	DEFINE	ERROM(A,B),<
	ASCIZ	B
>

	XLIST
>

	IFN	BASCOM,<
	LIST
	EXTERN LBASIC
	BASIC=LBASIC
	EXTERN LUXIT
	INTERN SKIPDA,NXCHD2,NXCHS,INLME1,PRNSIX,ATOMSZ
	INTERN DECTAB,D1EM4,BASORT,FILNM1,PANIC,FIXCON,CTTAB
	INTERN QSAX,D1EM18,D1E14,QSELS,ALPHSX,DECFLO,DECCEI
	INTERN SCNLT1,CPOPJ1,ERACOM,CPOPJ,SCN2,PRINT,NXCHD,SCNLT3
	INTERN SCNLT2,QST,CLOB,QSA,INLMES,BUMPRL,CLOSUP,SCN3,VSUB1
	INTERN DATCHK,NXCH,FILNAM,RPUSH,PRNNAM,PANIC1,OUCH,EVANUM
	INTERN SEARCH,FILNMO,OPENUP,ERRMS2,GETNU,ERRMS3,ERRMSG
	INTERN PRESS,GETNUM,GTNUMB,LOCKON,LOCKOF,QSKIP

	DEFINE	ERROM(A,B),<
	ASCIZ	B
>

	DEFINE INLEMS(C,A,B),<
	JRST	[MOVEI	T,B
		JRST	ERRMSG]
>

	DEFINE	FAIL(A,AC),<
	XWD	001000+AC'00,[ASCIZ /A/]
>
	XLIST
>
	XLIST
	IFN	BASXCT,<
	LIST
	EXTERN UXIT,LUXIT1
	UXIT1=LUXIT1
	BASIC=UXIT
	RUNNH=UXIT

	EXTERN .USREL,RUNDDT,NOLINE,NOTLIN

	EXTERN APPMAX,CHAER1,CHAXIT,CLSRAN,CRLF3,EOF31,EOF32,ERRTCN
	EXTERN ERRXCX,ERRXCY,ERRBPT,EXTD,FCNLNK,FILD,FPPN
	EXTERN INITO,LOK,LOKUP,MARGIN,MARWAI,MONLVL
	EXTERN OPS1,PAGLIM,PRDLER,QUOTBL,RENAMD,WRIPRI
	EXTERN REUXIT,TEMLOC,UXFLAG

	INTERN XXXXXX,SCNLTN
	INTERN PRINT,INLME1,QST,ATOMSZ,FILNM1,QSAX
	INTERN GETNU,ALPHSX,OUTCNT,OUTPT,PRTOCT
	INTERN UXIT7,UXIT6,DPBSTR,NOGETD,INLSYS
	INTERN PTXER1,LINPT,OUCH
	INTERN DATTBL,EOFFL,GOSR2,GOSR3,INLINE,INLB1,INLGEN
	INTERN OUTERR,OUTLMS,OUTQMS,DSKOT,DOS
	INTERN SKIPDA,D1E14,CPOPJ,CPOPJ1,NXCHD,NXCHD2,VPANIC
	INTERN NXCHS,QSA,INLMES,PRNSIX,VSUB1,DATCHK,NXCH,FILNAM,PRNNAM
	INTERN DECTAB,FIXCON,D1EM4,BASORT,CTTAB,EVANUM,SEARCH
	INTERN FILNMO,ERRMS3,D1EM18,GETNUM,GTNUMB,LOCKOF,LOCKON
	INTERN DECCEI,DECFLO,QSKIP

	DEFINE	INLERR(C,A,B),<
	BYTE (9) 1,0,^D'C,^D'A
>
	DEFINE	ERROM(A,B),<
>

	DEFINE	INLEMS(C,A,B),<
	JRST	[BYTE (9) 1,0,^D'C,^D'A
		JRST	GOSR2]
>

	XLIST
>
	XLIST
	IFN	BASEC,<
	LIST
	EXTERN CELIN,CETXT,CODROL,COMTOP,FLLIN,FLTXT
	EXTERN OLDCOD,PAKFLA,ROLTOP,SEXROL,TOPSTG
	XLIST
>
	IFN	BASEX,<
	LIST
	EXTERN ACTBL,CHAFLG,COMTIM,DDTFLG,FUNAME,GTSTS
	EXTERN INDSK,MTIME,NUMCOT,OUTTDS,PLIST,PRTNUM
	EXTERN SORCLN,STADSK,STODSK,STRCTR,STRPTR
	XLIST
>
	IFN	BASCX,<
	LIST
	EXTERN APPLST,BA,CEVSP,CORINC,FLVSP,INPFLA,LIBFLG
	EXTERN MASAPP,NUMAPP,NUMMSP,SRTDBA,SVRBOT
	EXTERN SVRTOP,VARFRE,VPAKFL,VRFBOT,VRFBTB,VRFTOP
	XLIST
>
	LIST

	RELOC
	HISEG

CTTAB:
	XWD	F.NU,	F.STR	;NULL	, @
	XWD	F.STR,	F.LETT	;	, A
	XWD	F.STR,	F.LETT	;	, B
	XWD	F.STR,	F.LETT	;	, C
	XWD	F.STR,	F.LETT	;	, D
	XWD	F.STR,	F.LETT	;	, E
	XWD	F.STR,	F.LETT	;	, F
	XWD	F.STR,	F.LETT	;	, G
	XWD	F.STR,	F.LETT	;	, H
	XWD	F.SPTB, F.LETT	;TAB	, I
	XWD	F.CR,	F.LETT	;LF	, J
	XWD	F.CR,	F.LETT	;VER.TAB, K
	XWD	F.CR,	F.LETT	;FFEED	, L
	XWD	F.CR,	F.LETT	;CR	, M
	XWD	F.STR,	F.LETT	;	, N
	XWD	F.STR,	F.LETT	;	, O
	XWD	F.STR,	F.LETT	;	, P
	XWD	F.STR,	F.LETT	;	, Q
	XWD	F.STR,	F.LETT	;	, R
	XWD	F.STR,	F.LETT	;	, S
	XWD	F.STR,	F.LETT	;	, T
	XWD	F.STR,	F.LETT	;	, U
	XWD	F.STR,	F.LETT	;	, V
	XWD	F.STR,	F.LETT	;	, W
	XWD	F.STR,	F.LETT	;	, X
	XWD	F.STR,	F.LETT	;	, Y
	XWD	F.STR,	F.LETT	;	, Z
	XWD	F.ESC,	F.STR	;ESC	, [
	XWD	F.STR,	F.APOS	;	, \
	XWD	F.STR,	F.STR	;	, ]
	XWD	F.STR,	F.OTH	;	, ^
	XWD	F.STR,	F.OTH	;	, _
	XWD	F.SPTB, F.STR		;SPACE	, <ACCENT GRAVE>
	XWD	F.STR,	F.LETT+F.LCAS	; !	, <LOWER CASE> A
	XWD	F.QUOT, F.LETT+F.LCAS	; "	, <LOWER CASE> B
	XWD	F.STR,	F.LETT+F.LCAS	; #	, <LOWER CASE> C
	XWD	F.DOLL, F.LETT+F.LCAS	; $	, <LOWER CASE> D
	XWD	F.STR,	F.LETT+F.LCAS	; %	, <LOWER CASE> E
	XWD	F.OTH,	F.LETT+F.LCAS	; &	, <LOWER CASE> F
	XWD	F.APOS, F.LETT+F.LCAS	; '	, <LOWER CASE> G
	XWD	F.OTH,	F.LETT+F.LCAS	; (	, <LOWER CASE> H
	XWD	F.RPRN, F.LETT+F.LCAS	; )	, <LOWER CASE> I
	XWD	F.STAR, F.LETT+F.LCAS	; *	, <LOWER CASE> J
	XWD	F.PLUS, F.LETT+F.LCAS	; +	, <LOWER CASE> K
	XWD	F.COMA, F.LETT+F.LCAS	; ,	, <LOWER CASE> L
	XWD	F.MINS, F.LETT+F.LCAS	; -	, <LOWER CASE> M
	XWD	F.PER,	F.LETT+F.LCAS	; .	, <LOWER CASE> N
	XWD	F.SLSH, F.LETT+F.LCAS	; /	, <LOWER CASE> O
	XWD	F.DIG,	F.LETT+F.LCAS	; 0	, <LOWER CASE> P
	XWD	F.DIG,	F.LETT+F.LCAS	; 1	, <LOWER CASE> Q
	XWD	F.DIG,	F.LETT+F.LCAS	; 2	, <LOWER CASE> R
	XWD	F.DIG,	F.LETT+F.LCAS	; 3	, <LOWER CASE> S
	XWD	F.DIG,	F.LETT+F.LCAS	; 4	, <LOWER CASE> T
	XWD	F.DIG,	F.LETT+F.LCAS	; 5	, <LOWER CASE> U
	XWD	F.DIG,	F.LETT+F.LCAS	; 6	, <LOWER CASE> V
	XWD	F.DIG,	F.LETT+F.LCAS	; 7	, <LOWER CASE> W
	XWD	F.DIG,	F.LETT+F.LCAS	; 8	, <LOWER CASE> X
	XWD	F.DIG,	F.LETT+F.LCAS	; 9	, <LOWER CASE> Y
	XWD	F.OTH,	F.LETT+F.LCAS	; :	, <LOWER CASE> Z
	XWD	F.OTH,	F.STR		; ;	, <LEFT BRACE>
	XWD	F.OTH,	F.STR		; <	, <VERTICAL BAR>
	XWD	F.EQAL, F.STR		; =	, <RIGHT BRACE>
	XWD	F.OTH,	F.STR		; >	, <TILDE>
	XWD	F.STR,	F.STR		; ?	, <RUBOUT>
	XLIST
	IFN	BASEX,<
	LIST
DATTBL: ASCIZ	/JAN/		;TABLE OF MONTHS, USED BY HEADING TYPEOUT.
	ASCIZ	/FEB/
	ASCIZ	/MAR/
	ASCIZ	/APR/
	ASCIZ	/MAY/
	ASCIZ	/JUN/
	ASCIZ	/JUL/
	ASCIZ	/AUG/
	ASCIZ	/SEP/
	ASCIZ	/OCT/
	ASCIZ	/NOV/
	ASCIZ	/DEC/
	XLIST
>
	LIST
SUBTTL	COMMAND SUBROUTINES
 
;ROUTINE TO PICK UP FILE NAME AND SET UP FOR DSK ACTION.
;THE FLAG COPFLG IS EXPLAINED AT THE COPY ROUTINE COPER.
 
FILNAM: SETZM	COPFLG
FILNM1: POP	P,B		;COPER ENTERS HERE, WITH COPFLG = -1.
	SETZM	DEVBAS
	MOVEI	A,<SIXBIT /   DSK/>
	HRLI	A,<SIXBIT /   BAS/>
	HRLZM	A,@(B)
	HLLZM	A,FILDIR+1
	MOVEI	X2,FILDIR
	PUSHJ	P,ATOMSZ
	SETZM	STARFL		;=0, MEANS DEVICE NOT YET SEEN.
	MOVEI	X1,":"		;DEVICE INDICATOR.
	CAIE	X1,(C)
	JRST	FILN1
	JUMPE	A,COMM2
	SETOM	STARFL		;LT.0, MEANS EXPLICIT DEVICE SEEN.
	MOVEM	A,DEVBAS
	MOVEM	A,@(B)
	PUSHJ	P,NXCH
	PUSHJ	P,ATOMSZ
	XLIST
	IFN	BASEDT,<
	LIST
	SKIPL	COPFLG
	JRST	FILN1
	JUMPN	A,FILN1
	SETZM	COPFLG
	JRST	1(B)
	XLIST
>
	IFN	BASCX,<
	LIST
	JRST	FILN1
	XLIST
>
	LIST
FILNMO: POP	P,B		;ENTRY POINT FOR NO DEVICE ALLOWED.
	MOVEI	A,<SIXBIT/   DSK/>
	HRLZM	A,@(B)
	SETZM	COPFLG
	HRRI	A,<SIXBIT /   BAS/>
	HRLZM	A,FILDIR+1
	MOVEM	A,STARFL	;GT.0, MEANS NO DEVICE ALLOWED.
	MOVEI	X2,FILDIR
	PUSHJ	P,ATOMSZ
FILN1:	SETZM	FILDIR+2
	SETZM	FILDIR+3
	TLNN	C,F.PER 	;PERIOD SEEN?
	JRST	FILN2
	JUMPE	A,COMM2
	MOVEM	A,FILDIR
	MOVEI	X2,FILDIR+1
	PUSHJ	P,NXCH
	PUSHJ	P,ATOMSZ
FILN2:	JUMPN	A,FILN3
	CAIE	X2,FILDIR
	JRST	FILN3
	XLIST
	IFN	BASEDT,<
	LIST
	HRRZ	A,B
	CAIN	A,SAVFIL+1	;ONLY SAVE AND UNSAVE CAN OMIT THE FILENAME.
	JRST	FILN9
	CAIL	A,UNSER
	CAILE	A,UNSATP
	JRST	COMM2
FILN9:	MOVE	A,CURNAM
	MOVEM	A,FILDIR
	HLLZ	A,CUREXT
	MOVEM	A,FILDIR+1
	JRST	FILN5
	XLIST
>
	IFN	BASCX,<
	LIST
	JRST	COMM2
	XLIST
>
	LIST
FILN3:	CAIN	X2,FILDIR
	JRST	FILN4
	TRNE	A,777777	;ONLY 3 CHARACTERS ALLOWED
	JRST	COMM2		;IN THE EXT.
FILN4:	MOVEM	A,(X2)
	XLIST
	IFN	BASEDT,<
	LIST
FILN5:	SKIPLE	STARFL		;POSSIBLE ***?
	JRST	FILN6		;NO.
	SKIPL	STARFL
	JRST	FILN51
	MOVE	A,DEVBAS	;ALREADY SEEN A DEVICE.
	CAME	A,[SIXBIT/BAS/]
	JRST	FILN6
FILN50: DEVCHR	A,
	JUMPN	A,FILN6
	MOVE	A,[XWD 5,1]
	MOVEM	A,FILDIR+3
	MOVEI	A,<SIXBIT/   DSK/>
	HRLZM	A,@(B)
	MOVSI	A,(SIXBIT/BAS/)
	MOVEM	A,DEVBAS	;FOR USE BY ERROR MESSAGES, ETC.
	JRST	FILN61
FILN51: CAME	C,[XWD F.STAR,"*"]
	JRST	FILN6
 
	PUSH	P,T
	PUSHJ	P,NXCH
	CAME	C,[XWD F.STAR,"*"]
	JRST	FILN7
	PUSHJ	P,NXCH
	CAME	C,[XWD F.STAR,"*"]
	JRST	FILN7
	MOVSI	A,(SIXBIT /BAS/)
	HLLZM	A,@(B)
	POP	P,C		;CLEAN UP PLIST.
	PUSHJ	P,NXCH
	JRST	FILN50
FILN7:	POP	P,T
	MOVE	C,[XWD F.STAR,"*"]
	XLIST
>
	LIST
FILN6:	SETZM	DEVBAS		;< > 0 SAYS FAKED DEVICE BAS.
FILN61:
;UOFP PATCH TO ALLOW ACCESS TO OTHER PPNS
	PUSH	P,D		;SAVE
	PUSH	P,G		;SOME ACS
	HRRZ	D,C		;GET CHAR
	CAIE	D,"["		;WAS IT [ ?
	JRST	FILN62		;NO
	SETZB	D,G		;CLEAR THE DECKS
PROJN:	PUSHJ	P,NXCH		;GET A DIGIT
	TLNE	C,F.COMA	;, ?
	JRST	PROGN		;YES, GO TO PROG #
	PUSHJ	P,OCTAL 	;NO, STASH IT
	JRST	PROJN		;AND GET MORE
PROGN:	EXCH	G,D		;STORE PROJ, ZERO D
PROGN1: PUSHJ	P,NXCH		;GET ANOTHER CHAR
	TLZ	C,-1		;CLEAR L.H.
	CAIN	C,"]"		;WAS IT ] ?
	JRST	PPN		;YES, ALL OVER
	PUSHJ	P,OCTAL 	;NO, STASH IT
	JRST	PROGN1		;AND GET MORE
PPN:	HRL	G,D		;SET PG,PJ IN G
	TLNE	G,-1		;L.H. ZERO ?
	TRNN	G,-1		;R.H. ZERO ?
	JRST	LEAVE1		;YES
	MOVSM	G,FILDIR+3	;OKAY, SET PJ,PG IN LOOKUP BLOCK
	PUSHJ	P,NXCH		;GET ANOTHER CHARACTER
	JRST	FILN62		;AND RETURN TO MAINSTREAM
 
OCTAL:	MOVEI	C,-"0"(C)	;MAKE DIGIT
	CAILE	C,7		;OCTAL ?
	JRST	LEAVE		;NO
	LSH	C,41		;LEFT JUSTIFY DIGIT
	ROTC	C,3		;AND SNEAK IT INTO D
	TLNN	D,-1		;MORE THAN 6 DIGITS ?
	POPJ	P,		;NO, RETURN
 
 
LEAVE:	POP	P,G		;RECTIFY PDL
LEAVE1: POP	P,G		;RESTORE ACS
	POP	P,D
	JRST	COMM2		;AND GO COMMISERATE
 
FILN62: POP	P,G		;RESTORE
	POP	P,D		;ACS
 
	MOVEI	A,DRMBUF
	MOVEM	A,.JBFF
	JRST	1(B)
COMM2:
	XLIST
	IFN	BASEDT,<
	LIST
	HRRZI	A,@(B)		;GET FILE STORAGE LOC
	CAIE	A,FILDIR	;FROM COMMAND LEVEL ?
	JRST	COMM1		;YES.
	FAIL	<? Illegal filename>	;NO, MUST BE SYNTAX CHECKER
	XLIST
>
	IFN	BASCOM,<
	LIST
	FAIL	<? Illegal filename>	;MUST BE COMPILE TIME
	XLIST
>
	IFN	BASXCT,<
	LIST
	JRST	CHAER1		;YES
	XLIST
>
	LIST
;ROUTINE TO CONVERT NEXT ATOM TO SIXBIT

ALPHSX:	SKIPA	D,[Z (F.LETT)]
ATOMSZ:	HRLZI	D,F.LETT+F.DIG
	HRRZI	B,(B)
	MOVEI	A,0
	MOVE	X1,[POINT 6,A]
ATOMS1:	TDNN	C,D
	POPJ	P,
	PUSHJ	P,SCNLTN	;PACK THIS LETTER INTO A
	JFCL			;SCNLTN HAS SKIP RETURN
	TLNE	X1,770000
	JRST	ATOMS1
	POPJ	P,
 
	XLIST
	IFN	BASEDT,<
	LIST
	EXTERN	CRBUF
OUCHX:	SKIPLE	CRBUF+2		;ANY ROOM IN BUFFER?
	JRST	OUCH1X		;YES. GO DEPOSIT CHAR.
	OUTPUT	16,		;OUTPUT ON CHAN. 16
	MOVEM	N,TEMLOC	;SAVE AC N
	GETSTS	16,N		;GET STATUS
	TRNE	N,740000	;ANY ERROR BITS?
	JRST	[SETZM	OUCRFF	;MAKE ERROR TO TTY
		JRST	OUTERR]
	MOVE	N,TEMLOC	;RESTORE AC N
OUCH1X:	SOS	CRBUF+2		;DECREMENT BYTE COUNT
	IDPB	C,CRBUF+1	;DEPOSIT CHAR IN BUFFER
	POPJ	P,		;RETURN
ERASE:	HRLZ	A,N		;LOOK FOR LINE
	MOVEI	R,LINROL
	PUSHJ	P,SEARCH
	POPJ	P,		;NONE, GOTO INSERTION
	XLIST
>
	XLIST
	IFN	BASEC,<
	LIST
ERACOM:
	MOVE	D,(B)		;PICK UP LOC OF LINE
	HRLI	D,440700	;MAKE BYTE POINTER
	MOVEI	T1,0		;TO USE IN DEPOSITING
ERAS1:	ILDB	C,D		;GET CHAR
	DPB	T1,D		;CLOBBER IT
	CAIE	C,15		;CARRIAGE RET?
	JRST	ERAS1		;NO.  GO FOR MORE
 
	SETOM	PAKFLA		;MARK FACT THAT THERE IS A HOLE
 
	MOVEI	E,1		;REMOVE ENTRY FROM LINE TABLE
	JRST	CLOSUP
	XLIST
>
	LIST
SUBTTL ERROR MESSAGES
 
 
	XLIST
	IFN	BASEC,<
	LIST
;ERROR MESSAGE ROUTINE.
;
;AC T ENTERS WITH THE LOC OF THE MESSAGE.
;ALL OTHER AC'S, EXCEPT P, CAN BE DESTROYED.
 
ERRMSG: SETZM	ODF
	SETZM	HPOS
	PUSHJ	P,TTYIN
	SETZ	D,		;END ON NULL.
	PUSHJ	P,PRINT 	;PRINT MESSAGE.
	SKIPE	CHAFL2		;CHAINING?
	JRST	ERRMS2
	OUTPUT			;NO.
	XLIST
	IFN	BASEDT,<
	LIST
	JRST	UXIT
ERRMS2: PUSH	P,[Z UXIT]	;YES, ADD DEV, FILENM, ETC.
	XLIST
>
	IFN	BASCOM,<
	LIST
	JRST	LUXIT
ERRMS2:	PUSH	P,[Z LUXIT]	;YES, ADD DEV, FILENM, ETC.
	XLIST
>
>
	LIST
ERRMS3: PUSHJ	P,INLMES
	ASCIZ	/ in /
	PUSH	P,ODF
	SETZM	ODF
	SKIPN	CURBAS
	JRST	ERLAB1
	MOVSI	T,(SIXBIT/BAS/)
	JRST	ERRM35
ERLAB1:	HLRZ	T,CURDEV
	CAIN	T,<SIXBIT/   DSK/>
	JRST	ERRMS4
	MOVE	T,CURDEV	;DEV MAY BE GT. 3 LETTERS.
 
ERRM35: PUSHJ	P,PRNSIX
	MOVEI	T,32
	PUSHJ	P,PRNSIX
ERRMS4: MOVE	T,CURNAM
	PUSHJ	P,PRNSIX
	HLRZ	T,CUREXT
	CAIN	T,<SIXBIT/   BAS/>
	JRST	ERLAB2
	TLO	T,16
	PUSHJ	P,PRNSIX
ERLAB2:	POP	P,ODF
	OUTPUT
	SETZM	HPOS
	POPJ	P,
	XLIST
	IFN	BASEX,<
	LIST
NOGETD: SETZM	ODF
	PUSH	P,T
 
	INLERR(10,57,</
? No such device />)
	POP	P,T
	XLIST
	IFN	BASEDT,<
	LIST
	PUSHJ	P,PRNSIX
	OUTPUT
	JRST	UXIT
	XLIST
>
	IFN	BASXCT,<
	LIST
	PUSHJ	P,ERRXCX
	PUSHJ	P,PRNSIX
	OUTPUT
	PUSHJ	P,ERRXCY
	JRST	UXIT
	XLIST
>
>
	LIST
;SUBROUTINE TO CHECK DATA LINE
;ALSO CALLED AT RUN TIME TO CHECK INPUT LINE
;(NOTE.. <RETURN> NOT CHECKED AFTER INPUT LINE)
 
 
DATCHK: TLNN	C,F.LETT+F.QUOT ;LETTER OR QUOT SIGN FIRST
	JRST	DATCH2		;NO, EVALUATE NUMBER
	PUSH	P,[DATCH3]	;YES, ASSUME STRING AND SKIP OVER
	JRST	SKIPDA
 
 
DATCH2: PUSH	P,X1
	PUSHJ	P,EVANUM
	JRST	[POP P,X1
		 POPJ	P,]
	POP	P,X1
DATCH4: CAIE	C,"&"		;IF "&", ASSUME MATINPUT TERM
	TLNE	C,F.CR		;MORE?
	JRST	CPOPJ1		;NO. RETURN
	SKIPE	INPFLA		;FOR READ AND MAT READ
	JRST	DALAB1		;BUT NOT FOR INPUT OR MAT
	TLNE	C,F.TERM	;INPUT, STOP ALSO ON AN
	JRST	CPOPJ1		;APOSTROPHE.
DALAB1:	TLNN	C,F.COMA	;DID FIELD END CORRECTLY?
	POPJ	P,		;NO. ERROR
	PUSHJ	P,NXCH		;YES. SKIP COMMA
	TLNE	C,F.TERM
	JRST	CPOPJ1
	JRST	DATCHK		;AND GO TO NEXT ITEM.
 
 
DATCH3: POPJ	P,
	JRST	DATCH4
	XLIST
	IFN	BASCX,<
	LIST
BASORT: MOVE	X1,[XWD BA,SRTDBA]
	BLT	X1,SRTDBA+8
	MOVEI	E,8
BASOR1: MOVE	X1,SRTDBA(E)
	MOVEI	C,(E)
BASOR2: MOVE	X2,SRTDBA-1(C)
	CAMG	X2,X1
	JRST	BASOR3
	MOVEM	X2,SRTDBA(E)
	MOVEM	X1,SRTDBA-1(C)
	MOVE	X1,X2
BASOR3: SOJG	C,BASOR2
	SOJG	E,BASOR1
 
 
BASOR4: SKIPE	SRTDBA(C)
	JRST	BASOR5
	AOJ	C,
	CAIG	C,8
	JRST	BASOR4
	POPJ	P,
BASOR5: JUMPE	C,CPOPJ
	MOVEI	E,10
	JRST	PAKBL0
	XLIST
>
	XLIST
	IFN	BASEX,<
	LIST
OUTERR:	TRNE	N,040000	;OUTERR EXPECTS THE STATUS BITS IN N
	INLEMS(10,58,OUTQMS)
	TRNE	N,400000
	INLEMS(10,59,OUTLMS)
	INLEMS(1,70,INLSYS)
OUTLMS:	ERROM	(59,</
? Device is write locked/>)
OUTQMS:	ERROM	(58,</
? Quota exceeded or block no. too large on output device/>)
XXXXXX:	SETZM	COMTIM
	SETZM	HPOS
	MOVE	P,PLIST
	SETZM	NUMCOT
	SETZB	LP,IFIFG
	XLIST
	IFN	BASXCT,<
	LIST
	SKIPN	UXFLAG
	JRST	UXIT5
	SETOM	ODF
	MOVEI	LP,^D9
UXIT3:	SKIPL	A,ACTBL-1(LP)
	JRST	UXLAB1
	PUSHJ	P,CLSRAN
	JRST	UXIT49
UXLAB1:	CAIE	A,3
	JRST	UXIT49
	SETZM	40
	SETZM	WRIPRI-1(LP)
	PUSHJ	P,PRDLER
	SKIPE	HPOS(LP)
	PUSHJ	P,CRLF3
UXIT49:	SOJG	LP,UXIT3
	SETZM	ODF
	PUSHJ	P,PRDLER
	XLIST
>
	LIST
UXIT5:	SETZM	ODF
	DEFINE %R(A)
<	IRP	A
<	RELEASE ^D<A>,	>>
	%R<1,2,3,4,5,6,7,8,9>	 ;DISK DATA FILES 1-9
	XLIST
	IFN	BASEDT,<
	LIST
EDTXT1:	PUSH	P,T		;SAVE T
	SETO	T,		;NEED LINE CHARACTERISTICS
	GETLCH	T		;ASK MONITOR
	TLZ	T,(1B15)	;TURN ON ECHO
	SETLCH	T		;IN CASE IT WAS LEFT OFF
	POP	P,T		;RESTORE T
	SETZM	RUNFLA
	PUSHJ	P,TTYIN 	;INIT TTY IN CASE OF ^O.
	SKIPE	CHAFLG		;CHAINING?
	JRST	FIXUP		;YES.
	SKIPE	MTIME		;IS THERE SOME RUN TIME?
	PUSHJ	P,RTIME
	PUSHJ	P,INLMES
	ASCIZ	/
Ready
/
	JRST	FIXUP		;GO TO MAIN LOOP AFTER CLEARING ROLLS
	XLIST
>
	XLIST
	IFN	BASXCT,<
	LIST
	SKIPN	UXFLAG		;END OF PROGRAM EXECUTION?
	JRST	UXIT1		;NO.
	SETZM	UXFLAG		;YES.
	SETZM	MARWAI
	MOVEI	X1,^D72
	MOVEM	X1,MARGIN
	SETZM	QUOTBL
	SETZM	HPOS
	SETOM	PAGLIM
	MOVEI	X1,^D9
UXIT2:	SKIPL	A,ACTBL-1(X1)	;ACTBL ENTRY = 3 IF FILE
	CAIN	A,3
	JRST	UXIT21		;IS BEING WRITTEN.
	SOJG	X1,UXIT2
	JRST	UXIT1
UXIT21: PUSH	P,[Z UXIT4]
UXIT6:	MOVE	X2,FILD-1(X1)
	MOVEM	X2,LOK
	MOVE	X2,EXTD-1(X1)
	MOVEM	X2,LOK+1
	MOVE	X2,FPPN-1(X1)
	MOVEM	X2,LOK+3
	HLRZ	X2,BA-1(X1)
	MOVEM	X2,.JBFF
	XCT	INITO-1(X1)
	JRST	[MOVE T,OPS1+1
		JRST NOGETD]	;OUTPUT MESSAGE "NO SUCH DEVICE"
	DPB	X1,[POINT 4,LOKUP,12]	;AND GIVE UP BECAUSE
	HLLZS	LOK+1		;ALL DEVICES ARE THE SAME.
	SETZM	LOK+2
	XCT	LOKUP
	JFCL
UXIT7:	HLLZ	X2,LOK+2
	TLZ	X2,777
	SKIPL	MONLVL
	TLNN	X2,700000
	IOR	X2,MONLVL	;MONLVL CONTAINS THE "DON'T DELETE " BIT.
	MOVEM	X2,LOK+2
	HLLZS	LOK+1
	DPB	X1,[POINT 4,RENAMD,12]
	XCT	RENAMD
	JFCL			;RENAME FAILS FOR DECTAPES.
	POPJ	P,
UXIT4:	SOJG	X1,UXIT2	;RETURN HERE FROM RENFAL MESSAGE.
	JRST	CHAXIT
	XLIST
>
	LIST
	DEFINE %R(A)
<	IRP	A
<	EXP	DO'A+1	>>
OUTPT:	%R<1,2,3,4,5,6,7,8,9>
	DEFINE %R(A)
<	IRP	A
<	EXP	DO'A+2
	EXTERN	DO'A	>>
OUTCNT: %R<1,2,3,4,5,6,7,8,9>
	DEFINE %R(A)
<	IRP	A
<	EXP	DI'A+1
	EXTERN	DI'A	>>
	INTERN INPT
INPT:	%R<1,2,3,4,5,6,7,8,9>
 
	DEFINE	%R(A)
<	IRP	A
<	EXP	DI'A+2	>>
	INTERN INCNT
INCNT:	%R<1,2,3,4,5,6,7,8,9>
 
	DEFINE %R(A)
<	IRP	A
<	POINT 7,LINB'A
 
	EXTERN	LINB'A	>>
LINPT:	%R<0,1,2,3,4,5,6,7,8,9>
	XLIST
>
	XLIST
	IFN	BASEC,<
	LIST
;SUBROUTINES FOR GENERAL ROLL MANIPULATION
 
CLOSUP: MOVN	X1,E		;COMPUTE NEW END OF ROLL
	ADDB	X1,CEIL(R)	;AND STORE IT
	MOVE	X2,B		;CONSTRUCT BLT WORD
	ADD	X2,E
	MOVS	X2,X2
	HRR	X2,B
	BLT	X2,-1(X1)	;MOVE DOWN TOP OF ROLL
	POPJ	P,
 
CLOB:	MOVEI	T1,COMTOP	;ROUTINE TO CLOBBER ALL MOVEABLE ROLLS
CLLAB1:	MOVEM	T,FLOOR(T1)	;T CONTAINS CLOBBER VALUE.
	MOVEM	T,CEIL(T1)
	CAILE	T1,1(X1)	;DO NOT CLOBBER ROLLS LE.(X1)
	SOJA	T1,CLLAB1
	POPJ	P,
 
 
 
OPEN2:	MOVE	X2,E		;IS THERE ROOM ABOVE THIS STODGY ROLL?
	ADD	X2,CEIL(R)	;THE NEW CEILING
	CAMLE	X2,FLOOR+1(R)
	JRST	OPENU0		;NO ROOM, PACK OTHER ROLLS UP
	ADDM	E,CEIL(R)	;THERE IS ROOM, INCREMENT CEILING
	POPJ	P,
 
OPENU0: SUB	B,FLOOR(R)
	PUSHJ	P,PANIC
	ADD	B,FLOOR(R)
 
OPENUP: CAMG	R,TOPSTG	;OPEN UP THE TOP STODGY ROLL?
	JRST	OPEN2		;YES. OPEN UPWARDS, NOT DOWN
	MOVN	X2,E
	MOVE	X1,TOPSTG	;DO NOT MOVE STODGY ROLLS
	ADD	X2,FLOOR+1(X1)
	CAMGE	X2,CEIL+0(X1)
	JRST	OPENU0		;NEED MORE ROOM
	HRL	X2,FLOOR+1(X1)	;CONSTRUCT BLT WORD
	SUB	B,E		;FIRST WORD OF GAP
	BLT	X2,-1(B)	;MOVE ROLLS DOWN
 
	MOVEI	X1,1(X1)	;ADJUST POINTERS FOR ROLLS JUST BLT'D.
	MOVN	X2,E
OPEN1:	ADDM	X2,FLOOR(X1)
	CAML	X1,R
	POPJ	P,
	ADDM	X2,CEIL(X1)
	AOJA	X1,OPEN1
 
 
;RPUSH - PUSH A ON TOP OF DESIGNATED ROLL
 
RPUSH:	MOVEI	E,1
	PUSHJ	P,BUMPRL	;MAKE ROOM
 
	MOVEM	A,(B)		;STORE WORD
	POPJ	P,
 
;ROUTINE TO ADD TO END OF ROLL
;E CONTAINS SIZE, R CONTAINS ROLL NUMBER
 
BUMPRL: MOVE	B,CEIL(R)
	ADD	B,E
	CAIE	R,ROLTOP
	SKIPA	X1,FLOOR+1(R)
	HRRZ	X1,.JBREL
	CAMLE	B,X1
	JRST	BUMP1
	EXCH	B,CEIL(R)
	POPJ	P,
 
BUMP1:	MOVE	B,CEIL(R)
	CAIE	R,CODROL
	CAIN	R,SEXROL
	JRST	BULAB1
	JRST	OPENUP
BULAB1:	ADDI	E,^D10		;***EXTRA 10 LOCS
	PUSHJ	P,OPENUP
	MOVNI	X1,^D10 	;TAKE BACK THE 10 LOCS
	ADDM	X1,CEIL(R)
	POPJ	P,
	XLIST
>
	LIST
QSKIP:	PUSHJ	P,NXCH		;SKIP TO NEXT QUOTE CHARACTER
	TLNE	C,F.CR		;TERMINAL QUOTE MISSING?
	POPJ	P,		;YES
	TLNN	C,F.QUOT	;END OF STRING?
	JRST	QSKIP		;NO, GO ON.
	PUSHJ	P,NXCH		;LYES, GET NEXT CHAR AND RETURN
	JRST	CPOPJ1		;
;BINARY SEARCH OF SORTED ROLL
;CALL WITH KEY IN A
;RETURN IN B ADDRS OF FIRST
;ENTRY NOT LESS THAN KEY
;SKIP RETURN IF LEFT SIDES EQUAL
 
SEARCH: MOVE	B,FLOOR(R)
	SKIPA	X1,CEIL(R)
SEAR1:	MOVEI	B,1(X2)
	CAIGE	B,(X1)
	JRST	SEAR2
	CAML	B,CEIL(R)
	POPJ	P,
	JRST	SEAR3
 
SEAR2:	MOVEI	X2,@X1
	ADD	X2,B
	ASH	X2,-1
	CAMLE	A,(X2)
	JRST	SEAR1
	HRRI	X1,0(X2)
	CAIGE	B,(X1)
	JRST	SEAR2
 
 
SEAR3:	HLLZ	X2,(B)
	CAMN	X2,A
	AOS	(P)
 
	POPJ	P,
 
;COMMON SUBROUTINE RETURNS
 
CPOPJ1: AOS	(P)
CPOPJ:	POPJ	P,
 
;ROUTINES TO ALLOW AND DELAY REENTRY.
;LOCKON TEMPORARILY PREVENTS REENTRY
;LOCKOF ALLOWS REENTRY AND REENTERS IF THERE IS A STANDING REQUEST
;REENTR MAKES A REENTRY OR MAKES A REQUEST AND CONTINUES
LOCKON: SKIPGE	RENFLA
	SETZM	RENFLA		;TURN ON REENTER PROTECT
	POPJ	P,
 
LOCKOF:	SKIPE	RENDON		;ALREADY PROCESSING INTERRUPT ?
	POPJ	P,		;YES, JUST IGNORE
	SKIPG	RENFLA		;NO, HAS ONE COME IN ?
	JRST	[SETOM	RENFLA	;NO, JUST GO AWAY
		POPJ	P,]
	SETOM	RENDON		;YES, LOCK IT OUT
	JRST	BASIC		;AND GO HANDLE
 
;ROUTINE TO READ CHARACTER, SKIPPING BLANKS
;CALL:	MOVE	T,<POINTER TO CHAR BEFORE FIRST>
;	PUSHJ	P,NXCH
;	...	RETURN, C:= (<FLAGS>)CHARACTER
 
NXCHS:	ILDB	C,T		;DOESNT SKIP TAB OR BLANK
	CAIE	C," "
	CAIN	C,11
	POPJ	P,
	JRST	NXLAB1		;SKIP INTO NXCH
 
NXCH:	ILDB	C,T		;FETCH NEXT CHARACTER
NXLAB1:	HLL	C,CTTAB(C)	;GET FLAGS FROM CTTAB
	TRNE	C,100
	HRL	C,CTTAB-100(C)
	CAME	C,[XWD	F.CR,12] ;SKIP <LF>
	TLNE	C,F.SPTB	;SPACE OR TAB?
	JRST	NXCH		;YES. IGNORE
	POPJ	P,
 
NXCHD:	ILDB	C,T
NXCHD2: HLL	C,CTTAB(C)
	TRNE	C,100
	HRL	C,CTTAB-100(C)
	POPJ	P,
 
	XLIST
	IFN	BASEC,<
	LIST
;SCAN INITIAL LETTER, LETTER IS PLACED LEFT
;JUSTIFIED IN A, 7-BIT ASCII.
 
SCNLT1: HRRZ	A,C
	ROT	A,-7
	JRST	NXCH
 
;SCAN SECOND LETTER, NON-SKIP RETURN IF NOT LETTER.
;MAKE 7-BIT LETTER LEFT JUST IN A
;INTO 6-BIT. THAN PUT 6-BIT CURRENT LETTER IN A.
 
SCNLT2: TLNN	C,F.LETT
	POPJ	P,
SCN2:	TLNN	A,400000	;ENTER HERE TO PROCESS NON-LETTER CHARS
	TLZA	A,200000
	TLO	A,200000
	LSH	A,1
	MOVE	X1,[POINT 6,A,5]
	JRST	SCNLTN
 
 
;ENTER HERE TO SCAN SECOND CHAR EVEN IF BOTH ARE NOT LETTERS.
 
 
;SCAN THIRD LETTER, NON-SKIP IF NOT LETTER.
;PUT 6-BIT LETTER TO 3RD 6-BIT FIELD IN A.
 
SCNLT3: TLNN	C,F.LETT
	POPJ	P,
SCN3:	MOVE	X1,[POINT 6,A,11]

;ROUTINE TO SEARCH FOR ELSE, SKIP RETURN IF SUCCESSFUL

	XLIST
>
	LIST
 
;NOW PUT 6-BIT LETTER INTO A, ADJUSTING LOWER CASE, INCREMENTING POINTER.
 
SCNLTN: TLNN	C,F.LCAS
	TRC	C,40
	IDPB	C,X1
	AOS	(P)
	JRST	NXCH
;QUOTE SCAN AND TEST
;CALL WITH PATTERN ADDRS IN X1
;SKIP IF EQUAL. C,T UPDATED TO LAST CHAR SCANNED.
QST:	HRLI	X1,440700	;MAKE BYTE PNTR TO PATTERN
QST1:	ILDB	X2,X1		;GET PATTERN CHAR
	JUMPE	X2,CPOPJ1	;DONE ON NULL
	SUBI	X2,(C)
	JUMPE	X2,QSLAB1	;DO CHARACTERS MATCH?
	TLNE	C,F.LCAS	;NO. LOWER CASE LETTER?
	CAME	X2,[ EXP -40]	;YES. SAME LETTER OF ALPHABET?
	JRST	QST2		;NO. MATCH FAILS
QSLAB1:	PUSHJ	P,NXCH
	JRST	QST1
QST2:	ILDB	X2,X1		;ON FAIL
	JUMPN	X2,QST2		;SKIP TO NULL
	POPJ	P,
;QUOTE SCAN UNTIL FAIL.
;CALL WITH INLINE PATTERN.
 
QSAX:	POP	P,X1
	PUSHJ	P,QST
	JRST	1(X1)
	JRST	1(X1)
 
;QUOTE SCAN WITH ANSWER
;CALL WITH INLINE PATTERN
;SKIP ON SUCCESS		;ON FAIL, RETURN WITH C,T RESTORED
 
QSA:	POP	P,X1		;GET PATTERN ADDRESS
	PUSH	P,C		;SAVE C,T
	PUSH	P,T
	PUSHJ	P,QST		;SAVE STRING
	JRST	QSLAB2
	JRST	QSA1		;MATCH
QSLAB2:	POP	P,T		;NO MATCH.  BACK UP
	POP	P,C
	JRST	1(X1)
 
QSA1:	POP	P,X2
	POP	P,X2
	JRST	2(X1)
	XLIST
	IFN	BASEC,<
	LIST
QSELS:	AOS	(P)		;ASSUME SUCCESS
	PUSH	P,C		;SAVE CHAR
	PUSH	P,T		;SAVE POINTER
	PUSHJ	P,QSA		;FIND ELSE
	ASCIZ	/ELSE/
	SOS	-2(P)		;NOT THERE
	POP	P,T		;RESTORE
	POP	P,C		;ACS
	POPJ	P,		;AND RETURN
	XLIST
>
	XLIST
	IFN	BASEX,<
	LIST
;ROUTINE TO READ A LINE INTO LINB0
;CALL:	PUSHJ	P,INLINE
 
INLINE: PUSH	P,X1
	PUSH	P,[XWD	Z,INLI1A]
INLGEN:	SETZB	X1,T1		;ENTRY FOR GEN COMMAND
	SKIPE	IFIFG
	SKIPA	T,LINPT(LP)
	MOVE	T,LINPT
	POPJ	P,
 
 
INLI1:	ILDB	C,TYI+1 	;GET CHAR
	JRST	INLB
INLA:	SOSGE	@INCNT-1(LP)
	JRST	DSKIN
	ILDB	C,@INPT-1(LP)
INLB:
	JUMPE	C,INLB2 	;SKIP NULL AS USUAL
	CAIE	C,15		;<CR> ?
	JRST	INLB3		;NO
	SETO	X1,		;YES, FLAG & SKIP
INLB2:
	SOJA	T1,INLI1A
INLB3:	CAIE	C,21		;IGNORE XON,XOFF
	CAIN	C,23
	SOJA	T1,INLI1A
	CAIN	C,12		;<LF> ?
	JUMPE	X1,INLC 	;JUST IGNORE UNLESS AFTER <CR>
	SETZ	X1,
	CAIG	C,14		;LINE TERMINATOR?
	CAIGE	C,12
	JRST	INLAB1
	JRST	INLI2		;YES.  GO FINISH UP
INLAB1:	CAIG	T1,^D255	;ROOM FOR CHAR+1 MORE?
	JRST	INLB1		;YES.
	SKIPE	IFIFG		;DISK?
	JRST	INERR		;YES, ERROR EXIT.
	INLEMS(38,69,INERR1)	;NO, ERROR EXIT.
INERR1: ERROM(68,</
? Line too long/>)
 
INLC:	HRRZ	X1,TYI+1
	CAIL	X1,TTYBUF
	TTCALL	1,INLI2 	;ECHO <CR> TO NAKED <LF>
	SETZ	X1,
INLB1:	IDPB	C,T		;STORE CHAR
INLI1A: SKIPE	IFIFG
	AOJA	T1,INLA
	SOSLE	TYI+2		;MORE INPUT?
	AOJA	T1,INLI1	;YES.  BUMP COUNT AND GO GET MORE
	INPUT
	STATZ	20000
	JRST	[SKIPN CHAFLG
		JRST BASIC
		JRST RUNNH]
	STATO	740000
	AOJA	T1,INLI1
	SKIPE	IFIFG
	SETZM	ACTBL-1(LP)
	INLEMS(1,70,INLSYS)
INLSYS: ASCIZ /
? System error/
 
INLI2:	MOVEI	C,15		;DONE.	PUT CR IN BFR.
	IDPB	C,T
	POP	P,X1
RESCAN: SKIPN	IFIFG
	SKIPA	T,LINPT
	MOVE	T,LINPT(LP)
	SKIPE	IFIFG
	JRST	INLI8
	SETZM	HPOS		;CARRIAGE POSITION := LFT MRGN
	SKIPE	INLNFG
	JRST	NXCHS
	JRST	NXCH		;GET FIRST CHAR AND RETURN
INLI8:	SETZM	HPOS(LP)
	SKIPE	INLNFG
	JRST	NXCHS
	JRST	NXCH
	XLIST
>
	XLIST
	IFN	BASEX,<
	LIST
DSKIN:	DPB	LP,[POINT 4,INDSK,12] ;DISK INPUT
	XCT	INDSK
	DPB	LP,[POINT 4,STADSK,12]
	XCT	STADSK
	XLIST
	IFN	BASEDT,<
	LIST
	JRST EOFFAL
	XLIST
>
	IFN	BASXCT,<
	LIST
	JRST	[HRRZ T,-2(P)
		CAIE T,EOF32
		JRST EOFFAL
		JRST EOF31]
	XLIST
>
	LIST
	DPB	LP,[POINT 4,STODSK,12]
	XCT	STODSK
	JRST	INLA
	SETZM	ACTBL-1(LP)
	INLEMS(1,70,INLSYS)
	XLIST
>
	LIST
 
 
;ROUTINE TO READ NEXT INTEGER FROM SCANNED LINE
;CALL:	MOVE	T,POINTER TO FIRST CHAR
;	PUSHJ	P,GETNUM
;	...	FAIL RETURN
;	...	SUCCESS RETURN, INTEGER IN N
 
GETNU:	TDZA	X1,X1		;GET A NUMBER OF ANY LENGTH.
GETNUM: MOVEI	X1,5		;GET A NUMBER OF AT MOST 5 DIGS
	MOVE	X2,[PUSHJ P,NXCH] ;IGNORE BLANKS
	JRST	GNNOB
GTNUMB:	MOVEI	X1,5		;ALWAYS A LINE NUMBER
	MOVE	X2,[PUSHJ P,NXCHS] ;PRESERVE SPACING
GNNOB:	TLNN	C,F.DIG 	;NUMERAL?
	POPJ	P,		;NO.  FAIL RETURN
	MOVEI	N,-60(C)	;YES.  ACCUMULATE FIRST DIGIT
GETN1:	MOVE	G,T		;SAVE PNTR FOR USE BY INSERT
	XCT	X2			;GET NEXT CHAR
	SOJE	X1,GETN2	;EXIT IF FIVE DIGITS ALREADY
	TLNN	C,F.DIG 	;NUMERAL?
	JRST	GETN2		;NO.  RETURN.
	IMULI	N,^D10		;YES.  ACCUMULATE NUMBER
	ADDI	N,-60(C)
	JRST	GETN1		;GO FOR MORE
GETN2:	CAMN	C,[XWD F.STR,"%"]
	PUSHJ	P,NXCH		;EAT THE % IF IT IS THERE
	JRST	CPOPJ1		;DO SKIP RETURN
;PRINT TO QUOTE CHAR
;CALL:	MOVE	T,<ADDRS OF MSG>
;	MOVE	D,<QUOTE CHAR>
;	PUSHJ	P,PRINT
;CALL:	MOVE	T,<ADDRS OF MSG>
;	MOVE	D,<QUOTE CHAR>
;	PUSHJ	P,PRINT
;ALTERNATE CALL: PRINT1, IF BYTE PNTR IN T.
 
 
PRINT:	HRLI	T,440700
PRINT1: ILDB	C,T
	CAMN	C,D
	POPJ	P,
	PUSHJ	P,OUCH		;OUTPUT THE CHAR
	XLIST
	IFN	BASEDT,<
	LIST
	CAIN	D,15		;CHECKING FOR <CR> ?
	CAIE	C,12		;AND SEEN <LF> ?
	XLIST
>
	LIST
	JRST	PRINT1		;NO
	XLIST
	IFN	BASEDT,<
	LIST
	EXCH	C,D		;YES, PUT OUT <CR>
	PUSHJ	P,OUCH
	EXCH	C,D
	JRST	PRINT1		;GO FOR MORE
	XLIST
>
	LIST
OUCH:
	XLIST
	IFN	BASEDT,<
	EXTERNAL OUCRFF
	LIST
	SKIPE	OUCRFF		;ERRORS TO CREF OUTPUT?
	JRST	OUCHX		;YES
	XLIST
>
	XLIST
	IFN	BASEDT,<
	LIST
	SKIPE	ODF		;DISK?
	JRST	DSKOT		;YES.
	XLIST
>
	XLIST
	IFN	BASEC,<
	LIST
	SKIPLE	TYO+2		;NO.
	JRST	OUCH1
	OUTPUT
	LIST
>
	XLIST
	IFN	BASEDT,<
	LIST
	MOVEM	N,TEMLOC
	GETSTS	0,N
	TRNE	N,740000
	JRST	OUTERR
	MOVE	N,TEMLOC
	XLIST
>
	XLIST
	IFN	BASXCT,<
	LIST
	SKIPE	ODF		;DISK?
	JRST	DSKOT		;YES
	SKIPN	ERRTCN		;STORING FATAL ERRORS?
	JRST	ERROK		;NO
	IDPB	C,ERRBPT	;YES, STORE IN LOW CORE
	AOS	HPOS
	POPJ	P,
ERROK:	SKIPLE	TYO+2
	JRST	OUCH1
	OUTPUT
	MOVEM	N,TEMLOC
	GETSTS	0,N
	TRNE	N,740000
	JRST	OUTERR
	MOVE	N,TEMLOC
	XLIST
>
	LIST
OUCH1:	SOS	TYO+2
	IDPB	C,TYO+1
	AOS	HPOS
	POPJ	P,
	XLIST
	IFN	BASEX,<
	LIST
DSKOT:	SKIPG	@OUTCNT-1(LP)
	JRST	DOS
	SOS	@OUTCNT-1(LP)
	IDPB	C,@OUTPT-1(LP)
	AOS	HPOS(LP)
	POPJ	P,

DOS:	DPB	LP,[POINT 4,OUTTDS,12]
	XCT	OUTTDS
	JRST	DSKOT
	SETZM	ACTBL-1(LP)
	XCT	GTSTS
	JRST	OUTERR
	XLIST
>
	LIST
 
;ROUTINE TO PRINT SIXBIT CHARACTERS IN ACCUM "T".
;IGNORES BLANKS.
 
 
PRNSIX: MOVE	T1,[POINT 6,T]
	ILDB	C,T1
	JUMPE	C,PRNS1 	;SKIP A BLANK
	ADDI	C,40
	PUSHJ	P,OUCH
PRNS1:	TLNE	T1,770000	;ALL SIX PRINTED?
	JRST	PRNSIX+1
	POPJ	P,
 
 
;UTILITY ROUTINE TO PRINT OUT "DEV:FILENM.EXT".
;FOR USE BY VARIOUS ERROR MESSAGES.
;DEV IS IN SAVE1, FILENM IN FILDIR, AND EXT IN FILDIR+1.
;IF LH(SAVE1)=0, DEV IS NOT PRINTED. DSK: AND .BAS ARE
;OMITTED.
 
PRNNAM: PUSH	P,C
	PUSH	P,T
	PUSH	P,ODF
	SETZM	ODF
	HLRZ	T,SAVE1
	JUMPE	T,PRNAM1
	CAIN	T,<SIXBIT /   DSK/>
	JRST	PRNAM1
	MOVE	T,SAVE1
	PUSHJ	P,PRNSIX
	MOVSI	T,320000
	PUSHJ	P,PRNSIX
PRNAM1: MOVE	T,FILDIR
	PUSHJ	P,PRNSIX
	HLRZ	T,FILDIR+1
	CAIN	T,<SIXBIT /   BAS/>
	JRST	PRNAM2
	TLO	T,16
	PUSHJ	P,PRNSIX
PRNAM2:	SKIPN	FILDIR+3
	JRST	PRNAM3
	GETPPN	C,
	JFCL
	CAMN	C,FILDIR+3
	JRST	PRNAM3
	MOVEI	C,"["
	PUSHJ	P,OUCH
	HLRZ	T,FILDIR+3
	PUSHJ	P,PRTOCT
	MOVEI	C,","
	PUSHJ	P,OUCH
	HRRZ	T,FILDIR+3
	PUSHJ	P,PRTOCT
	MOVEI	C,"]"
	PUSHJ	P,OUCH
PRNAM3: POP	P,ODF
	POP	P,T
	POP	P,C
	POPJ	P,
 
 
 
 
	XLIST
	IFN	BASEX,<
	LIST
;OCTAL NUMBER PRINTER.
PRTOCT: IDIVI	T,10
	JUMPE	T,PRTOC1
	PUSH	P,T1
	PUSHJ	P,PRTOCT
	POP	P,T1
PRTOC1: MOVEI	C,60(T1)
	AOS	NUMCOT
	JRST	OUCH
 
 
;ROUTINE USED BY OUTNUM FOR STRB.
 
DPBSTR: EXCH	T,STRPTR
	IDPB	C,T
	EXCH	T,STRPTR
	SOS	STRCTR
	POPJ	P,
	XLIST
>
	LIST
;MESSAGE PRINTER
 
INLMES: PUSHJ	P,TTYIN
INLME1: SETZM	HPOS
	EXCH	T,(P)	;GET MSG ADR AND SAVE T.
	PUSH	P,C
	PUSH	P,ODF
	SETZM	ODF
	MOVEI	D,0	;END ON NULL
	PUSHJ	P,PRINT ;PRINT THE MESSAGE
	POP	P,ODF
	POP	P,C
	EXCH	T,(P)
	SETZM	HPOS
	JRST	CPOPJ1	;RTN AFTER MSG.
 
 
	SUBTTL CORE COMPRESSION AND EXPANSION
	XLIST
	IFN	BASEC,<
	LIST
;PANIC - ROUTINE TO COMPRESS CORE
 
PANIC:	PUSHJ	P,PRESS 	;COMPRESS MEMORY
	MOVE	X2,TOPSTG	;IS THERE ROOM BETWEEN STODGY AND
	MOVE	X1,FLOOR+1(X2)	;MOVEABLE ONES?
	SUB	X1,CEIL(X2)
	CAML	X1,E		;ENOUGH ROOM?
	POPJ	P,
 
	MOVE	X1,.JBREL	;EXPAND BY 1K
	ADDI	X1,2000
	CORE	X1,
	INLEMS(60,60,PANIC1)
	JRST	PANIC		;OK.  GO MOVE ROLLS
 
PANIC1: ERROM(60,</
? Out of room/>)
 
PRESS:	PUSH	P,G		;SAVE AC
	PUSH	P,A
	SKIPN	PAKFLA		;ARE LINES PACKED?
	JRST	PRESS5		;YES
	SETZM	PAKFLA
 
	MOVE	X1,FLTXT	;LOOK FOR EMPTY SPACE
PRESS2: CAML	X1,CETXT	;THROUGH LOOKING?
	JRST	PRESS5
	SKIPE	(X1)		;A FREE WORD?
	AOJA	X1,PRESS2	;NO
 
	MOVEI	X2,1(X1)	;YES
PRESS3: CAML	X2,CETXT
	JRST	PRESS4		;FREE TO END
	SKIPN	(X2)
	AOJA	X2,PRESS3	;LOOK FOR NON-FREE WORD
 
	SUB	X1,X2		;X1 :=-LNG OF MOVE
 
	MOVE	A,FLLIN
PRES3A: CAML	A,CELIN 	;MOVE DOWN THE REFERENCES
	JRST	PRES3B		;IN THE LINE ROLL.
	HRRZ	G,(A)
	CAML	G,X2
	ADDM	X1,(A)
	AOJA	A,PRES3A
 
PRES3B: MOVE	G,CETXT 	;MOVE DOWN THE TEXT ROLL.
	ADD	G,X1
	MOVEM	G,CETXT
	ADD	X1,X2
	HRL	X2,X1
	MOVSS	X2
	BLT	X2,-1(G)
	JRST	PRESS2
 
PRESS4: MOVEM	X1,CETXT
 
;ROUTINE TO MOVE ROLLS UP
 
PRESS5:
	SKIPE	OLDCOD		;CRUNCHING SAVE CODE
	JRST	PRES9A		;YES, JUST RETURN
	MOVEI	G,ROLTOP	;HIGHEST MOVABLE ROLL
	MOVE	X1,.JBREL	;X1 IS PREVIOUS FLOOR
				;NOTE: TOP WORD OF USR CORE IS LOST
 
PRESS6: MOVE	X2,CEIL(G)	;GET OLD CEIL AND FLOOR
	MOVE	A,FLOOR(G)
	SUBI	X2,1		;SET UP X2 FOR POP LOOP
	ORCMI	X2,777777
	MOVEM	X1,CEIL(G)	;NEW CEILING
 
PRESS7: CAILE	A,(X2)		;DONE?
	JRST	PRESS8
	POP	X2,-1(X1)	;MOVE ONE WORD
	SOJA	X1,PRESS7
 
PRESS8: MOVEM	X1,FLOOR(G)	;NEW FLOOR
	SOS	G		;GO TO NEXT LOWER ROLL
	CAMLE	G,TOPSTG	;IS THIS ROLL MOVEABLE?
	JRST	PRESS6		;YES. GO PRESS IT.
PRES9A: POP	P,A
PRESS9: POP	P,G	;RESTORE G
	POPJ	P,	;RETURN
	XLIST
>
	XLIST
	IFN	BASEX,<
	LIST
GOSR2:	MOVE	T,[Z UXIT]
	XLIST
>
	IFN	BASXCT,<
	LIST
	SKIPE	RUNDDT
	MOVE	T,[Z UXIT1]
	XLIST
>
	IFN	BASEX,<
	LIST
	PUSH	P,T
GOSR3:
	XLIST
	IFN	BASXCT,<
	LIST
	SKIPE	ERRTCN
	PUSHJ	P,ERRXCX
	SKIPN	NOTLIN		;ANY LINE NUMBERS ?
	SKIPE	NOLINE		;SHOULD WE PRINT LINE #?
	JRST	GOSR3A		;NO, NO LINE NUMBER TO OUTPUT
	XLIST
>
	LIST
	PUSHJ	P,INLMES
	ASCIZ	/ in line /
	MOVE	T,SORCLN	;PRINT LINE NUMBER AND CONTINUE EXECUTION.
	HRRZ	T,0(T)
	PUSH	P,ODF
	SETZM	ODF
	PUSHJ	P,PRTNUM
	POP	P,ODF
GOSR3A:	SKIPE	CHAFL2		;CHAINING?
	PUSHJ	P,ERRMS3
GOSR6:	PUSHJ	P,INLMES
	ASCIZ	/
/
	OUTPUT
	XLIST
	IFN	BASXCT,<
	LIST
	SKIPE	ERRTCN
	PUSHJ	P,ERRXCY
	XLIST
>
	LIST
	POPJ	P,
 
INERR:	INLERR(38,8,</
? Data file line too long/>)
	JRST	GOSR2
 
PTXER1: INLERR(82,9,</
? Illegal character in string/>)
	JRST	GOSR2
 
 
EOFFAL: POP	P,X1
EOFFL:	INLERR(8,21,</
? Eof/>)
	JRST	GOSR2
	XLIST
>
	XLIST
	IFN	BASCX,<
	LIST
;SUBROUTINE TO GET OUT OF THE WAY OF THE BUFFERS.
 
 
VSUB1:	SETZ	C,		;X2 HAS LOWER BOUND.
VSUB11: HRRZ	X1,SRTDBA(C)	;T1 HAS UPPER BOUND.
	JUMPE	X1,CPOPJ	;T OR A HAS LENGTH, DEPENDING ON
	CAIG	X1,(X2) 	;DIRECTION OF TRAVEL.
	JRST	VSUB12
	HLRZ	X1,SRTDBA(C)
	CAIL	X1,(T1)
	JRST	VSUB12
	JUMPN	A,VSUB13	;GOING DOWN OR UP?
	HRRZ	T1,SRTDBA(C)	;GOING UP.
	HRRZI	X2,(T1)
	ADDI	T1,(T)
	JRST	VSUB12
VSUB13: HLRZ	T1,SRTDBA(C)	;GOING DOWN.
	HRRZI	X2,T1
	SUBI	X2,(A)
VSUB12: AOJ	C,
	CAIGE	C,9
	JRST	VSUB11
	POPJ	P,
	XLIST
>
	IFN	BASXCT,<
	LIST
VPANIC: PUSH	P,R
	PUSH	P,X1
	PUSH	P,X2
	PUSH	P,G
	PUSH	P,A
	PUSH	P,C
	PUSH	P,E
	PUSH	P,T1
	PUSH	P,T
	SKIPN	VPAKFL
	PUSHJ	P,VPRESS
 
 
VPAN3:	MOVE	G,VRFBTB
	SKIPN	VRFBOT
	MOVE	G,.USREL
	MOVE	X2,VARFRE
	MOVEI	T,^D200
	SETZ	A,
	MOVEI	T1,^D200(X2)
	PUSHJ	P,VSUB1
	SOJ	T1,
	CAIGE	T1,(G)
	JRST	[SKIPN X2,VRFBOT
		JRST VPAN92
		CAMN X2,VRFBTB
		JRST VPAN30
		JRST VPN21]
	SKIPE	X2,VRFBOT
	CAME	X2,VRFBTB
	JRST	VPAN32
	CAML	T1,VRFTOP	;ENCROACHING ON TEMP STRINGS ?
	JRST	VPAN32
VPAN30: ADDI	T1,1
	MOVEM	T1,VRFBTB
	MOVEM	T1,VRFBOT
	JRST	VPN2
VPAN32: PUSH	P,T1
	PUSHJ	P,VPAN16
	SKIPE	VRFBOT
	JRST	VPAN33
	POP	P,T1
	CAMLE	T1,.USREL
	JRST	VPAN32
	JRST	VPAN92
VPAN33:	POP	P,T1
	SKIPN	A,APPLST
	JRST	VPAN30
	SETZ	E,
VPAN34: MOVE	C,APPLST(A)
	CAILE	C,(T1)
	JRST	VPLAB1
	AOJ	E,
	SOJG	A,VPAN34
VPLAB1:	JUMPE	E,VPAN30
	MOVE	X2,VRFBOT
	MOVEI	T,^D47
	SETZ	A,
VPLAB2:	MOVEI	T1,^D47(X2)
	PUSHJ	P,VSUB1
	MOVEI	X2,(T1)
	SOJG	E,VPLAB2
	SUBI	T1,1
VPAN35: CAMG	T1,VRFTOP
 
 
	JRST	VPAN36
	PUSH	P,T1
	PUSHJ	P,VPAN16
	POP	P,T1
	JRST	VPAN35
VPAN36: MOVEI	E,1
	ADDI	T1,1
	MOVEM	T1,VRFBOT
VPAN37: SUBI	T1,^D47
	HRL	T1,APPLST(E)
	PUSH	P,T1
	PUSH	P,T
	MOVEI	T,^D46(T1)
	BLT	T1,(T)
	POP	P,T
	POP	P,T1
	MOVE	C,MASAPP
	SUBI	C,MASAPP
	JUMPE	C,VPAN38
VPLAB3:	HRRZ	A,MASAPP(C)
	CAMN	A,APPLST(E)
	HRRM	T1,MASAPP(C)
	SOJG	C,VPLAB3
VPAN38: AOJ	E,
	MOVEI	T1,(T1)
	CAMLE	E,APPLST
	JRST	VPAN39
	MOVEI	X2,-^D47(T1)
	SETZ	T,
	MOVEI	A,^D47
	PUSHJ	P,VSUB1
	JRST	VPAN37
VPAN39: MOVEM	T1,VRFBTB
	JRST	VPN2		; DONE WITH MOVING UP APP BLKS
VPN21:	ADDI	T1,1		; START OF APPEND BLOCK SPACE
	CAMN	T1,VRFBTB	; ANY CHANGE?
	JRST	VPN2		; NO - NOTHING TO DO
	MOVEM	T1,VRFBTB	; YES - SAVE NEW START ADDRESS
	MOVE	E,APPLST	; ANY APPEND BLOCKS
	JUMPE	E,VPN25		; NO - END = START
VPN22:	MOVEI	X2,(T1)		; LOWER ADDR OF NEW BLOCK
	ADDI	T1,^D47		; UPPER ADDR OF NEW BLOCK + 1
	MOVEI	T,^D47		; MOVING UP
	SETZ	A,		; NOT DOWN
	PUSHJ	P,VSUB1		; SKIP PAST ANY BUFFERS
	SUBI	T1,^D47		; NEW APP BLK. START ADDR.
	PUSH	P,T1		; SAVE AROUND BLT
	HRL	T1,APPLST(E)	; ADDR. OF CURRENT BLK.
	MOVEI	T,^D46(T1)	; END OF NEW BLK.
	BLT	T1,(T)		; MOVE 1 APPEND BLOCK DOWN
	POP	P,T1		; RESTORE NEW BLOCK PTR.
	MOVE	C,MASAPP	; DETERMINE NUMBER OF MASTER
	SUBI	C,MASAPP	; APPEND BLOCKS
	JUMPE	C,VPN24		; NONE - CONTINUE MOVE DOWN
VPN23:	HRRZ	A,MASAPP(C)	; GET MASTER APP. BLK. KEY
	CAMN	A,APPLST(E)	; DOES IT POINT TO MOVED APP. BLK.?
	HRRM	T1,MASAPP(C)	; YES - POINT IT TO NEW ADDR.
	SOJG	C,VPN23		; CHECK ALL MASTER APP. BLKS.
VPN24:	MOVEI	T1,^D47(T1)	; ADVANCE PAST NEW APP. BLK.
	SOJG	E,VPN22		; MOVE DOWN EACH EXISTING APP. BLK
VPN25:	MOVEM	T1,VRFBOT	; WHEN DONE - MARK END OF BLKS.
VPN2:	MOVEI	R,^D10
	MOVEI	T,^D47
	SETZ	A,
	MOVE	X2,VRFBOT
VPLAB4:	MOVEI	T1,^D47(X2)
	PUSHJ	P,VSUB1
	MOVEI	X2,(T1)
	SOJG	R,VPLAB4
	SUBI	T1,1
VPN3:	CAMG	T1,VRFTOP
	JRST	VPAN92
	PUSH	P,T1
	PUSHJ	P,VPAN16
	POP	P,T1
	JRST	VPN3
 
 
VPAN16: MOVE	X2,.JBREL	;GET MORE CORE AND MOVE UP TEMP STRS.
	MOVE	C,CORINC
	ADDI	C,(X2)
	CORE	C,
	INLEMS(60,60,PANIC1)
	MOVE	X2,.USREL
	PUSHJ	P,DPANIC##	;YES, SPECICAL HANDLING
	SKIPN	VRFBOT
	POPJ	P,
	MOVE	C,VRFTOP
	CAIE	C,(X2)
	JRST	VPLAB5
	MOVE	C,.USREL
	MOVEM	C,VRFTOP
	POPJ	P,
VPLAB5:	PUSHJ	P,VPRES1
	MOVE	X1,.USREL
	MOVEI	T,10
VPAN41: HRRZ	T1,SRTDBA(T)
	JUMPN	T1,VPAN42
	SOJGE	T,VPAN41
	JRST	VPAN43
VPAN42: MOVEI	T1,-1(T1)
	CAMLE	T1,VRFTOP
	JRST	VPAN44
	SETO	T,
VPAN43: MOVE	T1,VRFTOP
VPAN44: MOVEI	R,(X1)
	SUBI	R,(X2)
	SKIPN	C,NUMMSP
	JRST	VPAN5
VPAN45: HRRZ	E,MASAPP(C)	;UPDATE MASTER APP BLK.
	CAILE	E,(T1)
	CAILE	E,(X2)
	JRST	VPLAB6
	ADDI	E,(R)
	HRRM	E,MASAPP(C)
VPLAB6:	SOJG	C,VPAN45
VPAN5:	SKIPN	C,APPLST
	JRST	VPAN56
VPAN51: MOVE	A,APPLST(C)	;UPDATE OTHER APP BLKS.
	HRRZ	E,(A)
	HRRZI	G,(A)
	ADDI	E,(G)
VPAN55: HRRZ	A,(E)
	CAILE	A,(T1)
	CAILE	A,(X2)
	JRST	VPLAB7
	ADDI	A,(R)
	HRRM	A,(E)
VPLAB7:	SOJ	E,
	CAIE	E,(G)
	JRST	VPAN55
	SOJG	C,VPAN51
VPAN56:	HRLS	T1		;SOURCE-1 TO BOTH HALVES
	AOBJN	T1,VPN56A	;SOURCE TO BOTH
VPN56A:	ADDI	T1,(R)		;ADD INCREMENT, GIVES XWD SOURCE,DEST
	HRLS	X1		;LIMIT TO BOTH HALVES
	SUBI	X1,(R)		;DECREMENT BY INCREMENT
	MOVSS	X1		;XWD LIMIT-INCREMENT,LIMIT
	HRLS	R		;INCREMENT TO BOTH HALVES
	MOVE	X2,X1		;SAVE LIMIT
	AOBJN	X1,VPN56B	;PREPARE TOSET UP
VPN56B:	SUB	X1,R		;LARGEST SAFE BLT POINTER IN X1
	CAMGE	X1,T1		;LARGER THAN REQUIRED ?
	MOVE	X1,T1		;NO, USE REQUIRED
	PUSH	P,X1		;SAVE POINTER
	BLT	X1,(X2)		;BLOCK TRANSFER
	POP	P,X1		;GET BACK POINTER
	CAMN	X1,T1		;WAS IT FINAL BLOCK ?
	JRST	VPN56C		;YES
	SUBI	X2,(R)		;NO, REDUCE LIMIT
	JRST	VPN56B		;AND DO ANOTHER
VPN56C:	MOVEI	X1,-1(T1)
	JUMPL	T,VPAN6
 
 
VPAN58: HLRZ	X2,SRTDBA(T)
	SUBI	X2,1
	CAMG	X2,VRFTOP
	JRST	VPAN6
	SOJL	T,VPAN57
	HRRZ	T1,SRTDBA(T)
	CAIN	T1,1(X2)
	JRST	VPAN58
	SOJA	T1,VPAN44
VPAN57: MOVE	T1,VRFTOP
	JRST	VPAN44
VPAN6:	HRRZM	X1,VRFTOP
	POPJ	P,
VPAN92: POP	P,T
	POP	P,T1
	POP	P,E
	POP	P,C
	POP	P,A
	POP	P,G
	POP	P,X2
	POP	P,X1
	POP	P,R
	POPJ	P,
 
 
 
 
;PACK DOWN ROUTINE.
 
 
VPRESS: PUSH	P,[Z VPR4]
VPRES1: MOVE	A,MASAPP
	SUBI	A,MASAPP
	MOVEM	A,NUMMSP	;COUNT OF KEYS IN MASTER APPEND BLOCK.
	SETZM	NUMAPP		;COUNT OF KEYS IN ALL OTHER APP. BLKS.
	SETZM	APPLST		;COUNT OF OTHER APP. BLKS.
	SKIPN	A,VRFBOT
	POPJ	P,
	SETZ	E,		;E IS INDEX FOR APPLST.
	MOVEI	G,10		;G IS INDEX TO SRTDBA
	SKIPN	SRTDBA		;BUFFERS IN THE WAY?
	JRST	VLOPF1		;NO.
VLOOP:	HLRZ	C,SRTDBA(G)	;FIND THE APPEND BLKS, WHICH ARE
	JUMPE	C,VLOPFN
	CAIL	C,(A)		;BETWEEN VRFBTB AND VRFBOT.
	JRST	VLOPFN
	HRRZ	C,SRTDBA(G)
	CAMG	C,VRFBTB
	JRST	VLOPFN
	PUSHJ	P,VCHPBK	;A BUFFER IS IN THE APP BLK SPACE.
	HLRZ	A,SRTDBA(G)
	CAMGE	A,VRFBTB
	JRST	VLOOP4		;NO APP BLKS. LEFT.
VLOPFN:	SOJGE	G,VLOOP
VLOPF1: MOVE	C,VRFBTB	;POSSIBLY NO BUFFERS WERE SEEN.
	PUSH	P,[Z VLOOP4]
VCHPBK:	HRRZI	X1,(A)		;MAKE SURE
	SUBI	X1,(C)		;THIS SPACE
	JUMPLE	X1,CPOPJ	;IS STILL THERE
	PUSH	P,X2
	IDIVI	X1,^D47		;AND IS DIVISIBLE BY 47
	SUBI	A,(X2)
	POP	P,X2
VCHPB1:	SUBI	A,^D47		;CUT UP THIS KNOWN SPACE.
	CAIGE	A,(C)
	POPJ	P,
	CAIL	E,APPMAX	;IS APPEND LIST FULL ?
	JRST	APPFUL		;YES, GRIPE
	MOVEM	A,APPLST+1(E)
	AOJA	E,VCHPBK
 
 
VLOOP4: MOVEM	E,APPLST	;STORE COUNT OF APP BLKS.
	SETZ	A,		;FIND NO. OF KEYS.
	JUMPE	E,VLOOP5
VPLAB8:	MOVE	X1,APPLST(E)
	HRRZ	X1,(X1)		;GET COUNT OF STRING POINTERS
	ADDI	A,(X1)
	SOJG	E,VPLAB8
VLOOP5: MOVEM	A,NUMAPP
	POPJ	P,

APPFUL:	INLEMS(6,71,APPERR)
APPERR:	ERROM(71,</
? Out of static list space/>)
 
 
 
 
 
 
VPR4:	MOVE	G,SVRTOP	;SET UP LOWER BOUND.
	SETZ	C,
	MOVEI	E,10
	SKIPN	SRTDBA		;ANY BUFFERS?
	JRST	VPR00		;NO.
VPR5:	HLRZ	A,SRTDBA(C)
	CAIN	G,(A)		;GET ABOVE THE BUFFERS.
	JRST	VPLAB9
	PUSHJ	P,PAKBLK
	JRST	VPR00
VPLAB9:	HRRZ	G,SRTDBA(C)
	AOJ	C,
	CAIG	C,10
	JRST	VPR5
VPLABA:	SETZM	SRTDBA(E)	;ABOVE ALL THE BUFFERS, SO "ERASE" THEM.
	SOJGE	E,VPLABA
	JRST	VPR00
PAKBLK: JUMPE	C,CPOPJ
	XLIST
>
	IFN	BASCX,<
	LIST
PAKBL0: SETZ	X1,		;SET UP SRTDBA SO THAT
	SUBI	E,(C)		;THE NEXT HIGHEST BUFFER
PAKBL1: MOVE	X2,SRTDBA(C)	;IS IN THE FIRST LOCATION,
	MOVEM	X2,SRTDBA(X1)	;AND "ERASE" THE LOWER BUFFERS.
	SETZM	SRTDBA(C)
	AOJ	X1,
	AOJ	C,
	SOJGE	E,PAKBL1
VPLABB:	CAILE	X1,10
	POPJ	P,
	SETZM	SRTDBA(X1)
	AOJA	X1,VPLABB
	XLIST
>
	IFN	BASXCT,<
	LIST
 
 
VPR00:	MOVEM	G,VARFRE
VPR0:	HRRZI	X2,-1		;THE LOWEST ADDRESS WILL GO INTO X1
	MOVE	A,FLVSP 	;A POINTS TO EACH ENTRY ON THE ROLL.
	SETZI	X1,		;X1 WILL GET THE LOC OF NEXT LOWEST POINTER
 
 
VPR1:	CAMN	A,CEVSP 	;STARTING TO SCAN SVRROL, OR STILL IN VSPROL?
	MOVE	A,SVRBOT
	CAML	A,SVRTOP
	JRST	VPR2		;SEARCH FOR MINIMUM IS OVER.
	HRRZ	E,(A)		;GET POINTER ADDRESS.
	JUMPE	E,VPR11 	;NULL POINTER?
	CAIL	E,(G)		;HAVE WE MOVED THIS STRING ALREADY?
	CAIG	X2,(E)		;NO, IS IT A LOWER STRING ADDRESS?
VPR11:	AOJA	A,VPR1		;NO. LOOK AT NEXT STRING.
 
 
	MOVE	X1,A		;WE HAVE FOUND A STRING WITH LOWER ADDRESS.
	MOVE	X2,E
	AOJA	A,VPR1
 
 
VPR2:	JUMPE	X1,VPR3 	;ANY MORE STRINGS TO MOVE?
	HLRE	E,(X1)		;CALCULATE WORD LENGTH..
	JUMPN	E,VPLABC	;IS THIS A NULL STRING?
	SETZM	(X1)		;YES. IGNORE IT.
	JRST	VPR0
VPLABC:	HRL	G,(X1)		;GET THE OLD ADDRESS OF THIS STRING
	MOVN	E,E		;GET WORD LENGTH
	ADDI	E,4
	PUSH	P,G
	IDIVI	E,5
	POP	P,G
	ADDI	E,-1(G)
	HRRZI	X2,(G)
	HRRZ	C,(X1)		;GET CURRENT ADDRESS OF STRING
	CAMN	X2,C		;IS IT THE SAME AS THE NEW ONE
	JRST	VPR28
	SKIPN	SRTDBA		;POSSIBLY BUFFERS IN THE WAY?
	JRST	VPR23		;NO.
	SETZ	C,
VPR21:	HLRZ	X2,SRTDBA(C)
	JUMPE	X2,VPR22
	CAILE	X2,(E)
	JRST	VPR22
	SUBI	E,-1(G)
	HRR	G,SRTDBA(C)
	ADDI	E,-1(G)
	AOJ	C,
	CAIG	C,10
	JRST	VPR21
	MOVEI	E,10
VPLABD:	SETZM	SRTDBA(E)
	SOJGE	E,VPLABD
	JRST	VPR23
VPR22:	JUMPE	C,VPR23
	PUSH	P,E
	PUSH	P,X1
	MOVEI	E,10
	PUSHJ	P,PAKBL0	;WIND DOWN THE BUFFERS.
	POP	P,X1
	POP	P,E
 
 
VPR23:	HRRZ	X2,(X1) 	;GET THE OLD STRING ADDRESS
	HRRM	G,(X1)		;STORE THE NEW ADDRESS IN THE MAIN KEY.
	PUSH	P,G
	BLT	G,(E)		;MOVE THE STRING DOWN
	POP	P,G
	SKIPN	X1,NUMMSP	;UPDATE MASTER APP BLK?
	JRST	VPR25		;NO NEED.
	MOVE	X1,MASAPP	;GET NO OF MASAPP KEYS
	SUBI	X1,MASAPP	;SINCE NUMMSP CAN CHANGE
VPR24:	HRRZ	A,MASAPP(X1)	;POSSIBLY.
	CAIE	A,(X2)
	JRST	VPLABE
	HRRM	G,MASAPP(X1)
	SOS	NUMMSP
VPLABE:	SOJG	X1,VPR24
VPR25:	SKIPN	NUMAPP		;UPDATE OTHER APP BLKS?
	JRST	VPR28		;NO NEED.
	PUSH	P,E		;POSSIBLY.
	MOVE	X1,APPLST
VPR26:	HRRZ	A,APPLST(X1)
	HRRZ	C,(A)		;GET NO OF STRING PTRS
	ADDI	C,(A)
VPR27:	HRRZ	E,(C)
	CAIE	E,(X2)
	JRST	VPLABF
	HRRM	G,(C)
	SOS	NUMAPP
VPLABF:	SOJ	C,
	CAILE	C,(A)
	JRST	VPR27
	SOJG	X1,VPR26
	POP	P,E
VPR28:	AOS	G,E		;LOOK FOR A HIGHER ADDRESS NEXT TIME
	MOVEM	E,VARFRE
	JRST	VPR0
 
 
VPR3:	PUSHJ	P,BASORT	;RESTORE SRTDBA
	SETOM	VPAKFL		;STRINGS ARE TIGHTLY PACKED
	POPJ	P,
	XLIST
>
	LIST
SUBTTL DECIMAL NUMBER EVALUATE/PRINT
;ROUTINE TO EVALUATE NUMBER
;T: PNTR TO FIRST CHAR, C: FIRST CHAR
;NON-SKIP IS FAIL RETURN
;RETURN NUMBER IN N
 
 
;N: ACCUM NBMR, B: SCA FAC, D: DIG CNT, USE FLGS IN LEFT OF F
 
 
EVANUM: SETZB	N,B		;CLEAR ACS
	MOVEI	D,8
	MOVEI	F,(F)		;CLEAR LH OF F
 
 
	TLNE	C,F.PLUS	;SKIP +
	JRST	EVAN1
	TLNN	C,F.MINS	;CHECK FOR -
	JRST	EVAN2		;NO
	TLO	F,F.MIN 	;SET MINUS FLG
EVAN1:	SKIPN	IFIFG
	JRST	EV1
	PUSHJ	P,NXCHD
	JRST	EVAN2
EV1:	PUSHJ	P,NXCH
EVAN2:	TLNN	C,F.DIG 	;DIGIT?
	JRST	EVAN3		;NO
 
 
	TLO	F,F.NUM 	;DIGIT SEEN FLAG
	JUMPE	N,EVAN2A	;DONT COUNT LEADING ZEROS
	SOJG	D,EVAN2A	;COUNT DIGIT,  GO ACCUM IF OK
;			REST OF DIGITS ARE INSIGNIFIGANT.
	AOJA	B,EVAN2B	;LEAD OR TRAIL 0, FUDGE SCA FAC
 
 
EVAN2A: IMULI	N,^D10		;ACCUMULATE DIGIT
	ADDI	N,-60(C)
EVAN2B: TLNE	F,F.DOT 	;DECIMAL SEEN?
	SUBI	B,1		;YES.  COUNT DOWN SCALE FACT
	JRST	EVAN1		;GO TO NEXT CHAR
 
 
EVAN3:	TLNN	C,F.PER 	;NOT DIGIT.  DEC PNT?
	JRST	EVAN4		;NO.
	TLOE	F,F.DOT 	;YES, SET FLG & CHK ONLY ONE
	POPJ	P,		;2 DEC PNTS
	JRST	EVAN1
 
 
EVAN4:	TLNN	F,F.NUM 	;DID WE SEE A DIGIT?
	POPJ	P,		;NO.  WHAT A LOUSY NUMBER
	MOVEI	X1,"E"
	CAIE	X1,(C)		;EXPLICIT SCALE FACTOR?
	JRST	EVAN8		;NO
	XLIST
	IFN	BASEC,<
	LIST
	PUSH	P,T
	PUSH	P,C
	XLIST
>
	LIST
	SKIPN	IFIFG
	JRST	EV2
	PUSHJ	P,NXCHD
	JRST	EVLAB1
EV2:	PUSHJ	P,NXCH		;DO LOOK AHEAD
EVLAB1:	TLNE	C,F.PLUS	;SCALE FACTOR SIGN
	JRST	EVAN5
	TLNN	C,F.MINS
	JRST	EVAN6
	TLO	F,F.MXP
EVAN5:	SKIPN	IFIFG
	JRST	EV3
	PUSHJ	P,NXCHD
	JRST	EVAN6
EV3:	PUSHJ	P,NXCH
EVAN6:	TLNN	C,F.DIG 	;CHK FOR DIGIT
	XLIST
	IFN	BASXCT,<
	LIST
	POPJ	P,
	XLIST
>
	XLIST
	IFN	BASEC,<
	LIST
	JRST	EVAN6A
	POP	P,A
	POP	P,A
	XLIST
>
	LIST

	MOVEI	A,-60(C)	;SAVE FIRST EXPON DIGIT
	SKIPN	IFIFG
	JRST	EV4
	PUSHJ	P,NXCHD
	JRST	EVLAB2
EV4:	PUSHJ	P,NXCH
EVLAB2:	TLNN	C,F.DIG 	;IS THERE A SECOND DIGIT
	JRST	EVAN7		;NO
	IMULI	A,^D10		;YES.  ACCUMULATE IT
	ADDI	A,-60(C)
	SKIPN	IFIFG
	JRST	EV5
	PUSHJ	P,NXCHD
	JRST	EVAN7
EV5:	PUSHJ	P,NXCH		;DO LOOK AHEAD
EVAN7:	TLNE	F,F.MXP 	;NEG EXPON?
	MOVN	A,A		;YES.  NEGATE IT
	ADD	B,A		;ADD TO SCALE FACTOR
	XLIST
	IFN	BASEC,<
	JRST	EVAN8
EVAN6A:	POP	P,C
	POP	P,T
	XLIST
>
	LIST
	EXTERN	TYPE,PFLAG
EVAN8:	CLEARM	TYPE		;ASSUME REAL
	JUMPL	B,EVAN8F	;
	TLNE	F,F.DOT		;PERIOD SEEN?
	JRST	EVAN8F		;YES, REAL NUMBER
	CAME	C,[XWD F.STR,"%"] ;PERCENT SEEN?
	JRST	EVAN9		;NO
	PUSHJ	P,NXCH		;
	SETOM	PFLAG		;YES WE DID
EVAN9A:	SETOM	TYPE		;
	XLIST
	IFN	BASEC,<
	LIST
	JUMPE	B,CPOPJ1	;
	FAIL	<? Integer overflow>
	XLIST
>
	IFE	BASEC,<
	LIST
	SETZM	TYPE		;
	JUMPN	B,EVAN8F
	SETOM	TYPE		;
	CLEARM	LIBFLG		;CLEAR OVERFLOW FLAG
	JRST	EVAN8E+1
	XLIST
>
	LIST
EVAN9:	SKIPGE	PFLAG
	JRST	EVAN9A		;AND SKIP RETURN
EVAN8F:	JUMPE	N,CPOPJ1
EVAN8A: MOVE	X1,N		;)
	IDIVI	X1,^D10 	;)REMOVE ANY TRAILING ZEROS
	JUMPN	X2,EVAN8B	;)  IN MANTISSA.  (REASON:
	MOVE	N,X1		;)  SO THAT, E.G., .1,
	AOJA	B,EVAN8A	;)  .10, .100, ..., ARE THE SAME)
EVAN8B: TLO	N,233000	;FLOAT N
	FAD	N,[0]
	SETZM	LIBFLG		;CLEAR OVER/UNDERFLOW FLAG.
EVAN8C: CAIGE	B,^D15		;SCALE UP IF .GE. 10^15
	JRST	EVAN8D
	SUBI	B,^D14		;SUBTRACT 14 FROM SCALE FACTOR
	FMPR	N,D1E14 	;MULTIPLY BY 10^14
	JRST	EVAN8C		;GO LOOK AT SCALE AGAIN
EVAN8D: CAML	B,[EXP -^D4]	;SCALE DOWN IF .LT. 10^-4
	JRST	EVAN8E
 
 
	ADDI	B,^D18		;ADD 18 TO SCALE
	FMPR	N,D1EM18	;MULTIPLY BY 10^-18
	JRST	EVAN8D		;GO LOOK AT SCALE AGAIN
EVAN8E: FMPR	N,DECTAB(B)	;SCALE N
	TLNE	F,F.MIN 	;MINUS?
	MOVN	N,N		;YES.  NEGATE IT
	SKIPE	LIBFLG		;SKIP IF NO OVER/UNDERFLOW.
	JRST	CPOPJ
	JRST	CPOPJ1		;SUCCESS RETURN, NUMBER IN N
;POWER-OF-TEN TABLE.
 
 
D1EM18: OCT	105447113564	;10^-18
 
 
DECFLO:
D1EM4:	OCT	163643334273	;10^-4
	OCT	167406111565
	OCT	172507534122
	OCT	175631463146
DECTAB: DEC	1.0		;10^0
	DEC	1.0E1
	DEC	1.0E2
	DEC	1.0E3
	DEC	1.0E4
	DEC	1.0E5
	DEC	1.0E6
	DEC	1.0E7
	OCT	233575360401
	DEC	1.0E9
	DEC	1.0E10
	DEC	1.0E11
	OCT	250721522451	;10^12
	OCT	254443023471
D1E14:	OCT	257553630410	;10^14
DECCEI:
 
 
MAXEXP=^D38
DECFIX: EXP 225400000000
FIXCON: EXP 233400000000
 
 
;FLAGS USED BY DECIMAL READER/PRINTER
 
 
F.NUM=200000	;DIGIT SEEN
F.MIN=100000	;MINUS SEEN
F.MXP=40000	;MINUS EXPONENT
F.DOT=20000	;DECIMAL POINT SEEN
;ROUTINE THAT SKIPS OVER ONE DATA FIELD
SKIPDA: TLNE	C,F.QUOT	;QUOTE STRING?
	JRST	QSKIP		;YES, USE QSKIP ROUTINE
SKLAB1:	TLNE	C,F.COMA+F.TERM ;FIELD TERMINATOR?
	JRST	CPOPJ1
	PUSHJ	P,NXCH
	JRST	SKLAB1
	DEFINE	INT(LABEL),<
INTERN	LABEL
LABEL:
>
	IFN	BASEDT,<
INT	VPANIC
INT	VSUB1
INT	BASORT
INT	UXIT7
INT	UXIT6
>
	IFN	BASCOM,<
INT	QUEUER
INT	.HELPR
INT	OUCHX
INT	UXIT7
INT	UXIT6
INT	NOGETD
INT	VPANIC
INT	OUTCNT
INT	ERASE
INT	INLSYS
INT	PTXER1
INT	OUTERR
INT	DSKOT
INT	LINPT
INT	OUTPT
INT	PRTOCT
INT	DATTBL
INT	EOFFL
INT	GOSR2
INT	GOSR3
INT	DPBSTR
INT	INLINE
INT	INLGEN
INT	INLB1
INT	XXXXXX
INT	INPT
INT	INCNT
INT	EDTXT1
>
	IFN	BASXCT,<
INT	QUEUER
INT	.HELPR
INT	ERRMSG
INT	ERRMS2
INT	PANIC1
INT	OUCHX
INT	SCNLT1
INT	ERACOM
INT	SCN2
INT	SCNLT3
INT	CLOSUP
INT	SCNLT2
INT	CLOB
INT	SCN3
INT	RPUSH
INT	PANIC
INT	QSELS
INT	OPENUP
INT	PRESS
INT	BUMPRL
INT	ERASE
INT	EDTXT1
>
	END