Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-04 - 43,50343/vetrc.mac
There is 1 other file named vetrc.mac in the archive. Click here to see a list.
	TITLE	VETRC
;THIS PROGRAM VETS THE INPUT FIELD SPECIFICATION
;AND CONSTRUCTS THE  INTERNAL RECORD
;
;
;
;   JOHN KAY  DEC UK
;
	EDITNO==:1	;EDIT NO
	VERSION==:1	;MAJOR VERSION NO;
	VMINOR==:0	;MINOR VERSION NO;
	VWHO==:0	;WHO LAST EDITED
	JOBVER==:137	;LOC OF VERSION IN JOB DATA AREA
	%VERS==:<BYTE(3)VWHO(9)VERSION(6)VMINOR(18)EDITNO>
	ENTRY	RECCK,RECRIT,RECRED,OUTIO
	EXTERN	.JBFF
	ENTRY	VETRC,GENREC,DVALUE,INITIO,OVALUE,CLOS




		P=17
		AC=3
		ER=AC+1
		B=ER+1
		C=B+1
		D=C+1
		E=D+1
		F=E+1
		G=F+1		;INDEXING BRICK
		H=G+1
;***************************************************
;***************************************************

;
;TRANSFER FILENAME AND INITIALISE
;OUTPUT FILE
;
INITIO:	PUSHJ	P,FILMOV		;MOVE FILENAME
	JRST	CALLR
FILMOV:	MOVE	AC,1(16)
	MOVEM	AC,ERRNO	;ERROR NO
	MOVE	AC,@(16)	;FILENAME BYTE POINTER
	HRRZI	C,7		;LOOP COUNT
	SETZ	ER,		;CLEAR ERROR
	SETZM	EEE		;CLEAR FILE NAME AREA
	MOVE	D,EPT		;GET BYTE POINTER
ENXT:	ILDB	B,AC		;GET CHAR
	CAIN	B,16		;IS IT FULL STOP
	JRST	EXTM		;YES GET EXT
	IDPB	B,D			;
	SOJN	C,ENXT
	JUMPA	ERRS1		;
EXTM:	HRRZI	C,3		;MOVE EXTENSION
	MOVE	D,EPTA		;GET BYTE POINTER
EXTMA:	ILDB	B,AC		;THREE WORDS
	IDPB	B,D
	SOJN	C,EXTMA		
	POPJ	P,		;END OF SRTN

CALLR:	CALL	[SIXBIT/RESET/]	;INIT IO


	POPJ	P,		;EXIT
;****************************************************
;****************************************************
;
;INITIAISE AND SET UP OUTPUT FOR DATA RECORDS
;
;
OUTIO:	MOVE	AC,@(16)		;SIXBIT
	MOVEM	AC,SIXB

	MOVEI	AC,10		;SET UP OUTPUT TYPE
	SKIPN	SIXB		;IS IT SIXBIT
	HRRM	AC,.+1		;YES

	INIT	3,0		;INIT FILE
	SIXBIT	/DSK/
	XWD	OBUF,
	JRST	E1		;ERROR

	MOVEI	AC,ABC
	MOVEM	AC,.JBFF
	OUTBUF	3,2
	ENTER	3,EEE		;SELECT FILE
	JRST	E2		;ERROR

	POPJ	P,		;EXIT
;
;
;CHECK FOR UNIQUENESS OF RECORD IDENTIFIER
;
RECCK:	MOVE	AC,@(16)	;START OF INT REC LAYOUT
	MOVEM	AC,BRICK
	MOVE	AC,@1(16)	;REC ID
	MOVEM	AC,RECID
	MOVE	AC,2(16)
	HRRZM	AC,N		;ADDR OF N
	SETZ	ER,		;CLEAR ERROR FLAG
	MOVE	C,@N		;COUNT FOR LOOP
	MOVE	B,[-1]
RNR:	SOJE	C,RECEN		;END OF AREA
	AOS	BRICK		;WORD WITH REC ID
	LDB	AC,PTI
	CAMN	AC,RECID	;SAME ID
	JRST	ERRS1		;YES NO GOOD
RNEXT:	AOS	BRICK		;NEXT WORD
	SOJE	C,RECEN		;END OF AREA
	CAME	B,@BRICK	;START OF RECORD
	JRST	RNEXT		;NEXT WORD
	JRST	RNR		;NEXT RECORD
RECEN:	SETZM	POINT		;CLEAR OVERLAP POINTER
	POPJ	P,		;END OF SEARCH
;***************************************************
;***************************************************
;
;
; VET THE INPUT -FIELD LAYOUTS- OF THIS RECORD
;
VETRC:	MOVE	AC,@(16)	;FIRST PARAM
	MOVEM	AC,PA		;STORE BYTE POINTER
	MOVE	AC,@1(16)	;INTERNAL BUFFER
	MOVEM	AC,BRICK	;OUTPUT AREA
	MOVE 	AC,2(16)	;N
	MOVEM	AC,N		;POINTER TO NEXT WORD IN OUTPUT WORD
	MOVE	AC,@3(16)	;SIXBIT
	MOVEM	AC,SIXB
;
;INITIALISE OUTPUT
				;
	SETZ	ER,		;CLEAR ERROR MARKER REG
	MOVE	AC,@N		;CONTENTS OF INC
	SOJ	AC,
	ADDM	AC,BRICK	;UPDATE CURRENT POINTER
;
;FIND FIRST TAB IN INPUT BUFFER -THE END OF
;THE FIELD DESCRIPTION
;
TABS:	ILDB	AC,PA		;NEXT BYTE
	CAIE	AC,11		;IS IT TAB
	JUMPA	TABS		;NO
;
;VALIDATE THE FIELD TYPE AND STORE APPROPRIATE
;FIELD TYPE IN INTERNAL RECORD
;VALID TYPES ARE - A,X,N,C,F
;
	ILDB	AC,PA		;NEXT INPUT BYTE- FIELD TYPE
	SETZ	B,
	CAIN	AC,101		;IS IT A
	AOJA	B,.+2		;YES TYPE 5
	CAIN	AC,130		;IS IT X
	AOJA	B,.+2		;YES TYPE 4
	CAIN	AC,116		;IS IT N
	AOJA	B,.+2		;YES TYPE 3
	CAIN	AC,103		;IS IT C
	AOJA	B,.+2		;YES TYPE 2
	CAIN	AC,106		;IS IT F
	AOJA	B,.+2		;YES TYPE 1
	JUMPA	ERRS2		;NO
	MOVE	E,B		;PRESERVE TYPE
	DPB	B,PTA		;PUT MARK IN BRICK
	ILDB	AC,PA		;NEXT INPUT BYTE-TAB
	CAIE	AC,11		;IS IT
	JUMPA	ERRS2		;NO HARD LUCK
