Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
sort-source/srtdtr.mac
There is 1 other file named srtdtr.mac in the archive. Click here to see a list.
; UPD ID= 96 on 12/5/83 at 10:48 AM by FONG
TITLE SRTDTR - INTERFACE TO DATATRIEVE FOR SORT
SUBTTL P.M.VATNE
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
SEARCH SRTPRM
XSEARCH ;SEARCH OTHER UNIVERSALS
IFN FTPRINT,<PRINTX [Entering SRTDTR.MAC]>
.COPYRIGHT ;Put standard copyright statement in REL file
SEGMENT HPURE
SUBTTL TABLE OF CONTENTS FOR SRTDTR
; Table of Contents for SRTDTR
;
;
; Section Page
;
; 1 STRDTR - INTERFACE TO DATATRIEVE FOR SORT ................ 1
; 2 TABLE OF CONTENTS FOR SRTDTR ............................. 2
; 3 DEFINITIONS
; 3.1 Flags, Entry Points and Macros .................... 3
; 3.2 Internal/External Symbols ......................... 4
; 3.3 Impure Data ....................................... 5
; 3.4 TOPS-20 Entry Vector .............................. 6
; 4 SRTINI
; 4.1 SORT Initialization ............................... 7
; 4.2 Initialization continued .......................... 8
; 4.3 Convert Key Specifications to Internal Format ..... 9
; 4.4 Sort Key Type Table ............................... 10
; 5 SRTREL
; 5.1 Add Input Record to Tree .......................... 11
; 6 SRTMRG
; 6.1 Simulate Master End of File ....................... 12
; 7 SRTRET
; 7.1 Copy Records From Tree to Output File ............. 13
; 8 SRTEND
; 8.1 Clean Up After Sort ............................... 14
; 9 SRTERR
; 9.1 Return text of error message ...................... 15
; 10 ACCUMULATOR SAVE/RESTORE ROUTINE ......................... 16
; 11 STRCPY
; 11.1 String Copy Routine ............................... 17
; 11.2 BLT all full words in string ...................... 18
; 11.3 Initialize BYTBLT Constants ....................... 19
; 11.4 Convert One-word Byte Pointers to Two Words ....... 20
; 12 ERROR MESSAGES ........................................... 21
SUBTTL DEFINITIONS -- Flags, Entry Points and Macros
ENTRY SRTINI,SRTREL,SRTMRG,SRTRET,SRTEND,SRTERR
ERRLEN==^D80 ;MAXIMUM NUMBER OF CHARACTERS IN ERROR MESSAGE
CODSIZ==2000 ;MAXIMUM SIZE OF GENERATED COMPARE CODE
;***************************** WARNING *********************************
;THE FOLLOWING KEYZ MACRO CALL MUST BE THE SAME AS THE CALL IN SRTSTA
;***********************************************************************
KEYZ MOD,<SIXBIT,ASCII,EBCDIC,BINARY>
SUBTTL DEFINITIONS -- Internal/External Symbols
;GENERATE STRUCTURE MACROS
;NOW GENERATE THEM MAX = 10 FOR NOW
RADIX 10
$TEMPORARY (10,10)
RADIX 8
;GLOBAL ROUTINES
INTERN DTRVLN,DTRVEC
;EXTERNALS
;DEFINED IN SORT
EXTERN ACTTMP,DFBORG,ERRADR,INPREC,LSTREC,MAXTMP,MRGSW,NUMTMP,PSAV,RQ
EXTERN OUTREC,RECORD,REKSIZ,STRNAM,STRNUM,TCBIDX,TMPFCB,XTRWRD,$RETRN
EXTERN IOBPW
EXTERN CLRSPC,CPUTST,E$$KOR,E$$NEC,E$$RNI,GETJOB,GETSPC,INITRE,MERGE%
EXTERN PSORT%,RELES%,RETRN%,RETRN0,RETRN1,RSTSPC,SETMRG,SETSPC,SETTRE
EXTERN ZDATA,%ERMSG,%TDECW,%TCRLF,%TSIXN,%TSTRG,.TYOCH
;DEFINED IN SRTJSS
EXTERN DELFIL,CHKCOR,RESET$,ERSET$,SETTMP
;DEFINED IN SRTSTA
EXTERN .CMPAR,BPWORD,E$$OKR,E$$RSR,EXTORG,EXTSZ,KEYEXT,KEYGEN,FSTKEY,LSTKEY
SUBTTL DEFINITIONS -- Impure Data
SEGMENT IMPURE
LD (RETVAL,1) ;VALUE TO RETURN TO DATATRIEVE
LD (SAVEPC,1) ;PC OF CALLER TO .SAVE
LD (SAVACS,20) ;PLACE TO SAVE DATATRIEVE'S ACS
LD (STACK,PDLEN) ;NEW STACK
LD (SORTAC,2) ;SAVES SORT ACS
;***DO NOT SEPARATE OR REORDER THE FOLLOWING WORDS***
LD (ERRPTR,1) ;BYTE POINTER TO ERRMSG FOR ERRCHR
LD (ERRCTR,1) ;BYTE COUNTER TO ERRMSG FOR ERRCHR
;***END OF DO NOT SEPARATE***
ZCOR:! ;START OF DATA TO CLEAR
LD (INITED,1) ;FLAG WHETHER SRTINI HAS BEEN CALLED
LD (NUMKEY,1) ;NUMBER OF KEYS
LD (KEYBUF,1) ;ADDRESS OF CURRENT KEY SPEC
KEYTYP==0 ;KEY TYPE FOR CURRENT KEY
KEYORD==1 ;KEY ORDER FOR CURRENT KEY
KEYPOS==2 ;START POSITION FOR CURRENT KEY
KEYLEN==3 ;LENGTH OF CURRENT KEY
LD (MAXLEN,1) ;MAXIMUM RECORD LENGTH IN BYTES
;***DO NOT SEPARATE OR REORDER THE FOLLOWING WORDS***
LD (STRPTR,1) ;STRING BYTE POINTER
LD (STRLEN,1) ;STRING SECTION,,STRING LENGTH
;***END OF DO NOT SEPARATE***
LD (ERRMSG,ERRLEN/5) ;ASCII TEXT OF ERROR MESSAGE
LD (BYTPTR,1) ;P AND S FIELDS OF FIRST BYTE POINTER
LD (BYTFST,1) ;BYTE POINTER TO FIRST PART OF RECORD
LD (BYTLST,1) ;BYTE POINTER TO LAST PART OF RECORD
LD (BYTWRD,1) ;NUMBER OF BYTES PER WORD
LD (BYTLFT,1) ;NUMBER OF BYTES LEFT IN FIRST WORD
LD (FSTREL,1) ;FLAGS THE FIRST RELEASE
LD (MRGDON,1) ;FLAGS END OF RELEASES
LD (LASRET,1) ;FLAGS END OF RETURNS
EZCOR==.-1 ;END OF DATA TO BE ZEROED
SEGMENT LPURE
BLOCK 1 ;LINK TO NEXT
ZCOR,,EZCOR ;DATA TO ZERO
.LINK S.LNK,.-2 ;TELL LINK WHAT TO DO
SUBTTL DEFINITIONS -- TOPS-20 Entry Vector
SEGMENT HPURE
ENTVEC: JRST SRTINI ;MAIN ENTRY POINT
HALT . ;REENTER ENTRY POINT
EXP V%SORT ;VERSION NUMBER
DTRVLN,,DTRVEC ;USER DATATRIEVE ENTRY VECTOR
ENTVLN==.-ENTVEC
DTRVEC: EXP 0,SRTINI ;DATATRIEVE ENTRY POINTS
EXP 0,SRTREL
EXP 0,SRTMRG
EXP 0,SRTRET
EXP 0,SRTEND
EXP 0,SRTERR
DTRVLN==.-DTRVEC
SUBTTL SRTINI -- SORT Initialization
BEGIN;
PROCEDURE (PUSHJ P,SRTINI)
;
;CALL WITH:
; STATUS = SRTINI(KEY-ARRAY,MAX-RECORD-LENGTH)
;
;KEY-ARRAY CONTAINS: NUMBER OF KEYS, AND A REPEATING BLOCK OF
; KEY TYPE, KEY ORDER, KEY STARTING POSITION, KEY LENGTH.
;MAX-RECORD-LENGTH IS THE LENGTH OF THE LONGEST RECORD PASSED TO SORT.
;
PUSHJ P,.SAVE ;SAVE DATATRIEVE'S ACS
JSP T4,ZDATA ;ZERO SORT DATA
SETZM MRGSW ;TELL SORT THIS IS NOT A MERGE
JSP T4,CPUTST ;MAKE SURE IF CPU IS OK
XMOVEI T1,DIE ;WHERE TO GO ON FATAL ERROR
MOVEM T1,ERRADR ;STORE IN GLOBAL LOCATION
PUSHJ P,SETSPC ;SETUP MEMORY LOCS
;GET MAXIMUM RECORD LENGTH
SKIPG T1,@1(L) ;GET MAX RECORD LENGTH
JRST E$$RSR ;RECORD LENGTH MAY NOT BE ZERO
TLNE T1,-1 ;LENGTH BIGGER THAN A HALF-WORD?
JRST E$$MTL ;MAX RECORD LENGTH IS TOO LARGE
MOVEM T1,MAXLEN ;SAVE MAX RECORD LENGTH
MOVEM T1,RECORD ;SAVE FOR SRTCMP
;PROCESS THE KEY BUFFER
XMOVEI T1,@0(L) ;GET ADDRESS OF KEY BUFFER
MOVEM T1,KEYBUF ;SAVE FOR LATER
SKIPG T2,0(T1) ;GET NUMBER OF KEYS
JRST E$$OKR ;ERROR--ONE KEY REQUIRED
MOVEM T2,NUMKEY ;SAVE NUMBER OF KEYS
MOVE P1,T2 ;SAVE NUMBER OF KEYS FOR LOOP
FOR EACH KEY IN KEY-ARRAY DO
BEGIN;
AOS KEYBUF ;ADVANCE TO NEXT KEY
PUSHJ P,KEYCNV ;CONVERT TO INTERNAL FORMAT
MOVEI T1,KEYLEN ;GET LENGTH OF BLOCK MINUS 1
ADDM T1,KEYBUF ;ADVANCE PAST THIS BLOCK
SOJG P1,$B ;LOOP FOR NEXT KEY
ENDB;
SETOM INITED ;INDICATE WE ARE READY TO SORT
RETURN ;THAT'S ALL WE CAN DO FOR NOW
ENDB;
SUBTTL SRTINI -- Initialization continued
BEGIN;
PROCEDURE (PUSHJ P,SRTIN2)
;
;CONTINUE WITH INITIALIZATION HERE. CALLED FROM SRTREL
;THE FIRST TIME SRTREL IS CALLED AFTER SRTINI IS CALLED.
;
SETOM COBPDP## ;FAKE OUT SORT
DMOVE T1,STRPTR ;GET FIRST STRING POINTER
PUSHJ P,BYTINI ;INITIALIZE FOR BYTBLT
MOVE T1,BYTWRD ;GET NUMBER OF BYTES/WORD
MOVEM T1,BPWORD ;SAVE FOR SRTCMP
MOVEM T1,IOBPW ;AND SAVE FOR SORT I/O
SKIPE T1,BYTLFT ;ANY BYTES LEFT IN FIRST WORD?
MOVE T1,BYTWRD ;YES, COMPUTE NULL BYTES
SUB T1,BYTLFT ; AT BEGINNING OF RECORD
ADDM T1,RECORD ;ADJUST RECORD SIZE FOR SRTCMP
PUSHJ P,KEYREL ;RELOCATE KEYS W.R.T. NULL BYTES
MOVE T1,MAXLEN ;GET MAXIMUM NUMBER OF BYTES
SUB T1,BYTLFT ;SUBTRACT BYTES IN FIRST WORD
IDIV T1,BYTWRD ;COMPUTE LENGTH IN WORDS
SKIPE T2 ;ANY BYTES LEFT OVER?
ADDI T1,1 ;YES, ROUND UP
SKIPE BYTLFT ;ANY BYTES LEFT IN FIRST WORD?
ADDI T1,1 ;YES, ROUND UP
MOVEM T1,REKSIZ ;SAVE NUMBER OF WORDS/REC
IFN FTOPS20,<
MOVEI T1,MX.TMP ;GET MAXIMUM TEMP FILES
>
IFE FTOPS20,<
PUSHJ P,SETCHN ;SETUP CHANNEL ALLOCATOR
MOVE T1,CHNFRE ;GET CHANNELS AVAILABLE
>
MOVEM T1,MAXTMP ;THIS IS MAX TEMP FILES
MOVN T1,MAXTMP ;MAKE AN AOBJ POINTER
HRLZM T1,TCBIDX ;PUT IT AWAY FOR LATER
PUSHJ P,SETTMP ;SET UP STRNUM AND STRNAM
MOVEI T1,CODSIZ ;GET MAXIMUM SIZE OF CODE
MOVEM T1,EXTSZ ;SAVE FOR KEYGEN
PUSHJ P,GETSPC ;ALLOCATE BLOCK OF MEMORY
JRST E$$NEC ;NOT ENOUGH CORE
XMOVEI T1,(T1) ;MAKE SURE IT HAS THE SECTION
MOVEM T1,EXTORG ;SAVE ADDRESS OF CODE
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
PUSHJ P,GETJOB ;GET JOB NUMBER
PUSHJ P,CHKCOR ;USE DEFAULT CORE ALGORITHM
PJRST PSORT% ;JOIN COMMON CODE
ENDB;
SUBTTL SRTINI -- Convert Key Specifications to Internal Format
BEGIN;
PROCEDURE (PUSHJ P,KEYCNV)
;
;THIS ROUTINE CONVERTS A KEY BLOCK FROM THE SRTINI ARGUMENT LIST
;TO A FORMAT USED INTERNALLY BY KEYEXT, KEYGEN, AND SRTCMP.
;
MOVX T1,KY.LEN ;GET A KEY BLOCK
PUSHJ P,GETSPC ;..
JRST E$$NEC ;NOT ENOUGH CORE
PUSHJ P,CLRSPC ;MAKE SURE IT'S CLEAN
IF THIS IS THE FIRST KEY
SKIPE FSTKEY ;SEEN ONE YET?
JRST $T ;YES--PUT BLOCK AT END
THEN MAKE THIS BLOCK THE FIRST IN THE LIST
MOVEM T1,FSTKEY ;
JRST $F ;
ELSE PUT SUBSEQUENT BLOCKS AT END OF THE LIST
MOVE T2,LSTKEY ;
MOVEM T1,KY.NXT(T2) ;
FI;
MOVEM T1,LSTKEY ;REMEMBER NEW LAST BLOCK
MOVE T4,KEYBUF ;GET ADDRESS OF KEY BLOCK
MOVE T2,KEYPOS(T4) ;GET STARTING POSITION OF KEY
SOJL T2,E$$KOR ;MAKE 0-ORIGIN
CAML T2,MAXLEN ;DOES KEY START INSIDE RECORD?
JRST E$$KOR ;ERROR-KEY OUT OF RANGE
MOVEM T2,KY.INI(T1)
MOVE T2,KEYLEN(T4) ;GET LENGTH OF KEY
MOVEM T2,KY.SIZ(T1)
ADD T2,KY.INI(T1) ;COMPUTE ENDING BYTE
CAMLE T2,MAXLEN ;DOES KEY END INSIDE RECORD?
JRST E$$KOR ;ERROR-KEY OUT OF RANGE
MOVN T2,KEYORD(T4) ;GET ORDER OF KEY
MOVEM T2,KY.ORD(T1) ;-1 MEANS DESCENDING
MOVE T2,KEYTYP(T4) ;GET TYPE OF KEY
CAIL T2,FSTTYP ;IN RANGE OF LEGAL TYPES?
CAILE T2,LSTTYP ;
JRST E$$IKT ;ILLEGAL KEY TYPE CODE
MOVE T2,TYPTAB-FSTTYP(T2) ;CONVERT TO BITS
MOVEM T2,KY.MOD(T1)
RETURN ;DONE
ENDB;
SUBTTL SRTINI -- Sort Key Type Table
FSTTYP==1 ;INDEX OF FIRST TYPE
TYPTAB: EXP MODSIX!RM.SIX!RM.ALP ;ALS (1)
EXP MODASC!RM.ASC!RM.ALP ;ALA (2)
EXP MODEBC!RM.EBC!RM.ALP ;ALE (3)
EXP MODSIX!RM.SIX!RM.NUM!RM.SGN ;NSS (4)
EXP MODASC!RM.ASC!RM.NUM!RM.SGN ;NSA (5)
EXP MODEBC!RM.EBC!RM.NUM!RM.SGN ;NSE (6)
EXP MODSIX!RM.SIX!RM.NUM!RM.UNS ;NUS (7)
EXP MODASC!RM.ASC!RM.NUM!RM.UNS ;NUA (8)
EXP MODEBC!RM.EBC!RM.NUM!RM.UNS ;NUE (9)
EXP MODSIX!RM.SIX!RM.COM!RM.SGN ;CSS (10)
EXP MODASC!RM.ASC!RM.COM!RM.SGN ;CSA (11)
EXP MODEBC!RM.EBC!RM.COM!RM.SGN ;CSE (12)
EXP MODSIX!RM.SIX!RM.COM!RM.UNS ;CUS (13)
EXP MODASC!RM.ASC!RM.COM!RM.UNS ;CUA (14)
EXP MODEBC!RM.EBC!RM.COM!RM.UNS ;CUE (15)
EXP MODEBC!RM.EBC!RM.PAC!RM.SGN ;C3S (16)
EXP MODEBC!RM.EBC!RM.PAC!RM.UNS ;C3U (17)
EXP MODBIN!RM.BIN!RM.COM!RM.SGN ;CSB (18)
EXP MODBIN!RM.BIN!RM.COM!RM.UNS ;CUB (19)
EXP MODBIN!RM.BIN !RM.SGN ;NSB (20)
EXP MODBIN!RM.BIN !RM.UNS ;NUB (21)
LSTTYP==.-TYPTAB-1+FSTTYP ;INDEX OF LAST TYPE
BEGIN;
PROCEDURE (PUSHJ P,KEYREL)
MOVE R,FSTKEY ;GET ADDRESS OF FIRST KEY
FOR EACH KEY DO
BEGIN
ADDM T1,KY.INI(R) ;ADJUST KEY STARTING POSITION
IF KEY HAS BINARY MODE
MOVE T2,KY.MOD(R) ;GET MODE OF KEY
TXNN T2,RM.BIN ;BINARY?
JRST $F ;NOPE
THEN CONVERT STARTING POSITION TO WORDS
MOVE T3,KY.INI(R) ;GET STARTING POSITION IN BYTES
IDIV T3,BPWORD ;CONVERT TO WORDS (0-ORIGIN)
MOVEM T3,KY.INI(R) ;STORE NEW POSITION
IF KEY IS NON-COMPUTATIONAL
TXNE T2,RM.COM ;COMPUTATIONAL?
JRST $F ;YES
THEN CONVERT LENGTH OF KEY TO WORDS
MOVE T3,KY.SIZ(R) ;GET LENGTH OF KEY IN BYTES
IDIV T3,BPWORD ;CONVERT TO WORDS (TRUNCATED)
MOVEM T3,KY.SIZ(R) ;STORE NEW LENGTH
FI;
FI;
SKIPE R,KY.NXT(R) ;GET NEXT
JRST $B ;LOOP FOR MORE
ENDB;
RETURN ;DONE
ENDB;
SUBTTL SRTREL -- Add Input Record to Tree
BEGIN;
PROCEDURE (PUSHJ P,SRTREL)
;
;CALL WITH:
; STATUS = SRTREL(STRING)
;
;THE STRING DESCRIPTOR CONTAINS A BYTE POINTER, AND THE NEXT WORD
; IN THE DESCRIPTOR CONTAINS A BYTE COUNT.
;
PUSHJ P,.SAVE ;SAVE DATATRIEVE'S ACS
SKIPE INITED ;IS THE SORT ACTIVE?
SKIPE MRGDON ;HAS A MERGE NOT BEEN DONE?
JRST E$$RLO ;NO-AN ERROR
DMOVE T1,@0(L) ;GET STRING DESCRIPTOR
XHLLI T2,@0(L) ;GET STRING'S SECTION
DMOVEM T1,STRPTR ;SAVE THE DESCRIPTOR
SKIPN FSTREL ;IS THE THE FIRST RELEASE?
PUSHJ P,SRTIN2 ;YES, COMPLETE INITIALIZATION
SETOM FSTREL ;MARK INITIALIZATION COMPLETE
DMOVE T1,STRPTR ;GET BACK THE DESCRIPTOR
TRNN T2,-1 ;ZERO RECORD LENGTH?
JRST E$$RLZ ;YES--FATAL ERROR
HRRZM T2,RC.CNT(R) ;STORE LENGTH FOR SORT
MOVEI T3,RC.KEY(R) ;GET START OF RECORD IN TREE
ADD T3,XTRWRD ;MOVE PAST CONVERTED KEY AREA
HLL T3,BYTPTR ;FORM BYTE POINTER
MOVE T4,MAXLEN ;GET MAXIMUM LENGTH OF STRING
XHLLI T4,RC.KEY(R) ;GET SECTION OF RECORD IN TREE
PUSHJ P,STRCPY ;COPY STRING
JRST E$$RLM ;RECORD SIZE LARGER THAN MAX
JSP P4,@EXTORG ;CONVERT ANY KEYS NEEDED
AOS INPREC ;COUNT RECORDS ON WAY IN
PJRST RELES% ;RELEASE RECORD TO SORT
ENDB;
SUBTTL SRTMRG -- Simulate Master End of File
BEGIN;
PROCEDURE (PUSHJ P,SRTMRG)
;
;CALL WITH:
; STATUS = SRTMRG()
;
PUSHJ P,.SAVE ;SAVE DATATRIEVE'S ACS
SKIPE INITED ;IS THE SORT ACTIVE?
SKIPE MRGDON ;HAS A MERGE NOT BEEN DONE?
JRST E$$MRO ;NO-AN ERROR
HLRZ F,RN.FCB(S) ;GET FILE POINTER
SETOM MRGDON ;FLAG THAT MERGE WAS DONE
IF NO RECORDS WERE RELEASED TO THE SORT
SKIPE FSTREL ;FIRST RELEASE DONE?
JRST $F ;YES
THEN FLAG THAT NO RECORDS ARE TO BE RETURNED
SETOM LASRET ;ALLOW ONLY ONE RETURN
RETURN ;MAY NOT MERGE 0 RECORDS
FI;
AOS LASRET ;ENABLE RETURNS
MOVEM P,PSAV ;*** KLUDGE SO MERGE WILL WORK
PJRST MERGE% ;START UP THE MERGE PHASE
ENDB;
SUBTTL SRTRET -- Copy Records From Tree to Output File
BEGIN;
PROCEDURE (PUSHJ P,SRTRET)
;
;CALL WITH:
; STATUS = SRTRET(STRING,RECORD-LENGTH)
;
;THE STRING DESCRIPTOR CONTAINS A BYTE POINTER, AND THE NEXT WORD
; IN THE DESCRIPTOR CONTAINS A BYTE COUNT.
;RECORD-LENGTH IS THE LENGTH OF THE RECORD BEING RETURNED.
;
PUSHJ P,.SAVE ;SAVE DATATRIEVE'S ACS
IF NO MORE RECORDS TO BE RETURNED
SKIPL LASRET ;ANY MORE RECORDS TO RETURN?
JRST $T ;MORE TO DO
THEN FLAG LAST AND RETURN ZERO AS THE RECORD LENGTH
SETZM LASRET ;STOP ALLOWING RETURNS
SETZM @1(L) ;ZERO RECORD LENGTH
RETURN ;DONE
ELSE GET NEXT RECORD
SKIPN LASRET ;RETURNS ENABLED?
JRST E$$RTO ;NO, GIVE USER ERROR MESSAGE
MOVEI T1,RC.KEY(R) ;GET ADDRESS OF RECORD IN TREE
ADD T1,XTRWRD ;MOVE PAST CONVERTED KEYS
HLL T1,BYTPTR ;FORM BYTE POINTER
MOVE T2,RC.CNT(R) ;GET LENGTH OF RECORD
XHLLI T2,RC.KEY(R) ;GET SECTION OF RECORD IN TREE
HRRZM T2,@1(L) ;RETURN SIZE OF RECORD IN BYTES
DMOVE T3,@0(L) ;GET BYTE POINTER TO RECORD
XHLLI T4,@0(L) ;GET STRING'S SECTION
PUSHJ P,STRCPY ;COPY STRING
JRST E$$RLS ;RETURN RECORD TOO SMALL
AOS OUTREC ;COUNT ONE MORE RECORD OUTPUT
XMOVEI T1,EOFDTR ;*** KLUDGE TO TRAP END OF FILE
MOVEM T1,SAVEPC ;*** RETURN IN EOFCBL TO EOFDTR
XMOVEI T1,SAVEPC ;*** BY SAVING FAKE STACK
MOVEM T1,PSAV ;*** IN PSAV
PJRST RETRN% ;GET THE NEXT RECORD
FI;
ENDB;
BEGIN;
PROCEDURE (PUSHJ P,EOFDTR)
SETOM LASRET ;WANT ONLY ONE MORE RECORD
JRST .RESTR ;RETURN TO DATATRIEVE
ENDB;
SUBTTL SRTEND -- Clean Up After Sort
BEGIN;
PROCEDURE (PUSHJ P,SRTEND)
;
;CALL WITH:
; STATUS = SRTEND()
;
PUSHJ P,.SAVE ;SAVE DATATRIEVE'S ACS
IF USER ROUTINE EXITED BEFORE E-O-F
SKIPN LASRET ;DID WE END NORMALLY?
JRST $T ;YES
THEN DELETE ANY OPEN FILES
MOVE T1,$RETRN ;GET WHICH RETRN WAS USED
CAIE T1,RETRN0 ;ALL IN CORE?
SKIPN ACTTMP ; OR ALL TEMP FILES GONE ALREADY?
JRST $F ;YES, NO FILE TO CLOSE
IF ONE TEMP FILE
CAIE T1,RETRN1 ;1 FILE?
JRST $T ;NO
THEN JUST DELETE THIS FILE
MOVEI F,TMPFCB ;POINTER
PUSHJ P,DELFIL ;DELETE FILE
JRST $F ;DONE
ELSE DELETE ALL OPEN FILES
BEGIN
HLRZ F,RN.FCB(S) ;GET WHICH FILE
PUSHJ P,DELFIL ;DELETE IT
SOSG ACTTMP ;SOME LEFT?
JRST $E ;NO
HLLOS RQ ;FLUSH TREE
PUSHJ P,SETTRE ;GET NEXT RECORD
JRST $B ;LOOP
ENDB;
FI;
JRST $F ;
ELSE MAKE SURE ALL RECORDS WERE OUTPUT
SKIPN MRGDON ;WAS A MERGE DONE?
JRST $F ;NO-THAT'S WHY LASRET IS ZERO
MOVE T1,INPREC
CAME T1,OUTREC
JRST [PUSHJ P,E$$RNI ;RECORD NUMBER INCONSISTENT
JRST DIE] ;NOW GO DIE
FI;
PUSHJ P,RESETC ;RESET CORE AND FILES
SETZM INITED ;INDICATE DONE WITH SORT
SETZM FSTREL ;INDICATE FIRST RELEASE NOT DONE
SETZM MRGDON ;INDICATE MERGE NOT DONE
SETZM LASRET ;STOP ALLOWING RETURNS
RETURN ;RETURN TO DATATRIEVE
ENDB;
SUBTTL SRTERR -- Return text of error message
BEGIN;
PROCEDURE (PUSHJ P,SRTERR)
;
;CALL WITH:
; CALL SRTERR(STRING)
;
;THE STRING DESCRIPTOR CONTAINS A BYTE POINTER, AND THE NEXT WORD
; IN THE DESCRIPTOR CONTAINS A BYTE COUNT.
;
;DO NOT CALL .SAVE HERE!
DMOVE T1,@0(L) ;GET POINTER TO ERROR STRING
XHLLI T2,@0(L) ;GET ERROR STRING'S SECTION
PUSHJ P,BYTGLB ;CONVERT TO TWO-WORD GLOBAL
MOVE P3,T1 ;SAVE BYTE COUNT
DMOVE P1,T2 ;SAVE BYTE POINTER
MOVE T1,[POINT 7,ERRMSG] ;GET POINTER TO ERROR MESSAGE
MOVEI T2,ERRLEN ;COMPUTE HOW MANY CHARS
SUB T2,ERRCTR ; IN ERROR MESSAGE
SKIPN T2 ;WAS THERE ANY PREVIOUS ERROR?
DMOVE T1,[POINT 7,NOTERR
NOTLEN*5] ;NO, MAKE NOT AN ERROR MESSAGE
XHLLI T2,ERRMSG ;GET ERROR MESSAGE'S SECTION
PUSHJ P,BYTGLB ;CONVERT TO TWO-WORD GLOBAL
MOVE T4,P3 ;GET DESTINATION BYTE COUNT
EXTEND T1,[MOVSLJ
0] ;COPY TO USER'S STRING
JFCL ;DON'T CARE IF MESSAGE TRUNCATED
RETURN ;DONE
NOTERR: ASCII /[There was no error]/
NOTLEN==.-NOTERR
ENDB;
SUBTTL ACCUMULATOR SAVE/RESTORE ROUTINE
BEGIN;
PROCEDURE (PUSHJ P,.SAVE)
;
;THIS IS A CO-ROUTINE WHICH EXCHANGES DATATRIEVE'S ACS WITH SORT'S ACS,
;SETS UP A NEW STACK, AND INITIALIZES THE ERROR MESSAGE HANDLER.
;
;WHEN CONTROL IS RETURNED TO .RESTR, IT EXCHANGES THE ACS AGAIN,
;AND RETURNS A SUCCESS/FAILURE VALUE IN AC0.
;
;CALL WITH:
; PUSHJ P,.SAVE
;
SETOM RETVAL ;ASSUME CALL WILL BE SUCCESSFUL
POP P,SAVEPC ;POP OFF THE CALLER'S PC
MOVEI 0,SAVACS ;SAVE THE ACS
BLT 0,SAVACS+17 ;..
DMOVE R,SORTAC ;RESTORE THE SORT ACS
XMOVEI P,STACK-1 ;GET NEW STACK IN SORT'S SECTION
DMOVE T1,[POINT 7,ERRMSG
ERRLEN] ;INITIALIZE ERROR MESSAGE
DMOVEM T1,ERRPTR ; POINTER AND COUNTER
XMOVEI T1,ERRCHR ;GET ADDRESS OF CHAR PUTTER
PUSHJ P,.TYOCH ;ALL SCAN OUTPUT GOES TO ERRCHR
PUSHJ P,@SAVEPC ;CALL THE CALLER
.RESTR: DMOVEM R,SORTAC ;SAVE THE SORT ACS
MOVSI 17,SAVACS ;RESTORE THE ACS
BLT 17,17 ;..
MOVE 0,RETVAL ;GET VALUE TO BE RETURNED
RETURN
ENDB;
SUBTTL STRCPY -- String Copy Routine
BEGIN;
PROCEDURE (PUSHJ P,STRCPY)
;
;CALL WITH:
; T1/SOURCE BYTE POINTER
; T2/SOURCE SECTION,,SOURCE BYTE COUNT
; T3/DEST BYTE POINTER
; T4/DEST SECTION,,DEST BYTE COUNT
; PUSHJ P,STRCPY
; ERROR RETURN (DESTINATION TOO SHORT)
; NORMAL RETURN
;
;DESTROYS T1-T4,P1-P4
;
DMOVE P3,T1 ;SAVE SOURCE STRING DESCRIPTOR
DMOVE T1,T3 ;GET DEST STRING DESCRIPTOR
PUSHJ P,BYTGLB ;MAKE 2-WORD GLOBAL BYTE POINTER
DMOVE P1,T2 ;SAVE BYTE POINTER
EXCH T1,P3 ;SAVE DEST BYTE COUNT
MOVE T2,P4 ;GET SOURCE BYTE COUNT
PUSHJ P,BYTGLB ;MAKE 2-WORD GLOBAL BYTE POINTER
MOVE T4,P3 ;GET DEST BYTE COUNT
IF RECORDS START AT SAME BIT BOUNDARY AND DESTINATION IS LONG ENOUGH
CAMN T2,P1 ;COMPARE P AND S FIELDS
CAMLE T1,T4 ;SEE IF ROOM IN DESTINATION
JRST $T ;NOT SAME OR RECORD TOO SHORT
THEN COPY USING XBLT
PUSHJ P,BYTBLT ;COPY STRING USING XBLT
SKIPN T4 ;PARTIAL WORD LEFT?
AOSA (P) ;ALL DONE--GIVE GOOD RETURN
ELSE COPY USING MOVSLJ
EXTEND T1,[MOVSLJ
0] ;COPY THE STRING WITH NULL FILL
RETURN ;ERROR--GIVE NON-SKIP RETURN
AOS (P) ;GIVE GOOD RETURN
RETURN ;ALL DONE!
FI;
ENDB;
SUBTTL STRCPY -- BLT all full words in string
BEGIN;
PROCEDURE (PUSHJ P,BYTBLT)
;
;CALL WITH:
; T1/SOURCE BYTE COUNT
; T2/SOURCE TWO-WORD GLOBAL BYTE POINTER
; T3/..
; T4/DEST BYTE COUNT
; P1/DEST TWO-WORD GLOBAL BYTE POINTER
; P2/..
; PUSHJ P,BYTBLT
; RETURNS WITHOUT COPYING LAST PARTIAL WORD
;
;DESTROYS T1-T4,P1-P4. ASSUMES T2 AND P1 ARE THE SAME.
;
IF BYTES LEFT IN FIRST WORD
SKIPN P3,BYTLFT ;GET BYTES LEFT IN FIRST WORD
JRST $F ;NO BYTES LEFT IN THIS WORD
THEN COPY THE FIRST PARTIAL WORD
CAMGE T1,P3 ;DO WE EVEN FILL A PARTIAL WORD?
RETURN ;NO, BETTER LET MOVSLJ DO IT
MOVE T2,BYTFST ;GET POINTER TO FIRST PART
MOVE P1,T2 ;DEST IS SAME AS SOURCE
LDB P4,T2 ;GET THE FIRST PARTIAL WORD
DPB P4,P1 ;STORE THE PARTIAL WORD
SUB T4,P3 ;FIX HOW MANY BYTES LEFT IN DEST
FI;
IF THERE ARE ANY INTERMEDIATE FULL WORDS
SUBB T1,P3 ;COMPUTE HOW MANY BYTES TO GO
IDIV P3,BYTWRD ;COMPUTE HOW MANY WORDS TO GO
JUMPE P3,$F ;ANY FULL WORDS TO COPY?
THEN COPY THE WORDS WITH XBLT
MOVE T1,P3 ;GET WORDS TO TRANSFER
AOS T2,T3 ;COMPUTE SOURCE ADDRESS
AOS T3,P2 ;COMPUTE DEST ADDRESS
EXTEND T1,[XBLT] ;COPY THE RECORD
IMUL P3,BYTWRD ;COMPUTE BYTES TRANSFERRED
SUB T4,P3 ;COMPUTE BYTES REMAINING IN DEST
IF BYTES REMAINING IN DESTINATION
JUMPE T4,$F ;NO BYTES REMAINING IN DEST
THEN SET UP FOR COPY OF LAST PARTIAL WORD WITH MOVSLJ
MOVE P2,T3 ;UPDATE NEW DEST ADDRESS
MOVE T3,T2 ;UPDATE NEW SOURCE ADDRESS
MOVE T1,P4 ;GET BYTES REMAINING IN SOURCE
MOVE T2,BYTLST ;GET GLOBAL BYTE POINTER
MOVE P1,T2 ;DEST IS SAME AS SOURCE
FI;
FI;
RETURN ;ALL DONE!
ENDB;
SUBTTL STRCPY -- Initialize BYTBLT Constants
BEGIN;
PROCEDURE (PUSHJ P,BYTINI)
;
;THIS ROUTINE INITIALIZES ALL THE CONSTANTS NEEDED BY BYTBLT
;
;CALL WITH:
; T1/BYTE POINTER TO STRING
; T2/STRING SECTION,,LENGTH OF STRING IN BYTES
; PUSHJ P,BYTINI
;
PUSHJ P,BYTGLB ;MAKE 2-WORD GLOBAL BYTE POINTER
TLZ T2,77 ;GET JUST P AND S
HLLZM T2,BYTPTR ;SAVE P AND S FOR LATER
LDB T3,[POINT 6,T2,5] ;GET STARTING POSITION
LDB T4,[POINT 6,T2,11] ;GET BYTE SIZE
JUMPE T4,E$$IBS ;MAKE SURE BYTE POINTER OK
CAILE T4,^D36 ;LEGAL BYTE SIZE?
JRST E$$IBS ;NO-ERROR
MOVE T1,T3 ;GET BITS LEFT IN WORD
LSH T1,^D24 ;MAKE INTO BYTE POINTER TO
TLO T1,(<POINT 0,,35>!1B12) ; FIRST PART OF RECORD
MOVEM T1,BYTFST ;SAVE FOR LATER
MOVE T1,T4 ;GET BYTE SIZE
LSH T1,^D24 ;MAKE INTO BYTE POINTER TO
TLO T1,(<POINT 0,,-1>!1B12) ; LAST PART OF RECORD
MOVEM T1,BYTLST ;SAVE FOR LATER
MOVEI T1,^D36 ;GET NUMBER OF BITS IN A WORD
IDIV T1,T4 ;COMPUTE BYTES/WORD
MOVEM T1,BYTWRD ;SAVE FOR LATER
IDIV T3,T4 ;GET NUMBER OF BYTES LEFT
MOVEM T3,BYTLFT ;SAVE FOR LATER
MOVEI T1,^D36 ;POSITION WHEN PRE-DECREMENTED
SKIPN T3 ;IF THERE ARE NO BYTES LEFT
DPB T1,[POINT 6,BYTPTR,5] ;CONVERT TO PRE-DECREMENTED FORM
RETURN ;DONE
ENDB;
SUBTTL STRCPY -- Convert One-word Byte Pointers to Two Words
BEGIN;
PROCEDURE (PUSHJ P,BYTGLB)
;
;CALL WITH:
; T1/LOCAL OR ONE-WORD GLOBAL BYTE POINTER
; T2/BYTE SECTION,,BYTE COUNT
; PUSHJ P,BYTGLB
;RETURNS:
; T1/BYTE COUNT
; T2/TWO-WORD GLOBAL BYTE POINTER (NOT PRE-DECREMENTED)
; T3/..
;DESTROYS T4
;
SETZ T3, ;MAKE SURE BYTE POINTER
ADJBP T3,T1 ; IS NOT PRE-DECREMENTED
DMOVE T1,T2 ;SWAP COUNT AND POINTER
IF BYTE POINTER IS A ONE WORD GLOBAL BYTE POINTER
LDB T4,[POINT 6,T2,5] ;GET BYTE POSITION
CAIG T4,44 ;ANYTHING > 44 IS GLOBAL
JRST $T ;LOCAL
THEN CONVERT ONE-WORD TO TWO-WORD GLOBAL BYTE POINTER FORMAT
TLZ T1,-1 ;CLEAR JUNK FROM COUNT
LDB T3,[POINT 30,T2,35] ;GET SECTION AND ADDRESS
MOVE T2,BYTTAB-45(T4) ;GET TWO-WORD P AND S
RETURN ;DONE
ELSE CONVERT LOCAL TO TWO-WORD GLOBAL BYTE POINTER FORMAT
LDB T3,[POINT 5,T2,17] ;GET I AND X FROM BYTE POINTER
LSH T3,^D30 ;POSITION FOR TWO-WORD FORMAT
OR T3,T1 ;GET BYTE SECTION
HRR T3,T2 ;GET BYTE ADDRESS
TLZ T1,-1 ;CLEAR JUNK FROM COUNT
AND T2,[777700,,0] ;CLEAR JUNK IN BYTE POINTER
TLO T2,(1B12) ;AND SET TWO-WORD FORMAT FLAG
RETURN ;DONE
FI;
ENDB;
BYTTAB: EXP <POINT 6,,-1>!1B12,<POINT 6,,5>!1B12,<POINT 6,,11>!1B12
EXP <POINT 6,,17>!1B12,<POINT 6,,23>!1B12,<POINT 6,,29>!1B12
EXP <POINT 6,,35>!1B12,<POINT 8,,-1>!1B12,<POINT 8,,7>!1B12
EXP <POINT 8,,15>!1B12,<POINT 8,,23>!1B12,<POINT 8,,31>!1B12
EXP <POINT 7,,-1>!1B12,<POINT 7,,6>!1B12,<POINT 7,,13>!1B12
EXP <POINT 7,,20>!1B12,<POINT 7,,27>!1B12,<POINT 7,,34>!1B12
EXP <POINT 9,,-1>!1B12,<POINT 9,,8>!1B12,<POINT 9,,17>!1B12
EXP <POINT 9,,26>!1B12,<POINT 9,,35>!1B12,<POINT 18,,-1>!1B12
EXP <POINT 18,,17>!1B12,<POINT 18,,35>!1B12,<0>!1B12
SUBTTL ERROR MESSAGES
;HERE ON FATAL ERRORS
E$$IKT: $ERROR ?,IKT,<Illegal key type code.>
E$$MTL: $ERROR ?,MTL,<Maximum record length is too large for sort.>
E$$IBS: $ERROR ?,IBS,<Illegal byte size specified for record.>
E$$RLZ: $ERROR ?,RLZ,<Record length may not be equal to zero.>
E$$RLM: $ERROR ?,RLM,<Record length exceeds maximum declared length.>
E$$RLS: $ERROR ?,RLS,<Return record length is too small.>
E$$RLO: $ERROR ?,RLO,<SRTREL called out of sequence.>
E$$MRO: $ERROR ?,MRO,<SRTMRG called out of sequence.>
E$$RTO: $ERROR ?,RTO,<SRTRET called out of sequence.>
DIE: $CRLF ;CLOSE OUT LINE
SETZM RETVAL ;FLAG FAILURE OF THE CALL
JRST .RESTR ;ABORT THIS SUBROUTINE CALL
RESETC:
IFE FTOPS20,<
PJRST RELSPC ;RELEASE ANY RETAINED MEMORY
>
IFN FTOPS20,<
;*** WARNING *** THE FOLLOWING CODE IS PURE KLUDGERY!
SKIPE MRGDON ;WAS A MERGE DONE?
PJRST RESET$ ;YES-JUST RESET CORE
MOVE T1,NUMTMP ;NO-FIX UP ACTTMP FOR ERSET$
MOVEM T1,ACTTMP ;NUMBER OF ACTIVE TEMPORARY FILES
XMOVEI T2,DFBORG ;DATA FILE BLOCK ORIGIN
XMOVEI T3,TMPFCB ;.TMP FILE CONTROL BLOCK
ADDI T3,FCBLEN ;SKIP PAST CURRENT .TMP FILE
RESTC1: MOVE T4,FILJFN(T2) ;GET JFN OF FILE
MOVEM T4,FILJFN(T3) ;STORE IT SO ERSET$ CAN FIND IT
ADDI T2,DFBLEN ;ADVANCE TO NEXT DFB
ADDI T3,FCBLEN ;ADVANCE TO NEXT FCB
SOJG T1,RESTC1 ;LOOP FOR ALL TEMPORARY FILES
PJRST ERSET$ ;RESET CORE AND FILES
>
ERRCHR: CAIGE T1," " ;CONTROL CHARACTER?
POPJ P, ;YES, THROW IT AWAY
SOSL ERRCTR ;ROOM LEFT IN ERRMSG?
IDPB T1,ERRPTR ;YES, APPEND IT TO STRING
POPJ P, ;RETURN
END