/[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.2 - (hide annotations)
Mon Mar 11 23:09:09 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.1: +8 -2 lines
Sane filtering of -d option in checkout.

* find-bind.lisp (find-bind): Variable bindings can specify
a third element, which provides a default value for any variables
that turn out NIL.

* checkout.lisp (mcvs-checkout): Filter out the -d dir option,
and use it to override the name of the checkout directory,
the way CVS checkout does it.
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     (defun find-bind-extract-vals (val-list sequence test-func key-func take-func)
8     "This is an internal function that performs the sequence processing
9     that underlies the find-bind macro."
10     (let ((remainder (copy-seq sequence)) matches)
11     (dolist (item val-list (values (nreverse matches) remainder))
12     (let ((match (find item remainder :test test-func :key key-func)))
13     (if match
14     (progn
15     (push (funcall take-func match) matches)
16     (setf remainder (remove item remainder
17     :test test-func :key key-func :count 1)))
18     (push nil matches))))))
19    
20     (defmacro find-bind ((&key (test '#'eql)
21     (key '#'(lambda (x) x))
22     (take '#'(lambda (x) x)))
23     (remainder &rest var-specs)
24     sequence &body forms)
25     "Slick binding macro for pulling
26     to lambda variables.
27    
28     Syntax:
29    
30     find-bind ({:test test-func} {:key key-func} {:take take-func})
31 kaz 1.2 (rem-var {(var key {default-value})}*)
32 kaz 1.1 alist {decl}* {form}*
33    
34     var A symbol naming a variable to be bound.
35     key A value to be sought after in the input sequence.
36 kaz 1.2 default-value Optional value to bind to the variable if a match
37     is not found.
38 kaz 1.1 rem-var A symbol naming the variable to be bound to
39     a sequence that has only the unmatched elements
40     from the original sequence.
41     test-func A dyadic comparison function, used to compare
42     elements from the input sequence. Default is #'eql.
43     key-func A monadic function, used to select what part of
44     the sequence elements to compare. Default is to
45     compare the elements themselves.
46     take-func A monadic function, specifies what part of elements
47     to binding to variables (other than rem-var). Default
48     is to take the entire element.
49     sequence The input sequence.
50    
51     Semantics:
52    
53     The specified keys are looked up in the sequence and their corresponding
54 kaz 1.2 variables are bound to the values that are found, or else to their
55     default value, or NIL if there is no default value.
56 kaz 1.1
57     The rem-var variable is bound to a new sequence that is stripped of
58     these previously located elements. The declarations and forms are
59     then evaluated in the lexical environment thus formed.
60    
61     The binding occurs left to right. The first occurence of a value
62     name in the binding list matches the first occurence of the value
63     name in the input sequence. A second occurence of the same value
64     matches a second occurence and so on."
65     (let ((vars (mapcar #'first var-specs))
66     (keys (mapcar #'second var-specs))
67 kaz 1.2 (defaults (mapcar #'third var-specs))
68 kaz 1.1 (val-sym (gensym "VALS-"))
69     (rem-sym (gensym "REM-")))
70    
71     `(multiple-value-bind (,val-sym ,rem-sym)
72     (find-bind-extract-vals (list ,@keys) ,sequence
73     ,test ,key ,take)
74 kaz 1.2 (setf ,val-sym (mapcar #'(lambda (x y) (if x x y))
75     ,val-sym (list ,@defaults)))
76 kaz 1.1 (destructuring-bind (,remainder ,@vars)
77     (cons ,rem-sym ,val-sym)
78     ,@forms))))

  ViewVC Help
Powered by ViewVC 1.1.5