;
;VALIDATE INPUT METHOD AND STORE INTERNAL
;REPRESENTATION IN INTERNAL AREA
;VALID TYPES ARE - P THRU W INC
;
	ILDB	AC,PA		;NEXT BYTE -INPUT METHOD
				;BETWEEN P-W INC
	MOVEI	B,10		;LOOP COUNT
	MOVEI	C,117		;START VALUE
INM:	AOJ	C,
	CAME	AC,C		;IS CHAR OK
	SOJG	B,INM		;NO TRY NEXT
	SOJL	B,ERRS3		;FAIL IF COUNT LT 0
	DPB	B,PTB		;PUT MARK IN BRICK
	ILDB	AC,PA		;NEXT BYTE -TAB
	CAIE	AC,11		;IS IT
	JUMPA	ERRS3		;NO
;
;VALIDATE CHARACTER POSITION AND CONVERT TO
;BINARY IF OK   STORE IN INTERNAL RECORD
;
	PUSHJ	P,CONV		;CONVERT CH POS FROM DEC
	JUMPA	ERRS4		;NO GOOD
	MOVE	C,POINT		;END OF LAST FIELD
	CAMGE	B,C		;IS IT OK
	JUMPA	ERRS5		;FIELDS OVERLAP
	CAIN	B,0		;IS START POS 0
	JRST	ERRS4		;NO
	MOVE	D,B		;PRESERVE ST POS
	CAIL	E,3		;TYPE LS 3
	JUMPA	STOK		;NO -START OK
	MOVE	C,SIXB		;YES
	JUMPN	C,ERRS6		;BIN FIELD IN ASCII REC
	ADDI	B,5		;FIRST CHAR IN POS 1
	IDIVI	B,6		;FULL WORD ALIGNED
	JUMPN	C,ERRS7		;REM -NO GOOD
STOK:	DPB	D,PTC		;STORE START POSN
;
;VALIDATE FIELD LENGTH
;AND STORE IN INTERNAL RECORD
;
	PUSHJ	P,CONV		;FIELD LENGTH OK
	JUMPA	ERRS8		;NO GOOD
	CAIL	E,3		;TYPE 1 OR 2
	JUMPA	STFL		;NO
	CAIN	B,6		;IS FIELD LENGTH 6
	JUMPA	STFL		;YES ITS OK
	CAIE	E,2		;IS TYPE 2
	JUMPA	ERRS8		;NO- FIELD LENGTH BAD
	CAIE	B,12		;IS FIELD LENGTH 12
	JUMPA	ERRS8
	JRST	ERRS12		;DOUBLE LENGTH NOT IMPL
STFL:	MOVE	F,B		;PRESERVE LENGTH
	DPB	B,PTD		;STORE FIELD LENGTH
;
;VALIDATE INITIAL VALUE 
;STORE INTERNALLY IF PRESENT
;
	MOVE	G,BRICK		;SET UP BYTE POINTER
	PUSHJ	P,INIT		;CHECK INIT VALUE
	JUMPA	ERRS9		;INIT VALUE NO GOOD
	JUMPA	INCN		;NO INC
	ILDB	AC,PA		;INCREMENT
	CAIE	AC,40		;IS FIRST CH SP
	JUMPA	INCVT		;NO
	LDB	B,PTB		;INPUT FORM
	SETZ	AC,		;INC ZERO
	CAIN	B,1		;IS IT V
	MOVEI	AC,1		;YES PROVIDE DEFAULT INC
	DPB	AC,PTF		;SET ZERO INC
	JUMPA	INCN		;
;
;VALIDATE INCREMENT IF PRESENT
;AND STORE INTERNALLY
;
INCVT:	PUSHJ	P,CONV+1	;VET INC
	JUMPA	ERRS10		;INC NO GOOD
	DPB	B,PTF		;PUT INC IN PLACE
INCN:	AOS	@N		;INC POINTER N
	LDB	D,PTD		;LENGTH
	LDB	C,PTC		;START ADDR
	ADD	D,C
	MOVEM	D,POINT		;RESET OVERLAP POINTER
EXT:	POPJ	P,		;EXIT
				;
;
;THIS SECTION VETS THE INITIAL VALUE
;OF THIS FIELD IF ONE IS GIVEN
;NO INITIAL VALUE IS RECOGNISED BY A FIELD OF SPACES
;

INIT:	SETZ	D,		;CLEAR BLANK FIELD MARKER
	AOS	G
	SETZ	AC,		;
	DPB	AC,PTE		;SET NO INIT VALUE
	ILDB	AC,PA		;GET FIRST CHAR
	CAIN	AC,11		;IS IT A TAB
;
;ALTHOUGH THERE IS NO INITIAL VALUE THERE MAY BE 
;AN INCREMENT
;
	JRST	NOINIT		;NO FIELD
	CAIG	E,2		;TYPE 3,4,5
	JRST	TYP12		;NO TYPE 1 OR 2
	MOVE	C,SIXB		;SIXBIT MARKER
	MOVE	B,PTH		;SIXBIT BYTE POINTER
	SKIPE	SIXB		;SIXBIT?
	MOVE	B,PTG		;NO
	CAIE	AC,40		;IS IT A SPACE
	JRST	CHTST		;NO
	CAIE	E,3		;IS FIELD NUMERIC
	JRST	CHAROK		;NO
	JRST	NOINIT		;NO INITIAL VALUE
				;AND END OF INPUT
CHTST:	MOVEI	D,1		;FIELD NOT ALL SPACES
	CAIN	E,4		;TYPE = 4
	JRST	CHAROK		;YES ANY CHAR OK
	CAIN	E,5		;TYPE = 5
	JRST	TYP5		;YES
	PUSHJ	P,NUMR		;TYPE = 3
	JRST	EXTZ		;NUMBER INVALID
	JRST	CHAROK		;VALID CHARACTER
TYP5:	PUSHJ	P,ALPHA		;TEST ALPHACHAR
	JRST	EXTZ		;LETTER INVALID
