Trailing-Edge
-
PDP-10 Archives
-
AP-D489C-SB
-
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 10-Apr-78
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1975, 1978 BY DIGITAL EQUIPMENT CORPORATION
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 ............................. 5
; 5 INITIALIZATION PROCEDURE ................................. 6
; 6 SCAN CONTROL ROUTINES .................................... 8
; 7 SWITCH HANDLING
; 7.1 /FORMAT:xn.m ...................................... 11
; 8 COLLATING SEQUENCE TABLE ROUTINES ........................ 12
; 9 PSORT.
; 9.1 SORT Initialization Following Command Scanning .... 17
; 9.2 SETMOD - Set Up Recording Mode for SORT ........... 18
; 9.3 KEYEXT - Generate Key Extraction Code ............. 20
; 9.4 Dispatch Tables for Key Extraction ................ 21
; 9.5 KEYGEN - Generate Key Comparison Code ............. 22
; 10 HIGH SEGMENT ERROR MESSAGES .............................. 24
; 11 FATAL ERROR CLEAN-UP ROUTINES ............................ 25
; 12 RELES.
; 12.1 Add Input Record to Tree .......................... 26
; 12.2 End of Input File
; 12.2.1 SORT Case .................................. 28
; 12.2.2 MERGE Case ................................. 29
; 12.2.3 Check End Lables ........................... 30
; 13 MERGE. ................................................... 31
; 14 RETRN.
; 14.1 End of Output File ................................ 32
; 14.2 MSTEOT - EOT Detected on Output Tape .............. 33
; 14.3 RETRNM - Return Record From First-pass Merge Files 34
; 15 TAPE LABEL ROUTINES
; 15.1 CHKLBL - Check Header Labels ...................... 35
; 15.2 WRTLBL - Write Header Labels ...................... 39
; 15.3 CHKEND - Check End Labels ......................... 42
; 15.4 WRTEND - Write End-of-file Labels ................. 45
; 15.5 WRTEOT - Write End-of-tape Labels ................. 46
; 16 ENDS.
; 16.1 Clean Up After SORT ............................... 47
; 17 TYPE-OUT ROUTINES
; 17.1 Floating-point Number ............................. 48
; 18 LOW SEGMENT ERROR MESSAGES ............................... 49
SUBTTL DEFINITIONS -- Flags
LOW.SZ==261+100 ;SIZE OF FOROTS'S DATA BASE
FRE.DY==101 ;OFFSET OF FREE CORE LIST
SA.ADR==253 ;OFFSET, STARTING ADR OF CALLER
FRE.SZ==200 ;SIZE OF FREE MEMORY LIST
IFN FTFORTRAN,< EXTERN DEC.,IOLST.>
IFE FTFORTRAN,<
LOC 137
EXP V%SORT
RELOC
;DEFINITIONS FROM FORPRM
FOROT%==400010
DEC.==FOROT%+12
IOLST.==FOROT%+15
IFE FTOPS20,<FUNCT.==0> ;TO KEEP MACRO HAPPY
>;END IFE FTFORTRAN
DEFINE COMPARE (R,J)<
JSP P4,@.CMPAR
>
IF1,<
DEFINE $JRST$ <BLOCK 1> ;KEEP MACRO HAPPY
>
SUBTTL DEFINITIONS -- Low Segment Data
SEGMENT LOW
OFFSET: BLOCK 1 ;ENTRY OFFSET
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
IFN FTCOL,<
COLSW: BLOCK 1 ;THIS IS A COLLATING SEQUENCE FILE SPEC
;FORM= FLAGS1B12,27B17,LABEL ADDRSSB35
COLCHN: BLOCK 1 ;CHANNEL IN THE AC FIELD FOR READING
COLPTR: BLOCK 4 ;POINTER TO INPUT BUFFER FOR ALT COL SEQ
>
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 ;REWIND BEFORE USE
F.UNL:! BLOCK 1 ;UNLOAD AFTER USE
F.FMT:! BLOCK 0 ;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
CPUTIM: BLOCK 1
ORGTIM: BLOCK 1
SUMTMP: BLOCK 1 ;TOTAL PAGES WRITTEN TO TMP FILES
RCBTOT: BLOCK 1 ;NUMBER OF RECORDS IN MEMORY FOR SORT PHASE
CORSIZ: BLOCK 1 ;SIZE IF /CORE SEEN
ALIGN: BLOCK 1 ;+1 IF OUTPUT TO BE WORD ALIGNED (ASCII)
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
RTRUNC: BLOCK 1 ;-1 IF TRUNCATION MESSAGE ALREADY TYPED
CMPCNT: BLOCK 1
.CMPAR: BLOCK 1 ;POINTER TO COMPARE CODE SEQUENCES
EXTRCT: BLOCK 1 ;POINTER TO 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
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.
HISIZE: BLOCK 1 ;SIZE OF HIGH SEGMENT
MXDVSZ: BLOCK 1 ;MAX. OF I.DVSZ FOR ALL INPUT FILES
IFN FTCOL,<
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
>;END IFN FTCOL
EZCOR==.-1 ;END OF DATA AREA TO ZERO
LOSIZE==.JBREL##
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 START ADDRESS AND OUTER LOOP
IFE FTFORTRAN,<
SEGMENT HIGH
BEGIN
PROCEDURE (,START)
PORTAL .+2 ;NORNAL ENTRY
PORTAL .+2 ;CCL ENTRY
TDZA P1,P1 ;NORMAL OFFSET
MOVEI P1,1 ;CCL OFFSET
MOVEM P1,OFFSET ;STORE ENTRY OFFSET
IFN FTOPS20,<
RESET ;THE KNOWN UNIVERSE
MOVE T1,[SIXBIT /SORTV4/]
MOVE T2,T1
SETSN ;COLLECT PAGING STATISTICS
SETZM FORTPP ;DID NOT GET CALLED BY FORTRAN
>
IFE FTOPS20,<
MOVEM .SGNAM,RUNNAM ;SAVE INITIAL ACCS FOR RUN UUO
MOVEM .SGPPN,RUNDIR
MOVEM .SGDEV,RUNDEV
>
JSP P4,INITIALIZE ;INITIALIZE
IFE FTOPS20,<
MOVE T1,.ISBLK ;DATA BLOCK FOR ISCAN
PUSHJ P,.ISCAN## ;INITIALIZE SCANNER
JRST LOOP ;GO TO LOW SEGMENT
>
END;
SEGMENT LOW10
>;END IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,LOOP)
MOVE T1,[IOWD 100,CSTACK]
MOVEM T1,CORSTK ;INIT MEMORY ALLOCATION STACK
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
IFE FTOPS20!FTFORTRAN,<
JSR GETSCN ;GET HIGH SEG AGAIN
>
IFN FTFORTRAN,<
SKIPG ATSFLG ;
RETURN
>
JSP P4,INITIALIZE ;DATA
JRST $B ;GET NEXT LINE
END;
SEGMENT HIGH
SUBTTL INITIALIZATION PROCEDURE
BEGIN
PROCEDURE (JSP P4,INITIALIZE)
IFE FTFORTRAN,<
IFN FTOPS20,<
SKIPN FORTPP ;IF TOPS-20 FORTRAN SORT, WE HAVE STACK
>
MOVE P,[IOWD PDLEN,STACK] ;SET UP STACK
>
JSP T4,ZDATA ;[134] ZERO COMMON DATA AREAS
JSP T4,CPUTST ;[134] MAKE SURE IF CPU OK
IFE FTOPS20,<
IFE FTFORTRAN,<
RESET ;DO RESET AFTER CALL TO CPUTST
BEGIN ;GET WHERE WE REALLY CAME FROM
HRROI T1,.GTRDV
GETTAB T1, ;GET DEVICE
JRST $E ;PRE 6.03
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
MOVE T1,.JBREL## ;GET INITIAL .JBREL
MOVEM T1,RUNCOR ;SO WE CAN CALCULATE MEMORY REQUIRED
>;END IFE FTOPS20
IFN FTOPS20,<
MOVE T1,.JBFF## ;GET FIRST FREE
MOVEI T1,400000 ;*** TEMPORARY ***
HRRZM T1,MAXFRE ;MAX LOC TO BE USED
SETO T1, ;GET JOB INFO FOR THIS JOB
HRROI T2,T2 ;ONE WORD RETURNED IN T2
MOVX T3,.JIRS ;GET DEFAULT MTA RECORD SIZE
GETJI ; ..
ERJMP [$ERROR (?,GJF,<GETJI failure at initialization time>)]
MOVEM T2,DFMTRS ;SAVE DEFAULT MTA RECORD SIZE
>
BEGIN ;SETUP INITIAL VALUES
MOVSI T1,-MX.TMP ;NO. OF POSSIBLE TEMP STRS
MOVEM T1,TCBIDX ;...
MOVEI T1,MX.TMP ;USE ALL POSSIBLE TEMP FILES
MOVEM T1,MAXTMP ;IF STAND-ALONE SORT
SETOM P.BLKF ;BLOCKING FACTOR
SETOM P.VARF ;VARIABLE/FIXED RECORDS
SETOM P.INDU ;[143] /INDUSTRY
IFN FTFORTRAN,<
PUSHJ P,ALCHN ;GET A CHANNEL FOR FORTRAN
>
SETOM RTRUNC ;FOR TRUNCATION MESSAGE
END;
BEGIN
;DETERMINE AND RECORD CPU TIME AND TIME OF DAY AT START OF SORT
IFE FTOPS20,<
SETZ T1, ;SELECT CURRENT JOB
RUNTIM T1,
>
IFN FTOPS20,<
HRROI T1,-5 ;WHOLE JOB
RUNTM
>
MOVEM T1,CPUTIM ;INITIAL CPU TIME IN MS
IFE FTOPS20,<
MSTIME T1,
>
IFN FTOPS20,<
TIME
>
MOVEM T1,ORGTIM ;INITIAL TIME OF DAY IN MS
PUSHJ P,GETJOB ;GET JOB NUMBER
END;
RETURN
END;
SUBTTL SCAN CONTROL ROUTINES
IFE FTFORTRAN,<
BEGIN
PROCEDURE (PUSHJ P,CLRFIL)
SETOM TEMPSW ;RESET NOT SEEN FLAG
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
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
>
IFN FTCOL,<
SETZM COLSW
>
SETOM CORSIZ
SETOM ALIGN
SETOM RECORD
SETOM MRGSW
SETOM WSCSW
SETOM NUMRCB
SETOM ERRADR
SETOM FERCOD
; 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.UNL
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
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
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,CLRSTK) ;ROUTINE TO CLEAR STICKY DEFAULTS
;JUST A NO-OP FOR NOW
RETURN
END;
SUBTTL SWITCH HANDLING -- /FORMAT:xn.m
;STILL IN IFE FTFORTRAN
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) ;ONLY ONE /FORMAT PER /KEY
JRST E$$OOF ;COMPLAIN
MOVE T2,.NMUL ;GET FORMAT ARGUMENT
MOVE T3,.NMUL+1 ;
DMOVEM T2,KY.FMT(T1) ;TO KEY BLOCK
MOVX T1,RM.FPA ;[203] MODE IS FLOATING POINT ASCII
IORM T1,MODE ;
IORM T1,MODEM ;REMEMBER TO GETSEG DECODE
MOVE T0,[POINT 6,.NMUL] ;POINT AT FORMAT TYPE
ILDB T4,T0 ;GET FORMAT TYPE
CAIL T4,'D' ;
CAILE T4,'G' ;
JRST E$$FSA ;MUST BE D, E, F OR G
ILDB T4,T0 ;GET FIRST WIDTH DIGIT
CAIL T4,'0' ;
CAILE T4,'9' ;
JRST E$$FSA ;NOT A DIGIT
ILDB T3,T0 ;GET SECOND DIGIT
JUMPE T3,$1 ;SKIP IF NULL
CAIN T3,'.' ; OR A PERIOD
JRST $1 ;
CAIL T3,'0' ;
CAILE T3,'9' ;
JRST E$$FSA ;NOT A DIGIT
ILDB T3,T0 ;GET NEXT
LDB T4,[POINT 10,.NMUL,17];GET THE TWO DIGIT WIDTH
$1% PUSH P,T4 ;SAVE FOR RANGE CHECK
JUMPE T3,$2 ;NULL SO NO DECIMAL PLACES
CAIE T3,'.' ;1 OR 2 DIGITS PLUS "."?
JRST E$$FSA ;NO, COMPLAIN
ILDB T4,T0 ;GET FIRST DIGIT
CAIL T4,'0' ;
CAILE T4,'9' ;
JRST E$$FSA ;NOT A DIGIT
ILDB T3,T0 ;GET SECOND DIGIT
JUMPE T3,$2 ;SKIP IF NULL
CAIL T3,'0' ;
CAILE T3,'9' ;
JRST E$$FSA ;NOT A DIGIT
ILDB T2,T0 ;GET TERMINATOR
JUMPN T2,E$$FSA ;MUST BE A NULL
LSH T4,6 ;MAKE ROOM FOR LOW ORDER DIGIT
XORI T4,'0 '(T3) ;GET IT AND ZERO BIT25
$2% POP P,T2 ;GET TOTAL WIDTH
CAMGE T2,T4 ;SKIP IF WIDTH GE TO DECIMAL PLACES
JRST E$$FSA ;OOPS - COMPLAIN
LDB T0,[POINT 4,T2,29] ;CONVERT SIXBIT WIDTH TO BINARY
IMULI T0,^D10 ;
LDB T3,[POINT 4,T2,35]
ADD T0,T3 ;
MOVE T3,LSTKEY ;INDEX TO LAST KEY BLOCK
CAME T0,KY.SIZ(T3) ;MUST EQUAL KEY SIZE
JRST E$$FSA ;
RETURN
END;
>;END IFE FTFORTRAN
SUBTTL COLLATING SEQUENCE TABLE ROUTINES
IFN FTCOL,<
BEGIN
PROCEDURE (PUSHJ P,CHKCOL)
HRRZ T1,COLSW ;GET INDEX
CASE COLLATING SEQUENCE OF (ASCII,EBCDIC,FILESPEC,LITERAL,ADDRESS)
JRST @[EXP $1,$2,COLTRX,COLTRL,COLTRA]-1(T1) ;DISPATCH ON KEY WORD
$1% ;ASCII
CASE I/O MODE OF (ASCII,SIXBIT,EBCDIC,BINARY)
HRRZ T1,MODE
MOVE T1,[EXP 0,0,ALP.97,0]-1(T1)
ESAC;
JRST $C
$2% ;EBCDIC
CASE I/O MODE OF (ASCII,SIXBIT,EBCDIC,BINARY)
HRRZ T1,MODE
MOVE T1,[EXP ALP.69,ALP.79,0,0]-1(T1)
ESAC;
; JRST $C
ESAC;
MOVEM T1,COLSW ;STORE POINTER
RETURN
END;
;STILL IN IFN FTCOL
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
; 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
MOVEI P4,(T1) ;COPY THE TABLE ADDRESS
MOVEI P3,(T2) ;COPY NEXT CHARACTER ROUTINE
MOVE T1,[XWD 707070,707070]
MOVEM T1,(P4) ;INITIALIZE THE TABLE
HRLZI T1,(P4) ;MAKE A BLT POINTER
HRRI T1,1(P4)
BLT T1,177(P4) ;SET THE TABLE TO 707070,707070
SETZ P1, ;START AT COL. INDEX =0
$1% TLZE P1,(COL.MI) ;PENDING MINUS SIGN
JRST $6 ;YES,
TLZE P1,(COL.EQ) ;PENDING EQUAL SIGN
JRST $3 ;YES
PUSHJ P,(P3) ;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
CAIN T1,"""" ;IS IT A QUOTE
JRST $2 ;YES, PROCESS A QUOTED STRING
CAIE T1,"," ;SEPERATOR
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
AOJA P1,$1 ;UPDATE THE INDEX AND TRY AGAIN
JRST $1 ;GET THE NEXT CHARACTER
$2% PUSHJ P,(P3) ;GET THE NEXT CHARACTER
POPJ P, ;END OF DATA WITH NO ENDING QUOTE
CAIN T1,"""" ;IS THE A QUOTE IE ENDING
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) ;GET THE NEXT CHARACTER
POPJ P, ;ILLEGAL SEQUENCE
CAIE T1,"""" ;A SRING
JRST $5 ;NO
$4% PUSHJ P,(P3) ;GET THE NEXT CHARACTER OF THE STRING
POPJ P, ;ILLEGAL SEQUENCE
CAIN T1,"""" ;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) ;GET THE SECOND VALUE
POPJ P, ;ILLEGAL STRING
CAIE T1,"""" ;QUOTED STRING
JRST $7 ;NOPE
PUSHJ P,(P3) ;YES, GET THE CHARACTER
POPJ P, ;ILLEGAL STRING
PUSH P,T1 ;SAVE THE CHARACTER
PUSHJ P,(P3) ;GET THE NEXT CHARACTER
CAIA ;SKIP ON ERROR
CAIE T1,"""" ;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% MOVEI T4,(T1) ;SAVE THE ENDING CHARACTER
$9% AOS T1,P2 ;INCREMENT LAST CHARACTER STORED
CAMLE T1,T4 ;CHECK THE RANGE
JRST $1 ;END OF RANGE
PUSHJ P,BLDCOS ;STORE IN THE TABLE
AOS P1 ;INCREMENT THE INDEX
JRST $9 ;CONTINUE UNTIL EQUAL
END;
;STILL IN IFN FTCOL
BEGIN
PROCEDURE (PUSHJ P,BLDCOS)
;SUBROUTINE BLDCOS - STORE THE CURRENT CHARACTER IN THE TABLE
;CALL PUSHJ P,LDCOS
;RETURN CPOPJ
MOVEI P2,(T1) ;SAVE THE CHARACTER
IDIVI T1,2 ;GET THE TABLE INDEX AND WHICH HALF
ADDI T1,(P4) ;TABLE OFFSET
XCT [HRLM P1,(T1) ;STORE IN THELEFT HALF (EVEN)
HRRM P1,(T1)](T2) ;STORE IN THE RIGHT HALF (ODD)
RETURN
END;
;SUBROUTINE BLDCOE - WILL IN THE MISSING ELEMNET OF THE TABLE
;CALL PJRST BLDCOE WHIN END OF THE COLLATING STRING
;RETURN CPOPJ1
BEGIN
PROCEDURE (PUSHJ P,BLDCOE)
MOVSI T4,-200 ;SIZE OF THE TABLE
HRRI T4,(P4) ;ADDRESS OF THE TABLE
$1% HLRZ T1,(T4) ;GET THE LEFT HALF ENTRY
CAIE T1,707070 ;CHECK FOR A NULL ENTRY
JRST $2 ;NO, IT WAS USED
HRLM P1,(T4) ;STORE THE CURRECT INDEX
AOS P1 ;INCREMENT THE INDEX
$2% HRRZ T1,(T4) ;GE THE RIGHT HALF
CAIE T1,707070 ;IS IT EMPTY
JRST $3 ;NO
HRRM P1,(T4) ;YES, SET THE INDEX
AOS P1 ;STEP THE INDEX
$3% AOBJN T4,$1 ;CONTINUE THRU THE TABLE
AOS (P) ;SKIP RETURN
RETURN
END;
;STILL IN IFN FTCOL
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) ;GET THE CHARACTER
JRST $2 ;END OF INPUT
$1% CAIN T1,"=" ;CHECK FOR SEPERATORS
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
CAIL T1,"0" ;DID A DIGIT ARRIVE
CAILE T1,"7"
POPJ P, ;ERROR ILLEGAL SEPERATOR
LSH T2,3 ;YES, MAKE ROOM FOR THE DIGITS
ADDI T2,-<"0">(T1) ;ACCUMLATE THE SUM
JRST $5 ;GET THE NEXT DIGITS
$3% TLOA P1,(COL.EQ)
$4% TLO P1,(COL.MI)
$2% MOVE T1,T2 ;COPY THE RESULT
AOS (P) ;SKIP RETURN
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,COLTRL)
MOVE T1,[POINT 7,COLITB] ;FORM BYTE POINTER
MOVEM T1,COLPTR+2
MOVEI T1,COLBUF
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)
MOVE T1,COLBUF ;GET ADDRESS OF USERS TABLE
HRLI T1,(POINT 7,) ;FORM BYTE POINTER
MOVEM T1,COLPTR+2
MOVEI T1,COLBUF
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)
ILDB T1,COLPTR+2 ;GET A CHAR
JUMPE T1,CPOPJ ;STOP ON NULL
CAIGE T1," " ;IGNORE CONTROL CHAR
JRST $B
AOS (P) ;SKIP RETURN
RETURN
END;
>;END IFN FTCOL
SUBTTL PSORT. -- SORT Initialization Following Command Scanning
BEGIN
PROCEDURE (PUSHJ P,PSORT.)
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) ;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
IFN FTCOL,<
SKIPE COLSW ;COLLATING SWITCH SEEN?
PUSHJ P,CHKCOL ;YES, SEE WHAT IT WAS
>
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
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
IFE FTFORTRAN,<
IF S/A SORT & FORTRAN FLOATING-POINT ASCII WAS SPECIFIED
MOVE T1,MODEM ;GET MASK OF ALL MODE SWITCHES TYPED
IFN FTOPS20,<
SKIPN FORTPP ;IGNORE IF CALLED BY FORTRAN
>
TXNN T1,RM.FPA ;FORTRAN FLOATING-POINT ASCII?
JRST $F ;NO--SKIP THIS
THEN BUILD A LOW SEGMENT DATA BASE FOR FOROTS
MOVX T1,FRE.SZ+LOW.SZ;STATIC AREA + JUST ENOUGH FOR US
PUSHJ P,GETSPC ;GO ALLOCATE THAT MUCH
JRST E$$NEC ;NOT ENUF MEMORY
HRRM T1,.JBOPS## ;STORE WHERE FOROTS LOOKS FOR IT
MOVEI T2,LOW.SZ(T1) ;BUILD FREE MEMORY LIST WITH 1 BLOCK
MOVEM T2,FRE.DY(T1) ; ..
MOVSI T2,FRE.SZ ;LENGTH OF THIS BLOCK
MOVEM T2,LOW.SZ(T1) ;STORE AT BEGINNING OF BLOCK
IFN FTOPS20,<
MOVEI T2,ENTVEC ;GET ADDR OF CALLING ROUTINE FOR TRACE
>
IFE FTOPS20,<
MOVEI T2,START ;...
>
MOVEM T2,SA.ADR(T1) ; ..
FI;
>;END IFE FTFORTRAN
MOVX T1,2000 ;PLENTY TO BUILD EXTRACT AND COMPARE CODE
PUSHJ P,GETSPC ;GO ALLOCATE IT
JRST E$$NEC ;FAILED
HRRZM T1,EXTRCT ;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
ADD T1,XTRWRD ;ACCOUNT FOR EXTRACTED KEYS
MOVEM T1,MAXKEY ;STORE BACK FOR GTTREC
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;
PJRST CHKCOR ;CHECK AND SET MEMORY SIZE, GOTO LOSEG
END;
SUBTTL PSORT. -- SETMOD - Set Up Recording Mode for SORT
BEGIN
PROCEDURE (PUSHJ P,SETMOD)
HLLZ U,MODEM ;GET MASK OF ALL MODE BITS
IF RECORDING MODE IS BINARY AND NOT FORTRAN
TXNN U,RM.FOR ;FORTRAN BINARY IS OK
TXNN U,RM.BIN ;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 T1,[POINT 3,U,^L<RM.EBC>] ;GET ASCII/SIXBIT/EBCDIC SWITCH
JRST @.+1(T1) ;DISPATCH
SETMU ;UNDEFINED
SETME ;EBCDIC
SETMS ;SIXBIT
E$$MSC ;ERROR
SETMA ;ASCII
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
SETMU: TXNE U,RM.BIN ;BINARY ONLY?
JRST SETMB ;YES
TXNN U,RM.COM!RM.PAC ;COMPUTATIONAL?
JRST SETMA ;NO, SO USE ASCII BY DEFAULT
TXNE U,RM.PAC ;COMP-3?
JRST SETME ;YES, EBCDIC BY DEFAULT
SETMS: TXNE U,RM.PAC ;/SIX /PAC
JRST E$$MSC ;ERROR
HRRI U,MODSIXBIT ;SIXBIT
TXNN U,RM.BIN ;[203] UNLESS FILE IS ALREADY BINARY,
HRRZM U,P.VARF ;[105] FORCE SIXBIT TO BE VARIABLE
JRST RETMOD
SETMA: TXNE U,RM.PAC ;/ASC /PAC ?
JRST E$$MSC ;ERROR
MOVX T1,RM.ASC ;TURN ON ASCII BIT INCASE BY DEFAULT
IORM T1,MODE ;AND STORE BACK IN MODE
HRRI U,MODASCII ;ASCII
SKIPGE P.VARF ;DID USER SPECIFY FIXED LENGTH
HRRZM U,P.VARF ;[105] NO, ASSUME VARIABLE SIZE
TXNE U,RM.FOR ;FORTRAN ASCII?
HRRZM U,ALIGN ;[105] YES, FORCE WORD ALIGNMENT
JRST RETMOD
SETME: HRRI U,MODEBCDIC
JRST RETMOD
SETMB: SKIPGE P.VARF ;DID USER SPECIFY FIXED LENGTH
HRRZM U,P.VARF ;[105] NO, ASSUME VARIABLE SIZE
HRRI U,MODBINARY
; 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 U,RM.BIN ;[201] LEAVE MODE ALONE UNLESS /BINARY
THEN I/O MODE IS BINARY
HRRI U,MODBINARY ;[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
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,JMODES)
;ENTER WITH
;J = MODES + INDEX
;RETURN WITH
;J = TYPE INDEX
MOVE T1,J
HLLZ J,J ;LEAVE ROOM FOR NEW INDEX
JRST @.(T1) ;DISPATCH
SETKS ;SIXBIT
SETKA ;ASCII
SETKE ;EBCDIC
SETKB ;BINARY
SETKS: LDB T1,[POINT 3,J,^L<RM.NUM>] ;GET NEXT BITS
JRST @.+1(T1) ;DISPATCH
SETMSU ;UNDEFINED
SETMSN ;NUMERIC
SETMSC ;COMPUTATIONAL
E$$MSC ;ERROR
SETMSA ;ALPHANUMERIC
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
SETMSU: TXNN J,RM.SGN!RM.UNS ;SIGN SPECIFIED?
JRST SETMSA ;NO, ALPHANUMERIC BY DEFAULT
SETMSN: TXNN J,RM.UNS ;SPECIFICALLY UNSIGNED?
TROA J,IX.NSS ;NO, NUMERIC SIGNED SIXBIT
HRRI J,IX.NUS ;YES, NUMERIC UNSIGNED SIXBIT
RETURN
SETMSC: TXNN J,RM.UNS ;SPECIFICALLY UNSIGNED?
TROA J,IX.CSS ;NO, COMPUTATIONAL SIGNED SIXBIT
HRRI J,IX.CUS ;YES, COMPUTATIONAL UNSIGNED SIXBIT
RETURN
SETKA: LDB T1,[POINT 3,J,^L<RM.NUM>] ;GET NEXT BITS
JRST @.+1(T1) ;DISPATCH
SETMAU ;UNDEFINED
SETMAN ;NUMERIC
SETMAC ;COMPUTATIONAL
E$$MSC ;ERROR
SETMAA ;ALPHANUMERIC
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
SETMAU: TXNE J,RM.FPA ;FORTRAN FLOATING POINT ASCII?
JRST SETMAF ;YES
TXNN J,RM.SGN!RM.UNS ;SIGNED?
JRST SETMAA ;NO, ALPHANUMERIC BY DEFAULT
SETMAN: TXNN J,RM.UNS ;SPECIFICALLY SIGNED?
TROA J,IX.NSA ;NO, NUMERIC SIGNED ASCII
HRRI J,IX.NUA ;YES, NUMERIC UNSIGNED ASCII
RETURN
SETMAC: TXNN J,RM.UNS ;SPECIFICALLY SIGNED?
TROA J,IX.CSA ;NO, COMPUTATIONAL SIGNED ASCII
HRRI J,IX.CUA ;YES, COMPUTATIONAL UNSIGNED ASCII
RETURN
SETKE: LDB T1,[POINT 4,J,^L<RM.PAC>] ;GET NEXT BITS
JRST @.+1(T1) ;DISPATCH
SETMEU ;UNDEFINED
SETMEP ;COMP-3 PACKED
SETMEN ;NUMERIC
SETMEP ;NUMERIC & COMP-3
SETMEC ;COMPUTATIONAL
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ALPHANUMERIC
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
E$$MSC ;ERROR
SETMEU: TXNN J,RM.SGN!RM.UNS ;SIGNED?
JRST SETMEA ;NO, ALPHANUMERIC BY DEFAULT
SETMEN: TXNN J,RM.UNS ;SPECIFICALLY UNSIGNED?
TROA J,IX.NSE ;NO, NUMERIC SIGNED EBCDIC
HRRI J,IX.NUE ;YES, NUMERIC UNSIGNED EBCDIC
RETURN
SETMEC: TXNN J,RM.UNS ;SPECIFICALLY UNSIGNED?
TROA J,IX.CSE ;NO, COMPUTATIONAL SIGNED EBCDIC
HRRI J,IX.CUE ;YES, COMPUTATIONAL UNSIGNED EBCDIC
RETURN
SETMEA: HRRI J,IX.ALE ;ALPHANUMERIC
RETURN
SETMEP: TXNN J,RM.UNS ;SPECIFICALLY UNSIGNED?
TROA J,IX.C3S ;NO, COMP-3 SIGNED
HRRI J,IX.C3U ;YES, COMP-3 UNSIGNED
RETURN
SETMAA: TROA J,IX.ALA ;ALPHANUMERIC LOGICAL ASCII
SETMSA: HRRI J,IX.ALS ;ALPHANUMERIC LOGICAL SIXBIT
RETURN
SETKB: TXNE J,RM.FPA ;FORTRAN FLOATING POINT ASCII?
JRST SETMAF ;YES
TXNN J,RM.UNS ;SPECIFICALLY UNSIGNED?
TROA J,IX.CSB ;NO, SIGNED BINARY
HRRI J,IX.CUB ;YES, UNSIGNED BINARY
RETURN
SETMAF: HRRI J,IX.FPA ;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,EXTRCT ;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 J,KY.MOD(R) ;GET THIS MODE
IOR J,MODE ;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 J,RM.NUM!RM.PAC
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 J,RM.COM!RM.PAC ;COMP IS SPECIAL
JRST $T
THEN CALCULATE NO. OF WORDS FROM DIGITS GIVEN
IF COMP
TXNN J,RM.COM
JRST $T
THEN
MOVE T3,MODE
ADD T2,[EXP 6,5,4,1]-1(T3) ;ASSUME SINGLE PRECISION
CAILE P2,^D10 ;IS IT
ADD T2,[EXP 6,5,4,1]-1(T3) ;NO
JRST $F
ELSE MUST BE COMP-3
MOVEI T1,2(P2) ;NO. OF DIGITS + SIGN + ROUNDING
LSH T1,-1 ;CUT IN HALF
ADDI T2,(T1) ;NEW LAST BYTE
FI;
JRST $F
ELSE
ADDI T2,(P2) ;LAST BYTE
FI;
CAMLE T2,RECORD ;SEE IF IN RANGE
JRST E$$KOR ;NO
IFN FTKL10,<
PUSHJ P,@K.KLX(J)
>
IFE FTKL10,<
MOVE T1,CPU ;GET CPU TYPE (KL USES BIS)
PUSHJ P,@[EXP <Z @K.EXT(J)>,<Z @K.EXT(J)>,<Z @K.KLX(J)>](T1) ;AND PROCESS IT
>
SKIPE R,KY.NXT(R) ;NEXT KEY
JRST $B ;MORE TO DO
END;
$JRST$ ;NO, ALL DONE
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 J,KY.MOD(R) ;GET THIS MODE
IOR J,MODE ;ADD DEFAULTS
PUSHJ P,JMODES ;GET KEY MODE INDEX
PUSHJ P,@K.ADJ(J) ;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,EXTRCT
FOR EACH KEY DO
BEGIN
MOVE J,KY.MOD(R) ;GET THIS MODE
IOR J,MODE ;ADD DEFAULTS
PUSHJ P,JMODES ;GET KEY MODE INDEX
XCT K.ADX(J) ;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>,<CPOPJ>
IFIDN <B><A>,<AA'EXT>
IFN FTCOL,<
IFIDN <B><C>,<AA'EXT>
>
IFE FTCOL,<
IFIDN <B><C>,<CPOPJ>
>
>
K.EXT: IXMODE
DEFINE XX(AA,B)<
IFIDN <B><N>,<CPOPJ>
IFIDN <B><A>,<AA'KLX>
IFN FTCOL,<
IFIDN <B><C>,<AA'EXT>
>
IFE FTCOL,<
IFIDN <B><C>,<CPOPJ>
>
>
K.KLX: IXMODE
DEFINE XX(AA,B)<
IFIDN <B><A>,<CPOPJ1>
IFIDN <B><N>,<CPOPJ>
IFIDN <B><C>,<CPOPJC>
>
K.ADJ: IXMODE
IFN FTCOL,<
CPOPJC: SKIPE COLSW ;CONDITIONAL COLLATING SEQUENCE
AOS (P)
POPJ P,
>
IFE FTCOL,<CPOPJC==CPOPJ>
DEFINE XX(AA,B)<
IFIDN <B><A>,<PUSHJ P,AA'ADX>
IFIDN <B><N>,<NOOP>
IFE FTCOL,<
IFIDN <B><C>,<NOOP>
>
IFN FTCOL,<
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 J,KY.MOD(R) ;GET THIS MODE
IOR J,MODE ;PLUS DEFAULTS
PUSHJ P,JMODES ;GET INDEX
DMOVE P1,KY.INI(R) ;GET ORIGIN & LENGTH
MOVE S,KY.ORD(R) ;GET ORDER
PUSHJ P,KEYADJ ;SEE IF NEXT KEY IS ADJACENT
PUSHJ P,@K.GEN(J) ;AND PROCESS IT
SKIPE R,KY.NXT(R) ;MORE TO DO
JRST $B ;YES
END;
$JRST$ ;NO, ALL DONE
MOVEM U,TREORG ;MARK END OF COMPAR CODE
IFN FTOPS20,<
SKIPN FORTPP ;CAN'T TOUCH .JBFF IF FORTRAN
>
IFE FTFORTRAN,<
MOVEM U,.JBFF ;RESET FREE SPACE
>
RETURN
END;
DEFINE XX(AA,B)<
IFIDN <B><A>,<CNVGEN>
IFIDN <B><C>,<AA'GEN>
IFIDN <B><N>,<AA'GEN>
>
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
SKIPE T1,KY.NXT(R) ;ANY MORE TO DO?
CAME S,KY.ORD(T1) ;YES, CHECK FOR SAME ORDER
$1% RETURN ;GIVE UP
MOVE T2,KY.INI(T1) ;GET ORIGIN OF THIS KEY
SUBI T2,0(P2) ;SUBTRACT LENGTH OF PREVIOUS
CAIE T2,(P1) ;SAME ORIGIN?
RETURN ;NO
PUSH P,J ;YES, NOW TEST MODE
MOVE J,KY.MOD(T1)
IOR J,MODE
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) ;INCREMENT SIZE
MOVEM P2,KY.SIZ(R) ;REMEMBER THAT WE INCREMENTED
MOVE T2,KY.NXT(T1)
MOVEM T2,KY.NXT(R) ;REMOVE KEY
JRST $B ;TRY AGAIN
END;
SUBTTL HIGH 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$$DMS: $ERROR (?,DMS,<Data mode not supported>)
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>)
IFN FTCOL,<
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$$CFA: $ERROR (?,CFA,<Collating sequence input file not available or does not exist.>)
E$$CFE: $ERROR (?,CFE,<Collating sequence input file error.>)
E$$ICS: $ERROR (?,ICS,<Illegal user supplied collating sequence>)
>
SUBTTL FATAL ERROR CLEAN-UP ROUTINES
SEGMENT LOW10
BEGIN
PROCEDURE (,DIE) ;HERE ON FATAL ERROR
$CRLF ;CLOSE OUT LINE
IFE FTOPS20,<
IFE FTFORTRAN,<
JRST RSTART ;TRY AGAIN
>
IFN FTFORTRAN,<
MOVE P,SAVEP ;RESTORE ORIGINAL PP
IF USERS WANTS CONTROL
SKIPG T1,ERRADR ;GET RETURN ADDRESS
JRST $T
THEN RETURN TO FORTRAN
HRRM T1,0(P) ;SET USERS RETURN ADDRESS
POPJ P, ;RETURN TO FORTRAN
ELSE DO FORTRAN EXIT
MOVEI L,1+[EXP 0,0]
PUSHJ P,EXIT.##
HALT
>
>
IFN FTOPS20,<
SKIPE TAKFLG ;ARE WE TAKING FROM A FILE?
CALL TAKEX ;YES, CLOSE TAKE SOURCE AND LOG FILES
CALL ERSET% ;CLEAN UP THE MESS
SKIPE FORTPP ;CALLED FROM FORTRAN?
JRST FORERR ;YES
MOVE T1,OFFSET ;GET ENTRY OFFSET
JRST START(T1) ;AND TRY AGAIN
>
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 ;[215] GET AND REMOVE FIRST FILE'S X. BLOCK
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,@EF ;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
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;
; INITIALIZE AT MOST MAXTMP INPUT FILES FOR /MERGE
BEGIN
PROCEDURE (PUSHJ P,GETMRG)
PUSH P,ACTTMP ;ITERATION COUNT
MOVN T1,ACTTMP ;MINUS THE RUNS WE WILL DO THIS TIME
ADDM T1,NUMLFT ;RESIDUAL RUNS
MOVEI F,FCBORG ;PTR TO FIRST FCB FOR INPUT FILE
MOVE S,TREORG ;GET FIRST "WINNER"
HRRZ R,RN.REC(S) ;AND RECORD
WHILE THERE ARE MERGE FILES TO INITIALIZE
BEGIN
ADD F,[1,,FCBLEN] ;NEXT FILE
MOVE T1,@F.INZR ;[215] GET NEXT INPUT FILE
EXCH T1,F.INZR ;[215] SAVE NEXT, GET THIS ONE
MOVEM T1,FILXBK(F) ;[215] REMEMBER X. BLOCK LOC
PUSHJ P,INIINP ;OPEN FILE
JSP P4,GETREC ;GET FIRST RECORD OF MERGE FILE
JRST E$$RIE ;SOMETHING WRONG
AOS RQ ;WILL BE RUN #1
HRLM F,RN.FCB(S) ;INDICATE WHICH FILE RECORD CAME FROM
PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
HRRZ R,RN.REC(S) ;SET UP RECORD PTR
SOSLE 0(P) ;IF MORE TO DO
JRST $B ;[215] GET NEXT RECORD
END;
POP P,(P) ;GET JUNK OFF STACK
AOS RC ;SET CURRENT RUN TO #1
SETOM BUFALC ;INDICATE BUFFER RNGS FORMED
RETURN
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 ;[215] GET POINTER TO NEXT
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 ;[107,215] IGNORE NULL FILES
JRST $F ;[215]
ELSE RELEASE CHANNEL AND UNBIND STACK TO START MERGE
PUSHJ P,RELFIL ;[215] RELEASE CHANNEL
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
MOVE T1,FILSIZ(F)
ADDM T1,INPREC ;KEEP COUNT OF INPUT RECORDS
PUSHJ P,RELFIL ;RELEASE CHAN
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
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
CLEARO ;[215] CLEAR ^O
E$$LRI: $ERROR ($,LRI,<Load reel >,+) ;[215] ASK FOR TAPE
MOVE T1,X.REEL(P1) ;[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) ; ..
>
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,<
PUSHJ P,STRTIO ;START I/O
>
MOVX T1,FI.EOT ;CLEAR EOT FLAG
ANDCAM T1,FILFLG(F) ; ..
PUSHJ P,CHKLBL ;[215] CHECK NEW REEL
PUSHJ P,GETREC ;[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,CLSMST ;CLOSE MASTER FILE
MOVE T1,FILSIZ(F) ;[215] REMEMBER HOW MUCH WE
MOVEM T1,OUTREC ;[215] WROTE FOR ENDS.
IF OUTPUT FILE IS A MAGTAPE
PUSHJ P,ISITMT ;IS IT A MAGTAPE?
JRST $F ;NO
THEN WRITE EOF LABEL, AND UNLOAD TAPE IF NECESSARY
PUSHJ P,WRTEND ;[215] WRITE LABEL
MOVE T1,FILFLG(F) ;[215] CHECK FOR UNLOAD
TXNE T1,FI.UNL ;[215] ..
PUSHJ P,UNLDF ;[215] YES--UNLOAD TAPE
FI;
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,WRTEOF ;WRITE EOF MARK
PUSHJ P,WRTEOT ;[215] WRITE END LABEL
PUSHJ P,WRTEOF ;WRITE SECOND TAPE MARK
PUSHJ P,UNLDF ;[215] DONE WITH THIS TAPE
IFE FTOPS20,<
IF NEXT DRIVE IS DIFFERENT THAN CURRENT
SKIPN T1,@F.OUZR ;[215] GET NEXT DEVICE
MOVE T1,X.NXT(P1) ;[215] LIST ENDED--START OVER
MOVEM T1,F.OUZR ;[215] REMEMBER FOR NEXT TIME
MOVE T1,OM.DEV(T1) ;[215] GET DEVICE
CAMN T1,X.OPN+.OPDEV(P1) ;[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) ;[215] STORE DEVICE FOR OPEN
HLLZ T1,CHNMAP+0 ;[215] GET OUTPUT CHANNEL
ADD T1,[OPEN X.OPN(P1)] ;[215] TURN INTO OPEN UUO
DMOVE T2,FILHDR(F) ;[215] SAVE HEADER AND BYTE POINTER
XCT T1 ;[215] OPEN NEW DRIVE
JRST ERROFF ;[215] FAILED?!!?
DMOVEM T2,FILHDR(F) ;[215] RESTORE HEADER AND POINTER
PUSHJ P,STAPF ;[215] SET UP DENSITY, ETC.
FI;
>;END IFE FTOPS20
CLEARO ;[215] CLEAR ANY ^O
E$$LRO: $ERROR ($,LRO,<Load reel >) ;[215] ASK USER FOR NEXT TAPE
MOVE T1,X.REEL(P1) ;[215] SAY WHICH REEL
ADDI T1,1 ;[215] ..
$MORE (DECIMAL,T1) ;[215] ..
$MORE (TEXT,< of output file >)
IFE FTOPS20,<
MOVEI T1,X.RIB(P1) ;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
PUSHJ P,WRTLBL ;[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,@EF ;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,@EF ;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
HRRZ T2,FILNAM(T2) ;...
ADDI T2,X.RIB ;COMPENSATE FOR FOLLOWING MACRO
$MORE (FILESPEC,T2)
$CRLF
$1% PUSHJ P,SETTRE ;SET NEW RECORD IN TREE
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,EOFMRG)
MOVE T1,FILSIZ(F)
ADDM T1,INPREC ;KEEP COUNT OF INPUT RECORDS
PUSHJ P,RELFIL ;RELEASE CHAN
SOSG ACTTMP ;ALL DONE?
JRST EOFOUT ;YES
HLLOS RQ ;SET TERMINATING RUN#
RETURN
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
IFN FTOPS20,<
MOVX T1,FI.LAB ;FLAG THAT LABELLING
IORM T1,FILFLG(F) ;IS IN PROGRESS
>
IFE FTOPS20,<
IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
MOVE T1,FILFLG(F) ;[215] FETCH TAPE'S FLAG BITS
TXNE T1,FI.ATO ;[215] TAPE LABELER DOING THE WORK?
JRST $F ;[215] YES--DONE
THEN WE MUST DO IT OURSELVES
>
CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,ANSI)
MOVE T1,X.LABL(P1) ;[215] FETCH LABEL TYPE
JRST @[EXP $1,$C,$2,$1,$3,$4]-1(T1) ;[215] CHECK PROPER LABELS
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
SKIPN X.RIB+.RBNAM(P1) ;[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
MOVE T4,FILPTR(F) ;GET BYTE PTR
CASE I/O MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T1,MODE ;[215] GET MODE OF FILE
PUSHJ P,@[EXP CHKSIX,CHKASC,E$$ELN,CHKBIN]-1(T1)
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;
IFE FTOPS20,<
FI;
>
POP P,P1 ;[215] RESTORE TEMP
IFN FTOPS20,<
MOVX T1,FI.LAB ;INDICATE WE'RE DONE
ANDCAM T1,FILFLG(F) ; PROCESSING LABELS
>
RETURN ;[215] ALL DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKSIX) ;CHECK SIXBIT LABEL
MOVE T1,0(T4) ;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) ;GET BYTES 7-12
LSHC T1,4*6 ;LEFT JUSTIFY
LSH T2,-6 ;SHIFT INTO BYTES 1-2
HLR T2,2(T4) ;GET LAST CHARACTER
LSH T2,6 ;BYTES 11, 12, 13 IN LHS
CAME T1,X.RIB+.RBNAM(P1) ;[215] CHECK NAME
JRST E$$LNC
HLLZS X.RIB+.RBEXT(P1) ;[215] CLEAR RHS JUNK
HLLZ T2,T2 ;...
CAME T2,X.RIB+.RBEXT(P1) ;[215] MATCH
JRST E$$LNC
HRLZ T3,4(T4) ;GET REEL NUMBER
HLR T3,5(T4) ;...
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
ADDI T1,-'0'(T2) ;ADD IN
JUMPN T3,$1 ;MORE TO DO
SKIPN X.REEL(P1) ;[116,215] REEL #0 SAME AS #1
JUMPE T1,$2 ;[116] FOR FIRST MULTI-FILE REEL
MOVEI T3,-1(T1) ;[116] PUT REEL NO. -1 IN T3
CAME T3,X.REEL(P1) ;[116,215] ONE WE EXPECTED?
JRST ERRROS ;NO
$2% AOS X.REEL(P1) ;[116,215] INCREMENT PREVIOUS REEL ID
RETURN
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,CHKBIN)
MOVE T1,0(T4) ;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 T1,(T4) ;GET 1ST WORD
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
ADDI T1,-" "(T2) ;ADD IN (SIXBITIZED)
SOJG T3,$1 ;LOOP
CAME T1,X.RIB+.RBNAM(P1) ;[215] MATCH
JRST E$$LNC
MOVEI T3,3 ;GET EXT
$3% ILDB T2,T4
LSH T1,6
ADDI T1,-" "(T2) ;SAME AS ABOVE
SOJG T3,$3
HRLZ T1,T1 ;PUT IN LHS
HLLZS X.RIB+.RBEXT(P1) ;[215] CLEAR POSSIBLE JUNK
CAME T1,X.RIB+.RBEXT(P1) ;[215]
JRST E$$LNC
DMOVE T2,3(T4) ;PICKUP REEL ID
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
ADDI T3,-"0"(T1) ;ADD IN
JUMPN T2,$4 ;MORE TO DO
SKIPN X.REEL(P1) ;[116,215] REEL #0 SAME AS #1
JUMPE T3,$5 ;[116] FOR FIRST MULTI-FILE REEL
MOVEI T1,-1(T3) ;[116] PUT REEL NO. -1 IN T3
CAME T1,X.REEL(P1) ;[116,215] ONE WE EXPECTED?
JRST ERRROS ;NO
$5% AOS X.REEL(P1) ;[116,215] 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
IFE FTOPS20,<
IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
MOVE T1,FILFLG(F) ;[215] GET FILE'S FLAGS
TXNE T1,FI.ATO ;[215] LABELER DOING THE WORK?
JRST $F ;[215] YES--NO PROBLEM
THEN WE MUST DO IT OURSELVES
>
AOS X.REEL(P1) ;[215] WE'RE NOW ON NEXT REEL
CASE LABEL TYPE OF (STANDARD,OMITTED,NON-STANDARD,DEC,IBM)
MOVE T1,X.LABL(P1) ;[215] GET LABEL TYPE
JRST @[EXP $1,$C,$2,$1,$3,$4]-1(T1)
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
IFE FTOPS20,<
SKIPGE FILHDR(F) ;VIRGIN RING?
JSP T4,PUTBUF ;YES, DUMMY OUTPUT NEEDED
>;END IFE FTOPS20
MOVE T4,FILPTR(F) ;GET BYTE POINTER
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) ;[215] SET UP LABEL
PUSHJ P,@[EXP WRTSIX,WRTASC,WRTEBC,WRTBIN]-1(T2)
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;
IFE FTOPS20,<
FI;
>
POP P,P1 ;[215] RESTORE TEMP
RETURN ;[215] ALL DONE
END;
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTSIX) ;WRITE SIXBIT LABEL
;WRITE SIXBIT LABEL
DMOVE T2,X.RIB+.RBNAM(P1) ;[215] GET NAME, EXT
JUMPE T2,E$$NRL
HRRI T3,' ' ;FILL WITH SPACES
LSHC T1,2*6
MOVEM T1,0(T4) ;FIRST WORD
LSH T2,-2*6
LSHC T2,2*6
MOVEM T2,1(T4) ;SECOND WORD
HRRI T3,' '
MOVEM T3,2(T4) ;THIRD WORD
HRLZM T3,3(T4) ;FOURTH WORD
MOVE T1,X.REEL(P1) ;[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)
HRLI T3,'00 '
ADDI T3,' 00'
MOVSM T3,5(T4) ;STORE IT AS X0000
DATE T1, ;GET CURRENT DATE
IDIVI T1,^D31
ADDI T2,1
IDIVI T2,^D10 ;GET DAYS
LSH T2,6
ADDI T2,'00'(T3) ;SIXBITIZE
LSH T2,6
HRRZM T2,7(T4) ;STORE DAYS
IDIVI T1,^D12 ;GET MONTH
ADDI T2,1
IDIVI T2,^D10
LSH T2,6
ADDI T3,'00'(T2) ;PUT MONTH IN T3
ADDI T1,^D64 ;ADD IN YEAR BASE
IDIVI T1,^D10
LSH T2,2*6
ADDI T2,'0 '(T3) ;YMM
HRLM T2,7(T4)
ADDI T1,'0'
MOVEM T1,6(T4) ;COMPLETE DATE
MOVE T1,['PDP10 ']
MOVEM T1,^D10(T4)
MOVEI T1,^D80/6
ADDM T1,FILPTR(F) ;ADVANCE BYTE PTR
MOVN T1,T1
ADDM T1,FILCNT(F)
IFE FTOPS20,<
JSP T4,PUTBUF ;FORCE IT OUT
>
IFN FTOPS20,<
PUSHJ P,FORCBF ;FORCE IT OUT
>
RETURN
END;
WRTEBC: JRST E$$ELN
WRTBIN==WRTSIX
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,WRTASC)
;WRITE ASCII LABEL
SETZ T2,
SKIPN T3,X.RIB+.RBNAM(P1) ;[215] GET NAME
JRST E$$NRL
LSHC T2,6 ;SHIFT IN T2
ADDI T1,0(T2) ;ADD IN
LSH T1,1 ;LEFT JUST
MOVEM T1,0(T4) ;FIRST WORD
SETZ T1, ;HOLD NAME
$1% SETZ T2,
LSHC T2,6 ;GET NEXT CHAR
LSH T1,7 ;MAKE SPACE
ADDI T1," "(T2) ;ADD IN
TXNN T1,177B7 ;DONE?
JRST $1 ;NOT YET
LSH T1,1 ;LEFT JUSTIFY
MOVEM T1,1(T4) ;STORE
SETZ T1,
HLLZ T3,X.RIB+.RBEXT(P1) ;[215] GET EXTENSION
$2% SETZ T2,
LSHC T2,6 ;SHIFT IN
LSH T1,7 ;MAKE SPACE
ADDI T1," "(T2) ;ADD IN
TXNN T1,177B7 ;DONE
JRST $2
LSH T1,1 ;LEFT JUSTIFY
MOVEM T1,2(T4) ;STORE EXT
MOVE T1,[ASCII / /] ;5 SPACES
MOVEM T1,3(T4)
MOVEM T1,4(T4) ;MORE SPACES
MOVEM T1,7(T4)
MOVEM T1,^D10(T4)
MOVE T2,[ASCII /PDP10/]
DMOVEM T1,^D11(T4)
MOVEM T1,^D13(T4)
MOVEM T1,^D14(T4)
TRC T1,<BYTE (7) 40,40,40,40,40>^!<BYTE (7) 40,40,40,15,12>
MOVEM T1,^D15(T4) ;END WITH CR-LF
MOVE T1,X.REEL(P1) ;[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)
DATE T1, ;GET CURRENT DATE
IDIVI T1,^D31
ADDI T2,1
IDIVI T2,^D10 ;GET DAYS
LSH T2,7
ADDI T2,"00"(T3) ;ASCIIZE
LSH T2,1+3*7 ;SHIFT OFF BIT 35
IOR T2,[BYTE (7) 0,0,40,40,40]
MOVEM T2,^D9(T4) ;STORE DAYS
IDIVI T1,^D12 ;GET MONTH
ADDI T2,1
IDIVI T2,^D10
LSH T2,7
ADDI T3,"00"(T2) ;PUT MONTH IN T3
ADDI T1,^D64 ;ADD IN YEAR BASE
IDIVI T1,^D10
LSH T1,7
ADDI T1,"00"(T2) ;YY
LSH T1,2*7+1 ;YY
LSH T3,1 ;MM
IOR T1,T3 ; YYMM
TXO T1,ASCII / /
MOVEM T1,8(T4)
MOVEI T1,^D82/5+1
ADDM T1,FILPTR(F)
MOVN T1,T1
ADDM T1,FILCNT(F)
IFE FTOPS20,<
JSP T4,PUTBUF ;FORCE IT OUT
>
IFN FTOPS20,<
PUSHJ P,FORCBF ;FORCE IT OUT
>
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] ..
IFE FTOPS20,<
IF TAPE LABEL HANDLER IS NOT CHECKING THIS TAPE
MOVE T1,FILFLG(F) ;[215] GET TAPE'S FILE FLAGS
TXNE T1,FI.ATO ;[215] LABELER DOING THE WORK?
JRST $F ;[215] YES--NO PROBLEM
THEN WE MUST DO IT OURSELVES
>
CASE LABEL TYPE OF (STANDARD, OMITTED,NON-STANDARD,DEC,ANSI,IBM)
MOVE T1,X.LABL(P1) ;[215] GET LABEL TYPE
JRST @[EXP $1,$C,$2,$1,$2,$2]-1(T1) ;[215] CASE BY LABEL TYPE
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
MOVX T1,FI.LAB ;INDICATE LABEL PROCESSING
IORM T1,FILFLG(F) ; IN PROGRESS
JSP T4,GETBUF ;READ THE LABEL
JRST E$$RIE ;SHOULD NOT HAPPEN
MOVX T1,FI.LAB ;CLEAR LABELLING FLAG
ANDCAM T1,FILFLG(F) ; ..
SETZM FILCNT(F) ;SO WE IGNORE BLOCK WHEN DONE
MOVE T2,@FILPTR(F) ;[215] GET LABEL DESIGNATOR
CASE MODE OF (SIXBIT,ASCII,EBCDIC,BINARY)
HRRZ T1,MODE ;[215] GET MODE OF TAPE
PUSHJ P,@[EXP CHKESX,CHKEAS,E$$ELN,CHKEBN]-1(T1)
ESAC;
JRST $C ;[215] DONE HERE NOW
$2% ;[215] NON-STANDARD, ANSI, OR IBM LABELS
PUSHJ P,SKIPF ;[215] IGNORE LABEL (USER WARNED ALREADY)
; JRST $C ;[215] FALL THROUGH
ESAC;
IFE FTOPS20,<
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) ;[215] OK--RESET COUNT TO INDICATE NO MORE TAPES
FI;
PJRST SKIPF ;[215] SKIP OVER LABEL
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) ;[215] OK--RESET COUNT TO INDICATE NO MORE TAPES
FI;
PJRST SKIPF ;[215] SKIP OVER LABEL
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
IFE FTOPS20,<
IF TAPE LABEL HANDLER IS NOT DOING THIS TAPE
MOVE T1,FILFLG(F) ;[215] TEST AUTO-LABELING BIT
TXNE T1,FI.ATO ;[215] ..
JRST $F ;[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) ;[215] GET LABEL TYPE
JRST @[EXP $1,$C,$C,$1,$C,$C]-1(T1) ;[215] CASE ON LABEL TYPE
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
IFE FTOPS20,<
MOVX T1,BF.VBR
ANDCAM T1,FILHDR(F) ;CLEAR THE VIRGIN RING BIT
MOVE T4,[440000,,1]
ADDB T4,FILPTR(F) ;ADVANCE BYTE POINTER
>;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) ;[215] SET UP LABEL
PUSHJ P,@[EXP WRTSIX,WRTASC,WRTEBC,WRTBIN]-1(T2)
ESAC;
PUSHJ P,WRTEOF ;[215] WRITE EOF AFTER LABEL
; JRST $C ;[215] FALL THROUGH
ESAC;
IFE FTOPS20,<
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
IFE FTOPS20,<
IF TAPE LABEL HANDLER IS NOT DOING THIS TAPE
MOVE T1,FILFLG(F) ;[215] TEST AUTO-LABELING BIT
TXNE T1,FI.ATO ;[215] ..
JRST $F ;[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) ;[215] GET LABEL TYPE
JRST @[EXP $1,$2,$2,$1,$2,$2]-1(T1) ;[215] CASE ON LABEL TYPE
$1% ;[215] STANDARD OR DEC LABELS (SYNONYMOUS)
IFE FTOPS20,<
MOVX T1,BF.VBR
ANDCAM T1,FILHDR(F) ;CLEAR THE VIRGIN RING BIT
MOVE T4,[440000,,1]
ADDB T4,FILPTR(F) ;ADVANCE BYTE POINTER
>;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) ;[215] SET UP LABEL
PUSHJ P,@[EXP WRTSIX,WRTASC,WRTEBC,WRTBIN]-1(T2)
ESAC;
PUSHJ P,WRTEOF ;[215] WRITE 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;
IFE FTOPS20,<
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,<
MOVE T1,RUNCOR ;GET ORIGINAL MEMORY SIZE
CORE T1, ;REDUCE BACK TO IT
NOOP ;IGNORE ERROR RETURN
>
IFN FTOPS20,<
PUSHJ P,RESET% ;CLEAN UP MEMORY
SKIPE FORTPP ;FORTRAN?
JRST FORXIT ;YES, RETURN TO USER
>
HRRZ T1,.JBFF## ;ZERO FREE MEMORY
CAMG T1,.JBREL ;
SETZM (T1) ;
HRL T1,T1 ;
ADDI T1,1 ;
HRRZ T2,.JBREL ;
CAIL T2,(T1) ;
BLT T1,(T2) ;DOIT
MOVE T1,INPREC ;NUMBER OF RECORDS SORTED
CAME T1,OUTREC ;SAME NUMBER AS WE OUTPUT?
PUSHJ P,E$$RNI ;RECORD NUMBER INCONSISTENT
IF SORT
SKIPLE MRGSW
JRST $T
THEN PRINT <SORTED>
TYPE (<Sorted >)
JRST $F
ELSE PRINT <MERGED>
TYPE (<Merged >)
FI;
MOVE T1,INPREC
PUSHJ P,.TDECW ;TYPE #
TYPE (< records
>)
AOSG T1,RTRUNC ;ANY RECORDS TRUNCATED
JRST $2 ;NO
PUSHJ P,.TDECW ;YES
TYPE (< records truncated
>)
$2%
MOVE T1,CMPCNT ;NUMBER OF KEY COMPARISONS
PUSHJ P,.TDECW
TYPE (< KEY comparisons, >)
MOVE T1,CMPCNT ;NO. OF COMPARISONS
MOVE T2,INPREC ;NO. OF RECORDS READ
MOVEI T3,2 ;NO. OF PLACES AFTER DECIMAL PT.
PUSHJ P,.TFLPW ;PRINT IT
TYPE (< per record
>)
MOVE T1,RCBTOT ; ..
CAMGE T1,OUTREC ;IF WE NEVER ENTIRELY FILLED THE TREE,
MOVE T1,OUTREC ; TELL HIM HOW MANY RECORDS THERE WERE
PUSHJ P,.TDECW ; ..
IFE FTOPS20,<
TYPE (< record leaves in memory>) ;TELL HIM WHAT NUMRCB WAS
>
IFN FTOPS20,<
TYPE (< record leaves in memory, >) ;TELL HIM WHAT NUMRCB WAS
MOVE T1,BUFTOT ;GET SIZE OF BUFFER POOL
LSH T1,-<POW2(PGSIZ)> ;CONVERT TO NUMBER OF PAGES
PUSHJ P,.TDECW ;TYPE IT
TYPE (< buffer pages>)
>
PUSHJ P,.TCRLF ;NEW LINE
MOVE T1,RUNTOT ;TYPE NUMBER OF RUNS
PUSHJ P,.TDECW
IF JUST ONE RUN
MOVE T1,RUNTOT
SOJN T1,$T
THEN PRINT SINGULAR RUN
TYPE (< run>)
JRST $F
ELSE PRINT PLURAL RUNS
TYPE (< runs>)
FI;
IF MEANINGFUL BIAS VALUE
SKIPG MRGSW ;NOT MEANINGFUL IN /MERGE
SKIPN T2,RUNTOT ;NO. OF RUNS
JRST $F ;NOT MEANINGFUL IF 0 RUNS
THEN TYPE IT OUT
TYPE (<, bias >)
MOVE T1,INPREC ;TOTAL NO. OF RECORDS
IDIV T1,T2 ;NO. OF RECORDS PER RUN
MOVE T2,RCBTOT ;NO. OF RECORDS IN MEMORY
MOVEI T3,2 ;2 DECIMAL PLACES
PUSHJ P,.TFLPW ;OUTPUT BIAS
FI;
PUSHJ P,.TCRLF
IFN FTOPS20,<
IF ANY TEMPORARY PAGES WERE USED
SKIPN SUMTMP ;ANY TEMPORARY PAGES USED?
JRST $F ;NO, DON'T BOTHER PRINTING ANYTHING
THEN TYPE HOW MANY WE USED
TYPE (<Total of >)
MOVE T1,SUMTMP
PUSHJ P,.TDECW
IF JUST ONE TEMPORARY PAGE USED
MOVE T1,SUMTMP
SOJN T1,$T
THEN TYPE SINGULAR PAGE
TYPE (< page>)
JRST $F
ELSE TYPE PLURAL FORM
TYPE (< pages>)
FI;
TYPE (< in temporary files used
>)
FI;
>
IFE FTOPS20,<
SETZ T1, ;SELECT CURRENT JOB
RUNTIM T1, ;DETERMINE TOTAL CPU TIME IN MS
>
IFN FTOPS20,<
HRROI T1,-5 ;WHOLE JOB
RUNTM
>
SUB T1,CPUTIM ;CALCULATE INCREMENTAL CPU TIME
IFN FTOPS20,<
IMULI T1,^D1000
IDIVI T1,(T2) ;TIME IN MILLISECS
>
PUSH P,T1 ;SAVE IT
PUSHJ P,.TTIME ;TYPE TIME
TYPE (< CPU time, >)
POP P,T1 ;GET MS BACK
MOVE T2,INPREC ;NO. OF RECORDS
MOVEI T3,2 ;NO. OF DECIMAL PLACES
PUSHJ P,.TFLPW
TYPE (< MS per record
>)
IFE FTOPS20,<
MSTIME T1, ;CURRENT TIME OF DAY IN MS
>
IFN FTOPS20,<
TIME
>
SUB T1,ORGTIM ;CALCULATE INCREMENTAL ELAPSED TIME
IFE FTOPS20,<
SKIPGE T1 ;GONE PAST MIDNIGHT?
ADD T1,[^D<24*60*60*1000>] ;YES, ADD 1 DAY OF MILLISECS.
>
IFN FTOPS20,<
IMULI T1,^D1000
IDIVI T1,(T2) ;TIME IN MILLISECS
>
PUSHJ P,.TTIME ;TYPE TIME
TYPE (< elapsed time
>)
RETURN
END;
SUBTTL TYPE-OUT ROUTINES -- Floating-point Number
;STILL IN IFE FTFORTRAN
BEGIN
PROCEDURE (PUSHJ P,.TFLPW)
;TYPE OUT SIGNED FLOATING POINT NUMBER
;CALL: MOVE T1,NUMBER
; MOVE T2,DIVISOR
; MOVEI T3,NO. OF DIGITS AFTER DECIMAL PT.
; PUSHJ P,.TFLPW
;USES T1, T2, T3, T4
PUSH P,P1 ;[112] GET A SAFE ACC
IFE FTKL10,<
HRRZI T4,1(T3) ;[112] NO. OF DECIMAL PLACES + 1
HRLI T4,1(T3) ;[112] ...
ADD P,T4 ;[112] ADJUST STACK POINTER
>
IFN FTKL10,<
ADJSP P,1(T3) ;[112] ADJUST STACK POINTER
>
MOVE T4,T2 ;[112] SAVE DIVISOR
IDIV T1,T2 ;[112] GET NUMBER BEFORE DECIMAL PT.
MOVE P1,P ;[112] GET BASE OF STACK
PUSH P,T3 ;[112] SAVE COUNT
MOVEM T1,0(P1) ;[112] SAVE REMAINDER
$1% MOVE T1,T2 ;[112] GET REMAINDER
IMULI T1,^D10 ;[112]
IDIV T1,T4 ;[112] GET NEXT DIGIT
SUBI P1,1 ;[112] BACKUP STACK
MOVEM T1,0(P1) ;[112] SAVE DIGIT
SOJG T3,$1 ;[112] LOOP
MOVE T3,0(P) ;[112] GET COUNT AGAIN
LSH T2,1 ;[112] DOUBLE REMAINDER
CAMGE T2,T4 ;[112] NEED TO ROUND UP?
JRST $3 ;[112] NO
$2% AOS T1,0(P1) ;[112] ROUND UP
CAIG T1,9 ;[112] TOO BIG?
JRST $3 ;[112] NO, ROUNDING DONE
SOJL T3,$3 ;[112] OK IF BEFORE DECIMAL POINT
SETZM 0(P1) ;[112] MAKE IT ZERO
AOJA P1,$2 ;[112] AND ROUND UP NEXT DIGIT
$3% POP P,P1 ;[112] GET COUNT
POP P,T1 ;[112] GET WHOLE NUMBER
PUSHJ P,.TDECW ;[112] PRINT IT
MOVEI T1,"." ;[112] GET DECIMAL PT.
PUSHJ P,.TCHAR ;[112] PRINT IT
$4% POP P,T1 ;[112] GET NEXT DIGIT
ADDI T1,"0" ;[112] CONVERT TO ASCII
PUSHJ P,.TCHAR ;[112] TYPE IT
SOJG P1,$4 ;[112] LOOP
POP P,P1 ;[112] RESTORE P1
RETURN
END;
>;END IFE FTFORTRAN
SUBTTL LOW SEGMENT ERROR MESSAGES
E$$ELN: $ERROR (?,ELN,<EBCDIC tape labels not supported.>)
ERRRTI: AOSLE RTRUNC ;ALREADY SEEN MESSAGE
POPJ P, ;YES
PUSH P,T1
PUSH P,T2
$ERROR (%,RTI,<Record truncation on input>)
POP P,T2
POP P,T1
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) ;[215] TYPE OFFENDING FILE SPEC
>
IFN FTOPS20,<
HLRZ T2,X.JFN(P1) ;$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) ;[215] PRINT OFFENDING FILE SPEC
>
IFN FTOPS20,<
MOVE T2,X.JFN(P1)
>
$MORE (FILESPEC,T2)
$DIE
>;END IFE FTFORTRAN