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

Last change on this file since 6207 was 6207, checked in by Kon Lovett, 12 years ago

Bug fix for [un]zip-alist

File size: 7.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      ;; Deprecated
14      filter-rest-argument!
15      ;;
16      length=0? length=1? length=2? length>1?
17      ensure-list
18      not-null?
19      alist-inverse-ref
20      alist-delete/count alist-delete!/count
21      alist-delete-first alist-delete-first!
22      unzip-alist zip-alist
23      filter-rest-argument!
24      fixup-extended-lambda-list-rest
25      fixup-extended-lambda-list-optional
26      fixup-extended-lambda-list
27      ; Deprecated
28      alist-delete*) ) )
29
30;;;
31
32(define (check-procedure obj loc)
33  (unless (procedure? obj)
34    (error loc "invalid procedure" obj)) )
35
36(define (check-integer obj loc)
37  (unless (integer? obj)
38    (error loc "invalid integer" obj)) )
39
40;;;
41
42;; List of length = 0?
43
44(define length=0? null?)
45
46;; List of length = 1?
47
48(define (length=1? lst)
49  (= 1 (length lst)) )
50
51;; List of length = 2?
52
53(define (length=2? lst)
54  (= 2 (length lst)) )
55
56;; List of length > 1?
57
58(define (length>1? lst)
59  (< 1 (length lst)) )
60
61;; Returns a list
62
63(define (ensure-list obj)
64  (if (list? obj) obj (list obj)) )
65
66;; Returns #f if given list is empty and the list itself otherwise
67;; It is intended for emulation of MIT-style empty list treatment
68;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>
69
70(define (not-null? lst)
71  (and (not (null? lst))
72       lst) )
73
74;; Remove any keywords & keyword-value pairs from a #!rest argument.
75
76(define (filter-rest-argument! args #!optional testarg)
77  (let* (
78      [make-pred
79        (lambda (itmtst)
80          (let ([key? #f])
81            (lambda (arg)
82              (cond [key?
83                      (set! key? #f)
84                      #f]
85                    [(keyword? arg)
86                      (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
87                    [else
88                      #t]))))]
89      [pred
90        (cond [(procedure? testarg)   testarg]
91              [(list? testarg)        (make-pred memq)]
92              [(not testarg)          (make-pred (lambda (arg lst) #t))]
93              [else
94                (error 'filter-rest-argument!
95                  "test argument not a procedure or list" testarg)])])
96    (filter! pred args) ) )
97
98;; Remove any keywords & keyword-value pairs from a #!rest argument.
99
100(define (fixup-extended-lambda-list-rest keys rest #!optional (skip? #f))
101  (let loop ([rest rest] [skip? skip?] [lst '()])
102    (if (null? rest)
103        (reverse! lst)
104        (let ([arg (car rest)]
105              [nxt (cdr rest)])
106          (cond [skip?            (loop nxt #f lst)]
107                [(memq arg keys)  (loop nxt #t lst)]
108                [else             (loop nxt #f (cons arg lst))]) ) ) ) )
109
110;; Remove any keyword from #!optional argument.
111
112(define (fixup-extended-lambda-list-optional keys . opts)
113  (let loop ([opts opts] [skip? #f] [lst '()])
114    (if (null? opts)
115        (values skip? (reverse! lst))
116        (let ([opt (car opts)]
117              [nxt (cdr opts)])
118          (let ([val (car opt)]
119                [def (cadr opt)])
120            (cond [skip?            (loop nxt #f (cons def lst))]
121                  [(memq val keys)  (loop nxt #t (cons def lst))]
122                  [else             (loop nxt #f (cons val lst))]) ) ) ) ) )
123
124;; Remove any keywords & keyword-value pairs from a #!rest argument.
125
126(define (fixup-extended-lambda-list keys rest . opts)
127  (let-values ([(skip? fixed-opts) (apply fixup-extended-lambda-list-optional keys opts)])
128    (apply values (fixup-extended-lambda-list-rest keys rest skip?) fixed-opts) ) )
129
130;; Search the alist from back to front.
131
132(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
133  (let ([cell (rassoc val alist cmp)])
134    (if cell (car cell) default) ) )
135
136;; Remove 1st N matching elements from the alist [functional]
137
138(define (alist-delete/count key al #!optional (cmp eqv?) (cnt 1073741823))
139  (check-procedure cmp 'alist-delete/count)
140  (check-integer cnt 'alist-delete/count)
141  (let loop ([cal al] [cnt cnt] [oal '()])
142    (cond [(null? cal)
143            (reverse! oal)]
144          [(pair? cal)
145            (let ([elm (car cal)]
146                  [nxt (cdr cal)])
147              (if (pair? elm)
148                  (if (positive? cnt)
149                      ; then more deletion to attempt
150                      (if (cmp key (car elm))
151                          (loop nxt (sub1 cnt) oal)
152                          (loop nxt cnt (cons elm oal)))
153                      ; else copy rest of spine
154                      (loop nxt 0 (cons elm oal)))
155                  (error 'alist-delete/count "invalid association list item" elm)))]
156          [else
157            (error 'alist-delete/count "invalid association list" al)]) ) )
158
159(define (alist-delete* key al #!optional (cnt 1073741823) (cmp equal?))
160  (alist-delete/count key al cmp cnt) )
161
162;; Remove 1st N matching elements from the alist [destructive]
163
164(define (alist-delete!/count key al #!optional (cmp eqv?) (cnt 1073741823))
165  (check-procedure cmp 'alist-delete!/count)
166  (check-integer cnt 'alist-delete!/count)
167  (let ([ral al])
168    (let loop ([cal al] [pal #f] [cnt cnt])
169      (cond [(or (null? cal) (not (positive? cnt)))
170              ral]
171            [(pair? cal)
172              (let ([elm (car cal)]
173                    [nxt (cdr cal)])
174                (if (pair? elm)
175                    (cond [(cmp key (car elm))
176                            (if pal
177                                (set-cdr! pal nxt)
178                                (set! ral nxt))
179                              (loop nxt pal (sub1 cnt))]
180                           [else
181                              (loop nxt cal cnt)])
182                    (error 'alist-delete!/count "invalid association list item" elm)))]
183            [else
184              (error 'alist-delete!/count "invalid association list" al)]) ) ) )
185
186;; Remove 1st matching elements from the alist [functional]
187
188(define (alist-delete-first key al #!optional (cmp eqv?))
189  (alist-delete/count key al cmp 1) )
190
191;; Remove 1st matching elements from the alist [destructive]
192
193(define (alist-delete-first! key al #!optional (cmp eqv?))
194  (alist-delete!/count key al cmp 1) )
195
196;; Split alist into keys list & values list
197
198(define (unzip-alist alist)
199  (let loop ([alist alist] [keys '()] [vals '()])
200    (if (null? alist)
201      (values (reverse! keys) (reverse! vals))
202      (let ([elm (car alist)])
203        (if (pair? elm)
204          (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
205          (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
206
207;;
208
209(define (zip-alist keys vals)
210  (map cons keys vals) )
211
212;;; Deprecated
213
214;; Remove any keywords & keyword-value pairs from a #!rest argument.
215
216(define (filter-rest-argument! args #!optional testarg)
217  (let* (
218      [make-pred
219        (lambda (itmtst)
220          (let ([key? #f])
221            (lambda (arg)
222              (cond [key?
223                      (set! key? #f)
224                      #f]
225                    [(keyword? arg)
226                      (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
227                    [else
228                      #t]))))]
229      [pred
230        (cond [(procedure? testarg)   testarg]
231              [(list? testarg)        (make-pred memq)]
232              [(not testarg)          (make-pred (lambda (arg lst) #t))]
233              [else
234                (error 'filter-rest-argument!
235                  "test argument not a procedure or list" testarg)])])
236    (filter! pred args) ) )
Note: See TracBrowser for help on using the repository browser.