;
;AT THIS POINT THE INPUT CHARACTER IS 
;OK AND CAN BE STORED IN THE INTERNAL
;RECORD
;
CHAROK:	JUMPN	C,NXTCH
	PUSHJ	P,SIXCT		;CONVERT TO SIXBIT CHAR
	JRST	EXTZ		;NO GOOD
NXTCH:	IDPB	AC,B		;STORE BYTE

	ILDB	AC,PA		;NEXT CHARACTER
	SOJL	F,ERRIN		;TOO LONG
	CAIN	AC,11		;IS IT TAB
	JRST	EXTIN		;END WITH VALID FIELD
	CAIE	AC,40		;IS IT SPACE
	JRST	CHTST		;NO
	CAIN	F,0		;VALID FIELD END WITH SPACES
	JUMPE	D,NOINIT	;ALL SPACES
	JUMPE	F,EXTIN
	CAIE	E,3		;NUMERIC FIELD
	JRST	CHAROK		;NO
	JUMPE	F,EXTIN		;SPACE OK AT END
	JRST	EXTZ		;NO GOOD IN MIDDLE
;
;TO REACH THIS POINT TOO MANY CHARACTERS
;HAVE BEEN VETTED- EITHER
;FIELD ALL SPACES - NO INIT VALUE
;OR INPUT TOO LONG - HARD LUCK
;
ERRIN:	JUMPE	D,NOINIT		;ALL SPACES
	JRST	EXTZ	;INPUT TOO LONG
;
;EXIT SECTION
;
EXTIN:	MOVEI	AC,1		;INIT VALUE- YES
	DPB	AC,PTE		;SET MARKER
	PUSHJ	P,CLENGT
UPP:	ADDM	B,@N		;N+SIZE OF INIT FIELD

EXTZB:	AOS	(P)		;GOOD EXIT-EXPECT INC
EXTZA:	AOS	(P)		;END OF INPUT
EXTZ:	POPJ	P,		;NO GOOD
;
;NO INITIAL VALUE PROVIDED BY THE USER
;SO THE PROGRAM MUST CONSTRUCT ONE
;
NOINIT:	LDB	AC,PTB		;INPUT FORM
	CAIE	AC,7		;IS IT P
	CAIN	AC,0		;OR IS IT W
	JRST	EXTZB		;YES -DONT NEED INITIAL VAL
	LDB	E,PTA		;TYPE
	MOVE	B,PTH		;CORRECT BYTE POINTER;
	SKIPE	SIXB
	MOVE	B,PTG
	LDB	C,PTD		;LENGTH (LOOP COUNT)

	CAIG	AC,2		;IS IT U OR V
	JRST	RANLOP		;YES -RANDOM VALUES
	SETZ	AC,		;NO -Q,R,S,T
	CAIG	E,2		;TYPES 1 OR 2
	JRST	SPIN
	CAIN	E,3		;IS IT A NUM
	ADDI	AC,20		;YES MAKE NUMBER ZERO
	SKIPE	SIXB		;IS IT ASCII
	ADDI	AC,40		;YES

SPIN:	IDPB	AC,B		;STORE CHARACTER
	SOJN	C,SPIN		;NEXT ONE?
	JRST	EXTIN		;

RANLOP:	PUSHJ	P,GNXT		;GET A RANDOM CHAR
	IDPB	AC,B		;STORE IN INITIAL VALUE
	SOJN	C,RANLOP	;NEXT ONE?
	JRST	EXTIN
;
;THIS SECTION FOR TYPES 1 AND 2 ONLY
;
TYP12:	PUSHJ	P,COMP1	
	CAIN	AC,40		;FIRST CHAR A SPACE
	JRST	NOINIT		;YES NO INIT VALUE
	CAIE	E,2		;IS IT TYPE 2
	JRST	TYP1		;NO -FLOATING POINT
	PUSHJ	P,CHL		;CONVERT TO BINARY
	JRST	EXTZ		;NO GOOD
	CAIN	D,1
	MOVN	B,		;MAKE NEGATIVE
	MOVE	E,PTN		;BYTE POINTER
	IDPB	B,E		;STORE WORD
	JRST	EXTIN		;
;FLOATING POINT ONE WORD
TYP1:	JRST	ERRS11		;NOT IN YET
COMP1:	CAIE	AC,55		;IS IT MINUS
	JRST	TPLUS		;NO
	MOVEI	D,1		;SET NEGATIVE MARKER
	JRST	TNEXT
TPLUS:	SETZ	D,		;CLEAR MINUS MARKER
	CAIN	AC,53		;IS IT PLUS
TNEXT:	ILDB	AC,PA		;NEXT BYTE
TNEXTA:	SETZ	B,		;CLEAR TOTAL
	MOVEI	C,12		;COUNT FOR CONVERT
	POPJ	P,		;EXIT
;
;SUBR - TEST VALIDITY OF N TYPE FIELD CHARS
;
NUMR:	CAIN	AC,53		;IS IT A PLUS
	JRST	NUMRA		;YES
	CAIN	AC,55		;MINUS SIGN
	JRST	NUMRA		;YES
NUMRD:	CAIGE	AC,60		;VALID DIGIT
	JRST	NUMRB		;NO	
	CAILE	AC,71		;
	JRST	NUMRB		;
NUMRA:	AOS	(P)		;GOOD EXIT
NUMRB:	POPJ	P,		;
;
;CHECK VALIDITY OF ALPHA CHARACTERS - SRTN
;
ALPHA:	CAIN	AC,40		;IS CHAR A SPACE
	JRST	ALPHAA		;YES
	CAIGE	AC,101		;GE A
	JRST	ALPHAB		;NO
	CAILE	AC,132		;LE Z
	JRST	ALPHAB		;
ALPHAA:	AOS	(P)		;GOOD EXIT
ALPHAB:	POPJ	P,		;
;
;SRTN- CONVERT DEC FIELD TO BINARY
;
CONV:	ILDB	AC,PA		;CHAR
	SETZ	B,		;CLEAR ACC
	MOVEI	C,7		;LOOP COUNT
