.TITLE	SELECT
.IDENT	/230883/
.ENABL	LC
;
;	Written by	Ray Di Marco
;			6-May-82.
;
;
;	Version		060582/07
;
;
;----------------------------------------------------------------------------
;
; This is the main module for the database management program SELECT, that
; allows the user to extract selected information from a database and load it
; into a sort-format data file; such a file (after sorting) may be used as
; input to other database CUSPS such as the report writer (REPORT) or the on-
; line retriver (INSPECT). The program requests the user to specify
;
;	1) a FORMAT file, which determines the data extracted
;	2) a SORTER file, into which extracted data is loaded
;	3) the size (in bytes) of the output records.
;
; The program can be envoked as a CUSP from a menu program, and will accept
; the name of the FORMAT and SORTER file, as well as the entry size from data
; passed in core common. 
;
; The FORMAT file contains instructions intepreted by SELECT. While the
; instruction set is small, it is more than adequate for writing the small
; programs needed to extract data. Instructions are available for performing
; tests, loadind data into the output file and interacting with an operator
; via the terminal.
;
; The module must be linked with the user template and the database library
; to produce a selector customized for the target database. If the template
; is not linked in when the program is built, the user will be requested
; to specify the name of a .SAV formatted template file at execution time.
;
;
;	******************************************************************
;	**** See example FORMAT files at end of documentation section ****
;	******************************************************************

