;;;   **************************************************************
TITLE ***** MACLISP ****** SORT FUNCTIONS **************************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1978 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 DEFNS

]		;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
	CALL 2,.FUNCTION ALPHALESSP
	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