CHL:	CAIGE	AC,60		;GE 0
	JRST	EXTB		;OUT OF RANGE
	CAILE	AC,71		;LE 9
	JRST	EXTB		;OUT OF RANGE
	IMULI	B,12		;MULT BY 10
	SUBI	AC,60		;ASCII TO BINARY
	ADD	B,AC		;ADD IN NEW CHAR
	ILDB	AC,PA	;
	CAIN	AC,11		;IS IT TAB
	JRST	EXTA		;YES
	CAIN	AC,40		;IS IT A SPACE
	JRST	EXTA		;(FOR END OF INC)
	SOJG	C,CHL		;NO IS FIELD TOO LONG
	JRST	EXTB		;TOO LONG
EXTA:	AOS	(P)		;UPDATE TOP OF STACK
EXTB:	POPJ	P,		;ERRORS ST OUT
				;
				;
ERRS12:	ADDI	ER,1
ERRS11:	ADDI	ER,1
ERRS10:	ADDI	ER,1
ERRS9:	ADDI	ER,1
ERRS8:	ADDI	ER,1
ERRS7:	ADDI	ER,1
ERRS6:	ADDI	ER,1
ERRS5:	ADDI	ER,1
ERRS4:	ADDI	ER,1
ERRS3:	ADDI	ER,1
ERRS2:	ADDI	ER,1
ERRS1:	ADDI	ER,1
	MOVEM	ER,@ERRNO
	POPJ	P,		;EXIT
				;
				;
PA:	0		;BYTE POINTER INPUT TO VET -INRECF(M)
BRICK:	0		;INTERNAL AREA ADDR
N:	0		;COUNTER FOR COBOL USE
ERRNO:	0		;ERROR NO
PTA:	POINT	3,@BRICK,2
PTB:	POINT	3,@BRICK,5
PTC:	POINT	13,@BRICK,18
PTD:	POINT	10,@BRICK,28
PTE:	POINT	1,@BRICK,29
PTF:	POINT	6,@BRICK,35
PTG:	POINT	7,(G)	;ASCII FOR INIT VALUE
PTH:	POINT	6,(G)	;SIXBIT
PTN:	POINT	36,(G)		;DEPOSIT WORD
SIXB:	0	;SIXBIT MARKER
POINT:	0	;POSITION IN REC INDIC
;
;OUTPUT WORK AREAS AND ERROR ROUTINES
;
EPT:	POINT	6,EEE
EPTA:	POINT	6,EEE+1
ABC:	BLOCK	406		;BUFFERS
OBUF:	BLOCK	3		;OUTPUT BUFFER RING
EEE:	SIXBIT/OUTPUT/
	0
	0
	0

E1:	MOVEI	ER,20
	JRST	E3A
E2:	MOVEI	ER,21
	JRST	E3A

E3:	MOVEI	ER,22
E3A:	MOVEM	ER,@ERRNO
	POPJ	P,






;***************************************************
;***************************************************
;
;THIS SECTION CONDUCTS THE DIALOG WITH THE USER
;TO GENERATE THE OUTPUT RECORD HE DESIRES
;
GENREC:	MOVE	AC,@(16)	;TRANSFER PARAMETERS
	MOVEM	AC,BRICK	;START OF INT REC DESC
	MOVE	AC,@1(16)	;RECID
	MOVEM	AC,RECID
	MOVE	AC,@2(16)	;PROMPT MESSAGE AREA
	MOVEM	AC,DPROMT
	MOVE	AC,@3(16)
	ILDB	AC,AC		;GET FIELD SEP
	MOVEM	AC,FSEP		;STORE

	MOVE	AC,@4(16)	;USER INPUT AREA
	MOVEM	AC,PA		;STORE BYTE POINTER
	HRRZ	AC,DPROMT
	MOVEM	AC,ENDBUF	;STORE END OF BUFFER
	MOVE	AC,5(16)
	MOVEM	AC,PROMM	;STORE INDICATOR
	SETZ	ER,		;CLEAR ERROR FLAG
;
;SEARCH FOR CORRECT INTERNAL RECORD SPECIFICATION
;
	MOVE	B,[-1]		;
	JRST	GNEXT
GRECC:	CAMN	AC,RECID	;CORRECT ID
	JRST	GFOUND		;YES
GNEXT:	AOS	BRICK		;POINT TO NEXT WORD
	CAME	B,@BRICK	;START OF RECORD
	JRST	GNEXT		;NO
	AOS	BRICK		;NEXT WORD
	LDB	AC,PTI		;CHECK FOR END OF TABLE
	CAIN	AC,77		;IS IT END
	JRST	ERRS1		;YES
	JRST	GRECC		;NO
;
;HERE THE CORRECT RECORD ID HAS BEEN FOUND
;NOW FILL OUTPUT AREA WITH FILLERS
;
GFOUND:	LDB	AC,PTJ		;FILLER CHAR
	SKIPE	SIXB		;IS IT SIXBIT
	ADDI	AC,40		;CONVERT CHAR TO ASCII
	LDB	B,PTK		;RECORD LENGTH
	MOVEM	B,ORECL		;SAVE FOR OUTPUT
	MOVE	C,OPTB		;SELECT CORRECT BYTE POINTER
	SKIPN	SIXB		;SIXBIT
	MOVE	C,OPTA		;YES
GNEXTA:	IDPB	AC,C		;FILL REC WITH FILLERS
	SOJN	B,GNEXTA	;LAST ONE?
;
;OUTPUT RECORD BUFFER FILLED WITH FILLER
;CHARACTER NOW SET UP PROMPT MESSAGE
;IF LAST FIELD SPEC OUTPUT RECORD
;
GPROMT:	AOS	BRICK		;INC INTERNAL POINTER
	MOVE	B,[-1]		;HIGH VALUES
	CAMN	B,@BRICK	;NEXT WORD END
	JRST	GOUTPT		;YES OUTPUT RECORD
	MOVE	AC,@BRICK	;FIELD DESCRIPTION
	MOVEM	AC,@DPROMT	;MOVE TO PROMPT
	AOS	DPROMT		;SET UP POINTERS
	AOS	BRICK		;
	LDB	B,PTC		;LOAD START POSN
	SETZ	AC,		;CLEAR COUNT
	SETZ	E,		;CLEAR TOTAL
GDEC:	IDIVI	B,12		;CONVERT TO DEC
	PUSH	P,C		;SAVE REMAINDER
	AOJ	AC,		;INC AC
	SKIPE	B		;ALL DIGITS FORMED
	PUSHJ	P,GDEC		;NO COMPUTE NEXT
