source: project/misc-extn/trunk/misc-extn-list-support.scm @ 5437

Last change on this file since 5437 was 5437, checked in by Kon Lovett, 14 years ago

Release 3.0, where misc-extn.scm is rmvd & macros split into sep files.

File size: 3.4 KB
Line 
1;;;; misc-extn-list-support.scm
2;;;; Kon Lovett, Jul '07
3
4(use srfi-1)
5
6(eval-when (compile)
7  (declare
8    (fixnum)
9    (inline)
10    (no-procedure-checks)
11    (no-bound-checks)
12    (export
13      length=0? length=1? length=2? length>1?
14      ensure-list
15      not-null?
16      alist-inverse-ref alist-delete* alist-delete-first unzip-alist
17      filter-rest-argument!) ) )
18
19;;;
20
21;; List of length = 0?
22
23(define length=0? null?)
24
25;; List of length = 1?
26
27(define (length=1? lst)
28  (and (pair? lst) (null? (cdr lst))) )
29
30;; List of length = 2?
31
32(define (length=2? lst)
33  (and (pair? lst) (pair? (cdr lst)) (null? (cddr lst))) )
34
35;; List of length > 1?
36
37(define (length>1? lst)
38  (and (pair? lst) (pair? (cdr lst))) )
39
40;; Returns a list
41
42(define (ensure-list obj)
43  (if (list? obj) obj (list obj)) )
44
45;; Returns #f if given list is empty and the list itself otherwise
46;; It is intended for emulation of MIT-style empty list treatment
47;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>
48
49(define (not-null? lst)
50  (and (not (null? lst))
51       lst) )
52
53;; Remove any keywords & keyword-value pairs from a #!rest argument.
54
55(define (filter-rest-argument! args #!optional testarg)
56  (let* (
57      [make-pred
58        (lambda (itmtst)
59          (let ([key? #f])
60            (lambda (arg)
61              (cond
62                [key?
63                  (set! key? #f)
64                  #f]
65                [(keyword? arg)
66                  (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
67                [else
68                  #t]))))]
69      [pred
70        (cond
71          [(procedure? testarg)   testarg]
72          [(list? testarg)        (make-pred memq)]
73          [(not testarg)          (make-pred (lambda (arg lst) #t))]
74          [else
75            (error 'filter-rest-argument!
76              "test argument not a procedure or list" testarg)])])
77    (filter! pred args) ) )
78
79;; Search the alist from back to front.
80
81(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
82  (let ([cell (rassoc val alist cmp)])
83    (or (and cell (car cell)) default)))
84
85;; Remove 1st N matching elements from the alist
86
87(define (alist-delete* key al #!optional (cnt 1073741823) (cmp equal?))
88  (unless (procedure? cmp)
89    (error 'alist-delete* "compare must be a procedure" cmp))
90  (unless (integer? cnt)
91    (error 'alist-delete* "count must be an integer" cnt))
92  (let loop ([al al] [cnt cnt] [oal '()])
93    (cond
94      [(null? al)
95        (reverse! oal)]
96      [(pair? al)
97        (let ([elm (car al)]
98              [nxt (cdr al)])
99          (if (pair? elm)
100            (if (positive? cnt)
101              (if (cmp key (car elm))
102                (loop nxt (sub1 cnt) oal)
103                (loop nxt cnt (cons elm oal)))
104              (loop nxt 0 (cons elm oal)))
105            (error 'alist-delete* "improper association list item" elm)))]
106      [else
107        (error 'alist-delete* "improper association list" al)]) ) )
108
109;; Remove 1st matching elements from the alist
110
111(define (alist-delete-first key al #!optional (cmp equal?))
112  (alist-delete* key al 1 cmp) )
113
114;; Split alist into keys list & values list
115
116(define (unzip-alist alist)
117  (let loop ([alist alist] [keys '()] [vals '()])
118    (if (null? alist)
119      (values (reverse! keys) (reverse! vals))
120      (let ([elm (car alist)])
121        (if (pair? elm)
122          (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
123          (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
Note: See TracBrowser for help on using the repository browser.