Google
 

Trailing-Edge - PDP-10 Archives - BB-H138F-BM_1988 - 7-sources/cpascn.mac
There are 7 other files named cpascn.mac in the archive. Click here to see a list.
TITLE CPASCN  --  Command Scanner Interface for CMDPAR
SUBTTL Irwin L. Goverman/ILG/LSS/MLB/PJT/WLH/DC   25-Sept-79


;
;
;
;	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1975, 1986.
;	ALL RIGHTS RESERVED.
;
;	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
;	COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
;	THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
;	ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
;	AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
;	SOFTWARE IS HEREBY TRANSFERRED.
;
;	THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
;	NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
;	EQUIPMENT CORPORATION.
;
;	DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
;	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
;


		SALL			;SUPPRESS MACRO EXPANSION

		SEARCH	CPASYM,CMDPAR	;OPEN SYMBOLS NEEDED
		PROLOG(CPASCN)

;This module emulates the command scanning routines (COMND JSYS) found
;	in the TOPS-20 operating system. (Somewhat)
SUBTTL Table of Contents

;               TABLE OF CONTENTS FOR CPASCN
;
;
;                        SECTION                                   PAGE
;    1. Table of Contents.........................................   2
;    2. Revision History..........................................   3
;    3. Local Definitions.........................................   5
;    4. Module Storage............................................   6
;    5. S%INIT  --  Initialize the CPASCN Module..................   7
;    6. S%ERR - ERROR TYPEOUT ROUTINE.............................   8
;    7. S%ERR   --      ERROR MESSAGES FROM COMND.................   8
;    9. S%CMND  --  Scan a command................................  10
;   10. S%EXIT  --      Exit Address for Interrupt Breakout.......  11
;   11. S%SIXB  --      Convert ASCII to SIXBIT...................  12
;   12. CNVSIX  --      CONVERT ATOM BUFFER TO SIXBIT.............  12
;   13. RETYPE  --  Retype current line including the prompt......  19
;   14. TYPRMT  --  Retype the prompt if there is one.............  19
;   15. TYLINE  --  Retype the line until current position........  19
;   16. Atom Buffer Routines / INILCH - Init Atom Buffer..........  26
;   17. Atom Buffer Routines / STOLCH - Store Character in Atom Buffer  26
;   18. Atom Buffer Routines / CHKLCH - Return Number of Characters  26
;   19. Atom Buffer Routines / TIELCH - Terminate Atom Buffer With NULL  26
;   20. CMCIN  --  Read One Character for Processing..............  27
;   21. HELPER  --  Do caller supplied and default HELP text......  30
;   22. DOHLP  --  Do caller supplied HELP text...................  30
;   23. CMAMB  --  Handle Ambiguous Typein........................  30
;   24. Command Function / .CMINI - Init the scanner and do ^H....  33
;   25. Command Function / .CMSWI - Parse a SWITCH................  34
;   26. Command Function / .CMKEY - Parse a KEYWORD...............  35
;   27. Command Function / .CMTXT - Parse Arbitrary Text to Action Character  39
;   28. Function .CMNOI  --  Parse a NOISE-WORD...................  39
;   29. Command Function / .CMCFM - Command Confirmation (end-of-line)  40
;   30. Command Function / .CMNUM - Parse an INTEGER in any base..  42
;   31. Command Function / .CMNUX - Parse an INTEGER in any base (special break)  42
;   32. Command Function / .CMDEV - Parse a DEVICE specification..  45
;   33. Command Function / .CMQST - Parse a QUOTED STRING.........  45
;   34. Command Function / .CMNOD - Parse a NODE Specification....  46
;   35. PATHIN  Routine to Parse TOPS-10 Path Specification.......  49
;   36. PATH SUPPORT ROUTINES.....................................  51
;   37. S%SCMP  --  String Comparison Routine.....................  55
;   38. S%TBLK  --  Table lookup routine..........................  57
;   39. S%TBAD  --      Table Add Routine.........................  60
;   40. S%TBDL  --      Table Delete Routine......................  61
SUBTTL	Revision History


COMMENT \

Edit	GCO	Reason
----	---	-------------------------------------------

0001		Create CPASCN module
0002		Fix a number of interrupt race problems and
		start adding ESCape sequence code
0003		Add support for parsing of a string; fix bug in
		.CMINI which caused prompts not at left margin
0004	019	Add code for CR.COD and change S%ERR to return
		string. Add ERRBUF for the error messages.
0005	021	Use all the new terminal I/O routines in CPAKBD.
0010		Fix S%CMND to Allow Multiple File Specs to be separated

		by Commas (i.e DSK:FIL1,DSK:FIL2,etc)

		Also Changed FILBRK and PPNBRK sets to allow Full Path
		specifications (Path Not currently implemented)

		Added routine CMRPTH to Get [p,pn,foo,foo,...]

0011	037	Allow recognition on typed node name to be
		interpreted as a field terminator.
0012		Make Fix to Edit 10 for Multiple File Specs.
		Allow only DEV:FILNAM.EXE[P,PN,PATH,...] as filespec

0013	039	Change HELP text for .CMUSR function.

0014		Correct Path Specification added in edit 0010
0015		Code Clean up for ambiguous commands
0016		Make ^H work properly for commands with extra arguments
0017		Raise all LC to UC when comparing noise
		words. Changes made around label CMNOI4.
0020	G044	Add new Routines S%TBAD and S%TBDL for adding and
		deleting entries from command tables
0021		Fix S%TBAD Bug
0022		FIX .CMDEV and Let Node function do Parse Only on Names
0023		Fix S%TBLK, to save the P's
0024		Fix .CMNOD to save SIXBIT value when CM%PO is set
0025		Make S%SIXB to read sixbit strings from ascii strings
0026		If only one element in a Keyword or Switch Table do not
		Type out "one of the following" ..but put out a " ".
0027		Change name of ERRBUF to SAVBUF and make it Global. Saving
		of Stopcodes on the -20 will use this area.
0030		Change SAVE to $SAVE
0031		Make S%CMND return true if CM%NOP is set on the -20
0032		CORRECT EXTRA LINE TYPEOUT IN HELP TEXT
0033		DO NOT ALLOW NULL NODE NAMES
0034		Change all messages to Upper and lower case and change 
		Unrecognized Control Character to Ambiguous
0035		Support CM%BRK and output to other than terminal
0036		Change calling convention of NUMIN
0037		Add support for .CMTAD

\  ;END OF REVISION HISTORY
; Entry Points found in this module

	ENTRY	S%INIT			;INIT THE COMMAND SCANNER MODULE
	ENTRY	S%CMND			;SCAN A COMMAND
	ENTRY	S%SCMP			;COMPARE TWO STRINGS
	ENTRY	S%TBLK			;LOOK UP A STRING IN A TABLE
	ENTRY	S%ERR			;TYPE OUT SCANNER'S LAST ERROR
	ENTRY	S%EXIT			;INTERRUPT DEBRK ADDRESS FOR COMND
	ENTRY	S%TBAD			;ADD ENTRY TO COMMAND TABLES
	ENTRY	S%TBDL			;DELETE ENTRY FROM COMMAND TABLES
	ENTRY	S%SIXB			;CONVERT ASCII STRING TO SIXBIT VALUE
SUBTTL Local Definitions

; Special Accumulator definitions

	P5==P4+1			;S%CMND NEEDS LOTS OF ACS
	F==14				;FLAG AC
	Q1==15				;
	Q2==16				;DON'T DEFINE Q3 OR Q4

; Bad parse return macro

DEFINE NOPARS(CODE,TEXT)<
	  SKIPA	T1,[XWD	CODE,[ASCIZ\TEXT\]]
	XLIST
	  SKIPA
	  JRST  XCOMNE
	LIST
	SALL
> ;END OF NOPARS DEFINITION

; Special bit testing macros

DEFINE JXN(AC,FLD,ADDR)<
	  TXNN	AC,FLD
	XLIST
	  SKIPA
	  JRST  ADDR
	LIST
	SALL
> ;END OF JXN DEFINITION

DEFINE JXE(AC,FLD,ADDR)<
	  TXNE	AC,FLD
	XLIST
	  SKIPA
	  JRST	ADDR
	LIST
	SALL
> ;END OF JXE DEFINITION

	DEFINE	RETSKP<JRST	[AOS 0(P)
			         POPJ P,] >
SUBTTL	Module Storage

$IMPURE

; Bit table - 36. Words long with word N containing 1B<N>
	
	XX==0
BITS:	XLIST
	REPEAT ^D36,<EXP 1B<XX>
			XX==XX+1>
	LIST
	$DATA	ATBPTR			;ATOM BUFFER POINTER (END)
	$DATA	ATBSIZ			;ATOM BUFFER SIZE
	$DATA	STKFEN			;FENCE FOR STACK RESTORATION
	$DATA	FNARG			;FUNCTION ARGUMENT
	$DATA	CMCCM,2			;SAVED CC CODES
	$DATA	CMRBRK			;POINTER TO BREAK SET TABLE
	$DATA	CMCSF			;SAVED FLAGS
	$DATA	CMCSAC,7		;SAVED ACS DURING S%TXTI FROM S%CMND
	$DATA	CMCSC			;
	$DATA	CMCBLF			;
	$DATA	TBA			;TABLE ARGUMENTS
	$DATA	STRG			;TEMP STRING POINTER
	$DATA	REMSTR			;"REMEMBER"ED STRING
	$DATA	XXXPTR			;RE-USABLE STRING POINTER STORAGE
	$DATA	CRBLK,CR.SIZ		;RETURNED BLOCK OF ANSWERS
	$DATA	TABDON			;END OF TAB FOR "?"
	$DATA	TABSIZ			;SIZE OF TAB LARGER THAN LARGEST KEYWORD
	$DATA	LSTERR			;ERROR CODE RETURNED FROM NOPARS
	$DATA	BIGSIZ			;LENGTH OF LONGEST KEYWORD
	$DATA	PWIDTH			;TERMINAL'S WIDTH
	$DATA	CURPOS			;LINE POSITION OF CURSOR
	$DATA	Q3SAVE			;NO Q3 EXISTS
	$DATA	IFOB			;INDIRECT FILESPEC FOB
	$DATA	IIFN			;IFN OF INDIRECT FILE
	$DATA	TI,.RDSIZ		;S%TXTI ARGUMENT BLOCK
	$GDATA	SAVBUF,ERRBSZ		;BUFFER FOR ERROR MESSAGES
					;S%ERR AND SCRATCH
TOPS10 <
	$DATA	CMDACS,20		;AC SAVE AREA FOR COMMAND
	$DATA	PTHBLK,.PTMAX	;STORAGE FOR JOB PATH
	$DATA	INCMND			;FLAG FOR IN COMMAND STATE
	$DATA	TBADDR			;ADDRESS OF COMMAND TABLE
	$DATA	ENTADR			;ADDRESS OF ENTRY FOR TABLE
	$DATA	SPCBRK			;SPECIAL BREAK MASK
	$DATA	JFNWRD			;WORD CONTAINING THE JFNS

	$DATA	VAL1 		;DEFINE VALUES FOR THE DATA
	$DATA	VAL2 		;BLOCK FOR SECONDS
	$DATA	VAL3 		;BLOCK FOR MINUTES
	$DATA	VAL4 		;BLOCK FOR HOURS
	$DATA	VAL5 		;BLOCK FOR DAYS
	$DATA	VAL6 		;BLOCK FOR MONTHS
	$DATA	VAL7 		;BLOCK FOR YEARS
	$DATA	VAL8 		;BLOCK FOR DECADES
	$DATA	VAL9 		;BLOCK FOR CENTRIES

	$DATA	DAYNUM 		;DAY NUMBER VALUE "D"
	$DATA	SECOND 		;SECONDS
	$DATA	MINUTE 		;MINUTES
	$DATA	HOURS 		;HOURS
	$DATA	DAYS 		;DAYS
	$DATA	NOW 		;CURRENT DATE AND TIME
	$DATA	TIMPTR 		;POINTER FOR THE TIME
	$DATA	TIMCNT 		;COUNT FOR TIME BUFFER CHARACTERS
	$DATA	LSTCHR 		;LAST CHARACTER SEEN
	$DATA	FLFUTD 		;FUTURE TIME FLAG
	$DATA	FLFUTR 		;FUTURE TIME HOLDER
	$DATA	TIMSAV 		;TIME SAVE ADDRESS
	$DATA	STRDAT,5		;LEAVE ROOM FOR DATA
	$DATA	STRPTR 		;POINTER TO THE BLOCK
>;END TOPS10 CONDITIONAL
	$DATA	INTRPT			;FLAG FOR S%INTR
TOPS20 <
	$DATA	BLKSAV			;COMMAND BLOCK ADDRESS
	$DATA	BUFCNT			;SIZE OF COMMAND BUFFER
>;END TOPS20 CONDITIONAL
	SUBTTL	Date and Time Data Base

$PURE

TOPS10 <
	DEFINE	DAYERR,<
	X	IDT,<Invalid Date Field Specified>
	X	ITF,<Invalid Time Field Specified>
	X	DOR,<Date/time out of range>
	X	DTM,<Value missing in date/time>
	X	MDD,<Missing day in date/time>
	X	DFZ,<Field zero in date/time>
	X	MDS,<Mnemonic date/time switch not implemented>
	X	DFL,<Field too large in date/time>
	X	ILR,<Illegal year format in date/time>
	X	NND,<Negative number in date/time>
	X	NPF,<Not known whether past or future in date/time>
	X	RDP,<Relative Date Parse Required>
	>;END DAYERR

	.ZZ==0
	DEFINE	X(A,B),<
	E..'A==.ZZ
	.ZZ==.ZZ+1>

	DAYERR			;GENERATE THE CODES

	DEFINE	X(A,B),<
E$$'A:	MOVEI	1,E..'A		;GET THE ERROR
	PJRST	ERRRTN>		;SETUP ERROR RETURN

	XLIST
	SALL
	DAYERR			;GENERATE THE ROUTINES
	LIST


ERRRTN:	MOVEM	S1,LSTERR	;SAVE THE LAST ERROR
	$RETF			;RETURN FALSE


	DEFINE	X(A,B),<
	[ASCIZ\B\]>

	XLIST
	SALL
DERTBL:	DAYERR			;GENERATE MESSAGE TABLE
	LIST


DAYTBL:	$STAB
	KEYTAB(2,<FRIDAY>)
	KEYTAB(5,<MONDAY>)
	KEYTAB(3,<SATURDAY>)
	KEYTAB(4,<SUNDAY>)
	KEYTAB(1,<THURSDAY>)
	KEYTAB(6,<TUESDAY>)
	KEYTAB(0,<WEDNESDAY>)
	$ETAB

MONTBL:	$STAB
	KEYTAB(^D4,<APRIL>)
	KEYTAB(^D8,<AUGUST>)
	KEYTAB(^D12,<DECEMBER>)
	KEYTAB(^D2,<FEBRUARY>)
	KEYTAB(^D1,<JANUARY>)
	KEYTAB(^D7,<JULY>)
	KEYTAB(^D6,<JUNE>)
	KEYTAB(^D3,<MARCH>)
	KEYTAB(^D5,<MAY>)
	KEYTAB(^D11,<NOVEMBER>)
	KEYTAB(^D10,<OCTOBER>)
	KEYTAB(^D9,<SEPTEMBER>)
	$ETAB



>;END TOPS10
SUBTTL	S%INIT  --  Initialize the CPASCN Module

TOPS10 <
S%INIT:	MOVSI	S2,'TTY'		;LOAD TTY NAME
	IONDX.	S2,			;GET THE I/O INDEX
	  JFCL				;IGNORE THE ERROR
	MOVX	S1,.TOWID		;GET TERMINAL WIDTH FUNCTION
	MOVE	T1,[2,,S1]		;ARG POINTER
	TRMOP.	T1,			;GET THE NUMBER
	  MOVEI	T1,^D72			;USE A DEFAULT
	MOVEM	T1,PWIDTH		;AND SAVE IT
	$RETT				;AND RETURN
>  ;END TOPS10 CONDITIONAL

TOPS20 <
S%INIT:	$RETT				;RETURN
>  ;END TOPS20 CONDITIONAL
SUBTTL S%ERR - ERROR TYPEOUT ROUTINE
	SUBTTL	S%ERR	--	ERROR MESSAGES FROM COMND

	;CALL		$CALL	S%ERR
	;
	;RETURN	TRUE:	S1/ ADDRESS OF MESSAGE--ASCIZ
	;
	;RETURN	FALSE:	NO MESSAGE

TOPS10 <
S%ERR:	HRRZ	S1,LSTERR		;GET ADDRESS OF ERROR
	JUMPE	S1,.RETF		;NO MESSAGE RETURN FALSE
	$RETT				;RETURN TRUE
>  ;END TOPS10 CONDITIONAL

TOPS20 <
S%ERR:	HRROI	S1,SAVBUF		;POINTER TO BUFFER
	MOVE	S2,[.FHSLF,,-1]		;OUR LAST ERROR
	HRLZI	T1,-ERRBSZ*5		;MAXIMUM NUMBER OF CHARACTERS
	ERSTR%				;TYPE OUT THE ERROR STRING
	$RETF				;UNDEFINED ERROR NUMBER
	$RETF				;BAD DESTINATION DESIGNATOR
	MOVEI	S1,SAVBUF		;POINT TO THE MESSAGE
	$RETT				;RETURN TRUE
>  ;END TOPS20 CONDITIONAL
SUBTTL S%CMND  --  Scan a command


;LOCAL FLAGS (RH OF F)

CMQUES==1B18			;? TYPED
CMSWF==1B19			;BEG OF SWITCH SEEN
CMUSRF==1B20			;USER NAME REQUIRED
CMDEFF==1B21			;DEFAULT FIELD GIVEN
CMCFF==1B22			;^F RECOGNIZED FIELD
CMQUE2==1B23			;IN SECOND OR SUBSEQUENT HELP POSSIBILITY
CMBOL==1B24			;FIELD IS AT BEG OF LINE
CMTF1==1B25			;INTERNAL TEMP FLAG
CMINDF==1B26			;DOING GTJFN ON INDIRECT FILE
CMTOKF==1B27			;TOK CONFORMING TO SOME ENTRY OF FDB LIST FOUND

;FLAGS IN FUNCTION DISPATCH TABLE

CMNOD==1B0			;NO DEFAULT POSSIBLE