.SBTTL	Modifications
;
;
;	17-Jun-82 --> /02
;
; Number of extra features added to the program to increase utility. These
; features are as follows
;
;	SELECT now copies variables N0-N9, D0-D4 and L0 into SFL header block
;	starting at byte 100!8 of the block; this means that important
;	information (viz names, dates etc) may be passed to other CUSPs.
;	
;	The '$C' operator may now be included within the range of a '$T'
;	command (normally at the front) to clear/reset the P.ACPT flag.
;	
;	The $> operator, when included within the range of a '$L' command
;	causes the contents of the load buffer to be right justified; this is
;	useful when selecting numeric data that has been stored in ASCII
;	fields.
;	
;	The $: operator, when used within the range of a '$L' command allows
;	the load buffer to be padded or trimmed to a specified position. The
;	operator format is '$:DD' when DD is a numeric string that indicates
;	how may bytes are to be left in the load buffer. The load buffer is
;	trimmed or padded with SPACEs to the specified lenght.
;
;
;	5-Oct-82 --> /03
;
; Change ..LOAD decode table to add in $S operator to pass control to 6000$.
; This operator allows the two bytes in the tag field to be swapped with
; the first two data bytes; this is useful when selecting data from one
; database that is going to be used to produce a report from another 
; database.
;
;
;
;	10-Feb-83 --> /04
;
; Improve error handling so that give indication of what caused error prior
; to aborting. Added ABORT macro and ABORT routine.
;
;
;	24-Mar-83 --> /05
;
; Change ..TEST and ..LOAD routines to improve efficiency; the ..TEST
; routine now sets fail flag as soon as one test fails, and will discard
; all input untill a $$ sequence is detected (ie discard rest of tests). The
; ..LOAD routine now checks P.ACEPT at entry, and will abort if it is not
; set; all input untill next $$ sequence (ie end of load marker) is
; ignored.
;
;
;	23-Jun-83 --> /06
;
; Change comparision code to ignore upper/lower case diffrences in ascii
; strings. Add in following additional operators
;
;	$(L?	enters a field name into litaral variable L?, ?=0-3.
;		entering illegal field name will cause program to
;		re-request name.
;
;	$#	converts last two bytes in load buffer into equivalent 5
;		digit ascii string
;
;	$-X	will delete all occurances of character X from load buffer.
;		May be used to delete spaces etc.
;
;
;	23-Aug-83 -> /07
;
; Remove documentation from file to reduce size. Add in $A operator. This
; operator causes new data selected to be appended to existing data in SFL
; file. $A must appear at front of file as it also does an implict $*.
;

.SBTTL	DECLARATIONS
.ENABL	LC
;
;
.MCALL	.PUSH,.POP			; Stacking
.MCALL	CNAF				; Binary -> Ascii
.MCALL	.EXIT,.PRINT,.TTYOUT		; Abort Exit
.MCALL	.DATE				; returns date in R0
;
;
.GLOBL	$$FORM				; Index for DBS support routines
.GLOBL	FORM$$				; Start of database format block
.GLOBL	DBSLDR				; Database loader
.GLOBL	SFLINT,SFLEND			; entries
.GLOBL	SFLPSN,SFLRST			; entries
.GLOBL	SFLINP,SFLOUT			; entries
.GLOBL	SFLNME,SFLPAR			; data structures
.GLOBL	FRMINT,FRMINC,FRMMRK,FRMRST	; entry points
.GLOBL	FRMNME				; important data structure
.GLOBL	LOCFLD				; DBSSUP - locates DBS field block
.GLOBL	FILINT,FIL.DR,FIL.KR,KEY$$B	; DBSSUP - 'FILEIO'
.GLOBL	CON.ST,CON.LI,CON.CO,CON.EX	; "CONIO"
.GLOBL	CON.LO				; "CONIO"
;
;
;
	.PSECT	CODE			; OPEN CODE SECTION
;	------	----
;

.SBTTL	Macro Definitions
;
;
.MACRO	PRINT	STR=R0
	.GLOBL	CON.LO
	MOV	STR,R0
	CALL	CON.LO
.ENDM	PRINT
;
;
.MACRO	GTLIN	BUF=R0,STR
	.IF	NB,STR
		.GLOBL	CON.LO
		MOV	STR,R0
		CALL	CON.LO
	.ENDC
	MOV	BUF,R0
	.GLOBL	CON.LI
	CALL	CON.LI
.ENDM	GTLIN
;
;
.MACRO	DECODE	TABLE
	MOV	#TABLE,R1
	CALL	DECODE
.ENDM	DECODE
;
; ABORT is used to abort execution if CND is true; MES is printed out
;
.MACRO	ABORT	MES,CND,FILERR=NO,?LB,?LC
	.IF NB,CND
		B'CND	LB
		BR	LC
LB':	.ENDC
	.IIF IDN,FILERR,NO,	JSR	R1,ABORT
	.IIF DIF,FILERR,NO,	JSR	R1,ABORTF
	.ASCII	/'MES'/<200>
	.EVEN
	.IIF NB,CND,	LC':
.ENDM	ABORT
;

.SBTTL	INITIALIZATION SECTION
;
;
;	Initialize important parameters such as buffer size and name
;	of files to be used. We use the CONIO module to do I/O, so
;	must initialize this first.
;
START:	CALL	CON.ST			; initialize TTY interface
	PRINT	#7000$			; identify self
	TST	$$FORM			; is template linked in?
	BNE	100$			;  yes -> skip
	GTLIN	#TMPB1,#7010$		; get template name
	MOV	#TMPB1,R0		; R0 -> name
	CALL	DBSLDR			; load template
	MOV	R0,$$FORM		; save load address in pointer
100$:	GTLIN	#FRMNME,#7100$		; get name of 'FRM' file
	GTLIN	#SFLNME,#7110$		; get name of 'SFL' file
	PRINT	#7200$			; prompt for SIZE
	CALL	INPB1			; input answer into TMPB1
	CALL	DCDNUM			; R3 = answer
	MOV	R3,P.SIZE		; set up size of selection entry
	JMP	ACCESS			; access data files
;
.NLIST	BIN
7000$:	.ASCIZ	/Select RDM230883/
7010$:	.ASCII	/		DB Template: /<200>
7100$:	.ASCII	/		Format File: /<200>
7110$:	.ASCII	/		Output File: /<200>
7200$:	.ASCII	/		Record Size: /<200>
.EVEN
.LIST	BIN
;

;
;	Time gain access to files used and to zero out variables needed
;	later, and set up system date in variable D4 for the user.
;
ACCESS:	CALL	FRMINT			; format description file
	CALL	SFLINT			; initialize sort file
	CALL	FILINT			; open data base
	CLR	RECNUM			; Start at database record 0
	MOV	#SFLPAR,R0		; R0 -> SFLPAR
	MOV	(R0),$$APND		;	save old ENTSIZ
	MOV	2(R0),$$APND+2		;	save old NUMENT
	MOV	#1000/2,R1		; R1 =	buffer size
1000$:	CLR	(R0)+			;	clear out parameter block
	SOB	R1,1000$		;	loop
	.DATE				; R0 =	date in RT-11 format
	BIC	#^C37777,R0		;	strip unwanted bits
	CLR	R1			; R1 =	0
	ASHC	#-5,R0			; R1 =	year count
	ADD	R1,R0			; R0 =	date in internal format
	MOV	R0,D.....+<4*2>		;	set up D4 with system date
	JMP	NEXT			; enter select loop
;
;

.SBTTL	Code - "NEXT"		...	Find Next Record to be Processed
;
;	In this section we read in the database records one at a time and
;	call PROCESS for each one. We skip to 1000$ when have no more
;	records to do.
;
NEXT:	INC	RECNUM			; Point to next record
	MOV	$$FORM,R0		; R0 -> FDT
	CMP	RECNUM,14(R0)		; all done?
	BHI	1000$			; yes -> skip
	MOV	RECNUM,R0		; R0 = record number
	CALL	FIL.KR			; read in keys for record
	TST	KEY$$B			; record in use?
	BEQ	NEXT			; no -> ignore it
	CALL	PROCESS			; Process record
	BR	NEXT			; attempt find next record
;
;	We have finished. Set up SFLPAR block and then empty out buffer.
;
1000$:	MOV	P.SIZE,SFLPAR		; set up size
	MOV	#SFLPAR+100,R0		; R0 ->	DESTINATION
	MOV	#N.....,R1		; R1 ->	SOURCE
	MOV	#<1000-100>/2,R2	; R2 =	counter
1100$:	MOV	(R1)+,(R0)+		;	copy
	SOB	R2,1100$		;	loop
	CALL	SFLEND
;
;	Output number of records selected and then exit.
;
	CNAF	SSSSD,STRING=#7100$,NUMBER=<SFLPAR+2>
	PRINT	#7000$			;	show result
	JMP	CON.EX			;	exit time
;
.NLIST	BIN
7000$:	.ASCII	/ Number selections: /
7100$:	.ASCIZ		/....../
.EVEN
.LIST	BIN
;
;

.SBTTL	Routine - "Process"	...	supervises the processing of a record
;
;  This routine is called to process the record whose number is in 'RECNUM'.
;  The routine loads the record into memory, and then executes the user
;  commands stored in the format file.
;
;
;	Load record, rewind format file and mark record as not yet accepted.
;
PROCES:	MOV	RECNUM,R0		; R0 =	record number
	CALL	FIL.DR			;	load record into memory
	CALL	FRMRST			;	rewind format file
	CLR	P.ACPT			;	record not yet accepted
;
;	Use 700$ to decode format file and envoke required routines.
;
400$:	CALL	INPUT			; get next input character
	DECODE	700$			; decode via 700$, error = 600$
	BR	400$			; loop
;
;
;	Actioning routines	500$ envoked to terminate processing
;				570$ envoked if character to be ignored
;				600$ envoked if character is illegal
;
500$:	ADD	#2,SP			; discard 'process' return address
570$:	RETURN				; return to caller
600$:	ABORT	<PROCESS: illegal character in format file!>
;
;
;	Table used to decode input. Call routine when encounter char.
;
700$:	.WORD	'E+200,	500$		; end of format file
	.WORD	11,	570$		; ignore 'TB'
	.WORD	12,	570$		; ignore 'LF'
	.WORD	15,	570$		; ignore 'CR'
	.WORD	40,	570$		; ignore 'spaces'
	.WORD	';,	..COMM		; comment
	.WORD	')+200,	..SEND		; send output to terminal
	.WORD	'*+200,	FRMMRK		; mark rewind point in file
	.WORD	'?+200,	ARGINP		; input argument value	
	.WORD	'(+200,	FLDINP		; input name of a field	
	.WORD	'A+200,	..APND		; append output
	.WORD	'L+200,	..LOAD		; load data time
	.WORD	'T+200,	..TEST		; test time
	.WORD	0,	600$		; abort address
;

.SBTTL	Process Routine '..COMM'	...	Comment
;
;  Discard all input untill hit end of comment marker, a 'LF'!
;
..COMM:	CALL	INPUT			; get a character
	CMP	R0,#12			; hit a 'LF'?
	BNE	..COMM			; no -> loop
	RETURN				; loop
;
;

.SBTTL	Process Routine '..SEND'	...	Send output to terminal
;
; All characters upto but excluding terminator are to be sent to terminal.
;
..SEND:	CALL	INPUT			; get character
	CMP	R0,#'$+200		; terminator?
	BEQ	1000$			; yes -> skip
	CALL	CON.CO			; output
	BR	..SEND			; loop
1000$:	RETURN				; exit
;
;

.SBTTL	Process Routine '..APND'	...	append to output file
;
;
; This routine causes any new selection to be appended to the data already
; in the SFL file. An implict $* is performed.
;
..APND:	TST	SFLPAR+2		;	any new records loaded?
	ABORT	<..APND: $A not at start>,NE;	 yes -> abort
	TST	$$APND+2		;	any old records?
	BEQ	7000$			;	 no --> ignore $A
	TST	$$APND			;	old size valid?
	ABORT	<..APND: existing record lenght of 0>,EQ
;
	MOV	$$APND+2,R2		; R2 =	number old records
	MOV	$$APND,R1		; R1 =	old record size
	MOV	#TMPB1,R0		; R0 ->	tmp buffer
	MOV	R2,SFLPAR+2		;	fudge NUMENT
	MOV	R1,P.SIZE		;	fudge ENTSIZ
;
1000$:	CALL	SFLINP			;	load record
	CALL	SFLOUT			;	write record
	SOB	R2,1000$		;	loop
;
7000$:	JMP	FRMMRK			;	do implicit $*
;
$$APND:	.WORD	0,0			;	initialized from SFLPAR+0/2
;

.SBTTL	Process Routine '..TEST'	...	Carry out a test
;
;  This code is called by 'PROCESS' to carry out an 'acceptance' test. If
;  the record passes all the tests we increment the 'P.ACPT' flag.
;
;
..TEST:	CLR	(PC)+			; assume all ok
100$:	.WORD	0			; 0 -> test ok, 1 -> fail
;
400$:	CALL	INPUT			; get next input character
	DECODE	700$			; decode via 700$, error = 600$
	BR	400$			; loop
;
;	Actioning routines	500$ envoked to terminate processing
;				510$ invoked to UNSET/CLEAR/RESET P.ACPT
;				570$ envoked if character to be ignored
;				600$ envoked if character is illegal
;
500$:	ADD	#2,SP			; discard 'process' return address
	TST	100$			; did we fail the test?
	BNE	570$			; yes -> skip
	MOV	#1,P.ACPT		; indicate that passed
	RETURN				; return to caller
510$:	CLR	P.ACPT			; clear P.ACPT flag
570$:	RETURN				; return to caller
600$:	ABORT	<..TEST:illegal primary argument!>
;
;
;	Table used to decode input. Call routine when encounter char.
;
700$:	.WORD	'$+200,	500$		; end of test
	.WORD	'C+200,	510$		; CLEAR P.ACPT FLAG
	.WORD	11,	570$		; ignore 'TB'
	.WORD	12,	570$		; ignore 'LF'
	.WORD	15,	570$		; ignore 'CR'
	.WORD	40,	570$		; ignore 'spaces'
	.WORD	';,	..COMM		; comment
	.IRPC	X,^|'"[<0123456789NL@!D|; .... argument ....
	 .WORD	''X,	1000$		;	-> decode out
	.ENDR				; ..................
	.WORD	0,	600$		; eot
;

;
; Detected start of an argument. Use ARGDCD to load arguments value into
; TMPB1, and then look for 'operator'.
;
;
;	Load contents of specified field into buffer.
;
1000$:	MOV	#TMPB1,R5		; R5 -> storage buffer
	CALL	ARGDCD			;	load buffer with argument
;
;
;	Decode out next character in format file.
;
1400$:	CALL	INPUT			; get next input character
	DECODE	1700$			; decode via 1700$, error = 1600$
	BR	1400$			; loop
;
;	Actioning routines		1570$ envoked if character is ignored
;					1600$ envoked if character is illegal
;
1570$:	RETURN				; ignore character
1600$:	ABORT	<..TEST:expecting operator!>
;
;
;	Table used to decode input. Call routine when encounter char.
;
1700$:	.WORD	11,	1570$		; ignore 'TB'
	.WORD	40,	1570$		; ignore 'spaces'
	.WORD	'.,	2000$		; start of operator
	.WORD	0,	1600$		; eot
;

;
;  Have encountered start of operator character. Use 'OPRDCD' to decode
;  operator; this routine returns an equivalent 'BR .+2' conditional
;  instruction in R0 that we use to patch location 3400$.
;
;
2000$:	ADD	#2,SP			; discard 1000$ address
	CALL	OPRDCD			; decode out operator
	MOV	R0,3400$		; patch 'br' location
;
;
;	Decode out next character.
;
2400$:	CALL	INPUT			;	get char
	DECODE	2700$			;	decode input, error = 2600$
	BR	2400$			;	loop
;
;	Actioning routines	2570$ envoked if character to be ignored
;				2600$ envoked if character is illegal
;
2570$:	RETURN				; ignore character
2600$:	ABORT	<..TEST:illegal secondary argument!>
;
;	Table used to decode input. Call routine when encounter char.
;
2700$:	.WORD	11,	2570$		; ignore 'TB'
	.WORD	40,	2570$		; ignore 'spaces'
	.IRPC	X,^|'"[<0123456789NL@!D|; .... argument ....
	 .WORD	''X,	3000$		;	-> decode out
	.ENDR				; ..................
	.WORD	0,	2600$			; eot
;
;

;
; 	Hit second argument. Load it into TMPB2 ready for comparision.
;
3000$:	ADD	#2,SP			; clear '2000$' phase address
	MOV	#TMPB2,R5		; R5 -> buffer
	CALL	ARGDCD			; get argument
;
;
;	Compare two args and set 100$ flag iff test fails. Note that
;	location 3400$ patched by 2000$ phase so that branch over next
;	instruction iff test passes.
;
	MOV	#TMPB1,R0		; R0 -> arg1
	MOV	#TMPB2,R1		; R1 -> arg2
	MOV	#100$,R5		; R5 -> flag
	CALL	ARGCMP			;	compare arg1,arg2
3400$:	NOP				; **** changed by 2000$ ****
;;	INC	(R5)			;	set fail flag
	BR	3700$			;	get here if fail
	RETURN				;	get here if suceed
;
;
; get here if test fails; set fail flag and abort set of tests
;
3700$:	INC	(R5)			;	set fail flag
3710$:	CALL	INPUT			;	discard
	CMPB	R0,#200+'$		;	 rest of
	BNE	3710$			;	  test instructions
	JMP	500$			;	exit test code
;
;

.SBTTL	Process Routine '..LOAD'	...	Load data into sorter file
;
;	This routine is called to load the specified fields into the
;	sorter file. Start by resting the output buffer pointer etc.
;
..LOAD:	TST	P.ACPT			; load data?
	BNE	70$			;  yes -> skip
10$:	CALL	INPUT			;; no --> discard
	CMPB	R0,#'$+200		;;         rest of load
	BNE	10$			;;          instructions
	RETURN				;; all done
;
70$:	MOV	RECNUM,TMPB2		; TMPB2 bytes 0:1 = record num
	MOV	#TMPB2+2,(PC)+		; set up store pointer
100$:	.WORD	0			; storage pointer
;
400$:	CALL	INPUT			; get next input character
	DECODE	700$			; decode via 700$, error = 600$
	BR	400$			; loop
;
;	Actioning routines	500$ envoked to terminate processing
;				570$ envoked if character to be ignored
;				600$ envoked if character is illegal
;
500$:	ADD	#2,SP			; discard 'process' return address
	TST	P.ACPT			; load data?
	BEQ	570$			;  no -> skip
	MOV	100$,R5			; R5 ->	end data
	CMP	R5,#TMPB2+2		; any data to load?
	BEQ	570$			; no -> skip
;
	MOV	#TMPB2,R0		; R0 -> buffer
	MOV	R5,R1			; R1 -> last char
	SUB	R0,R1			; R1 =  number bytes
	TST	P.SIZE			;	size set up?
	BNE	520$			;	yes -> skip
	MOV	R1,P.SIZE		;	make this standard size
520$:	CMP	R1,P.SIZE		;	compare
	BHIS	560$			;	ok -> skip
	MOVB	#40,(R5)+		;	pad out
	INC	R1			;	increment record size
	BR	520$			;	loop	
560$:	MOV	P.SIZE,R1		;	set up size
	CALL	SFLOUT			;	output data
	INC	SFLPAR+2		;	one more entry
570$:	RETURN				; return to caller
600$:	ABORT	<..LOAD:illegal argument!>
;

;
;	Table used to decode input. Call routine when encounter char.
;
700$:	.WORD	'$+200, 500$		; finish
	.WORD	11,	570$		; ignore 'TB'
	.WORD	12,	570$		; ignore 'LF'
	.WORD	15,	570$		; ignore 'CR'
	.WORD	40,	570$		; ignore 'spaces'
	.WORD	';,	..COMM		; comment
	.IRPC	X,^|[<0123456789"'NL@!D|; ..... arguments .....
	 .WORD	''X,	1000$		;	load buffer
	.ENDM				; .....................
	.WORD	'^+200,	2000$		; convert upper to lower case
	.WORD	'~+200,	3000$		; NULL if string all spaces
	.WORD	'<+200,	4000$		; trim trailing spaces
	.WORD	'>+200,	4100$		; right justify data
	.WORD	'-+200,	4200$		; remove specified character
	.WORD	':+200,	5000$		; position load pointer
	.WORD	'S+200,	6000$		; switch tag/data
	.WORD	'#+200,	6100$		; convert number to ascii
	.WORD	0,	 600$		; eot
;

;
;	Use 'ARGDCD' to load value of next argument into TMPB1 and then
;	append to data in TMPB2.
;
1000$:	MOV	#TMPB1,R5		; R5 -> buffer
	CALL	ARGDCD			;	decode argument
	MOV	100$,R0			; R0 ->	buffer
	MOV	#TMPB1+4,R1		; R1 -> data
	MOV	TMPB1+2,R2		; R2 =	number bytes
	BEQ	1700$			;	skip no data
1100$:	MOVB	(R1)+,(R0)+		;	copy
	SOB	R2,1100$		;	loop till all done
	MOV	R0,100$			;	save pointer
1700$:	RETURN				;	all done
;
;

;
;	This routine converts all lower case characters in the buffer
;	into uppercase characters.
;
2000$:	MOV	100$,R2			; R2 ->	end data
	SUB	#TMPB2+2,R2		; R2 =	number characters in buffer
	BEQ	2240$			;	none -> skip
	MOV	#TMPB2+2,R1		; R1 ->	data
2100$:	CMPB	(R1)+,#140		;	LC?
	BLOS	2200$			;	 no -> skip
	BICB	#40,-1(R1)		;	 convert to LC
2200$:	SOB	R2,2100$		;	loop
2240$:	RETURN				;	exit
;

;
;	This routine resets the load buffer iff the buffer is full
;	of spaces.
;
3000$:	MOV	100$,R2			; R2 ->	end data
	SUB	#TMPB2+2,R2		; R2 =	number characters in buffer
	BEQ	3200$			;	none -> skip
	MOV	#TMPB2+2,R1		; R1 ->	data
3100$:	CMPB	(R1)+,#40		;	space?
	BNE	3200$			;	 no -> skip
	SOB	R2,3100$		;	loop
	MOV	#TMPB2+2,100$		;	reset pointer
3200$:	RETURN				;	exit
;

;
;	This routine deletes/trims all trailing blanks from
;	the end of the currently loaded sting.
;
4000$:	MOV	100$,R0			; R0 -> eos
4020$:	CMP	R0,#TMPB2+2		;	at start of buffer
	BEQ	4040$			;	 yes -> skip
	CMPB	-(R0),#40		;	is it a trailing space?
	BEQ	4020$			;	yes -> discard
	INC	R0			;	point to next free byte
4040$:	MOV	R0,100$			;	save pointer
	RETURN				;	all done
;
;
;	This routine RIGHT JUSTIFIES the string by removing trailing
;	spaces from the right and inserting them at the front.
;
4100$:	MOV	100$,R1			; R1 ->	eos'
	CALL	4000$			;	trim string
	MOV	R1,100$			;	untrim string
4120$:	CMP	R0,#TMPB2+2		;	at start of buffer?
	BEQ	4160$			;	 yes -> skip
	MOVB	-(R0),-(R1)		;	 justify to right
	BR	4120$			;	loop
4160$:	CMP	R1,#TMPB2+2		;	at start of buffer?
	BEQ	4170$			;	 yes -> all done
	MOVB	#40,-(R1)		;	justify with spaces
	BR	4160$			;	loop
4170$:	RETURN				; 	all done
;
; 	This routine is used to remove a specified characters from the load
;	buffer.
;
4200$:	CALL	INPUT			; R0 =	character to remove
	MOV	#TMPB2+2,R1		; R1 ->	source
	MOV	R1,R2			; R2 ->	destination
4210$:	CMP	R1,100$			;	done?
	BHIS	4270$			;	 yes -> exit
	CMPB	(R1)+,#40		;	space?
	BEQ	4210$			;	 yes ->	ignore
	MOVB	-1(R1),(R2)+		;	 no -->	copy it
	BR	4210$			;		loop
4270$:	MOV	R2,100$			;	save eos pointer
	RETURN				;	done
;

;
; This routine is called to either TRIM or PAD the contents of the
; load buffer to ensure that the next item loaded goes into a specified
; byte; the POSITION operation requires a numeric argument that indicates
; the desired position.
;
5000$:	CALL	INPUT			; R0 =	first character of argument
	MOV	#TMPB1,R5		; R5 -> buffer
	CALL	ARGDCD			;	decode argument
	TST	TMPB1			;	is type = 0 (ie numeric)
	BNE	5070$			;	 no -> error
	MOVB	TMPB1+5,R1		; R1 =	desired position
	BEQ	5070$			;	 zero -> illegal
	BIC	#^C377,R1		;	ensure > 256
	ADD	#TMPB2+1,R1		; R1 =	tab position
	MOV	100$,R0			; R0 ->	old eos
	MOV	R1,100$			;	setup new eos
5030$:	CMP	R0,R1			;	need padding?
	BHIS	5040$			;	 no -> skip
	MOVB	#40,(R0)+		;	pad buffer
	BR	5030$			;	loop
5040$:	RETURN				;	done
5070$:	ABORT	<..LOAD:invalid POSITION argument!>
;

;
;	This routine switchs the connents of the tag field with
;	the first two data bytes
;
6000$:	MOV	TMPB2,R0		; R0 =	tag
	MOV	TMPB2+2,R1		; R1 =	data bytes 1,2
	SWAB	R0			;	make tag bytes
	MOV	R0,TMPB2+2		;	 data bytes
	SWAB	R1			;	make data bytes
	MOV	R1,TMPB2		;	 tag bytes
	RETURN				;	exit	
;
;	This routine removes the last two bytes from the load buffer
;	and replaces them with ascii decimal string that is the
;	equivalent to the 16 bit number they represent.
;
6100$:	MOV	100$,R1			; R1 ->	EOD
	MOVB	-(R1),R2		; R2 =	LOB
	BIC	#^C377,R2		;	discard unwanted bits
	MOVB	-(R1),R0		; R0 =	HOB
	BIC	#^C377,R0		;	discard unwanted bits
	SWAB	R0			;	merge together
	BIS	R0,R2			;	 HOB and LOB
	CMP	R1,#TMPB2+2		;	load buffer held data?
	BLO	6170$			;	 no --> abort
	CNAF	SSSSD			;	 yes ->	convert to ascii
	MOV	R1,100$			;		save pointer
6170$:	RETURN				;	done
;

.SBTTL	Primitive - 'DECODE'	...	used to decode input
;
;	Routine called with R1 pointing to table. Table consists
;	of two word entries. Control passed to routine whose address
;	is in secon word iff R0 matchs first word in entry. Table
;	is terminated with an entry that has first word of 0. If cannot
;	find matching entry in table, pass control to routine whose
;	address is specified in terminating (null word 1) entry.
;
DECODE:	TST	(R1)			; eot?
	BEQ	1200$			; yes -> abort
	CMP	R0,(R1)			; match?
	BEQ	1200$			; yes -> skip
	ADD	#4,R1			; bump pointer
	BR	DECODE			; loop
;
1200$:	JMP	@2(R1)			; pass over control
;

.SBTTL	Primitive - "INPUT"	...	return next input character
;
;	This routine returns the next character from the input stream. If
;	INPUT$ is non-zero the character stored in INPUT$ is returned. This
;	allows a routine to push an unwanted character back into the input
;	stream.
;
INPUT:	TST	INPUT$				; pushed char available?
	BEQ	100$				; no -> skip
	MOV	INPUT$,R0			; return it
	CLR	INPUT$				; clear for next time
	RETURN					; all done
;
100$:	CALL	FRMINC				; get a stream character
	BCC	1000$				; got one -> skip
	ABORT	<INPUT:unexpected end of input stream!>
1000$:	RETURN					; bye
;
INPUT$:	.WORD	0				; used to push char back
;

.SBTTL	PRIMITIVE - "ARGDCD"	...	convert argument from ascii to bin
;
;
; This routine performs the function equivalent to fortrans DECODE statement,
; in that it converts an argument from ascii into its equivalent form. The
; routine uses the 'INPUT' routine the obtain all but the first character
; that makes up the argument; the first character is passed in R0. The entry
; conditions are
;
;		R0	holds the first chracter in argument
;		R5	holds address of buffer to hold result.
;
; All registers other than R0 are preserved through the routine. At exit, the
; buffer pointed to by R5 holds the following data
;
;	Buffer	.Word	type	; type of argument
;		.Word	size	; number bytes in arguments value
;		.Blkb	size	; value of argument
;
; The 'type' code indicates the type of data returned. Valid types are 0
; for 2 byte numeric values and 2 for strings of bytes. The 'size' entry
; indicates the number of bytes that make up the value. In all cases, the
; argument values are arranged so that the most significant byte is first.
;
;
; The first character of the argument, (passed in R0) is used to determ how
; the argument is to be interpreted. Valid first characters are
;
;	LEADIN		TYPE OF				TERMINATING
;	CHARACTER	ARGUMENT			CHARACTER
;
;	any digit	numeric constant		non-digit
;	!		date constant			non-digit after year
;	' or "		literal constant		leadin char
;	[ or <		contents of database field	] or >
;	N		numeric variable
;	D		date variable
;	L		literal variable
;	@		contents on field, name in LV
;
;

;
;
; Save registers, and then use '700$' table to determine which routine is to
; be called to process argument whose first character is in R0.
;
;
ARGDCD:	.PUSH	<R1,R2,R3,R4,R5>		; save
	DECODE	700$				; decode via leadin char
	.POP	<R5,R4,R3,R2,R1>		; restore
	RETURN					; exit
;
;
; The 700$ table indicates which routine is to be called to process character
; in R0 (and the rest of the argument). If leadin character not in table we
; abort via 600$, print an error message!
;
600$:	ABORT	<ARGDCD:illegal argument!>
700$:	.IRPC	X,<0123456789>		; .... digits ....
	 .WORD	''X,	1000$		; 	number
	.ENDR				; ................
	.WORD	'!,	1400$		;	date constant
	.IRPC	X,<"'>			; .... quaotes ....
	 .WORD	''X,	2000$		;	literal
	.ENDR				; .................
	.IRPC	X,^|<[|			; .... brackets ....
	 .WORD	''X,	3000$		;	field
	.ENDR				; ..................
	.WORD	'N,	4000$		; numeric variable
	.WORD	'D,	4400$		;	date variable
	.WORD	'L,	5000$		; literal variable
	.WORD	'@,	6000$		; indirrection on LV
	.WORD	'D,	1400$		; DATE
	.WORD	0,	600$		; eot
;

;
; Get here if have to evaluate a numeric constant. The binary value of the
; constant is returned in the buffer @R5. The constant is terminated by any
; non-digit character. Use DCDNUM to return value in R3 and delimiter in R0.
;
1000$:	MOV	R0,INPUT$		; force digit 1 back into stream
	MOV	#INPUT,R4		; R4 =	address get char routine
	CALL	DCDNUM			; R3 =	numeric value (R0=delimiter)
	MOV	R0,INPUT$		; rewind over char
	CLR	(R5)+			; type = 0 (numeric)
	MOV	#2,(R5)+		; size = 2 bytes
	MOVB	R3,1(R5)		; return LOB
	SWAB	R3			; get HOB
	MOVB	R3,(R5)			; return LOB
	RETURN
;
; Get here if have to evaluate a DATE constant. The binary value of the 
; constanti s returned in the buffer @R5. The constant format is DD-MM-YY 
; where the DD, MM and YY fields are numeric constants. Use DCDDAT to return
; value of date in R3 and the delimiter that terminated the YY field in R0.
;
1400$:	MOV	#INPUT,R4		; R4 =	address get char routine
	CALL	DCDDAT			; R3 =	numeric value (R0=delimiter)
	MOV	R0,INPUT$		; force delimiter back into stream
	CLR	(R5)+			; type = 0 (numeric)
	MOV	#2,(R5)+		; size = 2 bytes
	MOVB	R3,1(R5)		; return LOB
	SWAB	R3			; get HOB
	MOVB	R3,(R5)			; return LOB
	RETURN
;

;
;
;	Are here to decode a literal constant. The constant consists of all
;	characters upto but excluding the terminating delimiter, that is
;	the same as the leadin character!
;
2000$:	MOV	R5,R4			; R4 -> buffer
	ADD	#4,R4			; R4 -> start of buffer data area
	MOV	R0,R3			; R3 =	delimiter
	MOV	#100,R2			; R2 =	max allowed sting size
2100$:	CALL	INPUT			; get character
	CMP	R0,R3			; hit delimiter?
	BEQ	2200$			; yes -> skip
	CMP	R0,#15			; hit <CR>?
	BEQ	2600$			; yes -> error
	MOVB	R0,(R4)+		; save char
	SOB	R2,2100$		; loop till got all chars
	BR	2600$			; illegal literal
;
2200$:	SUB	R5,R4			; R4 =	total lenght
	SUB	#4,R4			; R4 =	number chars
	MOV	#2,(R5)+		;	set up TYPE
	MOV	R4,(R5)+		;	set up size
	RETURN				;	all done
;
;
2600$:	ABORT	<ARGDCD:illegal literal constant!>
;

;
;
;	Are here to return the value the data stored in a database record.
;	The argument being decoded is the actual name of the field. We must
;	get the name, translate it into the offset of the field descriptor
;	entry, and then use this to load the actual data. A long process, but
;	worth it in the end.
;
;
;
;	Get name of field.
;
3000$:	MOV	R5,R4			; R4 ->	buffer
	MOV	#100,R2			; R2 =	max allowed name
	MOV	#'],R3			; assume delimiter is '['
	CMP	R0,#'[			; was '[?
	BEQ	3100$			; yes -> ok
	MOV	#'>,R3			; must have been a '<'
3100$:	CALL	INPUT			; get character
	CMP	R0,R3			; hit delimiter?
	BEQ	3200$			; yes -> skip
	MOVB	R0,(R4)+		; save char
	SOB	R2,3100$		; loop till got all name
	BR	3600$			; illegal name
;
;	Locate form entry for field.
;
3200$:	CLRB	(R4)			;	terminate name
3277$:	MOV	R5,R1			; R1 ->	name
	MOV	$$FORM,R0		; R0 ->	form
	CALL	LOCFLD			;	find correct entry
	BCS	3610$			;	failed -> abort
;
;	Call appropriate routine to load field data into buffer.
;
	MOV	(R1),R0			; R0 =	flags
	BIC	#^C7,R0			; R0 =	type
	ASL	R0			; R0 =	type*2
	JMP	@3700$(R0)		;	return data
;
;

;
;	Code to load contents of numeric field.
;
3300$:	CLR	(R5)+			; operator type = 0 (numeric)
	MOV	#2,(R5)+		; lenght = 2 bytes
	MOV	4(R1),R0		; R0 = offset to data
	ADD	@$$FORM,R0		; R0 -> data
	MOVB	(R0),1(R5)		; return lob
	MOVB	1(R0),(R5)		; return hob
	RETURN				; exit
;
;	Code to load contents of an ascii field.
;
3400$:	MOV	#2,(R5)+		; operator type = 2 (string)
	MOV	2(R1),R2		; R2 = number bytes in string
	MOV	R2,(R5)+		; set up in buffer
	MOV	4(R1),R0		; R0 = offset to data
	ADD	@$$FORM,R0		; R0 -> data
3410$:	MOVB	(R0)+,(R5)+		; return lob
	SOB	R2,3410$		; loop till all done
	RETURN				; exit
;
;
;	Abort points.
;
3600$:	ABORT	<ARGDCD:illegal field name!>
3610$:	ABORT	<ARGDCD:cannot locate field!>
3620$:	ABORT	<ARGDCD:illegal type of field!>
;
;
;	Index into table via field type to get address load routine.
;
3700$:	.WORD	3400$			;	ascii type
	.WORD	3400$			;	ascii type
	.WORD	3400$			;	ascii type
	.WORD	3300$			;	numeric	(number)
	.WORD	3300$			;	numeric	(date)
	.WORD	3610$			;	illegal type
	.WORD	3610$			;	illegal type
;

;
;	Are to return the contents of a numeric variable. The next character
;	must be a digit that indicates which variable is requested.
;
4000$:	CALL	INPUT			; get next character
	SUB	#'0,R0			; convert digit to binary
	CMP	R0,#9.			; valid index?
	BHI	4060$			; invalid index -> skip
	ASL	R0			; 2*index -> R0
	ADD	#N.....,R0		; R0 -> value
4050$:	CLR	(R5)+			; type = 0
	MOV	#2,(R5)+		; size = 2 bytes
	MOVB	1(R0),(R5)+		; setup hob
	MOVB	 (R0),(R5)+		; setup lob
	RETURN				; all done
4060$:	ABORT	<ARGDCD:invalid numeric variable!>
;
;
4400$:	CALL	INPUT			; get next character
	SUB	#'0,R0			; convert digit to binary
	CMP	R0,#4.			; valid index?
	BHI	4460$			; invalid index -> skip
	ASL	R0			; 2*index -> R0
	ADD	#D.....,R0		; R0 -> value
	BR	4050$			;	return value
4460$:	ABORT	<ARGDCD:invalid DATE variable!>
;

;
;	This code returns the contents of a literal variable. The next
;	character is a digit that indicates which variable is wanted. The
;	literals are stored in 128 byte buffers starting at "L.....", and
;	the first word of each buffer is the number of bytes in the
;	variable. Note that a null variable is returned as one space.
;
5000$:	CALL	INPUT			; get next character
	SUB	#'0,R0			; convert digit to binary
	CMP	R0,#3.			; valid index?
	BHI	5600$			; invalid index -> skip
	ASL	R0			; 002*index -> R0
	ASL	R0			; 004*index -> R0
	ASL	R0			; 008*index -> R0
	ASL	R0			; 016*index -> R0
	ASL	R0			; 032*index -> R0
	ASL	R0			; 064*index -> R0
	ASL	R0			; 128*index -> R0
	ADD	#L.....,R0		; R0 -> value
	MOV	#2,(R5)+		; type = 2
	MOV	(R0)+,R2		; R2 = number bytes
	BNE	5200$			;	none-zero -> skip
	MOV	#1,R2			;	force lenght = 1
	MOVB	#40,(R2)		;	force to a space
5200$:	MOV	R2,(R5)+		;	return lenght
5300$:	MOVB	(R0)+,(R5)+		; copy data
	SOB	R2,5300$		; loop
	CLRB	(R5)			; terminate
	RETURN				; all done
5600$:	ABORT	<ARGDCD:invalid literal  variable!>
;
;

;
;	Here to return the data stored in the field whose name is store
;	in a literal variable.
;
6000$:	.PUSH	R5			; save pointer
	CALL	INPUT			; get next character
	CMP	R0,#'L			; must be literal
	BNE	6600$			; not -> error
	CALL	INPUT			; get next character
	SUB	#'0,R0			; convert digit to binary
	CMP	R0,#3.			; valid index?
	BHI	6610$			; invalid index -> skip
	ASL	R0			; 002*index -> R0
	ASL	R0			; 004*index -> R0
	ASL	R0			; 008*index -> R0
	ASL	R0			; 016*index -> R0
	ASL	R0			; 032*index -> R0
	ASL	R0			; 064*index -> R0
	ASL	R0			; 128*index -> R0
	ADD	#L.....,R0		; R0 -> value
	MOV	(R0)+,R2		; R2 = number bytes
	BEQ	6620$			;	none -> error
6300$:	MOVB	(R0)+,(R5)+		; copy data
	SOB	R2,6300$		; loop
	CLRB	(R5)			; terminate
	.POP	R5			; restore pointer
	JMP	3277$			; get field data
6600$:	ABORT	<ARGDCD:no literal variable after @ operator!>
6610$:	ABORT	<ARGDCD:invalid literal index number!>
6620$:	.POP	R5			; restore R5
	MOV	#2,(R5)+		; assume type = string
	CLR	(R5)+			; lenght = 0
	RETURN				; exit
;;****	ABORT	<ARGDCD:no data in literal variable!>
;

.SBTTL	Primitive - "ARGINP"	...	Input argument value
;
;
;	This routine when called allows the oprtator to input a value
;	via the terminal for numeric, date or literal variables. The
;	Literal variables have names of the form 'L?', while numeric
;	variable names are 'N?', where ? is a digit 0-9. Date variable
;	names are of the format D0-D3.
;
;	Numeric variable N?/D? are stored as 16 bit numbers in the N.....
;	and D..... vectors at word offset ?.
;
;	Literal variable L? is allocated a 128 byte buffer at byte
;	offset 128*? from L.....; the first word is the number of
;	characters stored in the variable. The characters are stored
;	sequentially in the following bytes.
;
;	On exit R0 points to the variable that has been input.
;
ARGINP:	.PUSH	<R1,R2,R3,R4,R5>	; save
	CALL	INPUT			; get variable name
	DECODE	700$			; decode time
	.POP	<R5,R4,R3,R2,R1>	; restore
	RETURN				; exit
;
;
700$:	.WORD	'N,	1000$		; numeric variable
	.WORD	'D,	1400$		; date variable
	.WORD	'L,	2000$		; literal variable
	.WORD	 0,	 600$		; eot
;
600$:	ABORT	<ARGINP:invalid variable name!>
610$:	ABORT	<ARGINP:invalid variable index!>
;
;

;
;	Are here to input a number from TTY and store its value in N?.
;
1000$:	CALL	INPB1			;	get input
	CALL	DCDNUM			; R3 =	number's value
	CALL	INPUT			; R0 =	variable index
	SUB	#'0,R0			; R0 =	variable number
	CMP	R0,#9.			;	valid variable number?
	BHI	610$			;	 no -> abort
	ASL	R0			; R0 =	variable offset
	ADD	#N.....,R0		; R0 ->	storage area
	MOV	R3,(R0)			;	save value
	RETURN				;	all done
;
;	Are here to input a date from TTY and store its value in D?.
;
1400$:	CALL	INPB1			;	get input
	CALL	DCDDAT			; R3 =	date's value
	CALL	INPUT			; R0 =	variable index
	SUB	#'0,R0			; R0 =	variable number
	CMP	R0,#3			;	valid variable number?
	BHI	610$			;	 no -> abort
	ASL	R0			; R0 =	variable offset
	ADD	#D.....,R0		; R0 ->	storage area
	MOV	R3,(R0)			;	save value
	RETURN				;	all done
;

;
;	We are here to input a literal string from the terminal.
;
2000$:	CALL	INPUT			; get next character
	SUB	#'0,R0			; convert digit to binary
	CMP	R0,#3.			; valid index?
	BHI	610$			; invalid index -> skip
	ASL	R0			; 002*index -> R0
	ASL	R0			; 004*index -> R0
	ASL	R0			; 008*index -> R0
	ASL	R0			; 016*index -> R0
	ASL	R0			; 032*index -> R0
	ASL	R0			; 064*index -> R0
	ASL	R0			; 128*index -> R0
	ADD	#L.....+2,R0		; R0 -> buffer
	MOV	R0,R5			; R5 -> buffer
	MOV	#TMPB1,R0		; R0 -> IO buffer
	CALL	CON.LI			;	get input
	MOV	#TMPB1,R0		; R0 ->	source
	MOV	R5,R1			; R1 =	destination
2400$:	MOVB	(R0)+,(R1)+		;	copy
	BNE	2400$			;	loop
	SUB	R5,R1			; R1 =	size
	DEC	R1			;	ignore <NULL>
	CMP	R1,#126.		;	valid size?
	BHIS	2600$			;	too large -> abort
	MOV	R5,R0			; R0 ->	variable
	MOV	R1,-(R5)		;	setup size
	RETURN				; all done
2600$:	ABORT	<ARGINP:literal string too long!>
;
;

.SBTTL	Primitive - "FLDINP"	...	Input field name into litaral variable
;
; This routine is invoked to allow the operator to input the name of a field
; into a literal variable. It function is similar to ARGINP. The difference
; is that only a literal (L?) variable may be specified and the literal
; is checked to insure it is a valid field name.
;
;
FLDINP:	.PUSH	<R1,R2,R3,R4,R5>	; 	save
	CALL	INPUT			; R0 =	1st letter of variable name
	CMP	R0,#'L			;	must be an L
	ABORT	<FLDINP:invalid variable>,NE
	CALL	INPUT			; R0 =	2nd character of var name
	SUB	#'0,R0			;	convert digit to binary
	CMP	R0,#3.			;	must be a 0-3
	ABORT	<FLDINP:invalid variable>,HI
	ASL	R0			; R0 =	002*index
	ASL	R0			; R0 =	004*index
	ASL	R0			; R0 =	008*index
	ASL	R0			; R0 =	016*index
	ASL	R0			; R0 =	032*index
	ASL	R0			; R0 =	064*index
	ASL	R0			; R0 =	128*index
	ADD	#L.....+2,R0		; R0 -> buffer
	MOV	R0,R5			; R5 -> buffer
	BR	2100$			;	go get field name
;
2000$:	MOV	#7000$,R0		; R0 ->	warning message
	CALL	CON.LO			;	display it
2100$:	MOV	#TMPB1,R0		; R0 -> IO buffer
	CALL	CON.LI			;	get input
	MOV	#TMPB1,R1		; R1 ->	input
	MOV	$$FORM,R0		; R0 ->	template
	CALL	LOCFLD			;	valid field name?
	BCS	2000$			;	 no --> try again
;
	MOV	#TMPB1,R0		; R0 ->	source
	MOV	R5,R1			; R1 =	destination
2400$:	MOVB	(R0)+,(R1)+		;	copy
	BNE	2400$			;	loop
	SUB	R5,R1			; R1 =	size
	DEC	R1			;	ignore <NULL>
	CMP	R1,#126.		;	valid size?
	BHIS	2600$			;	too large -> abort
	MOV	R5,R0			; R0 ->	variable
	MOV	R1,-(R5)		;	setup size
	.POP	<R5,R4,R3,R2,R1>	; restore
	RETURN				; all done
2600$:	ABORT	<FLDINP:literal string too long!>
;
.nlist bin
7000$:	.ASCII	|FLDINP:invalid field name?|<15><12>
	.ASCII	|         Enter FIELD name: |<200>
.even
.list bin

.SBTTL	Primitive - "INPB1"	...	input line of text into TMPB1
;
;	This primitive is called to get a line of input from the console,
;	and to set up R4 with the address of a routine that will return the
;	line input a character at a time in R0.
;
INPB1:	MOV	#TMPB1,R0		; R0 -> IO buffer
	CALL	CON.LI			;	input -> buffer
	MOV	#TMPB1,7700$		;	setup fetch pointer
	MOV	#7400$,R4		; R4 =	address GETCHAR routine
	RETURN				;	all done for now
7400$:	MOVB	@7700$,R0		; R0 =	next character
	BEQ	7410$			;	eos -> skip
	INC	7700$			;	up pointer
7410$:	RETURN				;	exit
7700$:	.WORD	0			;	fetch pointer
;

.SBTTL	Primitive - 'DCDNUM'	...	decode numeric string
;
;
; This primitive is called with R4 holding the address of an 'INPUT' routine
; that returns the next character in a string that has to be decoded in R0.
; The function of the routine is to decode the numeric string returning the
; binary value equivalent to the (decimal) numeric string in R3. The delimiter
; that terminated the decoding is passed back in R0, and all other registers
; are preseved.
;
DCDNUM:	CLR	R3			; R3 =	accumulator
1000$:	CALL	@R4			; R0 =	next character
	SUB	#'0,R0			; R0 =	binary value of digit
	CMP	R0,#9.			;	is legal decimal digit?
	BHI	1700$			;	 no -> skip
	MUL	#10.,R3			; R3 =	total
	ADD	R0,R3			;	add in new digit
	BR	1000$			;	loop
1700$:	ADD	#'0,R0			; R0 =	terminating delimiter
	RETURN				;	exit
;
;

.SBTTL	Primitive - 'DCDDAT'	...	Decode date string
;
; This primitive is called with R4 holding the address of an 'INPUT' routine
; that returns the next character in a string that has to be decoded in R0.
; The function of the routine is to decode a DATE (DD-MM-YY) string and to
; it equivalent binary value in R3. The delimiter that terminated the 
; decoding is passed back in R0, and all other registers are preseved. The
; date format is
;				year	= bits 15-11 to base 1972
;				month	= bits  8-5
;				day	= bits  4-0
;
DCDDAT:	.PUSH	R2			;	save R2, needed as work reg
	CLR	R2			; R2 =	accumulator
	CALL	DCDNUM			; R3 =	day count
	JSR	R4,2400$		;	process day count
	.WORD	0.,31.,1.		;	base, max, shift
	CALL	DCDNUM			; R3 = 	month count
	JSR	R4,2400$		;	process month count
	.WORD	0.,12.,32.		;	base, max, shift
	CALL	DCDNUM$			; R3 =	year count
	JSR	R4,2410$		;	process year count
	.WORD	72.,31.,2048.		;	base, max, shift
	MOV	R2,R3			; R3 =	result
	.POP	R2			;	restore R2
	RETURN				;	exit
;
;	This code is called with a JSR R4 and uses the three words after
;	the call points as arguments needed to merge in the value passed
;	in R3 to the result being bulit in R2.
;
2400$:	CMPB	R0,#'-			;	valid delimieter?
	BNE	2600$			;	 no  -> abort
2410$:	TST	R3			;	count = 0?
	BEQ	2600$			;	 yes -> abort
	SUB	(R4)+,R3		;	convert to required base
	CMP	R3,(R4)+		;	count in range?
	BHI	2600$			;	 no -> abort
	MUL	(R4)+,R3		;	shift bits into niblet
	BIS	R3,R2			;	merge bits
	RTS	R4			;	exit
2600$:	ABORT	<DCDDAT:invalid DATE string!>
;

.SBTTL	Primitive - "ARGCMP"	...	comapre arguments
;
;
; The following routine is called to compare the arguments stored in the
; buffers pointed to by R0 and R1 at entry. These buffers are structured as 
; follows
;		.WORD	Arg type
;		.WORD	Arg size
;		.BLKW	value
;
; The routine sets the PSW at exit as if a CMP ARG0,ARG1 instruction was done.
; Registers R0, R1 and R2 are volitile.
;
;
;
;	Dispatch control to correct code for argument types.
;
ARGCMP:	CMP	(R0),(R1)			; same types?
	BNE	600$				; no -> abort
	MOV	#700$-4,R2			; R2 -> table
100$:	ADD	#4,R2				; R2 ->	next entry
	TST	(R2)				; eot?
	BMI	610$				; yes -> error
	CMP	(R0),(R2)			; match?
	BNE	100$				; no -> loop
	JMP	@2(R2)				; envoke test code
;
600$:	ABORT	<ARGCMP:argument types different!>
610$:	ABORT	<ARGCMP:illegal argument type>
700$:	.WORD	00,	1000$			; numeric
	.WORD	02,	2000$			; string
	.WORD	-1,	 610$			; eot
;
;
;	This code is called to compare two numeric arguments.
;
1000$:	CMPB	4(R0),4(R1)		; MSB same?
	BNE	1100$			;  no -> done
	CMPB	5(R0),5(R1)		; LSB same?
1100$:	RETURN				; all done
;
;	This code is called to compare two ascii strings.
;
2000$:	ADD	#4,R0			; R0 ->	data
	ADD	#4,R1			; R1 ->	data
	MOV	-2(R0),R2		; R2 =	number bytes in arg 1
	CMP	R2,-2(R1)		;	is this shortest?
	BLOS	2100$			;	yes -> loop time
	MOV	-2(R1),R2		;	use shorter lenght
2100$:	TST	R2			;	lenght=0?
	BEQ	2200$			;	 yes -> exit
2110$:	MOVB	(R1)+,-(SP)		; SP ->	character @R1
	CALL	3000$			;	insure upper case
	MOVB	(R0)+,-(SP)		; SP ->	character @R0
	CALL	3000$			;	insure upper case
	CMPB	(SP)+,(SP)+		;	do a CMPB (R0)+,(R1)+
	BNE	2200$			;	different -> stop
	SOB	R2,2110$		;	loop till all done
2200$:	RETURN				;	bye
;
; This routine is called to convert the character pushed onto the stack
; into Upper Case.
;
3000$:	CMPB	2(SP),#140		;	is character LC?	
	BLO	3100$			;	 no --> skip
	BIC	#40,2(SP)		;	 yes ->	make UC
3100$:	RETURN				;	done
;

.SBTTL	Primitive - "OPRDCD"	...	Decode operator
;
; This routine is used to decode the operator contained in the input
; stream. It returns in R0 the equivalent conditional branch instruction
; in R0 that will cause a PDP11 to skip one (1 word) instruction if the
; condition is met.
;
OPRDCD:	.PUSH	<R1,R2,R3,R4,R5>	; save
	CALL	INPUT			; get character
	MOV	R0,R1			; save character
	CALL	INPUT			; get second character
	SWAB	R0			; switch char to HOB
	ADD	R1,R0			; operator -> R0
;
	CLR	R1			; R1 =	index
2100$:	CMP	R0,2710$(R1)		;	found match
	BEQ	2300$			;	yes -> skip
	ADD	#2,R1			;	bump up
	TST	2710$(R1)		;	hit EOT?
	BNE	2100$			;	no -> loop
2200$:	ABORT	<..TEST:invalid operator!>
2300$:	MOV	2720$(R1),-(SP)		;	save instruction
	CALL	INPUT			;	get character
	CMP	R0,#'.			;	delimiter?
	BNE	2200$			;	no -> abort
	.POP	<R0,R5,R4,R3,R2,R1>	;	restore
	RETURN				;	exit
;
;
;  Tables of valid operators and equivalent PDP11 instructions. The entries in
;  the two tables must correspond, so that when an operator in the 2710$ table
;  is decoded, the correct PDP11 code from the 2720$ table is returned.
;
2710$:	.WORD	"EQ			; operator
	.WORD	"GE			; operator
	.WORD	"GT			; operator
	.WORD	"LE			; operator
	.WORD	"LT			; operator
	.WORD	"NE			; operator
	.WORD	"eq			; operator
	.WORD	"ge			; operator
	.WORD	"gt			; operator
	.WORD	"le			; operator
	.WORD	"lt			; operator
	.WORD	"ne			; operator
	.WORD	0			; eot
;
2720$:	BEQ	.+4			; equivalent instruction
	BHIS	.+4			; equivalent instruction
	BHI	.+4			; equivalent instruction
	BLOS	.+4			; equivalent instruction
	BLO	.+4			; equivalent instruction
	BNE	.+4			; equivalent instruction
	BEQ	.+4			; equivalent instruction
	BHIS	.+4			; equivalent instruction
	BHI	.+4			; equivalent instruction
	BLOS	.+4			; equivalent instruction
	BLO	.+4			; equivalent instruction
	BNE	.+4			; equivalent instruction
;

.SBTTL	Primitive - "ABORT"	...	abort program execution
;
; get here if program is to be aborted; at entry R1 holds address of
; .ASCIZ string that gives reason of abort. This string is printed along
; with data from format file to allow error point to be found.
;
;
ABORT:	.PRINT	#7000$			;	header
	.PRINT	R1			;	reason for abort
	.PRINT	#7100$			;	trailer
;
	MOV	#70.,R2			; R2 =	counter
1000$:	CALL	FRMINC			;	input char
	BCS	1700$			;	abort if EOS
	.TTYOUT				;	output character
	SOB	R2,1000$		;	loop
1700$:	.EXIT				;	done
;
.nlist	bin
7000$:	.ASCII	<15><12>|SELECT-fatal-|<200>
7100$:	.ASCIZ	<15><12>| error in format file before:|
.even
.list	bin
;

.SBTTL	Variables
;
$$FORM:	.WORD	FORM$$			; address of template
RECNUM:	.WORD	0			; number of record in memory
N.....:	.WORD	0,0,0,0,0,0,0,0,0,0	; Variables N0 to N9
D.....:	.WORD	0,0,0,0,0,0,0,0,0,0	; Variables D0 to D4 (D5-D9 reserved)
L.....:	.WORD	0			; Literal variable L0	size
	.BLKB	126.			;			data
	.WORD	0			; Literal variable L1	size
	.BLKB	126.			;			data
	.WORD	0			; Literal variable L2	size
	.BLKB	126.			;			data
	.WORD	0			; Literal variable L3	size
	.BLKB	126.			;			data
;
P.ACPT:	.WORD	0			; 0 -> accepted, 1 -> not accepted
P.SIZE:	.WORD	0			; size of sorter records
TMPB1:	.WORD	0			; type
	.WORD	0			; size
	.BLKB	400			; data area
TMPB2:	.WORD	0			; type
	.WORD	0			; size
	.BLKB	2000			; data area
;
;
.END	START