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