source: project/release/3/misc-extn/trunk/misc-extn-list-support.scm @ 8075

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

Rel 3.1, adds -directory stuff.

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