1 /* xllist.c - xlisp built-in list functions */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 /* CHANGE LOG
7 * --------------------------------------------------------------------
8 * 28Apr03 dm eliminate some compiler warnings
9 * 28Apr03 rbd fix check in sort routine
10 */
11
12
13 #include "xlisp.h"
14
15 /* forward declarations */
16 FORWARD LOCAL LVAL cxr(char *adstr);
17 FORWARD LOCAL LVAL nth(int carflag);
18 FORWARD LOCAL LVAL assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult);
19 FORWARD LOCAL LVAL subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult);
20 FORWARD LOCAL LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult);
21 FORWARD LOCAL LVAL map(int carflag, int valflag);
22 FORWARD LOCAL LVAL remif(int tresult);
23 FORWARD LOCAL LVAL delif(int tresult);
24 FORWARD LOCAL LVAL sortlist(LVAL list, LVAL fcn);
25 FORWARD LOCAL void splitlist(LVAL pivot, LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn);
26 FORWARD LOCAL LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger);
27
28
29 /* xcar - take the car of a cons cell */
xcar(void)30 LVAL xcar(void)
31 {
32 LVAL list;
33 list = xlgalist();
34 xllastarg();
35 return (list ? car(list) : NIL);
36 }
37
38 /* xcdr - take the cdr of a cons cell */
xcdr(void)39 LVAL xcdr(void)
40 {
41 LVAL list;
42 list = xlgalist();
43 xllastarg();
44 return (list ? cdr(list) : NIL);
45 }
46
47 /* cxxr functions */
xcaar(void)48 LVAL xcaar(void) { return (cxr("aa")); }
xcadr(void)49 LVAL xcadr(void) { return (cxr("da")); }
xcdar(void)50 LVAL xcdar(void) { return (cxr("ad")); }
xcddr(void)51 LVAL xcddr(void) { return (cxr("dd")); }
52
53 /* cxxxr functions */
xcaaar(void)54 LVAL xcaaar(void) { return (cxr("aaa")); }
xcaadr(void)55 LVAL xcaadr(void) { return (cxr("daa")); }
xcadar(void)56 LVAL xcadar(void) { return (cxr("ada")); }
xcaddr(void)57 LVAL xcaddr(void) { return (cxr("dda")); }
xcdaar(void)58 LVAL xcdaar(void) { return (cxr("aad")); }
xcdadr(void)59 LVAL xcdadr(void) { return (cxr("dad")); }
xcddar(void)60 LVAL xcddar(void) { return (cxr("add")); }
xcdddr(void)61 LVAL xcdddr(void) { return (cxr("ddd")); }
62
63 /* cxxxxr functions */
xcaaaar(void)64 LVAL xcaaaar(void) { return (cxr("aaaa")); }
xcaaadr(void)65 LVAL xcaaadr(void) { return (cxr("daaa")); }
xcaadar(void)66 LVAL xcaadar(void) { return (cxr("adaa")); }
xcaaddr(void)67 LVAL xcaaddr(void) { return (cxr("ddaa")); }
xcadaar(void)68 LVAL xcadaar(void) { return (cxr("aada")); }
xcadadr(void)69 LVAL xcadadr(void) { return (cxr("dada")); }
xcaddar(void)70 LVAL xcaddar(void) { return (cxr("adda")); }
xcadddr(void)71 LVAL xcadddr(void) { return (cxr("ddda")); }
xcdaaar(void)72 LVAL xcdaaar(void) { return (cxr("aaad")); }
xcdaadr(void)73 LVAL xcdaadr(void) { return (cxr("daad")); }
xcdadar(void)74 LVAL xcdadar(void) { return (cxr("adad")); }
xcdaddr(void)75 LVAL xcdaddr(void) { return (cxr("ddad")); }
xcddaar(void)76 LVAL xcddaar(void) { return (cxr("aadd")); }
xcddadr(void)77 LVAL xcddadr(void) { return (cxr("dadd")); }
xcdddar(void)78 LVAL xcdddar(void) { return (cxr("addd")); }
xcddddr(void)79 LVAL xcddddr(void) { return (cxr("dddd")); }
80
81 /* cxr - common car/cdr routine */
cxr(char * adstr)82 LOCAL LVAL cxr(char *adstr)
83 {
84 LVAL list;
85
86 /* get the list */
87 list = xlgalist();
88 xllastarg();
89
90 /* perform the car/cdr operations */
91 while (*adstr && consp(list))
92 list = (*adstr++ == 'a' ? car(list) : cdr(list));
93
94 /* make sure the operation succeeded */
95 if (*adstr && list)
96 xlfail("bad argument");
97
98 /* return the result */
99 return (list);
100 }
101
102 /* xcons - construct a new list cell */
xcons(void)103 LVAL xcons(void)
104 {
105 LVAL arg1,arg2;
106
107 /* get the two arguments */
108 arg1 = xlgetarg();
109 arg2 = xlgetarg();
110 xllastarg();
111
112 /* construct a new list element */
113 return (cons(arg1,arg2));
114 }
115
116 /* xlist - built a list of the arguments */
xlist(void)117 LVAL xlist(void)
118 {
119 LVAL last=NULL,next,val;
120
121 /* protect some pointers */
122 xlsave1(val);
123
124 /* add each argument to the list */
125 for (val = NIL; moreargs(); ) {
126
127 /* append this argument to the end of the list */
128 next = consa(nextarg());
129 if (val) rplacd(last,next);
130 else val = next;
131 last = next;
132 }
133
134 /* restore the stack */
135 xlpop();
136
137 /* return the list */
138 return (val);
139 }
140
141 /* xappend - built-in function append */
xappend(void)142 LVAL xappend(void)
143 {
144 LVAL list,last=NULL,next,val;
145
146 /* protect some pointers */
147 xlsave1(val);
148
149 /* initialize */
150 val = NIL;
151
152 /* append each argument */
153 if (moreargs()) {
154 while (xlargc > 1) {
155
156 /* append each element of this list to the result list */
157 for (list = nextarg(); consp(list); list = cdr(list)) {
158 next = consa(car(list));
159 if (val) rplacd(last,next);
160 else val = next;
161 last = next;
162 }
163 }
164
165 /* handle the last argument */
166 if (val) rplacd(last,nextarg());
167 else val = nextarg();
168 }
169
170 /* restore the stack */
171 xlpop();
172
173 /* return the list */
174 return (val);
175 }
176
177 /* xreverse - built-in function reverse */
xreverse(void)178 LVAL xreverse(void)
179 {
180 LVAL list,val;
181
182 /* protect some pointers */
183 xlsave1(val);
184
185 /* get the list to reverse */
186 list = xlgalist();
187 xllastarg();
188
189 /* append each element to the head of the result list */
190 for (val = NIL; consp(list); list = cdr(list))
191 val = cons(car(list),val);
192
193 /* restore the stack */
194 xlpop();
195
196 /* return the list */
197 return (val);
198 }
199
200 /* xlast - return the last cons of a list */
xlast(void)201 LVAL xlast(void)
202 {
203 LVAL list;
204
205 /* get the list */
206 list = xlgalist();
207 xllastarg();
208
209 /* find the last cons */
210 while (consp(list) && cdr(list))
211 list = cdr(list);
212
213 /* return the last element */
214 return (list);
215 }
216
217 /* xmember - built-in function 'member' */
xmember(void)218 LVAL xmember(void)
219 {
220 LVAL x,list,fcn,val;
221 int tresult;
222
223 /* protect some pointers */
224 xlsave1(fcn);
225
226 /* get the expression to look for and the list */
227 x = xlgetarg();
228 list = xlgalist();
229 xltest(&fcn,&tresult);
230
231 /* look for the expression */
232 for (val = NIL; consp(list); list = cdr(list))
233 if (dotest2(x,car(list),fcn) == tresult) {
234 val = list;
235 break;
236 }
237
238 /* restore the stack */
239 xlpop();
240
241 /* return the result */
242 return (val);
243 }
244
245 /* xassoc - built-in function 'assoc' */
xassoc(void)246 LVAL xassoc(void)
247 {
248 LVAL x,alist,fcn,pair,val;
249 int tresult;
250
251 /* protect some pointers */
252 xlsave1(fcn);
253
254 /* get the expression to look for and the association list */
255 x = xlgetarg();
256 alist = xlgalist();
257 xltest(&fcn,&tresult);
258
259 /* look for the expression */
260 for (val = NIL; consp(alist); alist = cdr(alist))
261 if ((pair = car(alist)) && consp(pair))
262 if (dotest2(x,car(pair),fcn) == tresult) {
263 val = pair;
264 break;
265 }
266
267 /* restore the stack */
268 xlpop();
269
270 /* return result */
271 return (val);
272 }
273
274 /* xsubst - substitute one expression for another */
xsubst(void)275 LVAL xsubst(void)
276 {
277 LVAL to,from,expr,fcn,val;
278 int tresult;
279
280 /* protect some pointers */
281 xlsave1(fcn);
282
283 /* get the to value, the from value and the expression */
284 to = xlgetarg();
285 from = xlgetarg();
286 expr = xlgetarg();
287 xltest(&fcn,&tresult);
288
289 /* do the substitution */
290 val = subst(to,from,expr,fcn,tresult);
291
292 /* restore the stack */
293 xlpop();
294
295 /* return the result */
296 return (val);
297 }
298
299 /* subst - substitute one expression for another */
subst(LVAL to,LVAL from,LVAL expr,LVAL fcn,int tresult)300 LOCAL LVAL subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult)
301 {
302 LVAL carval,cdrval;
303
304 if (dotest2(expr,from,fcn) == tresult)
305 return (to);
306 else if (consp(expr)) {
307 xlsave1(carval);
308 carval = subst(to,from,car(expr),fcn,tresult);
309 cdrval = subst(to,from,cdr(expr),fcn,tresult);
310 xlpop();
311 return (cons(carval,cdrval));
312 }
313 else
314 return (expr);
315 }
316
317 /* xsublis - substitute using an association list */
xsublis(void)318 LVAL xsublis(void)
319 {
320 LVAL alist,expr,fcn,val;
321 int tresult;
322
323 /* protect some pointers */
324 xlsave1(fcn);
325
326 /* get the assocation list and the expression */
327 alist = xlgalist();
328 expr = xlgetarg();
329 xltest(&fcn,&tresult);
330
331 /* do the substitution */
332 val = sublis(alist,expr,fcn,tresult);
333
334 /* restore the stack */
335 xlpop();
336
337 /* return the result */
338 return (val);
339 }
340
341 /* sublis - substitute using an association list */
sublis(LVAL alist,LVAL expr,LVAL fcn,int tresult)342 LOCAL LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult)
343 {
344 LVAL carval,cdrval,pair;
345
346 if ((pair = assoc(expr,alist,fcn,tresult)))
347 return (cdr(pair));
348 else if (consp(expr)) {
349 xlsave1(carval);
350 carval = sublis(alist,car(expr),fcn,tresult);
351 cdrval = sublis(alist,cdr(expr),fcn,tresult);
352 xlpop();
353 return (cons(carval,cdrval));
354 }
355 else
356 return (expr);
357 }
358
359 /* assoc - find a pair in an association list */
assoc(LVAL expr,LVAL alist,LVAL fcn,int tresult)360 LOCAL LVAL assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult)
361 {
362 LVAL pair;
363
364 for (; consp(alist); alist = cdr(alist))
365 if ((pair = car(alist)) && consp(pair))
366 if (dotest2(expr,car(pair),fcn) == tresult)
367 return (pair);
368 return (NIL);
369 }
370
371 /* xremove - built-in function 'remove' */
xremove(void)372 LVAL xremove(void)
373 {
374 LVAL x,list,fcn,val,last=NULL,next;
375 int tresult;
376
377 /* protect some pointers */
378 xlstkcheck(2);
379 xlsave(fcn);
380 xlsave(val);
381
382 /* get the expression to remove and the list */
383 x = xlgetarg();
384 list = xlgalist();
385 xltest(&fcn,&tresult);
386
387 /* remove matches */
388 for (; consp(list); list = cdr(list))
389
390 /* check to see if this element should be deleted */
391 if (dotest2(x,car(list),fcn) != tresult) {
392 next = consa(car(list));
393 if (val) rplacd(last,next);
394 else val = next;
395 last = next;
396 }
397
398 /* restore the stack */
399 xlpopn(2);
400
401 /* return the updated list */
402 return (val);
403 }
404
405 /* xremif - built-in function 'remove-if' */
xremif(void)406 LVAL xremif(void)
407 {
408 return (remif(TRUE));
409 }
410
411 /* xremifnot - built-in function 'remove-if-not' */
xremifnot(void)412 LVAL xremifnot(void)
413 {
414 return (remif(FALSE));
415 }
416
417 /* remif - common code for 'remove-if' and 'remove-if-not' */
remif(int tresult)418 LOCAL LVAL remif(int tresult)
419 {
420 LVAL list,fcn,val,last=NULL,next;
421
422 /* protect some pointers */
423 xlstkcheck(2);
424 xlsave(fcn);
425 xlsave(val);
426
427 /* get the expression to remove and the list */
428 fcn = xlgetarg();
429 list = xlgalist();
430 xllastarg();
431
432 /* remove matches */
433 for (; consp(list); list = cdr(list))
434
435 /* check to see if this element should be deleted */
436 if (dotest1(car(list),fcn) != tresult) {
437 next = consa(car(list));
438 if (val) rplacd(last,next);
439 else val = next;
440 last = next;
441 }
442
443 /* restore the stack */
444 xlpopn(2);
445
446 /* return the updated list */
447 return (val);
448 }
449
450 /* dotest1 - call a test function with one argument */
dotest1(LVAL arg,LVAL fun)451 int dotest1(LVAL arg, LVAL fun)
452 {
453 LVAL *newfp;
454
455 /* create the new call frame */
456 newfp = xlsp;
457 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
458 pusharg(fun);
459 pusharg(cvfixnum((FIXTYPE)1));
460 pusharg(arg);
461 xlfp = newfp;
462
463 /* return the result of applying the test function */
464 return (xlapply(1) != NIL);
465
466 }
467
468 /* dotest2 - call a test function with two arguments */
dotest2(LVAL arg1,LVAL arg2,LVAL fun)469 int dotest2(LVAL arg1, LVAL arg2, LVAL fun)
470 {
471 LVAL *newfp;
472
473 /* create the new call frame */
474 newfp = xlsp;
475 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
476 pusharg(fun);
477 pusharg(cvfixnum((FIXTYPE)2));
478 pusharg(arg1);
479 pusharg(arg2);
480 xlfp = newfp;
481
482 /* return the result of applying the test function */
483 return (xlapply(2) != NIL);
484
485 }
486
487 /* xnth - return the nth element of a list */
xnth(void)488 LVAL xnth(void)
489 {
490 return (nth(TRUE));
491 }
492
493 /* xnthcdr - return the nth cdr of a list */
xnthcdr(void)494 LVAL xnthcdr(void)
495 {
496 return (nth(FALSE));
497 }
498
499 /* nth - internal nth function */
nth(int carflag)500 LOCAL LVAL nth(int carflag)
501 {
502 LVAL list,num;
503 FIXTYPE n;
504
505 /* get n and the list */
506 num = xlgafixnum();
507 list = xlgacons();
508 xllastarg();
509
510 /* make sure the number isn't negative */
511 if ((n = getfixnum(num)) < 0)
512 xlfail("bad argument");
513
514 /* find the nth element */
515 while (consp(list) && --n >= 0)
516 list = cdr(list);
517
518 /* return the list beginning at the nth element */
519 return (carflag && consp(list) ? car(list) : list);
520 }
521
522 /* xlength - return the length of a list or string */
xlength(void)523 LVAL xlength(void)
524 {
525 FIXTYPE n=0;
526 LVAL arg;
527
528 /* get the list or string */
529 arg = xlgetarg();
530 xllastarg();
531
532 /* find the length of a list */
533 if (listp(arg))
534 for (n = 0; consp(arg); n++)
535 arg = cdr(arg);
536
537 /* find the length of a string */
538 else if (stringp(arg))
539 n = (FIXTYPE)getslength(arg)-1;
540
541 /* find the length of a vector */
542 else if (vectorp(arg))
543 n = (FIXTYPE)getsize(arg);
544
545 /* otherwise, bad argument type */
546 else
547 xlerror("bad argument type",arg);
548
549 /* return the length */
550 return (cvfixnum(n));
551 }
552
553 /* xmapc - built-in function 'mapc' */
xmapc(void)554 LVAL xmapc(void)
555 {
556 return (map(TRUE,FALSE));
557 }
558
559 /* xmapcar - built-in function 'mapcar' */
xmapcar(void)560 LVAL xmapcar(void)
561 {
562 return (map(TRUE,TRUE));
563 }
564
565 /* xmapl - built-in function 'mapl' */
xmapl(void)566 LVAL xmapl(void)
567 {
568 return (map(FALSE,FALSE));
569 }
570
571 /* xmaplist - built-in function 'maplist' */
xmaplist(void)572 LVAL xmaplist(void)
573 {
574 return (map(FALSE,TRUE));
575 }
576
577 /* map - internal mapping function */
map(int carflag,int valflag)578 LOCAL LVAL map(int carflag, int valflag)
579 {
580 LVAL *newfp,fun,lists,val,last,p,x,y;
581 int argc;
582
583 /* protect some pointers */
584 xlstkcheck(3);
585 xlsave(fun);
586 xlsave(lists);
587 xlsave(val);
588
589 /* get the function to apply and the first list */
590 fun = xlgetarg();
591 lists = xlgalist();
592
593 /* initialize the result list */
594 val = (valflag ? NIL : lists);
595
596 /* build a list of argument lists */
597 for (lists = last = consa(lists); moreargs(); last = cdr(last))
598 rplacd(last,cons(xlgalist(),NIL));
599
600 /* loop through each of the argument lists */
601 for (;;) {
602 /* build an argument list from the sublists */
603 newfp = xlsp;
604 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
605 pusharg(fun);
606 pusharg(NIL);
607 argc = 0;
608 for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
609 pusharg(carflag ? car(y) : y);
610 rplaca(x,cdr(y));
611 ++argc;
612 }
613
614 /* quit if any of the lists were empty */
615 if (x) {
616 xlsp = newfp;
617 break;
618 }
619
620 /* apply the function to the arguments */
621 newfp[2] = cvfixnum((FIXTYPE)argc);
622 xlfp = newfp;
623 if (valflag) {
624 p = consa(xlapply(argc));
625 if (val) rplacd(last,p);
626 else val = p;
627 last = p;
628 }
629 else
630 xlapply(argc);
631 }
632
633 /* restore the stack */
634 xlpopn(3);
635
636 /* return the last test expression value */
637 return (val);
638 }
639
640 /* xrplca - replace the car of a list node */
xrplca(void)641 LVAL xrplca(void)
642 {
643 LVAL list,newcar;
644
645 /* get the list and the new car */
646 list = xlgacons();
647 newcar = xlgetarg();
648 xllastarg();
649
650 /* replace the car */
651 rplaca(list,newcar);
652
653 /* return the list node that was modified */
654 return (list);
655 }
656
657 /* xrplcd - replace the cdr of a list node */
xrplcd(void)658 LVAL xrplcd(void)
659 {
660 LVAL list,newcdr;
661
662 /* get the list and the new cdr */
663 list = xlgacons();
664 newcdr = xlgetarg();
665 xllastarg();
666
667 /* replace the cdr */
668 rplacd(list,newcdr);
669
670 /* return the list node that was modified */
671 return (list);
672 }
673
674 /* xnconc - destructively append lists */
xnconc(void)675 LVAL xnconc(void)
676 {
677 LVAL next,last=NULL,val;
678
679 /* initialize */
680 val = NIL;
681
682 /* concatenate each argument */
683 if (moreargs()) {
684 while (xlargc > 1) {
685
686 /* ignore everything except lists */
687 if ((next = nextarg()) && consp(next)) {
688
689 /* concatenate this list to the result list */
690 if (val) rplacd(last,next);
691 else val = next;
692
693 /* find the end of the list */
694 while (consp(cdr(next)))
695 next = cdr(next);
696 last = next;
697 }
698 }
699
700 /* handle the last argument */
701 if (val) rplacd(last,nextarg());
702 else val = nextarg();
703 }
704
705 /* return the list */
706 return (val);
707 }
708
709 /* xdelete - built-in function 'delete' */
xdelete(void)710 LVAL xdelete(void)
711 {
712 LVAL x,list,fcn,last,val;
713 int tresult;
714
715 /* protect some pointers */
716 xlsave1(fcn);
717
718 /* get the expression to delete and the list */
719 x = xlgetarg();
720 list = xlgalist();
721 xltest(&fcn,&tresult);
722
723 /* delete leading matches */
724 while (consp(list)) {
725 if (dotest2(x,car(list),fcn) != tresult)
726 break;
727 list = cdr(list);
728 }
729 val = last = list;
730
731 /* delete embedded matches */
732 if (consp(list)) {
733
734 /* skip the first non-matching element */
735 list = cdr(list);
736
737 /* look for embedded matches */
738 while (consp(list)) {
739
740 /* check to see if this element should be deleted */
741 if (dotest2(x,car(list),fcn) == tresult)
742 rplacd(last,cdr(list));
743 else
744 last = list;
745
746 /* move to the next element */
747 list = cdr(list);
748 }
749 }
750
751 /* restore the stack */
752 xlpop();
753
754 /* return the updated list */
755 return (val);
756 }
757
758 /* xdelif - built-in function 'delete-if' */
xdelif(void)759 LVAL xdelif(void)
760 {
761 return (delif(TRUE));
762 }
763
764 /* xdelifnot - built-in function 'delete-if-not' */
xdelifnot(void)765 LVAL xdelifnot(void)
766 {
767 return (delif(FALSE));
768 }
769
770 /* delif - common routine for 'delete-if' and 'delete-if-not' */
delif(int tresult)771 LOCAL LVAL delif(int tresult)
772 {
773 LVAL list,fcn,last,val;
774
775 /* protect some pointers */
776 xlsave1(fcn);
777
778 /* get the expression to delete and the list */
779 fcn = xlgetarg();
780 list = xlgalist();
781 xllastarg();
782
783 /* delete leading matches */
784 while (consp(list)) {
785 if (dotest1(car(list),fcn) != tresult)
786 break;
787 list = cdr(list);
788 }
789 val = last = list;
790
791 /* delete embedded matches */
792 if (consp(list)) {
793
794 /* skip the first non-matching element */
795 list = cdr(list);
796
797 /* look for embedded matches */
798 while (consp(list)) {
799
800 /* check to see if this element should be deleted */
801 if (dotest1(car(list),fcn) == tresult)
802 rplacd(last,cdr(list));
803 else
804 last = list;
805
806 /* move to the next element */
807 list = cdr(list);
808 }
809 }
810
811 /* restore the stack */
812 xlpop();
813
814 /* return the updated list */
815 return (val);
816 }
817
818 /* xsort - built-in function 'sort' */
xsort(void)819 LVAL xsort(void)
820 {
821 LVAL list,fcn;
822
823 /* protect some pointers */
824 xlstkcheck(2);
825 xlsave(list);
826 xlsave(fcn);
827
828 /* get the list to sort and the comparison function */
829 list = xlgalist();
830 fcn = xlgetarg();
831 xllastarg();
832
833 /* sort the list */
834 list = sortlist(list,fcn);
835
836 if (list && (ntype(list) == FREE_NODE)) {
837 stdputstr("error in sort 2");
838 }
839
840 /* restore the stack and return the sorted list */
841 xlpopn(2);
842 return (list);
843 }
844
845 /*
846 This sorting algorithm is based on a Modula-2 sort written by
847 Richie Bielak and published in the February 1988 issue of
848 "Computer Language" magazine in a letter to the editor.
849 */
850
851 /* sortlist - sort a list using quicksort */
sortlist(LVAL list,LVAL fcn)852 LOCAL LVAL sortlist(LVAL list, LVAL fcn)
853 {
854 LVAL smaller,pivot,larger;
855
856 /* protect some pointers */
857 xlstkcheck(3);
858 xlsave(smaller);
859 xlsave(pivot);
860 xlsave(larger);
861
862 /* lists with zero or one element are already sorted */
863 if (consp(list) && consp(cdr(list))) {
864 pivot = list; list = cdr(list);
865 splitlist(pivot,list,&smaller,&larger,fcn);
866 smaller = sortlist(smaller,fcn);
867 larger = sortlist(larger,fcn);
868 list = gluelists(smaller,pivot,larger);
869 }
870
871 /* cleanup the stack and return the sorted list */
872 xlpopn(3);
873 return (list);
874 }
875
876 /* splitlist - split the list around the pivot */
splitlist(LVAL pivot,LVAL list,LVAL * psmaller,LVAL * plarger,LVAL fcn)877 LOCAL void splitlist(LVAL pivot, LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn)
878 {
879 LVAL next;
880
881 xlprot1(list); // protect list from gc
882 // the rplacd disconnects list, and next is the only
883 // reference to it, but next is immediately assigned to list
884 // before dotest2 which is where gc might run.
885
886 /* initialize the result lists */
887 *psmaller = *plarger = NIL;
888
889 /* split the list */
890 for (; consp(list); list = next) {
891 next = cdr(list);
892 if (dotest2(car(list),car(pivot),fcn)) {
893 rplacd(list,*psmaller);
894 *psmaller = list;
895 }
896 else {
897 rplacd(list,*plarger);
898 *plarger = list;
899 }
900 }
901 xlpop();
902 }
903
904 /* gluelists - glue the smaller and larger lists with the pivot */
gluelists(LVAL smaller,LVAL pivot,LVAL larger)905 LOCAL LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger)
906 {
907 LVAL last;
908
909 /* larger always goes after the pivot */
910 rplacd(pivot,larger);
911
912 /* if the smaller list is empty, we're done */
913 if (null(smaller)) return (pivot);
914
915 /* append the smaller to the front of the resulting list */
916 for (last = smaller; consp(cdr(last)); last = cdr(last))
917 ;
918 rplacd(last,pivot);
919
920 return (smaller);
921 }
922