NOIBCH=="("			;NOISE WORD BEG CHARACTER
NOIECH==")"			;NOISE WORD END CHARACTER
CMSWCH=="/"			;SWITCH CHARACTER
CMSWTM==":"			;SWITCH TERMINATOR
CMHLPC=="?"			;HELP CHARACTER
CMCOM1=="!"			;COMMENT CHARACTER
CMCOM2==";"			;FULL LINE COMMENT CHARACTER
CMDEFC=="#"			;DEFAULT FIELD CHARACTER
CMFREC=="F"-100			;FIELD RECOGNITION CHARACTER
CMINDC=="@"			;INDIRECT FILE CHARACTER
CMRDOC=="H"-100			;REDO COMMAND CHARACTER
CMQTCH==""""			;CHARACTER FOR QUOTED STRINGS
CMCONC=="-"			;LINE CONTINUATION CHARACTER

;NOPARSE ERROR CODES
NPXNSW==1
NPXNOM==2
NPXNUL==3
NPXINW==4
NPXNC==5
NPXICN==6
NPXIDT==7
NPXNQS==10
NPXAMB==11
NPXNMT==12
NPXCMA==13
NPXNNC==14	;TOO MANY CHARACTERS IN NODE NAME
NPXNNI==15	;ILLEGAL CHARACTER IN NODE NAME
NPXNSN==16	;NO SUCH NODE
NPXIPS==17		;Invalid Path Specification
NPXIFS==20		;Invalid File Specification
NPXIUS==21		;Invalid User Specification
NPXDGS==22	;DEVICE NAME GREATER THAN 6 CHARACTERS ARE INVALID
NPXDNE==23	;DEVICE DOESN'T EXIST
NPXDIO==24	;DEVICE CAN NOT DO INPUT OR OUTPUT
NPXBDF==25	;BAD DATE/TIME FORMAT
SUBTTL	S%EXIT	--	Exit Address for Interrupt Breakout

;THE ADDRESS OF S%EXIT IS PLACED IN THE INTERRUPT PC TO FORCE RETURN
;TO THAT ADDRESS AT INTERRUPT IN COMND THAT WE WANT TO BREAKOUT OF.
;THE NECESSARY CLEANUP WILL BE DONE SO S%CMND CAN RETURN.

TOPS20 <
S%EXIT:	PJRST	CMND.3			;FIX UP RETURN
>;END TOPS20 CONDITIONAL


TOPS10 <
S%EXIT:	PJRST	XCOMXI			;SETUP PROPER RETURN
>;END TOPS10 CONDITIONAL
SUBTTL	S%SIXB	--	Convert ASCII to SIXBIT

	;
	;S1/	ASCII BYTE POINTER Returned updated
	;S2/	SIXBIT value

S%SIXB:	TLCE	S1,-1			;Left half of ptr = 0?
	TLCN	S1,-1			;... or -1 ?
	JRST	[HRLI S1,(POINT 7,)	;Yes, Make up pointer for caller
		JRST	S%SIX1]		;Re enter flow
	HRRI	S1,@S1			;Compute effective addr
	TLZ	S1,(@(17))		;Remove indirection and index
S%SIX1:	$CALL	CNVSIX		;Do the work
	$RETT				;Always return true

	SUBTTL	CNVSIX	--	CONVERT ATOM BUFFER TO SIXBIT
;Internal entry point
;Same calling args
;Returns false if more than 6 chars are passed
CNVSIX:	$CALL	.SAVET		;Preserve the caller's T's
	MOVEI	T2,6			;GET MAX NUMBER OF CHARACTERS IN NAME
	MOVE	T4,[POINT 6,S2]		; BP TO NODE STORAGE
	SETZM	S2			;START FRESH
CNVS.1:	ILDB	T3,S1			;GET NEXT CHARACTER FROM ATOM BUFFER
	CAIL	T3,"A"+40		;LESS THAN LC A
	CAILE	T3,"Z"+40		;OR GREATER THAN LC Z
	SKIPA				;YES, NOT A LC CHARACTER
	SUBI	T3,40			;NO, ITS LC, MAKE IT UC
	CAIL	T3,"0"			;IS THE CHARACTER
	CAILE	T3,"Z"			;NUMERIC OR UPPER CASE?
	$RETT				;RETURN TRUE..END OF FIELD
	CAILE	T3,"9"			;...
	CAIL	T3,"A"			;...
	CAIA				;GOOD CHARACTER, JUST SAVE IT
	$RETT				;RETURN TRUE..END OF FIELD
	SUBI	T3,"A"-'A'		;SIXBITIZE
	IDPB	T3,T4			;FILL OUT SIXBIT NODE NAME
	SOJGE	T2,CNVS.1		;HAVE WE SEEN ENOUGH CHARACTERS?
	$RETF				;ERROR..RETURN FALSE
;The S%CMND routine provides a command scanner interface similar to the
;	TOPS-20 COMND JSYS.	

;CALL IS:	S1/ Pointer to Command State Block
;		S2/ Pointer to list of Function Descriptor Blocks
;		    See CPASYM or MONSYM for a description of these

;TRUE RETURN:	ALWAYS, 
;		S1/ Length of Command Reply block
;		S2/ Address of the Command Reply block


TOPS20 <
S%CMND:	MOVEM	S1,BLKSAV		;SAVE THE COMMAND BLOCK ADDRESS
	MOVE	S1,.CMCNT(S1)		;GET SIZE OF THE BUFFER
	MOVEM	S1,BUFCNT		;SAVE BUFFER COUNT
	MOVE	S1,BLKSAV		;RESTORE S1
	PUSH	P,.CMFLG(S1)		;SAVE THE REPARSE ADDRESS
	PUSH	P,S1			;SAVE ADDRESS OF CSB
	HLLZS	.CMFLG(S1)		;AND ZERO OUT REPARSE ADDRESS
	$CALL	CMND.2		;DO THE COMMAND JSYS
	POP	P,S2			;GET CSB ADDRESS
	POP	P,S1			;GET THE REPARSE ADDRESS
	HRRM	S1,.CMFLG(S2)		;RESET THE REPARSE ADR
	TRNN	S1,-1			;IS THERE ONE?
	JRST	CMND.1			;NO, RETURN NORMALLY
	MOVX	S2,CM%RPT		;YES, GET REPARSE BIT
	TDNE	S2,CRBLK+CR.FLG		;WAS IT SET???
	HRRM	S1,0(P)			;YES, STORE REPARSE ADDRESS FOR RETURN
CMND.1:	MOVEI	S1,CR.SIZ		;LOAD SIZE OF COMMAND RESPONSE BLOCK
	MOVEI	S2,CRBLK		;LOAD ADDRESS OF COMMAND RESP. BLK.
	POPJ	P,			;AND PROPAGATE T/F RETURN FROM CMND.2


CMND.2:	$CALL	.SAVET		;SAVE T1-T4
	SETZ	T2,			;ASSUME TRUE RETURN
	SKIPN	INTRPT			;DID INTERRUPT OCCUR SKIP COMND
	COMND%				;DO THE COMMAND JSYS
	ERJMP	[SETO T2,		;SET FALSE RETURN
		 JRST CMND.3]		;AND CONTINUE ON
CMND.3:	SETZ	T3,			;SET FLAG
	EXCH	T3,INTRPT		;GET CURRENT FLAG AND RESET
	MOVE	T4,BLKSAV		;ADDRESS OF COMMAND BLOCK
	MOVE	T4,.CMCNT(T4)		;ROOM LEFT IN BUFFER
	CAMGE	T4,BUFCNT		;DID WE HAVE ANY DATA
	JRST	CMND.4			;YES..IGNORE INTERRUPT FLAG
	SKIPE	T3			;INTERRUPT BEFORE COMMAND
	TXO	S1,CM%INT		;YES..SET INTERRUPT FLAG
CMND.4:	MOVEM	S1,CRBLK+CR.FLG		;SAVE FLAGS
	MOVEM	S2,CRBLK+CR.RES		;SAVE DATA FIELD
	MOVEM	T1,CRBLK+CR.PDB		;SAVE PDB ADDRESS
;	TXNE	S1,CM%NOP		;NO PARSE?
;	SETO	T2,			;YES, RETURN FALSE
	HRRZ	S1,3			;RH (ac3) = parse block used.
	LOAD	S1,.CMFNP(S1),CM%FNC	;GET FUNCTION DONE
	MOVEM	S1,CRBLK+CR.COD		;SAVE IT
	JUMPL	T2,.RETF		;RETURN FALSE IF NECESSARY
	$RETT				;ELSE, RETURN TRUE
>  ;END TOPS20 CONDITIONAL
TOPS10 <
;!!!!!NOTE WELL - THIS CONDITIONAL RUNS TO THE END OF COMND ROUTINE

S%CMND:	MOVEM	0,CMDACS	;SAVE THE COMMAND ACS
	MOVE	0,[XWD 1,CMDACS+1] ;SET UP BLT POINTER
	BLT	0,CMDACS+17	;SAVE THE ACS
	MOVE	0,CMDACS	;RESTORE 0
	$CALL	XCOMND		;DO THE WORK
	HRRZ	T4,.CMFLG(P2)	;GET REPARSE ADDRESS IF ANY
	JUMPE	T4,COMN1	;NONE..JUST RETURN
	TXNN	F,CM%RPT	;REPARSE NEEDED..
	JRST	COMN1		;NO..JUST RESTORE AND RETURN
	HRRZ	T3,CMDACS+17	;GET STACK LOCATION
	HRRM	T4,@T3		;YES..RETURN TO REPARSE
COMN1:	SETZM	INCMND		;CLEAR IN COMMAND STATE
	MOVSI	17,CMDACS+T1	;SETUP TO RESTORE ACS
	HRRI	17,T1		;RESTORE FROM T1
	BLT	17,17		;RESTORE THE ACS
	POPJ	P,0		;NO RETURN

XCOMND:	MOVEM	S1,P2		;SAVE BLOCK PTR
	MOVEM	S2,P1		;SAVE FN BLOCK PTR
	HRL	P1,P1		;SAVE COPY OF ORIGINAL
	MOVEM	P,STKFEN	;SAVE CURRENT STACK AS FENCE
	MOVE	T1,.CMIOJ(P2)	;GET THE JFN WORD
	MOVEM	T1,JFNWRD	;SAVE THE JFN WORD
	MOVEI	T1,[.CMRTY	;LIST OF BYTE POINTERS TO CHECK
		    .CMBFP
		    .CMPTR
		    .CMABP
		    0]		;MARK OF END OF LIST
	$CALL	CHKABP	;CHECK ALL BYTE PTRS
	MOVE	P3,.CMCNT(P2)	;SETUP ACTIVE VARIABLES
	MOVE	P4,.CMPTR(P2)
	MOVE	P5,.CMINC(P2)
	HLLZ	F,.CMFLG(P2) 	;GET 'GIVEN' FLAGS
	TXZ	F,CM%PFE!CMTOKF	;WILL SOON KNOW IF PREC FLD ENDED IN ESC
				;[%43] INDIC TOKEN NOT FND YET	
	TXZE	F,CM%ESC	;PREV FLD HAD ESC? INCL SPEC CASE OF ESC AFT SELF-ENDING TOK (EG. "" STRING)
	TXO	F,CM%PFE	;YES
	$CALL	K%RCOC		;GET COC MODES
	DMOVEM	S1,CMCCM	;SAVE THEM
	TXZ	S1,3B<CMFREC*2+1> ;NO ECHO ^F 
	TXZ	S1,3B<CMRDOC*2+1> ;OR ^H
	TXO	S1,3B<.CHLFD*2+1> ;PROPER HANDLING OF NL
	TXZ	S2,3B<.CHESC*2+1-^D36> ;SET ESC TO NO ECHO
	$CALL	K%WCOC	;AND WRITE THEM BACK
	SETOM	INCMND		;MARK THAT IN COMND
	SKIPE	INTRPT		;DID WE HAVE AN INTERRUPT
	PJRST	S%EXIT		;YES..RETURN NOW
	; ..
	; ..
XCOMN0:	MOVE	P,STKFEN	;NORMALIZE STACK IN CASE ABORTED ROUTINES
	TXZ	F,CM%ESC+CM%NOP+CM%EOC+CM%RPT+CM%SWT+CMBOL+CMCFF+CMDEFF+CMINDF ;INIT FLAGS
	CAMN	P4,.CMBFP(P2)	;AT BEG OF LINE?
	TXO	F,CMBOL		;YES
XCOM1:	LOAD	T1,.CMFNP(P1),CM%FFL ;GET FUNCTION FLAGS
	STORE	T1,F,CM%FFL	;KEEP WITH OTHER FLAGS
	HLRZ	Q1,P1		;GET CM%DPP FLAG FROM FIRST BLOCK ONLY
	XOR	F,.CMFNP(Q1)
	TXZ	F,CM%DPP
	XOR	F,.CMFNP(Q1)
	TXNN	F,CM%BRK	;IS THERE A BREAK MASK SETUP
	JRST	XCOM2		;NO.. CONTINUE ON
	MOVE	T1,.CMBRK(P1)	;GET ADDRESS OF BREAK SET
	MOVEM	T1,SPCBRK	;SAVE AS SPECIAL BREAK
XCOM2:	MOVE	T1,.CMDAT(P1)	;GET FUNCTION DATA IF ANY
	MOVEM	T1,FNARG	;KEEP LOCALLY
	LOAD	T1,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
	CAIL	T1,0		;VALIDATE FN CODE
	CAIL	T1,MAXCFN
	$STOP(BFC,Bad function code)
	MOVE	T1,CFNTAB(T1)	;GET TABLE ENTRY FOR IT
	JXN	T1,CMNOD,XCOM4	;DISPATCH NOW IF NO DEFAULT POSSIBLE
	$CALL	INILCH	;SKIP SPACES AND INIT ATOM BUFFER
	$CALL	CMCIN		;GET INITIAL INPUT
	CAIN	T1,CMCONC	;POSSIBLE LINE CONTINUATION?
	JRST	[$CALL	CMCIN		;YES, SEE IF NL FOLLOWS
		CAIE	T1,.CHLFD
		$CALL	CMRSET	;NO, RESET FIELD
		$CALL	CMCIN		;RE-READ FIRST CHAR
		JRST	.+1]		;CONTINUE
	CAIN	T1,CMCOM2	;COMMENT?
	JRST	CMCMT2		;YES
	CAIN	T1,CMCOM1
	JRST	CMCMT1		;YES
	CAIN	T1,.CHLFD	;EOL BEGINS FIELD?
	JRST	[$CALL	CMDIP		;YES, PUT IT BACK
	        LOAD	T1,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
		CAIN	T1,.CMCFM	;CONFIRM?
		JRST	XCOM4		;YES, DO IT
		TXNE	F,CM%DPP	;HAVE DEFAULT?
		JRST	XCOM6		;YES, USE IT
		TXNN	F,CMBOL		;AT BGN OF BFR?
		JRST	XCOM4		;NO, TRY NULL FIELD
		$CALL	CMRSET
		SETZ	P5,0		;YES, EMPTY LINE.  IGNORE
		$CALL	TYPRMT		;REDO PROMPT
		JRST	XCOMN0]		;TRY AGAIN
	CAIE	T1,.CHESC	;ESC AT BEG OF FIELD?
	CAIN	T1,CMFREC
	JRST	XCOM5		;^F AT BEG OF FIELD
   ;	CAIN	T1,CMDEFC	;OR DEFAULT REQUEST?
   ;	JRST	XCOM5		;YES
XCOM3:	$CALL	CMDIP		;PUT CHAR BACK
XCOM4:	LOAD	T1,.CMFNP(P1),CM%FNC	;GET FUNCTION CODE
	JRST	@CFNTAB(T1)	;DO IT

;ESC OR ^F AT BEG OF FIELD

XCOM5:	TXNN	F,CM%DPP	;YES, HAVE DEFAULT STRING?
	JRST	XCOM3		;NO
	$CALL	CMDCH		;FLUSH RECOG CHAR
XCOM6:	HLRZ	Q1,P1		;GET PTR TO FIRST FLD BLOCK
	MOVE	S1,.CMDEF(Q1)	;GET DEFAULT STRING PTR
	$CALL	CHKBP		;CHECK POINTER
	MOVEM	S1,Q1
	TXO	F,CMDEFF	;NOTE FIELD ALREADY IN ATOM BFR
XCOM7:	ILDB	T1,Q1
	JUMPE	T1,[PUSHJ P,CHKLCH	;CHECK FOR NULL DEFAULT STRING
		CAIG	T1,0
		$STOP(BDS,Bad Default String) ;NULL STRING ILLEGAL
		$CALL	TIELCH	;END OF STRING, TIE OFF ATOM BUFFER
		TXNE	F,CMCFF		;^F RECOG?
		JRST	XCOMRF		;YES, GO GET MORE INPUT
		JXE	F,CM%ESC,XCOM4	;GO DIRECT TO FUNCTION IF NO RECOG
		MOVEI	T1,.CHESC
		$CALL	CMDIBQ	;YES, APPEND ESC TO BUFFER
		$CALL	CMRSET	;RESET LINE VARIABLES
		JRST	XCOMN0]		;TREAT AS ORDINARY INPUT
	$CALL	STOLCH	;STOR CHAR IN ATOM BUFFER
	TXNE	F,CM%ESC	;RECOGNIZING?
	$CALL	CMDIB		;YES, CHAR TO MAIN BUFFER ALSO
	JRST	XCOM7
;COMMENT

CMCMT2:	SETO	T1,		;SAY NO TERMINATOR OTHER THAN EOL
CMCMT1:	MOVEM	T1,Q2		;REMEMBER MATCHING TERMINATOR
CMCOM:	$CALL	CMCIN		;GET NEXT CHAR
	CAIN	T1,CMCONC	;POSSIBLE LINE CONTINUATION?
	JRST	[$CALL	CMCIN		;YES, CHECK FOR NL FOLLOWING
		CAIN	T1,.CHLFD
		JRST	CMCOM		;YES, STAY IN COMMENT
		JRST	.+1]		;NO, EXAMINE CHARACTER
	JXN	F,CM%ESC,CMAMB	;AMBIGUOUS
	CAIN	T1,.CHLFD	;END OF LINE?
	JRST	[$CALL	CMDIP		;YES, PUT IT BACK
		JRST	XCOM1]		;DO WHATEVER
	CAMN	T1,Q2		;MATCHING TERMINATOR?
	JRST	XCOM1		;YES, END OF COMMENT
	JRST	CMCOM		;NO, KEEP LOOKING

;TABLE OF COMND FUNCTIONS

CFNTAB:	PHASE 0
.CMKEY::!XCMKEY			;KEYWORD
.CMNUM::!XCMNUM			;INTEGER
.CMNOI::!XCMNOI+CMNOD		;NOISE WORD
.CMSWI::!XCMSWI			;SWITCH
.CMIFI::!XCMIFI			;INPUT FILE
.CMOFI::!XCMOFI			;OUTPUT FILE
.CMFIL::!XCMFIL			;GENERAL FILESPEC
.CMFLD::!XCMFLD			;ARBITRARY FIELD
.CMCFM::!XCMCFM			;CONFIRM
.CMDIR::!XCMDIR			;DIRECTORY NAME
.CMUSR::!XCMUSR			;USER NAME
.CMCMA::!XCMCMA			;COMMA
.CMINI::!XCMINI+CMNOD		;INITIALIZE COMMAND
.CMFLT::!XCMFLT			;FLOATING POINT NUMBER
.CMDEV::!XCMDEV			;DEVICE NAME
.CMTXT::!XCMTXT			;TEXT
.CMTAD::!XCMTAD			;TIME AND DATE
.CMQST::!XCMQST			;QUOTED STRING
.CMUQS::!XCMUQS+CMNOD		;UNQUOTED STRING
.CMTOK::!XCMTOK			;TOKEN
.CMNUX::!XCMNUX			;NUMBER DELIMITED BY NON-DIGIT
.CMACT::!XCMACT			;ACCOUNT
.CMNOD::!XCMNOD		;NODE NAME
	DEPHASE
MAXCFN==.-CFNTAB

;HERE TO GET MORE INPUT AND RETRY FIELD

XCOMRF:	$CALL	CMRSET	;RESET VARIABLES TO BEGINNING OF FIELD
	$CALL	CMCIN1	;GET MORE INPUT
	HLR	P1,P1		;RESET ALTERNATIVE LIST
	JRST	XCOMN0

;RESET VARIABLES TO BEGINNING OF CURRENT FIELD

CMRSET:	SUB	P5,P3		;RESET VARIABLES TO BGN OF FIELD
	ADD	P5,.CMCNT(P2)	;KEEP ALL CURRENT INPUT
	MOVE	P3,.CMCNT(P2)
	MOVE	P4,.CMPTR(P2)
	POPJ	P,0
;STANDARD EXITS

;RETURN AND REPEAT PARSE BECAUSE USER DELETED BACK INTO ALREADY
;PARSED TEXT

XCOMRP:	TXNE	F,CM%INT	;INTERRUPT EXIT
	JRST	XCOMXI		;SETUP RETURN
	TXO	F,CM%RPT	;REQUEST REPEAT
	MOVE	T1,P4		;COMPUTE NUMBER CHARS IN BUFFER
	MOVE	T2,.CMBFP(P2)
	MOVEM	T2,P4		;RESET PTR TO TOP OF BUFFER
	$CALL	SUBBP		;COMPUTE PTR-TOP
	MOVEM	T1,P5		;SET AS NUMBER CHARS FOLLOWING PTR
	ADDM	T1,P3		;RESET COUNT TO TOP OF BUFFER
	JRST	XCOMX1		;OTHERWISE UPDATE VARIABLES AND EXIT

;GOOD RETURN

XCOMXR:	TXNE	F,CM%ESC	;RECOG CHARACTER TERMINATED?
	$CALL	CMDCH		;YES, FLUSH IT
XCOMXI:
	TXZ	F,CM%RPT	;CLEAR THE REPARSE FLAG
	JUMPG	P5,[		;[%42] SOMETHING THERE ALREADY IF JUMP
		MOVE T2,P4	;[%42] GET PTR TO IT
		ILDB T1,T2	;[%42] SEE WHAT IT IS
		CAIN T1,.CHESC	;[%42] IS IT ESCAPE?
		JRST XCXESC	;[%42] YES
		JRST .+1]	;[%42] NO
	TXZN	F,CM%ESC	;FIELD TERMINATED WITH RECOG?
	JRST	XCOMX1		;NO
	TXNE	F,CMCFF		;^F RECOG?
	JRST	XCOMRF		;YES, GET MORE INPUT BEFORE RETURNING
XCXESC:	TXO	F,CM%ESC	;SET FLAG
	MOVEI	T1," "		;TERMINATE TYPESCRIPT WITH SPACE
	$CALL	CMDIB
XCOMX1:	SETZ	S1,		;CLEAR S1
	EXCH	S1,INTRPT	;GET THE CURRENT FLAG AND RESET
	SKIPE	S1		;DID WE HAVE AN INTERRUPT
	TXO	F,CM%INT	;YES..SET RETURN FLAG
	CAMGE	P3,.CMCNT(P2)	;DID WE HAVE ANY PROCESSING
	TXZ	F,CM%INT	;YES..CLEAR POSSIBLE INTERRUPT FLAG
	MOVEM	P3,.CMCNT(P2)	;UPDATE VARIABLES
	MOVEM	P4,.CMPTR(P2)
	MOVEM	P5,.CMINC(P2)
XCOMX2:	MOVE	P,STKFEN	;RESET STACK
	DMOVE	S1,CMCCM	;GET SAVED CC MODES
	$CALL	K%WCOC	;RESTORE THEM
	MOVEM	P1,CRBLK+CR.PDB	;RETURN PTR TO FUNCTION BLOCK USED
	TXZ	F,CM%FFL	;FLUSH FUNCTION FLAGS
	HLLM	 F,.CMFLG(P2)	;RETURN FLAGS
	MOVEM	P2,CRBLK+CR.FLG	;STORE BLK ADDRESS
	HLLM	F,CRBLK+CR.FLG	;AND THE FLAGS
	HRRZ	T1,CRBLK+CR.PDB		;GET THE CURRENT PDB
	LOAD	S1,.CMFNP(T1),CM%FNC	;GET FUNCTION CODE
	MOVEM	S1,CRBLK+CR.COD		;SAVE THE CODE
	MOVEI	S1,CR.SIZ	;LOAD SIZE OF RETURNED BLOCK
	MOVEI	S2,CRBLK	;AND ITS LOCATION
	$RETT			;AND TAKE A GOOD RETURN
;FAILURE RETURNS - FAILED TO PARSE

XCOMNE:	MOVEM	T1,LSTERR	;SAVE ERROR CODE
XCOMNP:	JXN	F,CMQUES,CMRTYP	;IF IN HELP, DON'T RETURN NOW
	$CALL	CMRSET	;RESET FIELD VARIABLES
	MOVEM	P5,.CMINC(P2)	;FIX USER BLOCK
	LOAD	T1,.CMFNP(P1),CM%LST	;GET PTR TO NEXT FN BLOCK
	HRRM	T1,P1		;SAVE IT
	JUMPN	T1,XCOMN0	;DISPATCH IF THERE IS ANOTHER FUNCTION
	TXO	F,CM%NOP	;NO OTHER POSSIBILITIES, PRESUME NO PARSE
	TXNN	F,CMTOKF	;[%43] TOKEN FND? IF SO DEFAULT STR IRRELEV
	TXNN	F,CM%DPP	;DEFAULT STRING?
	JRST	XCOMX2		;NO DEFAULT STRING OR TOKEN FOUND
XCOMDF:	MOVE	P,STKFEN	;RESTORE TOP-LEVEL CONTEXT
	TXZ	F,CM%ESC+CM%NOP+CM%EOC+CM%RPT+CM%SWT+CMBOL+CMCFF+CMDEFF+CMINDF
				;INIT FLAGS
	HLRS	P1		;RESUME WITH 1ST FUNCT CODE
	JRST	XCOM6		;...AFTER COPYING DEFAU STR TO BUF

;HERE AFTER EACH HELP OUTPUT

CMRTYP:	$CALL	CMRSET	;RESET FIELD VARIABLES
	LOAD	T1,.CMFNP(P1),CM%LST ;GET NEXT FUNCTION IN LIST
	HRRM	T1,P1
	TXO	F,CMQUES+CMQUE2	;NOTE IN SECOND HELP POSSIBILITY
	JUMPN	T1,XCOMN0	;DO SUBSEQUENT HELPS
;[32]	MOVEI	S1,.CHLFD	;START NEW LINE
;[32]	$CALL	CMDOUT
	HLR	P1,P1		;END OF LIST, REINIT IT
	SOS P5			;FLUSH QMARK FROM INPUT
	TXZ	F,CMQUES+CMQUE2	;NOTE NOT IN HELP
	$CALL	RETYPE	;RETYPE LINE
	JRST	XCOMN0		;RESTART PARSE OF CURRENT FIELD

XCOMEO:	TXO	F,CM%NOP	;SET NO PARSE
	MOVEI	S2,CRBLK
	MOVE	P,STKFEN	;FIXUP STACK
	$RETF
SUBTTL	RETYPE  --  Retype current line including the prompt

RETYPE:
	$CALL	CRLF			;TYPE CRLF TO GET TO LEFT MARGIN
	$CALL	TYPRMT			;RETYPE THE PROMPT
	$CALL	TYLINE			;RETYPE THE LINE THUS FAR
	$RETT				;AND RETURN


SUBTTL	TYPRMT  --  Retype the prompt if there is one

TYPRMT:
	SKIPE	Q1,.CMRTY(P2)		;GET ^R PTR IF ANY
TYPR.1:	CAMN	Q1,.CMBFP(P2)		;UP TO TOP OF BFR?
	$RETT				;DONE WITH PROMPT, RETURN
	ILDB	S1,Q1			;TYPE ^R BFR
	JUMPE	S1,.RETT		;RETURN IF END OF STRING
	$CALL	CMDOUT		;ELSE, OUTPUT THE CHARACTER
	JRST	TYPR.1			;AND LOOP


SUBTTL	TYLINE  --  Retype the line until current position

TYLINE:	MOVE	Q1,.CMBFP(P2)		;GET MAIN BFR PTR
TYLI.1:	CAMN	Q1,P4			;UP TO CURRENT PTR?
	JRST	TYLI.2			;YES, GO DO ADVANCE INPUT
	ILDB	S1,Q1			;TYPE OUT COMMAND BFR
	$CALL	CMDOUT
	JRST	TYLI.1

TYLI.2:	MOVE	Q2,P5			;GET INPUT COUNT
TYLI.3:	SOJL	Q2,[SETZ T1,0		;ALL INPUT PRINTED, TIE OFF
		    IDPB T1,Q1		;BUFFER
		    POPJ P,0]
	ILDB	S1,Q1
	$CALL	CMDOUT
	JRST	TYLI.3
;****************************************
;COMND - LOCAL SUBROUTINES
;****************************************

;READ NEXT FIELD ATOM
;ASSUMES ATOM BUFFER ALREADY SETUP

CMRATM:	MOVEI	T1,FLDBRK	;USE STANDARD FIELD BREAK SET
	TXNE	F,CM%BRK	;WAS THERE A BREAK SET PROVIDED?
	MOVE	T1,SPCBRK	;YES.. USE SPECIAL BREAK SET
	PJRST	CMRFLD		;PARSE THE FIELD

FLDBRK:	777777,,777760		;ALL CONTROL CHARS
	777754,,001760		;ALL EXCEPT - , NUMBERS
	400000,,000760		;ALL EXCEPT UC ALPHABETICS
	400000,,000760		;ALL EXCEPT LC ALPHABETICS

;READ FILESPEC FIELD - FILESPEC PUNCTUATION CHARACTERS
;ARE LEGAL (: . < > ) WITH EXCEPTION OF "," WHICH IS HANDLED
;WITH [P,PN] AS SPECIAL CASE
;ACCEPT FILESPECS IN THE FORM OF "DEV:FILNAM.EXT[P,PN,PATH,...]

CMRFIL:	MOVEI	T1,FILBRK
	$CALL	CMRFLD	;GET DEV:NAME.EXT
	MOVE	T1,P4		;GET POINTER TO LAST BYTE PARSED
	ILDB	T1,T1		;GET TERMINATOR
	CAIN	T1,"["		;PPN ?
	$CALL	CMRPTH	;YES -- GET DIRECTORY
	POPJ	P,0

FILBRK:	777777,,777760		;BREAK ON ALL CC
	777764,,000760		;ALLOW . 0-9 :
	400000,,000760		;ALLOW UC
	400000,,000760		;ALLOW LC

;USERNAME BREAK SET. BREAKS ON EVERYTHING EXCEPT DOT AND ALPHABETICS.

USRBRK:	777777,,777760		;BREAK ON ALL CONTROLS
	777744,,001760		;ALLOW - . 0-9
	400000,,000760		;ALLOW UC
	400000,,000760		;ALLOW LC

;READ TO END OF LINE

EOLBRK:	1B<.CHLFD>		;END OF LINE ONLY
	EXP	0,0,0		;THREE WORDS OF 0'S
;CMRPTH	Routine to Read TOPS-10 Path Specification from buffer

CMRPTH:	MOVEI	T1,PTHBRK	;POINT TO PATH BREAK SET
	$CALL	CMRFLD	;GET PATH (UP TO "]")
	TXNE	F,CMQUES	;RETURN IF HELP REQUESTED
	 POPJ	P,0
	MOVE	T1,P4		;GET POINTER TO LAST CHARACTER
	ILDB	T1,T1		;GET TERMINATOR
	CAIN	T1,"]"		;END OF PATH?
	JRST	CMRP.1		;YES -- STORE TERMINATOR AND RETURN
	JXN	F,CM%ESC,CMAMB		;DING IF ESCAPE TYPED
	POPJ	P,0		;ELSE RETURN

CMRP.1:	$CALL	CMCIN		;GET TERMINATOR
	$CALL	STOLCH	;STORE IN ATOM
	POPJ	P,0

PTHBRK:	777777,,777760		;BREAK ON ALL CONTROL CHARACTERS
	777734,,001760		;ALLOW , 0-9
	400000,,000360		;BREAK ON "]" ALLOW UC AND "["
	400000,,000760		;ALLOW LC
;GENERAL FIELD PARSE ROUTINE - TAKES BREAK SET MASK
; T1/ ADDRESS OF 4-WORD BREAK SET MASK
;	$CALL	CMRFLD
; RETURNS +1, FIELD COPIED TO ATOM BUFFER, TERMINATOR BACKED UP

CMRFLD:	MOVEM	T1,CMRBRK	;SAVE BREAK TABLE ADDRESS
	TXNE	F,CMDEFF	;DEFAULT GIVEN?
	JRST	CMRATT		;YES, ALREADY IN BUFFER
CMRAT1:	$CALL	CMCIN		;GET A CHAR
	CAIE	T1,CMFREC	;^F RECOGNITION?
	CAIN	T1,.CHESC	;ESC?
	JRST	[$CALL	CHKLCH	;YES, RETURN IF ANYTHING NOW
		JUMPG	T1,CMRATT	;IN ATOM BFR
		JRST	CMAMB]		;AMBIGUOUS
	CAIE	T1," "		;SPACE OR TAB?
	CAIN	T1,.CHTAB
	JRST	[$CALL	CHKLCH	;YES, RETURN IF ANYTHING
		JUMPG	T1,CMRATT	;IN ATOM BFR
		JRST	CMRAT1]		;OTHERWISE IGNORE
	CAIN	T1,.CHLFD	;OR EOL?
	JRST	CMRATR		;YES
	CAIN	T1,CMHLPC	;HELP REQUEST?
	JRST	[TXO	F,CMQUES	;YES, FLAG
		JRST	CMRATT]
	move	T2,t1		;get copy of char
	IDIVI	T2,40		;COMPUTE INDEX TO BIT MASK
	MOVE	T3,BITS(t3)
	ADD	T2,CMRBRK
	TDNE	T3,0(t2)	;BREAK CHARACTER?
	JRST	CMRATR		;YES
	$CALL	STOLCH		;BUILD KEYWORD STRING
	TXO	F,CMTOKF	;[%43] INDIC VALID TOKEN FND
	JRST	CMRAT1

CMRATR:	$CALL	CMDIP		;PUT CHARACTER BACK IN BUFFER
CMRATT:	PJRST	TIELCH		;TIE OFF ATOM BUFFER AND RETURN
;ATOM READ FOR SPECIAL FIELDS - DOES NOT ALLOW RECOGNITION
;READ FIELD TO CR

CMRSTR:	TXZA	F,CMTF1		;FLAG NO TERMINATE ON SPACE
	; ..			;CONTINUE IN CMRSPC

;READ FIELD TO SPACE OR CR

CMRSPC:	TXO	F,CMTF1		;FLAG TERMINATE ON SPACE
	TXNE	F,CMDEFF	;HAVE FIELD ALREADY?
	POPJ	P,0		;YES
CMRSP1:	$CALL	CMCIN		;GET CHAR
	CAIN	T1,CMHLPC	;HELP?
	JRST	[TXO	F,CMQUES	;YES
		POPJ	P,0]
	JXN	F,CM%ESC,CMAMB	;AMBIGUOUS
	CAIE	T1,.CHTAB
	CAIN	T1," "		;END OF FIELD?
	JRST	[JXE	F,CMTF1,.+1	;CONTINUE IF NOT TERMINATING ON BLANK
		$CALL	CHKLCH	;SEE IF ANY NON-BLANK SEEN
		JUMPE	T1,CMRSP1	;JUMP IF LEADING BLANK
		JRST	CMRATT]		;TERMINATING BLANK
	CAIN	T1,.CHLFD	;END OF LINE?
	JRST	CMRATR		;YES
	$CALL	STOLCH	;NO, CHAR TO ATOM BUFFER
	JRST	CMRSP1		;CONTINUE
;READ QUOTED STRING INTO ATOM BUFFER
;STRING DELIMITED BY ", "" MEANS LITERAL "

CMRQST:	TXNE	F,CMDEFF	;HAVE DEFAULT?
	RETSKP			;YES
	$CALL	CMCIN		;GET FIRST CHAR
	CAIN	T1,CMHLPC	;FIRST CHAR IS HELP?
	JRST	[TXO	F,CMQUES	;YES
		RETSKP]
	CAIE	T1,CMQTCH	;START OF STRING?
	POPJ	P,0		;NO, FAIL
CMRQS1:	$CALL	CMCIN		;READ NEXT CHAR
	TXZ	F,CM%ESC!CMCFF	;NOT CTL CHAR WHEN PART OF QUOTED STRING
	CAIN	T1,.CHLFD	;LINE ENDED UNEXPECTEDLY?
	JRST	[PJRST	CMDIP]	;YES, PUT LF BACK AND RETURN FAIL
	CAIE	T1,CMQTCH	;ANOTHER QUOTE?
	JRST	CMRQS2		;NO, GO STORE CHARACTER
	$CALL	CMCIN		;YES, PEEK AT ONE AFTER
	CAIN	T1,CMQTCH	;PAIR OF QUOTES?
	JRST	CMRQS2		;YES, STORE ONE
	$CALL	CMDIP		;NO, PUT BACK NEXT CHAR
	$CALL	TIELCH	;TIE OFF ATOM BUFFER
	RETSKP			;GOOD

CMRQS2:	$CALL	STOLCH	;STOR CHAR IN ATOM BUFFER
	JRST	CMRQS1		;KEEP LOOKING
SUBTTL	Atom Buffer Routines / INILCH - Init Atom Buffer

INILCH:	MOVE	T1,.CMABP(P2)	;GET PTR
	MOVEM	T1,ATBPTR
	MOVE	T1,.CMABC(P2)	;GET SIZE
	MOVEM	T1,ATBSIZ
	PJRST	CMSKSP		;FLUSH INITIAL SPACES


SUBTTL	Atom Buffer Routines / STOLCH - Store Character in Atom Buffer

STOLCH:	SOSGE	ATBSIZ		;ROOM?
	$STOP(ABS,Atom buffer too small) ;NO
	IDPB	T1,ATBPTR
	POPJ	P,0


SUBTTL	Atom Buffer Routines / CHKLCH - Return Number of Characters

CHKLCH:	MOVE	T1,.CMABC(P2)	;GET ORIG COUNT
	SUB	T1,ATBSIZ	;COMPUTE DIFFERENCE
	POPJ	P,0


SUBTTL	Atom Buffer Routines / TIELCH - Terminate Atom Buffer With NULL

TIELCH:	SKIPG	ATBSIZ		;ROOM FOR NULL?
	$STOP(ABS,Atom buffer too small) ;NO
	SETZ	T1,0
	MOVE	T3,ATBPTR	;GET POINTER
	IDPB	T1,T3		;DEPOSIT WITHOUT CHANGING PTR
	POPJ	P,0
SUBTTL	CMCIN  --  Read One Character for Processing

;APPEND TEXT TO BUFFER IF NECESSARY WITH INTERNAL TEXTI
;	$CALL	CMCIN
; RETURNS +1 ALWAYS, T1/ CHARACTER

CMCIN:	SOJL	P5,[SETZ P5,0		;MAKE INPUT EXACTLY EMPTY
		$CALL	CMCIN1	;NONE LEFT, GO GET MORE
		JRST	CMCIN]
	ILDB	T1,P4			;GET NEXT ONE
	SOS	P3			;UPDATE FREE COUNT
	CAIN	T1,.CHCRT		;IS IT A CARRIAGE RETURN?
	JRST	CMCIN			;YES, IGNORE IT
	CAIN	T1,CMFREC		;^F?
	JRST	[TXO F,CM%ESC+CMCFF	;YES
		 POPJ	P,0]
	CAIN	T1,.CHESC		;ESC?
	JRST	[TXO F,CM%ESC		;YES
		 POPJ	P,0]
	CAIN	T1,.CHLFD		;END OF LINE?
	TXO	F,CM%EOC		;YES, MEANS END OF COMMAND
	POPJ	P,0
CMCIN1:	MOVEM	F,CMCSF		;SAVE F
	SETZM CMCBLF		;INIT ACCUMULATED FLAGS
	MOVE	T1,[XWD P1,CMCSAC] ;PREPARE FOR BLT
	BLT	T1,CMCSAC+3	;SAVE P1-P4
	;***	REMOVE RD%RND FOR NOW 6/22/78
	MOVX	T1,RD%BRK+RD%PUN+RD%BEL+RD%JFN+RD%BBG ;SETUP FLAGS
;	REMOVE CM%NJF 9/20/79 MLB SYMBOL USED FOR CM%BRK
;	TXNE	F,CM%NJF	;WERE JFN'S PASSED?
;	TXZ	T1,RD%JFN	;NO, PASS THAT FACT
	TXNE	F,CM%RAI	;RAISE INPUT REQUESTED?
	TXO	T1,RD%RAI	;YES, PASS IT
	MOVEM	T1,TI+.RDFLG	;STORE FLAGS FOR TEXTI
	MOVX	T1,.RDBKL	;GET NUMBER OF WORDS TO PASS
	MOVEM	T1,TI+.RDCWB	;AND STORE IT
	MOVE	T1,.CMRTY(P2)	;SETUP ^R BUFFER
	MOVEM	T1,TI+.RDRTY	;FOR TXTI
	MOVE	T1,.CMBFP(P2)	;SETUP TOP OF BUFFER
	MOVEM	T1,TI+.RDBFP	;
	SETZM	TI+.RDBRK	;NO SPECIAL BREAK MASK
	MOVEM	P4,TI+.RDBKL	;STORE CURRENT PTR FOR BACK UP LIMIT
	MOVEM	P3,CMCSC	;SAVE CURRENT COUNT
	SUB	P3,P5		;ADJUST COUNT FOR ADVANCE INPUT
	MOVEM	P3,TI+.RDDBC	;AND STORE FOR THE TEXT INPUT
	SKIPE	P5		;PUSH POINTER PAST CURRENT INPUT
	IBP	P4		;
	SOJG	P5,.-1		;
	MOVEM	P4,TI+.RDDBP	;STORE FOR INPUT
CMCIN2:	MOVE	S1,.CMIOJ(P2)	;GET THE JFNS
	MOVEM	S1,TI+.RDIOJ	;STORE FOR TEXTI
	SKIPG	P3		;ROOM IN BUFFER FOR MORE INPUT?
	$STOP(TMT,Too much text) 	;NO
CMCN2B:	MOVEI	S1,TI		;GET LOCATION OF TEXTI BLOCK
	$CALL	K%TXTI	;DO INTERNAL TEXTI
	JUMPF	[MOVEI	S1,EREOF$
		JRST	XCOMEO]
	IOR	F,TI+.RDFLG	;GET FLAGS
	IORB	F,CMCBLF	;ACCUMULATE FLAGS (RD%BLR)
	LDB	T1,TI+.RDDBP		;GET LAST CHAR
	MOVE	P4,TI+.RDDBP	;REMEMBER POINTER
	MOVE	P3,TI+.RDDBC	;AND COUNT
	TXNE	F,RD%BFE	;BUFFER EMPTY?
	JRST	CMCIN3		;YES, RETURN
	JUMPE	T1,CMCIN3	;JUMP IF NULL
	CAIE	T1,.CHLFD	;AN ACTION CHAR?
	CAIN	T1,.CHESC
	JRST	CMCIN3		;YES
	CAIE	T1,CMHLPC
	CAIN	T1,CMFREC	;^F?
	JRST	CMCIN3		;YES
	JRST	CMCIN2		;NO, GET MORE INPUT

CMCIN3:	TXNE	F,RD%BLR	;BACKUP LIMIT REACHED?
	JRST	CMCIN4		;YES, CLEANUP AND REPARSE
	TXNE	F,RD%BFE	;BUFFER EMPTY
	SKIPN	INTRPT		;INTERRUPT OCCUR
	SKIPA			;NO..CHECK REST
	JRST	CMCIN4		;YES..SETUP TO RETURN
	MOVE	P5,CMCSC	;RECOVER PREVIOUS COUNT
	SUB	P5,P3		;COMPUTE CHARACTERS JUST APPENDED
	MOVSI	T1,CMCSAC	;RESTORE ACS P1-P4, F
	HRRI	T1,P1
	BLT	T1,P4
	MOVE	F,CMCSF
	POPJ	P,0

;HERE ON RETURN FROM TEXTI WHICH REACHED BACKUP LIMIT OR WHICH RETURNED
;BECAUSE BUFFER EMPTY.  MUST REPARSE LINE.  RESTORE ACS, BUT LEAVE
;MAIN POINTER AS RETURNED BY TEXTI.

CMCIN4:	DMOVE	P1,CMCSAC	;RESTORE P1&P2
	MOVE	F,CMCSF		;RESTORE F
	SKIPE	INTRPT		;WAS THERE AN INTERRUPT CALL?
	TXO	F,CM%INT	;YES, LIGHT THE FLAG
	SETZM	INTRPT		;CLEAR CALL FLAG
	JRST	XCOMRP		;RETURN REPEAT PARSE
;SKIP LEADING TABS OR SPACES

CMSKSP:	$CALL	CMCIN		;GET A CHAR
	CAIE	T1," "		;SPACE OR TAB?
	CAIN	T1,.CHTAB
	JRST	CMSKSP		;YES, KEEP LOOKING
	PJRST	CMDIP		;NO, PUT IT BACK

;LOCAL ROUTINE - SUBTRACT ASCII BYTE PTRS
;	T1, T2/ ASCII BYTE PTRS
;	$CALL	SUBBP
; RETURNS +1 ALWAYS,
; T1/ T1-T2

SUBBP:	HRRZ	T3,T1		;COMPUTE 5*(A1-A2)+(P2-P1)/7
	SUBI	T3,0(T2)
	IMULI	T3,5		;COMPUTE NUMBER CHARS IN THOSE WORDS
	LDB	T1,[POINT 6,T1,5]
	LDB	T2,[POINT 6,T2,5]
	SUBM	T2,T1
	IDIVI	T1,7
	ADD	T1,T3
	POPJ	P,0

;LOCAL ROUTINE - DELETE LAST CHAR INPUT

CMDCH:	MOVE	S1,P4
	$CALL	DBP		;DECREMENT BYTE PTR
	MOVEM	S1,P4
	AOS	P3		;ADJUST SPACE COUNT
	SETZ	P5,0		;CAN'T BE ANY WAITING INPUT
	POPJ	P,0

;LOCAL ROUTINE - DECREMENT INPUT POINTER

CMDIP:	LDB	T1,P4		;CHECK THE CHARACTER
	CAIE	T1,CMFREC	;A RECOG REQUEST CHAR?
	CAIN	T1,.CHESC
	TXZ	F,CM%ESC+CMCFF	;YES, RESET FLAGS
	MOVE	S1,P4		;GET POINTER
	$CALL	DBP		;DECREMENT IT
	MOVEM	S1,P4		;PUT IT BACK
	AOS	P5		;ADJUST COUNTS
	AOS	P3
	POPJ	P,0

;LOCAL ROUTINE - DEPOSIT INTO INPUT BUFFER

CMDIB:	MOVE	S1,T1		;COPY THE CHARACTER
	$CALL	CMDOUT	;TYPE IT
CMDIBQ:	SETZ	P5,0		;CLEAR ADVANCE COUNT
	SOSGE	P3		;ROOM?
	$STOP(ABS,Atom buffer too small) ;NO
	IDPB	T1,P4		;APPEND BYTE TO USER'S BUFFER
	POPJ	P,0


;LOCAL ROUTINE - DECREMENT BYTE POINTER
	;CALL	S1/	BYTE POINTER

DBP:	SOS	S1		;BACK OFF ONE WORD
	IBP	S1		;AND THEN GO FORWARD 4 TIMES
	IBP	S1
	IBP	S1
	IBP	S1
	$RETT			;THEN RETURN
SUBTTL	HELPER  --  Do caller supplied and default HELP text

;HELPER types out the caller supplied help text, if any, and then it types
;	the default help type unless it was suppressed.   Return is via CMRTYP
;	to retype the current line.
;
;Call:	S1/  address of default HELP text
;
;T Ret:	always

HELPER:	PUSH	P,S1			;SAVE S1
	$CALL	DOHLP			;DO CALLER SUPPLIED HELP IF ANY
	TXNE	F,CM%SDH		;ARE WE SUPPRESSING DEFAULT HELP?
	JRST	HELP.1			;YES, SKIP PRINTING IT
	MOVEI	S1," "			;LOAD A BLANK
	$CALL	CMDOUT		;PRINT IT
	MOVE	S1,0(P)			;GET THE MESSAGE
	$CALL	CMDSTO		;PRINT IT

HELP.1:	POP	P,S1			;GET THE STACK BACK
	PJRST	CMRTYP			;RETYPE THE LINE


SUBTTL	DOHLP  --  Do caller supplied HELP text

DOHLP:	MOVEI	S1,[ASCIZ /
  or/]
	TXNE	F,CMQUE2		;IN ALTERNATE HELP POSSIBILITIES?
	$CALL	CMDSTO
	TXNN	F,CM%HPP		;HAVE HELP POINTER?
	POPJ	P,0			;NO
	MOVEI	S1," "
	$CALL	CMDOUT		;SPACE BEFORE USER TEXT
	MOVE	S1,.CMHLP(P1)		;YES, GET IT
	PJRST	K%SOUT			;AND TYPE IT


SUBTTL	CMAMB  --  Handle Ambiguous Typein

CMAMB:	TXZN	F,CM%ESC		;ESC SEEN?
	NOPARS (NPXAMB,Ambiguous)
	$CALL	CMDCH			;FLUSH RECOG CHAR FROM BUFFER
	MOVEI	S1,.CHBEL		;INDICATE AMBIGUOUS
	$CALL	CMDOUT
	JRST	XCOMRF			;GET MORE INPUT AND RESTART
;OUTPUT STRING FROM CURRENT CONTEXT

XMCOUT:	$CALL	CMDOUT		;OUTPUT A CHARACTER
	CAIE	S1,^D9
	JRST	XMCS.2
XMCS.1:	MOVE	S1,CURPOS
	ADDI	S1,8
	IDIVI	S1,8
	IMULI	S1,8
	MOVEM	S1,CURPOS
	SKIPA
XMCS.2:	AOS	CURPOS		;MAINTAIN POSITION
	POPJ	P,0

CRLF:	SETZM	CURPOS			;AT LEFT MARGIN
	MOVEI	S1,[BYTE (7) .CHCRT,.CHLFD,0]
	PJRST	K%SOUT			;AND TYPE IT
;CHECK ALL BYTE PTRS
; T1/ PTR TO LIST OF ADDRESSES, TERMINATED BY 0

CHKABP:	$SAVE	Q1		;SAVE ACS
	$SAVE	Q2		;THAT WE USE
	MOVEM	T1,Q1		;SAVE LIST PTR
CHKAB1:	MOVE	Q2,0(Q1)	;GET NEXT ADDRESS
	JUMPE	Q2,.RETT		;DONE ON 0
	ADDI	Q2,0(P2)	;MAKE PTR TO BLOCK
	MOVE	S1,0(Q2)	;GET BYTE PTR
	$CALL	CHKBP		;CHECK AND NORMALIZE
	MOVEM	S1,0(Q2)	;PUT IT BACK
	AOJA	Q1,CHKAB1	;DO NEXT

;CHECK A BYTE PTR
; S1/ BYTE PTR - IF LH IS -1, PTR IS FIXED

CHKBP:	HLRZ	S2,S1
	CAIN	S2,-1
	HRLI	S1,(POINT 7)
	LDB	S2,[POINT 6,S1,11] ;GET BYTE SIZE
	IBP	S1		;INCREMENT AND DECREMENT TO NORMALIZE
	PJRST	DBP
SUBTTL	Command Function / .CMINI - Init the scanner and do ^H

XCMINI:	HLRZ	T1,.CMIOJ(P2)		;DOING INPUT FROM TERMINAL?
	CAXE	T1,.PRIIN		;..
	JRST	CMINI4			;NO, SKIP REPAIR
	$CALL	TYPRMT		;GO TYPE A PROMPT

	CAMN	P4,.CMBFP(P2)		;BUFFER EMPTY?
	JRST	CMINI4			;YES, NO REDO POSSIBLE
	LDB	T1,P4			;CHECK LAST CHAR
	CAIN	T1,.CHLFD		;END OF LINE?
	JRST	CMINI4			;YES, LAST COMMAND OK, NO REDO
	$CALL	K%BIN			;GET FIRST CHARACTER
	CAIN	S1,CMRDOC		;IS IT REDO?
	JRST	CMINI5			;YES
	$CALL	K%BACK		;NO, BACKUP OVER IT

CMINI4:	MOVE	T1,P4			;RESET LINE VARIABLES
	MOVE	T2,.CMBFP(P2)
	MOVEM	T2,P4
	$CALL	SUBBP			;COMPUTE CHARACTERS IN LINE
	ADDM	T1,P3			;UPDATE SPACE COUNT
	SETZ	P5,0			;RESET ADVANCE COUNT
	JRST	XCOMXI			;RETURN GOOD

CMINI5:	MOVE	P3,.CMCNT(P2)		;RESET VARIABLES TO CURR FIELD
	MOVE	P4,.CMPTR(P2)
	LDB	T1,P4			;IF LAST CHARACTER WAS <CR>
	CAIN	T1,.CHCRT
	$CALL	CMDCH			;DELETE FROM INPUT BUFFER
	SETZ	P5,0			;NO INPUT
	$CALL	RETYPE		;RETYPE
	JRST	XCOMRP			;RETURN TO REPARSE
SUBTTL	Command Function / .CMSWI - Parse a SWITCH

;SWITCH - LIKE KEYWORD BUT PRECEEDED BY SLASH

XCMSWI:	TXO	F,CMSWF			;NOTE DOING SWITCH
	TXNE	F,CMDEFF		;DEFAULT GIVEN?
	JRST	CMKEY0			;YES, SLASH ALREADY ASSUMED
	$CALL	CMCIN			;GET FIRST CHAR
	JXN	F,CM%ESC,CMAMB		;AMBIGUOUS
	CAIN	T1,CMHLPC		;HELP?
	JRST	[SETZ	T1,0
		 MOVE	T2,ATBPTR
		 IDPB	T1,T2
		 MOVE	T1,FNARG	;GET TABLE PTR
		 MOVEI	T1,1(T1)	;POINT TO FIRST TABLE ENTRY
		 JRST	CMQ2]		;TYPE OPTIONS
	CAIE	T1,CMSWCH		;THE SWITCH CHARACTER?
	JRST	[$CALL	CMDIP		;NO, PUT IT BACK
		 NOPARS	(NPXNSW,Unrecognizable Switch Construction)]
	JRST	CMKEY0			;CONTINUE LIKE KEYWORD
SUBTTL	Command Function / .CMKEY - Parse a KEYWORD

XCMKEY:	TXZ	F,CMSWF			;NOT SWITCH
CMKEY0:
KEYW1:	$CALL	CMRATM		;READ THE FIELD INTO LOCAL BUFFER
	MOVE	T1,FNARG		;GET TABLE HEADER ADDRESS
	MOVE	T2,.CMABP(P2)		;POINT TO KEYWORD BUFFER
	$CALL	XTLOOK		;LOOKUP
	TXNE	F,CMQUES		;HAD "?"
	JRST	CMQ1			;YES, GO TYPE ALTERNATIVES
	TXNE	T2,TL%NOM		;NO MATCH?
	NOPARS(NPXNOM,No KEYWORD Match)
	JXN	T2,TL%AMB,CMAMB		; ??? AMBIGUOUS
	MOVEM	T1,T2			;SAVE TABLE INDEX
	MOVEM	T1,CRBLK+CR.RES		;AS RESULT
	JXE	F,CM%ESC,KEYW4		;DONE IF NO REC WANTED
	MOVEM	T3,Q1			;SAVE PTR TO REMAINDER OF STRING
	$CALL	CMDCH			;FLUSH RECOG CHARACTER
KEYW2:	ILDB	T1,Q1			;TYPE REMAINDER OF KEYWORD
	JUMPE	T1,KEYW3		;DONE
	$CALL	CMDIB			;APPEND COMPLETION TO BUFFER
	CAIN	T1,CMSWTM		;A SWITCH TERMINATOR?
	JRST	[TXZ	F,CM%ESC	;YES, OVERRIDES ESC
		 TXO	F,CM%SWT	;NOTE SWITCH TERMINAOTR
		 TXNN	F,CMSWF		;IN SWITCH?
		 $CALL	CMDIP		;NO, PUT TERMINATOR BACK
		 JRST	XCOMXI]		;DONE
	JRST	KEYW2

KEYW3:	JXE	F,CMSWF,XCOMXI		;DONE IF NOT SWITCH
	MOVE	Q1,FNARG		;CHECK FUNCTION FLAGS
	JXE	Q1,CM%VRQ,XCOMXI 	;DONE IF NO VALUE REQUIRED
	MOVEI	T1,CMSWTM		;INCLUDE COLON IN RECOGNITION
	$CALL	CMDIB
	TXO	F,CM%SWT		;NOTE SWITCH TERMINATOR
	JRST	XCOMX1			;INHIBIT ADDITIONAL SPACE

KEYW4:	$CALL	CHKLCH		;SEE IF ATOM NON-NULL
	JUMPE	T1,[NOPARS (NPXNUL,KEYWORD Expected)] 	;FAIL IF NULL
	JXE	F,CMSWF,XCOMXI		;DONE IF NOT SWITCH
	$CALL	CMSKSP		;SKIP SPACES
	$CALL	CMCIN			;GET NON-BLANK CHAR
	CAIN	T1,CMSWTM		;SWITCH TERMINATOR?
	JRST	[TXO	F,CM%SWT	;YES, NOTE
		 JRST	XCOMXI]		;DONE
	$CALL	CMDIP			;NO, PUT IT BACK
	MOVE	Q1,FNARG
	JXN	Q1,CM%VRQ,XCOMNP 	;FAIL IF VALUE WAS REQUIRED
	JRST	XCOMXI			;OTHERWISE OK
;"?" TYPED, FIRST PARTIAL MATCH FOUND.  TYPE ALL PARTIAL MATCHES

CMQ1:	JXN	T2,TL%NOM,[
		JXN	F,CMQUE2,CMRTYP ;DO NOTHING IF NOT FIRST ALTERNATIVE
		MOVEI	S1,[ASCIZ / keyword (no defined keywords match this input)/]
		$CALL	CMDSTO	;TYPE MESSAGE
		JRST	CMRTYP]		;RETYPE LINE AND CONTINUE
CMQ2:	MOVEM	T1,Q2			;SAVE TABLE INDEX
	$CALL	DOHLP			;DO USER HELP IF ANY
	TXNE	F,CM%SDH		;DEFAULT HELP SUPPRESSED?
	JRST	CMRTYP			;YES, DONE
	MOVE	T1,FNARG		;GET TABLE PTR
	HLRZ	Q1,0(T1)		;GET TABLE SIZE
	MOVE	S1,Q1			;SAVE SIZE OF THE TABLE
	ADDI	Q1,1(T1)		;COMPUTE TABLE END ADDRESS FOR BELOW
	CAIN	S1,1			;ONLY ONE ELEMENT IN TABLE
	JRST	CMQ5			;YES.. BYPASS TEXT AND OUTPUT BLANK
	MOVEI	S1,[ASCIZ / one of the following:/]
	$CALL	CMDSTO		;TYPE IT
	$CALL	CRLF			;AND A CRLF
CMTAB0:	SOJ	Q2,0			;GETS INCREMENTED BEFORE EACH APPLICATION
	MOVEM	Q2,Q3SAVE		;SAVE SO IT CAN BE REINITIALIZED
	SETZM	TABSIZ			;START WITH TAB SIZE OF 0
CMTAB1:	$CALL	CMNXTE		;GET TO NEXT VALID KEYWORD IN TABLE
	JUMPF	CMTAB2			;NO MORE IN TABLE
	$CALL	CMGTLN		;CALCULATE LENGTH OF KEYWORD
	CAML	T1,TABSIZ		;LONGEST SEEN SO FAR?
	MOVEM	T1,TABSIZ		;YES, REMEMBER IT
	JRST	CMTAB1			;LOOK AT REST
CMTAB2:	MOVE	T1,TABSIZ
	MOVEM	T1,BIGSIZ		;REMEMBER LENGTH OF LONGEST KEYWORD
	MOVEI	S1,2			;LEAVE AT LEAST 2 SPACES
	ADDM	S1,TABSIZ		;BETWEEN ITEMS
	MOVE	Q2,Q3SAVE		;RESTART TABLE POINTER FOR ACTUAL LISTING
CMQ3:	$CALL	CMNXTE		;GET TO NEXT KEYWORD
	JUMPF	CMRTYP			;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
CMQ4:	MOVEI	S1,"/"			;LOAD A SLASH
	TXNE	F,CMSWF			;ARE WE DOING SWITCHES?
	$CALL	CMDOUT		;YES, TYPE THE SLASH
	PUSH	P,T1			;SAVE ADDRESS OF TABLE ENTRY
	$CALL	CMGTLN		;COMPUTE ITS LENGTH
	ADDM	T1,CURPOS		;MOVE CURRENT POSITION FORWARD
	POP	P,S1			;RESTORE POINTER
	$CALL	CMDSTO		;TYPE IT
	$CALL	CMNXTE		;GET TO NEXT KEYWORD
	JUMPF	CMRTYP			;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
	$CALL	NXTKEY		;AND POSITION FOR THE NEXT ONE
	JRST	CMQ4			;TRY NEXT
CMQ5:	MOVEI	S1," "			;GET A BLANK
	$CALL	CMDOUT		;OUTPUT A CHARACTER
	JRST	CMTAB0			;CONTINUE HELP PROCESSING
;ROUTINE WHICH TAKES POINTER TO TABLE IN Q2, POINTER TO END OF TABLE
;IN Q1, AND RETURNS POINTER TO KEYWORD NAME IN T1. SKIPS UNLESS TABLE
;IS EXHAUSTED. ONLY CONSIDERS PRINTABLE KEYWORDS, AND UPDATES Q2.

CMNXTE:	AOS	Q2		;LOOK AT NEXT TABLE ENTRY
	CAML	Q2,Q1		;BEYOND END OF TABLE?
	$RETF			;YES, FINISHED LIST
	HLRZ	T2,0(Q2)	;GET STRING PTR FOR IT
	$CALL	CHKTBS	;GET FLAGS FROM STRING
	JXN	T1,CM%INV+CM%NOR,CMNXTE ;SKIP ENTRY IF INVISIBLE OR NOREC
	MOVE	T1,.CMABP(P2)	;PTR TO PARTIAL KEYWORD
	$CALL	USTCMP	;COMPARE
	JUMPE	T1,CMNXT1	;OK IF EXACT MATCH
	JXE	T1,SC%SUB,.RETF ;DONE IF NOT SUBSTRING

CMNXT1:	HLRZ	T2,0(Q2)	;GET PTR TO STRING FOR THIS ENTRY
	$CALL	CHKTBS
	MOVE	T1,T2
	$RETT			;RETURN TRUE!!
;ROUTINE TO CALL BEFORE TYPING KEYWORD IN RESPONSE TO "?". GIVE
;IT USER'S BYTE POINTER IN T1. IT DECIDES WHETHER KEYWORD WILL FIT
;ON THIS LINE, AND STARTS NEW LINE IF NOT. IT THEN OUTPUTS A TAB,
;FOLLOWED BY SWITCH DELIMITER (IF KEYWORD IS A SWITCH).

NXTKEY:	$CALL	.SAVET		;DON'T CLOBBER USER'S BYTE POINTER
	MOVE	T2,CURPOS		;GET OUR CURRENT POSITION
	PUSHJ	P,[CMTAB: ADD	T2,TABSIZ  ;FIGURE OUT MAXIMUM PLACE TAB CAN MOVE US TO
			   IDIV	T2,TABSIZ  ;SCALE DOWN TO REALLY WHERE
			   IMUL	T2,TABSIZ  ;TAB WILL BRING US TO
			   POPJ	P,0]
	ADD	T2,BIGSIZ		;MAKE SURE WE HAVE ROOM FOR ANOTHER COLUMN
	CAMLE	T2,PWIDTH		;ROOM FOR ANOTHER KEYWORD ON THIS LINE?
	PJRST	CRLF			;NO, TYPE A CRLF AND RETURN
	PJRST	TYPTAB			;YES, GET TO NEXT TAB STOP

;ROUTINE TO TYPE TAB OF SIZE TABSIZ. IT ASSUMES HARDWARE TABS ARE OF
;SIZE 8 AND TRIES TO TYPE AS MANY REAL TABS AS IT CAN, AND THEN SPACES
;OVER REST OF THE WAY.

TYPTAB:	MOVE	T2,CURPOS	;SEE WHERE WE'RE STARTING ON LINE
	$CALL	CMTAB		;SEE WHERE WE WANT TO GET TO
	MOVEM	T2,TABDON	;REMEMBER WHERE WE WANT TO GET TO
TYPTB1:	MOVE	T1,CURPOS	;GET WHERE WE ARE
	ADDI	T1,8		;HARDWARE TAB MIGHT GO THIS FAR
	TRZ	T1,7		;BUT MAYBE NOT QUITE
	CAMLE	T1,TABDON	;WILL HARDWARE TAB GO TOO FAR?
	JRST	TYPTB2		;YES
	MOVEI	S1,.CHTAB
	$CALL	XMCOUT	;AND TYPE IT
	JRST	TYPTB1		;LOOP FOR AS MANY HARDWARE TABS AS WE CAN GET AWAY WITH
TYPTB2:	MOVE	T1,CURPOS
	CAML	T1,TABDON	;ARE WE THERE YET?
	POPJ	P,0		;YES, SO TAB IS TYPED
	MOVEI	S1," "		;NO, SO SPACE OVER
	$CALL	XMCOUT
	JRST	TYPTB2		;AND LOOP FOR REST OF SPACES

;ROUTINE TAKING POINTER TO KEYWORD IN T1. RETURNS KEYWORD LENGTH IN
;T1. GIVES EXTRA 1 FOR SWITCH, ASSUMING A SLASH WILL PREFIX ITS
;PRINTOUT.

CMGTLN:	MOVEI	T4,0		;COUNT OF NUMBER OF CHARACTERS NEEDED FOR THIS KEYWORD
CMGT.1:	ILDB	T2,T1		;PICK UP NEXT CHARACTER FROM KEYWORD
	CAIE	T2,0		;ASSUME KEYWORD ENDS ON NULL
	AOJA	T4,CMGT.1	;NOT OVER YET, ACCUMULATE ITS LENGTH
	TXNE	F,CMSWF		;IS THIS A SWITCH?
	AOJ	T4,0		;YES, DELIMITER TAKES UP ANOTHER SPACE
	MOVE	T1,T4		;RETURN LENGTH IN T1
	POPJ	P,0
SUBTTL	Command Function / .CMTXT - Parse Arbitrary Text to Action Character

XCMTXT:	$CALL	CMRSTR		;READ STRING
	MOVEI	S1,[ASCIZ /text string/]
	TXNE	F,CMQUES		;QUESTION MARK TYPED?
	$CALL	HELPER		;YES, GIVE HELP
	JRST	XCOMXI			;DONE


SUBTTL	Function .CMNOI  --  Parse a NOISE-WORD

XCMNOI:	MOVE	S1,FNARG		;GET STRING PTR
	$CALL	CHKBP			;CHECK AND NORMALIZE
	MOVEM	S1,XXXPTR
	TXNN	F,CM%PFE		;PREVIOUS FIELD ENDED WITH ESC?
	JRST	CMNOI3			;NO
	TXO	F,CM%ESC		;YES, MEANS THIS ONE DID TOO
	MOVEI	T1,NOIBCH		;TYPE NOISE BEG CHAR
	$CALL	CMDIB			; AND PUT IT IN BUFFER
CMNOI2:	ILDB	T1,XXXPTR		;GET NEXT NOISE CHAR
	JUMPN	T1,[PUSHJ P,CMDIB	;PUT IT IN BUFFER IF NOT END OF STRING
		JRST	CMNOI2]
	MOVEI	T1,NOIECH		;END OF STRING, TYPE END CHAR
	$CALL	CMDIB
	JRST	XCOMXI			;EXIT

;PREVIOUS FIELD NOT TERMINATED WITH ESC - PASS NOISE WORD IF TYPED

CMNOI3:	$CALL	CMSKSP		;BYPASS SPACES
	$CALL	CMCIN			;GET FIRST CHAR
	CAIE	T1,NOIBCH		;NOISE BEG CHAR?
	JRST	[$CALL	CMDIP		;NO, NOT A NOISE WORD, PUT IT BACK
		 JRST	XCOMXI]		;RETURN OK
CMNOI4:	$CALL	CMCIN			;GET NEXT NOISE CHAR
	CAIE	T1,CMFREC		;^F?
	CAIN	T1,.CHESC		;ESC?
	JRST	[$CALL	CMDCH		;YES, FLUSH IT
		JRST	CMNOI2]		;COMPLETE NOISE WORD FOR USER
	ILDB	T2,XXXPTR		;COMPARE WITH GIVEN STRING
	CAIL	T1,"A"+40		;RAISE CASING FOR COMPARE
	CAILE	T1,"Z"+40
	SKIPA
	SUBI	T1,40
	CAIL	T2,"A"+40
	CAILE	T2,"Z"+40
	SKIPA
	SUBI	T2,40
	CAMN	T1,T2
	JRST	CMNOI4			;STILL SAME AS EXPECTED
	CAIN	T1,NOIECH		;NOT SAME, STRING ENDED TOGETHER?
	JUMPE	T2,XCOMXI		;YES, EXIT OK
	NOPARS	(NPXINW,Bad Noise Word)	;NO, PROBABLY BAD NOISE WORD
SUBTTL	Command Function / .CMCFM - Command Confirmation (end-of-line)

XCMCFM:	$CALL	CMCFM0		;DO THE WORK
	NOPARS(NPXNC,CONFIRMATION Required)
	JRST	XCOMXI			;OK

CMCFM0:	$CALL	CMCIN			;GET CHAR
	CAIE	T1,.CHTAB		;BLANK?
	CAIN	T1," "
	JRST	CMCFM0			;YES, IGNORE
	MOVEI	S1,[ASCIZ /confirm with carriage return/]
	CAIN	T1,CMHLPC		;HELP?
	$CALL	HELPER		;YES, GIVE IT
	JXN	F,CM%ESC,CMAMB		;AMBIGUOUS
	CAIE	T1,.CHLFD		;NL (NEW LINE, I.E. LINEFEED)
	POPJ	P,0			;NO, FAIL
	RETSKP				;YES
;FLOATING POINT NUMBER

XCMFLT:
	MOVEI	T1,FLTBRK	;USE SPECIAL BREAK SET
	$CALL	CMRFLD	;READ FIELD
	MOVEI	S1,[ASCIZ /number/]
	TXNE	F,CMQUES		;QUESTION MARK?
	$CALL	HELPER			;YES, HELP!
	MOVE	S1,.CMABP(P2)		;NUMBER NOW IN ATOM BUFFER, GET PTR
	$CALL	FLIN			;EAT REAL #
	JUMPF	CMNUM1			;OOPS, DIDNT PARSE
	JRST	CMNUMR			;DO NUMBER CLEANUP AND RETURN

;FLOATING POINT BREAK SET MASK, ALLOWS +, -, ., E, NUMBERS

FLTBRK:	777777,,777760
	777644,,001760
	400000,,000760
	400000,,000760
SUBTTL	Command Function / .CMNUM - Parse an INTEGER in any base
SUBTTL	Command Function / .CMNUX - Parse an INTEGER in any base (special break)

XCMNUX:	SKIPA	T1,[NUXBRK]	;USE SPECIAL BREAK SET
XCMNUM:	MOVEI	T1,NUMBRK	;USE REGULAR BREAK SET
	$CALL	CMRFLD	;READ FIELD
	TXNE	F,CMQUES	;SAW "?"
	JRST	CMNUMH		;YES
	MOVE	S1,.CMABP(P2)	;SETUP NIN
	MOVE	S2,FNARG	;GET RADIX
	$CALL	NUMIN		;PARSE THE NUMBER
	JUMPF	CMNUM1		;NO PARSE
CMNUMR:	MOVEM	S2,CRBLK+CR.RES	;STORE RESULT
	MOVE	T2,ATBPTR
	IBP	T2		;BUMP PTR PAST TERMINATOR
	CAMN	S1,T2		;NIN SAW WHOLE FIELD?
	JRST	[MOVE	T2,CRBLK+CR.RES
		JRST	XCOMXR] ; YES, RECOVER RESULT AND RETURN
CMNUM1:	NOPARS	(NPXICN,Numeric Character Expected)

;NUMBER BREAK SET, ALLOWS +, -, NUMBERS

NUMBRK:	777777,,777760
	777654,,001760
	400000,,000760
	400000,,000760

NUXBRK:	777777,,777760
	777654,,001760
	777777,,777760
	777777,,777760


	SUBTTL	NUMIN	--	NUMBER INPUT ROUTINE

	;THIS ROUTINE WILL PARSE A NUMBER FROM A STRING AND RETURN THE
	;VALUE
	;
	;CALL	S1/	POINTER TO THE STRING
	;	S2/	RADIX
	;
	;RETURN TRUE:
	;	S1/	UPDATED POINTER
	;	S2/	NUMBER


NUMIN:	$CALL	.SAVE3	;GET 2 SCRATCH ACS
	SETZ	P2,	;CLEAR SIGN MODIFIER
NUMI.1:	ILDB	P1,S1		;GET FIRST CHARACTER
	CAIN	P1," "		;A BLANK?
	JRST	NUMI.1		;YES, IGNORE IT
	CAIN	P1,"-"		;IS IT MINUS SIGN?
	JRST	[JUMPN	P2,.RETF	;ONLY ALLOW ONE SIGN
		 MOVX	P2,-1		;SET NEGITIVE
		JRST NUMI.1]		;GET NEXT CHARACTER
	CAIN	P1,"+"		;IS IT PLUS SIGN?
	JRST	[JUMPN	P2,.RETF	;ONLY ALLOW ONE SIGN
		 MOVX	P2,+1		;SET POSITIVE
		 JRST	NUMI.1]		;GET NEXT CHARACTER
	CAIG	P1,"0"-1(S2)	;TOO BIG
	CAIGE	P1,"0"		;OR TOO SMALL?
	$RETF			;YES, TAKE FAILURE RETURN
	SETZ	P3,0		;CLEAR THE RESULT
NUMI.2:	IMULI	P3,0(S2)	;SHIFT OVER 1 DIGIT
	ADDI	P3,-"0"(P1)	;AND ADD IN THIS ONE
	ILDB	P1,S1		;GET NEXT CHAR
	CAIG	P1,"0"-1(S2)	;IN RANGE?
	CAIGE	P1,"0"
	JRST	NUMI.3		;FINISH OFF AND RETURN
	JRST	NUMI.2		;YES, REPEAT
NUMI.3:	SKIPGE	P2		;SHOULD BE NEGATIVE?
	MOVNS	P3		;MAKE IT NEGATIVE
	MOVE	S2,P3		;GET THE VALUE
	$RETT			;RETURN TRUE
CMNUMH:	$CALL	DOHLP		;DO USER SUPPLIED MESSAGE
	JXN	F,CM%SDH,CMRTYP	;SUPPRESS DEFAULT HELP IF REQUESTED
	HRRZ	T2,FNARG	;GET BASE
	CAIL	T2,^D2		;LEGAL?
	CAILE	T2,^D10
	$STOP(IBN,Illegal base for number)
	CAIN	T2,^D10		;DECIMAL?
	JRST	CMNH10		;YES
	CAIN	T2,^D8		;OCTAL?
	JRST	CMNH8		;YES
	MOVEI	S1,[ASCIZ / a number in base /]
	$CALL	CMDSTO	;ARBITRARY BASE
	HRRZ	T1,.CMIOJ(P2)
	HRRZ	T2,FNARG
	MOVEI	T3,^D10
	ADDI	T2,"0"		;CONVERT BASE TO ASCII
	MOVE	S1,T2			;COPY THE BASE OVER
	$CALL	CMDOUT		;AND TYPE IT
	SUBI	T2,"0"			;CONVERT IT BACK
	JRST	CMRTYP		;RETYPE LINE AND CONTINUE

CMNH8:	MOVEI	S1,[ASCIZ / octal number/]
	JRST	CMNH

CMNH10:	MOVEI	S1,[ASCIZ / decimal number/]
CMNH:	$CALL	CMDSTO
	JRST	CMRTYP
SUBTTL	Command Function / .CMDEV - Parse a DEVICE specification

XCMDEV:	MOVEI	T1,DEVBRK		;GET DEVICE BREAK SET
	$CALL	CMRFLD		;GET THE FIELD
	MOVEI	S1,[ASCIZ /device name/]
	TXNE	F,CMQUES		;TYPE A QUESTION MARK?
	$CALL	HELPER		;YES, CALL THE HELPER
	JXN	F,CM%ESC,CMAMB		;AMBIGUOUS
	MOVE	S1,.CMABP(P2)		;ADDRESS OF BUFFER
	$CALL	CMCIN			;CHECK TERMINATOR
	CAIE	T1,":"			;DEVICE?
	NOPARS(NPXIDT,<Invalid Device --  Device Specifications Requires a :>)
	TXNE	F,CM%PO			;PARSE ONLY ON FIELD
	JRST	XCOMXR			;YES..RETURN O.K.
	MOVE	S1,.CMABP(P2)		;POINT AT THE ATOM BUFFER
	$CALL	CNVSIX		;CONVERT FIELD TO SIXBIT
	SKIPT				;O.K. S1/  FIELD NAME
	NOPARS(NPXDGS,<Device Name is Greater Than Six Characters>)
	DEVCHR	S2,			;SEE IF IT EXISTS
	SKIPN	S2			;VALID DATA
	NOPARS(NPXDNE,<DEVICE Name Does Not Exist>)
	TXNE	S2,DV.IN!DV.OUT		;CHECK IF CAN DO INPUT OR OUTPUT
	PJRST	XCOMXR			;YES..RETURN O.K.
	NOPARS(NPXDIO,<DEVICE can not do INPUT or OUTPUT>)

DEVBRK:	777777,,777760			;BREAK ON ALL CONTROL CHARACTERS
	757754,,001760			;BREAK ON : ALLOW 0-9
	400000,,000740			;ALLOW UC
	400000,,000760			;ALLOW LC
SUBTTL	Command Function / .CMQST - Parse a QUOTED STRING

XCMQST:	$CALL	CMRQST		;READ THE STRING
	NOPARS(NPXNQS,Quoted String Expected)
	MOVEI	S1,[ASCIZ /quoted string/]
	TXNE	F,CMQUES		;QUESTION MARK TYPED?
	$CALL	HELPER		;YES, GIVE HELP
	JRST	XCOMXI

;UNQUOTED STRING - TAKES BIT MASK (4 WORDS * 32 BITS) TO SPECIFY BREAKS.

XCMUQS:
CMUQS1:	$CALL	CMCIN		;GET A CHAR
	IDIVI	T1,^D32		;COMPUTE INDEX TO BIT ARRAY
	MOVE	T2,BITS(T2)
	ADD	T1,FNARG
	TDNN	T2,0(T1)	;BIT ON?
	JRST	CMUQS1		;NO, KEEP GOING
	$CALL	CMDIP		;YES, PUT CHAR BACK
	JRST	XCOMXI		;DONE

;ARBITRARY FIELD

XCMFLD:	$CALL	CMRATM
CMFLD1:	TXNE	F,CMQUES	;"?" SEEN?
	JRST	[$CALL	DOHLP		;YES, DO USER MESSAGE
		 JRST	CMRTYP]
	JRST	XCOMXR		;LEAVE FIELD IN ATOM BUFFER

;ACCOUNT
XCMACT:	MOVEI	T1,USRBRK	;SAME BREAK SET AS USER NAME FIELD
	$CALL	CMRFLD	;READ FIELD
	JRST	CMFLD1		;FINISH LIKE ARBITRARY FIELD
SUBTTL	Command Function / .CMNOD - Parse a NODE Specification

XCMNOD:	$CALL	CMRATM		;GET AN ATOM
	MOVEI	S1,[ASCIZ /node name/]
	TXNE	F,CMQUES		;DID HE TYPE A QUESTION MARK?
	$CALL	HELPER		;YES, TYPE THE HELP TEXT(S)
	JXN	F,CM%ESC,[PUSHJ P,CMDCH	;DO RECOGNITION IF REQUESTED
			  PUSHJ P,TIELCH;TIE ATOM BUFFER
			  JRST  XNOD1]	;RETURN IN LINE
XNOD1:	MOVE	S1,.CMABP(P2)		;GET THE BYTE POINTER
	ILDB	S2,S1			;GET THE FIRST BYTE
	SKIPN	S2			;BETTER NOT BE NULL
	JRST	ILLNOD			;IMPROPER NODE NAME
	MOVE	S1,.CMABP(P2)		;POINT AT THE ATOM BUFFER
	MOVEI	S2,^D8			;TRY AS AN OCTAL NUMBER
	$CALL	NUMIN			;READ IT
	  JUMPF	XNOD2			;LOST, TRY AS A SIXBIT NAME
	MOVEM	S2,CRBLK+CR.RES		;SAVE AS RESULT
	MOVE	T2,ATBPTR		;GET POINTER TO END OF ATOM BUFFER
	IBP	T2			;POINT AT TERMINATOR
	CAME	S1,T2			;OUR POINTER END THE SAME PLACE?
	JRST	ILLNOD			;NO, LOSE!
	MOVE	T3,CRBLK+CR.RES		;NODE NUMER WE JUST PARSED
	TXNE	F,CM%PO			;PARSE ONLY?
	JRST	XCOMXI			;YES, JUST RETURN WITH RESULT
	MOVE	T1,[XWD .NDRNN,T2] 	; MAKE SURE THAT THIS NODE NUMBER EXISTS
	MOVEI	T2,2			;2 ARGS
	NODE.	T1,			;TRY IT FOR EXISTANCE
	  JRST	ILLNOD			;IT DOESN'T!
	JRST	XCOMXI			;A GOOD NODE NUMBER, RETURN

XNOD2:	MOVE	S1,.CMABP(P2)		;POINT AT THE ATOM BUFFER
	$CALL	CNVSIX		;CONVERT BUFFER TO SIXBIT
	SKIPT				;O.K.. CONTINUE
ILLNOD:	NOPARS	(NPXNNC,Improper Node Name)
	MOVEM	S2,CRBLK+CR.RES		;SAVE SIXBIT NAME IN RESULT FIELD

XNOD3:	TXNE	F,CM%PO			;PARSE ONLY?
	PJRST	XCOMXR			;YES..RETURN NOW
	MOVE	T2,ATBPTR		;GET POINTER TO END OF ATOM BUFFER
	IBP	T2			;POINT AT TERMINATOR
	CAME	S1,T2			;OUR POINTER END THE SAME PLACE?
	NOPARS	(NPXNNI,Node Name Expected)

XNOD4:	MOVEI	T2,2			;2 ARGS
	MOVE	T3,S2			;GET NODE NAME RETURNED

	MOVE	T1,[XWD .NDRNN,T2]
	NODE.	T1,0
	  NOPARS(NPXNSN,<Node Name is Not a Valid  Node>)
	MOVEM	T1,CRBLK+CR.RES		;STORE NUMBER
	JRST	XCOMXI			;AND RETURN
;FILE SPEC

XCMOFI:
XCMIFI:


XCMFIL:	$CALL	CMRFIL	;GET FILE SPECIFICATION
	JXN	F,CMQUES,CMFHLP	;IF THEY WANT HELP, GIVE IT TO THEM
	JXN	F,CM%ESC,[PUSHJ P,CMDCH	;ALLOW ESCAPE AS VALID TERMINATOR
			  PUSHJ P,TIELCH
			  JRST XFIL.1 ]	;RETURN IN LINE
XFIL.1:	$CALL	FILIN		;GET FILE SPEC
	  NOPARS (NPXIFS,Invalid File Specification)
	MOVE	T2,ATBPTR	;GET POINTER TO ATOM BUFFER END
	IBP	T2		;BUMP PAST TERMINATOR
	CAME	T2,XXXPTR	;DOES IT MATCH?
	  NOPARS (NPXIFS,Invalid File Specification)
	JRST	XCOMXI		;OTHERWISE, DONE


FILIN:	$CALL	.SAVE1	;SAVE A REG
	LOAD	S2,.CMGJB(P2),CM%GJB ;GET ADDR OF FD
	MOVEM	S2,CRBLK+CR.RES	;SAVE IT FOR CALLER
	MOVE	P1,S2		;AND REMEMBER IT
	MOVX	S1,FDXSIZ	;NOW ZERO IT OUT
	STORE	S1,.FDLEN(S2),FD.LEN ;STORE LENGTH INTO FD
	SKIPN	S1,.FDSTR(P1)	;SEE IF USER SUPPLIED A DEFAULT DEVICE
	MOVSI	S1,'DSK'	;NO, SUPPLY DEFAULT DEVICE
	STORE	S1,.FDSTR(P1)	;STORE DEFAULT DEVICE
	MOVE	T1,.CMABP(P2)	;GET ATOM BUFFER POINTER
	MOVEM	T1,XXXPTR	;STORE IT
	$CALL	FTOKEN	;GET FIRST FILE TOKEN
	CAIE	T2,':'		;IS FIRST PART A DEVICE
	JRST	FILI.1		;NO
	MOVEM	T1,.FDSTR(P1)	;STORE STRUCTURE NAME
	$CALL	FTOKEN	;YES, LOAD NEXT TOKEN
FILI.1:	JUMPN	T1,FILI.2	;IF WE HAVE SOMETHING, IT MUST BE FILENAM
	CAIE	T2,'['		;IF NOT, EXPECT A PPN HERE
	JRST	FILI.4		;CHECK FOR SUFFICIENT FILE-SPEC
	MOVE	S1,XXXPTR	;GET POINTER TO PPN
	$CALL	DBP		;DECREMENT POINTER
	MOVE	T1,S1		;GET THE POINTER
	MOVEI	T2,.FDPPN(P1)	;POINT TO DESTINATION
	HRLI	T2,5		;AND SET MAXIMUM DEPTH FOR SFD'S
	$CALL	PATHIN	;PARSE PATH
	  POPJ	P,		;PASS ON FAILURE
	$CALL	FTOKEN	;AND GET NEXT PART
FILI.2:	SKIPE	T1		;IF NO FILE NAME, LOOK FOR EXTENSTION
	STORE	T1,.FDNAM(P1)	;STORE NAME
	CAIE	T2,'.'		;IS THERE AN EXTENSION?
	JRST	FILI.3		;NO
	$CALL	FTOKEN	;GET EXTENSION
	STORE	T1,.FDEXT(P1)	;AND STORE IT
FILI.3:	CAIE	T2,'['		;HAVE WE GOT A PPN?
	JRST	FILI.4		;CHECK FOR SUFFICIENT FILE-SPEC
	MOVE	S1,XXXPTR	;RELOAD THE POINTER
	$CALL	DBP		;DECREMENT IT
	MOVE	T1,S1		;PLACE POINTER BACK IN T1
	MOVEI	T2,.FDPPN(P1)	;POINT TO DESTINATION
	HRLI	T2,5		;AND SET MAXIMUM SFD DEPTH
	$CALL	PATHIN	;PARSE THE PATH
	  POPJ	P,		;RETURN A FAILURE
	IBP	XXXPTR		;AND BUMP PAST TERMINATOR
FILI.4:	SKIPN	.FDNAM(P1)	;MAKE SURE THERE IS A NAME
	POPJ	P,		;NO NAME, BAD FILE SPEC
	RETSKP			;TAKE GOOD RETURN


FTOKEN:	SETZM	T1		;CLEAR RESULT
	MOVE	T3,[POINT 6,T1]	;AND POINT TO STORAGE AREA
	
FTOK.1:	ILDB	T2,XXXPTR	;GET A BYTE
	$CALL	C7TO6		;CONVERT TO SIXBIT
	CAIG	T2,'Z'		;IS IT IN RANGE?
	CAIGE	T2,'0'		;
	POPJ	P,0		;NO
	CAILE	T2,'9'		;
	CAIL	T2,'A'		;
	SKIPA
	POPJ	P,0
	TXNE	T3,<INSVL.(77,BP.POS)> ;IS THERE ROOM?
	IDPB	T2,T3		;YES,STORE IT
	JRST	FTOK.1		;TRY ANOTHER

C7TO6:	CAIL	T2,"a"		;IS IT LC?
	SUBI	T2,40		;YES
	SUBI	T2," "		;CONVERT TO SIXBIT
	ANDI	T2,77		;MASK IT AND
	POPJ	P,		;RETURN
;FILESPEC HELP

CMFHLP:	$CALL	DOHLP		;DO USER MESSAGE
	JXN	F,CM%SDH,CMRTYP	;SUPPRESS DEFAULT HELP IF REQUESTED
	LOAD	T2,.CMFNP(P1),CM%FNC	;GET FUNCTION CODE
	CAXE	T2,.CMIFI		;INPUT FILE?
	SKIPA	S1,[EXP [ASCIZ / output filespec/]] ;NO, OUTPUT
	MOVEI	S1,[ASCIZ \ input filespec\]	;YES,INPUT
CMFH1:	$CALL	CMDSTO
	JRST	CMRTYP

;TOKEN - ARBITRARY SYMBOL AS SPECIFIED BY FN DATA

XCMTOK:	MOVE	Q1,FNARG	;GET STRING ADDRESS
CMTOK1:	ILDB	Q2,Q1		;GET NEXT CHAR IN STRING
	JUMPE	Q2,[PUSHJ P,TIELCH	;SUCCESS IF END OF STRING
		JRST	XCOMXI]
CMTOK2:	$CALL	CMCIN		;GET NEXT CHAR OF INPUT
	CAMN	T1,Q2		;MATCH?
	JRST	[$CALL	STOLCH	;YES, APPEND TO ATOM BUFFER
		JRST	CMTOK1]		;CONTINUE
	JXN	F,CM%ESC,CMAMB	;AMBIGUOUS
	CAIN	T1,CMHLPC	;HELP REQUEST?
	JRST	[$CALL	DOHLP		;YES
		JXN	F,CM%SDH,CMRTYP
		MOVEI	S1,""""		;TYPE "token"
		$CALL	CMDOUT
		MOVE	S1,FNARG
		$CALL	CMDSTO
		MOVEI	S1,""""
		$CALL	CMDOUT
		JRST	CMRTYP]
	NOPARS	(NPXNMT,Invalid Token Found)	;NO MATCH OF TOKEN
SUBTTL	PATHIN	Routine to Parse TOPS-10 Path Specification

; PATHIN may be called to Parse a Path Specification in the Atom Buffer
; it builds a Path Block up to 6 words in length depending
; on the depth specified in T2 on the call.

; CALL	T1/ Byte Pointer to String
;	T2/ Length of Destination,,Destination Address

; Uses T1-T4 and XXXPTR

; Destination must not be an AC and Depth must be Less Than 6

; True Return is a Skip Return
;  With:	PPN and Path Stored Via Calling Arg in T2
;		XXXPTR Pointing to Terminating byte ("]") in String

; Error Return is a non skip Return

PATHIN:	ILDB	S1,T1		;LOAD FIRST BYTE
	CAIE	S1,"["		;MUST BE BRACKET
	 POPJ	P,0		;ELSE FAIL
	$CALL	.SAVE2	;PRESERVE P1-P2
	HRRZ	P2,T2		;GET DESTINATION ADDRESS
	HRLI	P2,P1		;P2 IS NOW  DESTINATION(P1)
	AOBJP	T2,.+1		;ADD ONE TO INCLUDE PPN WITH SFD'S
	HLLZ	P1,T2		;GET DEPTH IN P1 LEFT HALF
	MOVN	P1,P1		;P1 IS NOW AOBJN POINTER
	$CALL	RDPATH	;GET CURRENT PATH IN PTHBLK
	MOVEM	T1,XXXPTR	;SAVE IN CASE OF PPN FAILURE
	MOVE	S1,T1		;GET THE POINTER
	MOVEI	S2,^D8		;SET OCTAL RADIX
	$CALL	NUMIN		;FOR PROJECT AND PROGRAMMER NUMBERS
	LDB	T1,S1		;GET TERMINATOR
	CAIE	T1,","		;MUST BE COMMA
	  POPJ	P,0		;FAIL -- PPN NOT NUMERIC
	SKIPN	S2		;WAS ANSWER 0?
	HLR	S2,PTHBLK+.PTPPN ;YES -- LOAD DEFAULT
	HRLM	S2,(P2)		;STORE IN DESTINATION
	MOVEI	S2,^D8		;SET OCTAL RADIX
	$CALL	NUMIN
	LDB	T1,S1		;GET TERMINATOR
	CAIE	T1,","		;MUST BE COMMA OR BRACKET
	CAIN	T1,"]"
	 SKIPA
	 POPJ	P,0		;FAIL -- PPN INCORECT
	SKIPN	S2		;WAS ANSWER 0
	HRR	S2,PTHBLK+.PTPPN ;YES -- LOAD DEFAULT
	HRRM	S2,(P2)		;STORE IN DESTINATION
	MOVEM	S1,XXXPTR	;STORE UPDATED POINTER
	MOVE	T1,(P2)		;RECLAIM PPN
	JRST	PATH.2		;LOOK FOR SFD'S
PATH.1:	$CALL	FTOKEN	;GET TOKEN
PATH.2:SKIPN	T1		;IF FIELD IS ZERO
	MOVE	T1,PTHBLK+.PTPPN(P1) ;LOAD DEFAULT
	JUMPE	T1,.POPJ	;FAIL IF DEFAULT WAS 0
	MOVEM	T1,@P2		;STORE RESULT
	LDB	S1,XXXPTR	;GET TERMINATOR
	CAIN	S1,"]"		;AT END OF PATH?
	JRST	PATH.3		;YES -- CLEAR REST OF PATH
	CAIE	S1,","		;VALID SEPARATOR?
	 POPJ	P,0		;NO -- GIVE FAILURE RETURN
	AOBJN	P1,PATH.1	;REPEAT UNTIL MAXIMUM DEPTH
	POPJ	P,0		;TO DEEP -- GIVE FAILURE
	
PATH.3:	AOBJP	P1,PATH.4	;CLEAR REST OF PATH
	SETZM	@P2		;CLEAR REST OF DESTINATION
	JRST	PATH.3

PATH.4:	RETSKP			;GIVE GOOD RETURN
SUBTTL	PATH SUPPORT ROUTINES

; RDPATH Routine to Read Path for channel or job
; CALL Using No Arguments
; RETURN With Job's Path in PTHBLK

RDPATH:	MOVEI	S1,.PTMAX	;CLEAR ANSWER AREA
	MOVEI	S2,PTHBLK
	$CALL	.ZCHNK
	SETOM	PTHBLK			;REQUEST PATH FOR CURRENT JOB
	MOVE	S1,[.PTMAX,PTHBLK]	;POINT TO BLOCK
	PATH.	S1,
	 SETZM	PTHBLK			;OOPS -- FAILED
	POPJ	P,0			;RETURN
; PPN (EITHER DIRECTORY OR USER NAME FUNCTION)


XCMDIR:
XCMUSR:				;EQUIVALENT
	$CALL	CMRPTH	;GET PATH SPEC INTO ATOM
	MOVEI	S1,[ASCIZ/[Project,Programmer]/]
	JXN	F,CMQUES,HELPER	;GIVE HELP IF REQUESTED
	JXN	F,CM%ESC,[PUSHJ P,CMDCH	;ALLOW ESCAPE AS TERMINATOR
		  PUSHJ P,TIELCH
		  JRST XUSR.1]		;RETURN IN LINE

XUSR.1:	MOVE	T1,.CMABP(P2)	;POINT TO ATOM
	MOVEI	T2,CRBLK+CR.RES	;POINT TO DESTINATION
	$CALL	PATHIN	;PARSE PATH
	 NOPARS (NPXIUS,Invalid User Specification)
	MOVE	T1,XXXPTR	;Ensure Entire atom was parsed
	CAME	T1,ATBPTR
	 NOPARS (NPXIUS,Invalid User Specification)
	JRST	XCOMXI		;DONE NOW
;COMMA, ARBITRARY CHARACTER

XCMCMA:	MOVEI	T1,","		;SETUP COMMA AS CHARACTER TO FIND
	MOVEM	T1,FNARG
CMCHR:	$CALL	CMCIN		;GET A CHAR
	CAIE	T1,.CHTAB	;BLANK?
	CAIN	T1," "
	JRST	CMCHR		;YES, IGNORE
	HRRZ	T2,FNARG	;GET SPECIFIED CHAR
	CAMN	T1,T2		;THE RIGHT ONE?
	JRST	XCOMXI		;YES, WIN
	JXN	F,CM%ESC,CMAMB		;AMBIGUOUS
	CAIN	T1,CMHLPC	;HELP?
	JRST	[$CALL	DOHLP
		JXN	F,CM%SDH,CMRTYP ;JUMP IF SUPPRESSING HELP
		MOVEI	S1,""""		;TYPE "char"
		$CALL	CMDOUT
		HRRZ	S1,FNARG
		$CALL	CMDOUT
		MOVEI	S1,""""
		$CALL	CMDOUT
		JRST	CMRTYP]
	NOPARS	(NPXCMA,Comma was Expected)	;FAIL
;DATE AND/OR TIME
;FLAGS IN ARG SPECIFY WHICH

XCMTAD:	MOVE	Q1,FNARG	;GET ARG
	$CALL	CMRSPC	;READ FIRST FIELD
	JXN	F,CMQUES,CMTADH	;DO HELP IF REQUESTED
	JXN	F,CMDEFF,CMTAD1	;JUMP IF NOW HAVE FIELD DEFAULT
;	TXC	Q1,CM%IDA+CM%ITM ;DATE AND TIME BOTH?
;	TXCN	Q1,CM%IDA+CM%ITM
;	JRST	[MOVEI	T1," "		;YES, PUT SPACE IN ATOM BUFFER
;		$CALL	STOLCH
;		$CALL	CMRSPC	;READ SECOND FIELD
;		JXN	F,CMQUES,CMTADH ;DO HELP
;		JRST	.+1]
CMTAD1:	$CALL	DATIM		;GET DATE AND TIME
	JUMPT	CMTAD2		;CONTINUE ON
	MOVEI	T1,@DERTBL(S1)	;GET MESSAGE ADDRESS
	HRLI	T1,NPXBDF	;SET CODE TOO
	JRST	XCOMNE		;EXIT WITH MSG

CMTAD2:	TXNE	Q1,CM%NCI	;CONVERT TO INTERNAL FORMAT?
	  JRST CMTAD3		;NO .. STORE DATA IN USER BLOCK 
	MOVEM	S1,CRBLK+CR.RES	;STORE RESULT
	JRST	XCOMXR		;OK, TAD ALREADY IN T2
CMTAD3:	MOVEM	S1,NOW		;SAVE THE TIME FOR NOW
	$CALL	CMPDAT	;GET THE VALUE
	MOVE	S1,VAL9		;GET CENTURY
	IMULI	S1,^D100	;MAKE IT YEARS
	MOVE	S2,VAL8		;GET DECADES
	IMULI	S2,^D10		;MAKE YEARS ALSO
	ADD	S2,S1		;COMBINE THEM
	ADD	S2,VAL7		;GET THE YEAR FIELD
	HRL	S1,S2		;PLACE IN LEFT HALF
	HRR	S1,VAL6		;GET THE MONTH
	MOVEM	S1,0(Q1)	;SAVE IN THE BLOCK
	HRLZ	S1,VAL5		;GET THE MONTH
	MOVEM	S1,1(Q1)	;SAVE THE SECOND WORD
	MOVE	S1,SECONDS	;GET SECONDS
	HRRZM	S1,2(Q1)	;RIGHT HALF OF THIRD WORD
	JRST	XCOMXR

;TIME/DATE HELP
CMTADH:	$CALL	DOHLP		;DO USER TEXT
	JXN	F,CM%SDH,CMRTYP	;CHECK SUPPRESS DEFAULT
	LOAD	T1,Q1,<CM%IDA+CM%ITM> ;GET FLAGS
	MOVE	S1,[[ASCIZ //]
		    [ASCIZ / time/]
		    [ASCIZ / date/]
		    [ASCIZ / date and time/]](T1)
	$CALL	CMDSTO	;PRINT APPROPRIATE MESSAGE
	JRST	CMRTYP
	SUBTTL	DATIM	--	DATE AND TIME PARSER
	;These routines are called by the .CMTAD function of CPASCN
	;for processing date and time data
	;
	;
	;	CALL	S1/	POINTER TO THE STRING
	;		S2/	NUMBER OF CHARACTERS IN BUFFER
	;
	;
	;	RETURN TRUE	S1/	UDT FOR THE TIME
	;	RETURN FALSE	ERROR CODE IN S1


DATIM:	$CALL	.SAVE1		;SAVE P1
	MOVE	S1,.CMABP(P2)		;POINT TO ATOM BUFFER
	MOVE	S2,.CMABC(P2)		;COUNT IN THE ATOM BUFFER
	SUB	S2,ATBSIZ		;GET THE ACTUAL COUNT
	DMOVEM	S1,TIMPTR		;SAVE POINTER AND COUNT
	SETZM	FLFUTD			;CLEAR THE FUTURE
	SETZM	FLFUTR			;CLEAR THE VALUES
	SETOM	VAL1			;SET DEFAULT VALUES
	MOVE	S1,[VAL1,,VAL2]		;GET BLT POINTER
	BLT 	S1,VAL9			;DEFAULT ALL VALUES
	$CALL	I%NOW			;GET THE CURRENT DATE AND TIME
	MOVEM	S1,NOW			;SAVE THE TIME
	MOVE	S1,FNARG		;GET THE ARGS
	$CALL	GETCHR		;GET A CHARACTER
	CAIN	S1,"+"			;WAS IT A +
	  PJRST	PLSRTN			;CHECK PLUS ROUTINE
	CAIN	S1,"-"			;WAS IT A MINUS
	  PJRST	MINRTN			;MINUS ROUTINE
	CAIL	S1,"0"			;LESS THAN 0
	CAILE	S1,"9"			;LESS THAN 9
	  PJRST	DATPAR			;NO TRY PARSING THE DATE
	$CALL	DECBPT		;BACK UP TO FIRST CHARACTER
	$CALL	DECNUM		;GET THE NUMBER
	JUMPF	E$$IDT			;INVALID DATE AND TIME
	MOVEM	S1,DAYNUM		;SAVE THE NUMBER
	SKIPN	S2,LSTCHR		;GET LAST CHARACTER
	  PJRST	DATI.1			;SETUP FOR TIMPAR
	CAIN	S2,"D"			;CHECK IF DAYS	
	  JRST	DAYRTN			;PROCESS THE DAYS
	CAIE	S2,":"			;
	  PJRST	ALTDAT			;TRY THE ALTERNATE DATE FORMS
DATI.1:	MOVE	S1,.CMABP(P2)		;POINT TO ATOM BUFFER
	MOVE	S2,.CMABC(P2)		;COUNT IN THE ATOM BUFFER
	SUB	S2,ATBSIZ		;GET THE ACTUAL COUNT
	DMOVEM	S1,TIMPTR		;GET BACK TO START
DATI.2:	$CALL	TIMPAR		;PARSE THE TIME
	JUMPF	.POPJ			;ERROR..RETURN
	PJRST	CMPDAT			;COMPUTE THE DATE AND RETURN
	SUBTTL	TIMPAR	--	PARSE THE TIME FIELD

	;This routine will parse a time and return
	;
	;RETURN:	S1/	TIME IN SECONDS
	;		S2/	FRACTION OF DAY IN RH

TIMPAR:	MOVE	S1,FNARG		;GET THE ARGUMENT FLAGS
	TXNN	S1,CM%ITM		;TIME WANTED?
	  PJRST	E$$ITF			;TIME FIELD INVALID
	SETZM	SECOND			;CLEAR SECONDS
	SETZM	MINUTE			;CLEAR MINUTES
	SETZM	HOURS			;CLEAR HOURS
	$CALL	DECNUM		;GET A DECIMAL NUMBER
	JUMPF	E$$ITF			;INVALID DATE AND TIME FUNCTION
	JUMPL	S1,E$$ITF		;INVALID DATE AND TIME
	MOVEM	S1,DAYNUM		;SAVE THE NUMBER
	MOVEM	S1,SECOND		;SAVE AS SECONDS
	MOVE	S2,LSTCHR		;GET LAST CHARACTER
	CAIN	S2,"D"			;WAS IT A D(DAYS)
	  PJRST E$$RDP			;REQUIRES RELATIVE DATE CHECK
	CAIE	S2,":"			;WAS IT A COLON
	  PJRST	FINTIM			;FINISH OFF THE TIME
	$CALL	DECNUM		;GET THE NEXT FIELD
	JUMPF	E$$ITF			;INVALID DATE AND TIME FUNCTION
	JUMPL	S1,E$$ITF		;INVALID DATE AND TIME
	EXCH	S1,SECOND		;GET THE SECONDS AS MINUTES
	MOVEM	S1,MINUTE		;SAVE THE MINUTES
	MOVE	S1,LSTCHR		;GET THE LAST CHARACTER
	CAIE	S1,":"			;WAS IT A COLON
	  PJRST	FINTIM			;FINISH OFF THE TIME
	$CALL	DECNUM		;GET A DECIMAL NUMBER
	JUMPF	E$$ITF			;INVALID DATE AND TIME FUNCTION
	JUMPL	S1,E$$ITF		;INVALID DATE AND TIME
	EXCH	S1,SECOND		;SAVE AS SECONDS
	EXCH	S1,MINUTE		;SAVE AS MINUTES
	MOVEM	S1,HOURS		;SAVE AS HOURS

FINTIM:	MOVE	S1,SECOND		;GET THE SECONDS
	CAIL	S1,^D60			;LESS THAN 60
	  PJRST	E$$ITF			;INVALID DATE AND TIME
	MOVEM	S1,VAL2			;SAVE THE SECONDS
	MOVE	S1,MINUTE		;GET THE MINUTES
	CAIL	S1,^D60			;CHECK LESS THAN 60
	  PJRST	E$$ITF			;INVALID DATE AND TIME
	MOVEM	S1,VAL3			;SAVE THE MINUTES
	MOVE	S1,HOURS		;GET THE HOURS
	CAIL	S1,^D24			;LESS THAN 24
	  PJRST	E$$ITF			;INVALID DATE AND TIME
	MOVEM	S1,VAL4			;SAVE THE HOURS
	IMULI	S1,^D60			;CONVERT TO MINUTES
	ADD	S1,VAL3			;ADD IN THE MINUTES
	IMULI	S1,^D60			;CONVERT TO SECONDS
	ADD	S1,VAL2			;ADD IN THE SECONDS
	SETZM	T1			;CLEAR OTHER HALF
	MOVE	S2,S1			;GET THE VALUE
	ASHC	S2,-^D17		;MULTIPLY BY 2**18
	DIVI	S2,^D24*^D3600		;DIVIDE BY SECONDS PER DAY
					;GET FRACTION OF A DAY IN RH
	$RETT				;RETURN TRUE
	SUBTTL	PLSRTN	--	PROCESS DATE WITH "+"

	SUBTTL	MINRTN	--	PROCESS DATE WITH "-"

	SUBTTL	DAYRTN	--	PROCESS DAY "D"

PLSRTN:	AOS	FLFUTD			;INDICATE IN THE FUTURE
	SKIPA				;GET TIME
MINRTN:	SOS	FLFUTD			;INDICATE IN THE PAST
MINI.1:	$CALL	TIMPAR		;PARSE THE TIME
	JUMPT	RELDAY			;O.K. COMPUTE RELATIVE DAY
	CAIN	S1,E..RDP		;CHECK FOR RELATIVE DATE ERROR
	JRST	DAYRTN			;YES CHECK OUT DATE
	$RETF				;NO..PASS ERROR BACK
RELDAY:	SKIPGE	FLFUTD			;CHECK THE TIME
	MOVN	S2,S2			;PAST.. COMPLEMENT THE TIME
	ADD	S2,NOW			;GET THE VALUE
	MOVE	S1,S2			;GET THE TIME
	PJRST	DATEXT			;EXIT WITH DATE


DAYRTN:	SETZM	LSTERR			;CLEAR LAST ERROR
	HRLZ	S2,DAYNUM		;GET THE NUMBER
	SOSG	TIMCNT			;ANY CHARACTERS LEFT?
	  PJRST	RELDAY			;NO..COMPUTE THE DAY
	$CALL	GETCHR		;GET A CHARACTER
	JUMPF	E$$IDT			;INVALID DATE TIME
	CAIE	S1,":"			;BETTER BE A COLON
	  PJRST E$$IDT			;NO..BAD DATE/TIME
	HRLZ	S2,DAYNUM		;GET THE NUMBER
	SKIPGE	FLFUTD			;CHECK THE TIME
	MOVN	S2,S2			;PAST.. COMPLEMENT THE TIME
	ADDM	S2,NOW			;GET THE VALUE
	PJRST	MINI.1			;YES.. NOW GET DATE
	SUBTTL	CMPDAT	--	COMPUTE THE DATE FROM VALUES


	;This routine will default fields with the current values of time
	;for those fields that were not input

;HERE WITH VAL2-9 CONTAINING PARSE OR -1 IF TO BE FILLED IN
;	STRATEGY IS TO FILL-IN HOLES LESS SIGNIFICANT THAN
;	MOST SIGN. FIELD WITH 0; AND TO FILL IN MORE SIGNIFICANT
;	HOLES WITH CURRENT VALUE.  THEN IF WRONG DIRECTION FROM
;	NOW, ADD/SUB ONE TO FIELD JUST ABOVE MOST SIGNIFICANT DIFFERENT
;	(FIELD CARRY NOT NEEDED SINCE IT WILL HAPPEN IMPLICITLY).

CMPDAT:	MOVE	S1,NOW		;GET CURRENT DATE/TIME
	$CALL	CNTDT		;CONVERT TO EASY FORMAT
				;RETURN S1 TIME IN SECONDS 
				;	S2 TIME IN SYSTEM FORMAT
	MOVEM	S1,SECONDS	;SAVE THE VALUE OF SECONDS
	ADD	S2,[^D1964*^D12*^D31]  ;MAKE REAL
	MOVEI	T2,8		;TRY 8 FIELDS			
CMPD.1:	MOVE	S1,S2		;POSITION REMAINDER
	IDIV	S1,ADJTBL-1(T2)	;GET THE ADJUSTMENT
	SKIPL	VAL1(T2)	;SEE IF DEFAULT			
	JRST	[TLNN T1,-1	;NO--FLAG TO ZERO DEFAULTS	
		 HRL  T1,T2	; SAVING INDEX OF LAST DEFAULT	
		 JRST CMPD.2]	;AND CONTINUE LOOP
	SETZM	VAL1(T2)	;DEFAULT TO ZERO		
	TLNN	T1,-1		;SEE IF NEED CURRENT		
	MOVEM	S1,VAL1(T2)	;YES--SET THAT INSTEAD		
CMPD.2:	CAME	S1,VAL1(T2)	;SEE IF SAME AS CURRENT		
	JRST	CMPD.3		;NO--REMEMBER FOR LATER
	CAIN	T2,4		;SEE IF TIME FOR TIME		
	HRRZ	S2,T1		;YES--GET IT
	SOJG	T2,CMPD.1	;LOOP UNTIL ALL DONE		

;HERE WHEN FILLED IN CURRENT FOR SIGNIFICANT DEFAULTS

CMPD.3:	SKIPGE	VAL1(T2)	;SEE IF DEFAULT			
	SETZM	VAL1(T2)	;CLEAR DEFAULT			
	SOJG	T2,CMPD.3	;LOOP UNTIL DONE		
	HLRZ	P1,T1		;RECOVER LAST SIGN. DEFAULT-1	
	JUMPE	P1,CMPD.4	;DONE IF NONE			
	$CALL	MAKDAT	;MAKE CURRENT DATE, TIME
	MOVE	T2,FLFUTD	;GET DEFAULT DIRECTION
	XCT	[CAMGE	S1,NOW
		 JFCL
		 CAMLE	S1,NOW]+1(T2)  ;SEE IF OK
	JRST	CMPD.4		;YES--GO RETURN
	SKIPG	FLFUTD		;NO--SEE WHICH DIRECTION
	SOSA	VAL2(P1)		;PAST
	AOS	VAL2(P1)		;FUTURE
CMPD.4:	$CALL	MAKDAT	;REMAKE ANSWER
	MOVE	P1,T1		;MOVE TO ANSWER
	PJRST	DATEXT		;DATE EXIT AND RETURN
	SUBTTL	DATEXT	--	DATE EXIT ROUTINE

	;THIS ROUTINE WILL CHECK DATE AND RETURN

	RADIX	10

DATEXT:	TRC	S1,-1			;COMPLEMENT THE LEFT SIDE
	TRCN	S1,-1			;CHECK IF -1
	AOS	S1			;BUMP S1
	CAML	S1,[<1964-1859>*365+<1964-1859>/4+<31-18>+31,,0] ;CHECK RANGE
	$RETT				;RETURN TRUE

	RADIX	8

	PJRST	E$$DOR			;DATE AND TIME OUT OF RANGE

	SUBTTL	MAKDAT	--	ROUTINE TO MAKE A DATE AND TIME

	;THIS ROUTINE WILL TAKE THE VALUES IN VAL1-VAL9 AND
	;GENERATE A UDT

MAKDAT:	MOVE	S1,VAL4		;GET HOURS
	IMULI	S1,^D60		;MAKE INTO MINS
	ADD	S1,VAL3		;ADD MINS
	IMULI	S1,^D60		;MAKE INTO SECS
	ADD	S1,VAL2		;ADD SECS
	IMULI	S1,^D1000	;MAKE INTO MILLISECS
	MOVE	S2,VAL9		;GET CENTURIES
	IMULI	S2,^D10		;MAKE INTO DECADES
	ADD	S2,VAL8		;ADD DECADES
	IMULI	S2,^D10		;MAKE INTO YEARS
	ADD	S2,VAL7		;ADD YEARS
	IMULI	S2,^D12		;MAKE INTO MONTHS
	ADD	S2,VAL6		;ADD MONTHS
	IMULI	S2,^D31		;MAKE INTO DAYS
	ADD	S2,VAL5		;ADD DAYS
	SUB	S2,[^D1964*^D12*^D31]  ;REDUCE TO SYSTEM RANGE
	DMOVE	T1,S1		;SETUP THE ARGUMENTS
	PJRST	CNVDT		;CONVERT TO INTERNAL FORM AND RETURN


	;ADJUSTMENT FACTORS FOR EACH TIME ELEMENT

ADJTBL:	EXP	1	
	EXP   ^D60
	EXP    ^D60*^D60
	EXP    1
	EXP    ^D31
	EXP    ^D31*^D12
	EXP    ^D31*^D12*^D10
	EXP    ^D31*^D12*^D10*^D10
	SUBTTL	DATPAR	--	PARSE A DATE/DAY FIELD

	;This routine will parse a date and save the values of the
	;fields that are found
	;
	;CALL	S1/	NUMBER

DATPAR:	MOVE	S1,FNARG		;GET THE ARGUMENT FLAGS
	TXNN	S1,CM%IDA		;DATE WANTED?..
	  PJRST	E$$IDT			;INVALID DATE FUNCTION
	MOVE	S2,LSTCHR		;GET THE LAST CHARACTER
	CAIN	S2,"-"			;SEPERATOR?
	  PJRST	ALTDAT			;YES.. TRY ALTERNATE DATE FORM
	$CALL	DECBPT		;DECREMENT THE BYTE POINTER
	$CALL	GETSTG		;GET A STRING
	SKIPT				;O.K. CONTINUE ON
	PJRST	E$$DTM			;VALUE MISSING IN DATE AND TIME
	MOVE	P1,S1			;SAVE THE STRING POINTER
	MOVEM	S1,STRPTR		;SAVE THE STRING POINTER
	MOVEI	S1,DAYTBL		;GET THE DAYS TABLE
	MOVE	S2,P1			;GET THE POINTER
	$CALL	S%TBLK		;CHECK THE TABLE
	TXNE	S2,TL%NOM!TL%AMB 	;IS IT AMBIGUOUS OR NO MATCH
	  JRST	datp.5			;TRY MONTHS OR MNEMONICS
	HRRZ	P1,(S1)			;GET THE VALUE
	HLRZ	S2,NOW			;GET DAYS
	IDIVI	S2,7			;GET DAY OF WEEK
	SUB	P1,T1			;GET FUTURE DAYS FROM NOW
	SKIPGE	P1			;IF NEGATIVE,
	ADDI	P1,7			;  MAKE LATER THIS WEEK
	HLLZ	S1,NOW			;CLEAR CURRENT
	SKIPL	FLFUTD			;SEE IF FUTURE
	TROA	S1,-1			;YES--SET MIDNIGHT MINUS EPSILON
	SUBI	P1,7			;NO--MAKE PAST
	HRLZ	P1,P1			;POSITION TO LEFT HALF
	ADD	P1,S1			;MODIFY CURRENT DATE/TIME
DATP.1:	MOVEM	P1,TIMSAV		;SAVE THE TIME
	SKIPG	TIMCNT			;ANY MORE CHARACTERS
	  JRST [ MOVE	S1,TIMSAV	;GET THE SAVED TIME
		JRST DATP.3]		;FINISH OFF THE TIME
	MOVE	S1,LSTCHR		;CHECK THE LAST CHARACTER
	CAIE	S1,":"			;WAS IT A :
	   JRST	E$$IDT			;GENERATE AN ERROR
DATP.2:	$CALL	TIMPAR		;PARSE THE TIME FIELD
	SKIPT				;SKIP IF TRUE
	  PJRST	E$$ITF			;INVALID TIME FIELD
	HLL	S1,TIMSAV			;  TO ANSWER
	HRR	S1,S2			;PLACE THE PORTION OF DAY IN RH
DATP.3:	SKIPG	FLFUTR			;SKIP IF FUTURE
	JRST	DATP.4			;ADJUST PAST RESULT
	CAMGE	S1,NOW			;IF NOT FUTURE, MUST HAVE
					;WANTED A WEEK FROM TODAY,
					;BUT EARLIER IN THE DAY.
	ADD	S1,[7,,0]		;MAKE TIME NEXT WEEK
	JRST	DATEXT			;CHECK AND RETURN
DATP.4:	MOVE	S2,S1			;SIMILAR TEST FOR PAST
	ADD	S2,[7,,0]		;ADD A WEEK TO PAST TIME
	CAMG	S2,NOW			;WAS TIME OVER A WEEK AGO?
	MOVE	S1,S2			;YES, USE NEW ONE
	JRST	DATEXT			;CHECK ANSWER AND RETURN
DATP.5:	$CALL	MONPAR		;TRY TO PARSE A MONTH
	JUMPF	MNMPAR			;TRY A MNEMONIC
	MOVE	S1,LSTCHR		;GET THE LAST CHARACTER
	CAIE	S1,"-"			;MUST BE DAY NEXT
	  PJRST E$$MDS			;MISSING DAY IN DATE /TIME
	$CALL	DECNUM		;GET DECIMAL NUMBER
	JUMPLE	S1,E$$NND		;NEGATIVE NUMBER
	CAILE	S1,^D31			;VERIFY IN RANGE
	JRST	E$$DFL			;ERROR IF TOO LARGE
	MOVEM	S1,VAL5			;SAVE AWAY
	 PJRST	YEARPR			;PARSE THE YEAR
	SUBTTL	ALTDAT	--	PARSE ALTERNATE DATE FORM

	;This routine will check dates in the form DD-MMM-YY
	;					    MM-DD-YY

ALTDAT:	CAILE	S1,^D31			;IS IT A VALID DAY?
	  PJRST	E$$DFL			;NO..GIVE ERROR
	SKIPN	P1			;CHECK IF ZERO?
	PJRST E$$DFZ			;FIELD ZERO IN DATE/TIME
	MOVEM	S1,VAL5			;SAVE VALUE
	$CALL	GETCHR		;SKIP OVER MINUS
	JUMPF	E$$IDT			;INVALID DATE AND TIME
	CAIL	S1,"0"			;SEE IF DIGIT NEXT
	CAILE	S1,"9"			; ..
	  JRST	ALTD.1			;SETUP FOR MONTH
	$CALL	DECNUM		;YES-- MUST BE MM-DD FORMAT
	JUMPLE	S1,E$$NND		;BAD IF LE 0
	CAILE	S1,^D31			;VERIFY LE 31
	JRST	E$$DFL			;BAD
	EXCH	S1,VAL5			;SWITCH VALUES
	CAILE	S1,^D12			;VERIFY MONTH OK
	JRST	E$$DFL			;BAD
	MOVEM	S1,VAL6			;SAVE THE MONTH
	PJRST	YEARPR			;NOW PARSE THE YEAR
ALTD.1:	$CALL	DECBPT		;BACKUP POINTER
	$CALL	GETSTG		;GET THE STRING
	JUMPF	E$$IDT			;INVALID DATE AND TIME
	MOVE	P1,S1			;SAVE THE POINTER
	$CALL	MONPAR		;CHECK FOR MONTH
	JUMPF	.POPJ			;ERROR..RETURN
	PJRST	YEARPR			;PARSE THE YEAR
	SUBTTL	MONPAR	--	ROUTINE TO CHECK FOR A MONTH

MONPAR:	MOVE	S1,FNARG		;GET THE ARGUMENT FLAGS
	TXNN	S1,CM%IDA		;DATE WANTED?..
	  PJRST	E$$IDT			;INVALID DATE FUNCTION
	MOVEI	S1,MONTBL		;GET THE DAYS TABLE
	MOVE	S2,P1			;GET THE POINTER
	$CALL	S%TBLK		;CHECK THE TABLE
	TXNE	S2,TL%NOM!TL%AMB 	;IS IT AMBIGUOUS OR NO MATCH
	  $RETF				;RETURN FALSE
	HRRZ	P1,(S1)			;GET MONTH INDEX
	MOVEM	P1,VAL6			;YES--STORE MONTH
	$RETT				;RETURN TRUE
	SUBTTL	YEARPR	--	PARSE THE YEAR

	;THIS ROUTINE WILL PARSE A YEAR
YEARPR:	MOVE	S1,LSTCHR		;GET THE LAST CHARACTER
	CAIE	S1,"-"			;SEE IF YEAR NEXT
	JRST	YEAR.3			;NO--GO HANDLE TIME
	;HERE WHEN YEAR NEXT AS ONE, TWO, OR FOUR DIGITS
	SETZB	T3,T4			;CLEAR DIGIT AND RESULT COUNTERS
YEAR.1:	$CALL	GETCHR		;GET NEXT DIGIT
	CAIL	S1,"0"			;SEE IF NUMERIC
	CAILE	S1,"9"			; ..
	JRST	YEAR.2			;NO--MUST BE DONE
	IMULI	T3,^D10			;ADVANCE RESULT
	ADDI	T3,-"0"(S1)		;INCLUDE THIS DIGIT
	AOJA	T4,YEAR.1		;LOOP FOR MORE, COUNTING DIGIT
YEAR.2:	JUMPE	T4,E$$ILR		;ERROR IF NO DIGITS
	CAIE	T4,3			;ERROR IF 3 DIGITS
	CAILE	T4,4			;OK IF 1,2, OR 4
	JRST	E$$ILR			;ERROR IF GT 4 DIGITS
	MOVE	S2,T3			;GET RESULT
	IDIVI	S2,^D100		;SEP. CENTURY
	IDIVI	T1,^D10			;SEP. DECADE
	CAIG	T4,2			;IF ONE OR TWO DIGITS,
	SETOM	S2			;  FLAG NO CENTURY KNOWN
	CAIN	T4,1			;IF ONE DIGIT,
	SETOM	T1			;  FLAG NO DECADE KNOWN
	MOVEM	T2,VAL7			;SAVE UNITS
	MOVEM	T1,VAL8			;SAVE DECADE
	MOVEM	S2,VAL9			;SAVE CENTURY
	;HERE WITH VAL5-9 CONTAINING DAY, MONTH, YEAR, DECADE, CENTURY
YEAR.3:	SOS	VAL5			;MAKE DAYS 0-30
	SOS	VAL6			;MAKE MONTHS 0-11
	SKIPG	TIMCNT			;ANY MORE CHARACTERS
	  JRST	YEAR.5			;NO..FINISH TIME NOW
	MOVE	S1,LSTCHR		;CHECK THE LAST CHARACTER
	CAIE	S1,":"			;WAS IT A :
	   JRST	E$$IDT			;GENERATE AN ERROR
YEAR.4:	$CALL	TIMPAR		;GET THE TIME 
	SKIPT				;SKIP IF TRUE
	  PJRST	E$$ITF			;INVALID TIME FIELD
	 PJRST	CMPDAT			;COMPUTE THE DATE AND RETURN
	;HERE IF FUTURE WITHOUT TIME
YEAR.5:	SKIPG	FLFUTD			;FUTURE TIME?
	  PJRST CMPDAT			;NO.. JUST GET DATE NOW
	MOVEI	S1,^D59			;SET TO
	MOVEM	S1,VAL2			; 23:59:59
	MOVEM	S1,VAL3			; ..
	MOVEI	S1,^D23			; ..
	MOVEM	S1,VAL4			; ..
	PJRST	CMPDAT			;COMPUTE THE DATE
	SUBTTL	CNVDT	--	CONVERT DATE TO UDT


	;THIS ROUTINE WILL MAKE A UDT OUT OF AN ARBITRAY DATE
	;
	;CALL	S1/	TIME IN SECONDS
	;	S2/	DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
	;
	;RETURN	S1/	UDT
	;
	;NOTE:	LEFT HALF DIVIDED BY 7 GIVES THE DAY OF THE WEEK

	RADIX  10
	;UNDER RADIX 10 **** NOTE WELL ****


CNVDT::	$CALL	.SAVET	;PRESERVE T3
	PUSH	P,S1		;SAVE TIME FOR LATER
	IDIVI	S2,12*31	;S2=YEARS-1964
	CAILE	S2,2217-1964	;SEE IF BEYOND 2217
	JRST	GETNW2		;YES--RETURN -1
	IDIVI	T1,31		;T1=MONTHS-JAN, T2=DAYS-1
	ADD	T2,MONTAB(T1)	;T2=DAYS-JAN 1
	MOVEI	T3,0		;LEAP YEAR ADDITIVE IF JAN, FEB
	CAIL	T1,2		;CHECK MONTH
	MOVEI	T3,1		;ADDITIVE IF MAR-DEC
	MOVE	S1,S2		;SAVE YEARS FOR REUSE
	ADDI	S2,3		;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
	IDIVI	S2,4		;HANDLE REGULAR LEAP YEARS
	CAIE	T1,3		;SEE IF THIS IS LEAP YEAR
	MOVEI	T3,0		;NO--WIPE OUT ADDITIVE
	ADDI	T2,<1964-1859>*365+<1964-1859>/4+<31-18>+31(S2)
				;T2=DAYS BEFORE JAN 1,1964 +SINCE JAN 1
				; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
	MOVE	S2,S1		;RESTORE YEARS SINCE 1964
	IMULI	S2,365		;DAYS SINCE 1964
	ADD	T2,S2		;T2=DAYS EXCEPT FOR 100 YR. FUDGE
	HRREI	S2,64-100-1(S1)	;S2=YEARS SINCE 2001
	JUMPLE	S2,GETNW1	;ALL DONE IF NOT YET 2001
	IDIVI	S2,100		;GET CENTURIES SINCE 2001
	SUB	T2,S2		;ALLOW FOR LOST LEAP YEARS
	CAIE	T1,99		;SEE IF THIS IS A LOST L.Y.
GETNW1:	ADD	T2,T3		;ALLOW FOR LEAP YEAR THIS YEAR
	CAILE	T2,^O377777	;SEE IF TOO BIG
GETNW2:	SETOM	T2		;YES--SET -1

	POP	P,S1		;GET MILLISEC TIME
	MOVEI	S2,0		;CLEAR OTHER HALF
	ASHC	S1,-17		;POSITION
	DIV	S1,[24*60*60*1000]  ;CONVERT TO 1/2**18 DAYS
	CAMLE	S2,[^D24*^D60*^D60*^D1000/2]	; OVER 1/2 TO NEXT?
	ADDI	S1,1		;YES, SHOULD ACTUALLY ROUND UP
	HRL	S1,T2		;INCLUDE DATE
GETNWX:	POPJ	P,		;RETURN
	RADIX	8
SUBTTL CNTDT  - Convert UDT to TOPS-10 DATE UUO Time and Seconds

; This routine gratefully stolen from SCAN
;
;Call:	MOVE	S1,DATE/TIME
;	PUSHJ	P,.CNTDT
;	Return with T1=Seconds since Midnight, T2=Date in system format (.LT. 0 if arg .LT. 0)
;Based on ideas by John Barnaby, David Rosenberg, Peter Conklin
;Uses T1-4

CNTDT::	PUSH	P,S1			;SAVE TIME FOR LATER
	JUMPL	S1,CNTDT6		;DEFEND AGAINST JUNK INPUT
	HLRZ	S1,S1			;GET DATE PORTION (DAYS SINCE 1858)

	RADIX	10			;**** NOTE WELL ****

	ADDI	S1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
					;S1=DAYS SINCE JAN 1, 1501	
	IDIVI	S1,400*365+400/4-400/100+400/400
					;SPLIT INTO QUADRACENTURY	
	LSH	S2,2			;CONVERT TO NUMBER OF QUARTER DAYS  
	IDIVI	S2,<100*365+100/4-100/100>*4+400/400
					;SPLIT INTO CENTURY		
	IORI	T1,3			;DISCARD FRACTIONS OF DAY	
	IDIVI	T1,4*365+1		;SEPARATE INTO YEARS		
	LSH	T2,-2			;T2=NO DAYS THIS YEAR		
	LSH	S1,2			;S1=4*NO QUADRACENTURIES	
	ADD	S1,S2			;S1=NO CENTURIES
	IMULI	S1,100			;S1=100*NO CENTURIES		
	ADDI	S1,1501(T1)		;S1 HAS YEAR, S2 HAS DAY IN YEAR

	MOVE	S2,S1			;COPY YEAR TO SEE IF LEAP YEAR
	TRNE	S2,3			;IS THE YEAR A MULT OF 4?
	JRST	CNTDT0			;NO--JUST INDICATE NOT A LEAP YEAR 
	IDIVI	S2,100			;SEE IF YEAR IS MULT OF 100
	SKIPN	T1			;IF NOT, THEN LEAP
	TRNN	S2,3			;IS YEAR MULT OF 400?
	TDZA	T1,T1			;YES--LEAP YEAR AFTER ALL
CNTDT0:	MOVEI	T1,1			;SET LEAP YEAR FLAG
					;T1 IS 0 IF LEAP YEAR
		;UNDER RADIX 10 **** NOTE WELL ****

CNTDT1:	SUBI	S1,1964			;SET TO SYSTEM ORIGIN
	IMULI	S1,31*12		;CHANGE TO SYSTEM PSEUDO DAYS
	JUMPN	T1,CNTDT2		;IF NOT LEAP YEAR, PROCEED
	CAIGE	T2,31+29		;LEAP YEAR--SEE IF BEYOND FEB 29
	JRST	CNTDT5			;NO--JUST INCLUDE IN ANSWER
	SOS	T2			;YES--BACK OFF ONE DAY
CNTDT2:	MOVSI	S2,-11			;LOOP FOR 11 MONTHS

CNTDT3:	CAMGE	T2,MONTAB+1(S2)		;SEE IF BEYOND THIS MONTH
	JRST	CNTDT4			;YES--GO FINISH UP
	ADDI	S1,31			;NO--COUNT SYSTEM MONTH
	AOBJN	S2,CNTDT3		;LOOP THROUGH NOVEMBER

CNTDT4:	SUB	T2,MONTAB(S2)		;GET DAYS IN THIS MONTH
CNTDT5:	ADD	S1,T2			;INCLUDE IN FINAL RESULT

CNTDT6:	SKIPGE	S1			;TEST FOR JUNK
	SETZ	S1,0
	EXCH	S1,(P)			;SAVE ANSWER, GET TIME
	TLZ	S1,-1			;CLEAR DATE
	MULI	S1,<EXP 24*60*60>	;CONVERT TO SECONDS/DAY
	DIV	S1,[1B17]		;SHIFT BINARY POINT
	CAIL	S2,<EXP 1B18>		;ROUND UP?
	ADDI	S1,1			;YES, DO SO
	POP	P,S2			;RECOVER DATE
	$RETT				;RETURN

MONTAB:	EXP 0,31,59,90,120,151,181,212,243,273,304,334,365

	RADIX	8			;BACK TO USUAL RADIX
	SUBTTL	MNMPAR	--	PARSE MNEMONICS

	;THIS ROUTINE WILL CHECK FOR MNEMONICS

MNMPAR:	PJRST	E$$IDT			;INVALID DATE AND TIME


	COMMENT \

	HRRZ	S2,S1			;GET COPY			
	CAIN	S2,SPLGTM		;SEE IF "LOGIN"			
	SKIPG	P1,LOGTIM		;AND WE KNOW IT			
	SKIPA				;NO--PROCEED			
	JRST	DATEXT			;YES--GO GIVE ANSWER		
	CAIN	S2,SPNOON		;SEE IF "NOON"			
	JRST	[HLLZ P1,NOW		;YES--GET TODAY			
		 HRRI P1,1B18		;SET TO NOON			
		 JRST DATP.1]		;GO FINISH UP			
	CAIN	S2,SPMIDN		;SEE IF "MIDNIGHT"		
	JRST	[HLLZ P1,NOW		;GET TODAY			
		 JRST DATIMO]		;GO SET TO MIDNIGHT		
	SUBI	S2,SPCDAY		;SUBTRACT OFFSET TO SPECIAL DAYS  
	CAILE	S2,2			;SEE IF ONE OF THREE		
	JRST	E.MDS			;NO--UNSUPPORTED		
	HLRZ	P1,NOW			;YES--GET TODAY			
	ADDI	P1,-1(S2)		;OFFSET IT			
	HRLZS	P1			;POSITION FOR ANSWER		
DATIMO:	SKIPL	FLFUTD			;SEE IF FUTURE			
	TRO	P1,-1			;YES--SET TO MIDNIGHT MINUS EPSILON  
	JRST	DATP.1			;AND GO FINISH UP		

	;HERE IF UNSUPPORTED MNEMONIC

E.MDS:	MOVE	P1,(S1)			;GET NAME OF SWITCH
	  PJRST E$$MDS			;MNEMONIC DATE/TIME NOT IMPLEMENTED


	DEFINE	XX($1),<
	EXP	<SIXBIT	/$1/>>

SPCDAY:	XX	YESTERDAY
	XX	TODAY
	XX	TOMORROW

SPLGTM:	XX	LOGIN
SPNOON:	XX	NOON
SPMIDN:	XX	MIDNIGHT

SPDATM:	XX	LUNCH
	XX	DINNER
LSPDTM==.-SPCDAY

	\;END OF COMMENT
	SUBTTL	GETCHR	--	GET A CHARACTER FROM TIME FIELD

	;This Routine will return a character from the time field 
	;
	;RETURN	TRUE:	S1/	CHARACTER
	;
	;RETURN FALSE:	NO MORE DATA

GETCHR:	SOSGE	TIMCNT			;ANY CHARACTERS LEFT?
	  PJRST	GETC.1			;ERROR..RETURN
	ILDB	S1,TIMPTR		;GET A CHARACTER
	CAIL	S1,"a"			;LOWER CASE A
	CAILE	S1,"z"			;LOWER CASE Z
	SKIPA				;MUST BE O.K.
	SUBI	S1,40			;MAKE UPPER CASE
	MOVEM	S1,LSTCHR		;SAVE LAST CHARACTER
	$RETT				;RETURN TRUE
GETC.1:	SETZM	LSTCHR			;CLEAR LAST CHARACTER
	$RETF				;RETURN FALSE


	SUBTTL	DECNUM	--	GET A DECIMAL NUMBER

	;This routine will return a decimal number from the time field
	;
	;RETURN	TRUE	S1/	DECIMAL NUMBER

DECNUM:	SKIPG	TIMCNT			;ANY CHARACTERS LEFT
	  $RETF				;NONE.. RETURN FALSE
	MOVE	S1,TIMPTR		;GET THE POINTER
	MOVEI	S2,^D10			;GET THE RADIX (DECIMAL)
	$CALL	NUMIN		;GET THE NUMBER
	JUMPF	.POPJ			;ERROR...RETURN
DECN.1:	IBP	TIMPTR			;BUMP THE TIME POINTER
	CAMN	S1,TIMPTR		;ARE WE AT THE RIGHT PLACE
	  JRST	DECN.2			;YES.. FINISH UP
	SOS	TIMCNT			;DECREMENT TIME COUNT
	JRST	DECN.1			;KEEP GOING
DECN.2:	MOVE	S1,S2			;PLACE NUMBER IN S1
	LDB	S2,TIMPTR		;GET LAST CHARACTER
	CAIL	S2,"a"			;LOWER CASE A
	CAILE	S2,"z"			;LOWER CASE Z
	SKIPA				;MUST BE O.K.
	SUBI	S2,40			;MAKE UPPER CASE
	MOVEM	S2,LSTCHR		;SAVE LAST CHARACTER
	$RETT				;RETURN TRUE

	SUBTTL	DECBPT	--	DECREMENT THE BYTE POINTER

	;THIS ROUTINE WILL DECREMENT THE TIME BYTE POINTER


DECBPT:	MOVE	S1,TIMPTR		;GET CURRENT POINTER
	$CALL	DBP			;DECREMENT THE BYTE POINTER
	MOVEM	S1,TIMPTR		;SAVE THE POINTER
	AOS	TIMCNT			;BUMP THE CHARACTER COUNT
	$RETT				;RETURN
	SUBTTL	GETSTG	--	GET A STRING TO WORK FROM


	;THIS ROUTINE WILL GET A STRING FROM THE INPUT BUFFER AND BREAK ON 
	;A SEPERATOR
	;	RETURN	S1/	POINTER TO THE STRING


GETSTG:	$CALL	.SAVE1		;SAVE AN AC
	SETZM	STRDAT			;CLEAR STRING DATA
	HRLI	P1,STRDAT		;ADDRESS OF FIRST ONE
	HRRI	P1,1+STRDAT		;GET THE SECONDE WORD
	BLT	P1,4+STRDAT		;CLEAR THE DATA
	HRLI	P1,(POINT 7)		;GET POINTER
	HRRI	P1,STRDAT		;AND ADDRESS
GETS.1:	$CALL	GETCHR		;GET A CHARACTER
	JUMPF	GETS.3			;NO MORE.. FINISH AND RETURN
	CAIE	S1,40			;IS IT A BLANK?
	CAIN	S1,"-"			;OR A SEPERATOR
	JRST	GETS.3			;YES..CHECK IF SEEN ANYTHING
	CAIN	S1,":"			;WAS IT A SEPERATOR?
	  JRST	GETS.3			;YES..CHECK IS SEEN ANYTHING 
	CAIL	S1,"A"+40		;LOWER CASE A
	CAILE	S1,"Z"+40		;OR GREATER THAN LC Z
	SKIPA				;IGNORE ADJUSTMENT
	SUBI	S1,40			;MAKE IT UPPER CASE
	CAIL	S1,"0"			;IS IT 0 NUMBER OR UPPER CASE
	CAILE	S1,"Z"			;CHECK CHARACTER
	JRST GETS.3			;SETUP THE RETURN
GETS.2:	IDPB	S1,P1			;SAVE THE CHARACTER
	JRST	GETS.1			;GET NEXT ONE
GETS.3:	SKIPN	STRDAT			;ANY DATA SETUP?
	$RETF				;NO..RETURN FALSE
	MOVE	S1,[POINT 7,STRDAT]	;GET POINTER TO DATA 
	$RETT				;RETURN TRUE
;LOCAL ROUTINE TO SETUP BYTE PTR TO TABLE STRING AND GET FLAGS
; T2/ ADDRESS OF STRING
;	$CALL	CHKTBS
; T1/ FLAGS
; T2/ BYTE POINTER TO STRING

CHKTBS:	HRLI	T2,(POINT 7)	;SETUP P AND S FIELDS
	SKIPE	T1,0(T2)	;CHECK FIRST WORD OF STRING
	TXNE	T1,177B6	;FIRST CHAR 0 AND WORD NOT ALL-0?
	TDZA	T1,T1		;NO, MAKE FLAGS ALL 0
	AOS	T2		;YES, HAVE FLAGS, ADJUST BYTE PTR
	POPJ	P,0

>  ;END TOPS10 CONDITIONAL
	SUBTTL	CMDOUT	--	CHARACTER OUTPUT FOR TERMINALS AND FILES

	;THIS ROUTINE WILL DUMP A CHARACTER TO THE TERMINAL OR A FILE
	;DEPENDING ON THE JFN IN THE TEXTI ARGUMENT BLOCK

TOPS10	<
CMDOUT:	HRRZ	S2,JFNWRD		;GET OUTPUT JFN
	CAXN	S2,.NULIO		;NULL?
	  $RETT				;JUST IGNORE IT
	CAXN	S2,.PRIOU		;PRIMARY OUTPUT TERMINAL?
	  PJRST	K%BOUT##			;OUTPUT IT

	SUBTTL	CMDSTO	--	STRING OUTPUT TO FILE AND TERMINAL

	;This routine will check the output JFN and pass the data to
	;the file, terminal or null

CMDSTO:	HRRZ	S2,JFNWRD		;GET OUTPUT JFN
	CAXN	S2,.NULIO		;NULL?
	  $RETT				;JUST RETURN
	CAXN	S2,.PRIOU		;PRIMARY OUTPUT?
	  PJRST	K%SOUT			;YES.. DUMP THE STRING
>;END TOPS10
SUBTTL S%SCMP  --  String Comparison Routine

;CALL IS:	 S1/ TEST STRING POINTER
;		 S2/ BASE STRING POINTER
;TRUE RETURN:	  S1/ COMPARE CODE:
;	1B0 (SC%LSS) - TEST STRING LESS THAN BASE STRING
;	1B1 (SC%SUB) - TEST STRING SUBSET OF BASE STRING
;	1B2 (SC%GTR) - TEST STRING GREATER THAN BASE STRING
;	N.O.T.A. MEANS EXACT MATCH
;		S2/ UPDATED BASE STRING POINTER, USEFUL IN CASE TEST STRING
;	WAS SUBSET

TOPS20 <
S%SCMP:	STCMP%				;DO THE JSYS
	$RETT				;AND RETURN
>  ;END TOPS20 CONDITIONAL

TOPS10 <
S%SCMP:	$CALL	.SAVET		;SAVE T REGS
	DMOVE	T1,S1			;COPY ARGUMENTS
	HLRZ	T3,T1
	CAIN	T3,-1
	HRLI	T1,(POINT 7)
	HLRZ	T3,T2
	CAIN	T3,-1
	HRLI	T2,(POINT 7)
	$CALL	USTCMP	;DO THE WORK
	DMOVE	S1,T1			;PUT THE ARGUMENTS BACK
	$RETT


;STILL IN TOPS10 CONDITIONAL
;STRING COMPARE ROUTINE - REFERENCES PREVIOUS CONTEXT.
; T1/ TEST STRING POINTER
; T2/ BASE STRING POINTER
;	$CALL	USTCMP
;RETURN AS FOR .STCMP

USTCMP::ILDB	T3,T1		;GET NEXT BYTE FROM EACH STRING
	CAIL	T3,"A"+40	;LC LETTER?
	JRST	[CAIG	T3,"Z"+40
		SUBI	T3,40		;YES, CONVERT TO UC
		JRST	.+1]
	ILDB	T4,T2
	CAIL	T4,"A"+40	;LC LETTER?
	JRST	[CAIG	T4,"Z"+40
		SUBI	T4,40		;YES, CONVERT TO UC
		JRST	.+1]
	CAME	T3,T4		;STILL EQUAL?
	JRST	STRC2		;NO, GO SEE WHY
	JUMPN	T3,USTCMP	;KEEP GOING IF NOT END OF STRING
	SETZ	T1,		;STRINGS ENDED TOGETHER, EXACT MATCH.
	POPJ	P,0		;RETURN 0

STRC2:	JUMPE	T3,[MOVX T1,SC%SUB 	;TEST STRING ENDED, IS A SUBSET
		ADD	T2,[7B5] 	;DECREMENT BASE POINTER ONE BYTE
		POPJ	P,0]
	CAMG	T3,T4		;STRINGS UNEQUAL
	SKIPA	T1,[SC%LSS]	;TEST STRING LESS
	MOVX	T1,SC%GTR	;TEST STRING GREATER
	POPJ	P,0
>  ;END TOPS10 CONDITIONAL
SUBTTL S%TBLK  --  Table lookup routine


;CALL IS:	S1/ ADDRESS OF TABLE HEADER WORD
;		S2/ STRING POINTER TO STRING TO BE FOUND
;
;TRUE RETURN:	 S1/ ADDRESS OF ENTRY WHICH MATCHED OR WHERE ENTRY WOULD BE
;		IF IT WERE IN TABLE
;		  S2/ RECOGNITION CODE:
;	1B0 (TL%NOM) - NO MATCH
;	1B1 (TL%AMB) - AMBIGUOUS
;	1B2 (TL%ABR) - UNIQUE ABBREVIATION
;	1B3 (TL%EXM) - EXACT MATCH

TOPS20 <
S%TBLK:	PUSH	P,T1			;SAVE T1
	TBLUK%				;DO THE JSYS
	POP	P,T1			;RESTORE T1
	$RETT				;AND RETURN
>   ;END TOPS20 CONDITIONAL

TOPS10 <
S%TBLK:	$CALL	.SAVET		;SAVE SOME REGISTERS
	DMOVE	T1,S1			;COPY INPUT ARGUMENTS
	$CALL	XTLOOK		;DO THE WORK
	DMOVE	S1,T1			;RE-COPY ARGUMENTS
	$RETT				;AND RETURN
;WORKER ROUTINE - MAY BE CALLED INTERNALLY.
; RETURNS +1 SUCCESS, ACS AS ABOVE

;INTERNAL AC USAGE:
; T1/ TEST STRING FROM CALL
; T2/ STRING FROM TABLE
; T3/ CLOBBERED BY USTCMP
; T4/ " "
; P1/ CURRENT TABLE INDEX
; P2/ ADDRESS OF TABLE INDEXED BY P1 - USED FOR INDIRECTION
; P3/ INDEX INCREMENT FOR LOG SEARCH
; P4/ SIZE OF TABLE

XTLOOK::	$CALL	.SAVE4	;PRESERVE ACS
	$SAVE	P5
	HLRZ	T3,T2		;CHECK STRING POINTER
	CAIE	T3,-1		;LH 0 OR -1?
	CAIN	T3,0
	HRLI	T2,(POINT 7)	;YES, FILL IN
	MOVEM	T2,STRG
	MOVEI	P2,1(T1)	;CONSTRUCT ADDRESS OF FIRST ENTRY
	HRLI	P2,P1		;MAKE IT INDEXED BY P1
	HLRZ	P4,0(T1)	;GET PRESENT SIZE
	MOVE	P3,P4		;INITIAL INCREMENT IS SIZE
	MOVE	P1,P4		;SET INITIAL INDEX TO SIZE/2
	ASH	P1,-1
	JUMPE	P4,TABLKX	;IF TABLE EMPTY THEN NO MATCH
TABLK0:	HLRZ	T2,@P2		;GET STRING ADR FROM TABLE
	$CALL	CHKTBS	;CONSTRUCT POINTER
	MOVE	T1,STRG		;GET TEST STRING
	$CALL	USTCMP	;COMPARE
	JUMPN	T1,TABLK1	;JUMP IF NOT EXACTLY EQUAL
TABLKF:	HLRZ	T2,@P2		;GET STRING ADDRESS
	$CALL	CHKTBS	;GET FLAGS
	JXN	T1,CM%NOR,TABLKM ;MAKE IT AMBIG IF NOREC ENTRY
	MOVX	T2,TL%EXM	;EXACTLY EQUAL, RETURN CODE
	JRST	TABLKA

TABLKM:	SKIPA	T2,[TL%AMB]	;AMBIGUOUS RETURN
TABLKX:	MOVX	T2,TL%NOM	;NO MATCH RETURN
TABLKA:	MOVEI	T1,@P2		;RETURN ADR WHERE ENTRY IS OR SHOULD BE
	POPJ	P,
;STRING MAY BE UNEQUAL OR A SUBSET, SEE WHICH

TABLK1:	JXE	T1,SC%SUB,TABLKN ;UNEQUAL, GO SETUP NEXT PROBE
TABLK3:	MOVEM	T2,REMSTR	;SUBSTRING, SAVE REMAINDER
	JUMPE	P1,TABLK2	;JUMP IF THIS FIRST ENTRY IN TABLE
	MOVEI	T1,@P2		;CHECK NEXT HIGHER ENTRY IN TABLE
	HLRZ	T2,-1(T1)	;GET ITS STRING ADDRESS
	$CALL	CHKTBS	;BUILD BYTE PTR
	MOVE	T1,STRG		;GET TEST STRING
	$CALL	USTCMP	;TEST PREVIOUS ENTRY
	JUMPE	T1,[SOJA P1,TABLKF] ;EXACTLY EQUAL, DONE. FIX INDEX.
	JXN	T1,SC%GTR,TABLK2 ;IF LESS THEN HAVE FOUND HIGHEST SUBSTR
	SOJA	P1,TABLK3	;STILL A SUBSTR, CHECK HIGHER

;NOW POINT AT HIGHEST ENTRY WHICH IS A SUBSTR.  IF THERE IS AN EXACT
;MATCH, IT IS BEFORE ALL SUBSETS AND HAS ALREADY BEEN FOUND

TABLK2:	MOVEI	T1,@P2		;CHECK NEXT ENTRY FOR AMBIGUOUS
	CAIL	P1,-1(P4)	;NOW AT LAST ENTRY IN TABLE?
	JRST	TBLK2A		;YES, THIS ENTRY IS DISTINCT
	HLRZ	T2,1(T1)	;GET STRING ADR OF NEXT ENTRY
	$CALL	CHKTBS	;BUILD BYTE PTR
	MOVE	T1,STRG		;GET TEST STRING
	$CALL	USTCMP	;COMPARE NEXT LOWER ENTRY
	JUMPE	T1,[$STOP(BTF,Bad table format)] ;EXACT MATCH,TABLE IS BAD
	JXN	T1,SC%SUB,TABLKM ;NEXT ENTRY NOT DISTINCT, DO AMBIG RETURN
TBLK2A:	HLRZ T2,@P2		;CHECK FLAGS FOR THIS ENTRY
	$CALL	CHKTBS
	JXN	T1,CM%NOR,TABLKM ;FAIL IF NOREC BIT SET
	MOVX	T2,TL%ABR	;GIVE LEGAL ABBREVIATION RETURN
	MOVE	T3,REMSTR	;RETURN PTR TO REMAINDER OF STRING
	JRST	TABLKA

;HERE WHEN PROBE NOT EQUAL

TABLKN:	CAIG	P3,1		;INCREMENT NOW 1?
	JRST	[JXN	T1,SC%LSS,TABLKX ;YES, NO MATCH FOUND
		AOJA	P1,TABLKX] 	;IF STRING GREATER, BUMP ADR FOR INSERT
	AOS	P3		;NEXT INC = <INC+1>/2
	ASH	P3,-1
	TXNE	T1,SC%GTR	;IF LAST PROBE LOW, ADD INCREMENT
	ADD	P1,P3
	TXNE	T1,SC%LSS
	SUB	P1,P3		;LAST PROBE HIGH, SUBTRACT INCR
TBLKN1:	CAIL	P1,0(P4)	;AFTER END OF TABLE?
	JRST	[MOVX	T1,SC%LSS	;YES, FAKE PROBE TOO HIGH
		JRST	TABLKN]
	JUMPGE	P1,TABLK0	;IF STILL WITHIN TABLE RANGE, GO PROBE
	MOVX	T1,SC%GTR	;BEFORE START OF TABLE, FAKE LOW PROBE
	JRST	TABLKN
>  ;END TOPS10 CONDITIONAL
	SUBTTL	S%TBAD	--	Table Add Routine

;THIS ROUTINE IS DESIGNED TO ADD AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH:	S1/	ADDRESS OF TABLE HEADER
;		S2/	ADDRESS OF ENTRY TO BE ADDED
;
;
; RETURNS TRUE:	S1/	ADDRESS IN TABLE OF NEW ENTRY IN AC1
;
; RETURNS FALSE:	S1/	ERROR CODE
;
;POSSIBLE ERRORS:	ERTBF$ -- TABLE IS FULL
;			EREIT$	-- ENTRY ALREADY IN TABLE
;
;

TOPS20 <
S%TBAD:	TBADD%				;DO THE JSYS
	ERJMP	TBAD.1			;TRAB THE ERROR JUMP
	$RETT				;RETURN TRUE
TBAD.1:	MOVEI	S1,.FHSLF		;GET THE LAST ERROR
	GETER%				;GET THE LAST ERROR
	HRRZ	S2,S2			;GET JUST THE CODE
	SETZ	S1,			;CLEAR S1
	CAIN	S2,TADDX1		;WAS IT TABLE IS FULL
	MOVEI	S1,ERTBF$		;TABLE IS FULL
	CAIN	S2,TADDX2		;ENTRY ALREADY IN TABLE
	MOVEI	S1,EREIT$		;ENTRY ALREADY IN TABLE
	JUMPN	S1,.RETF		;NON-ZERO..RETURN FALSE
	$STOP(UTR,UNRECOGNIZED TABLE ADD RETURN CODE)
>;END TOPS20 CONDITIONAL


TOPS10 <
S%TBAD:	$CALL	.SAVET		;SAVE THE T REGS
	MOVEM	S1,TBADDR		;SAVE TABLE ADDRESS
	MOVEM	S2,ENTADR		;SAVE ENTRY ADDRESS
	HLRZ	S2,S2			;BUILD STRING POINTER FOR STRING
	HRLI	S2,(POINT 7,0)		;FINISH OFF POINTER
	$CALL	S%TBLK		;CHECK FOR ENTRY IN TABLE
	TXNE	S2,TL%EXM		;ENTRY IN TABLE
	$RETE(EIT)			;ENTRY ALREADY IN TABLE

		;S1 ADDRESS WHERE TO PLACE THE ENTRY

	MOVE	S2,TBADDR		;GET ADDRESS OF TABLE
	HLRZ	T2,0(S2)		;GET NUMBER OF ENTRIES IN USE
	AOS	T2			;BUMP THE COUNT
	HRRZ	T1,0(S2)		;GET THE TABLE SIZE
	CAMLE	T2,T1			;ROOM IN TABLE
	$RETE(TBF)			;TABLE IS FULL
	HRLM	T2,0(S2)		;UPDATE THE ENTRY COUNT
	ADD	T2,S2			;COMPUTE NEW END OF TABLE
TBAD.1:	CAML	S1,T2			;AT HOLE:
	JRST	[ MOVE	T1,ENTADR	;YES..INSERT THE ENTRY
		MOVEM	T1,0(S1)	;PLACE IN TABLE
		$RETT]			;RETURN TRUE
	MOVE	T1,-1(T2)		;MOVE TABLE TO CREATE HOLE
	MOVEM	T1,0(T2)		;PLACE IN NEW LOCATION
	SOJA	T2,TBAD.1		;CHECK NEXT ENTRY
>;END TOPS10 CONDITIONAL
	SUBTTL	S%TBDL	--	Table Delete Routine

;THIS ROUTINE IS DESIGNED TO DELETE AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH:	S1/	ADDRESS OF TABLE HEADER
;		S2/	ADDRESS OF ENTRY TO BE DELETED
;
;
; RETURNS TRUE:	S1/	ADDRESS IN TABLE OF NEW ENTRY IN AC1
;
; RETURNS FALSE:	S1/	ERROR CODE
;
;POSSIBLE ERRORS:	ERTBF$ -- TABLE IS FULL
;			ERITE$	-- INVALID TABLE ENTRY
;
;

TOPS20 <
S%TBDL:	TBDEL%				;DO THE JSYS
	ERJMP	TBDL.1			;TRAB THE ERROR JUMP
	$RETT				;RETURN TRUE
TBDL.1:	MOVEI	S1,.FHSLF		;GET THE LAST ERROR
	GETER%				;GET THE LAST ERROR
	HRRZ	S2,S1			;GET JUST THE CODE
	SETZ	S1,			;CLEAR S1
	CAIN	S2,TDELX1		;WAS IT TABLE IS FULL
	MOVX	S1,ERTBF$		;TABLE IS FULL
	CAIN	S2,TDELX2		;ENTRY ALREADY IN TABLE
	MOVX	S1,ERITE$		;ENTRY ALREADY IN TABLE
	JUMPN	S1,.RETF		;NON-ZERO..RETURN FALSE
	$STOP	(UTR,<unrecognized table return code>)
>;END TOPS20 CONDITIONAL



TOPS10 <
S%TBDL:	$CALL	.SAVET		;SAVE THE T REGS
	HLRZ	T2,0(S1)		;GET USED COUNT
	MOVE	T1,T2			;PLACE IN T1
	SOSGE	T1			;DECREMENT..SKIP IF NOT ZERO
	$RETE(TBF)			;FALSE RETURN..TABLE IS FULL
	ADD	T2,S1			;COMPUTE END OF TABLE
	CAILE	S2,(S1)			;ENTRY IN TABLE
	CAMLE	S2,T2			;MAKE SURE
	$RETE(ITE)			;INVALID TABLE ENTRY
	HRLM	T1,0(S1)		;SAVE COUNT
	JUMPE	T1,TBDL.1		;TABLE EMPTY
	HRLI	S2,1(S2)		;COMPACT TABLE
	BLT	S2,-1(T2)		;MOVE THE TABLE
TBDL.1:	SETZM	0(T2)			;CLEAR EMPTY WORD AT END
	$RETT				;RETURN TRUE
>;END TOPS10 CONDITIONAL

SCN%L:					;LABEL THE LITERAL POOL

PRGEND
TITLE	CPAFLO -- PARSES AND CONVERTS FLOATING PT NUMS
SEARCH	CPASYM

TOPS10 <				;FLOAT ROUTINE NEEDED ON 10 ONLY
PROLOG(CPAFLO)

;THE SYNTAX ANALYSIS FOR THE SINGLE AND DOUBLE PRECISION INPUT
;IS STATE TABLE DRIVEN. EACH NEW INPUT CHARACTER IS CONVERTED TO
;A CHARACTER TYPE AND COMBINED WITH THE OLD "STATE". THIS RESULT
;IS THEN LOOKED UP IN THE TABLE "NXTSTA" TO GET THE NEW STATE AND
;AN INDEX INTO THE "XCTTAB" TABLE TO DISPATCH FOR THE INPUT
;CHARACTER. THE STATE TABLE LOGIC AND THE DISPATCH ROUTINES BUILD
;THREE RESULTS: A DOUBLE PRECISION INTEGER(IN B,C) FOR THE FRACTIONAL
;PART OF THE RESULT, AN INTEGER(IN XP) FOR THE EXPONENT AFTER
;"D" OR "E", AND A COUNTER(IN "X") TO KEEP TRACK OF THE DECIMAL POINT.
;WHEN A TERMINATING CHARACTER IS FOUND, THE DOUBLE PRECISION INTEGER
;IS NORMALIZED TO THE LEFT TO GIVE A DOUBLE PRECISION FRACTION.
;THE DECIMAL POINT POSITION(FROM "X")OR THE IMPLIED DECIMAL POINT
;POSITION FROM THE FORMAT STATEMENT, THE "D" OR "E" EXPONENT, AND ANY
;SCALING FROM THE FORMAT STATEMENT ARE COMBINED INTO A DECIMAL
;EXPONENT. THIS DECIMAL EXPONENT IS USED AS AN INDEX INTO A POWER
;OF TEN TABLE (KEPT IN DOUBLE PRECISION INTEGER PLUS EXPONENT FORM
;SO INTERMEDIATE RESULTS WILL HAVE 8 MORE BITS OF PRECISION THAN
;FINAL RESULTS) TO MULTIPLY THE DOUBLE PRECISION FRACTION. THIS
;RESULT IS THEN ROUNDED TO GIVE A SINGLE PRECISION,
;PDP6/KI10 DOUBLE PRECISION RESULT.
;OVERFLOWS RETURN THE LARGEST POSSIBLE
;NUMBER (WITH CORRECT SIGN), WHILE UNDERFLOWS RETURN 0. NO ERROR
;MESSAGE IS GIVEN FOR  EITHER OVER OR UNDERFLOW.
;OLD ACCUMULATOR DEFINITIONS

F==0			;FLAG AC
T1==1
ST==2			;STATES (USES ST+1 TOO)
			;ST USED UP TO ENDF/ A&B AFTER THAT
A==2			;RET DIRECTLY IN THIS AC
B==3			;RESULT RETURNED IN A OR A AND B
C==4			;B,C, AND D ARE USED AS A MULTIPLE PRECISION
D==5			;  REGISTER FOR DOUBLE PRECISION OPERATIONS
E==6			;EXTRA AC

; THESE AC'S MUST BE PRESERVED

XP==7			;EXPONENT AFTER D OR E
BXP==10			;BINARY EXP
X==11			;COUNTS DIGITS AFTER POINT

;RIGHT HALF FLAGS IN AC "F"
DOTFL==1		;DOT SEEN
MINFR==2		;NEGATIVE FRACTION
MINEXP==4		;NEGATIVE EXPONENT
EXPFL==10		;EXPONENT SEEN IN DATA (MAY BE 0)
DPFLG==20		;VARIABLE IS DOUBLE PRECISION
EEFLG==40		;VARIABLE IS EXTENDED EXPONENT

LOCFLG==DOTFL+MINFR+MINEXP+EXPFL+DPFLG+EEFLG

;INPUT CHARACTER TYPES
CRTYP==1	;CARRIAGE RETURN
DOTTYP==2	;DECIMAL POINT
DIGTYP==3	;DIGITS 0-9
SPCTYP==4	;SPACE OR TAB
EXPTYP==5	;D OR E
PLSTYP==6	;PLUS SIGN (+)
MINTYP==7	;MINUS SIGN (-)
		;ANYTHING ELSE IS TYPE 0

$IMPURE
IN.PTR:	0				;BP TO FL NUM
SUBTTL	PROCEDURE TO PARSE AND CONVERT FLOATING PT NUM

$PURE

FLIN::
; ARGUMENTS:
;	1 = BYTE PTR TO ASCIZ NUMBER
; RETURNS:
;	TRUE/FALSE
;	1 = UPDATED BP
;	2 = COMPUTED VALUE

	PUSH	P,7		;SAVE PERM AC'S
	PUSH	P,10
	PUSH	P,11
	MOVEM	1,IN.PTR	;PERMANIZE INPUT ARG
	SETZB	C,D		;INIT D.P. FRACTION
	SETZB	ST,XP		;INIT STATE AND DECIMAL EXPONENT
	SETZB	X,F		;INIT "DIGITS AFTER POINT" COUNTER & FLAGS
	JRST	GETCH1		;[354] PROCESS FIELD
GETNXT:
	LSH	ST,-^D30	;MOVE STATE TO BITS 30-32
GETCH1:	ILDB	T1,IN.PTR		;GET NEXT CHAR
	JUMPE	T1,ENDF	;HIT NUL YET? IF SO, DONE
GETCH2:	CAIL	T1,"0"		;CHECK FOR NUMBER
	CAILE	T1,"9"
	JRST	CHRTYP		;NO, TRY OTHER
	SUBI	T1,"0"		;CONVERT TO NUMBER
GOT1:	IORI	ST,DIGTYP	;SET TYPE
GOTST:	LSHC	ST,-2		;DIVIDE BY NUMBER OF BYTES IN WORD
	TLNE	ST+1,(1B0)	;TEST WHICH HALF
	SKIPA	ST,NXTSTA(ST)	;RIGHT HALF (BYTES 2 OR 3)
	HLRZ	ST,NXTSTA(ST)	;UNFORTUNATELY BYTES 0 OR 1
	TLNN	ST+1,(1B1)	;WHICH QUADRANT
	LSH	ST,-9		;BYTES 0 OR 2
	ANDI	ST,777		;LEAVE ONLY RIGHT MOST  QUARTER
	ROT	ST,-3		;PUT DISPATCH ADDRESS IN BITS 32-35
				; AND NEW STATE IN BITS 0-2
	XCT	XCTTAB(ST)	;DISPATCH OR EXECUTE
	JRST	GETNXT		;RETURN FOR NEXT CHAR.
XCTTAB:	JRST	ILLCH		; (00) ILLEGAL CHAR
	JRST	BLNKIN		; (01) CR-LF
	IORI	F,DOTFL		; (02) PERIOD
	JRST	DIG		; (03) DIGIT BEFORE POINT
	JRST	BLNKIN		; (04) BLANK OR TAB
	JRST	GETNXT		; (05) RETURN FOR NEXT CHAR.
	IORI	F,MINFR		; (06) NEGATIVE FRACTION
	IORI	F,MINEXP	; (07) NEGATIVE EXP
	SOJA	X,DIGAFT	; (10) DIGIT AFTER POINT
	JRST	DIGEXP		; (11) EXPONENT
	JRST	ILLCH		; (12) DELIMITER TO BACK UP OVER
CHRTYP:	CAIN	T1,"+"		;CONVERT INPUT CHARS TO CHARACTER TYPE
	IORI	ST,PLSTYP
	CAIN	T1,"-"
	IORI	ST,MINTYP
	CAIE	T1," "		;SPACE
	CAIN	T1,"	"	;TAB
	IORI	ST,SPCTYP
	CAIE	T1,"."		;DECIMAL POINT?
	JRST	NOTDOT		;NO
	IORI	ST,DOTTYP
NOTDOT:	CAIE	T1,"D"
	CAIN	T1,"E"
	JRST	GOTEXP
	CAIE	T1,"d"		;[652] LOWER CASE D?
	CAIN	T1,"e"		;[652] LOWER CASE E?
	JRST	GOTEXP		;YES
	JRST	GOTST		;NO
GOTEXP:	IORI	ST,EXPTYP	;SET STATUS FOR EXPONENT
	JRST	GOTST		;GO DISPATCH ON OLD STATE AND CHAR TYPE
DIGAFT:
DIG:	JUMPN	C,DPDIG		;NEED D.P. YET?
	CAMLE	D,MAGIC		;NO, WILL MUL AND ADD CAUSE OVERFLOW?
	JRST	DPDIG		;MAYBE, SO DO IT IN DOUBLE PRECISION
	IMULI	D,12		;NO, MULTIPLY BY 10 SINGLE PRECISION
	ADD	D,T1		;ADD DIGIT INTO NUMBER
	JRST	GETNXT		;GO GET NEXT CHARACTER

DPDIG:	CAMLE	C,MAGIC		;WILL MULTIPLY AND ADD CAUSE OVERFLOW?
	AOJA	X,DIGRET	;YES
	IMULI	C,12		;MULTIPLY HIGH D.P. FRACTION BY 10
	MULI	D,12		;MULTIPLY LOW D.P. FRACTION BY 10
	ADD	C,D		;ADD HI PART OF LO PRODUCT INTO RESULT
	MOVE	D,E		;GET LO PART OF LO PRODUCT
	TLO	D,(1B0)		;STOP OVERFLOW IF CARRY INTO HI WORD
	ADD	D,T1		;ADD DIGIT INTO FRACTION
	TLZN	D,(1B0)		;SKIP IF NO CARRY INTO HI WORD
	ADDI	C,1		;PROPOGATE CARRY INTO HI WORD
DIGRET:	JRST	GETNXT		;GET NEXT CHAR

MAGIC:	<377777777777-9>/^D10	;LARGEST NUM PRIOR TO MULTIPLY AND ADD

DIGEXP:
	IORI	F,EXPFL		;SET FLAG TO SAY WE'VE SEEN EXPONENT
	IMULI	XP,12		;MULTIPLY BY TEN
	ADD	XP,T1		;ADD IN NEXT DIGIT
	JRST	GETNXT		;GET NEXT CHAR
;	 ? ,CR , . ,0-9,   ,D E, + , - ,
NXTSTA:	BYTE (9)
	000,010,022,031,050,000,051,061,
	000,011,022,031,041,053,054,074,
	000,012,120,102,042,053,054,074,
	000,013,120,114,043,000,054,074,
	000,014,120,114,044,000,120,120
	
ILLCH:				;[354]
	POP	P,11
	POP	P,10
	POP	P,7
	$RETF

BLNKIN:	SETZ	T1,		;SET TO NULL CHAR
	JRST	ENDF
SUBTTL	BUILD THE FLOATING VALUE NOW

ENDF:				;HERE WHEN ENTIRE FIELD PARSED
	DMOVE	A,C		;MOVE 2-WORD RESULT TO BOTTOM AC'S
	TXNE	F,MINEXP	;WAS D OR E EXPONENT NEGATIVE?
	MOVNS	XP		;YES, SO NEGATE IT
	ADD	X,XP		;ADD EXPONENT FROM D OR E
NORM:	MOVEI	BXP,106		;INIT BINARY EXPON FOR D.P. INTEGER
	JUMPN	A,NORM1		;XFER IF AT LEAST ONE 1 IN HIGH HALF
	EXCH	A,B		;HIGH HALF ZERO, MOVE LOW HALF TO HIGH,
				;AND CLEAR LOW HALF
	SUBI	BXP,^D35	;AND ADJUST EXPONENT FOR 35 SHIFTS
NORM1:	JUMPE	A,ZERO		;LEAVE IF BOTH WORDS ZERO
	MOVE	D,A		;COPY 1ST WORD
	JFFO	D,NORM2		;JUST IN CASE
	JRST	ZERO		;EE CLEARS OUT EVERYTHING
NORM2:	ASHC	A,-1(E)		;NORMALIZE D.P. INTEGER WITH BIN POINT
				;BETWEEN BITS 0 AND 1 IN HIGH WORD
	SUBI	BXP,-1(E)	;AND ADJUST EXPON TO ALLOW FOR SHIFTING
	JUMPE	X,ENDF6		;IF DECIMAL EXP=0, NO MUL BY 10 NEEDED
ENDF3:	MOVM	D,X		;GET MAG OF DEC EXP
	CAILE	D,%HIMAX	;LESS THAN MAX TABLE ENTRY?
	JRST	BADXP2		;NO. MUCH TOO BIG!
	MOVM	D,X		;GET MAGNITUDE OF DECIMAL EXPONENT
	CAILE	D,%PTLEN	;BETWEEN 0 AND MAX. TABLE ENTRY?
	MOVEI	D,%PTLEN	;NO, MAKE IT SO
	SKIPGE	X		;AND RESTORE CORRECT SIGN
	MOVNS	D
	SUB	X,D		;LEAVE ANY EXCESS EXPONENT IN X
DPMUL:	MUL	B,%HITEN(D)	;LO FRAC TIMES HI POWER OF TEN(RESULT IN B,C)
	MOVE	E,B		;GET HI PART OF PREVIOUS PRODUCT OUT OF WAY
	MOVE	B,A		;COPY HI PART OF FRACTION
	MUL	B,%LOTEN(D)	;HI FRAC TIMES LO POWER OF TEN
	TLO	E,(1B0)
	ADD	E,B		;SUM OF HI PARTS OF CROSS PRODUCTS TO AC T
	MUL	A,%HITEN(D)	;HI FRACTION TIMES HI POWER OF TEN
	TLON	E,(1B0)		;DID CARRY OCCUR?  ALLOW FOR NEXT CARRY
	ADDI	A,1		;CARRY FROM ADDING CROSS PRODUCTS
	ADD	B,E		;ADD CROSS PRODUCTS TO LO PART
				;  OF (HI FRAC TIMES HI POW TEN)
	TLZN	B,(1B0)
	AOJA	A,ENDF5		;AND PROPOGATE A CARRY, IF ANY
ENDF5:	TLNE	A,(1B1)		;NORMALIZED? 1.0 GTR RESULT GE 0.25
	JRST	ENDF5A		;YES, RESULT GE 0.5
	ASHC	A,1		;NO, SHIFT LEFT ONE PLACE
	SUBI	BXP,1		;AND ADJUST EXPONENT
ENDF5A:	MOVE	D,%EXP10(D)	;GET BINARY EXPONENT
	ADD	BXP,D		;ADJUST BINARY EXPONENT
	JUMPN	X,ENDF3		;CONTINUE IF ANY MORE DEC EXP LEFT
ENDF6:	TLO	A,(1B0)		;START ROUNDING (ALLOW FOR OVERFLOW)
	TXNE	F,DPFLG		;DOUBLE PRECISION?
	JRST	DPRND		;[563] TO DPRND
SPRND:	ADDI	A,200		;NO, ROUND IN HIGH WORD
	TRZ	A,377		;GET RID OF USELESS (UNUSED) BITS
	MOVEI	B,0		; DITTO
ENDF7:	TLZE	A,(1B0)		;CARRY PROPOGATE TO BIT 0?
	JRST	ENDF7A		;NO
	ASHC	A,-1		;YES, RENORMALIZE TO RIGHT
	ADDI	BXP,1		;AND ADJUST BINARY EXPONENT
	TLO	A,(1B1)		;AND TURN ON HI FRACTION BIT
ENDF7A:	TXNE	F,EEFLG		;EXTENDED EXPONENT?
	JRST	EERET		;YES. RETURN DIFFERENT FORMAT
	CAIGE	BXP,200		;OUT OF RANGE
	CAMGE	BXP,[-200]
	JRST	BADEXP		;YES. RETURN ZERO OR INFINITY
	ADDI	BXP,200		;ADD IN EXCESS 200
	ASHC	A,-8		;NO, LEAVE ROOM FOR EXPONENT
	DPB	BXP,[POINT 9,A,8] ;INSERT EXPONENT INTO HI WORD
RETURN:	TXNE	F,MINFR		;RESULT NEGATIVE?
	DMOVN	A,A		;YES. SO NEGATE RESULT
	MOVE	1,IN.PTR	;RET UPD BYTE PTR
	DMOVE	2,A		;AND COMPUTED VALUE
	POP	P,11
	POP	P,10
	POP	P,7
	$RETT

EERET:	CAIGE	BXP,2000	;OUT OF RANGE?
	CAMGE	BXP,[-2000]
	JRST	BADEXP		;YES. RETURN ZERO OR INFINITY
	ADDI	BXP,2000	;ADD IN EXCESS 2000
	ASHC	A,-^D11		;SHIFT TO MAKE ROOM FOR EXP
	DPB	BXP,[POINT 12,A,11];DEPOSIT THE EXPONENT
	JRST	RETURN

BADEXP:	HRLOI	A,377777	;SET NUMBER TO LARGEST POSSIBLE
	HRLOI	B,377777 	;FOR PDP-6 OR KI10
	JUMPG	BXP,RETURN	;DONE IF EXPONENT .GT. ZERO
ZERO:	SETZB	A,B		;IF NEGATIVE, SET TO ZERO
	JRST	RETURN

BADXP2:	JUMPL	X,ZERO			;RETURN ZERO IF DEC EXP NEGATIVE
	MOVEI	A,3777			;GET VERY LARGE EXP
	HRLOI	A,377777		;GET LARGEST FRACTION
	HRLOI	B,377777
	JRST	RETURN
;HERE FOR DOUBLE PRECISION ROUNDING

DPRND:	TLO	B,(1B0)		;START ROUNDING (ALLOW FOR CARRYS)
	TXNE	F,EEFLG		;EXTENDED EXPONENT?
	ADDI	B,2000		;YES. DO SPECIAL ROUNDING
	TXNN	F,EEFLG		;CHECK AGAIN
	ADDI	B,200	 	;LOW WORD ROUNDING FOR PDP-6 OR KI10
	TLZN	B,(1B0)		;DID CARRY PROPOGATE TO SIGN?
	AOJA	A,ENDF7		;YES, ADD CARRY INTO HIGH WORD
	JRST	ENDF7		;AND GO RENORMALIZE IF NECESSARY
SUBTTL	DATA TO SUPPORT CONVERSION

;POWER OF TEN TABLE IN DOUBLE PRECISION
;INTEGER FORMAT. EACH ENTRY CONSISTS OF TWO WORDS,
;EACH WITH 35 BITS OF FRACTION (SIGNS ARE EXCLUDED).
;THE BINARY POINT IS BETWEEN BITS 0 AND 1 OF THE
;HI ORDER WORD. THE EXPONENT (EXCESS 200) FOR THE 70 BIT
;FRACTION IS STORED IN THE SHORT TABLE CALLED "EXPTEN".

DEFINE .TAB. (A)<
	NUMBER 732-1000,357347511265,056017357445	;D-50
	NUMBER 736-1000,225520615661,074611525567
	NUMBER 741-1000,273044761235,213754053126
	NUMBER 744-1000,351656155504,356747065753
	NUMBER 750-1000,222114704413,025260341563
	NUMBER 753-1000,266540065515,332534432117
	NUMBER 756-1000,344270103041,121263540542
	NUMBER 762-1000,216563051724,322660234336
	NUMBER 765-1000,262317664312,007434303426
	NUMBER 770-1000,337003641374,211343364333
	NUMBER 774-1000,213302304735,325716130611	;D-40
	NUMBER 777-1000,256162766125,113301556754
	NUMBER 002,331617563552,236162112546	;D-38
	NUMBER 006,210071650242,242707256537
	NUMBER 011,252110222313,113471132270
	NUMBER 014,324532266776,036407360744
	NUMBER 020,204730362276,323044526460
	NUMBER 023,246116456756,207655654173
	NUMBER 026,317542172552,051631227232
	NUMBER 032,201635314542,132077636440
	NUMBER 035,242204577672,360517606150	;D-30
	NUMBER 040,312645737651,254643547601
	NUMBER 043,375417327624,030014501541
	NUMBER 047,236351506674,217007711035
	NUMBER 052,306044030453,262611673245
	NUMBER 055,367455036566,237354252117
	NUMBER 061,232574123152,043523552261
	NUMBER 064,301333150004,254450504735
	NUMBER 067,361622002005,327562626124
	NUMBER 073,227073201203,246647575664
	NUMBER 076,274712041444,220421535242	;D-20
	NUMBER 101,354074451755,264526064512
	NUMBER 105,223445672164,220725640716
	NUMBER 110,270357250621,265113211102
	NUMBER 113,346453122766,042336053323
	NUMBER 117,220072763671,325412633104
	NUMBER 122,264111560650,112715401725
	NUMBER 125,341134115022,135500702312
	NUMBER 131,214571460113,172410431376
	NUMBER 134,257727774136,131112537676
	NUMBER 137,333715773165,357335267655	;D-10
	NUMBER 143,211340575011,265512262714
	NUMBER 146,253630734214,043034737477
	NUMBER 151,326577123257,053644127417
	NUMBER 155,206157364055,173306466552
	NUMBER 160,247613261070,332170204304
	NUMBER 163,321556135307,020626245365
	NUMBER 167,203044672274,152375747331
	NUMBER 172,243656050753,205075341217
	NUMBER 175,314631463146,146314631463	;D-01
A:	NUMBER 201,200000000000,0	;D00
	NUMBER 204,240000000000,0
	NUMBER 207,310000000000,0
	NUMBER 212,372000000000,0
	NUMBER 216,234200000000,0
	NUMBER 221,303240000000,0
	NUMBER 224,364110000000,0
	NUMBER 230,230455000000,0
	NUMBER 233,276570200000,0
	NUMBER 236,356326240000,0
	NUMBER 242,225005744000,0	;D+10
	NUMBER 245,272207335000,0
	NUMBER 250,350651224200,0
	NUMBER 254,221411634520,0
	NUMBER 257,265714203644,0
	NUMBER 262,343277244615,0
	NUMBER 266,216067446770,040000000000
	NUMBER 271,261505360566,050000000000
	NUMBER 274,336026654723,262000000000
	NUMBER 300,212616214044,117200000000
	NUMBER 303,255361657055,143040000000	;D+20
	NUMBER 306,330656232670,273650000000
	NUMBER 312,207414740623,165311000000
	NUMBER 315,251320130770,122573200000
	NUMBER 320,323604157166,147332040000
	NUMBER 324,204262505412,000510224000
	NUMBER 327,245337226714,200632271000
	NUMBER 332,316627074477,241000747200
	NUMBER 336,201176345707,304500460420
	NUMBER 341,241436037271,265620574524
	NUMBER 344,311745447150,043164733651	;D+30
	NUMBER 347,374336761002,054022122623
	NUMBER 353,235613266501,133413263574
	NUMBER 356,305156144221,262316140533
	NUMBER 361,366411575266,037001570662
	NUMBER 365,232046056261,323301053417
	NUMBER 370,300457471736,110161266323
	NUMBER 373,360573410325,332215544010
	NUMBER 377,226355145205,250330436405	;D+38
	NUMBER 402,274050376447,022416546106
	NUMBER 405,353062476160,327122277527	;D+40
	NUMBER 411,222737506706,206363367627
	NUMBER 414,267527430470,050060265574
	NUMBER 417,345455336606,062074343133
	NUMBER 423,217374313163,337245615771
	NUMBER 426,263273376020,327117161367
	NUMBER 431,340152275425,014743015665
	NUMBER 435,214102366355,050055710521
	NUMBER 440,257123064050,162071272646
	NUMBER 443,332747701062,216507551417
	NUMBER 447,210660730537,231114641751	;D+50
	NUMBER 452,253035116667,177340012344
>
DEFINE NUMBER (A,B,C) <B>

TENTAB:	.TAB. %HITEN
DEFINE NUMBER (A,B,C) <C>

	.TAB. %LOTEN
%PTLEN==%HITEN-TENTAB	;CALCULATE NUMBER OF TABLE ENTRIES BEFORE "TENS"

DEFINE	NUMBER	(A,B,C) <A-200>

	.TAB. %EXP10
	DEFINE	HITABL <
%%EXP==0
 HIEXP  21, 0106, 330656232670, 273650000000
 HIEXP  31, 0147, 374336761002, 054022122623
 HIEXP  42, 0214, 267527430470, 050060265574
 HIEXP  52, 0255, 325644342445, 137230015035
 HIEXP  63, 0322, 233446460731, 230310256731
 HIEXP  73, 0363, 265072116565, 045110433533
 HIEXP  84, 0430, 203616042160, 325266273336
 HIEXP  94, 0471, 231321375525, 337205744040
 HIEXP 105, 0535, 337172572336, 007545174114
 HIEXP 115, 0577, 201742476560, 254305755624
 HIEXP 126, 0643, 275056630405, 050037577756
 HIEXP 136, 0704, 334103204270, 352046213536
 HIEXP 147, 0751, 240125245530, 066753037575
 HIEXP 158, 1015, 351045347212, 074316542737
 HIEXP 168, 1057, 207525153773, 310102120644
 HIEXP 179, 1123, 305327273020, 343641442602
 HIEXP 189, 1164, 345647674501, 121102720144
 HIEXP 200, 1231, 247161432765, 330455055455
 HIEXP 210, 1272, 302527746114, 232735577633
 HIEXP 221, 1337, 215510706516, 363467704427
 HIEXP 231, 1400, 244711331533, 105545654076
 HIEXP 242, 1444, 357747123347, 374251221667
 HIEXP 252, 1506, 213527073575, 262011603207
 HIEXP 263, 1552, 313176275662, 023427342311
 HIEXP 273, 1613, 354470426352, 214122564267
 HIEXP 284, 1660, 254120203313, 021677205125
 HIEXP 295, 1724, 372412614644, 074374052054
 HIEXP 305, 1766, 221645055640, 266335117623
 HIEXP 316, 2032, 324146136354, 344313410130
 HIEXP 326, 2073, 367020634251, 325055547056
>

%HIMAX==^D326

DEFINE	HIEXP	(DEXP,BEXP,HIWRD,LOWRD) <
	XWD	BEXP,^D<DEXP>
	EXP	HIWRD
	EXP	LOWRD
	%%EXP==%%EXP+1
>

%DEXP:	HITABL
%BEXP==%DEXP+1

>			;END TOPS10 CONDITIONAL FOR CPAFLO

END