Trailing-Edge
-
PDP-10 Archives
-
BB-H580E-SB_1985
-
srtsta.mac
There are 10 other files named srtsta.mac in the archive. Click here to see a list.
SUBTTL SRTSTA - NON-COBOL ROUTINES FOR SORT
SUBTTL D.M.NIXON/DMN/DZN/DLC/BRF/CLRH/GCS 21-Jan-83
SEARCH COPYRT
;COPYRIGHT (C) 1975, 1985 BY DIGITAL EQUIPMENT CORPORATION
;ALL RIGHTS RESERVED
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
.COPYRIGHT
IFN FTPRINT,<PRINTX [Entering SRTSTA.MAC]>
SUBTTL TABLE OF CONTENTS FOR SRTSTA
; Table of Contents for SRTSTA
;
;
; Section Page
;
; 1 SRTSTA - NON-COBOL ROUTINES FOR SORT ..................... 1
; 2 TABLE OF CONTENTS FOR SRTSTA ............................. 2
; 3 DEFINITIONS
; 3.1 Flags ............................................. 3
; 3.2 Low Segment Data .................................. 4
; 4 START ADDRESS AND OUTER LOOP
; 4.1 Entry Points ...................................... 5
; 4.2 V/M Fortran Entry and Exit Points ................. 6
; 4.3 Outer Loop ........................................ 7
; 5 INITIALIZATION PROCEDURE ................................. 8
; 6 SCAN CONTROL ROUTINES .................................... 9
; 7 SWITCH HANDLING
; 7.1 /FORMAT:xn.m ...................................... 12
; 8 COLLATING SEQUENCE TABLE ROUTINES ........................ 13
; 9 PSORT.
; 9.1 SORT Initialization Following Command Scanning .... 18
; 9.2 SETMOD - Set Up Recording Mode for SORT ........... 19
; 9.3 KEYEXT - Generate Key Extraction Code ............. 21
; 9.4 Dispatch Tables for Key Extraction ................ 22
; 9.5 KEYGEN - Generate Key Comparison Code ............. 23
; 10 HPURE SEGMENT ERROR MESSAGES ............................. 25
; 11 FATAL ERROR CLEAN-UP ROUTINES ............................ 26
; 12 RELES.
; 12.1 Add Input Record to Tree .......................... 27
; 12.2 Merge Initialization .............................. 28
; 12.3 End of Input File
; 12.3.1 SORT Case .................................. 29
; 12.3.2 MERGE Case ................................. 30
; 12.3.3 Check End Lables ........................... 31
; 13 MERGE. ................................................... 32
; 14 RETRN.
; 14.1 End of Output File ................................ 33
; 14.2 MSTEOT - EOT Detected on Output Tape .............. 34
; 14.3 RETRNM - Return Record From First-pass Merge Files 35
; 15 TAPE LABEL ROUTINES
; 15.1 CHKLBL - Check Header Labels ...................... 37
; 15.2 WRTLBL - Write Header Labels ...................... 41
; 15.3 CHKEND - Check End Labels ......................... 44
; 15.4 WRTEND - Write End-of-file Labels ................. 47
; 15.5 WRTEOT - Write End-of-tape Labels ................. 48
; 16 ENDS.
; 16.1 Clean Up After SORT ............................... 48
; 17 LPURE SEGMENT ERROR MESSAGES ............................. 50
SUBTTL DEFINITIONS -- Flags
IFE FTFORTRAN,<
LOC 137
EXP V%SORT
RELOC
>;END IFE FTFORTRAN
DEFINE COMPARE (R,J)<
JSP P4,@.CMPAR ;;[OK]
>
IF1,<
DEFINE $JRST$ <BLOCK 1> ;KEEP MACRO HAPPY
>
SUBTTL DEFINITIONS -- Impure Data
SEGMENT IMPURE ;[C20]
IFE FTFORTRAN,< ;ONLY IN STAND-ALONE SORT
STACK: BLOCK PDLEN ;PUSHDOWN STACK
>
ZCOR:! ;START OF DATA TO CLEAR
FSTKEY: BLOCK 1 ;POINTER TO LIST OF KEYS & ORDER
LSTKEY: BLOCK 1 ;POINTER TO LAST BLOCK OF KEYS
TEMPSW: BLOCK 1 ;THIS IS A TEMP FILE SPEC
COLSW: BLOCK 1 ;THIS IS A COLLATING SEQUENCE FILE SPEC
;FORM= FLAGS1B12,27B17,LABEL ADDRSSB35
COLADR: BLOCK 1 ;[C20] COLLATING SEQUENCE ADDRESS IF IN CORE
COLCHN: BLOCK 1 ;CHANNEL IN THE AC FIELD FOR READING
COLPTR: BLOCK 4 ;POINTER TO INPUT BUFFER FOR ALT COL SEQ
QOTCHR: BLOCK 1 ;[N25] EITHER " OR ' IN COLLATING SEQUENCE
F.OXBK: BLOCK 1 ;[215] WHERE TO FIND X. BLOCK FOR OUTPUT
F.OUZR: BLOCK 1 ;START OF SCAN OUTPUT CHAIN
F.INZR: BLOCK 1 ;START OF SCAN INPUT CHAIN
F.TMZR: BLOCK 1 ;START OF SCAN TEMP SPEC CHAIN
F.SPC==.-1 ;START OF TEMP SWITCHES
F.BLKF: BLOCK 1 ;BLOCKING FACTOR
F.LABL: BLOCK 1 ;STANDARD, OMITTED, NONSTANDARD
F.VARI: BLOCK 1 ;VARIABLE RECORD SIZE
F.INDU: BLOCK 1 ;INDUSTRY COMPATIBLE MODE
F.STDA: BLOCK 1 ;STANDARD ASCII MODE
F.REW: BLOCK 1 ;[372] REWIND BEFORE USE
F.POSI: BLOCK 1 ;[C11] /POSITION: VALUE
F.UNL: BLOCK 1 ;[372] UNLOAD AFTER USE
F.FMT: BLOCK 0 ;[372]FORMAT STATEMENT
P.BLKF: BLOCK 1 ;DEFAULT BLOCKING FACTOR
P.LABL: BLOCK 1 ;STANDARD, OMITTED, NONSTANDARD
P.VARF: BLOCK 1 ;DEFAULT VARIABLE/FIXED RECORD SIZE
;-1=UNKNOWN, 0=FIXED, +1=VARIABLE
P.INDU: BLOCK 1 ;INDUSTRY COMPATIBLE MODE
P.STDA: BLOCK 1 ;STANDARD ASCII MODE
BPWORD: BLOCK 1 ;NO. OF BYTES PER WORD
CORSIZ: BLOCK 1 ;SIZE IF /CORE SEEN
ALIGN: BLOCK 1 ;+1 IF OUTPUT TO BE WORD ALIGNED (ASCII)
STATSW: BLOCK 1 ;[C20] +1 IF STATISTICS REQUESTED
IBUFNO: BLOCK 1 ;NUMBER OF BUFFERS FOR INPUT FILE
RECSIZ: BLOCK 1 ;NUMBER OF WORDS IN RECORD
RECOUT: BLOCK 1 ;OUTPUT RECORD SIZE IN BYTES
MODE: BLOCK 1 ;RECORDING MODE BITS ,, INDEX
MODEM: BLOCK 1 ;MASK (SET BY SCAN)
IOMODE: BLOCK 1 ;[201] = RH OF MODE UNLESS /BIN, THEN = MODBINARY
P4SAV: BLOCK 1
RECSAV: BLOCK 1
INSREC: BLOCK 1
.CMPAR: BLOCK 1 ;POINTER TO COMPARE CODE SEQUENCES
EXTORG: BLOCK 1 ;[C13] ADDRESS OF EXTRACT CODE SEQUENCES
EXTSZ: BLOCK 1 ;[C13] SIZE OF EXTRACT CODE SEQUENCES
XTRBYT: BLOCK 1 ;NO. OF EXTRA BYTES IN RECORD
MAXKEY: BLOCK 1 ;MIN. NO. OF WORDS TO HOLD ALL KEYS IN RECORD
MINKEY: BLOCK 1 ;MINIMUM SIZE VAR. LEN. REC. MUST BE
ADVFLG: BLOCK 1 ;[N11] POSITIVE IF WRITE AFTER ADVANCING REQUIRED
NOCRLF: BLOCK 1 ;[N11] POSITIVE IF ASCII FILES HAVE NO CRLF
LEAVES: BLOCK 1 ;[N11] NON ZERO IF /LEAVES SEEN
IFE FTOPS20,<
PRIORI: BLOCK 1 ;GLOBAL DSK PRIORITY
>
;
; NOTE THAT BLT IN SCNSLT RUNS TO HERE!!!!!
SEQNO: BLOCK 1 ;[110] -1 = NO SEQ NO. ,+1 = SEQUENCE NO.
MXDVSZ: BLOCK 1 ;MAX. OF I.DVSZ FOR ALL INPUT FILES
COLITS==5*200 ;ALLOW 128 WORDS FOR LITERAL
COLITB: BLOCK COLITS/5 ;BUFFER FOR COLLATE SEQUENCE LITERAL
COLBUF: BLOCK 200 ;HOLD THE ALTERNATE COLLATING SEQUENCE
EZCOR==.-1 ;END OF DATA AREA TO ZERO
KEYZ LAB,<STANDARD,OMITTED,NONSTANDARD,DEC,ANSI,IBM>
KEYZ COL,<ASCII,EBCDIC,FILESPEC,LITERAL,ADDRESS,UASCII,UEBCDIC>
KEYZ MOD,<SIXBIT,ASCII,EBCDIC,BINARY>
KEYZ SUP,<NONE,INFORMATION,WARNING,FATAL,ALL>
SUBTTL ENTRY POINTS
IFE FTFORTRAN,<
SEGMENT HPURE ;[C20]
BEGIN
PROCEDURE (,START)
IFE FTOPS20,<
PORTAL .+3 ;[C20] NORMAL ENTRY
PORTAL .+3 ;[C20] CCL ENTRY
PORTAL FORENT ;[C20] V/M FORTRAN ENTRY
TDZA P1,P1 ;NORMAL OFFSET
MOVEI P1,1 ;CCL OFFSET
IFE FTVM,<
MOVEM .SGNAM,RUNNAM ;[C20] SAVE INITIAL ACCS FOR GETSEG UUO
MOVEM .SGPPN,RUNDIR ;[C20] ..
MOVEM .SGDEV,RUNDEV ;[C20] ..
>
FASTSKIP ;[C20] SKIP BECAUSE FIRST TIME
RSTART: SETZ P1, ;[C20] NO OFFSET ON RESTARTS
RESET ;[C20] [C13] RESET THE UNIVERSE
IFN FTVM,<
MOVEI T2,1 ;[C20] PAGE. UUO ARGUMENT COUNT
MOVEI T3,LOWORG/PGSIZ ;[C29] [C20] GET FIRST PAGE NUMBER
$1% MOVE T0,[XWD .PAGCD,T2] ;[C20] GET ALL THE PAGES
PAGE. T0, ;[C20] ..
NOOP ;[C20] ..
ADDI T3,1 ;[C20] ..
CAIG T3,LOWEND/PGSIZ ;[C20] ..
JRST $1 ;[C20] ..
>
MOVEM P1,OFFSET ;[C20] STORE ENTRY OFFSET
>
IFN FTOPS20,<
RSTART: RESET% ;[C13] [335] THE KNOWN UNIVERSE
MOVE T1,[SIXBIT /SORTV4/]
MOVE T2,T1
SETSN% ;[335] COLLECT PAGING STATISTICS
NOOP ;[C20] ..
>
SETZM FORRET ;[C20] DID NOT GET CALLED BY FORTRAN
JSP P4,INITIALIZE ;INITIALIZE
IFE FTOPS20,<
MOVE T1,.ISBLK ;DATA BLOCK FOR ISCAN
PUSHJ P,.ISCAN## ;INITIALIZE SCANNER
>
JRST LOOP ;[C20] START SORT
END;
;VIRTUAL MEMORY FORTRAN SORT ENTRY AND EXIT POINTS
BEGIN
PROCEDURE (JSP T4,FORENT)
IFE FTOPS20,<
MOVEI T2,1 ;[C20] PAGE. UUO ARGUMENT COUNT
MOVEI T3,LOWORG/PGSIZ ;[C29] [C20] GET FIRST PAGE NUMBER
$1% MOVE T0,[XWD .PAGCD,T2] ;[C20] GET ALL THE PAGES
PAGE. T0, ;[C20] ..
;**;[473] @FORENT + 6L Replace 1 line with 2 GCS 9-DEC-81
JRST $4 ;[473] TRY TO GO VIRTUAL
TLZ T3,200000 ;[473] CLEAR VIRTUAL BIT
ADDI T3,1 ;[C20] ..
CAIG T3,LOWEND/PGSIZ ;[C20] ..
JRST $1 ;[C20] ..
;**;[473] @FORENT + 11L Insert 20 lines GCS 9-Dec-81
JRST $6 ;[473] SKIP VIRTUAL ROUTINE
$4% CAIN T0,PAGNX% ;[473] VIRTUAL PRIVS?
JRST $5 ;[473] NO!
TLNE T3,200000 ;[473] HAVE WE ALREADY WENT VIRTUAL?
JRST $5 ;[473] YES, GIVE UP. PAGE CAN'T BE CREATED.
CAIE T0,PAGLE% ;[473] CORE LIMIT EXCEEDED?
JRST $5 ;[473] NO, ALL OTHER ERRORS ARE FATAL.
HRLI T3,200000 ;[473] SET BIT IN ARG BLOCK.
JRST $1 ;[473] GO TRY TO CREATE ON DISK.
$5% OUTSTR E$$PCF ;[473] START ERROR MESSAGE.
HRRZ T1,T3 ;[473] GET PAGE #
PUSHJ P,.TOCTW ;[473] TYPE IT.
OUTSTR E$$PC1 ;[473] CONTINUE ERROR MESSAGE.
MOVE T1,T0 ;[473] GET PAGE. ERROR CODE
PUSHJ P,.TOCTW ;[473] TYPE IT.
OUTSTR E$$PC2 ;[473] CONTINUE
JRST (T4) ;[473] FORTRAN RETURN ADDR.(FORRET)
>
$6% MOVEM T1,FORFUN ;[C20] SAVE FUNCT. ADDRESS
MOVEM T4,FORRET ;[C20] SAVE RETURN ADDRESS
MOVEM L,FORARG ;[C20] SAVE L
MOVE T1,FORARG ;[C20] GET ARG COUNT
SUBI T1,1 ;[C20] ..
HLRE T1,@T1 ;[C20] ..
MOVMM T1,FORCNT ;[C20] STORE FOR SCANNER
MOVEM P,FORPDP ;[C20] SAVE P
MOVE T1,HIORG+.JBHSM## ;[C20] EXCHANGE SYMBOL TABLES
EXCH T1,.JBSYM## ;[C20] ..
MOVEM T1,FORSYM ;[C20] ..
JSP P4,INITIALIZE ;[C20]
XMOVEI T1,0 ;[526] GET OUR SECTION NUMBER
TLZN T1,-1 ;[526] IN A NON-ZERO SECTION
TLOA T1,20 ;[526] NO - SET THE INDIRECT BIT
TLO T1,200000 ;[526] YES - SET NON-ZERO SECTION INDIRECT BIT.
IOR T1,FORARG ;[526] ADD IN ADDRESS OF ARGUMENT BLOCK
XMOVEI T1,@T1 ;[526] GET ADDRESS OF ARG. TO SORT
IFN FTKI10!FTKL10,<
DMOVE T2,[POINT 7,@T1 ;[C20] GET INPUT BYTE POINTER
POINT 7,BUFFER] ;[C20] OUTPUT BYTE POINTER
>
IFE FTKI10!FTKL10,<
MOVE T2,[POINT 7,@T1] ;[C20] GET INPUT BYTE POINTER
MOVE T3,[POINT 7,BUFFER] ;[C20] OUTPUT BYTE POINTER
>
IFE FTOPS20,<
MOVEM T3,CMDPTR ;[C20] STORE IT FOR LATER
>
MOVNI T4,5*BUFSIZ-2 ;[C20] NO. OF CHARACTERS (NOT INCLUDING LF,NUL)
$2% TLNN T2,(70B5) ;[C20] NEED TO ADVANCE INDIRECT BYTE POINTER?
AOJA T1,[SOJA T2,.+1] ;[C20] YES, ADVANCE IT PROPERLY
ILDB T0,T2 ;[C20] GET CHAR
JUMPE T0,$3 ;[C20] END ON NUL
IDPB T0,T3 ;[C20] STORE
AOJL T4,$2 ;[C20] LOOP
$ERROR (?,CTL,<Command string too long>) ;[C20]
$3% MOVEI T0,.CHLFD ;[C20] LF
IDPB T0,T3 ;[C20]
SETZ T0, ;[C20]
IDPB T0,T3 ;[C20] END WITH NUL
ADDI T4,5*BUFSIZ-1 ;[C20] DONT COUNT THE NULL
MOVEM T4,CMDLEN ;[C20] STORE SIZE
IFN FTOPS20,<
SETZM FOR2ND ;[C20] RESET COMMAND SEEN BEFORE
>
IFE FTOPS20,<
SETZM QBUFER ;[C20] RESET FORTRAN OUTPUT BUFFER STATUS
MOVE T1,.ISFBK ;[C20] FORTRAN DATA BLOCK FOR ISCAN
PUSHJ P,.ISCAN## ;[C20] INITIALIZE SCANNER
>
JRST LOOP ;[C20] GO TO SORT
END;
BEGIN
PROCEDURE (PUSHJ P,FORXIT)
MOVE P,FORPDP ;[C20] RESTORE ORIGINAL P
MOVE T1,FORSYM ;[C20] RESTORE SYMBOL TABLE
MOVEM T1,.JBSYM## ;[C20] ..
AOS FORRET ;[C20] SKIP RETURN
JRST @FORRET ;[C20] ..
END;
BEGIN
PROCEDURE (PUSHJ P,FORERR)
MOVE P,FORPDP ;[C20] RESTORE ORIGINAL P
MOVE T1,FORSYM ;[C20] RESTORE SYMBOL TABLE
MOVEM T1,.JBSYM## ;[C20] ..
SKIPLE ERRADR ;[C20] A USER RETURN ADDRESS?
JRST @ERRADR ;[C20] YES
JRST @FORRET ;[C20] NO
END;
BEGIN
PROCEDURE (PUSHJ P,FUNCT.)
JRST @FORFUN ;[C20] CALL THE REAL FUNCT.
END;
>;END IFE FTFORTRAN
SEGMENT IMPURE ;[C20]
FORRET: BLOCK 1 ;[C20] RETURN ADDRESS
FORPDP: BLOCK 1 ;[C20] AC P
FORARG: BLOCK 1 ;[C20] ARGUMENT ADDRESS
FORCNT: BLOCK 1 ;[C20] ARGUMENT COUNT
FORFUN: BLOCK 1 ;[C20] ADDRESS OF FUNCT.
FORSYM: BLOCK 1 ;[C20] FORTRAN SYMBOL TABLE POINTER
IFN FTOPS20,<
FORHI: BLOCK 1 ;[N27] START OF HI-SEG, OTS, OR SORT
>
SEGMENT HPURE ;[C20]
SUBTTL OUTER LOOP
SEGMENT LPURE ;[C20]
BEGIN
PROCEDURE (PUSHJ P,LOOP)
PUSHJ P,SSTATS ;[C20] SETUP STATS LOCS
PUSHJ P,SETSPC ;[C13] SETUP MEMORY LOCS
PUSHJ P,SCAN ;CALL SCAN
; OR FORTRAN SCAN WHICH DOESN'T RETURN
PUSHJ P,PSORT. ;INITIALIZE SORT
PUSHJ P,RELES. ;READ INPUT FILES
PUSHJ P,MERGE. ;MERGE TEMP FILES
PUSHJ P,RETRN. ;WRITE OUTPUT FILES
PUSHJ P,ENDS. ;CLEAN UP
IFN FTFORTRAN,<
SKIPG ATSFLG ;
RETURN
>
JSP P4,INITIALIZE ;DATA
JRST $B ;GET NEXT LINE
END;
;**;[475] @LOOP +16L INSERT 5L ERD 15-DEC-81
IFE FTOPS20,< ;[475]
IFE FTFORTRAN,< ;[475]
IFN FTVM,< ;[475]
.HELPR::$ERROR (?,UKS,<Unknown switch /HELP>);[475]HELPER not available
>>> ;[475]
SEGMENT HPURE ;[C20]
SUBTTL INITIALIZATION PROCEDURE
BLOCK 1 ;[427] LINK TO NEXT
ZCOR,,EZCOR ;[427] DATA TO ZERO
.LINK S.LNK,.-2 ;[427] TELL LINK TO LINK TOGETHER
BEGIN
PROCEDURE (JSP P4,INITIALIZE)
IFE FTOPS20,<
PORTAL .+1 ;INCASE EXECUTE ONLY
>
IFE FTFORTRAN,<
;**;[474] @INITIALIZE +5L REPLACE 1L ERD 14-DEC-81
IFN FTOPS20,< ;[474]
XMOVEI P,STACK-1 ;[C20] SET UP STACK
>
;**;[474] @INITIALIZE +8L REPLACE 1L ERD 14-DEC-81
IFE FTOPS20,< ;[474]
MOVE P,[IOWD PDLEN,STACK] ;[N21] SET UP STACK
;**;[474] @INITIALIZE +10L REPLACE 1L WITH 4L ERD 14-DEC-81
> ;[474]
SKIPE FORPDP ;[474] CALLED FROM FORTRAN?
PUSH P,['STOP!!'] ;[474] YES, LOAD END OF STACK INDICATOR
> ;[474]
JSP T4,ZDATA ;[134] ZERO COMMON DATA AREAS
JSP T4,CPUTST ;[134] MAKE SURE IF CPU OK
IFE FTFORTRAN!FTVM,<
BEGIN ;GET WHERE WE REALLY CAME FROM
HRROI T1,.GTRDV
GETTAB T1, ;GET DEVICE
JRST $E ;PRE 6.03
JUMPE T1,$E ;[343] 6.03A
MOVEM T1,RUNDEV ;SAVE ACTUAL DEVICE
HRROI T1,.GTRDI
GETTAB T1, ;GET DIRECTORY
JRST $E
MOVEM T1,RUNDIR ;SAVE ACTUAL PPN
HRROI T1,.GTRS0
GETTAB T1, ;GET SFD #1
JRST $E ;PRE 6.04
JUMPE T1,$E ;NO SFD
MOVEM T1,RUNSFD ;SAVE SFD
MOVEI T1,RUNPTH ;GET POINTER
EXCH T1,RUNDIR ;SWAP WITH PPN
MOVEM T1,RUNPPN ;SAVE PPN
HRROI T1,.GTRS1
GETTAB T1, ;NEXT SFD
JRST $E
MOVEM T1,RUNSFD+1
JUMPE T1,$E ;ALL DONE
HRROI T1,.GTRS2
GETTAB T1, ;NEXT SFD
JRST $E
MOVEM T1,RUNSFD+2
JUMPE T1,$E ;ALL DONE
HRROI T1,.GTRS3
GETTAB T1, ;NEXT SFD
JRST $E
MOVEM T1,RUNSFD+3
JUMPE T1,$E ;ALL DONE
HRROI T1,.GTRS4
GETTAB T1, ;NEXT SFD
JRST $E
MOVEM T1,RUNSFD+4
SETZM RUNSFD+5 ;TERMINATE WITH ZERO
END;
>;END IFE FTFORTRAN!FTVM
IFE FTOPS20,<
PUSHJ P,MONSPC ;[N12] SEE IF 7-SERIES MONITOR
>
IFN FTOPS20,<
SETO T1, ;GET JOB INFO FOR THIS JOB
HRROI T2,DFMTRS ;[407] SAVE DEFAULT MTA RECSIZE
MOVX T3,.JIRS ;GET DEFAULT MTA RECORD SIZE
GETJI% ;[335] ..
ERJMP [$ERROR (?,GJF,<GETJI% failure at initialization time>)]
SETO T1, ;[C03] GET JOB INFO FOR THIS JOB
HRROI T2,DFMTMD ;[C03] SAVE DEFAULT MTA MODE
MOVX T3,.JIDM ;[C03] ..
GETJI% ;[C03] ..
ERJMP E$$GJF ;[C03]
SETZM MOUNTR ;[C12] CLEAR MOUNTR AROUND FLAG
>
BEGIN ;SETUP INITIAL VALUES
SETOM P.BLKF ;BLOCKING FACTOR
SETOM P.VARF ;VARIABLE/FIXED RECORDS
SETOM P.INDU ;[143] /INDUSTRY
SETOM P.LABL ;[353] /LABEL
IFN FTOPS20,<
SETOM P.DENS ;[372] /DENSITY: (SCAN DOES THESE ON -10)
SETOM P.PARI ;[372] /PARITY:
SETOM P.REW ;[372] /REWIND
SETOM P.UNL ;[372] /UNLOAD
>
PUSHJ P,GETJOB ;[C20] GET JOB NUMBER
END;
RETURN
END;
SUBTTL SCAN CONTROL ROUTINES
IFE FTFORTRAN,<
BEGIN
PROCEDURE (PUSHJ P,CLRFIL)
SETOM TEMPSW ;RESET NOT SEEN FLAG
IFE FTOPS20,<
SKIPGE T1,P.BLKF ;ALREADY SEEN A DEFAULT?
SKIPL T1,F.BLKF ;NO, TRY TEMP BLOCKING FACTOR?
MOVEM T1,P.BLKF ;YES, USE THIS AS IT
SKIPG T1,P.LABL ;ALREADY SEEN LABEL?
SKIPL T1,F.LABL ;NO, TRY TEMP
MOVEM T1,P.LABL ;AS DEFAULT
SKIPGE T1,P.VARF ;[143] ALREADY SEEN DEFAULT?
SKIPL T1,F.VARI ;[143] NO--TRY FILE VAR/FIX
MOVEM T1,P.VARF ;[143] YES--USE THIS AS IT
SKIPGE T1,P.INDU ;ALREADY GOT A DEFAULT
SKIPL T1,F.INDU ;NO, DO WE NOW?
MOVEM T1,P.INDU ;YES
SKIPGE T1,P.STDA
SKIPL T1,F.STDA
MOVEM T1,P.STDA
>;END IFE FTOPS20
PJRST CLRLOC ;FALL INTO CLRLOC
END;
>;END IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CLRANS)
;SET ALL FULL WORD QUANTITIES TO NULL
; THAT IS -1 (FOR SCAN)
;CALLED FROM SCAN BEFORE EACH "*" ONLY
SETZM F.INZR
SETZM F.OUZR
SETZM F.TMZR
SETZM FSTKEY
SETZM LSTKEY
IFE FTOPS20,<
SETZM PRIORI
>
SETZM COLSW
SETOM CORSIZ
SETOM ALIGN
SETOM STATSW ;[C20]
SETOM RECORD
IFE FTOPS20,< ;[454] DON'T SET THIS AGAIN ON -20
SETOM MRGSW ;[454]
> ;[454]
SETOM WSCSW
SETOM NUMRCB
SETOM ERRADR ;[OK]
SETOM FERCOD ;[OK]
SETOM SUPFLG ;[351]
SETOM ADVFLG ;[N11]
SETOM NOCRLF ;[N11]
SETOM MAXTMP ;[N20]
IFE FTOPS20!FTFORTRAN,<
MOVE T1,[IOWD STCKSZ,CSTACK] ;[N06] MEMORY STACK MIGHT NOT BE IN INITIAL STATE
MOVEM T1,CORSTK ;[N06] BECAUSE OF A BUG IN SCAN IF COMMAND CONTAINED AN ERROR
>;END IFE FTOPS20!FTFORTRAN
; PJRST CLRLOC ;COMMON RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,CLRLOC)
SETOM F.BLKF
SETOM F.LABL
SETOM F.VARI
SETOM F.INDU
SETOM F.STDA
SETOM F.REW
SETOM F.POSI ;[C11]
SETOM F.UNL
IFN FTOPS20,<
SETOM F.DENS ;[372]
SETOM F.PARI ;[372]
>
RETURN
END;
IFE FTFORTRAN,<
BEGIN
PROCEDURE (PUSHJ P,MEMSTK)
;ROUTINE TO MEMORIZE STICKY DEFAULTS
;STORE RESULTS IN P.????
SKIPL T1,F.BLKF ;GET BLOCKING FACTOR
MOVEM T1,P.BLKF
SKIPL T1,F.LABL ;GET LABEL
MOVEM T1,P.LABL
SKIPL T1,F.VARI ;[143] GET FIX/VAR
MOVEM T1,P.VARF ;[143] STORE IF IT WAS SET
SKIPL T1,F.INDU
MOVEM T1,P.INDU
SKIPL T1,F.STDA
MOVEM T1,P.STDA
IFN FTOPS20,<
SKIPL T1,F.DENS ;[372] GET /DENSITY: VALUE AND SAVE IF IT
MOVEM T1,P.DENS ;[372] WAS SET (SCAN DOES THIS ON TOPS10)
SKIPL T1,F.PARI ;[372] GET /PARITY: VALUE AND SAVE IF IT
MOVEM T1,P.PARI ;[372] WAS SET
SKIPL T1,F.REW ;[372] GET /REWIND VALUE AND SAVE IF IT
MOVEM T1,P.REW ;[372] WAS SET
SKIPL T1,F.UNL ;[372] GET /UNLOAD VALUE AND SAVE IF IT
MOVEM T1,P.UNL ;[372] WAS SET
>
RETURN
END;
DEFINE APPLY (X,Y)<
MOVE T1,X ;DEFAULT
SKIPGE Y ;PARTICULAR SET
MOVEM T1,Y ;NO, APPLY DEFAULT
>
BEGIN
PROCEDURE (PUSHJ P,APPSTK)
APPLY P.BLKF,F.BLKF
APPLY P.LABL,F.LABL
APPLY P.VARF,F.VARI
APPLY P.INDU,F.INDU
APPLY P.STDA,F.STDA
IFN FTOPS20,<
APPLY P.DENS,F.DENS ;[372]
APPLY P.PARI,F.PARI ;[372]
APPLY P.REW,F.REW ;[372]
APPLY P.UNL,F.UNL ;[372]
>
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,CLRSTK) ;ROUTINE TO CLEAR STICKY DEFAULTS
;JUST A NO-OP FOR NOW
RETURN
END;
>;END IFE FTFORTRAN
SUBTTL SWITCH HANDLING -- /FORMAT:xn.m
BEGIN
PROCEDURE (PUSHJ P,USRFMT) ;STORE THE /FORMAT ARGUMENT
SKIPN T1,LSTKEY ;GET POINTER TO KEY BLOCK
JRST E$$FSM ;/KEY BEFORE /FORMAT
SKIPE KY.FMT(T1) ;[OK] ONLY ONE /FORMAT PER /KEY
JRST E$$OOF ;COMPLAIN
MOVX T4,RM.FPA ;[C13] [203] MODE IS FLOATING POINT ASCII
IORM T4,MODE ;[C13] ..
IORM T4,MODEM ;[C13] ..
MOVE T0,[POINT 6,.NMUL] ;POINT AT FORMAT TYPE
ILDB T4,T0 ;[C13] GET A CHAR
;**;[511] @USRFMT + 13 lines, Insert 11 lines. DMN 27-Oct-82
;**;[514] @USRFMT + 14 lines, Replace 1 line. GCS 21-Jan-83
SETZB T3,KY.FMT+2(T1) ;[514] CLEAR FORMAT FLAGS.
CAIN T4,'B' ;[511] IS IT BLANK=?
JRST [ILDB T4,T0 ;[511] YES, SEE WHICH ONE.
CAIN T4,'N' ;[511] BLANK=NULL?
MOVX T3,KY%FBN ;[511] YES.
CAIN T4,'Z' ;[511] BLANK=ZERO?
MOVX T3,KY%FBZ ;[511] YES.
JUMPE T3,E$$FSA ;[511] NEITHER IS AN ERROR.
IORM T3,KY.FMT+2(T1) ;[511] STORE FLAGS.
ILDB T4,T0 ;[511] GET NEXT CHAR.
JRST .+1] ;[511] CONTINUE FORMAT SCAN.
PUSHJ P,$5 ;[C13] LOOK FOR A SCALING FACTOR
JRST $1 ;[C13] NOT FOUND, SKIP IT
CAIE T4,'P' ;[C13] FOUND IT, A P?
JRST E$$FSA ;[C13] NO, COMPLAIN
HRRM T3,KY.FMT+2(T1) ;[OK] [C13] SAVE SCALING FACTOR
ILDB T4,T0 ;[C13] YES, GET A CHAR
$1% CAIL T4,'D' ;[C13] MUST BE A D, E, F, OR G
CAILE T4,'G' ;[C13] ..
JRST E$$FSA ;[C13] NO, COMPLAIN
MOVE T2,T4 ;[C13] SAVE IT
ILDB T4,T0 ;[C13] GET A CHAR
PUSHJ P,$5 ;[C13] GET FIELD WIDTH
JRST [SETOM KY.FMT(T1) ;[OK] [C13] CAN'T, FREE FORMAT
JRST $2] ;[C13] SKIP DECIMAL PLACES
SKIPLE T3 ;[C13] WIDTH .LE. 0?
CAMLE T3,KY.SIZ(T1) ;[OK] [C13] OR WIDTH .GT. KEY SIZE?
JRST E$$FSA ;[C13] ERROR
MOVEM T3,KY.FMT(T1) ;[OK] [C13] SAVE FIELD WIDTH
CAIE T4,'.' ;[C13] DECIMAL PLACES SPECIFIED?
JRST $2 ;[C13] NO, ASSUME ZERO
ILDB T4,T0 ;[C13] YES, GET CHAR
PUSHJ P,$5 ;[C13] GET DECIMAL PLACES
JRST E$$FSA ;[C13] CAN'T, COMPLAIN
SKIPL T3 ;[C13] DECIMAL PLACES .LT. 0?
CAMLE T3,KY.FMT(T1) ;[OK] [C13] OR DECIMAL PLACES .GT. WIDTH?
JRST E$$FSA ;[C13] ERROR
MOVEM T3,KY.FMT+1(T1) ;[OK] [C13] SAVE DECIMAL PLACES
$2% JUMPN T4,E$$FSA ;[C13] MUST TERMINATE WITH A NULL
CAIN T2,'D' ;[C13] D TYPE?
JRST $3 ;[C13] YES, MUST BE DOUBLE PRECISION
CAIE T2,'G' ;[C13] G TYPE
JRST $4 ;[C13] NO, CAN'T BE DOUBLE PRECISION
SKIPG T2,KY.FMT(T1) ;[OK] [C13] YES, GET WIDTH
MOVE T2,KY.SIZ(T1) ;[OK] [C13] ONE WAY OR ANOTHER
CAIG T2,^D10 ;[C13] WIDTH .GT. 10?
JRST $4 ;[C13] NO, CAN'T BE DOUBLE PRECISION
$3% MOVX T2,1B0 ;[C13] DOUBLE PRECISION, REMEMBER THIS
IORM T2,KY.FMT+2(T1) ;[OK] [C13] ..
$4% RETURN ;[C13] DONE
; GET A POSITIVE NON-ZERO NUMBER SUBROUTINE
$5% SETZ T3, ;[C13] START WITH A ZERO
PUSH P,T3 ;[C13] PUT A ZERO ON THE STACK
CAIN T4,'+' ;[C13] PREFIXED BY A '+'?
JRST [ILDB T4,T0 ;[C13] YES, GET A CHAR
JRST $6] ;[C13] RESUME AT LOOP
CAIN T4,'-' ;[C13] PREFIXED BY A '-'?
JRST [SETOM (P) ;[C13] YES, REMEMBER IT
ILDB T4,T0 ;[C13] GET A CHAR
JRST $6] ;[C13] RESUME AT LOOP
CAIL T4,'0' ;[C13] NO SIGN, A DIGIT?
CAILE T4,'9' ;[C13] ..
JRST [POP P,(P) ;[C13] NO, RESTORE STACK
POPJ P,] ;[C13] ERROR RETURN
$6% CAIL T4,'0' ;[C13] DONE?
CAILE T4,'9' ;[C13] ..
JRST $7 ;[C13] YES
IMULI T3,^D10 ;[C13] ADD DIGIT TO NUMBER
SUBI T4,'0' ;[C20] ..
ADD T3,T4 ;[C20] [C13] ..
ILDB T4,T0 ;[C13] GET NEXT CHAR
JRST $6 ;[C13] LOOP AROUND
$7% SKIPE (P) ;[C13] NEGATIVE NUMBER?
MOVNS T3 ;[C13] YES
POP P,(P) ;[C13] RESTORE STACK
AOS (P) ;[C13] SKIP RETURN
POPJ P, ;[C13] ..
END;
SUBTTL COLLATING SEQUENCE TABLE ROUTINES
BEGIN
PROCEDURE (PUSHJ P,CHKCOL)
HRRZ T1,COLSW ;GET INDEX
CASE COLLATING SEQUENCE OF (ASCII,EBCDIC,FILESPEC,LITERAL,ADDRESS)
JRST @[IFIWS <$1,$2,COLTRX,COLTRL,COLTRA>]-1(T1) ;[C20] DISPATCH ON KEY WORD
$1% ;ASCII
CASE I/O MODE OF (ASCII,SIXBIT,EBCDIC,BINARY)
HRRZ T1,MODE
MOVE T1,[EXP 0,0,<IFIW ALP.97>,0]-1(T1) ;[C20]
ESAC;
JRST $C
$2% ;EBCDIC
CASE I/O MODE OF (ASCII,SIXBIT,EBCDIC,BINARY)
HRRZ T1,MODE
MOVE T1,[EXP <IFIW ALP.69>,<IFIW ALP.79>,0,0]-1(T1) ;[C20]
ESAC;
; JRST $C
ESAC;
MOVEM T1,COLSW ;STORE POINTER
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,BLDCOL)
;CALL MOVE T1,LOCATION OF THE NEW TABLE
; MOVEI T2,GET THE NEXT CHARACTER ROUTINE
; PUSHJ P,BLDCOL
;RETURN CPOPJ ;ILLEGAL ARGUMENTS (TABLE INVALID)
; CPOPJ1 ;TABLE IS BUILT
; AC USAGE P1=XWD LOCAL FLAGS,CURRENT COLLATING INDEX
COL.MI==1B1 ;PENDING MINUS SIGN
COL.EQ==1B2 ;PENDING EQUAL SIGN
COL.QU==1B3 ;[467] PENDING QUOTE
; P2=LAST CHARACTER VALUE SEEN
; P3=ADDRESS OR ROUTINE TO GET THE NEXT CHARACTER
; P4=LOCATION OF THE COLLATING BLOCK
PUSHJ P,.SAVE4 ;SAVE THE P'S
HRRZ P4,T1 ;[C20] COPY THE TABLE ADDRESS
MOVE P3,T2 ;[C20] COPY NEXT CHARACTER ROUTINE
MOVE T1,[XWD 707070,707070]
MOVEM T1,(P4) ;[OK] INITIALIZE THE TABLE
HRLZI T1,0(P4) ;[OK] MAKE A BLT POINTER
HRRI T1,1(P4) ;[OK]
BLT T1,177(P4) ;[OK] SET THE TABLE TO 707070,707070
SETZ P1, ;START AT COL. INDEX =0
$1% TXZ P1,COL.QU ;[467] CLEAR PENDING QUOTE
TXZE P1,COL.MI ;[365] PENDING MINUS SIGN
JRST $6 ;YES,
TXZE P1,COL.EQ ;[365] PENDING EQUAL SIGN
JRST $3 ;YES
PUSHJ P,(P3) ;[OK] GET THE NEXT ALT SEQ CHARACTER
JRST BLDCOE ;END OF INPUT GO FILL THE TABLE
CAIN T1,"-" ;IS IT A RANGE OF VALUES
JRST $6 ;YES
CAIN T1,"=" ;CHECK FOR AN EQUAL
JRST $3 ;YES
CAIE T1,"'" ;[N25] IS IT A SINGLE QUOTE?
CAIN T1,"""" ;IS IT A QUOTE
JRST [MOVEM T1,QOTCHR ;[N25] YES, SAVE WHICH ONE
JRST $2] ;[N25] AND PROCESS A QUOTED STRING
CAIE T1,"," ;SEPARATOR
CAIN T1," " ;TOP LEVEL BLANK
JRST $1 ;YES SKIP IT
CAIL T1,"0" ;CHECK FOR A DIGIT
CAILE T1,"7" ;IN THE OCTAL RANGE
POPJ P, ;NO, ERROR NOTHING LEFT TO LOOK AT
PUSHJ P,BLDIGT ;GET THE DIGITS
POPJ P, ;ILLEGAL DIGITS
PUSHJ P,BLDCOS ;STORE THE VALUE
;**;[500] In BLDCOL at $2% - 2L Replace 2 lines with 3. GCS 13-APR-82
TXNN P1,COL.QU ;[500] DID WE SEE A QUOTE?
AOJA P1,$1 ;[500] NO, UPDATE INDEX AND TRY AGAIN
AOJA P1,$2 ;[500] YES, GET THE NEXT CHARACTER
$2% TXO P1,COL.QU ;[467] SET QUOTE FLAG.
PUSHJ P,(P3) ;[OK] GET THE NEXT CHARACTER
POPJ P, ;END OF DATA WITH NO ENDING QUOTE
CAMN T1,QOTCHR ;[N25] IS IT A MATCHING ENDING QUOTE?
JRST $1 ;YES, GET THE NEXT CHARACTER
PUSHJ P,BLDCOS ;STORE THE INDEX VALUE FOR THE CHARACTER
AOJA P1,$2 ;INCREMENT THE INDEX GET NEXT CHARACTER
$3% SOJL P1,CPOPJ ;BAKUP THE INDEX TO THE PREVIOUS VALUE
;(ERROR IF NO PREVIOUS VALUE)
PUSHJ P,(P3) ;[OK] GET THE NEXT CHARACTER
POPJ P, ;ILLEGAL SEQUENCE
CAIE T1,"""" ;[N25] A STRING
CAIN T1,"'" ;[N25] ...
TRNA ;[N25] YES
JRST $5 ;NO
MOVEM T1,QOTCHR ;[N25] SAVE WHICH ONE IT IS
$4% PUSHJ P,(P3) ;[OK] GET THE NEXT CHARACTER OF THE STRING
POPJ P, ;ILLEGAL SEQUENCE
CAMN T1,QOTCHR ;[N25] END OF STRING
AOJA P1,$1 ;YES, RESTORE THE INDEX GET NEXT CHARACTER
PUSHJ P,BLDCOS ;STORE THE CHARACTER
JRST $4 ;NO, GET THE NEXT STRING CHARACTER
$5% PUSHJ P,BLDIGT ;GET THE DIGITS
POPJ P, ;ILLEGAL DIGITS
PUSHJ P,BLDCOS ;STORE THE INDEX
AOJA P1,$1 ;RETURN FOR NEXT CHARACTER
$6% PUSHJ P,(P3) ;[OK] GET THE SECOND VALUE
POPJ P, ;ILLEGAL STRING
CAIE T1,"""" ;[N25] QUOTED STRING?
CAIN T1,"'" ;[N25] ...
TRNA ;[N25] YES
JRST $7 ;NOPE
MOVEM T1,QOTCHR ;[N25] SAVE WHICH ONE IT IS
PUSHJ P,(P3) ;[OK] YES, GET THE CHARACTER
POPJ P, ;ILLEGAL STRING
PUSH P,T1 ;SAVE THE CHARACTER
PUSHJ P,(P3) ;[OK] GET THE NEXT CHARACTER
CAIA ;SKIP ON ERROR
CAME T1,QOTCHR ;[N25] MUST END WITH QUOTE
JRST [POP P,(P) ;ILLEGAL STRING REMOVE THE SAVED CHARACTER
POPJ P,] ;RETURN
POP P,T1 ;RESTORE THE CHARACTER
JRST $8 ;CONTINUE
$7% PUSHJ P,BLDIGT ;CHECK FOR A DIGIT
POPJ P, ;ILLEGAL DIGIT
$8% MOVE T4,T1 ;[C20] SAVE THE ENDING CHARACTER
$9% AOS T1,P2 ;INCREMENT LAST CHARACTER STORED
CAMLE T1,T4 ;CHECK THE RANGE
;**;[500] In BLDCOL at $9% + 2L Replace 1 line with 3. GCS 13-APR-82
JRST [TXNN P1,COL.QU ;[500] END OF RANGE, SEE A QUOTE?
JRST $1 ;[500] NO
JRST $2] ;[500] YES, PROCESS THE STRING
PUSHJ P,BLDCOS ;STORE IN THE TABLE
AOJA P1,$9 ;[365] INCREMENT THE INDEX AND CONTINUE UNTIL EQUAL
END;
;SUBROUTINE BLDCOS - STORE THE CURRENT CHARACTER IN THE TABLE
;CALL PUSHJ P,BLDCOS
;RETURN CPOPJ
BEGIN
PROCEDURE (PUSHJ P,BLDCOS)
MOVE P2,T1 ;[C20] SAVE THE CHARACTER
HRRZ T3,IOMODE ;[460] GET EXTERNAL I/O MODE
CASE I/O MODE OF (SIXBIT, ASCII, EBCDIC, BINARY)
JRST @[IFIWS <$2,$1,$3,$3>]-1(T3) ;[460] DISPATCH
$3% $ERROR (?,CNS,<EBCDIC or BINARY collating sequence is not supported.>)
$2% CAIL T3,40 ;[460] MAKE SURE ITS IN SIXBIT RANGE
CAILE T1,137 ;[460] ...
JRST E$$ICS ;[460] ITS NOT
SUBI T1,40 ;[460] CONVERT TO SIXBIT
$1% IDIVI T1,2 ;[460] GET THE TABLE INDEX AND WHICH HALF
ADD T1,P4 ;[C20] TABLE OFFSET
;**;[500] In BLDCOS at $1% + 2L Replace 2 lines with 10. GCS 13-APR-82
JUMPN T2,$4 ;[500] JUMP IF RIGHT HALF OF TABLE
HLRZ T2,(T1) ;[500] A DUPLICATE?
CAIE T2,707070 ;[500] ...
PUSHJ P,ERRDCC ;[500] YES, WARN USER
HRLM P1,(T1) ;[500] STORE IN THE LEFT HALF (EVEN)
RETURN ;[500]
$4% HRRZ T2,(T1) ;[500] A DUPLICATE?
CAIE T2,707070 ;[500] ...
PUSHJ P,ERRDCC ;[500] YES, WARN USER
HRRM P1,(T1) ;[500] STORE IN THE RIGHT HALF (ODD)
RETURN
ESAC;
END;
;SUBROUTINE BLDCOE - WILL FILL IN THE MISSING ELEMENTS OF THE TABLE
;CALL PJRST BLDCOE WHEN END OF THE COLLATING STRING
;RETURN CPOPJ1
BEGIN
PROCEDURE (PUSHJ P,BLDCOE)
MOVEI T4,200 ;[C20] SIZE OF THE TABLE
$1% HLRZ T1,(P4) ;[OK] GET THE LEFT HALF ENTRY
CAIE T1,707070 ;CHECK FOR A NULL ENTRY
JRST $2 ;NO, IT WAS USED
HRLM P1,(P4) ;[OK] STORE THE CURRECT INDEX
ADDI P1,1 ;[365] INCREMENT THE INDEX
$2% HRRZ T1,(P4) ;[OK] GET THE RIGHT HALF
CAIE T1,707070 ;IS IT EMPTY
JRST $3 ;NO
HRRM P1,(P4) ;[OK] YES, SET THE INDEX
ADDI P1,1 ;[365] STEP THE INDEX
$3% AOS P4 ;[C20] CONTINUE THRU THE TABLE
SOJG T4,$1 ;[C20] ..
JRST CPOPJ1 ;[365] SKIP RETURN
END;
BEGIN
;SUBROUTINE BLDIGT - CONVERT A STRING OF DIGITS
;CALL MOVEI T1,FIRST DIGIT
; PUSHJ P,BLDIGT
;RETURN CPOPJ ;NOT DIGITS
; CPOPJ1 ;T1=BINARY DIGITS
PROCEDURE (PUSHJ P,BLDIGT)
SETZ T2, ;CLEAR THE OUTPUT WORD
JRST $1 ;CONTINUE BELOW
$5% PUSHJ P,(P3) ;[OK] GET THE CHARACTER
JRST $2 ;END OF INPUT
$1% CAIN T1,"=" ;CHECK FOR SEPARATORS
JRST $3 ;YES
CAIN T1,"-"
JRST $4 ;YES
CAIE T1," " ;OR BLANKS (FORTRAN LITERALS)
CAIN T1,"," ;MUST END WITH A COMMA
JRST $2 ;YES, END OF STRING
;**;[500] In BLDIGT at $1% + 7L Insert 3 lines. GCS 13-APR-82
CAIE T1,"'" ;[500] IS IT A SINGLE QUOTE?
CAIN T1,"""" ;[500] OR A DOUBLE QUOTE?
JRST $6 ;[500] YES, END OF DIGITS
CAIL T1,"0" ;DID A DIGIT ARRIVE
CAILE T1,"7"
POPJ P, ;ERROR ILLEGAL SEPARATOR
LSH T2,3 ;YES, MAKE ROOM FOR THE DIGITS
SUBI T1,"0" ;[C20] ACCUMULATE THE SUM
ADD T2,T1 ;[C20] ..
JRST $5 ;GET THE NEXT DIGITS
;**;[500] In BLDIGT at $3% Insert 3 lines. GCS 13-APR-82
$6% TXO P1,COL.QU ;[500] SET QUOTE FLAG
MOVEM T1,QOTCHR ;[500] SAVE THE QUOTE CHAR
JRST $2 ;[500] RETURN THE DIGIT
$3% TXOA P1,COL.EQ ;[365]
$4% TXO P1,COL.MI ;[365]
$2% MOVE T1,T2 ;COPY THE RESULT
JRST CPOPJ1 ;[365] SKIP RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,COLTRL)
MOVE T1,[POINT 7,COLITB] ;FORM BYTE POINTER
MOVEM T1,COLPTR+2
MOVE T1,[IFIW COLBUF] ;[C20]
MOVEM T1,COLSW ;POINT TO TABLE
MOVEI T2,COLLCH ;INPUT ROUTINE
PUSHJ P,BLDCOL ;BUILD THE TABLE
JRST E$$ICS
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,COLTRA)
MOVSI T1,(POINT 7,(T1)) ;[C20] GET BYTE POINTER
MOVEM T1,COLPTR+2
MOVE T1,[IFIW COLBUF] ;[C20]
MOVEM T1,COLSW ;POINT TO TABLE
MOVEI T2,COLLCH ;INPUT ROUTINE
PUSHJ P,BLDCOL ;BUILD THE TABLE
JRST E$$ICS
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,COLLCH)
MOVE T1,COLADR ;[C20] IN CASE ITS NEEDED FOR BYTE PTR
ILDB T1,COLPTR+2 ;GET A CHAR
JUMPE T1,CPOPJ ;STOP ON NULL
CAIGE T1," " ;IGNORE CONTROL CHAR
JRST $B
JRST CPOPJ1 ;[365]
END;
SUBTTL PSORT. -- SORT Initialization Following Command Scanning
BEGIN
PROCEDURE (PUSHJ P,PSORT.)
IFE FTOPS20,<
SKIPN T1,LSTKEY ;GET LAST KEY SEEN
JRST E$$OKR ;AT LEAST ONE KEY REQUIRED
MOVE T2,MODE ;GET MODE OF LAST KEY
MOVEM T2,KY.MOD(T1) ;[OK] STORE IT
MOVE T2,MODEM ;GET MASK OF ALL MODE BITS
ANDX T2,RM.ASC!RM.SIX!RM.EBC!RM.BIN!RM.FOR!RM.FPA
MOVEM T2,MODE ;CLEAR TEMP BITS AND RHS
PUSHJ P,SETMOD ;SETUP SORT MODE
>
SKIPE COLSW ;COLLATING SWITCH SEEN?
PUSHJ P,CHKCOL ;YES, SEE WHAT IT WAS
IFE FTFORTRAN,<
MOVEI T1,1 ;[C20] SET DEFAULT /STATISTICS:YES
SKIPE FORRET ;[C20] IF CALLED FROM FORTRAN
MOVEI T1,0 ;[C20] SET DEFAULT /STATISTICS:NO
SKIPGE STATSW ;[C20] IF NECESSARY
MOVEM T1,STATSW ;[C20] ..
SKIPLE T1,NUMRCB ;[N11] DID USER SUPPLY /LEAVES:?
MOVEM T1,LEAVES ;[N11] YES
>
IFN FTOPS20,<
MOVEI T1,MX.TMP ;[N20] ASSUME 26 TEMP FILES
SKIPG MAXTMP ;[N20] UNLESS USER SAID OTHERWISE
>
IFE FTOPS20,<
PUSHJ P,SETCHN ;[N20] [C19] SETUP CHANNEL ALLOCATOR
MOVE T1,CHNFRE ;[N20] [C19] GET CHANNELS AVAILABLE
SUBI T1,1 ;[N20] [C19] LESS INPUT/OUTPUT FILE
>
MOVEM T1,MAXTMP ;[N20] STORE MAX. NO. OF TEMP FILES ALLOWED
MOVN T1,MAXTMP ;[N20] [C19] MAKE AN AOBJ POINTER
HRLZM T1,TCBIDX ;[N20] [C19] PUT IT AWAY FOR LATER
SKIPLE T1,RECORD ;NUMBER OF BYTES IN RECORD
JRST $2 ;SPECIFIED
SKIPG T1,RECOUT ;SEE IF ON OUTPUT SIDE
JRST E$$RSR ;ERROR
MOVEM T1,RECORD ;STORE IT
$2% IDIV T1,BPWORD ;GET NO. OF WORDS
SKIPE T2 ;RESIDUE ?
ADDI T1,1 ;YES, INCREMENT NUMBER OF WORDS
MOVEM T1,RECSIZ ;SET RECORD SIZE
MOVEM T1,REKSIZ ;INITIAL IN-MEMORY RECORD SIZE
SKIPLE NOCRLF ;[N11] IF /NOCRLF SPECIFIED
SETZM P.VARF ;[N11] DEFAULT TO /FIXED
IF I/O MODE IS SIXBIT OR VARIABLE EBCDIC
HRRZ T1,IOMODE ;[201] FETCH EXTERNAL I/O MODE INDEX
CAXN T1,MODSIXBIT ;[201] SIXBIT?
JRST $1 ;[201] YES--GO INCLUDE COUNT WORD IN RECSIZ
CAXN T1,MODEBCDIC ;[201] EBCDIC?
SKIPG P.VARF ;[201] SO FAR SO GOOD. VARIABLE TOO?
JRST $F ;[201] NO--NO COUNT WORD THEN
$1%
THEN EXTERNAL RECORD INCLUDES A COUNT WORD TOO
AOS RECSIZ ;[201] REALLY 4 BYTES (= 1 WORD) FOR EBCDIC
FI;
PUSHJ P,SETTMP ;[214] GET ALL TEMP FILES USER SPECIFIED
IFE FTOPS20,<
PUSHJ P,PRUNE ;[214] PRUNE NULL FILES FROM LISTS
>
PUSHJ P,SETUPO ;SETUP OUTPUT FILES
PUSHJ P,SETUPI ;SETUP INPUT FILES
MOVX T1,FTEXSZ ;[C13] GET SIZE OF KEY EXTRACT CODE AREA
MOVEM T1,EXTSZ ;[C13] REMEMBER IT
PUSHJ P,GETSPC ;[C13] GO ALLOCATE IT
JRST E$$NEC ;[C13] FAILED
XMOVEI T1,(T1) ;[C20] MAKE SURE IT HAS THE SECTION
MOVEM T1,EXTORG ;[C13] WHERE EXTRACT KEY CODE WILL GO
PUSHJ P,KEYEXT ;GENERATE CODE TO EXTRACT KEYS
PUSHJ P,KEYGEN ;GENERATE CODE FOR KEY COMPARES
MOVEI T1,1 ;ACCOUNT FOR HEADER WORD
ADD T1,XTRWRD ;PLUS EXTRACTED KEYS
ADDM T1,REKSIZ ;NEW RECORD SIZE IN MEMORY
MOVE T1,MAXKEY ;GET NO. OF BYTES WE REALLY NEED
IDIV T1,BPWORD ;IN WORDS
SKIPE T2
ADDI T1,1 ;COUNT REMAINDER
MOVEM T1,MAXKEY ;STORE BACK FOR GTTREC
MOVN T1,XTRBYT ;[461] IF WE HAVE ALLOCATED SPACE FOR EXTRACTED KEYS
ADDM T1,MINKEY ;[461] REMOVE FROM SIZE OF ORIGINAL RECORD
MOVEI T1,MSTEOF ;END OF FILE INTERCEPT ADDRESS
MOVEM T1,LOGEOF ;LOGICAL EOF
MOVEM T1,PHYEOF ;PHYSICAL EOF
IF /MERGE
SKIPLE MRGSW
THEN INITIALIZE UP TO MX.TMP OF THE INPUT FILES
PUSHJ P,SETMRG ;SETUP DIFFERENTLY
FI;
XMOVEI T1,PSORT% ;[C20] [C13] CHECK AND SET MEMORY SIZE, GOTO LOWSEG
PUSH P,T1 ;[C20] ..
PJRST CHKCOR ;[C13] DO IT THIS WAY IN CASE WE'RE GONE
END;
SUBTTL PSORT. -- SETMOD - Set Up Recording Mode for SORT
BEGIN
PROCEDURE (PUSHJ P,SETMOD)
HLLZ T1,MODEM ;[C20] GET MASK OF ALL MODE BITS
SETZ U, ;[C20] CLEAR INDEX
IF RECORDING MODE IS BINARY AND NOT FORTRAN
TXNN T1,RM.FOR ;[C20] FORTRAN BINARY IS OK
TXNN T1,RM.BIN ;[C20] BINARY IS SPECIAL
JRST $F
THEN CHECK /FIX /VARIABLE SETTINGS
SKIPLE P.VARF ;CANNOT HAVE /VARIABLE WITH BINARY
JRST E$$BNV
SETZM P.VARF ;FORCE FIXED LENGTH
FI;
LDB T2,[POINT 3,T1,^L<RM.EBC>] ;[C20] GET ASCII/SIXBIT/EBCDIC SWITCH
JRST @.+1(T2) ;[C20] DISPATCH
IFIW SETMU ;[C20] UNDEFINED
IFIW SETME ;[C20] EBCDIC
IFIW SETMS ;[C20] SIXBIT
IFIW E$$MSC ;[C20] ERROR
IFIW SETMA ;[C20] ASCII
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
SETMU: TXNE T1,RM.BIN ;[C20] BINARY ONLY?
JRST SETMB ;YES
TXNN T1,RM.COM!RM.PAC ;[C20] COMPUTATIONAL?
JRST SETMA ;NO, SO USE ASCII BY DEFAULT
TXNE T1,RM.PAC ;[C20] COMP-3?
JRST SETME ;YES, EBCDIC BY DEFAULT
SETMS: TXNE T1,RM.PAC ;[C20] /SIX /PAC
JRST E$$MSC ;ERROR
MOVEI U,MODSIXBIT ;[C20] SIXBIT
TXNN T1,RM.BIN ;[C20] [203] UNLESS FILE IS ALREADY BINARY,
MOVEM U,P.VARF ;[C20] [105] FORCE SIXBIT TO BE VARIABLE
JRST RETMOD
SETMA: TXNE T1,RM.PAC ;[C20] /ASC /PAC ?
JRST E$$MSC ;ERROR
MOVX T2,RM.ASC ;[C20] TURN ON ASCII BIT INCASE BY DEFAULT
IORM T2,MODE ;[C20] AND STORE BACK IN MODE
MOVEI U,MODASCII ;[C20] ASCII
SKIPGE P.VARF ;DID USER SPECIFY FIXED LENGTH
MOVEM U,P.VARF ;[C20] [105] NO, ASSUME VARIABLE SIZE
TXNE T1,RM.FOR ;[C20] FORTRAN ASCII?
MOVEM U,ALIGN ;[C20] [105] YES, FORCE WORD ALIGNMENT
JRST RETMOD
SETME: MOVEI U,MODEBCDIC ;[C20]
IFN FTOPS20,<
SKIPGE P.VARF ;[372] DEFAULT TO /FIXED ON TOPS-20
SETZM P.VARF ;[372] ..
>
JRST RETMOD
SETMB: SKIPGE P.VARF ;DID USER SPECIFY FIXED LENGTH
MOVEM U,P.VARF ;[C20] [105] NO, ASSUME VARIABLE SIZE
MOVEI U,MODBINARY ;[C20]
; JRST RETMOD
RETMOD: HRRM U,MODE ;STORE MODE BACK
MOVE T2,[EXP 6,5,4,1]-1(U)
MOVEM T2,BPWORD ;NO. OF BYTES PER WORD
IF RECORDING MODE IS BINARY
TXNE T1,RM.BIN ;[C20] [201] LEAVE MODE ALONE UNLESS /BINARY
THEN I/O MODE IS BINARY
MOVEI U,MODBINARY ;[C20] [201] /BINARY FORCES BINARY I/O
FI;
HRRM U,IOMODE ;[201] SAVE SO I/O ROUTINES WILL KNOW
MOVE T2,[EXP 6,5,4,1]-1(U) ;[300] NUMBER OF I/O BYTES PER WORD
MOVEM T2,IOBPW ;[201] SAVE FOR I/O ROUTINES
MOVE T2,[EXP 1,5,4,1]-1(U) ;[C03] NUMBER OF I/O BYTES PER WORD USED
MOVEM T2,IOBPW2 ;[C03] SAVE FOR I/O ROUTINES
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,JMODES)
;ENTER WITH
;T1 = MODES + INDEX
;RETURN WITH
;J = TYPE INDEX
HRRZ T2,T1 ;[C20] DISPATCH
JRST @.(T2) ;[C20] ..
IFIW SETKS ;[C20] SIXBIT
IFIW SETKA ;[C20] ASCII
IFIW SETKE ;[C20] EBCDIC
IFIW SETKB ;[C20] BINARY
SETKS: LDB T2,[POINT 3,T1,^L<RM.NUM>] ;[C20] GET NEXT BITS
JRST @.+1(T2) ;[C20] DISPATCH
IFIW SETMSU ;[C20] UNDEFINED
IFIW SETMSN ;[C20] NUMERIC
IFIW SETMSC ;[C20] COMPUTATIONAL
IFIW E$$MSC ;[C20] ERROR
IFIW SETMSA ;[C20] ALPHANUMERIC
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
SETMSU: TXNN T1,RM.SGN!RM.UNS ;[C20] SIGN SPECIFIED?
JRST SETMSA ;NO, ALPHANUMERIC BY DEFAULT
SETMSN: TXNN T1,RM.UNS ;[C20] SPECIFICALLY UNSIGNED?
SKIPA J,[IX.NSS] ;[C20] NO, NUMERIC SIGNED SIXBIT
MOVEI J,IX.NUS ;[C20] YES, NUMERIC UNSIGNED SIXBIT
RETURN
SETMSC: TXNN T1,RM.UNS ;[C20] SPECIFICALLY UNSIGNED?
SKIPA J,[IX.CSS] ;[C20] NO, COMPUTATIONAL SIGNED SIXBIT
MOVEI J,IX.CUS ;[C20] YES, COMPUTATIONAL UNSIGNED SIXBIT
RETURN
SETKA: LDB T2,[POINT 3,T1,^L<RM.NUM>] ;[C20] GET NEXT BITS
JRST @.+1(T2) ;[C20] DISPATCH
IFIW SETMAU ;[C20] UNDEFINED
IFIW SETMAN ;[C20] NUMERIC
IFIW SETMAC ;[C20] COMPUTATIONAL
IFIW E$$MSC ;[C20] ERROR
IFIW SETMAA ;[C20] ALPHANUMERIC
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
SETMAU: TXNE T1,RM.FPA ;[C20] FORTRAN FLOATING POINT ASCII?
JRST SETMAF ;YES
TXNN T1,RM.SGN!RM.UNS ;[C20] SIGNED?
JRST SETMAA ;NO, ALPHANUMERIC BY DEFAULT
SETMAN: TXNN T1,RM.UNS ;[C20] SPECIFICALLY SIGNED?
SKIPA J,[IX.NSA] ;[C20] NO, NUMERIC SIGNED ASCII
MOVEI J,IX.NUA ;[C20] YES, NUMERIC UNSIGNED ASCII
RETURN
SETMAC: TXNN T1,RM.UNS ;[C20] SPECIFICALLY SIGNED?
SKIPA J,[IX.CSA] ;[C20] NO, COMPUTATIONAL SIGNED ASCII
MOVEI J,IX.CUA ;[C20] YES, COMPUTATIONAL UNSIGNED ASCII
RETURN
SETKE: LDB T2,[POINT 4,T1,^L<RM.PAC>] ;[C20] GET NEXT BITS
JRST @.+1(T2) ;[C20] DISPATCH
IFIW SETMEU ;[C20] UNDEFINED
IFIW SETMEP ;[C20] COMP-3 PACKED
IFIW SETMEN ;[C20] NUMERIC
IFIW SETMEP ;[C20] NUMERIC & COMP-3
IFIW SETMEC ;[C20] COMPUTATIONAL
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW SETMEA ;[C20] [450] ALPHANUMERIC
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
IFIW E$$MSC ;[C20] ERROR
SETMEU: TXNN T1,RM.SGN!RM.UNS ;[C20] SIGNED?
JRST SETMEA ;NO, ALPHANUMERIC BY DEFAULT
SETMEN: TXNN T1,RM.UNS ;[C20] SPECIFICALLY UNSIGNED?
SKIPA J,[IX.NSE] ;[C20] NO, NUMERIC SIGNED EBCDIC
MOVEI J,IX.NUE ;[C20] YES, NUMERIC UNSIGNED EBCDIC
RETURN
SETMEC: TXNN T1,RM.UNS ;[C20] SPECIFICALLY UNSIGNED?
SKIPA J,[IX.CSE] ;[C20] NO, COMPUTATIONAL SIGNED EBCDIC
MOVEI J,IX.CUE ;[C20] YES, COMPUTATIONAL UNSIGNED EBCDIC
RETURN
SETMEA: MOVEI J,IX.ALE ;[C20] ALPHANUMERIC
RETURN
SETMEP: TXNN T1,RM.UNS ;[C20] SPECIFICALLY UNSIGNED?
SKIPA J,[IX.C3S] ;[C20] NO, COMP-3 SIGNED
MOVEI J,IX.C3U ;[C20] YES, COMP-3 UNSIGNED
RETURN
SETMAA: SKIPA J,[IX.ALA] ;[C20] ALPHANUMERIC LOGICAL ASCII
SETMSA: MOVEI J,IX.ALS ;[C20] ALPHANUMERIC LOGICAL SIXBIT
RETURN
SETKB: TXNE T1,RM.FPA ;[C20] FORTRAN FLOATING POINT ASCII?
JRST SETMAF ;YES
TXNN T1,RM.COM ;[C20] [330] SPECIFICALLY COMP?
JRST SETMBN ;[330] MODE BINARY NONCOMP
; JRST SETMBC ;[330] MODE BINARY COMP
SETMBC: TXNN T1,RM.UNS ;[C20] [330] COMP. UNSIGNED?
SKIPA J,[IX.CSB] ;[C20] [330] NO- SIGNED. DEFAULT
MOVEI J,IX.CUB ;[C20] [330] YES- UNSIGNED.
RETURN ;[330]
SETMBN: TXNN T1,RM.UNS ;[C20] [330] NONCOMP. UNSIGNED?
SKIPA J,[IX.NSB] ;[C20] [330] NO- SIGNED. DEFAULT.
MOVEI J,IX.NUB ;[C20] [330] YES- UNSIGNED.
RETURN ;[330]
;**;[511] @SETMAF: Insert 2 lines. DMN 27-Oct-82
SETMAF: TXNE T1,RM.UNS ;[511] IS IT UNSIGNED?
SKIPA J,[IX.FPU] ;[511] YES.
MOVEI J,IX.FPA ;[C20] FORTRAN FLOATING POINT ASCII
RETURN
END;
SUBTTL PSORT. -- KEYEXT - Generate Key Extraction Code
BEGIN
PROCEDURE (PUSHJ P,KEYEXT)
;GENERATE CODE TO EXTRACT KEYS AT RUN TIME
MOVE U,EXTORG ;[C13] ADDRESS OF EXTRACT CODE
SKIPN R,FSTKEY ;MUST HAVE SEEN ONE
JRST E$$OKR ;ERROR
MOVE T1,[POINT 36,1(R)]
MOVEM T1,XTRWRD ;SETUP DEPOSIT BYTE PTR
FOR EACH KEY DO
BEGIN
MOVE T1,KY.MOD(R) ;[C20] GET THIS MODE
IOR T1,MODE ;[C20] ADD DEFAULTS
PUSHJ P,JMODES ;GET KEY MODE INDEX
DMOVE P1,KY.INI(R) ;GET FIRST BYTE AND LENGTH
MOVE T2,P1 ;GET COPY
IF MODE IS NUMERIC OR COMP-3
TXNE T1,RM.NUM!RM.PAC ;[C20]
THEN CHECK FOR TOO MANY DIGITS
CAIG P2,^D18
JRST $F
E$$TMD: $ERROR (?,TMD,<Too many digits in key>)
FI;
IF MODE IS COMP OR COMP-3
TXNN T1,RM.COM!RM.PAC ;[C20] COMP IS SPECIAL
JRST $T
THEN CALCULATE NO. OF WORDS FROM DIGITS GIVEN
IF COMP
TXNN T1,RM.COM ;[C20]
JRST $T
THEN
HRRZ T3,MODE ;[C20]
ADD T2,[EXP 6,5,4,1]-1(T3) ;[OK] ASSUME SINGLE PRECISION
CAILE P2,^D10 ;IS IT
ADD T2,[EXP 6,5,4,1]-1(T3) ;[OK] NO
JRST $F
ELSE MUST BE COMP-3
MOVEI T1,2(P2) ;[OK] NO. OF DIGITS + SIGN + ROUNDING
LSH T1,-1 ;CUT IN HALF
ADD T2,T1 ;[C20] NEW LAST BYTE
FI;
JRST $F
ELSE
ADD T2,P2 ;[C20] LAST BYTE
FI;
CAMLE T2,RECORD ;SEE IF IN RANGE
JRST E$$KOR ;NO
IFN FTKL10,<
PUSHJ P,@K.KLX(J) ;[C20]
>
IFE FTKL10,<
MOVE T1,CPU ;GET CPU TYPE (KL USES BIS)
PUSHJ P,@[IFIWS <@K.EXT(J),@K.EXT(J),@K.KLX(J)>](T1) ;[C20] AND PROCESS IT
>
MOVE T1,EXTORG ;[C13] GET END ADDRESS OF EXTRACT SPACE
ADD T1,EXTSZ ;[C13] ..
SUBI T1,1 ;[C20] ..
CAML U,T1 ;[C20] [C13] DID IT GET TOO BIG?
JRST [$ERROR (?,KEB,<KEY extraction code too big>)] ;[C13]
SKIPE R,KY.NXT(R) ;NEXT KEY
JRST $B ;MORE TO DO
END;
$JRST$ ;NO, ALL DONE
XMOVEI U,(U) ;[C20] MAKE SURE THE SECTION NUMBER IS THERE
MOVEM U,.CMPAR ;MARK END OF EXTRACT CODE
SOS XTRWRD ;BACKUP BYTE PTR
HRRZS XTRWRD ;NO. OF EXTRA WORDS EXTRACTED
IF ANY EXTRACTED KEYS
SKIPN P1,XTRBYT
RETURN
THEN ADJUST OTHER KEYS FOR INSERTED EXTRACTED ONES
MOVE R,FSTKEY ;START AT FRONT
FOR EACH KEY DO
BEGIN
MOVE T1,KY.MOD(R) ;[C20] GET THIS MODE
IOR T1,MODE ;[C20] ADD DEFAULTS
PUSHJ P,JMODES ;GET KEY MODE INDEX
PUSHJ P,@K.ADJ(J) ;[OK] PROCESS IT
ADDM P1,KY.INI(R) ;ADJUST FIRST BYTE
SKIPE R,KY.NXT(R) ;GET NEXT
JRST $B
END;
FI;
;NOW ADJUST EXTRACTED KEYS TO COMPENSATE FOR MOVING ACTUAL RECORD
MOVE R,FSTKEY ;START AT FRONT
MOVE U,EXTORG ;[C13]
FOR EACH KEY DO
BEGIN
MOVE T1,KY.MOD(R) ;[C20] GET THIS MODE
IOR T1,MODE ;[C20] ADD DEFAULTS
PUSHJ P,JMODES ;GET KEY MODE INDEX
XCT K.ADX(J) ;[OK] PROCESS IT
SKIPE R,KY.NXT(R) ;GET NEXT
JRST $B
END;
RETURN
END;
SUBTTL PSORT. -- Dispatch Tables for Key Extraction
DEFINE XX(AA,B)<
IFIDN <B><N>,<IFIW CPOPJ> ;;[C20]
IFIDN <B><A>,<IFIW AA'EXT>
IFIDN <B><C>,<IFIW AA'EXT> ;;[C20]
>
K.EXT: IXMODE
DEFINE XX(AA,B)<
IFIDN <B><N>,<IFIW CPOPJ> ;;[C20]
IFIDN <B><A>,<IFIW AA'KLX> ;;[C20]
IFIDN <B><C>,<IFIW AA'EXT> ;;[C20]
>
K.KLX: IXMODE
DEFINE XX(AA,B)<
IFIDN <B><A>,<IFIW CPOPJ1> ;;[C20]
IFIDN <B><N>,<IFIW CPOPJ> ;;[C20]
IFIDN <B><C>,<IFIW CPOPJC> ;;[C20]
>
K.ADJ: IXMODE
CPOPJC: SKIPE COLSW ;CONDITIONAL COLLATING SEQUENCE
AOS (P)
POPJ P,
DEFINE XX(AA,B)<
IFIDN <B><A>,<PUSHJ P,AA'ADX>
IFIDN <B><N>,<NOOP>
IFIDN <B><C>,<PUSHJ P,AA'ADX>
>
K.ADX: IXMODE
SUBTTL PSORT. -- KEYGEN - Generate Key Comparison Code
BEGIN
PROCEDURE (PUSHJ P,KEYGEN)
;GENERATE CODE TO COMPARE KEYS AT RUN TIME
MOVE U,.CMPAR ;ADDRESS OF COMPARE/EXTRACT CODE
MOVE T1,[AOS CMPCNT] ;YES, LOAD FIRST INST
MOVEM T1,(U) ;INTO GENERATED CODE
ADDI U,1 ;AND PRESERVE AOS CMPCNT INSTRUCTION
MOVE R,FSTKEY ;MUST HAVE SEEN ONE
FOR EACH KEY DO
BEGIN
MOVE T1,KY.MOD(R) ;[C20] GET THIS MODE
IOR T1,MODE ;[C20] PLUS DEFAULTS
PUSHJ P,JMODES ;GET INDEX
DMOVE P1,KY.INI(R) ;GET ORIGIN & LENGTH
PUSHJ P,KEYADJ ;SEE IF NEXT KEY IS ADJACENT
PUSHJ P,@K.GEN(J) ;[OK] AND PROCESS IT
MOVE T1,EXTORG ;[C13] GET END ADDRESS OF EXTRACT SPACE
ADD T1,EXTSZ ;[C13] ..
SUBI T1,1 ;[C20] ..
CAML U,T1 ;[C20] [C13] DID IT GET TOO BIG?
JRST [$ERROR (?,KCB,<KEY comparison code too big>)] ;[C13]
SKIPE R,KY.NXT(R) ;MORE TO DO
JRST $B ;YES
END;
$JRST$ ;NO, ALL DONE
RETURN
END;
DEFINE XX(AA,B)<
IFIDN <B><A>,<IFIW CNVGEN> ;;[C20]
IFIDN <B><C>,<IFIW AA'GEN> ;;[C20]
IFIDN <B><N>,<IFIW AA'GEN> ;;[C20]
>
K.GEN: IXMODE
BEGIN
PROCEDURE (PUSHJ P,KEYADJ)
;SEE IF NEXT KEY IS ADJACENT
HRREI T1,-IX.ALE(J) ;ALPHANUMERICS COME FIRST IN TABLE
JUMPG T1,$1 ;ONLY CHECK FOR ALPHANUMERIC
MOVE T2,KY.ORD(R) ;[C20] GET ORDER
SKIPE T1,KY.NXT(R) ;ANY MORE TO DO?
CAME T2,KY.ORD(T1) ;[C20] YES, CHECK FOR SAME ORDER
$1% RETURN ;GIVE UP
MOVE T2,KY.INI(T1) ;[OK] GET ORIGIN OF THIS KEY
SUB T2,P2 ;[C20] SUBTRACT LENGTH OF PREVIOUS
CAME T2,P1 ;[C20] SAME ORIGIN?
RETURN ;NO
PUSH P,J ;YES, NOW TEST MODE
MOVE T1,KY.MOD(T1) ;[C20]
IOR T1,MODE ;[C20]
PUSHJ P,JMODES ;SET MODE IN J
MOVE T1,J
POP P,J ;GET BACK PREVIOUS
CAME T1,J ;ALL THE SAME?
RETURN ;NO
MOVE T1,KY.NXT(R)
ADD P2,KY.SIZ(T1) ;[OK] INCREMENT SIZE
MOVEM P2,KY.SIZ(R) ;REMEMBER THAT WE INCREMENTED
MOVE T2,KY.NXT(T1) ;[OK]
MOVEM T2,KY.NXT(R) ;REMOVE KEY
JRST $B ;TRY AGAIN
END;
SUBTTL HPURE SEGMENT ERROR MESSAGES
E$$RSR: $ERROR (?,RSR,<Record size required>)
E$$KLR: $ERROR (?,KLR,<Key length required>)
E$$KOR: $ERROR (?,KOR,<Key outside of record>)
E$$KAI: $ERROR (?,KAI,<Key argument incorrect>)
E$$OKR: $ERROR (?,OKR,<At least one key is required>)
E$$MSC: $ERROR (?,MSC,<Mode switch conflict>)
E$$INS: $ERROR (?,INS,<Input file not specified>)
E$$ONS: $ERROR (?,ONS,<Output file not specified>)
E$$MOM: $ERROR (?,MOM,<Multiple output specs only on magtapes>)
E$$CWB: $ERROR (?,CWB,<Computational key must be on word boundary>)
E$$BNV: $ERROR (?,BNV,<BINARY mode does not support variable length records>)
E$$ATF: $ERROR (?,ATF,<At least two input files required for MERGE>)
E$$FSM: $ERROR (?,FSM,</FORMAT switch must be preceded by /KEY switch>)
E$$FSA: $ERROR (?,FSA,</FORMAT switch argument error>)
E$$OOF: $ERROR (?,OOF,<Only one /FORMAT switch per /KEY switch>)
E$$MCS: $ERROR (?,MCS,<Multiple collating sequences not allowed.>)
E$$CND: $ERROR (?,CND,<Collating sequence not defined>)
E$$CFS: $ERROR (?,CFS,<Collating sequence file specification in error.>)
E$$CLS: $ERROR (?,CLS,<Collating sequence literal specification in error.>)
E$$CFE: $ERROR (?,CFE,<Collating sequence input file error.>)
E$$ICS: $ERROR (?,ICS,<Illegal user supplied collating sequence>)
;**;[500] @E$$ICS: + 1L Insert 4 lines. GCS 13-APR-82
ERRDCC: PUSHJ P,.PSH4T ;[500] SAVE T1 THRU T4
$ERROR (%,DCC,<Duplicate character in collating sequence>) ;[500]
PUSHJ P,.POP4T ;[500] RESTORE T1 THRU T4
POPJ P, ;[500]
SUBTTL FATAL ERROR CLEAN-UP ROUTINES
SEGMENT LPURE ;[C20]
BEGIN
PROCEDURE (,DIE) ;HERE ON FATAL ERROR
$CRLF ;CLOSE OUT LINE
IFE FTOPS20,<
PUSHJ P,RELSPC ;[C13] RELEASE ANY RETAINED MEMORY
IFE FTFORTRAN,<
IFE FTVM,<
PUSHJ P,GETSCN ;[C20] [425] NEED HI-SEG
>
SKIPE FORRET ;[C20] CALLED FROM FORTRAN?
JRST FORERR ;[C20] YES
JRST RSTART ;[C13] RESTART SORT
>
IFN FTFORTRAN,<
MOVE P,SAVEP ;RESTORE ORIGINAL PP
IF USERS WANTS CONTROL
SKIPG T1,ERRADR ;[OK] GET RETURN ADDRESS
JRST $T
THEN RETURN TO FORTRAN
MOVEM T1,(P) ;[C20] SET USERS RETURN ADDRESS
POPJ P, ;RETURN TO FORTRAN
ELSE DO FORTRAN EXIT
MOVEI L,1+[EXP 0,0]
PUSHJ P,EXIT.##
HALT
FI;
>
>
IFN FTOPS20,<
SKIPE TAKFLG ;ARE WE TAKING FROM A FILE?
CALL TAKEX ;YES, CLOSE TAKE SOURCE AND LOG FILES
CALL ERSET$ ;[335] CLEAN UP THE MESS
SKIPE FORRET ;[C20] CALLED FROM FORTRAN?
JRST FORERR ;YES
JRST RSTART ;[C13] RESTART SORT
>
END;
SUBTTL RELES. -- Add Input Record to Tree
BEGIN
PROCEDURE (PUSHJ P,RELES.)
MOVEM P,PSAV ;SO WE CAN RECOVER FROM EOF
IF /MERGE NOT SEEN
SKIPLE MRGSW ;MERGE ONLY?
JRST $T ;YES
THEN SETUP FOR SORT
MOVEI F,FCBORG ;[215] SET INPUT FILE'S FILE BLOCK
MOVE T1,F.INZR ;[C20] [215] GET AND REMOVE FIRST FILE'S X. BLOCK
MOVE T1,(T1) ;[C20] ..
EXCH T1,F.INZR ;[215] ..
MOVEM T1,FILXBK(F) ;[215] SAVE IN FILE'S FILE BLOCK
PUSHJ P,INIINP ;[215] INITIALIZE FIRST INPUT FILE
SETOM BUFALC ;[215] REMEMBER WE SET BUFFERS UP
$1% MOVEI F,FCBORG ;INPUT CHAN#
JSP P4,GETREC ;GET RECORD INTO (R)
PUSHJ P,DOEOF ;[C20] HANDLE E-O-F
PUSHJ P,RELES% ;GIVE IT TO TREE
JRST $1 ;LOOP
ELSE SETUP FOR MERGE
PUSHJ P,GETMRG ;SETUP AT MOST MAXTMP FILES
IF IT CAN BE DONE IN 1 PASS
SKIPE NUMINP ;ANY LEFT TO DO
JRST $T ;YES, NEED MULTIPLE PASSES
THEN SETUP TO MERGE TO OUTPUT FILE
MOVEI T1,EOFMRG
MOVEM T1,LOGEOF
MOVEM T1,PHYEOF
PUSHJ P,INIOUT ;OPEN OUTPUT FILE
SKIPE ACTTMP ;[327] ALL FILES EMPTY?!
JSP P4,PUTREC ;WE ALREADY HAVE FIRST RECORD IN R
MOVEI T1,RETRNM
SKIPLE WSCSW ;/CHECK REQUIRED?
MOVEI T1,RETWSC ;YES
MOVEM T1,$RETRN
HRRZS LSTREC ;USED IF /CHECK ON
MOVE P,PSAV
RETURN
ELSE SETUP TO DO MULTIPLE MERGE CYCLES
MOVEI T1,EOFMNY
MOVEM T1,LOGEOF
MOVEM T1,PHYEOF
MOVEI F,FCBORG
PUSHJ P,FSTRUN ;OPEN TEMP FILE
FASTSKIP ;WE ALREADY HAVE FIRST RECORD IN R
$2% PUSHJ P,RETRNM ;GET NEXT RECORD
MOVEI F,FCBORG
JSP P4,PTTREC ;OUTPUT IT
JRST $2 ;LOOP UNTIL EOF
FI;
FI;
END;
SUBTTL RELES. -- Merge Initialization
;GETMRG IS CALLED TO INITIALIZE UP TO ACTTMP FILES FOR A MERGE. THIS INVOLVES
;OPENING UP THE FILE, READING ITS FIRST RECORD, AND PUTTING IT IN THE TREE.
;SPECIAL CASES OCCUR WHEN THE FIRST READ GIVES THE END-OF-FILE RETURN, MEANING
;THE FILE WAS NULL. IN THIS CASE, WE SIMPLY CLOSE THE FILE AND USE THE NEXT FILE
;IN ITS PLACE. HOWEVER, IF WE RUN OUT OF FILES, THEN WE FILL THE TREE WITH
;DUMMY RECORDS (RUN = -1), INDICATING END-OF-FILE. IF ALL FILES ARE NULL, THE
;ENTIRE TREE IS FILLED WITH THESE RECORDS, AND ACTTMP IS 0. THUS, SUBSEQUENT
;ROUTINES SHOULD CHECK ACTTMP FOR 0, OR FOR A RECORD WITH A -1 RUN # AT THE TOP
;OF THE TREE. THE SAVING OF BUFALC IS DONE SO THAT A NULL FILE'S BUFFER SPACE IS
;REUSED BY THE NEXT FILE.
BEGIN
PROCEDURE (PUSHJ P,GETMRG) ;[327] INITIALIZE FIRST MERGE FILES
MOVE S,TREORG ;GET FIRST "WINNER"
HRRZ R,RN.REC(S) ; AND RECORD
MOVEI F,TMPFCB ;[C20] [327] START WITH FIRST FILE BLOCK
PUSH P,ACTTMP ;[327] COUNTER FOR MOST WE CAN DO NOW
PUSH P,BUFALC ;[327] SAVE BUFFER RE-USE FLAG
WHILE THERE ARE FILES WE CAN INITIALIZE
BEGIN
MOVE T1,F.INZR ;[C20] [327] REMEMBER THIS FILE
MOVE T1,(T1) ;[C20] ..
EXCH T1,F.INZR ;[327] AND ADVANCE TO NEXT
MOVEM T1,FILXBK(F) ;[327] SAVE THIS FILE IN X. BLOCK
SOS NUMINP ;[327] ONE LESS FILE LEFT
PUSHJ P,INIINP ;[327] INITIALIZE THIS FILE
MOVE T1,(P) ;[327] RESTORE BUF RE-USE FLAG
MOVEM T1,BUFALC ;[327] ..
IF THIS FILE ISN'T NULL
JSP P4,GETREC ;[327] GET FIRST REC FROM FILE
JRST [PUSHJ P,CHKMTA ;[327] MULTI-REEL TAPE?
JRST .+1 ;[327] YES--NOW HAVE REC
JRST $T] ;[327] NO--NULL FILE
THEN COUNT FILE & PUT ITS RECORD IN THE TREE
AOS RQ ;WILL BE RUN #1
HRLM F,RN.FCB(S) ;[327] REMEMBER WHICH FILE REC CAME FROM
PUSHJ P,SETTRE ;[327] ADD RECORD TO TREE
SOS -1(P) ;[327] ONE LESS REC IN TREE
HRRZ R,RN.REC(S) ;[327] SET UP NEXT RECORD POINTER
ADDI F,FCBLEN ;[C20] [327] ADVANCE TO NEXT FILE BLOCK
JRST $F ;[327]
ELSE CLOSE FILE AND REUSE ITS BUFFER SPACE ON NEXT FILE
PUSHJ P,CLSMST ;[327] CLOSE THE FILE
SETOM BUFALC ;[327] REUSE BUFFER SPACE
FI;
SKIPE -1(P) ;[327] MORE TREE ROOM?
SKIPN F.INZR ;[327] AND MORE FILES TO DO?
JRST $E ;[327] NO--DONE HERE
JRST $B ;[327] YES--LOOP
END;
WHILE THE TREE ISN'T FULL
BEGIN
SKIPN -1(P) ;[327] MORE ROOM IN TREE?
JRST $E ;[327] NO--DONE
HLLOS RQ ;[327] YES--FILL WITH DUMMY RECORD
PUSHJ P,SETTRE ;[327] ..
SOS ACTTMP ;[327] ONE LESS INPUT FILE
SOS -1(P) ;[327] ONE LESS TREE RECORD
JRST $B ;[327] LOOP
END;
SUB P,[2,,2] ;[327] CLEAR OFF STACK TEMPS
AOS RC ;SET CURRENT RUN TO #1
SETOM BUFALC ;[327] SIGNAL TO REUSE BUFFERS
RETURN ;[327] DONE
END;
SUBTTL RELES. -- End of Input File -- SORT Case
BEGIN
PROCEDURE (PUSHJ P,MSTEOF) ;[215] MASTER INPUT FILE EOF
;[215] CALLED IN ERROR RETURN OF CALL TO GETREC WITH:
;[215] F/ POINTER TO FCB BLOCK FOR THIS FILE
PUSHJ P,CHKMTA ;[215] CHECK EOT IF MAGTAPE
RETURN ;[215] ANOTHER REEL--CONTINUE
MOVE T1,FILSIZ(F) ;[215] UPDATE INPUT RECORD COUNT
ADDM T1,INPREC ;[215] ..
PUSHJ P,CLSMST ;CLOSE THE CURRENT MASTER FILE
IF ANY MORE INPUT FILES
SKIPN F.INZR ;[215] LIST EMPTY?
JRST $T ;[215] YES--NO MORE INPUT FILES
THEN INITIALIZE THE NEXT ONE
MOVE T1,F.INZR ;[C20] [215] GET POINTER TO NEXT
MOVE T1,(T1) ;[C20] ..
EXCH T1,F.INZR ;[215] SWAP NEXT WITH THIS
MOVEM T1,FILXBK(F) ;[215] STORE IN X. BLOCK POINTER
PUSHJ P,INIINP ;[215] OPEN FILE AND SET MODES
JSP P4,GETREC ;[215] FINISH PENDING RECORD REQUEST
JRST MSTEOF ;[215] [107] IGNORE NULL FILES
JRST $F ;[215]
ELSE UNBIND STACK TO START MERGE
MOVE P,PSAV ;[215] UNBIND STACK
FI;
RETURN ;[215] ALL DONE
END;
SUBTTL RELES. -- End of Input File -- MERGE Case
BEGIN
PROCEDURE (PUSHJ P,EOFMNY)
PUSHJ P,CHKMTA ;[215] THIS MIGHT BE MULTI-REEL FILE
RETURN ;[215] YES--CONTINUE AS IF NOTHING HAPPENED
PUSHJ P,CLSMST ;[327] CLOSE THE FILE (EOT PROCESSING, ETC.)
MOVE T1,FILSIZ(F)
ADDM T1,INPREC ;KEEP COUNT OF INPUT RECORDS
IF NOT LAST FILE
SOSG ACTTMP ;ALL DONE?
JRST $T
THEN TERMINATE THIS RUN AND CONTINUE
HLLOS RQ ;SET TERMINATING RUN#
RETURN
ELSE TERMINATE CYCLE AND START AGAIN
IF NO MORE TO DO
SKIPE NUMINP ;ANY MORE
JRST $T ;TOO BAD
THEN JUST RETURN
MOVE P,PSAV
RETURN
ELSE TRY AGAIN
MOVEI F,FCBORG ;SET ON OUTPUT FILE
PUSHJ P,CLSRUN ;CLOSE THIS, OPEN NEXT RUN
PUSHJ P,SETMRG ;SETUP MERGE NO. AGAIN
PUSHJ P,INITRE ;SETUP NUL TREE AGAIN
PUSHJ P,GETMRG ;SETUP TEMP FILES AGAIN
SKIPN ACTTMP ;[327] ALL FILES NULL?
JRST [MOVE P,PSAV ;[327] YES--NOTHING TO DO
POPJ P,] ;[327] SO JUST RETURN
MOVEI F,FCBORG
JSP P4,PTTREC ;WE ALREADY HAVE FIRST RECORD IN R
POP P,(P) ;GET TOP CALL OFF STACK
PJRST RETRNM ;CONTINUE
FI;
FI;
END;
SUBTTL RELES. -- End of Input File -- Check End Lables
BEGIN
PROCEDURE (PUSHJ P,CHKMTA) ;[215] SEE IF EOT OF MULTI-REEL FILE OR EOF
PUSH P,P1 ;[215] SAVE TEMP FOR X. BLOCK
IF WE HAVE A MAGTAPE
PUSHJ P,ISITMT ;IS THIS A MAGTAPE?
JRST $T ;NO, SKIP LABEL STUFF
THEN CHECK END LABEL (IF ANY) AND SEE IF MULTI-REEL
MOVE P1,FILXBK(F) ;GET ADDR OF X. BLOCK
IFE FTFORTRAN,<
$1% PUSHJ P,CHKEND ;[215] PROCESS LABEL
>
IF TAPE NEEDS UNLOADING
MOVE T1,FILFLG(F) ;[215] SEE IF USER ASKED FOR IT
TXNE T1,FI.UNL!FI.EOT ;[215] OR ANOTHER REEL TO FILE
THEN UNLOAD TAPE
PUSHJ P,UNLDF ;[215] YES--UNLOAD TAPE
FI;
IFE FTFORTRAN,<
IF FILE IS MULTI-REEL
MOVE T1,FILFLG(F) ;[215] GET FLAGS BACK
TXNN T1,FI.EOT ;[215] EOT RATHER THAN EOF?
JRST $T ;[215] NO--WE'RE DONE
THEN ASK USER OR OPERATOR TO MOUNT NEXT REEL
IFN FTOPS20,<
SKIPE MOUNTR ;[C12] MOUNTR AROUND?
PUSHJ P,[ PUSHJ P,GMTVOL ;[C12] YES, LET MOUNT DO IT
JRST $2] ;[C12] ..
>
CLEARO ;[215] CLEAR ^O
E$$LRI: $ERROR ($,LRI,<Load reel >,+) ;[215] ASK FOR TAPE
MOVE T1,X.REEL(P1) ;[OK] [215] PRINT REEL # WE WANT
ADDI T1,1 ;[215] ..
$MORE (DECIMAL,T1) ;[215] ..
$MORE (TEXT,< of input file >);[215] NOW PRINT WHICH FILE
IFE FTOPS20,<
MOVEI T1,X.RIB(P1) ;[OK] ..
>
IFN FTOPS20,<
HLRZ T1,FILPGN(F) ;GET JFN
>
$MORE (FILESPEC,T1) ;[215] TYPE FILESPEC
$MORE (TEXT,<, type CONTINUE when ready.>) ;[215]
$CRLF ;[215] ALL DONE
MONRET ;[215] EXIT TO ALLOW USER TO MOUNT TAPE
IFN FTOPS20,<
$2% PUSHJ P,STRTIO ;[C12] START I/O
>
MOVX T1,FI.EOT ;CLEAR EOT FLAG
ANDCAM T1,FILFLG(F) ; ..
PUSHJ P,CHKLBL ;[215] CHECK NEW REEL
JSP P4,GETREC ;[C07] [215] FINISH PENDING GETREC
JRST $1 ;[215] WHAT?? ANOTHER LABEL SO QUICK??
JRST $F ;[215] WE HAVE NEW REEL SET UP NOW
ELSE WE'RE REALLY DONE WITH FILE, SO GIVE EOF RETURN
>
AOS -1(P) ;[215] EOF IS SKIP RETURN
IFE FTFORTRAN,<
FI;
>
JRST $F ;[215] NOW DONE CHECKING EOT
ELSE NOT A TAPE, JUST GIVE EOF RETURN
AOS -1(P) ;[215] EOF IS SKIP RETURN
FI;
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] DONE
END;
SUBTTL MERGE.
BEGIN
PROCEDURE (PUSHJ P,MERGE.)
MOVEM P,PSAV ;SAVE P INCASE NEEDED
IF NOT 1 PASS /MERGE
SKIPLE MRGSW
SKIPE NUMTMP
THEN DO MERGE
PJRST MERGE%
ELSE JUST RETURN
RETURN
FI;
END;
SUBTTL RETRN. -- End of Output File
BEGIN
PROCEDURE (PUSHJ P,EOFOUT)
;THIS ROUTINE IS CALLED FROM VARIOUS PLACES WHEN WE ARE FINALLY
;DONE WITH THE OUTPUT FILE. ANY FINAL MAGTAPE PROCESSING IS DONE
;AND WE RETURN TO THE TOP LEVEL OF SORT.
MOVEI F,FCBORG
PUSHJ P,ISITMT ;[C08] IS IT A MAGTAPE?
SKIPA ;[C08] NO
PUSHJ P,WRTEND ;[C08] YES, WRITE EOF LABEL
PUSHJ P,CLSMST ;CLOSE MASTER FILE
MOVE T1,FILSIZ(F) ;[215] REMEMBER HOW MUCH WE
MOVEM T1,OUTREC ;[215] WROTE FOR ENDS.
MOVE T1,FILFLG(F) ;[C08] CHECK FOR UNLOAD IF MAGTAPE
TXNE T1,FI.UNL ;[C08] ..
PUSHJ P,ISITMT ;[C08] ..
SKIPA ;[C08] NO
PUSHJ P,UNLDF ;[C08] YES--UNLOAD TAPE
MOVE P,PSAV ;UNBIND STACK
RETURN
END;
SUBTTL RETRN. -- MSTEOT - EOT Detected on Output Tape
IFE FTFORTRAN,<
BEGIN
PROCEDURE (PUSHJ P,MSTEOT) ;[215] CONTINUE MULTI-REEL FILE
;THIS ROUTINE IS CALLED BY PUTREC WHEN AN END-OF-TAPE ERROR HAS BEEN
;DETECTED BY PUTBUF. SINCE THERE IS A PENDING RETURN FROM PUTREC IN
;P4, WE MUST SAVE IT. END-OF-TAPE PROCESSING FOLLOWS, BY WRITING
;LABELS AND UNLOADING THE OLD TAPE. IF THE NEXT DRIVE TO BE USED IS
;DIFFERENT FROM THE ONE WE JUST FINISHED WITH, A BOILED-DOWN COPY OF
;THE INIOUT ROUTINE IS USED TO SET UP ALL PROPER TAPE PARAMETERS.
;THEN, USER IS ASKED TO MOUNT THE NEXT TAPE. FINALLY, A HEADER LABEL
;IS WRITTEN.
PUSH P,P1 ;[215] SAVE TEMP FOR X. BLOCK
PUSH P,P4 ;[215] SAVE ORIGINAL CALLER
MOVE P1,FILXBK(F) ;[215] SET UP X. BLOCK
PUSHJ P,WRTEOT ;[215] WRITE END LABEL
PUSHJ P,UNLDF ;[215] DONE WITH THIS TAPE
MOVX T1,FI.EOT ;[414] GET EOT BIT
ANDCAM T1,FILFLG(F) ;[414] AND CLEAR IT
IFE FTOPS20,<
IF NEXT DRIVE IS DIFFERENT THAN CURRENT
MOVE T1,F.OUZR ;[C20] GET NEXT DEVICE
SKIPN T1,(T1) ;[C20] ..
MOVE T1,X.NXT(P1) ;[OK] [215] LIST ENDED--START OVER
MOVEM T1,F.OUZR ;[215] REMEMBER FOR NEXT TIME
MOVE T1,OM.DEV(T1) ;[OK] [215] GET DEVICE
CAMN T1,X.OPN+.OPDEV(P1) ;[OK] [215] SAME AS LAST ONE?
JRST $F ;[215] YES--WE'RE ALL SET
THEN WE MUST INITIALIZE IT TO LOOK LIKE LAST DRIVE
MOVEM T1,X.OPN+.OPDEV(P1) ;[OK] [215] STORE DEVICE FOR OPEN
MOVX T1,BF.VBR ;[C19] SET VIRGIN BUFFER RING HEADER
IORM T1,FILHDR(F) ;[C19] ..
HLLZS FILPTR(F) ;[C19] CLEAR RH OF BYTE POINTER
SETZM FILCNT(F) ;[C19] CLEAR FILE COUNT
HRL T1,FILCHN(F) ;[C19] BUILD FILOP. BLOCK, GET CHANNEL
HRRI T1,.FORED ;[C19] GET READ FUNCTION
MOVEM T1,FLPARG+.FOFNC ;[C19] STORE THEM
HRLI T1,X.OPN(P1) ;[OK] [C19] TRANSFER OPEN BLOCK
HRRI T1,FLPARG+.FOIOS ;[C19] ..
BLT T1,FLPARG+.FOIOS+2 ;[C19] ..
SETZM FLPARG+.FONBF ;[C19] NO BUFFERS
SETZM FLPARG+.FOLEB ;[C19] NO LOOKUP BLOCK
HLLZ T2,FILPTR(F) ;[C19] SAVE BYTE SIZE
MOVE T1,[.FOLEB+1,,FLPARG] ;[C19] DO READ FILOP.
FILOP. T1, ;[C19] ..
JRST ERRFUF ;[C19] FAILED
HLLM T2,FILPTR(F) ;[C19] RESTORE BYTE SIZE
PUSHJ P,STAPF ;[215] SET UP DENSITY, ETC.
FI;
>;END IFE FTOPS20
IFN FTOPS20,<
SKIPE MOUNTR ;[C12] MOUNTR AROUND?
PUSHJ P,[ PUSHJ P,GMTVOL ;[C12] YES, LET MOUNTR DO IT
JRST $1] ;[C12] ..
>
CLEARO ;[215] CLEAR ANY ^O
E$$LRO: $ERROR ($,LRO,<Load reel >) ;[215] ASK USER FOR NEXT TAPE
MOVE T1,X.REEL(P1) ;[OK] [215] SAY WHICH REEL
ADDI T1,1 ;[215] ..
$MORE (DECIMAL,T1) ;[215] ..
$MORE (TEXT,< of output file >)
IFE FTOPS20,<
MOVEI T1,X.RIB(P1) ;[OK] LOAD ADDR OF RIB
>
IFN FTOPS20,<
HLRZ T1,FILPGN(F) ;LOAD JFN
>
$MORE (FILESPEC,T1) ;[215] SAY WHICH FILE
$MORE (TEXT,<, type CONTINUE when ready.>)
MONRET ;[215] WAIT FOR REEL
$1% PUSHJ P,WRTLBL ;[C12] [215] WRITE HEADER ON NEW REEL
POP P,P4 ;[215] RESTORE TEMPS
POP P,P1 ;[215] ..
RETURN ;[215] DONE
END;
>
SUBTTL RETRN. -- RETRNM - Return Record From First-pass Merge Files
BEGIN
PROCEDURE (PUSHJ P,RETRNM)
HLRZ F,RN.FCB(S) ;GET WHICH FILE
JSP P4,GETREC ;GET A RECORD
PUSHJ P,DOEOF ;[C20] E-O-F RETURN
PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,RETWSC)
EXCH R,LSTREC ;SAVE RECORD JUST OUTPUT
HRRM R,RN.REC(S) ;GET SPARE RECORD AREA
HLRZ F,RN.FCB(S) ;GET WHICH FILE
JSP P4,GETREC ;GET A RECORD
JRST [PUSHJ P,DOEOF ;[C20] E-O-F RETURN
JRST $1] ;DON'T TEST SINCE RECORD NOT READ
HRRZ J,LSTREC ;GET PREVIOUS FROM SAME FILE
COMPARE (R,J)
JRST $1 ;KEY(R) = KEY(J) ;OK
JRST $1 ;KEY(R) > KEY(J) ;OK
;KEY(R) > KEY(J) ;OUT OF SEQUENCE
E$$MRS: $ERROR (%,MRS,<MERGE record >,+)
$MORE (DECIMAL,FILSIZ(F))
$MORE (TEXT,< not in sequence for >)
HLRZ T2,RN.FCB(S) ;GET POINTER TO FILE BLOCK
IFE FTOPS20,< ;[521]
MOVE T2,FILXBK(T2) ;[521] OK
ADDI T2,X.RIB ;COMPENSATE FOR FOLLOWING MACRO
> ;[521]
IFN FTOPS20,<
HLRZ T2,FILPGN(T2) ;[521] GET JFN OF FILE
;[522] FROM LEFT HALF OF NEXT PAGE
> ;[521]
$MORE (FILESPEC,T2)
$CRLF
$1% PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,EOFMRG)
PUSHJ P,CHKMTA ;[327] MIGHT HAVE A MULTI-REEL TAPE
RETURN ;[327] YES--NOW HAVE ANOTHER RECORD
PUSHJ P,CLSMST ;[327] NO--JUST CLOSE THE FILE
MOVE T1,FILSIZ(F)
ADDM T1,INPREC ;KEEP COUNT OF INPUT RECORDS
SOSG ACTTMP ;ALL DONE?
JRST EOFOUT ;YES
HLLOS RQ ;SET TERMINATING RUN#
RETURN
END;
SUBTTL TAPE LABEL ROUTINES -- POSITF - Position Magtape at File
BEGIN
PROCEDURE (PUSHJ P,POSITF) ;[C11]
PUSH P,P1 ;[C11] SAVE A TEMP
MOVE T1,FILFLG(F) ;[C11] NEED TO REWIND FIRST?
TXNE T1,FI.REW ;[C11] ..
PUSHJ P,RWNDF ;[C11] YES, DO IT
MOVE T1,FILXBK(F) ;[C11] WAS POSITIONING REQUESTED?
SKIPG P1,X.POSI(T1) ;[OK] [C11] ..
JRST $4 ;[C11] NO
TXZN P1,1B1 ;[C11] YES, A BACKSPACE?
JRST $2 ;[C11] NO
IFN FTOPS20,<
MOVX T1,FI.ATO ;[C12] LABELED MOUNTR TAPE?
TDNN T1,FILFLG(F) ;[C12] ..
>
PUSHJ P,BKSPR ;[C11] NO, BACKSPACE OVER POSSIBLE EOF FIRST
$1% PUSHJ P,BKSPF ;[C11] BACKSPACE A FILE
SOJG P1,$1 ;[C11] LOOP FOR COUNT
IFN FTOPS20,<
MOVX T1,FI.ATO ;[C12] LABELED MOUNTR TAPE?
TDNE T1,FILFLG(F) ;[C12] ..
JRST $4 ;[C12] YES, DONE
>
PUSHJ P,ISATBT ;[C11] NO, AT BOT?
PUSHJ P,SKIPF ;[C11] NO, SKIP OVER EOF
JRST $4 ;[C11] DONE
$2% ;[C12] A SKIP
IFN FTOPS20,<
MOVX T1,FI.ATO ;[C12] LABELED MOUNTR TAPE?
TDNE T1,FILFLG(F) ;[C12] ..
JRST $3 ;[C12] YES
>
PUSHJ P,BKSPR ;[C11] NO, BACKSPACE OVER POSSIBLE EOF FIRST
PUSHJ P,ISATBT ;[C11] AT BOT?
ADDI P1,1 ;[C11] NO, SKIP OVER EOF
$3% PUSHJ P,SKIPF ;[C11] SKIP A FILE
SOJG P1,$3 ;[C11] LOOP FOR COUNT
$4% POP P,P1 ;[C11] RESTORE TEMP
RETURN ;[C11] ALL DONE
END;
SUBTTL TAPE LABEL ROUTINES -- CHKLBL - Check Header Labels
IFE FTFORTRAN,<
BEGIN
PROCEDURE (PUSHJ P,CHKLBL) ;[215] CHECK TAPE HEADER LABELS
PUSH P,P1 ;[215] SAVE A TEMP
MOVE P1,FILXBK(F) ;[215] NEED X. BLOCK A LOT HERE
IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
MOVE T1,FILFLG(F) ;[C12] [215] FETCH TAPE'S FLAG BITS
TXNE T1,FI.ATO ;[C12] [215] TAPE LABELER DOING THE WORK?
JRST $F ;[C12] [215] YES--DONE
THEN WE MUST DO IT OURSELVES
CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI)
MOVE T1,X.LABL(P1) ;[OK] [215] FETCH LABEL TYPE
JRST @[IFIWS <$1,$C,$2,$1,$3,$4>]-1(T1) ;[C20] [215] CHECK PROPER LABELS
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
SKIPN X.RIB+.RBNAM(P1) ;[OK] [215] DID USER GIVE A NAME?
JRST E$$NRL ;TELL USER
JSP T4,GETBUF ;READ THE LABEL
JRST E$$RIE ;SHOULD NOT HAPPEN
SETZM FILCNT(F) ;SO WE IGNORE BLOCK WHEN DONE
CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T1,MODE ;[215] GET MODE OF FILE
PUSHJ P,@[IFIWS <CHKSIX,CHKASC,E$$ELN,CHKBIN>]-1(T1) ;[C20]
ESAC;
JRST $C ;[215] DONE WITH DEC LABELS
$2% ;[215] NON-STANDARD LABELS
E$$NSL: $ERROR (%,NSL,<Non-standard label not checked.>)
PUSHJ P,SKIPR ;[215] SKIP LABEL
JRST $C ;[215] DONE WITH NON LABELS
$3% ;[215] ANSI LABELS
E$$ANL: $ERROR (%,ANL,<ANSI label not checked.>)
PUSHJ P,SKIPF ;[215] SKIP LABEL
JRST $C ;[215] DONE WITH ANSI LABELS
$4% ;[215] IBM LABELS
E$$IBL: $ERROR (%,IBL,<IBM label not checked.>)
PUSHJ P,SKIPF ;[215] SKIP LABEL
; JRST $C ;[215] FALL THROUGH
ESAC;
FI;
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] ALL DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKSIX) ;CHECK SIXBIT LABEL
HRRZ T4,FILPTR(F) ;[C20] GET BUFFER ADDRESS
MOVE T1,0(T4) ;[OK] GET HEADER BYTES
LSHC T1,-2*6 ;BYTES 1-4
CAME T1,['HDR1'] ;IS IT CORRECT?
JRST E$$LNC
LSHC T1,2*6 ;RESTORE BYTES 5-6
MOVE T2,1(T4) ;[OK] GET BYTES 7-12
LSHC T1,4*6 ;LEFT JUSTIFY
LSH T2,-6 ;SHIFT INTO BYTES 1-2
HLR T2,2(T4) ;[OK] GET LAST CHARACTER
LSH T2,6 ;BYTES 11, 12, 13 IN LHS
CAME T1,X.RIB+.RBNAM(P1) ;[OK] [215] CHECK NAME
JRST E$$LNC
HLLZS X.RIB+.RBEXT(P1) ;[OK] [215] CLEAR RHS JUNK
HLLZ T2,T2 ;...
CAME T2,X.RIB+.RBEXT(P1) ;[OK] [215] MATCH
JRST E$$LNC
HRLZ T3,4(T4) ;[OK] GET REEL NUMBER
HLR T3,5(T4) ;[OK] ...
ANDCMI T3,7777 ;IN BYTES 0-4
SETZ T1, ;WHERE TO BUILD NUMBER
$1% SETZ T2,
LSHC T2,6 ;MOVE IN NEXT DIGIT
IMULI T1,^D10 ;MAKE SPACE FOR IT
SUBI T2,'0' ;[C20] ADD IN
ADD T1,T2 ;[C20] ..
JUMPN T3,$1 ;MORE TO DO
SKIPN X.REEL(P1) ;[OK] [215] [116] REEL #0 SAME AS #1
JUMPE T1,$2 ;[116] FOR FIRST MULTI-FILE REEL
SUBI T1,1 ;[C20] [C07] [116] PUT REEL NO. -1 IN T1
CAME T1,X.REEL(P1) ;[OK] [C07] [215] [116] ONE WE EXPECTED?
JRST ERRROS ;NO
$2% AOS X.REEL(P1) ;[OK] [215] [116] INCREMENT PREVIOUS REEL ID
RETURN
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKBIN)
HRRZ T4,FILPTR(F) ;[C20] GET BUFFER ADDRESS
MOVE T1,0(T4) ;[OK] GET HEADER BYTES
LSH T1,-8 ;TRY ASCII BYTES
CAMN T1,["HDR1"] ;IS IT ASCII?
JRST CHKASC ;YES
LSH T1,-4 ;NO, TRY SIXBIT BYTES
CAMN T1,['HDR1'] ;IS IT SIXBIT?
JRST CHKSIX ;YES
JRST E$$LNC ;ERROR
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKASC) ;CHECK ASCII LABEL
MOVE T4,FILPTR(F) ;[C20] GET BYTE PTR
HRRZ T1,T4 ;[C20] GET 1ST WORD
MOVE T1,0(T1) ;[C20] ..
LSHC T1,-8 ;RIGHT JUST
CAME T1,["HDR1"] ;
JRST E$$LNC ;ERROR
SETZ T1, ;BUILD NAME HERE
LSH T2,-4*7-1 ;RIGHT JUSTIFY
MOVEI T3,6 ;SIX CHARS
AOJA T4,$2 ;INCREMENT BYTE PTR
$1% ILDB T2,T4 ;GET NEXT BYTE
$2% LSH T1,6 ;MAKE SPACE
SUBI T2," " ;[C20] ADD IN (SIXBITIZED)
ADD T1,T2 ;[C20] ..
SOJG T3,$1 ;LOOP
CAME T1,X.RIB+.RBNAM(P1) ;[OK] [215] MATCH
JRST E$$LNC
MOVEI T3,3 ;GET EXT
$3% ILDB T2,T4
LSH T1,6
SUBI T2," " ;[C20] SAME AS ABOVE
ADD T1,T2 ;[C20] ..
SOJG T3,$3
HRLZ T1,T1 ;PUT IN LHS
HLLZS X.RIB+.RBEXT(P1) ;[OK] [215] CLEAR POSSIBLE JUNK
CAME T1,X.RIB+.RBEXT(P1) ;[OK] [215]
JRST E$$LNC
HRRZ T1,T4 ;[C20] PICKUP REEL ID
DMOVE T2,3(T1) ;[C20] ..
LSH T2,-1 ;DROP BIT 35
LSHC T2,2*7+1 ;LEFT JUSTIF
ANDCMI T2,377 ;CLEAR JUNK
SETZ T3, ;WHERE TO BUILD NUMBER
$4% SETZ T1,
LSHC T1,7 ;MOVE IN NEXT DIGIT
IMULI T3,^D10 ;MAKE SPACE FOR IT
SUBI T1,"0" ;[C20] ADD IN
ADD T3,T1 ;[C20] ..
JUMPN T2,$4 ;MORE TO DO
SKIPN X.REEL(P1) ;[OK] [215] [116] REEL #0 SAME AS #1
JUMPE T3,$5 ;[116] FOR FIRST MULTI-FILE REEL
SOS T1,T3 ;[C20] [C07] [116] PUT REEL NO. -1 IN T1
CAME T1,X.REEL(P1) ;[OK] [215] [116] ONE WE EXPECTED?
JRST ERRROS ;NO
$5% AOS X.REEL(P1) ;[OK] [215] [116] INCREMENT PREVIOUS REEL ID
RETURN
END;
SUBTTL TAPE LABEL ROUTINES -- WRTLBL - Write Header Labels
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTLBL) ;HERE TO WRITE MAGTAPE LABEL
PUSH P,P1 ;[215] SAVE TEMP FOR X. BLOCK
MOVE P1,FILXBK(F) ;[215] SET UP X. BLOCK
IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
MOVE T1,FILFLG(F) ;[C12] [215] GET FILE'S FLAGS
TXNE T1,FI.ATO ;[C12] [215] LABELER DOING THE WORK?
JRST $F ;[C12] [215] YES--NO PROBLEM
THEN WE MUST DO IT OURSELVES
AOS X.REEL(P1) ;[OK] [215] WE'RE NOW ON NEXT REEL
CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,IBM)
MOVE T1,X.LABL(P1) ;[OK] [215] GET LABEL TYPE
JRST @[IFIWS <$1,$C,$2,$1,$3,$4>]-1(T1) ;[C20]
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
IFE FTOPS20,<
SKIPG FILCNT(F) ;[C19] VIRGIN RING?
JSP T4,PUTBUF ;YES, DUMMY OUTPUT NEEDED
>;END IFE FTOPS20
CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T2,MODE ;[215] GET MODE OF TAPE
MOVE T1,[EXP 'HDR1',"HDR1 ",0,'HDR1']-1(T2) ;[OK] [215] SET UP LABEL
PUSHJ P,@[IFIWS <WRTSIX,WRTASC,WRTEBC,WRTBIN>]-1(T2) ;[C20]
JSP T4,PUTBUF ;[C08] FORCE BUFFER OUT
ESAC;
JRST $C ;[215] DONE WITH DEC LABELS
$2% ;[215] NON-STANDARD LABELS
E$$NLN: $ERROR (%,NLN,<Non-standard label not written.>)
JRST $C ;[215] CONTINUE
$3% ;[215] ANSI LABELS
E$$ALN: $ERROR (%,ALN,<ANSI label not written.>)
JRST $C ;[215] CONTINUE
$4% ;[215] IBM LABELS
E$$ILN: $ERROR (%,ILN,<IBM label not written.>)
; JRST $C ;[215] FALL THROUGH
ESAC;
FI;
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] ALL DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTSIX) ;WRITE SIXBIT LABEL
HRRZ T4,FILPTR(F) ;[C20] GET BUFFER ADDRESS
DMOVE T2,X.RIB+.RBNAM(P1) ;[OK] [215] GET NAME, EXT
JUMPE T2,E$$NRL
HRRI T3,' ' ;FILL WITH SPACES
LSHC T1,2*6
MOVEM T1,0(T4) ;[OK] FIRST WORD
LSH T2,-2*6
LSHC T2,2*6
MOVEM T2,1(T4) ;[OK] SECOND WORD
HRRI T3,' '
MOVEM T3,2(T4) ;[OK] THIRD WORD
HRLZM T3,3(T4) ;[OK] FOURTH WORD
MOVE T1,X.REEL(P1) ;[OK] [215] GET REEL NUMBER
SETZ T3, ;WHERE TO BUILD ID
$1% IDIVI T1,^D10 ;GET LEAST DIGIT
ADDI T2,'0' ;SIXBITIZE
LSHC T2,-6 ;SHIFT IN
TRNN T3,770000 ;GOT 4 CHARS YET?
JRST $1 ;NO
HLRZM T3,4(T4) ;[OK]
HRLI T3,'00 '
ADDI T3,' 00'
MOVSM T3,5(T4) ;[OK] STORE IT AS X0000
IFE FTOPS20,<
DATE T1, ;GET CURRENT DATE
IDIVI T1,^D31
ADDI T2,1
IDIVI T2,^D10 ;GET DAYS
LSH T2,6
ADDI T3,'00' ;[C20] SIXBITIZE
ADD T2,T3 ;[C20] ..
LSH T2,6
HRRZM T2,7(T4) ;[OK] STORE DAYS
IDIVI T1,^D12 ;GET MONTH
ADDI T2,1
IDIVI T2,^D10
LSH T2,6
ADDI T2,'00' ;[C20] PUT MONTH IN T3
ADD T3,T2 ;[C20] ..
ADDI T1,^D64 ;ADD IN YEAR BASE
IDIVI T1,^D10
LSH T2,2*6
ADDI T3,'0 ' ;[C20] YMM
ADD T2,T3 ;[C20] ..
HRLM T2,7(T4) ;[OK]
ADDI T1,'0'
MOVEM T1,6(T4) ;[OK] COMPLETE DATE
>;END IFE FTOPS20
IFN FTOPS20,<
PUSH P,T4 ;[360] NEEDED BY JSYS
SETO T2, ;[360] CURRENT DATE AND TIME
SETZ T4, ;[360] NOTHING SPECIAL
ODCNV% ;[360] GET IT
HLRZ T3,T3 ;[360] GET DAY
ADDI T3,1 ;[360] START AT 1
IDIVI T3,^D10 ;[360]
LSH T3,6 ;[360] MAKE ROOM
ADDI T4,'00' ;[C20] SIXBIT DAYS IN T3
ADD T3,T4 ;[C20] [360] ..
LSH T3,6 ;[360] FORM 'HH '
POP P,T4 ;[360] GET STORE POINTER
HRRZM T3,7(T4) ;[OK] [360] STORE DAYS
HLRZ T1,T2 ;[360] GET YEAR
HRRZ T3,T2 ;[C20] [360] GET MONTH
ADDI T3,1 ;[C20] ..
IDIVI T1,^D100 ;[360] GET RID OF 1900
MOVE T1,T3 ;[360] MOVE MONTH TO SAFE PLACE
IDIVI T2,^D10 ;[360] GET 2 DIGITS OF YEAR
ADDI T2,'0' ;[360] SIXBITIZE
MOVEM T2,6(T4) ;[OK] [360] STORE ' Y'
IDIVI T1,^D10 ;[360] GET 2 DIGITS OF MONTH
LSH T1,6 ;[360] MAKE ROOM
IOR T1,T2 ;[360] FORM MM
LSH T3,2*6 ;[360] MAKE ROOM
ADDI T1,'000' ;[C20] [360] SIXBITIZE
ADD T3,T1 ;[C20] ..
HRLM T3,7(T4) ;[OK] [360] STORE 'YMM'
>;END IFN FTOPS20
MOVE T1,['PDP10 ']
MOVEM T1,^D10(T4) ;[OK]
MOVEI T1,^D80/6
ADDM T1,FILPTR(F) ;ADVANCE BYTE PTR
MOVN T1,T1
ADDM T1,FILCNT(F)
RETURN
END;
WRTEBC: JRST E$$ELN
WRTBIN==WRTSIX
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTASC) ;WRITE ASCII LABEL
HRRZ T4,FILPTR(F) ;[C20] GET BUFFER ADDRESS
SETZ T2,
SKIPN T3,X.RIB+.RBNAM(P1) ;[OK] [215] GET NAME
JRST E$$NRL
LSHC T2,6 ;SHIFT IN T2
ADD T1,T2 ;[C20] ADD IN
LSH T1,1 ;LEFT JUST
MOVEM T1,0(T4) ;[OK] FIRST WORD
SETZ T1, ;HOLD NAME
$1% SETZ T2,
LSHC T2,6 ;GET NEXT CHAR
LSH T1,7 ;MAKE SPACE
ADDI T2," " ;[C20] ADD IN
ADD T1,T2 ;[C20] ..
TXNN T1,177B7 ;DONE?
JRST $1 ;NOT YET
LSH T1,1 ;LEFT JUSTIFY
MOVEM T1,1(T4) ;[OK] STORE
SETZ T1,
HLLZ T3,X.RIB+.RBEXT(P1) ;[OK] [215] GET EXTENSION
$2% SETZ T2,
LSHC T2,6 ;SHIFT IN
LSH T1,7 ;MAKE SPACE
ADDI T2," " ;[C20] ADD IN
ADD T1,T2 ;[C20] ..
TXNN T1,177B7 ;DONE
JRST $2
LSH T1,1 ;LEFT JUSTIFY
MOVEM T1,2(T4) ;[OK] STORE EXT
MOVE T1,[ASCII / /] ;5 SPACES
MOVEM T1,3(T4) ;[OK]
MOVEM T1,4(T4) ;[OK] MORE SPACES
MOVEM T1,7(T4) ;[OK]
MOVEM T1,^D10(T4) ;[OK]
MOVE T2,[ASCII /PDP10/]
DMOVEM T1,^D11(T4) ;[OK]
MOVEM T1,^D13(T4) ;[OK]
MOVEM T1,^D14(T4) ;[OK]
TRC T1,<BYTE (7) 40,40,40,40,40>^!<BYTE (7) 40,40,40,15,12>
MOVEM T1,^D15(T4) ;[OK] END WITH CR-LF
MOVE T1,X.REEL(P1) ;[OK] [215] GET REEL NUMBER
SETZ T3, ;WHERE TO BUILD ID
$3% IDIVI T1,^D10 ;GET LEAST DIGIT
LSHC T2,-7 ;SHIFT IN
TXNN T3,<BYTE (7) 0,0,0,177> ;GOT 4 CHARS YET
JRST $3 ;NO
LSHC T2,3*7 ;PUT 3 CHARS IN FIRST WORD
LSH T2,1
IFE FTKL10,<
ADD T2,[ASCII / 000/] ;MAKE ASCII
ADD T3,[ASCII /00000/] ;COBOL FILLS WITH 0
>
IFN FTKL10,<
DADD T2,[ASCII / 00000000/]
>
DMOVEM T2,5(T4) ;[OK]
IFE FTOPS20,<
DATE T1, ;GET CURRENT DATE
IDIVI T1,^D31
ADDI T2,1
IDIVI T2,^D10 ;GET DAYS
LSH T2,7
ADDI T3,"00" ;[C20] ASCIIIZE
ADD T2,T3 ;[C20] ..
LSH T2,1+3*7 ;SHIFT OFF BIT 35
IOR T2,[BYTE (7) 0,0,40,40,40]
MOVEM T2,^D9(T4) ;[OK] STORE DAYS
IDIVI T1,^D12 ;GET MONTH
ADDI T2,1
IDIVI T2,^D10
LSH T2,7
ADDI T2,"00" ;[C20] PUT MONTH IN T3
ADD T3,T2 ;[C20] ..
ADDI T1,^D64 ;ADD IN YEAR BASE
IDIVI T1,^D10
LSH T1,7
ADDI T2,"00" ;[C20] YY
ADD T1,T2 ;[C20] ..
LSH T1,2*7+1 ;YY
LSH T3,1 ;MM
>;END IFE FTOPS20
IFN FTOPS20,<
PUSH P,T4 ;[360] NEEDED BY JSYS
SETO T2, ;[360] CURRENT DATE AND TIME
SETZ T4, ;[360] NOTHING SPECIAL
ODCNV% ;[360] GET IT
HLRZ T3,T3 ;[360] GET DAY
ADDI T3,1 ;[360] START AT 1
IDIVI T3,^D10 ;[360]
LSH T3,7 ;[360] MAKE ROOM
ADDI T4,"00" ;[C20] [360] ASCII DAYS IN T3
ADD T3,T4 ;[C20] ..
LSH T3,1+3*7 ;[360] SHIFT OFF BIT 35
IOR T3,[BYTE (7) 0,0,40,40,40] ;[360] PAD WITH SPACES
MOVE T4,0(P) ;[360] GET STORE POINTER
MOVEM T3,9(T4) ;[OK] [360] STORE DAYS
HRRZ T1,T2 ;[C20] [360] GET MONTH
ADDI T1,1 ;[C20] ..
HLRZ T2,T2 ;[360] GET YEAR
IDIVI T2,^D100 ;[360] GET RID OF 1900
IDIVI T3,^D10 ;[360] GET 2 DIGITS OF YEAR
LSH T3,7 ;[360] MAKE SPACE
ADDI T4,"00" ;[C20] [360] ASCII "YY"
ADD T3,T4 ;[C20] ..
IDIVI T1,^D10 ;[360] GET 2 DIGITS OF MONTH
LSH T1,7 ;[360] MAKE ROOM
ADDI T2,"00" ;[C20] [360] FORM MM
ADD T1,T2 ;[C20] ..
LSH T3,2*7+1 ;[360] MAKE ROOM
LSH T1,1 ;[360] LEFT JUSTIFY
POP P,T4 ;[360] GET STORE POINTER
>;END IFN FTOPS20
IOR T1,T3 ; YYMM
TXO T1,ASCII / /
MOVEM T1,8(T4) ;[OK]
MOVEI T1,^D82/5+1
ADDM T1,FILPTR(F)
MOVNI T1,^D82 ;[C08] GET BYTE COUNT
ADDM T1,FILCNT(F)
RETURN
END;
SUBTTL TAPE LABEL ROUTINES -- CHKEND - Check End Labels
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKEND) ;HERE TO CHECK END MAGTAPE LABEL
PUSH P,P1 ;[215] SAVE TEMP FOR X. BLOCK
MOVE P1,FILXBK(F) ;[215] ..
IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
MOVE T1,FILFLG(F) ;[C12] [215] GET TAPE'S FILE FLAGS
TXNE T1,FI.ATO ;[C12] [215] LABELER DOING THE WORK?
JRST $F ;[C12] [215] YES--NO PROBLEM
THEN WE MUST DO IT OURSELVES
IFE FTOPS20,<
HRL T1,FILCHN(F) ;[C19] BUILD FILOP. BLOCK, GET CHANNEL
HRRI T1,.FOCLS ;[C19] GET CLOSE FUNCTION
MOVEM T1,FLPARG+.FOFNC ;[C19] STORE THEM
SETZM FLPARG+.FOIOS ;[C19] NO CLOSE BITS
SETZM FLPARG+.FOLEB ;[C19] NO LOOKUP BLOCK FOR ERRORS
MOVE T1,[XWD .FOIOS+1,FLPARG] ;[C19] DO CLOSE FILOP.
FILOP. T1, ;[C19] ..
JRST ERRFUF ;[C19] FAILED
>
CASE LABEL TYPE OF (STANDARD, OMITTED,NON-STANDARD,DEC,ANSI,IBM)
MOVE T1,X.LABL(P1) ;[OK] [215] GET LABEL TYPE
JRST @[IFIWS <$1,$C,$C,$1,$C,$C>]-1(T1) ;[C20] [C03] [215] CASE BY LABEL TYPE
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
IFN FTOPS20,<
PUSHJ P,STRTIO ;[C03] RESTART I/O
>
JSP T4,GETBUF ;READ THE LABEL
JRST E$$RIE ;SHOULD NOT HAPPEN
SETZM FILCNT(F) ;SO WE IGNORE BLOCK WHEN DONE
HRRZ T2,FILPTR(F) ;[C20] [215] GET LABEL DESIGNATOR
MOVE T2,(T2) ;[C20] ..
CASE MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T1,MODE ;[215] GET MODE OF TAPE
PUSHJ P,@[IFIWS <CHKESX,CHKEAS,E$$ELN,CHKEBN>]-1(T1) ;[C20]
ESAC;
ESAC;
$2% JSP T4,GETBUF ;[C03] GET A BUFFER
JRST $3 ;[C03] EOF, YAY
SETZM FILCNT(F) ;[C03] NOT EOF, NOT INTERESTED
JRST $2 ;[C03] TRY AGAIN
$3% ;[C03]
FI;
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKESX) ;[215] CHECK SIXBIT END LABEL
LSH T2,-^D12 ;[215] SHIFT OUT GARBAGE
IF EOV1 LABEL (FILE IS CONTINUED ON ANOTHER REEL)
CAXE T2,'EOV1' ;[215] LOOK AT JUST DESIGNATOR
JRST $T ;[215] NOT EOV--TRY EOF
THEN REMEMBER FOR LATER
MOVX T1,FI.EOT ;[215] SET UP EOT BIT FOR LATER
ORM T1,FILFLG(F) ;[215] REMEMBER EOT CONDITION PENDING
JRST $F ;[215] NOW GO EAT LABEL
ELSE CHECK IF EOF1 (END-OF-FILE)
CAXE T2,'EOF1' ;[215] LOOK AT JUST DESIGNATOR
JRST E$$LNC ;[215] NO GOOD--TELL USER
SETZM X.REEL(P1) ;[OK] [215] OK--RESET COUNT TO INDICATE NO MORE TAPES
FI;
RETURN ;[C03]
END;
BEGIN
PROCEDURE (PUSHJ P,CHKEAS) ;[215] CHECK ASCII END LABELS
LSH T2,-^D8 ;[215] SHIFT OUT GARBAGE
IF EOV1 LABEL (FILE CONTINUED ON ANOTHER REEL)
CAXE T2,"EOV1" ;[215] LOOK AT JUST DESIGNATOR
JRST $T ;[215] NOT EOV--TRY EOF
THEN REMEMBER FOR LATER
MOVX T1,FI.EOT ;[215] SET UP EOT BIT FOR LATER
ORM T1,FILFLG(F) ;[215] REMEMBER EOT CONDITION PENDING
JRST $F ;[215] NOW GO EAT LABEL
ELSE CHECK IF EOF1 (END-OF-FILE)
CAXE T2,"EOF1" ;[215] LOOK AT JUST DESIGNATOR
JRST E$$LNC ;[215] NO GOOD--TELL USER
SETZM X.REEL(P1) ;[OK] [215] OK--RESET COUNT TO INDICATE NO MORE TAPES
FI;
RETURN ;[C03]
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKEBN) ;[215] CHECK BINARY END LABELS
MOVE T1,T2 ;[215] GET TEMP COPY OF DESIGNATOR
LSH T1,-^D8 ;[215] SET UP TO TRY ASCII
CAXE T1,"EOV1" ;[215] END-OF-VOLUME
CAXN T1,"EOF1" ;[215] OR END-OF-FILE?
PJRST CHKEAS ;[215] YES--MUST BE ASCII
LSH T1,-4 ;[215] NO--THEN TRY FOR SIXBIT
CAXE T1,'EOV1' ;[215] END-OF-VOLUME
CAXN T1,'EOF1' ;[215] OR END-OF-FILE?
PJRST CHKESX ;[215] YES--MUST BE SIXBIT
JRST E$$LNC ;[215] NEITHER--NO GOOD
END;
SUBTTL TAPE LABEL ROUTINES -- WRTEND - Write End-of-file Labels
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTEND)
PUSH P,P1 ;[215] SAVE TEMP FOR X. BLOCK
MOVE P1,FILXBK(F) ;[215] LOAD UP X. BLOCK
JSP T4,PUTBUF ;[C08] FORCE BUFFER OUT
IF TAPE LABEL HANDLER IS NOT DOING THIS TAPE
MOVE T1,FILFLG(F) ;[C12] [215] TEST AUTO-LABELING BIT
TXNE T1,FI.ATO ;[C12] [215] ..
JRST $F ;[C12] [215] NO PROBLEM
THEN WE MUST DO IT OURSELVES
CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI,IBM)
MOVE T1,X.LABL(P1) ;[OK] [215] GET LABEL TYPE
JRST @[IFIWS <$1,$C,$C,$1,$C,$C>]-1(T1) ;[C20] [215] CASE ON LABEL TYPE
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
PUSHJ P,WRTEOF ;[C08] WRITE EOF BEFORE LABEL
IFE FTOPS20,<
MOVX T1,BF.VBR
ANDCAM T1,FILHDR(F) ;CLEAR THE VIRGIN RING BIT
>;END IFE FTOPS20
CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T2,MODE ;[215] GET TAPE'S I/O MODE
MOVE T1,[EXP 'EOF1',"EOF1 ",0,'EOF1']-1(T2) ;[OK] [215] SET UP LABEL
PUSHJ P,@[IFIWS <WRTSIX,WRTASC,WRTEBC,WRTBIN>]-1(T2) ;[C20]
ESAC;
; JRST $C ;[215] FALL THROUGH
ESAC;
FI;
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] ALL DONE
END;
SUBTTL TAPE LABEL ROUTINES -- WRTEOT - Write End-of-tape Labels
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTEOT)
PUSH P,P1 ;[215] SAVE TEMP FOR X. BLOCK
MOVE P1,FILXBK(F) ;[215] LOAD UP X. BLOCK
IF TAPE LABEL HANDLER IS NOT DOING THIS TAPE
MOVE T1,FILFLG(F) ;[C12] [215] TEST AUTO-LABELING BIT
TXNE T1,FI.ATO ;[C12] [215] ..
JRST $F ;[C12] [215] NO PROBLEM
THEN WE MUST DO IT OURSELVES
CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI,IBM)
MOVE T1,X.LABL(P1) ;[OK] [215] GET LABEL TYPE
JRST @[IFIWS <$1,$2,$2,$1,$2,$2>]-1(T1) ;[C20] [215] CASE ON LABEL TYPE
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
PUSHJ P,WRTEOF ;[C08] WRITE EOF BEFORE LABEL
IFE FTOPS20,<
MOVX T1,BF.VBR
ANDCAM T1,FILHDR(F) ;CLEAR THE VIRGIN RING BIT
>;END IFE FTOPS20
CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T2,MODE ;[215] GET TAPE'S I/O MODE
MOVE T1,[EXP 'EOV1',"EOV1 ",0,'EOV1']-1(T2) ;[OK] [215] SET UP LABEL
PUSHJ P,@[IFIWS <WRTSIX,WRTASC,WRTEBC,WRTBIN>]-1(T2) ;[C20]
ESAC;
JSP T4,PUTBUF ;[C08] FORCE BUFFER OUT
PUSHJ P,WRTEOF ;[215] WRITE EOF AFTER LABEL
PUSHJ P,WRTEOF ;[C08] WRITE ANOTHER EOF AFTER LABEL
JRST $C ;[215] DONE
$2% ;[215] OMITTED, NON-STANDARD, ANSI, OR IBM LABELS
E$$MSD: $ERROR (?,MSD,<Multi-reel tape files with other than STANDARD or DEC labels not supported.>)
; JRST $C ;[215] FALL THROUGH
ESAC;
FI;
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] ALL DONE
END;
SUBTTL ENDS. -- Clean Up After SORT
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,ENDS.)
IFE FTOPS20,<
PUSHJ P,RELSPC ;[C13] RELEASE ANY RETAINED SPACE
IFE FTVM,<
PUSHJ P,GETSCN ;[C20] NEED HI-SEG
>>
IFN FTOPS20,<
PUSHJ P,RESET$ ;[335] CLEAN UP MEMORY
>
MOVE T1,INPREC ;[363] NUMBER OF RECORDS SORTED
CAME T1,OUTREC ;[363] SAME NUMBER AS WE OUTPUT?
PUSHJ P,E$$RNI ;[363] RECORD NUMBER INCONSISTENT
PUSHJ P,STATS ;[C20] TYPE STATISTICS, IF NECESSARY
SKIPE FORRET ;[C20] CALLED FROM FORTRAN?
IFN FTOPS20,<
SKIPE TAKFLG ;[C20] AND NOT TAKING?
SKIPA ;[C20] NO
>
JRST FORXIT ;[C20] YES, RETURN TO USER
RETURN
END;
>;END IFE FTFORTRAN
SUBTTL LPURE SEGMENT ERROR MESSAGES
E$$ELN: $ERROR (?,ELN,<EBCDIC tape labels not supported.>)
;**;[473] @E$$ELN + 1L Insert 5 lines GCS 9-Dec-81
E$$PCF: ASCIZ /
?SRTPCF Page / ;[473]
E$$PC1: ASCIZ / creation failed.(PAGE. UUO error / ;[473]
E$$PC2: ASCIZ /)
/ ;[473]
ERRRTI: AOSLE RTRUNC ;ALREADY SEEN MESSAGE
POPJ P, ;YES
PUSH P,T0 ;[C28]
PUSH P,T1
PUSH P,T2
PUSH P,T3 ;[C28]
PUSH P,T4 ;[455] [C28]
$ERROR (%,RTI,<Record truncation on input>)
POP P,T4 ;[455] [C28]
POP P,T3 ;[C28]
POP P,T2
POP P,T1
POP P,T0 ;[C28]
POPJ P,
IFE FTOPS20,<
E$$SAT: $ERROR (?,SAT,<Standard ASCII requires TU70 drive>)
>
IFE FTFORTRAN,<
E$$NRL: $ERROR (?,NRL,<Name required with labeled magtape>)
E$$LNC: $ERROR (?,LNC,<LABEL not correct for >,+)
IFE FTOPS20,<
MOVEI T2,X.RIB(P1) ;[OK] [215] TYPE OFFENDING FILE SPEC
>
IFN FTOPS20,<
HRRZ T2,X.JFN(P1) ;[C20] [C08] $MORE WANTS JFN ON TOPS20
>
$MORE (FILESPEC,T2)
$DIE
ERRROS: PUSH P,T1 ;SAVE BAD REEL #
$ERROR (?,ROS,<Reel no. >,+)
POP P,T1
$MORE (DECIMAL,T1)
$MORE (TEXT,< out of sequence for >,+)
IFE FTOPS20,<
MOVEI T2,X.RIB(P1) ;[OK] [215] PRINT OFFENDING FILE SPEC
>
IFN FTOPS20,<
HRRZ T2,X.JFN(P1) ;[C20]
>
$MORE (FILESPEC,T2)
$DIE
>;END IFE FTFORTRAN