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

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

Rmvd extra dsssl-fixup, put test of dsssl-fixup back in testbase test, works w/ hygienic macros.

File size: 3.0 KB
Line 
1;;;; misc-extn-list.scm
2;;;; Kon Lovett, Jul '07
3
4;;; Lists
5
6;; List of length = 0?
7
8(define-macro (length=0? ?lst)
9  `(null?,?lst) )
10
11;; List of length = 1?
12
13(define-macro (length=1? ?lst)
14  `(= 1 (length ,?lst)) )
15
16;; List of length = 2?
17
18(define-macro (length=2? ?lst)
19  `(= 2 (length ,?lst)) )
20
21;; List of length > 1?
22
23(define-macro (length>1? ?lst)
24  `(< 1 (length ,?lst)) )
25
26;; Returns a list
27
28(define-macro (ensure-list ?obj)
29  (let ([objvar (gensym)])
30    `(let ([,objvar ,?obj])
31       (if (list? ,objvar) ,objvar (list ,objvar)) ) ) )
32
33;; Returns #f if given list is empty and the list itself otherwise
34;; It is intended for emulation of MIT-style empty list treatment
35;; (not-null? <list>) may be considered as a counterpart to MIT-style <list>
36
37(define-macro (not-null? ?lst)
38  (let ([lstvar (gensym)])
39    `(let ([,lstvar ,?lst])
40       (and (not (null? ,lstvar))
41            ,lstvar) ) ) )
42
43;; Remove 1st matching elements from the alist [functional]
44
45(define-macro (alist-delete-first ?key ?al . ?rest)
46  (let-optionals ?rest ([?cmp 'eqv?])
47    `(alist-delete/count ,?key ,?al ,?cmp 1) ) )
48
49;; Remove 1st matching elements from the alist [destructive]
50
51(define-macro (alist-delete-first! ?key ?al . ?rest)
52  (let-optionals ?rest ([?cmp 'eqv?])
53    `(alist-delete!/count ,?key ,?al ,?cmp 1) ) )
54
55;; shift! with a variable
56
57(define-macro (shift!/set ?var . ?rest)
58  (let-optionals ?rest ([?empval #f])
59    (let ([tmpvar (gensym)])
60      `(if (pair? ,?var)
61           (let ([,tmpvar (car ,?var)])
62             (set! ,?var (cdr ,?var))
63             ,tmpvar )
64           ,?empval ) ) ) )
65
66;; Some useful alist search macros. Supplied default maybe a thunk or other.
67;; The default action is an error.
68
69;; opt-args may be (), (def), or (test def)
70
71(define-macro (assoc-def key alist . opt-args)
72  (let ([test
73          (if (length>1? opt-args)
74              (let ([testp (car opt-args)])
75                (set! opt-args (cdr opt-args))
76                testp)
77              `equal?)])
78    (let ([default-action
79            (if (pair? opt-args)
80                (let ([defact-symb (car opt-args)])
81                  `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))
82                `(error 'assoc-def "key not found" ,key))])
83      `(or (assoc ,key ,alist ,test) ,default-action))))
84
85;; opt-args may be () or (def)
86
87(define-macro (assq-def key alist . opt-args)
88  (let ([default-action
89          (if (pair? opt-args)
90              (let ([defact-symb (car opt-args)])
91                `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))
92              `(error 'assq-def "key not found" ,key))])
93    `(or (assq ,key ,alist) ,default-action) ) )
94
95;; opt-args may be () or (def)
96
97(define-macro (assv-def key alist . opt-args)
98  (let ([default-action
99          (if (pair? opt-args)
100              (let ([defact-symb (car opt-args)])
101                `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))
102              `(error 'assv-def "key not found" ,key))])
103    `(or (assv ,key ,alist) ,default-action) ) )
Note: See TracBrowser for help on using the repository browser.