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

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

Added tests (finally).

File size: 3.6 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;; shift! with a variable
44
45(define-macro (shift!/set ?var . ?rest)
46  (let-optionals ?rest ([?empval #f])
47    (let ([tmpvar (gensym)])
48      `(if (pair? ,?var)
49           (let ([,tmpvar (car ,?var)])
50             (set! ,?var (cdr ,?var))
51             ,tmpvar )
52           ,?empval ) ) ) )
53
54;; Some useful alist search macros. Supplied default maybe a thunk or other.
55;; The default action is an error.
56
57;; opt-args may be (), (def), or (test def)
58
59(define-macro (assoc-def key alist . opt-args)
60  (let ([test
61          (if (length>1? opt-args)
62              (let ([testp (car opt-args)])
63                (set! opt-args (cdr opt-args))
64                testp)
65              `equal?)])
66    (let ([default-action
67            (if (pair? opt-args)
68                (let ([defact-symb (car opt-args)])
69                  `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))
70                `(error 'assoc-def "key not found" ,key))])
71      `(or (assoc ,key ,alist ,test) ,default-action))))
72
73;; opt-args may be () or (def)
74
75(define-macro (assq-def key alist . opt-args)
76  (let ([default-action
77          (if (pair? opt-args)
78              (let ([defact-symb (car opt-args)])
79                `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))
80              `(error 'assq-def "key not found" ,key))])
81    `(or (assq ,key ,alist) ,default-action) ) )
82
83;; opt-args may be () or (def)
84
85(define-macro (assv-def key alist . opt-args)
86  (let ([default-action
87          (if (pair? opt-args)
88              (let ([defact-symb (car opt-args)])
89                `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb))
90              `(error 'assv-def "key not found" ,key))])
91    `(or (assv ,key ,alist) ,default-action) ) )
92
93;; Remove 1st matching elements from the alist [functional]
94
95(define-macro (alist-delete-first ?key ?al . ?rest)
96  (let-optionals ?rest ([?cmp 'eqv?])
97    `(alist-delete/count ,?key ,?al ,?cmp 1) ) )
98
99;; Remove 1st matching elements from the alist [destructive]
100
101(define-macro (alist-delete-first! ?key ?al . ?rest)
102  (let-optionals ?rest ([?cmp 'eqv?])
103    `(alist-delete!/count ,?key ,?al ,?cmp 1) ) )
104
105;;
106
107(define-macro (dsssl-fixup ?keys ?opts ?rest . ?body)
108  (let-values (
109      [(optvars optvals)
110        (let loop ([opts ?opts]
111                   [varlst '()]
112                   [vallst '()])
113          (if (null? opts)
114              (values (reverse varlst) (reverse vallst))
115              (let* ([opt (car opts)]
116                     [var (car opt)])
117                (loop (cdr opts)
118                      (cons var varlst)
119                      (cons `(list ,var ,(cadr opt)) vallst)))))])
120    `(let-values ([(,?rest ,@optvars) (fixup-extended-lambda-list ,?keys ,?rest ,@optvals)])
121       ,@?body ) ) )
Note: See TracBrowser for help on using the repository browser.