GDEC1:	POP	P,B		;TAKE OUT CHARACTER
	ADDI	B,20		;CONVERT TO SIXBIT
	ADD	E,B		;ADD IN NEW CHAR
	SOJE	AC,GSTFN	;LAST ONE
	LSH	E,6		;NO SHIFT UP
	POPJ	P,GDEC1		;GET NEXT CHAR

GSTFN:	HRRZI	B,3	;LOOP COUNT
GSHIFT:	CAIG	E,400000	;LEFT JUSTIFY NO
	LSH	E,6		;MOVE ONE PLACE
	SOJG	B,GSHIFT	;AGAIN
	HRLI	AC,4300		;CONSTANT OF C
	ADD	E,AC		;ADD IN TO START POS
	MOVEM	E,@DPROMT	;STORE IN PROMPT
	AOS	DPROMT		;UPDATE PROMPT POINTER
	LDB	AC,PTA		;INPUT TYPE
	CAIN	AC,1		;IS IT TYPE 1
	HRRZI	B,46		;YES F
	CAIN	AC,2		;IS IT TYPE 2
	HRRZI	B,43		;YES C
	CAIN	AC,3		;IS IT TYPE 3
	HRRZI	B,56		;YES N
	CAIN	AC,4		;IS IT TYPE 4
	HRRZI	B,70		;YES X
	CAIN	AC,5		;IS IT TYPE 5
	HRRZI	B,41		;YES A
	LSH	B,30		;SHIFT TO POSITION
	ADDI	B,320000	;MOVE IN :
	MOVEM	B,@DPROMT	;STORE IN PROMPT
	SOS	DPROMT
	SOS	DPROMT
;
;THE PROMPT MESSAGE IS NOW SET UP IN TOTAL
;NOW CHECK WHETHER OR NOT IT IS REQUIRED
;AT THIS STAGE OR WHETHER USER HAS ALREADY
;SUPPLIED INPUT FOR THIS FIELD
;
	LDB	B,PTB		;INPUT FORM
	CAIG	B,2		;IS IT P-T
	JRST	GNOUS		;NO USER VALUE POSS
	MOVE	B,FSEP		;YES GET FIELD SEP
	CAIN	B,177		;IS IT CR
	POPJ	P,		;YES EXIT

	PUSHJ	P,GEMPTY	;NO-ANY MORE DATA
	JRST	ANYIN
	JRST	DVAL2		;DATA IN BUFFER
ANYIN:	MOVE	AC,@PROMM
	SOSE	AC
	POPJ	P,
	JRST	GNOUS
;
;ENTRY POINT AFTER USER HAS TYPED IN A VALUE
;OR A CARRIAGE RETURN OR A VALUE IS ALREADY IN
;THE INPUT BUFFER
;
DVALUE:	MOVE	AC,@(16)	;RESET INPUT BYTE POINTER
	MOVEM	AC,PA
	MOVE	AC,@1(16)	;PROMPT AREA
	MOVEM	AC,DPROMT
	HRRZI	AC,1
	MOVEM	AC,@PROMM	;PROMPT SENT MARK=1
	SETZ	ER,		;SET ERROR MARKER ZERO
DVAL2:	PUSHJ	P,GEMPTY	;HAS USER PUT IN A VALUE
	JRST	GNOUS		;NO USER VALUE
	MOVE	B,FSEP		;GET FIELD SEP
	PUSHJ	P,DRANGE	;GET NEXT VALUE -RANGE CHECK
	JRST	ERRS2		;NO GOOD
	LDB	D,PTB		;GET INPUT METHOD
	CAIE	D,3		;IS IT T
	JRST	DVAL3		;NO TRANSFER REQ
;
;TRANSFER USERS INPUT VALUE TO INTERNAL RECORD
;FOR NEXT TIME USE IF TYPE T
;
DVAL4:	MOVE	D,PTH		;SELECT CORRECT BYTE POINTER
	SKIPE	SIXB
	MOVE	D,PTG
	MOVE	G,BRICK		;SET POINTER TO INIT VALUE
	AOS	G
	PUSHJ	P,PNTPOS	;POSITION OUTPUT POINTERS
	LDB	E,PTD		;LENGTHD
DVAL5:	ILDB	AC,C		;GET FROM OUTPUT REC
	IDPB	AC,D		;PLACE IN INIT VALUE
	SOJN	E,DVAL5		;NEXT BYTE
;
;THE OUTPUT RECORD VALUE FOR THIS FIELD HAS
;BEEN SET UP OK - GO AND SEND USER PROMPT
;
DVAL3:	SETZ	B,		;CLEAR COUNT
	LDB	AC,PTE		;IS INIT VALUE PRESENT
	SKIPE	AC		;
	PUSHJ	P,CLENGT		;YES CALC LENGTH
	ADDM	B,BRICK		;LENGTH OF INIT VALUE
	SETZ	AC,		;CLEAR PROMPT SENT
	MOVEM	AC,@PROMM
	JRST	GPROMT		;GET NEXT FIELD
;
;THIS SECTION IS ENTERED IF THE USER HAS
;NOT INPUT ANY VALUE - THEREFORE THE ROUTINE
;WILL GENERATE A SUITABLE ONE
;
GNOUS:	LDB	B,PTB		;INPUT FORM
	CAIN	B,5		;IS INPUT FORM R
	JRST	ADDINC		;YES
	CAIN	B,3		;IS INPUT FORM T
	JRST	ADDINC		;YES
	CAIE	B,1		;IS INPUT FORM V
	JRST	NOINC		;NO -NO INC REQUIRED

ADDINC:	PUSHJ	P,AINCR		;ADD INC AND RANGE CHECK



NOINC:	SKIPE	@PROMM		;HAS PROMPT BEEN SENT
	JRST	OVALUE		;YES
	HRRZI	AC,2		;SET PROMM =2
	MOVEM	AC,@PROMM
	POPJ	P,		;SEND MESSAGE
;
;INPUT POINT IF NO USER VALUE
;IS ALLOWED
;
OVALUE:	MOVE	AC,ENDBUF
	MOVEM	AC,DPROMT	
	SETZ	ER,
	LDB	B,PTB		;INPUT FORM
	CAIN	B,0		;IS INPUT FORM W
	JRST	GRANM		;YES
	CAIN	B,4		;IS INPUT FORM S
	JRST	GRANM		;YES
	CAIN	B,7		;IS INPUT FORM P
	JRST	ERRS3		;YES -USER MUST INPUT A VALUE
	JRST	MVINIT		;MOVE VALUE TO OUTPUT
