/[meta-cvs]/meta-cvs/F-5AD8C72020BEB5748163790EE9832EC7.lisp
ViewVC logotype

Contents of /meta-cvs/F-5AD8C72020BEB5748163790EE9832EC7.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Tue May 21 02:55:20 2002 UTC (11 years, 11 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-14, mcvs-0-13
Changes since 1.6: +8 -5 lines
* find-bind (find-bind-extract-vals, find-bind): Process default
values in find-bind-extract-vals, instead of in the expansion of
find-bind, thereby reducing some macro bloat.
1 kaz 1.1 ;;; This source file is part of the Meta-CVS program,
2     ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5     (provide "find-bind")
6    
7 kaz 1.7 (defun find-bind-extract-vals (val-list defaults sequence
8     test-func key-func take-func)
9 kaz 1.1 "This is an internal function that performs the sequence processing
10     that underlies the find-bind macro."
11     (let ((remainder (copy-seq sequence)) matches)
12 kaz 1.7 (dolist (item val-list (values (mapcar #'(lambda (x y) (if x x y))
13     (nreverse matches) defaults)
14     remainder))
15 kaz 1.1 (let ((match (find item remainder :test test-func :key key-func)))
16     (if match
17     (progn
18     (push (funcall take-func match) matches)
19     (setf remainder (remove item remainder
20     :test test-func :key key-func :count 1)))
21     (push nil matches))))))
22    
23     (defmacro find-bind ((&key (test '#'eql)
24     (key '#'(lambda (x) x))
25     (take '#'(lambda (x) x)))
26     (remainder &rest var-specs)
27     sequence &body forms)
28     "Slick binding macro for pulling
29     to lambda variables.
30    
31     Syntax:
32    
33     find-bind ({:test test-func} {:key key-func} {:take take-func})
34 kaz 1.4 ({rem-var} {(var key {default-value})}*)
35 kaz 1.5 sequence {decl}* {form}*
36 kaz 1.1
37     var A symbol naming a variable to be bound.
38     key A value to be sought after in the input sequence.
39 kaz 1.2 default-value Optional value to bind to the variable if a match
40 kaz 1.3 is not found, or the variable would otherwise be
41     bound to the value NIL.
42 kaz 1.1 rem-var A symbol naming the variable to be bound to
43 kaz 1.6 a new sequence that has only the unmatched elements
44 kaz 1.1 from the original sequence.
45     test-func A dyadic comparison function, used to compare
46     elements from the input sequence. Default is #'eql.
47     key-func A monadic function, used to select what part of
48     the sequence elements to compare. Default is to
49     compare the elements themselves.
50     take-func A monadic function, specifies what part of elements
51 kaz 1.6 to bind to variables (other than rem-var). Default
52 kaz 1.1 is to take the entire element.
53     sequence The input sequence.
54    
55     Semantics:
56    
57     The specified keys are looked up in the sequence and their corresponding
58 kaz 1.2 variables are bound to the values that are found, or else to their
59 kaz 1.3 default value, or NIL if there is no default value. If NIL happens
60     to be the result of an explict match, the default value is substituted,
61     if specified.
62 kaz 1.1
63     The rem-var variable is bound to a new sequence that is stripped of
64     these previously located elements. The declarations and forms are
65     then evaluated in the lexical environment thus formed.
66    
67     The binding occurs left to right. The first occurence of a value
68     name in the binding list matches the first occurence of the value
69     name in the input sequence. A second occurence of the same value
70     matches a second occurence and so on."
71 kaz 1.4 (when (consp remainder)
72     (push remainder var-specs)
73     (setf remainder nil))
74 kaz 1.1 (let ((vars (mapcar #'first var-specs))
75     (keys (mapcar #'second var-specs))
76 kaz 1.2 (defaults (mapcar #'third var-specs))
77 kaz 1.1 (val-sym (gensym "VALS-"))
78     (rem-sym (gensym "REM-")))
79    
80     `(multiple-value-bind (,val-sym ,rem-sym)
81 kaz 1.7 (find-bind-extract-vals (list ,@keys)
82     (list ,@defaults)
83     ,sequence
84 kaz 1.1 ,test ,key ,take)
85 kaz 1.4 (declare (ignorable ,rem-sym))
86     ,(if remainder
87     `(destructuring-bind (,remainder ,@vars)
88     (cons ,rem-sym ,val-sym)
89     ,@forms)
90     `(destructuring-bind (,@vars) ,val-sym
91     ,@forms)))))

  ViewVC Help
Powered by ViewVC 1.1.5