home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / list.scm < prev    next >
Text File  |  2000-05-02  |  29KB  |  915 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: list.scm,v 14.24 2000/05/02 20:39:37 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; List Operations
  23. ;;; package: (runtime list)
  24.  
  25. ;;; Note: Many list operations (like LIST-COPY and DELQ) have been
  26. ;;  replaced with iterative versions which are slightly longer than
  27. ;;  the recursive ones.  The iterative versions have the advantage
  28. ;;  that they are not limited by the stack size.  If you can execute
  29. ;;  (MAKE-LIST 100000) you should be able to process it.  Some
  30. ;;  machines have a problem with large stacks - Win32s as a max stack
  31. ;;  size of 128k.
  32. ;;
  33. ;;  The disadvantage of the iterative versions is that side-effects are
  34. ;;  detectable in horrible ways with CALL-WITH-CURRENT-CONTINUATION.
  35. ;;  Due to this only those procedures which call procedures known NOT
  36. ;;  to use CALL-WITH-CURRENT-CONTINUATION can be written this way, so
  37. ;;  MAP is still recursive, but LIST-COPY is iterative.  The
  38. ;;  assumption is that any other way of grabbing the continuation
  39. ;;  (e.g. the threads package via a timer interrupt) will invoke the
  40. ;;  continuation at most once.
  41. ;;
  42. ;;  We did some performance measurements.  The iterative versions were
  43. ;;  slightly faster.  These comparisons should be checked after major
  44. ;;  compiler work.
  45. ;;
  46. ;;  Each interative version appears after the commented-out recursive
  47. ;;  version.  Please leave them in the file, we may want them in the
  48. ;;  future.  We have commented them out with ;; rather than block (i.e
  49. ;;  #||#) comments deliberately.  [Note from CPH: commented-out code
  50. ;;  deleted as it can always be recovered from version control.]
  51. ;;
  52. ;;  -- Yael & Stephen
  53.  
  54. (declare (usual-integrations))
  55.  
  56. (define-primitives
  57.   cons pair? null? length car cdr set-car! set-cdr! general-car-cdr)
  58.  
  59. (define (list . items)
  60.   items)
  61.  
  62. (define (cons* first-element . rest-elements)
  63.   (let loop ((this-element first-element) (rest-elements rest-elements))
  64.     (if (pair? rest-elements)
  65.     (cons this-element
  66.           (loop (car rest-elements)
  67.             (cdr rest-elements)))
  68.     this-element)))
  69.  
  70. (define (make-list length #!optional value)
  71.   (guarantee-index/list length 'MAKE-LIST)
  72.   (let ((value (if (default-object? value) '() value)))
  73.     (let loop ((n length) (result '()))
  74.       (if (fix:zero? n)
  75.       result
  76.       (loop (fix:- n 1) (cons value result))))))
  77.  
  78. (define (circular-list . items)
  79.   (if (pair? items)
  80.       (let loop ((l items))
  81.     (if (pair? (cdr l))
  82.         (loop (cdr l))
  83.         (set-cdr! l items))))
  84.   items)
  85.  
  86. (define (make-circular-list length #!optional value)
  87.   (guarantee-index/list length 'MAKE-CIRCULAR-LIST)
  88.   (if (not (fix:zero? length))
  89.       (let ((value (if (default-object? value) '() value)))
  90.     (let ((last (cons value '())))
  91.       (let loop ((n (fix:- length 1)) (result last))
  92.         (if (zero? n)
  93.         (begin
  94.           (set-cdr! last result)
  95.           result)
  96.         (loop (fix:- n 1) (cons value result))))))
  97.       '()))
  98.  
  99. (define (make-initialized-list length initialization)
  100.   (guarantee-index/list length 'MAKE-INITIALIZED-LIST)
  101.   (let loop ((index (- length 1)) (result '()))
  102.     (if (negative? index)
  103.     result
  104.     (loop (- index 1)
  105.           (cons (initialization index) result)))))
  106.  
  107. (define (list-ref list index)
  108.   (let ((tail (list-tail list index)))
  109.     (if (not (pair? tail))
  110.     (error:bad-range-argument index 'LIST-REF))
  111.     (car tail)))
  112.  
  113. (define (list-tail list index)
  114.   (guarantee-index/list index 'LIST-TAIL)
  115.   (let loop ((list list) (index* index))
  116.     (if (fix:zero? index*)
  117.     list
  118.     (begin
  119.       (if (not (pair? list))
  120.           (error:bad-range-argument index 'LIST-TAIL))
  121.       (loop (cdr list) (fix:- index* 1))))))
  122.  
  123. (define (list-head list index)
  124.   (guarantee-index/list index 'LIST-HEAD)
  125.   (let loop ((list list) (index* index))
  126.     (if (fix:zero? index*)
  127.     '()
  128.     (begin
  129.       (if (not (pair? list))
  130.           (error:bad-range-argument index 'LIST-HEAD))
  131.       (cons (car list) (loop (cdr list) (fix:- index* 1)))))))
  132.  
  133. (define (sublist list start end)
  134.   (list-head (list-tail list start) (- end start)))
  135.  
  136. (define (list? object)
  137.   (let loop ((l1 object) (l2 object))
  138.     (if (pair? l1)
  139.     (let ((l1 (cdr l1)))
  140.       (and (not (eq? l1 l2))
  141.            (if (pair? l1)
  142.            (loop (cdr l1) (cdr l2))
  143.            (null? l1))))
  144.     (null? l1))))
  145.  
  146. (define (alist? object)
  147.   (let loop ((l1 object) (l2 object))
  148.     (if (pair? l1)
  149.     (and (pair? (car l1))
  150.          (let ((l1 (cdr l1)))
  151.            (and (not (eq? l1 l2))
  152.             (if (pair? l1)
  153.             (and (pair? (car l1))
  154.                  (loop (cdr l1) (cdr l2)))
  155.             (null? l1)))))
  156.     (null? l1))))
  157.  
  158. (define (list-copy items)
  159.   (let ((lose (lambda () (error:wrong-type-argument items "list" 'LIST-COPY))))
  160.     (cond ((pair? items)
  161.        (let ((head (cons (car items) '())))
  162.          (let loop ((list (cdr items)) (previous head))
  163.            (cond ((pair? list)
  164.               (let ((new (cons (car list) '())))
  165.             (set-cdr! previous new)
  166.             (loop (cdr list) new)))
  167.              ((not (null? list)) (lose))))
  168.          head))
  169.       ((null? items) items)
  170.       (else (lose)))))
  171.  
  172. (define (alist-copy alist)
  173.   (let ((lose
  174.      (lambda () (error:wrong-type-argument alist "alist" 'ALIST-COPY))))
  175.     (cond ((pair? alist)
  176.        (if (pair? (car alist))
  177.            (let ((head (cons (car alist) '())))
  178.          (let loop ((alist (cdr alist)) (previous head))
  179.            (cond ((pair? alist)
  180.               (if (pair? (car alist))
  181.                   (let ((new
  182.                      (cons (cons (caar alist) (cdar alist))
  183.                        '())))
  184.                 (set-cdr! previous new)
  185.                 (loop (cdr alist) new))
  186.                   (lose)))
  187.              ((not (null? alist)) (lose))))
  188.          head)
  189.            (lose)))
  190.       ((null? alist) alist)
  191.       (else (lose)))))
  192.  
  193. (define (tree-copy tree)
  194.   (let walk ((tree tree))
  195.     (if (pair? tree)
  196.     (cons (walk (car tree)) (walk (cdr tree)))
  197.     tree)))
  198.  
  199. ;;;; Weak Pairs
  200.  
  201. (define-integrable (weak-cons car cdr)
  202.   (system-pair-cons (ucode-type weak-cons) (or car weak-pair/false) cdr))
  203.  
  204. (define-integrable (weak-pair? object)
  205.   (object-type? (ucode-type weak-cons) object))
  206.  
  207. (define-integrable (weak-pair/car? weak-pair)
  208.   (system-pair-car weak-pair))
  209.  
  210. (define (weak-car weak-pair)
  211.   (let ((car (system-pair-car weak-pair)))
  212.     (and (not (eq? car weak-pair/false))
  213.      car)))
  214.  
  215. (define-integrable (weak-set-car! weak-pair object)
  216.   (system-pair-set-car! weak-pair (or object weak-pair/false)))
  217.  
  218. (define-integrable (weak-cdr weak-pair)
  219.   (system-pair-cdr weak-pair))
  220.  
  221. (define-integrable (weak-set-cdr! weak-pair object)
  222.   (system-pair-set-cdr! weak-pair object))
  223.  
  224. (define (weak-list->list items)
  225.   (let loop ((items* items))
  226.     (if (weak-pair? items*)
  227.     (let ((car (system-pair-car items*)))
  228.       (if (not car)
  229.           (loop (system-pair-cdr items*))
  230.           (cons (if (eq? car weak-pair/false) #f car)
  231.             (loop (system-pair-cdr items*)))))
  232.     (begin
  233.       (if (not (null? items*))
  234.           (error:wrong-type-argument items "weak list" 'WEAK-LIST->LIST))
  235.       '()))))
  236.  
  237. (define (list->weak-list items)
  238.   (let loop ((items* items))
  239.     (if (pair? items*)
  240.     (weak-cons (car items*) (loop (cdr items*)))
  241.     (begin
  242.       (if (not (null? items*))
  243.           (error:wrong-type-argument items "list" 'LIST->WEAK-LIST))
  244.       '()))))
  245.  
  246. (define weak-pair/false
  247.   "weak-pair/false")
  248.  
  249. (define (weak-memq object items)
  250.   (let ((object (or object weak-pair/false)))
  251.     (let loop ((items* items))
  252.       (if (weak-pair? items*)
  253.       (if (eq? object (system-pair-car items*))
  254.           items*
  255.           (loop (system-pair-cdr items*)))
  256.       (begin
  257.         (if (not (null? items*))
  258.         (error:wrong-type-argument items "weak list" 'WEAK-MEMQ))
  259.         #f)))))
  260.  
  261. (define (weak-delq! item items)
  262.   (letrec ((trim-initial-segment
  263.         (lambda (items*)
  264.           (if (weak-pair? items*)
  265.           (if (or (eq? item (system-pair-car items*))
  266.               (eq? #f (system-pair-car items*)))
  267.               (trim-initial-segment (system-pair-cdr items*))
  268.               (begin
  269.             (locate-initial-segment items*
  270.                         (system-pair-cdr items*))
  271.             items*))
  272.           (begin
  273.             (if (not (null? items*))
  274.             (error:wrong-type-argument items "weak list"
  275.                            'WEAK-MEMQ))
  276.             '()))))
  277.        (locate-initial-segment
  278.         (lambda (last this)
  279.           (if (weak-pair? this)
  280.           (if (or (eq? item (system-pair-car this))
  281.               (eq? #f (system-pair-car this)))
  282.               (set-cdr! last
  283.                 (trim-initial-segment (system-pair-cdr this)))
  284.               (locate-initial-segment this (system-pair-cdr this)))
  285.           (if (not (null? this))
  286.               (error:wrong-type-argument items "weak list"
  287.                          'WEAK-MEMQ))))))
  288.     (trim-initial-segment items)))
  289.  
  290. ;;;; Standard Selectors
  291.  
  292. (declare (integrate-operator safe-car safe-cdr))
  293.  
  294. (define (safe-car x)
  295.   (if (pair? x) (car x) (error:not-a-pair x)))
  296.  
  297. (define (safe-cdr x)
  298.   (if (pair? x) (cdr x) (error:not-a-pair x)))
  299.  
  300. (define (error:not-a-pair x)
  301.   (error:wrong-type-argument x "pair" #f))
  302.  
  303. (define (caar x) (safe-car (safe-car x)))
  304. (define (cadr x) (safe-car (safe-cdr x)))
  305. (define (cdar x) (safe-cdr (safe-car x)))
  306. (define (cddr x) (safe-cdr (safe-cdr x)))
  307.  
  308. (define (caaar x) (safe-car (safe-car (safe-car x))))
  309. (define (caadr x) (safe-car (safe-car (safe-cdr x))))
  310. (define (cadar x) (safe-car (safe-cdr (safe-car x))))
  311. (define (caddr x) (safe-car (safe-cdr (safe-cdr x))))
  312.  
  313. (define (cdaar x) (safe-cdr (safe-car (safe-car x))))
  314. (define (cdadr x) (safe-cdr (safe-car (safe-cdr x))))
  315. (define (cddar x) (safe-cdr (safe-cdr (safe-car x))))
  316. (define (cdddr x) (safe-cdr (safe-cdr (safe-cdr x))))
  317.  
  318. (define (caaaar x) (safe-car (safe-car (safe-car (safe-car x)))))
  319. (define (caaadr x) (safe-car (safe-car (safe-car (safe-cdr x)))))
  320. (define (caadar x) (safe-car (safe-car (safe-cdr (safe-car x)))))
  321. (define (caaddr x) (safe-car (safe-car (safe-cdr (safe-cdr x)))))
  322.  
  323. (define (cadaar x) (safe-car (safe-cdr (safe-car (safe-car x)))))
  324. (define (cadadr x) (safe-car (safe-cdr (safe-car (safe-cdr x)))))
  325. (define (caddar x) (safe-car (safe-cdr (safe-cdr (safe-car x)))))
  326. (define (cadddr x) (safe-car (safe-cdr (safe-cdr (safe-cdr x)))))
  327.  
  328. (define (cdaaar x) (safe-cdr (safe-car (safe-car (safe-car x)))))
  329. (define (cdaadr x) (safe-cdr (safe-car (safe-car (safe-cdr x)))))
  330. (define (cdadar x) (safe-cdr (safe-car (safe-cdr (safe-car x)))))
  331. (define (cdaddr x) (safe-cdr (safe-car (safe-cdr (safe-cdr x)))))
  332.  
  333. (define (cddaar x) (safe-cdr (safe-cdr (safe-car (safe-car x)))))
  334. (define (cddadr x) (safe-cdr (safe-cdr (safe-car (safe-cdr x)))))
  335. (define (cdddar x) (safe-cdr (safe-cdr (safe-cdr (safe-car x)))))
  336. (define (cddddr x) (safe-cdr (safe-cdr (safe-cdr (safe-cdr x)))))
  337.  
  338. (define (first x) (safe-car x))
  339. (define (second x) (safe-car (safe-cdr x)))
  340. (define (third x) (safe-car (safe-cdr (safe-cdr x))))
  341. (define (fourth x) (safe-car (safe-cdr (safe-cdr (safe-cdr x)))))
  342. (define (fifth x) (safe-car (safe-cdr (safe-cdr (safe-cdr (safe-cdr x))))))
  343.  
  344. (define (sixth x)
  345.   (safe-car (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr x)))))))
  346.  
  347. (define (seventh x)
  348.   (safe-car
  349.    (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr x))))))))
  350.  
  351. (define (eighth x)
  352.   (safe-car
  353.    (safe-cdr
  354.     (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr x)))))))))
  355.  
  356. (define (ninth x)
  357.   (safe-car
  358.    (safe-cdr
  359.     (safe-cdr
  360.      (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr x))))))))))
  361.  
  362. (define (tenth x)
  363.   (safe-car
  364.    (safe-cdr
  365.     (safe-cdr
  366.      (safe-cdr
  367.       (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr (safe-cdr x)))))))))))
  368.  
  369. ;;;; Sequence Operations
  370.  
  371. ;;; This algorithm uses a finite amount of stack and therefore half
  372. ;;; the memory of the simple recursive algorithm.  In addition, a
  373. ;;; clever compiler could optimize this into the obvious loop that
  374. ;;; everyone would write in assembly language.
  375.  
  376. (define (append . lists)
  377.   (%append lists))
  378.  
  379. (define (%append lists)
  380.   (let ((lists (reverse! lists)))
  381.     (if (pair? lists)
  382.     (let loop ((accum (car lists)) (rest (cdr lists)))
  383.       (if (pair? rest)
  384.           (loop (let ((l1 (car rest)))
  385.               (cond ((pair? l1)
  386.                  (let ((root (cons (car l1) #f)))
  387.                    (let loop ((cell root) (next (cdr l1)))
  388.                  (cond ((pair? next)
  389.                     (let ((cell* (cons (car next) #f)))
  390.                       (set-cdr! cell cell*)
  391.                       (loop cell* (cdr next))))
  392.                        ((null? next)
  393.                     (set-cdr! cell accum))
  394.                        (else
  395.                     (error:wrong-type-argument (car rest)
  396.                                    "list"
  397.                                    'APPEND))))
  398.                    root))
  399.                 ((null? l1)
  400.                  accum)
  401.                 (else
  402.                  (error:wrong-type-argument (car rest) "list"
  403.                             'APPEND))))
  404.             (cdr rest))
  405.           accum))
  406.     '())))
  407.  
  408. (define (append! . lists)
  409.   (%append! lists))
  410.  
  411. (define (%append! lists)
  412.   (if (pair? lists)
  413.       (let loop ((head (car lists)) (tail (cdr lists)))
  414.     (cond ((not (pair? tail))
  415.            head)
  416.           ((pair? head)
  417.            (set-cdr! (last-pair head) (loop (car tail) (cdr tail)))
  418.            head)
  419.           (else
  420.            (if (not (null? head))
  421.            (error:wrong-type-argument (car lists) "list" 'APPEND!))
  422.            (loop (car tail) (cdr tail)))))
  423.       '()))
  424.  
  425. (define (reverse l)
  426.   (%reverse l '()))
  427.  
  428. (define (%reverse l tail)
  429.   (let loop ((rest l) (so-far tail))
  430.     (if (pair? rest)
  431.     (loop (cdr rest) (cons (car rest) so-far))
  432.     (begin
  433.       (if (not (null? rest))
  434.           (error:wrong-type-argument l "list" '%REVERSE))
  435.       so-far))))
  436.  
  437. (define (reverse! l)
  438.   (let loop ((current l) (new-cdr '()))
  439.     (if (pair? current)
  440.     (let ((next (cdr current)))
  441.       (set-cdr! current new-cdr)
  442.       (loop next current))
  443.     (begin
  444.       (if (not (null? current))
  445.           (error:wrong-type-argument l "list" 'REVERSE!))
  446.       new-cdr))))
  447.  
  448. ;;;; Mapping Procedures
  449.  
  450. (define (map procedure first . rest)
  451.  
  452.   (define (map-1 l)
  453.     (cond ((pair? l)
  454.        (let ((head (cons (procedure (car l)) '())))
  455.          (let loop ((l (cdr l)) (previous head))
  456.            (cond ((pair? l)
  457.               (let ((new (cons (procedure (car l)) '())))
  458.             (set-cdr! previous new)
  459.             (loop (cdr l) new)))
  460.              ((not (null? l))
  461.               (bad-end))))
  462.          head))
  463.       ((null? l) '())
  464.       (else (bad-end))))
  465.  
  466.   (define (map-2 l1 l2)
  467.     (cond ((and (pair? l1) (pair? l2))
  468.        (let ((head (cons (procedure (car l1) (car l2)) '())))
  469.          (let loop ((l1 (cdr l1)) (l2 (cdr l2)) (previous head))
  470.            (cond ((and (pair? l1) (pair? l2))
  471.               (let ((new (cons (procedure (car l1) (car l2)) '())))
  472.             (set-cdr! previous new)
  473.             (loop (cdr l1) (cdr l2) new)))
  474.              ((not (and (null? l1) (null? l2)))
  475.               (bad-end))))
  476.          head))
  477.       ((and (null? l1) (null? l2)) '())
  478.       (else (bad-end))))
  479.  
  480.   (define (map-n lists)
  481.     (let ((head (cons unspecific '())))
  482.       (let loop ((lists lists) (previous head))
  483.     (if (pair? (car lists))
  484.         (do ((lists lists (cdr lists))
  485.          (cars '() (cons (caar lists) cars))
  486.          (cdrs '() (cons (cdar lists) cdrs)))
  487.         ((not (pair? lists))
  488.          (let ((new (cons (apply procedure (reverse! cars)) '())))
  489.            (set-cdr! previous new)
  490.            (loop (reverse! cdrs) new)))
  491.           (if (not (pair? (car lists)))
  492.           (bad-end)))
  493.         (do ((lists lists (cdr lists)))
  494.         ((not (pair? lists)))
  495.           (if (not (null? (car lists)))
  496.           (bad-end)))))
  497.       (cdr head)))
  498.  
  499.   (define (bad-end)
  500.     (do ((lists (cons first rest) (cdr lists)))
  501.     ((not (pair? lists)))
  502.       (if (not (list? (car lists)))
  503.       (error:wrong-type-argument (car lists) "list" 'MAP)))
  504.     (let ((n (length first)))
  505.       (do ((lists rest (cdr lists)))
  506.       ((not (pair? lists)))
  507.     (if (not (= n (length (car lists))))
  508.         (error:bad-range-argument (car lists) 'MAP)))))
  509.  
  510.   (if (pair? rest)
  511.       (if (pair? (cdr rest))
  512.       (map-n (cons first rest))
  513.       (map-2 first (car rest)))
  514.       (map-1 first)))
  515.  
  516. (let-syntax
  517.     ((mapping-procedure
  518.       (macro (name combiner initial-value procedure first rest)
  519.     `(BEGIN
  520.        (DEFINE (MAP-1 L)
  521.          (COND ((PAIR? L)
  522.             (,combiner (,procedure (CAR L))
  523.                    (MAP-1 (CDR L))))
  524.            ((NULL? L) ,initial-value)
  525.            (ELSE (BAD-END))))
  526.  
  527.        (DEFINE (MAP-2 L1 L2)
  528.          (COND ((AND (PAIR? L1) (PAIR? L2))
  529.             (,combiner (,procedure (CAR L1) (CAR L2))
  530.                    (MAP-2 (CDR L1) (CDR L2))))
  531.            ((AND (NULL? L1) (NULL? L2)) ,initial-value)
  532.            (ELSE (BAD-END))))
  533.  
  534.        (DEFINE (MAP-N LISTS)
  535.          (LET N-LOOP ((LISTS LISTS))
  536.            (IF (PAIR? (CAR LISTS))
  537.            (DO ((LISTS LISTS (CDR LISTS))
  538.             (CARS '() (CONS (CAAR LISTS) CARS))
  539.             (CDRS '() (CONS (CDAR LISTS) CDRS)))
  540.                ((NOT (PAIR? LISTS))
  541.             (,combiner (APPLY ,procedure (REVERSE! CARS))
  542.                    (N-LOOP (REVERSE! CDRS))))
  543.              (IF (NOT (PAIR? (CAR LISTS)))
  544.              (BAD-END)))
  545.            (DO ((LISTS LISTS (CDR LISTS)))
  546.                ((NOT (PAIR? LISTS)) ,initial-value)
  547.              (IF (NOT (NULL? (CAR LISTS)))
  548.              (BAD-END))))))
  549.  
  550.        (DEFINE (BAD-END)
  551.          (DO ((LISTS (CONS ,first ,rest) (CDR LISTS)))
  552.          ((NOT (PAIR? LISTS)))
  553.            (IF (NOT (LIST? (CAR LISTS)))
  554.            (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name)))
  555.          (LET ((N (LENGTH ,first)))
  556.            (DO ((LISTS ,rest (CDR LISTS)))
  557.            ((NOT (PAIR? LISTS)))
  558.          (IF (NOT (= N (LENGTH (CAR LISTS))))
  559.              (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
  560.  
  561.        (IF (PAIR? ,rest)
  562.            (IF (PAIR? (CDR ,rest))
  563.            (MAP-N (CONS ,first ,rest))
  564.            (MAP-2 ,first (CAR ,rest)))
  565.            (MAP-1 ,first))))))
  566.  
  567. (define (for-each procedure first . rest)
  568.   (mapping-procedure for-each begin unspecific procedure first rest))
  569.  
  570. ;;(define (map procedure first . rest)
  571. ;;  (mapping-procedure map cons '() procedure first rest))
  572.  
  573. (define (map* initial-value procedure first . rest)
  574.   (mapping-procedure map* cons initial-value procedure first rest))
  575.  
  576. (define (append-map procedure first . rest)
  577.   (mapping-procedure append-map append '() procedure first rest))
  578.  
  579. (define (append-map* initial-value procedure first . rest)
  580.   (mapping-procedure append-map* append initial-value procedure first rest))
  581.  
  582. (define (append-map! procedure first . rest)
  583.   (mapping-procedure append-map! append! '() procedure first rest))
  584.  
  585. (define (append-map*! initial-value procedure first . rest)
  586.   (mapping-procedure append-map*! append! initial-value procedure first rest))
  587.  
  588. ;;; end LET-SYNTAX
  589. )
  590.  
  591. (define mapcan append-map!)
  592. (define mapcan* append-map*!)
  593.  
  594. (define (reduce procedure initial list)
  595.   (if (pair? list)
  596.       (let loop ((value (car list)) (l (cdr list)))
  597.     (if (pair? l)
  598.         (loop (procedure value (car l)) (cdr l))
  599.         (begin
  600.           (if (not (null? l))
  601.           (error:wrong-type-argument list "list" 'REDUCE))
  602.           value)))
  603.       (begin
  604.     (if (not (null? list))
  605.         (error:wrong-type-argument list "list" 'REDUCE))
  606.     initial)))
  607.  
  608. (define (reduce-right procedure initial list)
  609.   (if (pair? list)
  610.       (let loop ((value (car list)) (l (cdr list)))
  611.     (if (pair? l)
  612.         (procedure value (loop (car l) (cdr l)))
  613.         (begin
  614.           (if (not (null? l))
  615.           (error:wrong-type-argument list "list" 'REDUCE-RIGHT))
  616.           value)))
  617.       (begin
  618.     (if (not (null? list))
  619.         (error:wrong-type-argument list "list" 'REDUCE-RIGHT))
  620.     initial)))
  621.  
  622. (define (fold-left procedure initial-value a-list)
  623.   (let fold ((initial-value initial-value)
  624.          (list a-list))
  625.     (if (pair? list)
  626.     (fold (procedure initial-value (car list))
  627.           (cdr list))
  628.     (begin
  629.       (if (not (null? list))
  630.           (error:wrong-type-argument a-list "list" 'FOLD-LEFT))
  631.       initial-value))))
  632.  
  633. (define (fold-right procedure initial-value a-list)
  634.   (let fold ((list a-list))
  635.     (if (pair? list)
  636.     (procedure (car list) (fold (cdr list)))
  637.     (begin
  638.       (if (not (null? list))
  639.           (error:wrong-type-argument a-list "list" 'FOLD-RIGHT))
  640.       initial-value))))
  641.  
  642. ;;;; Generalized List Operations
  643.  
  644. (define (list-transform-positive items predicate)
  645.   (let ((lose
  646.      (lambda ()
  647.        (error:wrong-type-argument items "list" 'LIST-TRANSFORM-POSITIVE))))
  648.     (cond ((pair? items)
  649.        (let ((head (cons (car items) '())))
  650.          (let loop ((items* (cdr items)) (previous head))
  651.            (cond ((pair? items*)
  652.               (if (predicate (car items*))
  653.               (let ((new (cons (car items*) '())))
  654.                 (set-cdr! previous new)
  655.                 (loop (cdr items*) new))
  656.               (loop (cdr items*) previous)))
  657.              ((not (null? items*)) (lose))))
  658.          (if (predicate (car items))
  659.          head
  660.          (cdr head))))
  661.       ((null? items) items)
  662.       (else (lose)))))
  663.  
  664. (define (list-transform-negative items predicate)
  665.   (let ((lose
  666.      (lambda ()
  667.        (error:wrong-type-argument items "list" 'LIST-TRANSFORM-NEGATIVE))))
  668.     (cond ((pair? items)
  669.        (let ((head (cons (car items) '())))
  670.          (let loop ((items* (cdr items)) (previous head))
  671.            (cond ((pair? items*)
  672.               (if (predicate (car items*))
  673.               (loop (cdr items*) previous)
  674.               (let ((new (cons (car items*) '())))
  675.                 (set-cdr! previous new)
  676.                 (loop (cdr items*) new))))
  677.              ((not (null? items*)) (lose))))
  678.          (if (predicate (car items))
  679.          (cdr head)
  680.          head)))
  681.       ((null? items) items)
  682.       (else (lose)))))
  683.  
  684. (define ((list-deletor predicate) items)
  685.   (list-transform-negative items predicate))
  686.  
  687. (define (list-deletor! predicate)
  688.   (lambda (items)
  689.     (letrec ((trim-initial-segment
  690.           (lambda (items*)
  691.         (if (pair? items*)
  692.             (if (predicate (car items*))
  693.             (trim-initial-segment (cdr items*))
  694.             (begin
  695.               (locate-initial-segment items* (cdr items*))
  696.               items*))
  697.             (begin
  698.               (if (not (null? items*))
  699.               (error:wrong-type-argument items "list" #f))
  700.               '()))))
  701.          (locate-initial-segment
  702.           (lambda (last this)
  703.         (if (pair? this)
  704.             (if (predicate (car this))
  705.             (set-cdr! last (trim-initial-segment (cdr this)))
  706.             (locate-initial-segment this (cdr this)))
  707.             (if (not (null? this))
  708.             (error:wrong-type-argument items "list" #f))))))
  709.       (trim-initial-segment items))))
  710.  
  711. (define (list-search-positive items predicate)
  712.   (let loop ((items* items))
  713.     (if (pair? items*)
  714.     (if (predicate (car items*))
  715.         (car items*)
  716.         (loop (cdr items*)))
  717.     (begin
  718.       (if (not (null? items*))
  719.           (error:wrong-type-argument items "list" 'LIST-SEARCH-POSITIVE))
  720.       #f))))
  721.  
  722. (define (list-search-negative items predicate)
  723.   (let loop ((items* items))
  724.     (if (pair? items*)
  725.     (if (predicate (car items*))
  726.         (loop (cdr items*))
  727.         (car items*))
  728.     (begin
  729.       (if (not (null? items*))
  730.           (error:wrong-type-argument items "list" 'LIST-SEARCH-NEGATIVE))
  731.       #f))))
  732.  
  733. ;;;; Membership/Association Lists
  734.  
  735. (define (initialize-package!)
  736.   (set! memv (member-procedure eqv?))
  737.   (set! member (member-procedure equal?))
  738.   (set! delv (delete-member-procedure list-deletor eqv?))
  739.   (set! delete (delete-member-procedure list-deletor equal?))
  740.   (set! delv! (delete-member-procedure list-deletor! eqv?))
  741.   (set! delete! (delete-member-procedure list-deletor! equal?))
  742.   (set! assv (association-procedure eqv? car))
  743.   (set! assoc (association-procedure equal? car))
  744.   (set! del-assq (delete-association-procedure list-deletor eq? car))
  745.   (set! del-assv (delete-association-procedure list-deletor eqv? car))
  746.   (set! del-assoc (delete-association-procedure list-deletor equal? car))
  747.   (set! del-assq! (delete-association-procedure list-deletor! eq? car))
  748.   (set! del-assv! (delete-association-procedure list-deletor! eqv? car))
  749.   (set! del-assoc! (delete-association-procedure list-deletor! equal? car))
  750.   unspecific)
  751.  
  752. (define memv)
  753. (define member)
  754. (define delv)
  755. (define delete)
  756. (define delv!)
  757. (define delete!)
  758. (define assv)
  759. (define assoc)
  760. (define del-assq)
  761. (define del-assv)
  762. (define del-assoc)
  763. (define del-assq!)
  764. (define del-assv!)
  765. (define del-assoc!)
  766.  
  767. (define (member-procedure predicate)
  768.   (lambda (item items)
  769.     (let loop ((items* items))
  770.       (if (pair? items*)
  771.       (if (predicate (car items*) item)
  772.           items*
  773.           (loop (cdr items*)))
  774.       (begin
  775.         (if (not (null? items*))
  776.         (error:wrong-type-argument items "list" #f))
  777.         #f)))))
  778.  
  779. (define (add-member-procedure predicate)
  780.   (let ((member (member-procedure predicate)))
  781.     (lambda (item items)
  782.       (if (member item items)
  783.       items
  784.       (cons item items)))))
  785.  
  786. (define ((delete-member-procedure deletor predicate) item items)
  787.   ((deletor (lambda (match) (predicate match item))) items))
  788.  
  789. (define (association-procedure predicate selector)
  790.   (lambda (key items)
  791.     (let loop ((items* items))
  792.       (if (pair? items*)
  793.       (if (predicate (selector (car items*)) key)
  794.           (car items*)
  795.           (loop (cdr items*)))
  796.       (begin
  797.         (if (not (null? items*))
  798.         (error:wrong-type-argument items "list" #f))
  799.         #f)))))
  800.  
  801. (define ((delete-association-procedure deletor predicate selector) key alist)
  802.   ((deletor (lambda (entry) (predicate (selector entry) key))) alist))
  803.  
  804. ;;; The following could be defined using the generic procedures above,
  805. ;;; but the compiler produces better code for them this way.  The only
  806. ;;; reason to use these procedures is speed, so we crank them up.
  807.  
  808. (define (memq item items)
  809.   (let loop ((items* items))
  810.     (if (pair? items*)
  811.     (if (eq? (car items*) item)
  812.         items*
  813.         (loop (cdr items*)))
  814.     (begin
  815.       (if (not (null? items*))
  816.           (error:wrong-type-argument items "list" 'MEMQ))
  817.       #f))))
  818.  
  819. (define (assq key alist)
  820.   (let loop ((alist* alist))
  821.     (if (pair? alist*)
  822.     (begin
  823.       (if (not (pair? (car alist*)))
  824.           (error:wrong-type-argument alist "alist" 'ASSQ))
  825.       (if (eq? (car (car alist*)) key)
  826.           (car alist*)
  827.           (loop (cdr alist*))))
  828.     (begin
  829.       (if (not (null? alist*))
  830.           (error:wrong-type-argument alist "alist" 'ASSQ))
  831.       #f))))
  832.  
  833. (define (delq item items)
  834.   (let ((lose (lambda () (error:wrong-type-argument items "list" 'DELQ))))
  835.     (cond ((pair? items)
  836.        (let ((head (cons (car items) '())))
  837.          (let loop ((items (cdr items)) (previous head))
  838.            (cond ((pair? items)
  839.               (if (eq? item (car items))
  840.               (loop (cdr items) previous)
  841.               (let ((new (cons (car items) '())))
  842.                 (set-cdr! previous new)
  843.                 (loop (cdr items) new))))
  844.              ((not (null? items)) (lose))))
  845.          (if (eq? item (car items))
  846.          (cdr head)
  847.          head)))
  848.       ((null? items) items)
  849.       (else (lose)))))
  850.  
  851. (define (delq! item items)
  852.   (letrec ((trim-initial-segment
  853.         (lambda (items*)
  854.           (if (pair? items*)
  855.           (if (eq? item (car items*))
  856.               (trim-initial-segment (cdr items*))
  857.               (begin
  858.             (locate-initial-segment items* (cdr items*))
  859.             items*))
  860.           (begin
  861.             (if (not (null? items*))
  862.             (error:wrong-type-argument items "list" 'DELQ!))
  863.             '()))))
  864.        (locate-initial-segment
  865.         (lambda (last this)
  866.           (if (pair? this)
  867.           (if (eq? item (car this))
  868.               (set-cdr! last (trim-initial-segment (cdr this)))
  869.               (locate-initial-segment this (cdr this)))
  870.           (if (not (null? this))
  871.               (error:wrong-type-argument items "list" 'DELQ!))))))
  872.     (trim-initial-segment items)))
  873.  
  874. ;;;; Lastness and Segments
  875.  
  876. (define (last-pair list)
  877.   (guarantee-pair list 'LAST-PAIR)
  878.   (let loop ((list list))
  879.     (if (pair? (cdr list))
  880.     (loop (cdr list))
  881.     list)))
  882.  
  883. (define (except-last-pair list)
  884.   (guarantee-pair list 'EXCEPT-LAST-PAIR)
  885.   (if (not (pair? (cdr list)))
  886.       '()
  887.       (let ((head (cons (car list) '())))
  888.     (let loop ((list* (cdr list)) (previous head))
  889.       (if (pair? (cdr list*))
  890.           (let ((new (cons (car list*) '())))
  891.         (set-cdr! previous new)
  892.         (loop (cdr list*) new))
  893.           head)))))
  894.  
  895. (define (except-last-pair! list)
  896.   (guarantee-pair list 'EXCEPT-LAST-PAIR!)
  897.   (if (pair? (cdr list))
  898.       (begin
  899.     (let loop ((list list))
  900.       (if (pair? (cdr (cdr list)))
  901.           (loop (cdr list))
  902.           (set-cdr! list '())))
  903.     list)
  904.       '()))
  905.  
  906. (define-integrable (guarantee-pair object procedure)
  907.   (if (not (pair? object))
  908.       (error:wrong-type-argument object "pair" procedure)))
  909.  
  910. (define-integrable (guarantee-index/list object procedure)
  911.   (if (not (index-fixnum? object))
  912.       (guarantee-index/list/fail object procedure)))
  913.  
  914. (define (guarantee-index/list/fail object procedure)
  915.   (error:wrong-type-argument object "valid list index" procedure))