;
;GENERATE A RANDOM NUMBER AND STORE IN
;OUTPUT AREA
;
GRANM:	PUSHJ	P,PNTPOS	;POSITION OUTPUT RECORD POINTERS
	LDB	B,PTD		;COUNT FOR LOOP
	LDB	E,PTA		;TYPE
GNXTO:	PUSHJ	P,GNXT		;GET A RANDOM CHAR
	JRST	GGG		;PROCESS IT
GNXT:	CALLI	AC,23		;GET A RANDOM NUMBER
	ADD	AC,HASH		;ADD RANDOM
	LSH	AC,-5
	MOVEM	AC,HASH		;STORE A NEW VALUE
	ANDI	AC,177		;REDUCE TO 7 BITS
	CAIG	E,2		;TYPE 1 OR 2
	JRST	GGOOD		;YES CHAR OK
	CAIN	E,4		;TYPE 4
	JRST	GGOOD		;YES CHAR OK
	CAIN	E,3		;TYPE 3
	JRST	GTYP3		;YES
	ANDI	AC,37		;VALID ALPHA?
	CAIL	AC,1		;LESS 1
	CAIL	AC,33		;GT 32
	JRST	GNXT		;NO GOOD
	TRO	AC,100
	TRO	AC,40
	JRST	GGOOD		;CHAR NOW OK
GTYP3:	ANDI	AC,77		;SET TOP BITS
	TRO	AC,60
	CAIL	AC,72		;IN RANGE ?
	TRZ	AC,10		;NO-THEN MAKE IT
	SKIPN	SIXB
	SUBI	AC,40
GGOOD:	POPJ	P,
GGG:	SKIPN	SIXB
	TRZ	AC,100		;CLEAR TOP BIT
	IDPB	AC,C		;STORE BYTE IN OUTPUT
	SKIPN	SIXB		;SKIP ASCII
	ADDI	AC,40		;CONVERT
	TTCALL	1,AC
	SOJN	B,GNXTO		;ANY MORE
	MOVEI	AC,15		;CR
	TTCALL	1,AC
	MOVEI	AC,12		;LF
	TTCALL	1,AC
	JRST	DVAL3
;
;GET INTERNAL VALUE AND PLACE IN 
;OUTPUT AREA
;
MVINIT:	PUSHJ	P,PNTPOS	;POSITION OUTPUT REC POINTERS
	MOVE	D,PTH
	SKIPE	SIXB		;SET UP INIT VAL BYTE POINTERS
	MOVE	D,PTG		;
MNXT:	LDB	B,PTD		;LOOP COUNT
	MOVE	G,BRICK		;INTERNAL AREA POINTERS
	AOS	G		;CORRECT
MNXTA:	ILDB	AC,D		;MOVE FROM INT AREA
	IDPB	AC,C		;TO OUTPUT AREA
	SKIPN	SIXB		;MAKE ASCII IF NESS
	ADDI	AC,40
	TTCALL	1,AC		;OUTPUT CHAR
	SOJN	B,MNXTA		;END OF LOOP
	MOVEI	AC,15		;CR
	TTCALL	1,AC
	MOVEI	AC,12		;LF
	TTCALL	1,AC
	JRST	DVAL3

;
;POSITION OUTPUT AREA POINTERS
;FOR THIS FIELD OF THE RECORD
;
PNTPOS:	LDB	H,PTC		;START ADDR
	MOVE	C,OPTA		;SIXBIT BYTE POINTER
	SKIPE	SIXB
	MOVE	C,OPTB		;ASCII BYTE POINTER
	SOSE	H		;DEC   CHAR 1=POS 0
PNTP:	ILDB	AC,C		;POSITION
	SOJG	H,PNTP
	POPJ	P,
;
;CALCULATE THE LENGTH IN WORDS OF THE INITIAL
;VALUE
;
CLENGT:	LDB	B,PTD		;LENGTH OF FIELD
	SKIPE	SIXB		;SKIP IF SIXBIT
	JRST	ASC		;ASCII
	IDIVI	B,6		;NO OF WORDS
	JUMPE	C,CLEX		;REMAINDER ZERO
	AOJA	B,CLEX		;INC BY 1
ASC:	IDIVI	B,5		;ASCII
	JUMPE	C,CLEX		;REMAINDER ZERO
	AOJ	B,CLEX		;INC BY 1
CLEX:	POPJ	P,		;EXIT
;
;CHECK AN ASCII CHARACTER FOR CONVERSION 
;TO SIXBIT AND CONVERT IF VALID
;
SIXCT:	CAIGE	AC,40		;CHECK CHAR VALID SIXBIT
	JRST	SEXTZ		;NO GOOD
	CAILE	AC,137		;BETWEEN 40 - 13
	JRST	SEXTZ		;NO GOOD
	SUBI	AC,40		;CONVERT
	AOS	(P)		;GOOD EXIT
SEXTZ:	POPJ	P,		;
;
;CHECK WHETHER AREA FOR USERS DATA INPUT
;IS EMPTY (INREC IN COBOL)
;
GEMPTY:	MOVE	C,PA		;TAKE COPY OF BYTE POINTER
	HRRZ	B,FSEP
	SETZ	E,
	ILDB	AC,C		;FIRST BYTE
	CAME	AC,B		;FIELD SEP
	JRST	GNXTZA		;NO
	ILDB	AC,PA		;EMPTY STEP ON POINTER
	MOVEI	AC,1
	MOVEM	AC,@PROMM	;SET PROMM = USER HAS INPUT
	JRST	GOUT2
GNXTZ:	ILDB	AC,C		;NEXT BYTE
	HRRZ	D,C		;ADDR OF BYTE
	CAMN	D,ENDBUF	;IS IT END OF BUFFER
	JRST	GOUT3
	CAMN	AC,B		;FIELD SEP
	JRST	GOUT1		;YES OK
GNXTZA:	CAIN	AC,40		;IS IT A SPACE
	JRST	GNXTZ		;YES
	HRRZI	E,1		;SET MARKER NOT ALL SPACES
	JRST	GNXTZ		;GET NEXT CHAR
