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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by kaz, Thu Jul 4 14:17:57 2002 UTC revision 1.12 by kaz, Sun Jul 14 18:38:33 2002 UTC
# Line 9  Line 9 
9    (default)    (default)
10    (matched-p))    (matched-p))
11    
12  (defun find-bind-extract-vals (val-list defaults sequence  (defmacro vector-bind (vars vec &rest forms)
13      (do ((i 0 (1+ i))
14           (var vars (rest var))
15           (list))
16          ((null var) `(let ,(nreverse list) ,@forms))
17        (push `(,(first var) (aref ,vec ,i)) list)))
18    
19    (defun find-bind-extract-vals (key-vec default-vec sequence
20                                 test-func key-func take-func                                 test-func key-func take-func
21                                 &key remainder-p)                                 &key remainder-p)
22  "This is an internal function that performs the sequence processing  "This is an internal function that performs the sequence processing
23  that underlies the find-bind macro."  that underlies the find-bind macro."
24    (let ((val-matches (mapcar #'(lambda (val dfl)    (let ((unique '#:unique)
                                  (make-fb-match-info  
                                    :value val :default dfl :matched-p nil))  
                              val-list defaults))  
25          (remainder))          (remainder))
26      (macrolet ((process-item (item-place remainder-save-form)      (macrolet ((process-item (item-place remainder-save-form)
27                   `(let* ((item (funcall key-func ,item-place))                   `(let* ((item (funcall key-func ,item-place))
28                           (match (find item val-matches                           (match (position item key-vec
29                                        :key #'fb-match-info-value :test test-func)))                                            :test (lambda (x y)
30                                                      (cond
31                                                        ((eq x unique) nil)
32                                                        ((eq y unique) nil)
33                                                        (t (funcall test-func
34                                                                    x y)))))))
35                      (cond                      (cond
36                        ((and match (not (fb-match-info-matched-p match)))                        (match
37                           (setf (fb-match-info-matched-p match) t)                           (setf (aref default-vec match)
38                           (setf (fb-match-info-value match)                                 (funcall take-func ,item-place))
39                                 (funcall take-func ,item-place)))                           (setf (aref key-vec match) unique))
40                        (t (when remainder-p ,remainder-save-form))))))                        (t (when remainder-p ,remainder-save-form))))))
41        (typecase sequence        (typecase sequence
42          (list          (list
# Line 42  that underlies the find-bind macro." Line 51  that underlies the find-bind macro."
51          (otherwise          (otherwise
52            (error "FIND-BIND: value ~s specified as SEQUENCE parameter.~%"            (error "FIND-BIND: value ~s specified as SEQUENCE parameter.~%"
53                   sequence))))                   sequence))))
54      (values (mapcar #'(lambda (match)      (values default-vec remainder)))
                         (if (fb-match-info-matched-p match)  
                           (fb-match-info-value match)  
                           (fb-match-info-default match)))  
                     val-matches)  
             remainder)))  
   
55    
56  (defmacro find-bind ((&key (test '#'eql)  (defmacro find-bind ((&key (test '#'eql)
57                             (key '#'values)                             (key '#'values)
# Line 108  Semantics: Line 111  Semantics:
111          (defaults (mapcar #'third var-specs))          (defaults (mapcar #'third var-specs))
112          (val-sym (gensym "VALS-"))          (val-sym (gensym "VALS-"))
113          (rem-sym (gensym "REM-")))          (rem-sym (gensym "REM-")))
   
114      `(multiple-value-bind (,val-sym ,rem-sym)      `(multiple-value-bind (,val-sym ,rem-sym)
115                            (find-bind-extract-vals (list ,@keys)                            (find-bind-extract-vals (vector ,@keys)
116                                                    (list ,@defaults)                                                    (vector ,@defaults)
117                                                    ,sequence                                                    ,sequence
118                                                    ,test ,key ,take                                                    ,test ,key ,take
119                                                    :remainder-p ',remainder)                                                    :remainder-p
120                                                      ,(not (null remainder)))
121         (declare (ignorable ,rem-sym))         (declare (ignorable ,rem-sym))
122         ,(if remainder         ,(if remainder
123           `(destructuring-bind (,remainder ,@vars)           `(let ((,remainder ,rem-sym)) (vector-bind (,@vars) ,val-sym ,@forms))
124                                (cons ,rem-sym ,val-sym)           `(vector-bind (,@vars) ,val-sym ,@forms)))))
             ,@forms)  
          `(destructuring-bind (,@vars) ,val-sym  
             ,@forms)))))  

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

  ViewVC Help
Powered by ViewVC 1.1.5