/[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.11 - (hide annotations)
Thu Jul 4 14:17:57 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: partial-sandbox-branch~branch-point, partial-sandbox-branch~merged-to-HEAD-0, mcvs-0-18
Branch point for: partial-sandbox-branch
Changes since 1.10: +45 -14 lines
* find-bind.lisp (find-bind-extract-vals): Rewrite for
efficiency. No impact on Meta-CVS, just done for the sake of improving
the quality of this highly reusable code. There is specialized
code now depending on whether the input sequence is a list or
a vector. A single pass is made over the sequence, with multiple
passes over the search values. The sequence could be large,
whereas the list of search values is typically going to be small.
(find-bind): Modified to reflect slight interface change
in find-bind-extract-vals.
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.11 (defstruct fb-match-info
8     (value)
9     (default)
10     (matched-p))
11    
12     (defun find-bind-extract-vals (val-list defaults sequence
13     test-func key-func take-func
14     &key remainder-p)
15 kaz 1.1 "This is an internal function that performs the sequence processing
16     that underlies the find-bind macro."
17 kaz 1.11 (let ((val-matches (mapcar #'(lambda (val dfl)
18     (make-fb-match-info
19     :value val :default dfl :matched-p nil))
20     val-list defaults))
21     (remainder))
22     (macrolet ((process-item (item-place remainder-save-form)
23     `(let* ((item (funcall key-func ,item-place))
24     (match (find item val-matches
25     :key #'fb-match-info-value :test test-func)))
26     (cond
27     ((and match (not (fb-match-info-matched-p match)))
28     (setf (fb-match-info-matched-p match) t)
29     (setf (fb-match-info-value match)
30     (funcall take-func ,item-place)))
31     (t (when remainder-p ,remainder-save-form))))))
32     (typecase sequence
33     (list
34     (dolist (element sequence)
35     (process-item element (push element remainder)))
36     (setf remainder (nreverse remainder)))
37     (vector
38     (setf remainder (make-array (list (length sequence)) :fill-pointer 0))
39     (dotimes (i (length sequence))
40     (process-item (aref sequence i)
41     (vector-push (aref sequence i) remainder))))
42     (otherwise
43     (error "FIND-BIND: value ~s specified as SEQUENCE parameter.~%"
44     sequence))))
45     (values (mapcar #'(lambda (match)
46     (if (fb-match-info-matched-p match)
47     (fb-match-info-value match)
48     (fb-match-info-default match)))
49     val-matches)
50     remainder)))
51    
52 kaz 1.1
53     (defmacro find-bind ((&key (test '#'eql)
54 kaz 1.8 (key '#'values)
55     (take '#'values))
56 kaz 1.1 (remainder &rest var-specs)
57     sequence &body forms)
58 kaz 1.9 "Slick macro for binding variables to elements of a sequence
59     by matching keys.
60 kaz 1.1
61     Syntax:
62    
63     find-bind ({:test test-func} {:key key-func} {:take take-func})
64 kaz 1.4 ({rem-var} {(var key {default-value})}*)
65 kaz 1.5 sequence {decl}* {form}*
66 kaz 1.1
67 kaz 1.10 Arguments:
68    
69 kaz 1.1 var A symbol naming a variable to be bound.
70     key A value to be sought after in the input sequence.
71 kaz 1.2 default-value Optional value to bind to the variable if a match
72 kaz 1.3 is not found, or the variable would otherwise be
73     bound to the value NIL.
74 kaz 1.1 rem-var A symbol naming the variable to be bound to
75 kaz 1.6 a new sequence that has only the unmatched elements
76 kaz 1.1 from the original sequence.
77     test-func A dyadic comparison function, used to compare
78     elements from the input sequence. Default is #'eql.
79     key-func A monadic function, used to select what part of
80     the sequence elements to compare. Default is to
81     compare the elements themselves.
82     take-func A monadic function, specifies what part of elements
83 kaz 1.6 to bind to variables (other than rem-var). Default
84 kaz 1.1 is to take the entire element.
85     sequence The input sequence.
86    
87     Semantics:
88    
89     The specified keys are looked up in the sequence and their corresponding
90 kaz 1.2 variables are bound to the values that are found, or else to their
91 kaz 1.3 default value, or NIL if there is no default value. If NIL happens
92     to be the result of an explict match, the default value is substituted,
93     if specified.
94 kaz 1.1
95     The rem-var variable is bound to a new sequence that is stripped of
96     these previously located elements. The declarations and forms are
97     then evaluated in the lexical environment thus formed.
98    
99     The binding occurs left to right. The first occurence of a value
100     name in the binding list matches the first occurence of the value
101     name in the input sequence. A second occurence of the same value
102     matches a second occurence and so on."
103 kaz 1.4 (when (consp remainder)
104     (push remainder var-specs)
105     (setf remainder nil))
106 kaz 1.1 (let ((vars (mapcar #'first var-specs))
107     (keys (mapcar #'second var-specs))
108 kaz 1.2 (defaults (mapcar #'third var-specs))
109 kaz 1.1 (val-sym (gensym "VALS-"))
110     (rem-sym (gensym "REM-")))
111    
112     `(multiple-value-bind (,val-sym ,rem-sym)
113 kaz 1.7 (find-bind-extract-vals (list ,@keys)
114     (list ,@defaults)
115     ,sequence
116 kaz 1.11 ,test ,key ,take
117     :remainder-p ',remainder)
118 kaz 1.4 (declare (ignorable ,rem-sym))
119     ,(if remainder
120     `(destructuring-bind (,remainder ,@vars)
121     (cons ,rem-sym ,val-sym)
122     ,@forms)
123     `(destructuring-bind (,@vars) ,val-sym
124     ,@forms)))))

  ViewVC Help
Powered by ViewVC 1.1.5