GOUT3:	SKIPE	E		;ANY NON SPACE
GOUT1:	AOS	(P)		;MORE DATA
GOUT2:	POPJ	P,		;EMPTY
;
;THIS ROUTINE EXTACTS THE NEXT PARAMETER FROM
;THE INPUT BUFFER ,RANGE CHECKS IT
;AND STORES IT IN THE OUTPUT BUFFER
;
DRANGE:	LDB	F,PTD		;LENGTH
	PUSHJ	P,PNTPOS	;SET OUTPUT POINTERS
	ILDB	AC,PA		;FIRST BYTE
	LDB	E,PTA		;INPUT TYPE
DRANGA:	JRST	.(E)		;SWITCH
	JRST	DTYP12
	JRST	DTYP12
	JRST	DTYP3		;TYPE 3 NUMBER
	JRST	DGOOD		;TYPE 4 OK
	PUSHJ	P,ALPHA		;TEST ALPHA TYPE 5
	JRST	DEXTZ		;INVALID
DGOOD:	SKIPE	SIXB		;IS IT SIXBIT
	JRST	DOK		;NO
	PUSHJ	P,SIXCT	;CHECK VALID SIXBIT
	JRST	DEXTZ		;NO GOOD
DOK:	IDPB	AC,C		;DEPOSIT BYTE
DNXT:	SOJE	F,DFINIT	;END OF FIELD
	ILDB	AC,PA		;NEXT BYTE
	JRST	DRANGA		;NO
;
;HERE THE CORRECT NUMBER OF CHARACTERS
;HAS BEEN EXTRACTED FROM THE USER INPUT BUFFER
;
DFINIT:	ILDB	AC,PA		;NEXT CHAR
	CAMN	AC,B		;IS IT A SEP
	JRST	DEXTZA		;YES
	CAIE	AC,40		;NO -IS IT A SPACE
	JRST	DEXTZ		;NO -INPUT ERROR
DEXTZA:	AOS	(P)		;EXIT
DEXTZ:	POPJ	P,		;

DTYP3:	PUSHJ	P,NUMR		;TYPE =3
	JRST	DEXTZ		;INVALID
	JRST	DGOOD		;OK
;
DTYP12:	PUSHJ	P,COMP1
	PUSHJ	P,CHL		;CONVERT TO BINARY
	JRST	DENDT		;NO GOOD OR END
	CAIN	D,1		;IS IT NEGATIVE
	MOVN	B,B		;YES CONVERT
	PUSHJ	P,PNTPOS
	HLL	C,OPTC		;SET UP BYTE POINTER
	IDPB	B,C		;DEPOSIT WORD
	JRST	DEXTZA		;FINISHED
DENDT:	CAMN	AC,FSEP		;HAS CONVERT ENDED OK
	JRST	DEXTZA		;YES
	JRST	DEXTZ		;NO
;
;OUTPUT A RECORD FULL OF INFORMATION
;
;
GOUTPT:	HRRZ	B,ORECL		;LENGTH OF RECORD
	MOVE	F,SIXB		;IS IT SIXBIT
	JUMPE	F,GSIXOT	;YES JUMP
	MOVE	AC,OPTB		;ASCII BYTE POINTER
	JRST	GNXTCH
GSIXOT:	MOVE	AC,RECLPT	;RECORD LENGTH
	ILDB	C,AC
	PUSHJ	P,GOUTCH	;OUTPUT IT
	MOVE	AC,OPTC		;36 BIT BYTE POINTER
	IDIVI	B,6		;CONV LENGTH TO WORDS
	CAIE	C,0		;IS REMAINDER ZERO
	AOS	B		;NO -INC NO OF WORDS
GNXTCH:	ILDB	C,AC		;GET A BYTE
	PUSHJ	P,GOUTCH	;OUTPUT A CHAR
	SOJG	B,GNXTCH	;GET NEXT ONE
	JUMPE	F,GEND		;IS IT ASCII
	MOVEI	C,15		;YES OUTPUT CR-LF
	PUSHJ	P,GOUTCH
	MOVEI	C,12
	PUSHJ	P,GOUTCH
GEND:	HRRZI	AC,3		;FINISHED SET MARKER
	MOVEM	AC,@PROMM	;FOR COBOL
	POPJ	P,		;EXIT

GOUTCH:	SOSG	OBUF+2	;ADVANCE BYTE COUNTER
	PUSHJ	P,PUTBUF	;JUMP BUFFER FULL
	IDPB	C,OBUF+1	;PUT BYTE IN BUFFER
	POPJ	P,		;GET NEXT BYTE
PUTBUF:	OUT	3,		;GIVE BUFFER TO MONITOR
	POPJ	P,		;GOOD RETURN
	JRST	E3		;ERROR RETURN
;
;ADD INCREMENT TO INITIAL VALUE AND
;CHECK THE RANGE
;
AINCR:	LDB	E,PTA		;TYPE
	LDB	B,PTD		;LENGTH
	LDB	C,PTF		;INCREMENT
	MOVE	G,BRICK		;POINT TO INIT VALUE
	AOS	G
	MOVE	F,PTG		;BYTE POINTER ASCII
	SKIPN	SIXB		;IS IT SIXBIT
	MOVE	F,PTH		;YES
	MOVE	H,SMARK		;RESET BYTE POINTER MARK
	SKIPE	SIXB		;IS IT SIXBIT
	MOVE	H,AMARK		;NO
ARS:	ILDB	AC,F		;RESET BYTE POINTER
	SOJG	B,ARS		;TO LAST BYTE
	LDB	B,PTD		;RESET LENGTH
	JRST	.(E)		;SWITCH ON TYPE
	JRST	AT12		;TYPE 1
	JRST	AT12		;TYPE 2
	JRST	AT3		;TYPE 3
	JRST	AT4		;TYPE 4
	JRST	AT5		;TYPE 5
AT3:	JUMPE	C,AT3A		;IS IN ZERO
	LDB	AC,F		;GET CURRENT CHAR
	SKIPE	SIXB		;IF ASCII MAKE SIXBIT
	SUBI	AC,40		;
	IDIVI	C,12		;DIVIDE INC BY 10
	ADD	AC,D		;ADD REMAINDER
	CAIG	AC,31		;>9 IN THIS POSITION
	JRST	AT3B		;NO CHAR OK
	AOS	C		;ADD CARRY TO REST
	SUBI	AC,12		;PUT NEW CHAR IN RANGE
AT3B:	SKIPE	SIXB		;IS IT SIXBIT
	ADDI	AC,40		;NO- MAKE ASCII
	DPB	AC,F		;
	SOJE	B,AT3A		;FINISH IF LAST
	PUSHJ	P,UPBP		;UPDATE BYTE POINTERS
	JRST	AT3		;NEXT BYTE
