Trailing-Edge
-
PDP-10 Archives
-
decuslib20-04
-
decus/20-0108/cobedt.mac
There are 2 other files named cobedt.mac in the archive. Click here to see a list.
TITLE COBEDT
SUBTTL A COBOL FILE EDITOR
SEARCH APROC
SEARCH UUOSYM
TWOSEG
SALL
;/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/
;
; C O B E D T
;
; A COBOL FILE EDITOR
;
; DAVE GORKA
; 18-JUNE-76
;
;/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/
F=0 ; THE FLAG REGISTER
P=17 ; THE PDL
PDLLEN==^D30 ; PDL LENGTH
POSLEN==^D1000 ; MAX RECORD SIZE SUPPORTED
STRLEN==POSLEN ; MAX # CHARS IN A FIND STRING
OPDEF CALL [PUSHJ P,] ; CALL OPCODE
OPDEF RET [POPJ P,] ; RETURN FROM SUBROUTINE
OPDEF PJRST [JRST ] ; JUMP TO SUBROUTINE AFTER PUSHJ
OPDEF ERRS [001000,,0] ; ERROR OCCURRED IN SCAN ROUTINE
OPDEF ERRC [002000,,0] ; ERROR OCCURRED IN MANIPULATION LANGUAGE
OPDEF ERRO [003000,,0] ; ERROR IN COBOL FILE SCANNER
DEFINE PRINT(TXT),<
OUTSTR [ASCIZ/TXT/]
>
DEFINE P$RINT(TXT),<
PRINT <TXT>
OUTSTR CRLF
>
; ERROR DEFINES
DEFINE SE(TXT),<
ERRS [ASCIZ/TXT/]
>
DEFINE CE(TXT),<
ERRC [ASCIZ/TXT/]
>
DEFINE OE(TXT),<
ERRO [ASCIZ/TXT/]
>
SUBTTL EXTERNALS AND FLAGS
EXTERNAL SCAN ; FILE NAME SCANNER
EXTERNAL TTYINI,TTYI ; INPUT TTY HANDLER
EXTERNAL DSKINI,DSKIN ; INPUT DISK HANDLER
EXTERNAL DSKCLS ; CLOSE OUT THIS DEVICE
EXTERNAL DS2INI,DS2OUT ; OUTPUT FILE HANDLER
EXTERNAL DS2CLS
EXTERNAL DS3INI,DS3OUT ; OUTPUT LIST FILE ROUTINES
EXTERNAL DS3CLS ; CLOSE THE OPEN FILE
EXTERNAL DS4INI,DS4IN ; ASCII INPUT ROUTINES
EXTERNAL DS4CLS ; AND CLOSE ROUTINE
EXTERNAL TTYLST ; LAST CHAR READ FROM TTY
; IN RH: F
FOURFG==1 ; 4 DIGITS IN DECIMAL FIELD
FILEIT==2 ; PROCESSING AN INDIRECT COMMAND FILE
CHARFL==4 ; 1 HAS A SCANNED CHARACTER IN IT
COMNFL==10 ; PROCESSING A CHAR
RECWRT==20 ; A RECORD NEEDS TO BE WRITTEN
JUSTEX==40 ; JUST EXIT AFTER COPY
GOTCR==100 ; WE HAVE SEEN A CR
DFLAG==200 ; TELL PRINT TO REALLY DELETE
NULLF==400 ; CONTINUE THE FIND SEQUENCE
NOACWF==1000 ; NO ACCESS WORDS IN FILE
AFLAG==2000 ; ASCII FILE -- CHECK FOR CRLF
SFLAG==4000 ; LET STRSCN DO INSERTS DIRTY WORK
FINDFG==10000 ; [00] IN A FIND SEQUENCE
; IN LH: F
COMP==1 ; SINGLE PRECISION COMP
COMP1==2 ; DOUBLE PRECISION COMP
INFILE==4 ; PROCESSING A COBOL FD FILE
PICFLG==10 ; A PICTURE STRING WAS SCANNED FROM OCCURS
SUBTTL COBEDT START
RELOC 400000
COBEDT: RESET ; ALWAYS NICE
MOVE 1,[CALL UUOH]
MOVEM 1,.JB41## ; THE PRINT ROUTINES
P$RINT <COBEDT VERSION 4.0>
MOVE 1,[ZEROB,,ZEROB+1]
SETZB F,-1(1)
BLT 1,ZEROE ; ZERO THE OLD CORE ON ENTRY
MOVE P,[IOWD PDLLEN,PDL]
CALL TTYINI ; INIT THE TTY
SE <?CANNOT INITIALIZE TTY>
COB1: PRINT <ENTER COBOL FILE TO EDIT: >
CALL SCAN ; GO SCAN THE FILE NAME
JRST COB1 ; OOPS - HE BLEW IT
CALL DSKINI ; LOOKUP THIS FILE
JRST [P$RINT <?INIT FAILURE FOR DEVICE DSK:>
JRST COB1]
JRST [P$RINT <?FILE CANNOT BE FOUND>
JRST COB1]
COB101: MOVEI 14,TTYI ; GET FROM TTY
COB10: TRNN F,FILEIT ; IN FILE MODE ?
OUTSTR [ASCIZ/FD-/]
SETZ 2, ; WHERE THE COMMAND GOES
MOVEI 4,6 ; 4 = # CHARS IN A COMMAND
MOVE 3,[POINT 6,2] ; IN SIXBIT
COB2: CALL 0(14) ; GET A CHAR FROM THE INPUT MEDIUM
JFCL ; JUST IN CASE IF FROM FILE
TRNE 1,777600 ; AN EOF YET ?
TRNN F,FILEIT ; IN FILE MODE ?
CAIA ; NO
JRST FILEO ; YES -- ALL DONE
CAIE 1,33 ; ALTMODE ?
CAIN 1,15 ; OR CR
JRST COB2
CAIE 1,12 ; A LF ?
CAIN 1," " ; OR START OF NEXT FIELD ?
JRST COB3 ; YES
CAIN 1,"@" ; INDIRECT FILE ?
JRST FILE ; YES -- HANDLE IT RIGHT HERE
CAIL 1,"A" ; ALPHA ?
CAILE 1,"Z"
CAIA
TRC 1,40 ; CVT TO SIXBIT
IDPB 1,3 ; SAVE IN 0
SOJGE 4,COB2 ; REPEAT FOR ALL
SE <%COMMAND TO LONG>
SUBTTL FILE DESCRIPTOR COMMAND DISPATCH
COB3: MOVSI 3,-CLEN ; SEARCH FOR THE COMMAND
SUBI 4,6 ; 4 = - # OF CHARS IN WORD
JUMPE 4,ENDIT ; NULL ? YES,ENDIT
MOVE 4,MASKTB+1(4) ; 4 = MASK
MOVE 5,CTBL(3) ; GET THE COMMAND
AND 5,4 ; LESS WHAT WE DIDN'T TYPE
CAME 2,5 ; SAME WITH THE LOST BITS ?
AOBJN 3,.-3 ; NO -- REPEAT AS NEEDED
JUMPL 3,@CLEN+CTBL(3) ; GO TO THE RIGHT ROUTINE
SE <%BAD COMMAND>
CTBL: 'RECORD' ; RECORD N
'SIXBIT' ; SIXBIT(M:N[,M:N])
'ASCII ' ; ASCII(M:N[,M:N])
'COMP ' ; COMP(M[,N])
'COMP-2' ; COMP-2(M[,N])
'BLOCK ' ; BLOCK SIZE COMMAND
'FD ' ; COBOL FD FILE
'NOACW ' ; NO INTERNAR DATA ACCESS WORDS
'HELP '
CLEN==.-CTBL
+ RECORD ; ROUTINE ADDRESSES
+ SIX
+ ASC
+ COM
+ COM2
+ BLOCKN ; BLOCK SCANNING ROUTINE
+ HFILE ; ROUTINE TO SETUP THE COBOL CONVERTOR
+ NOACW ; SET NO ACW FLAG
+ HELP ; DO THE HELP
- 1 ; MASK FOR A FULL WORD
- 1B29 ; LESS S6
- 1B23 ; LESS S5+S6
- 1B17 ; LESS S4+S5+S6
- 1B11 ; LESS S3+S4+S5+S6
MASKTB: - 1B5 ; LESS S2+S3+S4+S5+S6
HELP: OUTSTR FDHLP
JRST COBCLR
SUBTTL RECORD(N) SCANNER + SUBROUTINES
BLOCKN: SKIPA 5,[ BSIZE ] ; SAVE THE BLOCK SIZE
RECORD: MOVEI 5,RECSIZ ; WHERE TO PUT THE RECORD
CALL SCANC ; USING THIS ROUTINE
CALL GETNUM
MOVEM 2,0(5) ; SAVE THE RECORD SIZE
JRST COBCLR
SCANCI: CALL 0(14) ; CALL THE RIGHT INPUT ROUTINE
JFCL ; JUST IN CASE IF FROM FILE
SCANC: CAIE 1,11 ; TAB OR
CAIN 1," "
JRST SCANCI ; YES - IGNORE
CAIN 1,15 ; CR ?
JRST SCANCI ; YES -- IGNORE ALSO
TRO F,CHARFL ; 1 NOW HAS A CHARACTER IN IT
RET ; RETURN -- 1 = NEXT CHAR IN SCAN
COBCLR: CAIE 1,33 ; ALT ?
CAIN 1,"Z"-100 ; CNTL-Z ?
JRST COB10
CAIN 1,12 ; LF ?
JRST COB10 ; YES -- START AGAIN
CALL 0(14) ; CALL THE RIGHT ROUTINE
JFCL
JRST COBCLR ; ANOTHER CHAR -- SEE IF DONE
GETNUM: MOVE 4,[CALL 0(14)] ; 4 = ROUTINE TO GET CHARS FROM
GETNU1: SETZ 2, ; 2 = RETURNED #
GETNU2: TRZN F,CHARFL ; GOT A CHAR IN 1 ALREADY ?
XCT 4 ; NO -- GET A CHAR FROM WHOMEVER
JFCL ; JUST IN CASE
CAIN 1,"." ; CURRENCY ?
JRST GETNU3 ; YES - ASSUME WHATEVER
CAIN 1," " ; IGNORE SPACES
JRST GETNU2 ;
CAIL 1,"0" ; NUMERIC
CAILE 1,"9"
RET ; NON-NUMERIC
IMULI 2,^D10
ADDI 2,-"0"(1)
JRST GETNU2 ; AND CONTINUE
GETNU3: MOVE 2,CURLIN ; GET CURRENCY
JRST GETNU2 ; AND CONTINNUE
NOACW: TRO F,NOACWF ; SAY WE HAVE NO ACCESS WORD
JRST COBCLR ; AND CONTINUE
SUBTTL ASCII AND SIXBIT SCANNER
;/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/
;
; THE POS TABLE CONSISTS OF 3 BIT ENTRY'S FOR EACH
; CHARACTER POSITION IN THE RECORDS FOR THE FILES.
; THE TYPES CURRENTLY DEFINED ARE:
; 0 => UNDEFINED (POSITIONS ARE IGNORED)
; 1 => SIXBIT
; 2 => ASCII
; 3 => COMP
; 4 => COMP-2
;
;/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/
ASC: MOVEI 5,2 ; TYPE FOR ASCII DEFINITIONS
MOVEI 2,377777 ; ASSUME A LARGE RECORD SIZE
MOVEM 2,RECSIZ ; AND SET
TROA F,AFLAG!NOACWF ; IN ASCII MODE (CHECK FOR CRLF)
SIX: MOVEI 5,1 ; FOR SIXBIT
SKIPN 2,MODE
JRST .+3 ; NO
CAME 2,5 ; YES -- SAME MODE ?
SE <%CANNOT MIX SIXBIT AND ASCII RECORDS>
MOVEM 5,MODE ; SET THE MODE
CALL SCANC ; SKIP TO THIS CHAR
SIX1: CALL SCANR ; GO SCAN A RANGE
PUSH P,1 ; SAVE TERMINAL CHAR
SOS 1,2 ; 1 = WHERE TO START
SIXENT: IDIVI 1,^D12 ; 1 = WORD, 2 = POS IN WORD
MOVSI 4,(POINT 3,)
ADDI 4,POS(1) ; 4 = BP TO START
JUMPE 2,.+3
IBP 4 ; INCREMENT TO ACTUAL POSITION
SOJG 2,.-1 ; REPEAT FOR ALL
SIXX: EXCH 3,CURPOS ; [00] SAVE COUNT, GET CURRENT
ADD 3,CURPOS ; [00] 3 = # CHARS NEW
CAIL 3,POSLEN ; [00] BEYOND MAX ?
SE <?EXCEEDING MAXIMUM RECORD SIZE>
EXCH 3,CURPOS ; [00] GET ORIGINAL, SAVE NEW TOTAL
ILDB 1,4 ; GET THE CHAR WE WILL ZAP
JUMPN 1,SIXERR ; IS THIS POSITION COVERED ?
DPB 5,4 ; NO - SET TYPE
SOJG 3,.-3 ; REPEAT FOR ALL CHARACTERS
TLNE F,INFILE ; IN A FILE (COBOL THAT IS)
RET ; YES
POP P,1 ; GET LAST CHAR SEEN
CAIN 1,"," ; COMMA ?
JRST SIX1 ; YES - AGAIN
JRST COBCLR
SIXERR: P$RINT <?THESE POSITIONS HAVE BEEN COVERED>
JRST COBCLR ; CLEAR THE BUFFER
SUBTTL IMBEDDED COMPUTATION FIELDS SCANNER
COM2: SKIPA 5,[4] ; COMP-2 TYPE
COM: MOVEI 5,3 ; COMP TYPE
CALL SCANC ; IN THE INPUT
COM1: CALL GETNUM ; GET THE POSITION
MOVE 3,2 ; COPY ORIGINAL
CAIE 1,"," ; COMMA ?
JRST COM3 ; NO
CALL GETNUM
EXCH 3,2 ; 2 = FIRST #, 3 = 2ND
CAIN 1,"," ; COMMA HERE ALSO
COM3: SE <%SECOND COMMA ILLEGAL>
PUSH P,1 ; SAVE LAST CHAR SCANNED
SKIPN 2 ; SPECIFIED ?
MOVE 2,CURPOS ; NO -- USE CURRENT
SKIPN 3 ; # COMP FIELDS SPECIFIED
MOVEI 3,1 ; OOPS -- ASSUME 1 ONLY
CAIN 5,4
LSH 3,1 ; MUL BY 2 IF DOUBLE PRECISION
IMULI 3,6
MOVEI 1,0(2) ; HIT THE RIGHT WORD
IDIVI 1,6 ; 1 = HALFWORD ADDRESS
SKIPE 2 ; CROSSES RIGHT POSITIONS ?
SE <%POSITIONS NOT ON A WORD BOUNDARY>
MOVSI 4,(POINT 3,0)
TRNE 1,1 ; IN OTHER HALFWORD ?
MOVSI 4,(POINT 3,0,17)
LSH 1,-1 ; DIVIDE BY 2
ADDI 4,POS(1)
PJRST SIXX ; GO BLOT OUT THESE POSITIONS
SUBTTL COBOL FILE DESCRIPTOR CONVERTOR
SCNBEG: MOVEI 14,DS4IN ; 14 = ROUTINE TO CALL FOR DATA
HRRZS ; NO FLAGS IN LH:
CALL SETUPL ; AND BUILD A WHOLE LINE
RET ; $E TO ORIGINAL CALLER ON EOF
MOVE 14,[POINT 7,RECSTR]
CALL GETID ; SCAN AN IDENTIFIER
CALL NAMEF ; LOOKUP THE NAME IN THE RESERVED WORD LIST
CAIN 1,^D17 ; TYPE 17 ?
OE <%ILLEGAL TO USE LEVEL NUMBERS 66 AND 88>
CALL GETID ; SCAN IDENTIFIER ONTO FLOOR
SCNLP: CALL GETID ; SCAN A KEY WORD (MAYBE A PERIOD)
CALL NAMEF ; GIVE IT A NAME (FIND IT)
CAIL 1,1 ; [00] IS IT LEGAL ?
CAILE 1,^D19 ; [00] ?
JRST WHATQ ; [00] NO -- BETTER TELL THE GUY
CAIL 1,^D11 ; A CHARACTER TYPE ?
CAILE 1,^D16
JRST @.+1(1) ; DISPATCH AS INDICATED
JRST @USA ; YES -- DO DISPLAY-6 STUFF
+ NLEVEL ; 1 = '.'
[OE <%REDEFINES ARE ILLEGAL>
]
+ PIC ; 3 = PICTURE CODES
+ USAGE ; 4 = USAGE
+ NOOP ; 5 = SYNCHRONIZED
+ NOOP ; 6 = JUSTIFIED
+ NOOP2 ; 7 = BLANK
+ NOOP2 ; 8 = VALUE
+ OCCURS ; 9 = OCCURS
+ SCNLP ; 10 = IS
; THROW A IDENTIFIER ON THE FLOOR
NOOP: CALL GETID ; THEN THE IDENTIFIER
JRST SCNLP ; AND RETURN
; THROW A POSSIBLE 2 IDENTIFIES ON THE FLOOR
NOOP2: CALL GETID ; THEN THE IDENTIFIER
HRRZ 1,STRING ; CHECK TO SEE WHAT WE SCANNED
CAIE 1,'WHE' ; THE OPTIONAL WORDS PRESENT ?
CAIN 1,'IS '
JRST NOOP ; YES - SCAN THE NEXT SET
JRST SCNLP ; NO,SCNLP
WHATQ: PRINT <?YOU HAVE CONFUSED ME ON LINE: >
OUTSTR RECSTR ; [00] GIVE HIM THE LINE
HALT . ; [00] DO NOT PROCEED
; SET ALL THOSE PARAMETER WE HAVE JUST SCANNED
NLEVEL: SKIPN 3,LENGTH ; # OF POSITIONS THIS ITEM OCCUPIES
JRST SCNBEG ; NO POSITIONS -- IGNORE AND GET NEXT
SKIPN 5,MODE ; DID WE ESTABLISH THE MODE OF THE RECORD ?
AOS 5,MODE ; NO -- JUMP ON ASCII
TLZN F,COMP!COMP1 ; [00] COMP FIELD ?
JRST NLVL1 ; [00] NO -- JUST PASS
CAIL 3,9 ; [00] DOUBLE PRECISION ?
SKIPA 5,[4] ; [00] YES
MOVEI 5,3 ; [00] NO -- SINGLE
NLVL1: MOVE 1,CURPOS ; GET CURRENT POSITION IN RECORD
TLO F,INFILE ; WE ARE IN A COBOL RECORD FILE
CAIN 5,3 ; COMP VAR ?
MOVEI 3,6
CAIN 5,4
MOVEI 3,^D12 ; DOUBLE PRECISION
SKIPE TIMES ; OBJECT OF AN OCCURS ?
IMUL 3,TIMES ; YES -- INCREASE PROPOTIONATELY
CALL SIXENT ; GO USE THIS SUBROUTINE FOR THE WORK
SETZM LENGTH ; NO LENGTH
JRST SCNBEG
SUBTTL HANDLE THE 'OCCURS' CLAUSE
OCCURS: CALL GETID ; THEN GET AND IDENTIFIER
PUSH P,STRING ; SAVE THIS POSSIBLE NUMBER
CALL GETID ; SCAN THE IDENTIFIER
CALL NAMEF ; SEE IF A NAME EXISTS
CAIN 1,^D18 ; 18 = 'TO'
JRST OCCUR1 ; POSITION TO NEXT
CAIN 1,^D19 ; 19 = 'TIMES'
JRST OCCUR2 ; YES -- LAST IS OUR NUMBER
CAIE 1,1 ; A PERIOD ?
OE <%CONFUSION IN 'OCCURS'>
OCCUR2: POP P,1 ; THIS IS THE NUMBER OF TIMES
OCCUR0: SETZ 3, ; 3 = BINARY
SETZ 2,
ROTC 1,6 ; SHIFT NUMBER TO LOWER 2
IMULI 3,^D10 ; ADJUST
ADDI 3,-'0'(2) ; AND ADD
JUMPN 1,.-4 ; REPEAT FOR ALL DIGITS
MOVEM 3,TIMES ; # TIMES TO REPEAT THIS PIC STRING
OCCUR3: CALL NAMEF ; FIND OUT THE NAME AGAIN
CAIN 1,1 ; WAS IT A PERIOD ?
JRST NLEVEL ; YES -- DONE WITH THIS STRING
CAIN 1,3 ; 3 = A PICTURE CLAUSE
JRST OCCUR4
CALL GETID ; GET THE NEXT ID
JRST OCCUR3 ; AND REPEAT UNTIL A PERIOD IS FOUND !
OCCUR4: TLO F,PICFLG ; WE MUST RETURN HERE
JRST PIC ; GO DO THE PICTURE
OCCUR1: CALL GETID
JRST OCCUR0 ; AND PROCESS
SUBTTL PICTURE SCANNER
PIC: CALL GETID ; SCAN THE ID
CALL NAMEF ; GIVE IT A NAME
CAIN 1,^D10 ; 10 = 'IS'
JRST PIC ; SKIP UP TO THE ACTUAL PICTURE STRING
MOVE 5,[POINT 6,STRING]
SETZ 4, ; 4 = # CHARS IN PICTURE STRING
PICLP: ILDB 1,5 ; GET A CHARACTER
JUMPE 1,PICDON ; EOF OF STRING ? YES,PICDON
MOVSI 2,-PICLEN ; THE TABLE INDEX
HLRZ 3,PICTAB(2) ; CHECK THIS TABLE
CAME 1,3 ; SAME ?
AOBJN 2,.-2 ; NO -- REPEAT
HRRE 1,PICTAB(2) ; GET POSSIBLE ADDRESS
TRNN 1,200000 ; AND ADDRESS
HRRZS 1 ; YES - KEEP ONLY THAT
JUMPL 1,[AOJA 4,PICLP]; JUST KEEP A COUNT
JUMPN 1,0(1) ; A GO TO ADDRESS ? YES,0(1)
JRST PICLP ; IGNORE THE UNFOUND
PICCR: ILDB 1,5 ; GET THAT CHAR
CAIN 1,'R' ; THE REST OF THE FIELD ?
JRST PICLP ; JUST IGNORE
OE <%BAD PIC STRING>
PICDB: ILDB 1,5
CAIN 1,'B' ; THE DB ?
JRST PICLP ; YES
OE <%BAD PIC STRING>
PICDON: MOVEM 4,LENGTH ; SAVE THE LENGTH OF THE PICTURE
TLZE F,PICFLG ; IN A OCCUR PICTURE STRING
JRST OCCUR3 ; YES,OCCUR3
JRST SCNLP ; AND CONTINUE WITH THE REST
PICREP: SETZ 2, ; 2 = # CHARACTERS IN THIS STRING
ILDB 1,5 ; GET A CHARACTER
CAIL 1,'0' ; A NUMERIC ?
CAILE 1,'9' ; ?
JRST .+4 ; NO
IMULI 2,^D10
ADDI 2,-'0'(1) ; ADD ON
JRST PICREP+1 ; REPEAT AS NEEDED
ADDI 4,0(2) ; AND ADD
SOJA 4,PICLP ; CONTINUE BUT DECREMENT FOR LEAD CHAR
SUBTTL USAGE - SCAN THE USAGE
USAGE: CALL GETID ; READ THE IDENTIFIER
CALL NAMEF ; GIVE IT A NAME
CAIN 1,^D10 ; 10 = 'IS'
JRST USAGE ; SKIP THE IS AND POSITION
USA: JRST @.-^D10(1) ; CALL THE PROPER ROUTINE
+ UCOMP ; 11 = COMPUTATIONAL
+ UCOMP1 ; 12 = COMPUTATIONAL-1
+ UDISP ; 13 = DISPLAY (SIXBIT)
+ UDISP7 ; 14 = DISPLAY-7 (ASCII)
[OE <%INDEX USAGE IS NOT ALLOWED>
]
[OE <%DATABASE KEY USAGE IS NOT ALLOWED>
]
UDISP7: SKIPA 5,[2] ; THE ASCII TYPE
UDISP: MOVEI 5,1 ; THE SIXBIT TYPE
SKIPN 4,MODE ; GET THE MODE
MOVE 4,5 ; OOPS -- LOAD THE CURRENT ONE
MOVEM 4,MODE ; AND SET
CAME 4,5 ; SAME ?
OE <?CANNOT MIX RECORD MODES!>
JRST SCNLP
UCOMP: TLOA F,COMP ; WE SCANNED A COMP FIELD
UCOMP1: TLO F,COMP1 ; A DOUBLE PRECISION
MOVE 1,CURPOS ; GET CURRENT POSITION IN LINE
IDIVI 1,6 ; BE SURE OF A COMP MULTIPLE
SKIPE 2 ; LEFTOVERS ?
ADDI 1,1 ; YES -- TO NEXT WORD
IMULI 1,6 ; BACK TO REGULAR PSITION
JRST SCNLP ; AND CONTINUE
SUBTTL SCANNING SUBROUTINES
; SCAN A WHOLE LINE OFTEXT (FROM PERIIOD TO PERIIOD)
SETUPL: MOVE 2,[POINT 7,RECSTR] ; WHERE TO SAVE THE FULL LINE AT
SETZM OLDCHR ; WE HAVE NO LYING CHARACTER
SETUP0: CALL 0(14) ; READ FROM THE FILE
RET ; A NO SKIP RETURN
CAIN 1,15 ; CR ?
JRST .-3 ; YES -- IGNORE
CAIE 1,"," ; THE "BLANK" CHARACTERS ?
CAIN 1,";" ; ?
MOVEI 1," " ; YES
CAIE 1,11 ; TAB ?
CAIN 1,12 ; LF ?
MOVEI 1," " ; YES
IDPB 1,2 ; SAVE THE CHAR AWAY
CAIE 1,"." ; PERIOD ?
JRST SETUP0 ; NO
SETZ 1,
IDPB 1,2 ; FOR A POSSIBLE ERROR
AOS 0(P) ; GIVE A SKIP ON A LINE FOUND
RET ; $E
; SKIP TO THE FIRST NON BLANK
SKIPNB: SKIPN 1,OLDCHR ; LYING A CHARACTER ?
ILDB 1,14 ; NO -- JUST READ A CHAR
MOVEM 1,OLDCHR ; SAVE HERE
CAIN 1," " ; BLANK ?
JRST .-3 ; YES -- IGNORE
RET ; NO,$E
; SCAN A IDENTIFIER INTO A SIXBIT FORMAT
GETID: CALL SKIPNB ; DO THIS FIRST
MOVE 2,[POINT 6,STRING] ; WHERE TO PUT THE COMPLETE STRING
MOVE 1,[STRING,,STRING+1]
SETZM -1(1)
BLT 1,STRING+4 ; ZERO THE STRING
SKIPN 1,OLDCHR ; LYING A CHARACTER
GETID0: ILDB 1,14 ; GET THAT CHAR
MOVEM 1,OLDCHR ; SAVE FOR LATER
TRC 1," " ; CVT TO SIXBIT
JUMPE 1,GETID1 ; BLANK YES,GETID1
CAIE 1,'.' ; A PERIOD ?
JRST .+4 ; NO
CAMN 2,[POINT 6,STRING] ; ANY CHARACTERS SCANNED ?
IDPB 1,2 ; NO -- SAVE THE PERIOD
GETID1: RET ; $E
IDPB 1,2 ; SAVE A CHARACTER IN STRING
JRST GETID0 ; AND REPEAT AS NEEDED
; LOOKUP A COBOL RESERVED WORD AND ASSIGN IT A TYPE
NAMEF: MOVEI 2,NAMETB+1 ; 2 = POINTS TO STRINGS
NAME0: SKIPN 3,-1(2) ; 3 = # WORDS IN A COBOL ENTRY
JRST NAMEDN ; OOPS -- NO LONGER ANY ENTRY'S
MOVEI 4,STRING ; 4 = TEXT ADDRESS OF MATCH STRING
HLRZ 1,3 ; 1 = TYPE OF THE VARIABLE
HRRZS 3 ; 3 = WC LESS TYPE
MOVE 5,0(2) ; GET COBOL STRING
ADDI 2,1 ; INCREMENT POINTER
CAME 5,0(4) ; SAME AS OUR STRING
AOJA 2,NAME0 ; NO -- SKIP TO NEXT
ADDI 4,1 ; INCREMENT OUR STRING POINTER
SOJG 3,.-5 ; REPEAT FOR ALL WORDS
RET ; WE HAVE A MATCH !
NAMEDN: SETZ 1, ; WE HAVE NO BANANNAS !
RET ; AND LEAVE
; NAMETB FORMAT IS: TYPE,,# WORDS IN STRING
; <STRING IN SIXBIT>
RADIX 10
NAMETB: + 1,,1 ; TYPE 1
SIXBIT '. '
+ 2,,2 ; TYPE 2
SIXBIT 'REDEFINES '
+ 3,,2 ; TYPE 3
SIXBIT 'PICTURE '
+ 3,,1
SIXBIT 'PIC '
+ 4,,1 ; TYPE 4
SIXBIT 'USAGE '
+ 5,,2 ; TYPE 5
SIXBIT 'SYNCHRONIZED'
+ 5,,1
SIXBIT 'SYNC '
+ 6,,2 ; TYPE 6
SIXBIT 'JUSTIFIED '
+ 6,,1
SIXBIT 'JUST '
+ 7,,1 ; TYPE 7
SIXBIT 'BLANK '
+ 8,,1 ; TYPE 8
SIXBIT 'VALUE '
+ 9,,1 ; TYPE 9
SIXBIT 'OCCURS'
+ 10,,1 ; TYPE 10
SIXBIT 'IS '
+ 11,,3 ; TYPE 11
SIXBIT 'COMPUTATIONAL '
+ 11,,1
SIXBIT 'COMP '
+ 12,,3 ; TYPE 12
SIXBIT 'COMPUTATIONAL-1 '
+ 12,,1
SIXBIT 'COMP-1'
+ 13,,2 ; TYPE 13
SIXBIT 'DISPLAY '
+ 13,,2
SIXBIT 'DISPLAY-6 '
+ 14,,2 ; TYPE 14
SIXBIT 'DISPLAY-7 '
+ 15,,1 ; TYPE 15
SIXBIT 'INDEX '
+ 16,,2 ; TYPE 16
SIXBIT 'DATABASE-KEY'
+ 17,,1 ; TYPE 17
SIXBIT '66 '
+ 17,,1
SIXBIT '88 '
+ 18,,1 ; TYPE 18
SIXBIT 'TO '
+ 19,,1 ; TYPE 19
SIXBIT 'TIMES '
Z ; ** END OF THE LIST **
RADIX 8
SUBTTL INDIRECT FILE HANDLER
FILE: TROE F,FILEIT ; IN FILE MODE ALREADY ?
SE <%FILE COMMAND ILLEGAL IN FILE MODE>
CALL SCAN ; SCAN THE INPUT FILE NAME
JRST FILEO ; BAD WHATEVER
SKIPN 2 ; EXTENSION ?
MOVSI 2,'CMD' ; ASSUME CMD FILE
CALL DS4INI ; INIT THAT DEVICE
FILE1: JRST [P$RINT <?INIT FAILED FOR DEVICE>
JRST FILEO]
JRST [P$RINT <?LOOKUP FAILED FOR FILE>
JRST FILEO]
MOVEI 14,DS4IN ; 14 = INPUT SUBROUTINE TO CALL
JRST COB10
FILEO: CALL DS4CLS ; CLOSE CHANNEL
TRZ F,FILEIT ; CLEAR FLAG
JRST COB101
; START THE INTERPRETING OF THE COBOL FD
HFILE: TRNE F,FILEIT ; IN A INDIRECT COMMAND ?
SE <%COBOL RECORD SCANNER UNAVAILABLE>
CALL SCAN ; GET THE FILE NAME
JRST COB101 ; OOPS
CALL DS4INI
JRST FILE1
JRST FILE1+1
CALL SCNBEG ; START THE WHEELS ROLLING
MOVE 1,CURPOS ; GET # POSITIONS IN FILE
MOVEM 1,RECSIZ ; SET HERE
CALL NOUT ; EDIT OUT THE NUMBER
OUTSTR [ASCIZ/ POSITIONS SCANNED FOR RECORD/]
OUTSTR CRLF
JRST FILEO ; CLOSE DOWN
SUBTTL BEGIN INTERACTIVE PROCESSING
ENDIT: SKIPE 1,RECSIZ ; THIS ONE MUST BE ENTERED
JRST ENDI2
P$RINT <%RECORD SIZE MUST BE ENTERED!>
JRST COB101 ; REINIT
ENDI2: MOVSI 4,'TTY' ; LIST FILE IS TTY FOR NOW !
CALL DS3INI ; INIT THE DEFAULT LIST DEVICE
JRST [P$RINT <?CANNOT INIT DEFAULT LIST DEVICE>
HALT .]
JFCL
SETZM CURLIN
MOVEI 1,5 ; SET MODE
ADDB 1,MODE
TRNE F,AFLAG ; ASCII FILE ?
JRST ENDI1 ; YES -- SKIP THIS
ADD 1,RECSIZ ; DO A COVERED DIVIDE
SUBI 1,1 ; OFF BY ONE
IDIV 1,MODE ; 1 = # OF FULL WORDS
IMUL 1,MODE ; # OF FULL CHARS
SUB 1,RECSIZ ; 1 = # OF DUMMY RECORDS
MOVEM 1,DUMMY ; SAVE HERE FOR LATER
SKIPN 4,BSIZE ; A BLOCK SIZE SPECIFIED ?
JRST ENDI1 ; NO -- JUST PASS THE DATA LINEARLY
MOVEM 4,GETREX ; # RECORDS BEFORE DATA SKIP
MOVEM 4,PUTREX ; HERE FOR PUTREC
ADD 1,RECSIZ ; 1 = # OF POSITIONS IN REC + DUMMY
MOVE 3,MODE ; GET THE MODE
CAIN 3,7 ; ASCII ?
SUBI 3,2 ; YES -- 5 CHARS PER WORD
IDIVI 1,0(3) ; 1 = # OF WORDS THIS REC
ADDI 1,1 ; INCLUDE THE RECORD DESCRIPTOR !!
IMULI 4,0(1) ; 4 = # WORDS OF GOOD DATA
SUBI 4,^D128 ; 4 = # WORDS OF BAD DATA
IMULI 4,0(3) ; 4 = # POSITIONS OF SKIPPED DATA
MOVMM 4,BSIZEC ; SAVE HERE FOR GETREC
ENDI1: PRINT <ENTER OUTPUT FILE NAME >
CALL SCAN ; SCAN THE FILE NAME TYPED
JRST ENDI1 ; OOPS -- SOMETHING HAPPENED
DMOVEM 1,OFN ; SAVE OUTPUT FILE NAME
DMOVEM 3,OFN+2 ; FOR LATER
SETOM EOFFLG ; DONE NOTHING YET
CALL DS2INI ; INIT THE OUTPUT FILE
JRST [P$RINT <?CANNOT INIT DEVICE>
JRST ENDI1]
JRST [P$RINT <?CANNOT ENTER FILENAME>
JRST ENDI1]
; COMMAND PROCESSING
CMDLP: TRNE F,COMNFL ; IN A COMMAND ?
JRST CMDCLR ; HERE WITH A COMMAND IN PROGRESS -- CLEAR
OUTSTR [ASCIZ/ML-/] ; CATCH THE MANIPULATION LANGUAGE COMMANDS
CMDLP1: CALL TTYI
MOVE 2,[IOWD MLLEN,MLTBL+1]
CAME 1,0(2) ; IN TABLE ?
AOBJN 2,.-1 ; NO - SEARCH THE TABLE
TRO F,COMNFL ; IN A COMMAND
JUMPL 2,@MLLEN(2)
CE <%ILLEGAL COMMAND>
MLTBL: + "L" ; LIST
+ "P" ; PRINT
+ "F" ; FIND
+ "R" ; REPLACE
+ "E" ; EXIT
+ 12 ; SET FLAG
+ 15 ; AND CR
+ 33 ; ALT IS BACKUP !
+ "D" ; DELETE THE CURRENT RECORD !
+ "S" ; TYPE THE SCALE
+ "H" ; HELP
+ "I" ; INSERT A LINE OR TWO
MLLEN==.-MLTBL
+ LISTEM
+ PRINTM
+ FINDIT
+ REPIT
+ EXITIT ; $E
+ NLINE ; DO THE NEXT LINE
+ SETCR
+ LLINE ; DO THE LAST LINE
+ DLINE ; DO THE DELETE
+ PSCALE
+ HELPM
+ INSERT ; INSERT
HELPM: OUTSTR MLHLP ; HELP !
CMDCLR: SKIPA 1,TTYLST ; GET LAST CHAR TYPED
CALL TTYI ; THERE BETTER BE ANOTHER CHAR
CAIE 1,"Z"-100
CAIN 1,33
MOVEI 1,12 ; ASSUME THE BEST
CAIE 1,12 ; LF ?
JRST CMDCLRI+1
TRZ F,COMNFL
MOVE P,[IOWD PDLLEN,PDL]
JRST CMDLP
SUBTTL NEXT LINE AND BACKUP A LINE
SETCR: TRO F,GOTCR ; WE HAVE A CR
JRST CMDLP1 ; CHECK ON NEXT
NLINE: TRZE F,GOTCR ; LYING A CR ?
JRST CMDLP ; YES -- IGNORE
AOS 2,CURLIN ; GET CURRENT LINE
MOVEI 3,1 ; # LINES TO PRINT
MOVEI 1,15 ; DO A CR
CALL DS3OUT ; TO THE LIST DEVICE
HALT . ; JUST STOP
JRST PRINTN ; PRINT THE NEXT LINE
; BACKUP A LINE
LLINE: SKIPG CURLIN ; TO NEXT ?
JRST LLAT
MOVEI 2,CRLF ; DO THIS
CALL DS3PRT ; TO THE LIST FILE
SOS 2,CURLIN
MOVEI 3,1 ; ONLY ONE FLINE
JUMPG 2,PRINTN ; PRINT IT IF POSSIBLE
LLAT: P$RINT <%AT BEGINNING OF FILE>
JRST CMDLP
; SCALE - PRINT OUT THE SCALE
PSCALE: CALL SCALE
JRST CMDLP
SUBTTL EXIT ROUTINES
EXITIT: CALL SCAN ; SCAN A FILE NAME
JRST CMDLP ; OOPS -- ERROR
JUMPE 1,.+3 ; ANYTHING ?
DMOVEM 1,OFN ; OUTPUT FILE NAME
DMOVEM 1,OFN+2 ; FOR LATER
CALL EXITRT ; ON THE EXIT
EXIT 1,
JRST COBEDT ; ON THE CONTINUE
EXITRT: CALL GETREC ; READ A RECORD
JRST EXITI0 ; ALL DONE
JRST EXITRT ; DO FOR ALL
EXITI0: TRZE F,JUSTEX ; JUST EXIT ?
RET ; YES -- NO RENAME
DMOVE 1,OFN ; 1,2 = FN,EXT
MOVE 4,OFN+2 ; PPN
SETZ 3,
RENAME 3,1 ; YES -- RENAME THE MAGIC ONE
CE <%CANNOT RENAME FILE>
SETOM EOFFLG ; AT THE BEGINNING
EXITN: RET
SUBTTL FIND ROUTINES
FINDIT: TRO F,FINDFG ; [00] FINDING
CALL STRSCN ; SCAN S<STR>$<COL RANGE>
JRST CMDLP ; OOPS -- BAD STRING
TRZE F,NULLF ; JUST A F ?
JRST FINF ; YES -- GO DUMMY THE RANGE
SKIPGE 16 ; OK ?
CE <%LINE RANGE MUST BE SPECIFIED>
CALL SCANR
DMOVEM 2,STARTL ; SAVE FOR BLANK FINDS
FINDI: HRLI 3,0(2) ; SAVE IN ACW
MOVE 16,3
CALL RECPOS ; POSITION TO THE REQUIRED RECORD
CE <%NO SUCH RECORD>
HRRI 15,0(16) ; 15 = # RECORDS TO LOOK AT
MOVE 1,FTBL-1(5) ; GET ADDRESS
MOVEM 1,FJUMP ; OF COMPARISON ROUTINE
JRST FIN3 ; AND ENTER CORRECTLY
FIN2: CALL GETREC ; GET THE RECORD
JRST FATEOF ; AT END OF FILE
FIN3: CALL @FJUMP ; GO TO RIGHT STRING MATCH
JRST FINP ; GO PRINT
SOJG 15,FIN2 ; REPEAT FOR ALL
FATEOF: P$RINT <%SEARCH FAILED>
SKIPE 15 ; FALL THROUGH ?
CALL EOFRES ; NO -- DO A EOF RESET
JRST CMDLP
FTBL: + FSIXC ; SIXBIT COMPARE ROUTINE
+ FASCC ; ASCII
+ FCOMP ; SINGLE COMP
[CE <%NOT IMPLEMENTED FOR DOUBLE WORD>
]
FINP: CALL PRTREC ; PRINT THE RECORD
JRST CMDLP
FINF: MOVE 2,EOFFLG ; # RECORDS - 2
ADDI 2,2 ; WHERE TO START THE SEARCH
MOVE 3,STARTL ; GET STARTED LAST
SUBI 3,0(2) ; WHERE WE ARE NOW = # LEFT
SUB 3,STARTB
MOVMS 3
JRST FINDI
; THE COMPARISON ROUTINES FOR THE FILES
FSIXC: MOVE 1,FDAT ; 1 = POSITION TO MOVE OVER
IDIVI 1,6 ; NOW GET WORD AND SPOT IN WORD
MOVE 4,[POINT 6,RECSTR]
ADDI 4,0(1) ; 4 = BP TO START OF MATCH
SKIPE 2 ; ANY SPOTS TO MOVE OVER ?
IBP 4 ; YES -- INC THE BP
SOJG 2,.-1 ; REPEAT AS NEEDED
MOVE 5,[POINT 7,STRING]
MOVE 6,FDAT+1 ; 6 = # CHARS IN THE MATCH
FSIXC1: ILDB 1,4 ; GET CHAR FROM RECORD
ILDB 2,5 ; AND FROM THE MATCH REQUEST
TRC 2,40 ; CVT FOR A SIXBIT MATCH
ANDI 2,77 ; KEEP THE BOTTOM ONLY
CAIE 1,0(2) ; A POSITIVE MATCH ?
AOSA 0(P) ; NOT -- STOP SCAN
SOJG 6,FSIXC1 ; REPEAT FOR ALL CHARS
RET ; RETURN AS NEEDED
; ASCII COMPARE ROUTINE
FASCC: MOVE 1,FDAT ; DISP IN RECORD REQUESTED
IDIVI 1,6 ; 1 = WORD, 2 = DISP IN WORD
MOVE 4,[POINT 7,RECSTR]
ADDI 4,0(1) ; 4 = BYTE POINTER IN CURRENT RECORD
SKIPE 2 ; ANY OFF ?
IBP 4 ; YES - MAKE UP FOR IT
SOJG 2,.-1
MOVE 5,[POINT 7,STRING] ; 5 = WHERE THE MATCH REQUESTED IT
MOVE 6,FDAT+1 ; 6 = # CHARS TO MATCH ON
FASC1: ILDB 1,4 ; GET A CHAR FROM THE RECORD
ILDB 2,5 ; AND FROM THE MATCH
CAIE 1,0(2) ; EQUAL ?
AOSA 0(P) ; NO -- EXIT WITH A SKIP RIGHT NOW
SOJG 6,FASC1 ; REPEAT AS NEEDED
RET ; RETURN AS REQUESTED
; COMPUTATION COMPARISON ROUTINE
FCOMP: CALL CMPSCN ; SCAN A COMP FIELD FOR ACCURACY
JRST CMDLP ; OOPS -- ERROR
FCOMP1: CALL GETNU1 ; SCAN THE NUMBER
MOVE 1,0(7) ; GET ACTUAL DATA FROM RECORD
ADDI 7,1 ; TO NEXT JUST IN CASE
CAME 2,1 ; SAME ?
AOSA 0(P) ; NO -- EXIT WITH A SKIP
SOJG 6,FCOMP1 ; YES -- REPEAT FOR ALL
RET ; RETURN TO CALLER CORRECTLY
; SCAN A COMP FIELD FOR ACCURACY
CMPSCN: MOVE 1,FDAT ; 1 = # POSITION THIS FIELD STARTS ON
IDIVI 1,6 ; DETURMINE ITS WORD ADDRESS
SKIPE 2 ; BETTER BE A WORD BOUNDARY !
CE <%COMP FIELD MUST BEGIN ON WORD BOUNDARY>
MOVEI 7,RECSTR(1) ; 7 = WORD ADDR OF COMP DATA
MOVE 4,FDAT+1 ; 4 = # POSITIONS OF COMPARE
IDIVI 4,6 ; GOT TO BE A MULTIPLE OF 6
SKIPE 5 ; ALL OK ?
CE <%COLUMN RANGE DOES NOT END AT END OF COMP FIELD>
MOVE 6,4 ; 6 = # WORDS IN SEARCH LOOP
MOVE 5,[POINT 7,STRING] ; 5 = BP TO DATA
MOVE 4,[ILDB 1,5] ; 4 = INSTRUCTION FOR NUMBER SCANNING
AOS 0(P) ; GIVE A SKIP
RET ; ON RETURN
SUBTTL INSERT A LINE
INSERT: CALL SCANR ; SCAN THE RANGE
CAIE 3,1 ; ONLY ONE LINE NUMBER PERMITTED
CE <%LINE RANGE NOT PERMITTED>
PUSH P,14 ; SAVE THIS GUY !
TRZE F,RECWRT ; DO WE ALREADY HAVE A RECORD ?
INSERL: CALL PUTREC ; YES -- MAKE SURE ITS WRITTEN.
MOVE 16,[POINT 3,POS] ; 16 = START OF STRING SCAN
MOVE 15,[1,,1] ; 15 = COLUMN RANGE CURRENTLY ON
MOVE 13,RECSIZ ; DO ALL THE CHARACTERS
INSERX: CALL INSET ; MAKE SURE WE SET UP TO A VALID FIELD
CAIE 14,3 ; COMP ?
JRST INSER0 ; NO -- JUST SIX/ASC
SUBI 13,6 ; YES -- DO FUNNY THINGS
ADDI 15,6 ; TO SAVE A FEW STEPS
TRNN 15,1 ; GOT A SPECIAL FUDGE ?
ADD 15,[1,,1] ; ** FUDGE **
JRST INSER2 ; GO DIRECTLY
INSER0: ILDB 1,16 ; GET THE TYPE
CAIE 1,0(14) ; SAME TYPE AS PREDECESSOR
JRST INSER2 ; NO
ADDI 15,1 ; INCREMENT COLUMN PPOSITION
INSER1: SOJG 13,INSER0 ; REPEAT UNTIL NO FIND
INSER2: OUTSTR [ASCIZ/INSERT: /]
MOVE 1,TYPTBL-1(14)
OUTSTR 0(1) ; GIVE THE TYPE
HLRZ 1,15 ; GET STARTING COLUMN
CALL NOUT
MOVEI 1,":"
OUTCHR 1 ; FOLLOWED BY A ":"
MOVEI 1,0(15) ; THE ENDING COLUMN NUMBER
SUBI 1,1 ; OFF BY ONE
CALL NOUT
SUB 15,[1,,1] ; NOW FOOL REPLACE !
HLRZM 15,FDAT ; SET STARTING COLUMN
SUB 15,FDAT ; AND ENDING COLUMN
HRRZM 15,FDAT+1
ADD 15,FDAT ; AND CORRECT
ADD 15,[1,,1]
MOVEI 1,">" ; DO THE ">" STUFF
OUTCHR 1 ; TO THE TERMINAL
TRO F,SFLAG ; DO A STRING SCAN
SETZM TTIBUF##+2 ; ZERO THE INPUT BUFF
CALL STRSCN ; YOU HAVE TO FOOL THIS GUY TOO
CAIN 1,33 ; ALT ?
JRST CRCMDL ; ALL DONE
TLNN 15,777776 ; THE FIRST TIME THROUGH
CALL BLTSTR
CALL @REPTBL-1(14) ; AND ENTER THE RIGHT ROUTINE
LDB 14,16 ; GET THE NEW MODE
HRLS 15
JUMPN 13,INSERX ; REPEAT AS NEEDED
AOS EOFFLG ; INCREMENT RECORD WE ARE ON
AOS CURLIN ; AND THIS ONE ALSO
JRST INSERL ; AND CONTINUE
TYPTBL: [ASCII "S "]
[ASCII "A "]
[ASCII "1 "]
[ASCII "2 "]
CRCMDL: OUTSTR CRLF ; GIVE A CRLF AFTER THE ALTMODE
POP P,14 ; RESTORE 14
JRST CMDLP
INSET: ILDB 14,16 ; GET A TYPE CODE
JUMPN 14,[SOJA 13,INSET1]
SOJG 13,INSET ; REPEAT AS NEEDED
POP P,0(P) ; LESS THIS CALL ADDRESS
TLNN 15,777776 ; FIRST TIME THROUGH ?
CALL BLTSTR ; YES -- ZERO THE REC
JRST INSERL
BLTSTR: MOVE 1,[RECSTR,,RECSTR+1]
SETZM -1(1) ; ZERO THE AREA
BLT 1,<<POSLEN+4>/5>-1+RECSTR
INSET1: RET
SUBTTL REPLACE ROUTINES
;
; R<STRING>$<COLUMN RANGE>
;
REPIT: CALL STRSCN ; SCAN THE FIRST PART OF THE STRING
JRST CMDLP ; OOPS -- BAD
CAIN 1,"," ; TRIED TO SPECIFY A RANGE
CE <%LINE RANGE NOT PERMITTED>
CALL @REPTBL-1(5) ; GO TO THE CORRECT SUBROUTINE
JRST CMDLP ; AND RETURN TO CALLER
REPTBL: + RSIX ; SIXBIT REPLACE
+ RASC ; ASCII REPLACE
+ RCOMP ; COMPUTATIONAL REPLACE
[CE <%DOUBLE PRECISION NOT YET IMPLEMENTED>
]
; REPLACE SIXBIT/ASCII STRINGS
RSIX: MOVE 4,[POINT 6,RECSTR]
MOVEI 3,6 ; # CHARS PER WORD
JRST RASC1 ; GO DO THE SUBSTITUTION
RASC: MOVE 4,[POINT 7,RECSTR]
MOVEI 3,5 ; # CHARS PER WORD
RASC1: MOVE 1,FDAT ; POSITION # WE STARTED ON
IDIVI 1,0(3) ; 1 = WORD, 2 = POSITION IN WORD
ADDI 4,0(1) ; CORRECT THE BYTE POINTER
SKIPE 2 ; BETWEEN WORDS ?
IBP 4 ; YES
SOJG 2,.-1
MOVE 5,[POINT 7,STRING] ; WHERE TO COME FROM
MOVE 6,FDAT+1 ; 6 = # CHARACTERS TO MATCH ON
RASC2: ILDB 1,5 ; GET A CHARACTER
CAIN 3,6 ; SIXBIT ?
TRC 1,40 ; YES
IDPB 1,4 ; SAVE WHILE TRUNCATING HIGH BIT
SOJG 6,RASC2 ; REPEAT FOR ALL
RET ; ALL OK
; REPLACE A COMP FIELD WITH THE SPECIFICS
RCOMP: CALL CMPSCN ; SCAN THE INPUT PARAMS
JRST CMDLP
RCOMP1: CALL GETNU1 ; TRANSLATE A NUMBER TO BINARY
MOVEM 2,0(7) ; SAVE IN THE RECORD
ADDI 7,1 ; INCREMENT FOR OTHERS
SOJG 6,RCOMP1 ; REPEAT FOR ALL FIELDS
RET ; ALL OK
SUBTTL PRINT AND LIST ROUTINES
LISTEM: CALL SCAN ; PICKUP THE FILE NAME
JRST CMDLP
CALL DS3INI ; SET UP THE OUTPUT FILE NAME
CE <%CANNOT INIT OUTPUT DEVICE>
CE <%CANNOT ENTER FILENAME SPECIFIED>
JRST CMDLP ; AND RETURN
DLINE: TRO F,DFLAG ; WE ARE REALLY DELETING
PRINTM: CALL SCANR ; SCAN THE RANGE
PRINTN: MOVE 15,3 ; 15 = # LINES TO PRINT
HRLI 16,0(2) ; 16 = LH:START LINE #,,RH:# LINES
CALL RECPOS ; POSITION TO THAT RECORD
JRST ATEOF
JRST PRINT2 ; NOW EDIT THE RECORD POSITIONED TO
PRINT1: CALL GETREC ; READ A RECORD
JRST ATEOF ; AT THE EOF
PRINT2: TRNE F,DFLAG ; DELETING ?
TRZA F,RECWRT ; YES - DO IT !
CALL PRTREC ; PRINT A RECORD
SOJG 15,PRINT1 ; REPEAT AS SPECIFIED
TRZ F,DFLAG ; WERE WE DELETING ?
JRST CMDLP ; NO -- RETURN TO COMMAND MODE
PRINTE: CE <%BAD LINE RANGE>
SUBTTL EOF ROUTINE
ATEOF: INCHRS 1 ; CLEARA CONTROL O
JFCL
TRZ F,DFLAG ; TURN OFF IF ON
PRINT <%EOF ENCOUNTERED >
PUSH P,[ CMDLP ] ; NOTE FALL THROUGH
; EOFRES -- A EOF RESET ROUTINE
EOFRES: INCHRS 1 ; CLEAR A CONTROL O
JFCL
CALL DS2CLS ; CLOSE OUTPUT
CALL DSKCLS ; AND INPUT
DMOVE 1,OFN ; GET OUTPUT FILE NAME
DMOVE 3,OFN+2
CALL DSKINI ; INIT INPUT
JRST 4,. ; IMPOSSIBLE
JRST 4,. ; LIKEWISE
DMOVE 1,OFN ; INIT A NEW GENERATION OF OUTPUT
DMOVE 3,OFN+2
CALL DS2INI
JRST 4,. ; IMPOSSIBLE UNLESS OVER QUOTE
JRST 4,. ; LIKEWISE
CLRBFI ; CLEAR A CONTROL O IF ANY ?
AOS 1,EOFFLG ; GET THE COUNT
CALL NOUT ; DUMP THE NUMBER TO THE TTY
OUTSTR [ASCIZ/ RECORDS/]
OUTSTR CRLF
SETOM EOFFLG ; SET AT END FLAG
SKIPN 1,BSIZE ; BLOCK FACTOR
RET
MOVEM 1,GETREX
MOVEM 1,PUTREX ; SAVE FOR ROUTINES
RET
SUBTTL GET A RECORD (WHILE PUTTING)
GETREC: TRZE F,RECWRT ; DID WE READ A RECORD ?
CALL PUTREC ; YES -- WRITE THE OLD BEFOR READING NEW
MOVE 10,RECSIZ ; GET THE SIZE OF THE RECORD
TRNN F,NOACWF ; A INTERNAL ACW ?
ADDI 10,6 ; ** ASSUME A SIXBIT FILE **
MOVE 7,[POINT 6,RECSTR-1]
TRNE F,NOACWF ; AND INTERNAL ACW ?
ADDI 7,1 ; YES -- CORRECT BP
TRNE F,AFLAG ; ASCII ?
HRLI 7,(POINT 7,0) ; YES -- CORRECT
GETRE1: CALL DSKIN ; GET 1 SIXBIT CHARACTER
JRST GETRE2 ; AT EOF
IDPB 1,7 ; SAVE CHAR
TRNE F,AFLAG ; IN AN ASCII FILE
CAIE 1,12 ; YES -- A LF ?
SOJG 10,GETRE1 ; NO FOR ALL - REPEAT FOR ALL
MOVE 10,DUMMY ; GET # OF FILLERS
JUMPE 10,.+4
CALL DSKIN ; LOSE THEM
JRST GETRE2
SOJG 10,.-2
TRNE F,NOACWF ; A INTERNAL ACW PRESENT ?
JRST GETREE ; NO -- NO NO VERIFICATION
SKIPN 1,RECSTR-1 ; 1 = SIXBIT DESC -- IS THERE ONE ?
SKIPN BSIZE ; DID WE HAVE A BLOCK SIZE ?
JRST .+3 ; YES -- JUST TELL AND CONTINUE !
OUTSTR HMSG ; PRINT THE HOLY MESSAGE
MOVE 1,RECSIZ ; ASSUME THE GOOD ONE
HRRZS 1 ; KEEP ONLY LOWER HALF FOR ISAM
CAME 1,RECSIZ ; BETTER COMPARE
JRST GETRE3 ; TELL US MORE !
GETREE: AOS 0(P) ; NOT A EOF RETURN !
AOS EOFFLG ; CLEAR FLAG + KEEP COUNT OF RECS
TRO F,RECWRT ; THERE IS A RECORD TO WRITE
SOSE GETREX ; TIME TO DUMMY UP FOR BLOCK ?
RET ; NO,$E
MOVE 1,BSIZE ; GET # RECORDS BEFORE ONE OF THESE
MOVEM 1,GETREX ; SAVE HERE
SKIPE 10,BSIZEC ; 10 = # CHARS TO PAD - IF ANY
CALL DSKIN ; READ
JFCL
SOJG 10,.-2
RET ; AND EXIT
GETRE2: SUB 10,RECSIZ ; 10 = # CHARS XFERED
SUBI 10,6 ; LESS HEADER WORD
SKIPN 10 ; ANY ?
RET
P$RINT <%INCOMPLETE RECORDS EXIST>
RET ; EOF EXIT
GETRE3: OUTSTR [ASCIZ/?RECORD LENGTH INCORRECT/]
OUTSTR CRLF
OUTSTR [ASCIZ/DESCRIBED: /]
MOVE 1,RECSIZ
CALL NOUT
OUTSTR [ASCIZ/ IS: /]
MOVE 1,RECSTR-1
CALL NOUT
OUTSTR CRLF
HALT CMDLP
SUBTTL SAVE A RECORD (PRIMITIVE)
PUTREC: MOVE 10,RECSIZ ; # CHARS THIS RECORD TYPE
TRNN F,NOACWF ; INTERNAL ACW'S IN FILE ?
ADDI 10,6 ; NO -- ADD ON LENGTH OF DESCRIPTOR
MOVE 7,[POINT 6,RECSTR-1]
TRNE F,NOACWF ; INTERNAL ACW'S IN FILE ?
ADDI 7,1 ; NO -- USE RIGHT WORD
TRNE F,AFLAG ; ASCII ?
HRLI 7,(POINT 7,0)
PUTRE1: ILDB 1,7 ; GET THE CHAR FROM REC
CALL DS2OUT ; TO THE OUTPUT FILE
JRST PUTERR ; OOPS -- ERROR
TRNE F,AFLAG ; ASCII ?
CAIE 1,12 ; AND THE LAST CHAR ?
SOJG 10,PUTRE1 ; NO TO BOTH -- REPEAT FOR ALL
MOVE 10,DUMMY ; PAD CORRECTLY
MOVEI 1,0
JUMPE 10,.+4
CALL DS2OUT ; WITH NULLS
JRST PUTERR
SOJG 10,.-2
SOSE PUTREX ; TIME TO PAD OUT A BLOCK ?
RET ; EXIT OK
MOVE 1,BSIZE ; # BEFORE A BLOCK DONE
MOVEM 1,PUTREX ; FOR THE PUT ROUTINES
SETZ 1, ; OUTPUT NULLS
SKIPE 10,BSIZEC ; 10 = # OF NULLS TO OUTPUT
CALL DS2OUT
JFCL
SOJG 10,.-2
RET ; $E
PUTERR: P$RINT <?OUTPUT FILE ERROR>
HALT .
SUBTTL MISC SUBROUTINES
;
; SCAN A LINE/COLUMN RANGE
; 1/ CHAR THAT TERMINATED SCAN
; 2/ START NUMBER
; 3/ ENDING NUMBER (START # IF OMITTED)
;
SCANR: TRNE F,CHARFL ; LYING A CHARACTER ?
CALL SCANC ; NO -- CLEAR THE NECESSARY
CALL GETNUM ; GET A NUMBER FROM USER
MOVE 3,2 ; COPY HERE
CAIN 1,":" ; A COLON TERMINATED GETNUM'S SCAN ?
CALL GETNUM ; GET ANOTHER
EXCH 3,2 ; NO -- IN REVERSE ORDER
SUBI 3,-1(2) ; 3 = # LINES AFTER 1
JUMPL 3,PRINTE ; OOPS -- ERROR
RET ; $E
; NOUT -- OUTPUT A DIGIT TO THE TTY
NOUT: IDIVI 1,^D10 ; DIVIDE TO DECIMAL
HRLM 2,0(P) ; SAVE IN LH OF STACK
SKIPE 1 ; ANY LEFT ?
CALL NOUT ; NO -- DO A RECURSIVE CALL
HLRZ 1,0(P) ; GET BACK THE NUMBER
ADDI 1,"0" ; TO DECIMAL
OUTCHR 1 ; TO TTY
RET ; $E
; DECIMAL EDITING ROUTINE (1 = #)
DECOUT: MOVE 2,1 ; SAVE ACROSS CALL
A$DIT APKT ; ENTER ASCII EDIT MODE
MOVE 1,2 ; AND RESTORE
MOVEI 2,^D12 ; 12 DIGIT FIELD
TRNE F,FOURFG ; ONLY 4 DIGITS ?
MOVEI 2,4
A%DECF
MOVEI 1,0 ; EDIT IN A NULL
A%CHAR
MOVE 2,[POINT 7,IM] ; NOW COPY THE NUMBER OVER
ILDB 1,2
JUMPE 1,.+4
CALL DS3OUT
HALT . ; NO WAY THIS SHOULD HAPPEN
JRST .-4 ; REPEAT FOR ALL
RET
; POSITION TO THE RECORDS SPECIFIED IN 16
RECF: CAIN 3,1(2) ; THIS RECORD IN ALREADY ?
JRST RECPO2 ; YES -- NO NEED FOR FIND
TRO F,JUSTEX ; INSURE A COPY
CALL EXITRT
CALL EOFRES ; EOF RESET ON FILE
RECPOS: HLRZ 3,16 ; GET RECORD NUMBER
MOVE 2,EOFFLG ; GET CURRENT RECORD
CAIGE 3,1(2) ; POSITION BACKWARDS REQUIRED ?
JRST RECF ; YES
SUBI 3,1(2) ; 3 = # RECORDS TO POSITION AHEAD
JUMPE 3,RECPO2 ; ANY TO MOVE ?
CALL GETREC ; YES -- LET GETREC DO IT
RET ; AT EOF !
SOJG 3,.-2 ; REPEAT FOR ALL
RECPO2: AOS 0(P) ; SKIP IF ALL OK
RET
; COMPUTE A BYTE POINTER BASED ON INPUT DATA
BITFIG: SUBI 12,0(1) ; 12 = # BITS LEFT THIS WORD OF DATA
JUMPL 12,BITN ; EXHAUSTED ? YES,BITN
MOVEI 6,0(12) ; 6 = CREATED BYTE POINTER
ADDI 6,0(1) ; CORRECT FOR THE SUBTRACT
LSH 6,^D6 ; P IS MOVED PREPARE FOR S
ADDI 6,0(1) ; ADD ON S (# BITS THIS BYTE)
LSH 6,^D6+^D18
ADDI 6,0(11) ; ADD ON CURRENT ADDRESS
CAIN 1,^D36
JRST BITX1 ; COMPHENSATE
CAME 1,[^D72,,^D36] ; [00] COMP 2 ?
RET ; 6 = BYTE POINTER
BITX2: MOVEI 2,^D11 ; # LEFT IN POS TABLE
AOJA 11,.+2
BITX1:: MOVEI 2,^D5
IBP 10 ; POSITION TO NEXT WHATEVER
SOJG 2,.-1
RET ; $E
BITN: MOVEI 12,^D36 ; GET SET FOR NEXT WORD
AOJA 11,BITFIG ; INCREMENT FOR NEXT WORD
; UUOH -- HANDLE THE PRINT UUO'S
UUOH: SOS 1,0(P)
HRRZ 2,0(1) ; GET THE TEXT ADDRESS
OUTSTR 0(2) ; PRINT THE MESSAGE
OUTSTR CRLF
LDB 2,[POINT 7,0(2),6] ; GET FIRST CHAR IN MSG
CAIN 2,"?" ; A STOPCODE ?
HALT . ; YES -- HALT
LDB 2,[POINT 9,0(1),8]
CAIE 2,3 ; FROM COBOL FD SCANNER ?
JRST @UUOHT-1(2) ; RETURN TO PROPER ROUTINE
OUTSTR RECSTR ; OUTPUT THE BAD LINE
OUTSTR CRLF ; AND A CRLF
JRST SCNBEG ; AND TRY TO CONTINUE
UUOHT: + COBCLR ; ERRS
+ CMDLP ; ERRC
; SCAN A STRING OF THE FORMAT <C><STR>$<COLUMN RANGE>
STRSCN: MOVEI 5,STRLEN ; MAX LENGTH OF STRINGS
MOVE 4,[POINT 7,STRING]
TRZE F,FINDFG ; [00] FINDING (MAYBE FOR A SECOND TIME)
JRST FIN0 ; [00] YES -- DON'T ZERO THE DATA
MOVE 1,[ASCII " " ]
MOVEM 1,STRING ; PUT IN BLANKS !
MOVE 1,[STRING,,STRING+1]
BLT 1,<<STRLEN+4>/5>-1+STRING
FIN0: CALL TTYI ; READ A CHARACTER
CAIN 1,15 ; CR ?
JRST FIN0 ; YES - IGNORE
CAIN 1,12 ; LF ?
JRST FIN12 ; YES - DO NOT RESET ANYTHING
IDPB 1,4 ; 4 = STRING BYTE PTR
CAIN 1,33 ; MUST BE AN ALTMODE
JRST FIN1 ; IT IS
CAIN 1,"Z"-100
TDZA 5,5
SOJG 5,FIN0 ; SCAN AS MANY AS REQUIRED
OUTSTR CRLF
CE <%STRING TOO LONG>
FIN1: SUBI 5,STRLEN ; 5 = -LENGTH OF STRING
MOVMM 5,STRSIZ ; SAVE THE SIZE
TRZE F,SFLAG ; FROM A INSERT STRING SCAN ?
RET ; YES -- RETURN NOW WITH NO COLUMN RANGE
PRINT < COLUMN RANGE >
CALL SCANR ; READ THE RANGE
SETZM 16 ; 16 = FLAG REG FOR LINE RANGE
CAIE 1,"," ; COMMA ?
SOJ 16,
SOS 2 ; 2 = STARTING POSITION
DMOVEM 2,FDAT ; FDAT = STARTING POS, FDAT+1 = # POSITIONS
FIN10: IDIVI 2,^D12 ; 2 = WORD POSITION, 3 = CHAR IN WORD
ADD 2,[POINT 3,POS] ; INTO A BYTE PTR
SKIPE 3 ; PRESENT ?
IBP 2 ; NO -- CORRECT FOR NON WORD BOUNDARY
SOJG 3,.-1 ; REPEAT UNTIL MATCHED
MOVEM 2,FDAT+2 ; FDAT+2 = START OF DESCRIPTORS
MOVE 4,FDAT+1 ; 4 = # POSITIONS IN RANGE
ILDB 5,2 ; 5 = TYPE OF STRING
SOJLE 4,.+5 ; DON'T DO IF SINGLE CHARACTER
ILDB 1,2 ; GET NEXT CHAR
CAIE 1,0(5) ; MATCH FIRST ?
CE <%MATCH MAY NOT INVOLVE DIFFERENT DATA TYPES>
SOJG 4,.-3 ; ALL DATA TYPES THE SAME ?
AOS 0(P) ; SKIP FOR OK
RET
FIN12: TRNE F,SFLAG ; A STRING SCAN FROM INSERT ?
JRST FIN1 ; YES -- COMPUTE CC AND EXIT
CAIE 5,STRLEN ; TYPED ANYTHING ?
CE <%NO MATCH PERMITTED>
TRO F,NULLF ; NULL STRING -- JUST CONTINUE
DMOVE 2,FDAT ; GET THE OLD
JRST FIN10 ; AND ENTER
SUBTTL PRINT OUT A PRINT PAGE
PRTREC: MOVE 10,[POINT 3,POS] ; 10 = POSITION TABLE ADDRESS
MOVEI 11,RECSTR ; 11 = WHERE THE DATA IS
MOVEI 12,^D36 ; 12 = BIT POINTER IN DATA WORD !
MOVE 13,RECSIZ ; # CHARS THIS RECORD
MOVE 1,EOFFLG ; GET RECORD # - 2
ADDI 1,1 ; OFF BY 1
MOVEM 1,CURLIN ; THE CURRENT LINE NUMBER
TRO F,FOURFG ; 4 DIGITS TO DECOUT
CALL DECOUT ; TO LIST DEVICE
TRZ F,FOURFG
MOVEI 2,[ASCII/. /] ; PRINT
CALL DS3PRT ; GO PRINT
PRTRET: ILDB 1,10 ; GET A POSITION TYPE
JRST @PRTCMD(1) ; DISPATCH PROPERLY
PRTCMD: + PRTSKP ; DO NOTHING - SKIP
+ PRTSIX ; PRINT SIXBIT
+ PRTASC ; PRINT ASCII
+ PRTCOM ; PRINT COMPUTATIONAL
+ PRTCM2 ; PRINT COMP-2
PRTSKP: MOVE 1,MODE ; GET THE MODE OF THE FILE
CALL BITFIG ; ADVANCE CORRECTLY
ILDB 1,6 ; MAKE SURE WE HAVE THE CHAR !
PRTREB: TRNE F,AFLAG ; ASCII ?
CAIE 1,12 ; LF GIVEN ?
SOJG 13,PRTRET ; CONTINUE ? YES,PRTRET
MOVEI 2,CRLF ; THE CRLF SEQUENCE
CALL DS3PRT
RET
; PRINT OUT THE SCALE
SCALE: SKIPN FMT ; FORMAT BEE BUILT YET ?
CALL SETHED ; NO -- GO BUILD THE HEADERS
MOVEI 2,FMT
CALL DS3PRT
MOVEI 2,FMT1
CALL DS3PRT ; PRINT THE HEADERS
RET
PRTSIX: MOVEI 1,6 ; 6 BITS OF DATA
CALL BITFIG ; FIGURE OUT BIT PATTERN
ILDB 1,6 ; GET THE CHAR
CAIL 1,'A' ; CVT TO ASCII
CAILE 1,'Z'
TRCA 1,40 ; CVT TO ASCII
TRC 1,140 ; YES -- CVT CORRECTLY
PRTSI1: CALL DS3OUT ; AND PRINT
HALT . ; CANNOT HAPPEN
JRST PRTREB ; EXIT FOR NEXT
PRTASC: MOVEI 1,7 ; DO A ASCII FIELD
CALL BITFIG ; CREATE A BYTE PTR
ILDB 1,6 ; 1 = CHAR
CAIE 1,15 ; LF ?
CAIN 1,12 ; CR ?
JRST PRTREB ; YES -- DON'T PRINT
JRST PRTSI1 ; AND EDIT IT OUT
PRTCOM: MOVEI 1,^D36 ; 36 BIT CHUNKS
CALL BITFIG ; BUILD A BYTE POINTER
PRTCO1: ILDB 1,6 ; GET THE FULL WORD
CALL DECOUT ; CVT TO DECIMAL
SUBI 13,5 ; 6 CHARS PER WORD
JUMPG 13,PRTREB ; ALL OK ?
P$RINT <%A COMP FIELD IS LARGER THAT RECORD SIZE>
HALT .
PRTCM2: MOVE 1,[^D72,,^D36] ; [00] 36 BIT BYTES
CALL BITFIG ; DETERMINE BYTE PTR
ILDB 1,6 ; GET WORD
CALL DECOUT ; CVT TO DECIMAL
MOVEI 1,"/" ; SEP WITH A SLASH
CALL DS3OUT
HALT . ; [00] DON'T FORGET THIS !
SUBI 13,6 ; DECREASE SIZE OF FIELD
JRST PRTCO1 ; AND DO LAST WORD
DS3PRT: HRLI 2,(POINT 7,)
ILDB 1,2 ; GET CHAR
JUMPE 1,.+4
CALL DS3OUT ; TO OUTPUT DEVICE
HALT . ; ON ERROR
JRST .-4
RET ; RETURN
; BUILD THE HEADERS FOR PRETTY OUTPUT
SETHED: MOVE 1,[FMTLEN,,FMT] ; THE FIRST HEADER
MOVEM 1,APKT ; INTO THE EDIT PACKAGE
A$DIT APKT
A$FD2 [ASCIZ/REC # /]
MOVE 5,RECSIZ ; GET THE RECORD SIZE
TRNE F,AFLAG ; ASCII ?
MOVEI 5,^D132 ; ASSUME MAX HERE
MOVE 4,[POINT 3,POS] ; 4 = THE POSITION DESCRIPTORS
ILDB 1,4 ; GET A DESCRIPTOR
JUMPN 1,.+3 ; A ENTRY ?
SETHE1: SOJG 5,.-2 ; REPEAT FOR ALL
JRST SETHE2 ; NEXT STAGE
MOVE 1,SETTBL-1(1) ; GET THE DEMARKATION CHARACTER
A%FD1 ; EDIT IN THE CHAR(S)
JRST SETHE1 ; AND COUNTINUE
SETTBL: ASCII /S/ ; SIXBIT
ASCII /A/ ; ASCII
ASCII / 1/ ; SINGLE PRESCISION BINARY
ASCII / 2/ ; DOUBLE PRECISION BINARY
SETHE2: A$LINE
A$CHAR ; A NULL
MOVE 1,[FMTLEN,,FMT1]
MOVEM 1,APKT ; SET FOR NEXT LINE
A$DIT APKT
A$POS 6 ; ROOM FOR THE RECORD #
MOVE 3,[POINT 3,POS] ; 3 = DESCRIPTOR TABLE POINTER
MOVEI 4,1 ; 4 = WHAT POS WE ARE ON MOD 10
MOVE 6,RECSIZ ; RECORD SIZE
TRNE F,AFLAG
MOVEI 6,^D132
SETHE3: ILDB 2,3 ; GET POS TABLE DESCRIPTOR
JUMPE 2,SETHE4 ; ANY DESCRIPTION ?
IDIVI 4,^D10 ; MOD 10 (5 = POSITION)
MOVEI 1," " ; CHECK FOR COMP STUFF
CAIL 2,3 ; ?
A%CHAR ; YES -- INSERT THAT EXTRA SPACE
MOVEI 1,"0"(5) ; CVT TO ASCII
A%CHAR ; AND EDIT IT IN
AOS 4,5 ; TO NEXT AND LOAD FOR DIVIDE
SETHE4: SOJG 6,SETHE3 ; REPEAT FOR ALL POSITIONS
A$LINE
A$CHAR ;
MOVE 1,[IML,,IM]
MOVEM 1,APKT ; SET UP EDIT PACKET FOR NEXT PASS
RET ; $E
SUBTTL LITERALS AND HELPS - NOT LISTED
%%=.
XLIST
LIT
FDHLP: ASCIZ/
RECORD N - THE SIZE OF THE RECORD
BLOCK N - THE # OF RECORDS PER 128 WORD BLOCK
NOACW - THE FILE CONTAINS NO INTERNAL COBOL ACCESS WORDS
FD <FILE.EXT> - SCAN THE FD GIVEN INTO INTERNAL FORMAT
SIXBIT M:N[,M:N]- SPECIFY SIXBIT FIELD SPECS
ASCII M:N[,M:N] - SPECIFY ASCII FIELD SPECS
COMP M,N - SPECIFY COMPUTATIONAL FIELDS
COMP-2 M,N - SPECIFY DOUBLE PRECISION COMP FIELDS
- (NOTHING) PROCEED TO MANIPULATION LANGUAGE
/
MLHLP: ASCIZ/
D<R> - DELETE A RECORD
E<FILE.EXT> - EXIT NAME THE FILE (OPTIONAL FN)
F<STR>$<COL>,<R>- FIND THE STRING GIVEN IN THE COLUMNS AND RECORDS SPECIFIED
L<FILE.EXT> - LIST ALL OUTPUT TO THE FILE GIVEN
R<STR>$<COL> - REPLACE THE COLUMNS SPECIFIED WITH THE STRING GIVEN
S - TYPE THE SCALE FOR THE RECORD GIVEN
$ - (ALTMODE) MOVE UP A RECORD
LF - (LINEFEED) MOVE DOWN A RECORD
/
LIST
%%=.-%%
SUBTTL COBEDT DATA AREA
HMSG: ASCII "%FILE IS BLOCKED WITH NULL RECORDS "
CRLF: BYTE (7)15,12
RELOC 0
APKT: A$PKT IML,IM
PICTAB: + '9',,-1 ; NUMERIC
+ 'A',,-1 ; ALPHABETIC
+ 'X',,-1 ; GENERAL
+ 'Z',,-1 ; ZERO FILLED
+ 'C',,PICCR ; CREDIT
+ 'D',,PICDB ; DEBIT
+ '(',,PICREP ; MULTIPLE WHATEVERS
PICLEN==.-PICTAB
Z ; FALL THROUGH
ZEROB: ; START OF AREA TO ZERO ON START
MODE: Z ; THE MODE OF THE FILE (6 OR 7)
LENGTH: Z ; # OF POSITIONS OCCUPIED BY A PIC STRING
OLDCHR: Z ; LAST CHARACTER SEEN (SCANNED) FROM DS4IN
TIMES: Z ; # TIMES TO REPEAT PICTURE STRING
PDL: BLOCK PDLLEN ; PDL
STARTL: Z ; WHERE WE STARTED IN FIND
STARTB: Z ; AND # LINES WE DID
CURLIN: Z ; CURRENT USER LINE
BSIZE: Z ; # OF RECORDS PER BLOCK
BSIZEC: Z ; # OF POSITIONS TO DUMMY OUT THIS BLOCK
GETREX: Z ; # OF RECORDS LEFT IN GETREC
PUTREX: Z ; # OF RECORDS LEFT THIS BLOCK IN PUTREC
RECSIZ: Z ; SIZE OF RECORD IN POSITIONS
Z ; ** SIXBIT RECORD SIZE **
RECSTR: BLOCK <POSLEN+6>/5 ; MAX SIZED RECORD GOES HERE
POS: BLOCK <POSLEN+5>/^D12 ; BIT MASK FIELD
CURPOS: Z ; CURRENT POSITION IN RECORD
OFN: BLOCK 4 ; OUTPUT FILE NAME FN,EXT,PPN,DEV
EOFFLG: Z ; -1 => AT EOF
STRSIZ: Z ; SIZE OF STRING
STRING: BLOCK <STRLEN+4>/5 ; WHERE THE STRING COMPARE GOES
NUMBER: Z ; FOR COMP AND
Z ; COMP-1 FIELDS
FMTLEN==<POSLEN+4>/5
FMT: BLOCK FMTLEN ; FORMAT HEADER # 1
FMT1: BLOCK FMTLEN ; FORMAT HEADER # 2
IML==<132+4>/5
IM: BLOCK IML
FJUMP: Z ; JUMP ADDRESS FOR ROUTINES
FDAT: BLOCK 3 ; 0 = START IN POS TABLE
DUMMY: Z ; # OF PAD CHARS THIS REC
; 1 = # POSITIONS
ZEROE: Z ; END OF ZERO AREA
END COBEDT