source: project/release/3/misc-extn/tags/3.1/misc-extn-list-support.scm @ 9512

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

Rmvd dep procs. Updated doc.

File size: 4.7 KB
Line 
1;;;; misc-extn-list-support.scm
2;;;; Kon Lovett, Jul '07
3
4(eval-when (compile)
5  (declare
6    (usual-integrations)
7    (fixnum)
8    (inline)
9    (no-procedure-checks)
10    (no-bound-checks)
11    (bound-to-procedure
12      ##sys#check-pair )
13    (export
14      length=0?
15      length=1?
16      length=2?
17      length>1?
18      ensure-list
19      not-null?
20      alist-inverse-ref
21      alist-delete/count
22      alist-delete!/count
23      alist-delete-first
24      alist-delete-first!
25      unzip-alist
26      zip-alist
27      shift!
28      unshift! ) ) )
29
30(use srfi-1)
31
32;;;
33
34(define (check-procedure obj loc)
35  (unless (procedure? obj)
36    (error loc "invalid procedure" obj)) )
37
38(define (check-integer obj loc)
39  (unless (integer? obj)
40    (error loc "invalid integer" obj)) )
41
42;;;
43
44;; List of length = 0?
45
46(define length=0? null?)
47
48;; List of length = 1?
49
50(define (length=1? lst)
51  (= 1 (length lst)) )
52
53;; List of length = 2?
54
55(define (length=2? lst)
56  (= 2 (length lst)) )
57
58;; List of length > 1?
59
60(define (length>1? lst)
61  (< 1 (length lst)) )
62
63;; Returns a list
64
65(define (ensure-list obj)
66  (if (list? obj) obj (list obj)) )
67
68;; Returns #f if given list is empty and the list itself otherwise
69;; It is intended for emulation of MIT-style empty list treatment
70;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>
71
72(define (not-null? lst)
73  (and (not (null? lst))
74       lst ) )
75
76;; Search the alist from back to front.
77
78(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
79  (let ([cell (rassoc val alist cmp)])
80    (if cell
81        (car cell)
82        default ) ) )
83
84;; Remove 1st N matching elements from the alist [functional]
85
86(define (alist-delete/count key al #!optional (cmp eqv?) (cnt 1073741823))
87  (check-procedure cmp 'alist-delete/count)
88  (check-integer cnt 'alist-delete/count)
89  (let loop ([cal al] [cnt cnt] [oal '()])
90    (cond [(null? cal)
91            (reverse! oal)]
92          [(pair? cal)
93            (let ([elm (car cal)]
94                  [nxt (cdr cal)])
95              (if (pair? elm)
96                  (if (positive? cnt)
97                      ; then more deletion to attempt
98                      (if (cmp key (car elm))
99                          (loop nxt (sub1 cnt) oal)
100                          (loop nxt cnt (cons elm oal)))
101                      ; else copy rest of spine
102                      (loop nxt 0 (cons elm oal)))
103                  (error 'alist-delete/count "invalid association list item" elm)))]
104          [else
105            (error 'alist-delete/count "invalid association list" al)]) ) )
106
107;; Remove 1st N matching elements from the alist [destructive]
108
109(define (alist-delete!/count key al #!optional (cmp eqv?) (cnt 1073741823))
110  (check-procedure cmp 'alist-delete!/count)
111  (check-integer cnt 'alist-delete!/count)
112  (let ([ral al])
113    (let loop ([cal al] [pal #f] [cnt cnt])
114      (cond [(or (null? cal) (not (positive? cnt)))
115              ral]
116            [(pair? cal)
117              (let ([elm (car cal)]
118                    [nxt (cdr cal)])
119                (if (pair? elm)
120                    (cond [(cmp key (car elm))
121                            (if pal
122                                (set-cdr! pal nxt)
123                                (set! ral nxt))
124                              (loop nxt pal (sub1 cnt))]
125                           [else
126                              (loop nxt cal cnt)])
127                    (error 'alist-delete!/count "invalid association list item" elm)))]
128            [else
129              (error 'alist-delete!/count "invalid association list" al)]) ) ) )
130
131;; Remove 1st matching elements from the alist [functional]
132
133(define (alist-delete-first key al #!optional (cmp eqv?))
134  (alist-delete/count key al cmp 1) )
135
136;; Remove 1st matching elements from the alist [destructive]
137
138(define (alist-delete-first! key al #!optional (cmp eqv?))
139  (alist-delete!/count key al cmp 1) )
140
141;; Split alist into keys list & values list
142
143(define (unzip-alist alist)
144  (let loop ([alist alist] [keys '()] [vals '()])
145    (if (null? alist)
146        (values (reverse! keys) (reverse! vals))
147        (let ([elm (car alist)])
148          (if (pair? elm)
149              (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
150              (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
151
152;;
153
154(define (zip-alist keys vals)
155  (map cons keys vals) )
156
157;;; Handy little things:
158
159(define (shift! lst #!optional default)
160  (if (null? lst)
161      default
162      (begin
163        (##sys#check-pair lst 'shift!)
164        (let ([x (car lst)]
165              [d (cdr lst)] )
166          (##sys#check-pair d 'shift!)
167          (set-car! lst (car d))
168          (set-cdr! lst (cdr d))
169          x ) ) ) )
170
171(define (unshift! x lst)
172  (##sys#check-pair lst 'unshift!)
173  (set-car! lst x)
174  (set-cdr! lst (cons (car lst) (cdr lst)))
175  lst )
Note: See TracBrowser for help on using the repository browser.