AT3A:	POPJ	P,		;FINISHED

AT4:	SKIPE	SIXB		;IS IT SIXBIT
	JRST	AT4C		;NO
AT4D:	JUMPE	C,AT4A		;IS INC ZERO
	LDB	AC,F		;GET CURRENT CHAR
	IDIVI	C,100		;DIVIDE BY 100 OCT
	ADD	AC,D		;ADD REMAINDER
	CAIG	AC,77		;> 77 OCT
	JRST	AT4B		;NO CHAR OK
	AOS	C		;ADD CARRY TO REST
	SUBI	AC,100		;PUT CHAR IN RANGE
AT4B:	DPB	AC,F		;STORE BACK CHAR
	SOJE	B,AT4A		;FINISH IF LAST
	PUSHJ	P,UPBP		;UPDATE BYTE POINTERS
	JRST	AT4D		;NEXT BYTE
AT4A:	POPJ	P,		;FINISHED

AT4C:	JUMPE	C,AT4A		;IS INC ZERO
	LDB	AC,F		;GET CURRENT CHAR
	IDIVI	C,200		;DIVIDE INC BY 200
	ADD	AC,D		;ADD REMAINDER
	CAIG	AC,177		;> 177 OCT
	JRST	AT4E		;NO - CHAR OK
	AOS	C		;ADD CARRY TO REST
	SUBI	AC,200		;PUT CARRY IN RANGE
AT4E:	DPB	AC,F		;STORE BACK CHAR
	SOJE	B,AT4A		;FINISH IF LAST
	PUSHJ	P,UPBP		;UPDATE BYTE POINTER
	JRST	AT4C		;NEXT BYTE

AT5:	JUMPE	C,AT5A		;IS INC ZERO
	LDB	AC,F		;GET CURRENT CHAR
	SKIPE	SIXB		;IF ASCII MAKE SIXBIT
	SUBI	AC,40
	IDIVI	C,32		;DIVIDE INC BY 32 OCT
	ADD	AC,D		;ADD REMAINDER
	CAIG	AC,73		;> Z IN THIS POS
	JRST	AT5B		;NO CHAR OK
	AOS	C		;ADD CARRY TO REST
	SUBI	AC,32		;PUT NEW CHAR IN RANGE
	CAIE	AC,73		;
	SETZ	AC,		;MAKE CHAR A SPACE
AT5B:	CAIGE	AC,41		;IF IT WAS A SPACE MAKE A
	HRRZI	AC,41		;
	SKIPE	SIXB		;RESET TO ASCII IF REQUIRED
	ADDI	AC,40		;
	DPB	AC,F		;STORE BACK
	SOJE	B,AT3A		;FINISH IF LAST
	PUSHJ	P,UPBP		;UPDATE BYTE POINTERS
	JRST	AT5		;NEXT BYTE
AT5A:	POPJ	P,		;FINISHED
;
;NOT YET WRITTEN
AT12:	MOVE	F,PTN		;BYTE POINTER
	ILDB	AC,F		;LOAD INIT VALUE
	ADD	AC,C		;ADD INCREMENT
	DPB	AC,F		;STORE RESULT
	POPJ	P,		;EXIT


UPBP:	MOVEI	AC,60000	;SIXBIT MARKER
	SKIPE	SIXB
	MOVEI	AC,70000	;ASCII MARKER
	HRLZ	AC,AC
	ADD	F,AC		;UPDATE BYTE POINTER
	CAMG	F,TOP		;TO LARGE
	POPJ	P,		;EXIT
	SOS	G		;DECREASE ADDR
	DPB	H,AMARKR	;RESET POINTER
	POPJ	P,		;EXIT

;**************************************************
;***************************************************
;
;
;CLOSE DOWN IO AND EMPTY BUFFERS
;
CLOS:	CLOSE	3,0
	RELEASE	3,
	POPJ	P,

;**************************************************
;**************************************************
;
;WRITE INTERNAL 2000 DEC WORD RECORD AREA
;TO DSK
;
RECRIT:	PUSHJ	P,FILMOV	;TRANSFER FILNAME
	MOVE	AC,@2(16)	;ADDR OF AREA
	SOS	AC
	HRRM	AC,IOLST	;SET UP START ADDR

	OPEN	0,OPNBLK	;OPEN CHANNEL
	JRST	E1		;ERROR RETURN
	ENTER	0,EEE		;SELECT FILE
	JRST	E2

	OUTPUT	0,IOLST		;OUTPUT 1 BLOCK
	JRST	RECLOS
	JRST	E3		;ERROR RETURN

RECLOS:	CLOSE	0,0
	RELEASE	0,
	POPJ	P,

OPNBLK:	17
	SIXBIT/DSK/
	0
IOLST:	IOWD	^D2000,@BRICK
	0

;*************************************************
;*************************************************
;
;READ IN RECORD LAYOUT AREA
;
;
RECRED:	PUSHJ	P,FILMOV
	MOVE	AC,@2(16)	;ADDR FOR INPUT
	SOS	AC
	HRRM	AC,IOLST	;SET UP START ADDR

	OPEN	0,OPNBLK
	JRST	E1		;ERROR

	LOOKUP	0,EEE
	JRST	E2		;ERROR

	INPUT	0,IOLST		;INPUT THE RECORD
	JRST	RECLOS
	JRST	E3





PTI:	POINT	6,@BRICK,11	;REC ID
PTJ:	POINT	6,@BRICK,35	;FILLER
PTK:	POINT	18,@BRICK,29	;LENGTH
RECID:	0
OUTPT:	BLOCK	1000	;OUTPUT REC AREA
OPTC:	POINT	36,OUTPT	;
OPTA:	POINT	6,OUTPT	;
OPTB:	POINT	7,OUTPT	;
ENDBUF:	0
DPROMT:	0
FSEP:	0
USINPT:	0	;USER INPUT POINTER
ORECL:	0	;OUTPUT RECORD LENGTH
PROMM:	0	;MARKER 1= PROMPT SENT
RECLPT:	POINT	36,ORECL	;RECORD LENGTH BYTE POINTER
TOP:	360000000000
SMARK:	600
AMARK:	10700
AMARKR:	POINT	12,(F),11
HASH:	0
	END