mirror of
https://github.com/PDP-10/its.git
synced 2026-01-24 19:32:35 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
555 lines
14 KiB
Plaintext
Executable File
555 lines
14 KiB
Plaintext
Executable File
|
||
;;; **************************************************************
|
||
TITLE ***** MACLISP ****** SORT FUNCTIONS **************************
|
||
;;; **************************************************************
|
||
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
|
||
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
|
||
;;; **************************************************************
|
||
|
||
|
||
.FASL
|
||
|
||
IF1,[
|
||
|
||
IFE .OSMIDAS-<SIXBIT \ITS\>,[
|
||
IFNDEF D10, D10==0
|
||
DEFINE $INSRT $%$%$%
|
||
.INSRT $%$%$% >
|
||
PRINTX \ ==> INSERTED: \
|
||
$FNAME .IFNM1
|
||
PRINTX \ \
|
||
$FNAME .IFNM2
|
||
PRINTX \
|
||
\
|
||
TERMIN
|
||
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
|
||
IFE .OSMIDAS-<SIXBIT \DEC\>,[
|
||
IFNDEF D10, D10==1
|
||
DEFINE $INSRT $%$%$%
|
||
.INSRT $%$%$%!.MID
|
||
PRINTX \INSERTED: \
|
||
$FNAME .IFNM1
|
||
PRINTX \.\
|
||
$FNAME .IFNM2
|
||
PRINTX \
|
||
\
|
||
TERMIN
|
||
] ;END OF IFE .OSMIDAS-<SIXBIT \DEC\>,
|
||
|
||
IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY???
|
||
|
||
DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT
|
||
ZZX==<FOO>
|
||
REPEAT 6,[
|
||
IRPNC ZZX_-36,1,1,Q,,[ !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ(\)^_]
|
||
IFSN [Q][ ] PRINTX |Q|
|
||
TERMIN
|
||
ZZX==ZZX_6
|
||
]
|
||
TERMIN
|
||
|
||
$INSRT SYS:FASDFS
|
||
|
||
] ;END OF IF1
|
||
|
||
VERPRT SORT
|
||
|
||
;;; THIS ROUTINE IS A "SORT DRIVER". IT TAKES AN ARRAY AND THE ADDRESSES
|
||
;;; OF FIVE MANIPULATIVE FUNCTIONS, AND USES THE FUNCTIONS TO SORT THE
|
||
;;; CONTENTS OF THE ARRAY. IT IS CALLED AS FOLLOWS:
|
||
;;; JSP AR2A,SORT1 ;POINTER TO SAR0 OF ARRAY IS IN AR1
|
||
;;; XXXGET ;ARRAY FETCH FUNCTION
|
||
;;; XXXPUT ;ARRAY STORE FUNCTION
|
||
;;; XXXMOV ;INTRA-ARRAY TRANSFER FUNCTION
|
||
;;; XXXCKA ;COMPARE K WITH ARRAY ITEM
|
||
;;; XXXCAK ;COMPARE ARRAY ITEM WITH K
|
||
;;; XXXTRYI ;TRY TO LET AN INTERRUPT HAPPEN (NON-BIBOP)
|
||
;;; ... ;RETURN HERE
|
||
;;; CONCEPTUALLY THERE IS AN ACCUMULATOR CALLED "K" WHICH THE SUPPLIED
|
||
;;; FUNCTIONS OPERATE ON. XXXGET PUTS THE ARRAY ITEM WHOSE INDEX IS IN
|
||
;;; TT AND PLACES IT IN K. XXXPUT STORES K INTO THE ARRAY LOCATION
|
||
;;; WHOSE INDEX IS IN TT. XXXMOV TRANSFERS AN ARRAY ITEM (INDEX IN TT)
|
||
;;; TO ANOTHER ARRAY LOCATION (INDEX IN D) WITHOUT AFFECTING K.
|
||
;;; XXXCKA SKIPS UNLESS K IS STRICTLY LESS THAN THE ARRAY ITEM (INDEX
|
||
;;; IN TT). XXXCAK SKIPS UNLESS THE ARRAY ITEM (INDEX IN TT) IS STRICTLY
|
||
;;; LESS THAN K. (IN THE LAST TWO SENTENCES, "STRICTLY LESS THAN" MEANS
|
||
;;; "UNEQUAL, AND IN CORRECT SORTING ORDER (AS DEFINED BY SOME
|
||
;;; PREDICATE)". THE PREDICATE USED TO DETERMINE THIS CAN BE ARBITRARY,
|
||
;;; BUT HOPEFULLY WILL IMPOSE SOME MEANINGFUL ORDERING ON THE ITEMS IN
|
||
;;; THE ARRAY.)
|
||
;;; THE FIVE FUNCTIONS ARE ALL CALLED VIA PUSHJ P,; THE SORT DRIVER
|
||
;;; DOES NOT PUSH ANYTHING ELSE ON THE REGULAR PDL, AND THE CALLER MAY
|
||
;;; DEPEND ON THIS FACT TO PASS INFORMATION TO THE FIVE FUNCTIONS. THE
|
||
;;; FIVE FUNCTIONS MAY DESTROY ANY ARRAY INDICES THEY ARE GIVEN; BUT
|
||
;;; AR1, AR2A, D (EXCEPT FOR SRTMOV), R, AND F MUST BE PRESERVED.
|
||
;;; A, B, C, T, AND TT MAY BE USED FREELY. THE SORT DRIVER DOES NOT
|
||
;;; USE A, B, AND C AT ALL, AND IT USES T ONLY WHEN IT DOES NOT WANT
|
||
;;; WHAT IS IN K; HENCE THESE FOUR MAY BE USED BY THE FIVE FUNCTIONS
|
||
;;; TO REPRESENT K.
|
||
;;; THE ALGORITHM USED IS C.A.R. HOARE'S "QUICKSORT", AS DESCRIBED BY
|
||
;;; D.E. KNUTH IN HIS "THE ART OF COMPUTER PROGRAMMING, VOLUME 3, SORTING
|
||
;;; AND SEARCHING" (ADDISON-WESLEY, 1973), PAGES 114-123 (Q.V.). THE
|
||
;;; ALGORITHM HAS BEEN MODIFIED USING THE SUGGESTION KNUTH MAKES ON PAGE
|
||
;;; 122 OF USING RANDOM NUMBERS TO SELECT SUCCESSIVE TEST KEYS, IN ORDER
|
||
;;; TO AVOID SUCH WORST CASES AS AN ALREADY SORTED ARRAY!
|
||
;;; DETAILS OF THIS IMPLEMENTATION: ACS R AND F CORRESPOND GENERALLY TO
|
||
;;; I AND J OF THE ALGORITHM AS KNUTH PRESENTS IT. THE ARRAY INDICES GO
|
||
;;; FROM 0 TO N-1 RATHER THAN 1 TO N; THIS IS A TRIVIAL MODIFICATION OF
|
||
;;; STEP 1. BOUNDARY CONDITIONS ARE DETECTED IN A SLIGHTLY DIFFERENT
|
||
;;; MANNER FROM KNUTH'S, WHICH INVOLVES HAVING A DUMMY KEY AT EACH END
|
||
;;; OF THE ARRAY; THE METHOD USED HERE REDUCES THE NUMBER OF
|
||
;;; COMPARISONS AND AVOIDS THE PROBLEM OF DETERMINING EXACTLY WHAT
|
||
;;; <-INFINITY> AND <INFINITY> SHOULD BE FOR A PARTICULAR PREDICATE.
|
||
;;; (REMEMBER, THIS SORT DRIVER WILL OPERATE WITH ANY ARBITRARY
|
||
;;; ORDERING PREDICATE; FURTHERMORE, FOR MANY PREDICATES (E.G. ALPHALESSP)
|
||
;;; CREATING AN INFINITE KEY IS IMPRACTICAL IF NOT IMPOSSIBLE.) THE
|
||
;;; CURRENT (L,R) PAIR IS KEPT ON THE STACK (HERE REPRESENTED BY THE
|
||
;;; FIXNUM PDL) AS WELL AS OTHER (L,R) PAIRS: THE PAIR ON TOP IS THE
|
||
;;; CURRENT PAIR, AND THE REST ARE BELOW IT. THE VALUE M IN KNUTH'S
|
||
;;; ALGORITHM IS HERE A PARAMETER CALLED SORTM.
|
||
;;; THE LABELS IN THIS IMPLEMENTATION CORRESPOND IN THE OBVIOUS WAY
|
||
;;; TO THE STEP NUMBERS IN KNUTH'S DESCRIPTION OF THE ALGORITHM.
|
||
|
||
SORTM==10 ;SMALLEST SUBFILE NOT TO USE INSERTION SORT ON
|
||
|
||
IRPS OP,F,[GET-PUT-MOV-KAC-AKC-RETURN]
|
||
IFSE F,-, SORT!OP=<PUSHJ P,@.IRPCNT(AR2A)>
|
||
IFSN F,-, SORT!OP=<JRST .IRPCNT(AR2A)>
|
||
TERMIN
|
||
|
||
;;; MAIN SORT DRIVER - POINTER TO SAR0 OF ARRAY IN AR1
|
||
|
||
SORT1: PUSH FXP,.+1 ;ANYTHING NEGATIVE WILL DO (HRRZI = 551_33)
|
||
HRRZI TT,-1
|
||
MOVE T,@TTSAR(AR1)
|
||
SUBI T,1 ;LARGEST VALID ARRAY INDEX
|
||
PUSH FXP,T ;R <- N-1
|
||
PUSH FXP,R70" ;L <- 0
|
||
SORT2: MOVE R,(FXP) ;I <- L
|
||
MOVE F,-1(FXP) ;J <- R
|
||
CAIGE F,SORTM(R)
|
||
JRST SORT8 ;R-L < M -- USE INSERTION SORT
|
||
MOVEI T,0
|
||
NCALL 16,.FUNCTION RANDOM
|
||
MOVE R,(FXP) ;RANDOM CLOBBERS R,F
|
||
MOVE F,-1(FXP)
|
||
TLZ TT,400000
|
||
MOVEI D,1(F)
|
||
SUBI D,(R)
|
||
IDIVI T,(D)
|
||
ADDI TT,(R) ;Q <- RANDOM BETWEEN L AND R
|
||
MOVEI D,(TT)
|
||
SORTGET ;K <- ARRAY(Q) ;PRESERVES D!!!
|
||
MOVEI TT,(R)
|
||
SORTMOV ;ARRAY(Q) <- ARRAY(L)
|
||
MOVEI TT,(R)
|
||
SORTPUT ;ARRAY(L) <- K
|
||
SORT3: CAMG F,(FXP) ;MUSTN'T RUN OFF END OF SUBFILE
|
||
JRST SORT4
|
||
MOVEI TT,(F) ;WHILE K < ARRAY(J) DO J <- J-1;
|
||
SORTKAC
|
||
SOJA F,SORT3
|
||
SORT4: CAIGE R,(F)
|
||
JRST SORT4A
|
||
MOVEI TT,(R) ;I >= J
|
||
SORTPUT ;ARRAY(J) <- K
|
||
JRST SORT7
|
||
|
||
|
||
SORT4A: MOVEI TT,(F) ;I < J
|
||
MOVEI D,(R)
|
||
SORTMOV ;ARRAY(I) <- ARRAY(J)
|
||
ADDI R,1 ;I <- I+1
|
||
SORT5: CAML R,-1(FXP) ;BOUNDARY CASE
|
||
JRST SORT6
|
||
MOVEI TT,(R) ;WHILE ARRAY(I) < K DO I <- I-1;
|
||
SORTAKC
|
||
AOJA R,SORT5
|
||
SORT6: CAIL R,(F)
|
||
JRST SORT6A
|
||
MOVEI TT,(R) ;I < J
|
||
MOVEI D,(F) ;ARRAY(J) <- ARRAY(I)
|
||
SORTMOV
|
||
SOJA F,SORT3 ;J <- J-1
|
||
SORT6A: MOVEI TT,(F) ;I >= J
|
||
SORTPUT ;ARRAY(J) <- K
|
||
MOVEI R,(F) ;I <- J
|
||
SORT7: CAMN R,(FXP) ;LOSING BOUNDARY CASES
|
||
JRST SORT7B ; KNUTH DIDN'T MENTION!!!
|
||
CAMN R,-1(FXP)
|
||
JRST SORT7C
|
||
PUSH FXP,-1(FXP) ;COPY (L,R) PAIR ONTO STACK
|
||
PUSH FXP,-1(FXP)
|
||
MOVEI T,(R)
|
||
ADDI T,(R)
|
||
SUB T,(FXP) ;2*I-L
|
||
MOVEI TT,-1(R)
|
||
MOVEI D,1(R)
|
||
CAMLE T,-1(FXP)
|
||
JRST SORT7A
|
||
MOVEM D,-2(FXP) ;2*I-L <= R
|
||
MOVEM TT,-1(FXP) ;(I+1,R) ON STACK
|
||
JRST SORT2 ;R <- I-1
|
||
|
||
SORT7A: MOVEM TT,-3(FXP) ;2*I-L > R
|
||
MOVEM D,(FXP) ;(L,I-1) ON STACK
|
||
JRST SORT2 ;L <- I+1
|
||
|
||
SORT7B: AOSA (FXP)
|
||
SORT7C: SOS -1(FXP)
|
||
JRST SORT2
|
||
|
||
|
||
|
||
SORT8: CAIN R,(F) ;INSERTION SORT
|
||
JRST SORT9
|
||
MOVEI F,1(R)
|
||
SORT8A: MOVEI TT,(F)
|
||
SORTGET
|
||
MOVEI R,-1(F)
|
||
MOVEI TT,(R)
|
||
JRST SORT8C
|
||
|
||
SORT8B: MOVEI TT,(R)
|
||
MOVEI D,1(R)
|
||
SORTMOV
|
||
SOS TT,R
|
||
CAMGE R,(FXP)
|
||
JRST SORT8D
|
||
SORT8C: SORTKAC
|
||
JRST SORT8B
|
||
SORT8D: MOVEI TT,1(R)
|
||
SORTPUT
|
||
CAMGE F,-1(FXP)
|
||
AOJA F,SORT8A
|
||
SORT9: SUB FXP,R70+2 ;POP CURRENT (L,R) PAIR
|
||
SKIPL (FXP) ;SKIP IF DONE
|
||
JRST SORT2 ;ELSE GO SORT ANOTHER SUBFILE
|
||
POP FXP,T ;POP STACK MARKER
|
||
SORTRETURN ;ALL DONE - HOORAY!!!
|
||
|
||
|
||
;;; FOR LISTS, WE USE A WINNING MERGE SORT WHICH DOES MANY RPLACD'S
|
||
;;; TO GET THE LIST IN ORDER. THIS ALGORITHM WAS ORIGINALLY
|
||
;;; CODED IN LISP BY MJF, AND TRANSCRIBED INTO MIDAS BY GLS.
|
||
;;; IT OPERATES BY CONSIDERING THE GIVEN LIST TO BE THE FRONTIER
|
||
;;; OF A (POSSIBLY INCOMPLETE) BINARY TREE, AND AT EACH NODE
|
||
;;; MERGES THE TWO NODES BELOW IT. INSTEAD OF THE USUAL METHOD
|
||
;;; OF MERGING ALL PAIRS, THEN ALL PAIRS OF PAIRS, ETC., THIS
|
||
;;; IMPLEMENTATION EFFECTIVELY DOES A SUFFIX WALK OVER THE BINARY
|
||
;;; TREE (THUS IT CAN GRAB ITEMS SEQUENTIALLY OFF THE GIVEN LIST.)
|
||
;;; WARNING: LIKE DELQ AND OTHERS, THE SAFE WAY TO USE THIS
|
||
;;; FUNCTION IS (SETQ FOO (ALPHASORT FOO)) OR WHATEVER.
|
||
;;; TO ILLUMINATE THE MACHINATIONS OF THE HACKISH CODE BELOW,
|
||
;;; A MODIFIED FORM OF THE LISP ENCODING IS HERE GIVEN.
|
||
;;;
|
||
;;; (DECLARE (SPECIAL LESSP-PREDICATE F C))
|
||
;;;
|
||
;;; (DEFUN MSORT (C LESSP-PREDICATE)
|
||
;;; (DO ((TT -1 (1+ TT))
|
||
;;; (S)
|
||
;;; (F (CONS NIL)))
|
||
;;; ((NULL C) S)
|
||
;;; (SETQ S (MMERGE S (MPREFX TT)))))
|
||
;;;
|
||
;;; (DEFUN MPREFX (TT)
|
||
;;; (COND ((NULL C) NIL)
|
||
;;; ((< TT 1)
|
||
;;; (RPLACD (PROG2 NIL C (SETQ C (CDR C))) NIL))
|
||
;;; ((MMERGE (MPREFX (1- TT)) (MPREFX (1- TT))))))
|
||
;;;
|
||
;;; (DEFUN MMERGE (AR1 AR2A)
|
||
;;; (PROG (R)
|
||
;;; (SETQ R F)
|
||
;;; A (COND ((NULL AR1) (RPLACD R AR2A) (RETURN (CDR F)))
|
||
;;; ((NULL AR2A) (RPLACD R AR1) (RETURN (CDR F)))
|
||
;;; ((FUNCALL LESSP-PREDICATE (CAR AR2A) (CAR AR1))
|
||
;;; (RPLACD R (SETQ R AR2A))
|
||
;;; (SETQ AR2A (CDR AR2A)))
|
||
;;; (T (RPLACD R (SETQ R AR1))
|
||
;;; (SETQ AR1 (CDR AR1))))
|
||
;;; (GO A)))
|
||
|
||
|
||
.ENTRY SORT SUBR 000003
|
||
SORT: MOVE T,[SORTFN,,MSORTFN]
|
||
CAIN B,.ATOM ALPHALESSP
|
||
MOVE T,[AALPHALESSP,,MALPHALESSP]
|
||
JRST ASORT1
|
||
|
||
.ENTRY SORTCAR SUBR 000003
|
||
SORTCAR: MOVE T,[SORTCFN,,MSORTCFN]
|
||
CAIN B,.ATOM ALPHALESSP
|
||
MOVE T,[ALPCAR,,MALPCAR]
|
||
ASORT1: HRLI B,(CALL 2,)
|
||
JUMPE A,CCPOPJ
|
||
PUSH P,A ;SAVE A ON STACK (TO PROTECT IF ARRAY)
|
||
PUSH P,T ;SAVE ADDRESS OF PREDICATE HANDLER
|
||
PUSH P,B ;SAVE CALL 2, ON STACK FOR SORT/SORTCAR
|
||
MOVE B,A
|
||
CALL 1,.FUNCTION ATOM
|
||
EXCH A,B
|
||
JUMPN B,KWIKSORT ;HMM... MUST BE AN ARRAY, USE QUICKSORT
|
||
MSORT: HRRZS -1(P) ;WANT PREDICATE HANDLER FROM RH OF T
|
||
PUSH P,. ;RANDOM GC-PROTECTED SLOT FOR MMERGE
|
||
SETZM -3(P) ;DON'T NEED TO PROTECT ARG - USE SLOT
|
||
SETO TT, ; TO REPRESENT S
|
||
MOVEI C,(A)
|
||
MOVEI F,(P) ;F POINTS TO PDL FROBS FOR US
|
||
MSORT1: PUSHJ P,MPREFX
|
||
MOVE AR1,-3(F)
|
||
PUSHJ P,MMERGE
|
||
MOVEM AR2A,-3(F)
|
||
ADDI TT,1
|
||
JUMPN C,MSORT1
|
||
SUB P,R70+3
|
||
SOPOPAJ: POP P,A
|
||
POPJ P,
|
||
|
||
MALPCAR: HLRZ A,(A)
|
||
HLRZ B,(B)
|
||
MALPHALESSP: PUSH FXP,TT ;ALPHALESSP, BUT SAVES TT, R AND F
|
||
PUSH FXP,R
|
||
PUSH FXP,F
|
||
CALL 2,.FUNCTION ALPHALESSP
|
||
POP FXP,F
|
||
POP FXP,R
|
||
POP FXP,TT
|
||
POPJ P,
|
||
|
||
ALPCAR: HLRZ A,(A)
|
||
HLRZ B,(B)
|
||
AALPHALESSP: JCALL 2,.FUNCTION ALPHALESSP
|
||
|
||
|
||
|
||
MPREFX: MOVEI AR2A,(C)
|
||
MPREF2: JUMPE C,MPREF9
|
||
JUMPG TT,MPREF4
|
||
HRRZ C,(C)
|
||
HLLZS (AR2A)
|
||
MPREF9: POPJ P,
|
||
MPREF4: SUBI TT,1 ;DECREMENT TT FOR CALLS TO MPREFX
|
||
PUSHJ P,MPREF2
|
||
PUSH P,AR2A
|
||
PUSHJ P,MPREFX
|
||
POP P,AR1
|
||
ADDI TT,1 ;INCR TT, AND FALL INTO MMERGE
|
||
MMERGE: MOVEI R,(F)
|
||
JUMPE AR2A,MMERG3
|
||
JRST MMERG1
|
||
|
||
MMERG4: HRRM AR1,(R)
|
||
MOVEI R,(AR1)
|
||
HRRZ AR1,(AR1)
|
||
MMERG1: JUMPN AR1,MMERG2
|
||
HRRM AR2A,(R)
|
||
HRRZ AR2A,(F)
|
||
POPJ P,
|
||
|
||
MMERG2: HLRZ A,(AR2A)
|
||
HLRZ B,(AR1)
|
||
PUSHJ P,@-2(F)
|
||
JUMPE A,MMERG4
|
||
HRRM AR2A,(R)
|
||
MOVEI R,(AR2A)
|
||
HRRZ AR2A,(AR2A)
|
||
JUMPN AR2A,MMERG2
|
||
MMERG3: HRRM AR1,(R)
|
||
HRRZ AR2A,(F)
|
||
POPJ P,
|
||
|
||
MSORTCFN: HLRZ A,(A) ;TAKE CAR OF BOTH ITEMS
|
||
HLRZ B,(B)
|
||
MSORTFN: PUSH P,C ;SAVE UP ACS
|
||
PUSH P,AR1
|
||
PUSH P,AR2A
|
||
PUSH FXP,TT
|
||
PUSH FXP,R
|
||
PUSH FXP,F
|
||
XCT -1(F) ;CALL PREDICATE (MAYBE IT GETS SMASHED)
|
||
POP FXP,F ;RESTORE ACS
|
||
POP FXP,R
|
||
POP FXP,TT
|
||
POP P,AR2A
|
||
POP P,AR1
|
||
POP P,C
|
||
POPJ P,
|
||
|
||
|
||
KWIKSORT: HLRZS -1(P) ;WANT PREDICATE HANDLER FROM LH OF T
|
||
PUSHJ P,AREGET ;GET SAR0
|
||
MOVEI AR1,(A)
|
||
JSP AR2A,SORT1 ;MOBY SORT!!!
|
||
ASRGET
|
||
ASRPUT
|
||
ASRMOV
|
||
ASRCKA
|
||
ASRCAK
|
||
SUB P,R70+2 ;POP JUNK
|
||
JRST SOPOPAJ ;RETURN FIRST ARG
|
||
|
||
ASRGET: ROT TT,-1 ;FETCH FROM S-EXP ARRAY
|
||
JUMPL TT,ASRGT1 ;USE C TO REPRESENT K
|
||
HLRZ C,@TTSAR(AR1)
|
||
CSORTFN: POPJ P,SORTFN
|
||
ASRGT1: HRRZ C,@TTSAR(AR1)
|
||
POPJ P,
|
||
|
||
ASRPUT: ROT TT,-1 ;STORE INTO S-EXP ARRAY
|
||
JUMPL TT,ASRPT1 ;USE C TO REPRESENT K
|
||
HRLM C,@TTSAR(AR1)
|
||
POPJ P,
|
||
ASRPT1: HRRM C,@TTSAR(AR1)
|
||
POPJ P,
|
||
|
||
ASRMOV: ROTC TT,-1 ;FIRST FETCH...
|
||
JUMPGE D,ASRMV1 ; (WITHOUT DISTURBING C!!!)
|
||
SKIPA T,@TTSAR(AR1)
|
||
ASRMV1: HLRZ T,@TTSAR(AR1)
|
||
EXCH TT,D
|
||
JUMPL D,ASRMV2 ;THEN STORE
|
||
HRLM T,@TTSAR(AR1)
|
||
POPJ P,
|
||
ASRMV2: HRRM T,@TTSAR(AR1)
|
||
POPJ P,
|
||
|
||
|
||
ASRCKA: TLOA AR2A,1 ;COMPARE K TO ARRAY
|
||
ASRCAK: TLZ AR2A,1 ;COMPARE ARRAY TO K
|
||
ROT TT,-1
|
||
JUMPL TT,ASRCK1 ;FETCH ARRAY ITEM INTO A
|
||
HLRZ A,@TTSAR(AR1)
|
||
JRST ASRCK2
|
||
ASRCK1: HRRZ A,@TTSAR(AR1)
|
||
ASRCK2: MOVEI B,(C) ;PUT K INTO B
|
||
TLNE AR2A,1
|
||
EXCH A,B ;MAYBE INVERT ORDER OF COMPARISON
|
||
PUSHJ P,@-2(P) ;COMPARE (MUST PRESERVE C,AR1,AR2A,R,F)
|
||
SKIPN A ;SKIP UNLESS COMPARE WAS TRUE
|
||
AOS (P)
|
||
POPJ P,
|
||
|
||
|
||
;;; PDL STRUCTURE ON ENTRY TO SORTFN
|
||
;;; ... ;FIRST ARG OF SORT/SORTCAR
|
||
;;; SORTFN ;OR MAYBE SORTCFN
|
||
;;; CALL 2,PREDFN ;USER SUPPLIED FN
|
||
;;; ... ;(NON-BIBOP ONLY) FAKE SAR0
|
||
;;; ... ;RETURN ADDRESS FROM SORT1
|
||
;;; ... ;RETURN ADDRESS FROM ASRCKA/ASRCAK
|
||
|
||
SORTCFN: HLRZ A,(A) ;FOR SORTCAR, TAKE CAR OF EACH ITEM
|
||
HLRZ B,(B)
|
||
SORTFN: PUSH P,C ;SAVE ACS
|
||
PUSH P,AR1
|
||
PUSH P,AR2A
|
||
PUSH FXP,R
|
||
PUSH FXP,F
|
||
XCT -5(P) ;XCT THE CALL 2, ON THE STACK
|
||
POP FXP,F ;RESTORE ACS
|
||
POP FXP,R
|
||
POP P,AR2A
|
||
POP P,AR1
|
||
POP P,C
|
||
POPJ P,
|
||
|
||
|
||
IFN 0,[ ;FOR NEW ARRAY SCHEME ONLY!!!
|
||
IFN BIBOP,[
|
||
|
||
;;; ***** THIS CODE LOSES GROSSLY - NEED TO RETHINK WHOLE MESS *****
|
||
|
||
NUMSORT: PUSH P,A ;SAVE FIRST ARG
|
||
MOVEI AR2A,(B) ;SAVE SECOND ARG IN AR2A
|
||
PUSHJ P,AREGET ;GET SAR0 OF ARRAY
|
||
SKIPN A,AR2A ;MAYBE THE SECOND ARG IS ALSO AN ARRAY?
|
||
JRST NSR1
|
||
PUSH P,A ;YUP - SAVE IT TOO
|
||
PUSHJ P,AREGET ;GET SAR0 OF SECOND ARRAY
|
||
MOVNI TT,1
|
||
MOVE D,@(T) ;CHECK OUT LENGTHS OF ARRAYS
|
||
CAME D,@(AR1)
|
||
JRST NSRER
|
||
HRLI T,(@) ;SET @ BIT FOR DOUBLE INDIRECTION
|
||
PUSH P,T
|
||
TLO AR1,1 ;SET FLAG FOR SECOND ARRAY ARG
|
||
NSR1: JSP AR2A,SORT1 ;MOBY SORT!!!
|
||
NSRGET
|
||
NSRPUT
|
||
NSRMOV
|
||
NSRCKA
|
||
NSRCAK
|
||
POP P,A
|
||
TLNE AR1,1
|
||
SUB P,R70+1 ;IF SECOND ARG WAS ARRAY, MUST POP FIRST
|
||
POPJ P,
|
||
|
||
NSRER:
|
||
POP P,A ;CONS UP ARGS FOR FAIL-ACT
|
||
PUSHJ P,NCONS
|
||
POP P,B
|
||
PUSHJ P,XCONS
|
||
MOVEI B,.ATOM NUMSORT
|
||
PUSHJ P,XCONS
|
||
FAC [ARRAY LENGTHS DIFFER!]
|
||
|
||
|
||
;;; IFN BIBOP
|
||
|
||
;;; IFN 0 (NEW ARRAYS ONLY!)
|
||
|
||
NSRGET: MOVE T,@(AR1) ;FETCH FROM NUMBER ARRAY
|
||
TLNN AR1,1 ;USE T TO REPRESENT K
|
||
POPJ P,
|
||
ROT TT,-1 ;FOR SECOND ARRAY, DO S-EXP FETCH
|
||
JUMPL TT,NSRGT1 ;USE C AS FOR ALPHASORT
|
||
HLRZ C,@-1(P)
|
||
POPJ P,
|
||
NSRGT1: HRRZ C,@-1(P)
|
||
POPJ P,
|
||
|
||
NSRPUT: MOVEM T,@(AR1) ;STORE INTO NUMBER ARRAY
|
||
TLNN AR1,1 ;USE T TO REPRESENT K
|
||
POPJ P,
|
||
ROT TT,-1 ;FOR SECOND ARRAY, DO S-EXP STORE
|
||
JUMPL TT,NSRPT1 ;ITEM IS IN C
|
||
HRLM C,@-1(P)
|
||
POPJ P,
|
||
NSRPT1: HRRM C,@-1(P)
|
||
POPJ P,
|
||
|
||
NSRMOV: TLNN AR1,1 ;ARRAY TRANSFER - MUST NOT ALTER T OR C
|
||
JRST NSRMV3
|
||
ROT TT,-1 ;FOR SECOND ARRAY, DO S-EXP FETCH INTO B
|
||
JUMPL TT,NSRMV1
|
||
HLRZ B,@-1(P)
|
||
JRST NSRMV2
|
||
NSRMV1: HRRZ B,@-1(P)
|
||
NSRMV2: ROT TT,1
|
||
NSRMV3: MOVE TT,@(AR1) ;TRANSFER WITHIN NUMBER ARRAY
|
||
EXCH D,TT
|
||
MOVEM D,@(AR1)
|
||
TLNN AR1,1
|
||
POPJ P,
|
||
ROT TT,-1 ;MAYBE ALSO NOW DO AN S-EXP STORE FROM B
|
||
JUMPL TT,NSRMV4
|
||
HRLM B,@-1(P)
|
||
POPJ P,
|
||
NSRMV4: HRRM B,@-1(P)
|
||
POPJ P,
|
||
|
||
NSRCKA: CAML T,@(AR1) ;COMPARE K TO ARRAY
|
||
AOS (P) ;SKIP UNLESS K < ARRAY
|
||
POPJ P,
|
||
|
||
NSRCAK: CAMG T,@(AR1) ;COMPARE ARRAY TO K
|
||
AOS (P) ;SKIP UNLESS ARRAY < K
|
||
POPJ P,
|
||
|
||
] ;END OF IFN BIBOP
|
||
] ;END OF IFN 0 (NEW ARRAYS ONLY!)
|
||
|
||
|
||
FASEND
|
||
|