9 | 
10 |
11 | ## metabang-bind
12 |
13 | #### Sticking the pedal to the metal fun
14 |
15 |
16 |
17 | [tr]: test-report.html
18 |
19 | [user-guide]: user-guide.html
20 |
21 | [tarball]: http://common-lisp.net/project/cl-containers/bundler/bundler_latest.tar.gz
22 | [metabang-bind-tar]: http://common-lisp.net/project/metabang-bind/metabang-bind_latest.tar.gz
23 |
24 | [devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/metabang-bind-devel
25 | [cliki-home]: http://www.cliki.net//metabang-bind
26 | [tarball]: http://common-lisp.net/project/metabang-bind/metabang-bind.tar.gz
27 |
--------------------------------------------------------------------------------
/lift-standard.config:
--------------------------------------------------------------------------------
1 | ;;; configuration for LIFT tests
2 |
3 | ;; settings
4 | (:if-dribble-exists :supersede)
5 | (:dribble "metabang-bind.dribble")
6 | (:print-length 10)
7 | (:print-level 5)
8 | (:print-test-case-names t)
9 |
10 | ;; suites to run
11 | (metabang-bind-test)
12 |
13 | ;; report properties
14 | (:report-property :title "Metabang-Bind | Test results")
15 | (:report-property :relative-to metabang-bind-test)
16 |
17 | (:report-property :style-sheet "test-style.css")
18 | (:report-property :if-exists :supersede)
19 | (:report-property :format :html)
20 | (:report-property :full-pathname "test-results/test-report")
21 | (:report-property :unique-name t)
22 | (:build-report)
23 |
24 | (:report-property :unique-name t)
25 | (:report-property :format :describe)
26 | (:report-property :full-pathname "test-results/test-report.txt")
27 | (:build-report)
28 |
29 | (:report-property :format :save)
30 | (:report-property :full-pathname "test-results/test-report.sav")
31 | (:build-report)
32 |
33 | (:report-property :format :describe)
34 | (:report-property :full-pathname *standard-output*)
35 | (:build-report)
36 |
--------------------------------------------------------------------------------
/COPYING:
--------------------------------------------------------------------------------
1 | Copyright (c) 2004-2008 Gary Warren King (gwking@metabang.com)
2 |
3 | Permission is hereby granted, free of charge, to any person obtaining a
4 | copy of this software and associated documentation files (the "Software"),
5 | to deal in the Software without restriction, including without limitation
6 | the rights to use, copy, modify, merge, publish, distribute, sublicense,
7 | and/or sell copies of the Software, and to permit persons to whom the
8 | Software is furnished to do so, subject to the following conditions:
9 |
10 | The above copyright notice and this permission notice shall be included in
11 | all copies or substantial portions of the Software.
12 |
13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
16 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
19 | DEALINGS IN THE SOFTWARE.
20 |
--------------------------------------------------------------------------------
/dev/bind-re-allegro.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang.bind.developer)
2 |
3 | (defmethod bind-generate-bindings ((kind (eql :re)) variable-form value-form)
4 | ;; (:re "re" vars)
5 | (bind (((regex &rest vars) variable-form)
6 | (gok (gensym "ok"))
7 | (gblock (gensym "block"))
8 | ((:values vars ignores) (bind-fix-nils vars)))
9 | `(let* ((,gok nil))
10 | (block ,gblock
11 | (flet ((doit (,@vars)
12 | ,@(when ignores `((declare (ignore ,@ignores))))
13 | ,metabang-bind::+decl-marker+
14 | (return-from ,gblock ,metabang-bind::+code-marker+)))
15 | (excl:re-let ,regex ,(first value-form)
16 | ,(loop for var in vars for i from 1 collect
17 | `(,var ,i))
18 | (setf ,gok t)
19 | (doit ,@vars))
20 | (unless ,gok
21 | (doit ,@(make-list (length vars) :initial-element nil))))))))
22 |
23 | #+(or)
24 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
25 | fname lname date month year) "Frank Zappa 21.12.1940"))
26 | (list fname lname date month year))
27 |
28 | (defmethod bind-generate-bindings ((kind (eql :regex)) variable-form value-form)
29 | ;; (:regex "re" vars)
30 | (bind (((regex &rest vars) variable-form))
31 | `(excl:re-let ,regex ,(first value-form)
32 | ,(loop for var in vars for i from 1 collect
33 | `(,var ,i)))))
34 |
--------------------------------------------------------------------------------
/metabang-bind-test.asd:
--------------------------------------------------------------------------------
1 | (in-package common-lisp-user)
2 |
3 | (defpackage #:metabang-bind-test-system
4 | (:use #:common-lisp #:asdf))
5 | (in-package #:metabang-bind-test-system)
6 |
7 | (defsystem metabang-bind-test
8 | :version "0.1"
9 | :author "Gary Warren King
10 |
11 | ## metabang-bind
12 |
13 | #### Sticking the pedal to the metal fun
14 |
15 |
2 | 
3 | 
4 | 
5 | 
6 | 
7 |
8 |
9 | Copyright (c) 2005 - {current-year} Gary Warren King (gwking@metabang.com)
10 |
11 |
12 | metabang-bind has an [MIT style][mit-license] license
13 |
14 |
--------------------------------------------------------------------------------
/dev/packages.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:common-lisp-user)
2 |
3 | (defpackage #:metabang.bind
4 | (:use #:common-lisp)
5 | (:nicknames #:bind #:metabang-bind)
6 | (:intern
7 | #:bind-generate-bindings
8 | #:bind-filter-declarations
9 | #:bind-macro-helper
10 | #:bind-fix-nils)
11 | (:export
12 | #:bind
13 | #:fluid-bind
14 |
15 | #:binding-forms
16 | #:binding-form-synonyms
17 | #:binding-form-groups
18 | #:binding-form-docstring
19 | #:binding-form ;for documentation
20 |
21 | #:*bind-all-declarations*
22 | #:*bind-non-var-declarations*
23 | #:*bind-lambda-list-markers*
24 |
25 | #:bind-error
26 | #:bind-keyword/optional-nil-with-default-error
27 | #:bind-missing-value-form-warning
28 | #:bind-too-many-value-forms-error
29 |
30 | #:*unused-declarations-behavior*
31 | #:bind-unused-declarations-condition
32 | #:bind-unused-declarations-warning
33 | #:bind-unused-declarations-error
34 |
35 | #:*unused-declarations-behavior*
36 | #:bind-unused-declarations-condition
37 | #:bind-unused-declarations-warning
38 | #:bind-unused-declarations-error
39 |
40 | #:lambda-bind))
41 |
42 | (defpackage #:metabang.bind.developer
43 | (:use #:common-lisp #:metabang-bind)
44 | (:import-from #:metabang-bind
45 | #:bind-generate-bindings
46 | #:bind-filter-declarations
47 | #:bind-macro-helper
48 | #:bind-fix-nils)
49 | (:export
50 | #:bind-generate-bindings
51 | #:bind-filter-declarations
52 | #:bind-macro-helper
53 | #:bind-fix-nils
54 | #:defbinding-form))
55 |
56 |
--------------------------------------------------------------------------------
/unit-tests/structures.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang-bind-test)
2 |
3 | (defstruct (metabang-bind-test-1)
4 | a
5 | b
6 | c)
7 |
8 | (defstruct (metabang-bind-test-2 (:conc-name bind-test-))
9 | d
10 | e)
11 |
12 | (deftestsuite test-structures (metabang-bind-test)
13 | ())
14 |
15 | (addtest (test-structures)
16 | basic-access
17 | (ensure-same
18 | (bind (((:struct metabang-bind-test-1- a c)
19 | (make-metabang-bind-test-1 :a 1 :b 2 :c 3)))
20 | (list a c))
21 | '(1 3) :test 'equal))
22 |
23 | (addtest (test-structures)
24 | no-capture
25 | (let ((values 4))
26 | (bind (((:struct metabang-bind-test-1- a c)
27 | (make-metabang-bind-test-1 :a 1 :b 2 :c 3)))
28 | (ensure-same '(4 1 3) (list values a c) :test 'equal))))
29 |
30 | (addtest (test-structures)
31 | changed-variable-name
32 | (ensure-same
33 | (bind (((:struct metabang-bind-test-1- (my-a a) c)
34 | (make-metabang-bind-test-1 :a 1 :b 2 :c 3)))
35 | (list c my-a))
36 | '(3 1) :test 'equal))
37 |
38 | (addtest (test-structures)
39 | changed-variable-name-2
40 | (ensure-same
41 | (bind (((:structure metabang-bind-test-1- (my-a a) c)
42 | (make-metabang-bind-test-1 :a 1 :b 2 :c 3)))
43 | (list c my-a))
44 | '(3 1) :test 'equal))
45 |
46 | (addtest (test-structures)
47 | nested-read-only
48 | (let ((c1 (make-metabang-bind-test-1 :a 1 :b 2 :c 3))
49 | (c2 (make-metabang-bind-test-1 :a 4 :b 5 :c 6)))
50 | (ensure-same
51 | (bind (((:structure metabang-bind-test-1- (my-a a) c) c1)
52 | ((:structure metabang-bind-test-1- a b (second-c c)) c2))
53 | (list my-a c a b second-c))
54 | '(1 3 4 5 6) :test 'equal)))
55 |
56 | (addtest (test-structures)
57 | read-write-nested
58 | (let ((c1 (make-metabang-bind-test-1 :a 1 :b 2 :c 3))
59 | (c2 (make-metabang-bind-test-1 :a 4 :b 5 :c 6)))
60 | (bind (((:structure/rw metabang-bind-test-1- (my-a a) c) c1)
61 | ((:structure/rw metabang-bind-test-1- a b (second-c c)) c2))
62 | (setf my-a :a second-c :c b :b))
63 | (ensure-same (metabang-bind-test-1-a c1) :a)
64 | (ensure-same (metabang-bind-test-1-b c2) :b)
65 | (ensure-same (metabang-bind-test-1-c c2) :c)))
66 |
--------------------------------------------------------------------------------
/unit-tests/regex.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang-bind-test)
2 |
3 | #+(or)
4 | (run-tests :suite 'test-regex)
5 |
6 |
7 | (deftestsuite test-regex (metabang-bind-test)
8 | ()
9 | (:equality-test #'equalp))
10 |
11 | (addtest (test-regex)
12 | simple-bind
13 | (ensure-same
14 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
15 | fname lname date month year) "Frank Zappa 21.12.1940"))
16 | (list fname lname date month year))
17 | (list "Frank" "Zappa" "21" "12" "1940")))
18 |
19 | (addtest (test-regex)
20 | nils-are-ignored-1
21 | (ensure-same
22 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
23 | fname lname nil month year) "Frank Zappa 21.12.1940"))
24 | (list fname lname month year))
25 | (list "Frank" "Zappa" "12" "1940")))
26 |
27 | (addtest (test-regex)
28 | nils-are-ignored-2
29 | (ensure-same
30 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
31 | nil lname nil month year) "Frank Zappa 21.12.1940"))
32 | (list lname month year))
33 | (list "Zappa" "12" "1940")))
34 |
35 | #+(or)
36 | (addtest (test-regex)
37 | nils-are-ignored-1
38 | (let ((result
39 | (lambda ()
40 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
41 | fname lname nil month year) "Frank Zappa 21.12.1940"))
42 | (list lname month year)))))
43 | (ensure-same (funcall result)
44 | (list "Zappa" "12" "1940"))
45 | (ensure-warning
46 | (compile
47 | nil
48 | (lambda ()
49 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
50 | fname lname nil month year) "Frank Zappa 21.12.1940"))
51 | (list lname month year)))))))
52 |
53 | (addtest (test-regex)
54 | executes-when-no-bindings
55 | (ensure-same
56 | (bind (((:re "(a|b)+" first) "cccc"))
57 | (list "still seen" first))
58 | (list "still seen" nil)))
59 |
60 | #+(or)
61 | (addtest (test-regex)
62 | you-can-use-doit
63 | (ensure-same
64 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
65 | fname lname nil month year)
66 | "Frank Zappa 21.12.1940"))
67 | (flet ((doit (&rest vars)
68 | (reverse vars)))
69 | (doit fname lname month year)))
70 | (reverse (list "Frank" "Zappa" "12" "1940"))))
71 |
72 | #+(or)
73 | (defun xxx ()
74 | (let ((result
75 | '(lambda ()
76 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
77 | nil lname nil month year) "Frank Zappa 21.12.1940"))
78 | (list lname month year)))))
79 | (compile nil result)))
80 |
--------------------------------------------------------------------------------
/unit-tests/functions.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang-bind-test)
2 |
3 | (deftestsuite test-flet (metabang-bind-test)
4 | ())
5 |
6 | (addtest (test-flet)
7 | basic-access
8 | (bind (((:flet doit (x))
9 | (setf x (* 2 x))
10 | (setf x (+ x 3))
11 | x))
12 | (ensure-same (doit 1) 5)
13 | (ensure-same (doit 2) 7)))
14 |
15 | (addtest (test-flet)
16 | declarations
17 | (bind (((:flet doit (x))
18 | (declare (type fixnum x))
19 | (setf x (* 2 x))
20 | (setf x (+ x 3))
21 | x))
22 | (ensure-same (doit 1) 5)
23 | (ensure-same (doit 2) 7)))
24 |
25 | (addtest (test-flet)
26 | docstring
27 | (bind (((:flet doit (x))
28 | "if I knew how to get the docstring out of flet, I'd test it."
29 | (setf x (* 2 x))
30 | (setf x (+ x 3))
31 | x))
32 | (ensure-same (doit 1) 5)
33 | (ensure-same (doit 2) 7)))
34 |
35 | (addtest (test-flet)
36 | docstring-and-declarations-1
37 | (bind (((:flet doit (x))
38 | "whatever"
39 | (declare (type fixnum x))
40 | (setf x (* 2 x))
41 | (setf x (+ x 3))
42 | x))
43 | (ensure-same (doit 1) 5)
44 | (ensure-same (doit 2) 7)))
45 |
46 | (addtest (test-flet)
47 | docstring-and-declarations-2
48 | (bind (((:flet constant (x))
49 | (declare (ignore x))
50 | 42))
51 | (ensure-same (constant 1) 42)))
52 |
53 |
54 | (deftestsuite test-labels (metabang-bind-test)
55 | ())
56 |
57 | (addtest (test-labels)
58 | basic-access
59 | (bind (((:labels my-oddp (x))
60 | (cond ((<= x 0) nil)
61 | ((= x 1) t)
62 | (t (my-oddp (- x 2))))))
63 | (ensure (my-oddp 1))
64 | (ensure (my-oddp 7))
65 | (ensure-null (my-oddp 2))))
66 |
67 | (addtest (test-labels)
68 | declarations
69 | (bind (((:labels doit (x))
70 | (declare (type fixnum x))
71 | (setf x (* 2 x))
72 | (setf x (+ x 3))
73 | x))
74 | (ensure-same (doit 1) 5)
75 | (ensure-same (doit 2) 7)))
76 |
77 | (addtest (test-labels)
78 | docstring
79 | (bind (((:labels doit (x))
80 | "if I knew how to get the docstring out of flet, I'd test it."
81 | (setf x (* 2 x))
82 | (setf x (+ x 3))
83 | x))
84 | (ensure-same (doit 1) 5)
85 | (ensure-same (doit 2) 7)))
86 |
87 | (addtest (test-labels)
88 | docstring-and-declarations-1
89 | (bind (((:labels doit (x))
90 | "whatever"
91 | (declare (type fixnum x))
92 | (setf x (* 2 x))
93 | (setf x (+ x 3))
94 | x))
95 | (ensure-same (doit 1) 5)
96 | (ensure-same (doit 2) 7)))
97 |
98 | (addtest (test-labels)
99 | docstring-and-declarations-2
100 | (bind (((:labels constant (x))
101 | (declare (ignore x))
102 | 42))
103 | (ensure-same (constant 1) 42)))
104 |
--------------------------------------------------------------------------------
/website/source/images/index.mmd:
--------------------------------------------------------------------------------
1 | {include header.md}
2 | {set-property title "metabang-bind - Sticking it the to metal..."}
3 |
4 |
3 |
4 |
5 |
6 |
7 |
8 |
9 | Copyright (c) 2005 - {current-year} Gary Warren King (gwking@metabang.com)
10 |
11 |
12 | metabang-bind has an [MIT style][mit-license] license
13 |
14 | Last updated {today} at {now}
15 |
5 |
86 |
87 | {include footer.md}
88 |
89 |
90 |
--------------------------------------------------------------------------------
/website/source/index.mmd:
--------------------------------------------------------------------------------
1 | {include resources/header.md}
2 | {set-property title "metabang-bind - Sticking it the to metal..."}
3 |
4 |
6 |
7 | * [User's guide](user-guide.html)
8 | * [Issue's tracker](https://github.com/gwkkwg/metabang-bind/issues)
9 | * [Mailing Lists][3]
10 | * [Getting it][4]
11 | * [News][6]
12 | * [Changelog][7]
13 |
14 | [3]: #mailing-lists
15 | [4]: #downloads
16 | [5]: documentation/ (documentation link)
17 | [6]: #news
18 | [7]: changelog.html
19 |
20 |
21 |
22 |
23 |
24 | ### What it is
25 |
26 | Bind extends the idea of of `let` and destructing to provide
27 | a uniform syntax for all your accessor needs. It combines
28 | _let_, _destructuring-bind_, `with-slots`, `with-accessors`,
29 | structure editing, property or association-lists, and
30 | _multiple-value-bind_ and a whole lot more into a single
31 | form. The [user guide][user-guide] has all the details but
32 | here is example to whet your appetite:
33 |
34 | (bind ((a 2)
35 | ((b &rest args &key (c 2) &allow-other-keys) '(:a :c 5 :d 10 :e 54))
36 | ((:values d e) (truncate 4.5)))
37 | (list a b c d e args))
38 | ==> (2 :A 5 4 0.5 (:C 5 :D 10 :E 54))
39 |
40 | Bind is especially handy when you have more than one layer of
41 | `multiple-value-bind` or `destructuring-bind`. Since `bind` is a
42 | single form, you don't end up too far off to the right in
43 | editor land.
44 |
45 | Bind is released under the [MIT license][mit-license].
46 |
47 | {anchor mailing-lists}
48 |
49 | ### Mailing Lists
50 |
51 | Use the developer [mailing list][metabang-bind-devel] for any questions or comments regarding bind.
52 |
53 | {anchor downloads}
54 |
55 | ### Where is it
56 |
57 | metabang.com is switching from [darcs][] to [git][] for source control; the current metabang-bind repository is on [github][github-metabang-bind] and you can clone it using:
58 |
59 | git clone git://github.com/gwkkwg/metabang-bind
60 |
61 | metabang-bind is also [ASDF installable][asdf-install]. Its
62 | CLiki home is right [where][cliki-home] you'd expect.
63 |
64 | There's also a handy [gzipped tar file][tarball].
65 |
66 | {anchor news}
67 |
68 | ### What is happening
69 |
70 | 10 April 2010 - moved to github; added flet support
71 |
72 | 28 May 2009 - added `:structure/rw` binding form; updated
73 | webpage to link to the user's guide
74 |
75 | 1 Dec 2007 - Added support for [array
76 | destructuring][array-bindings] (Thanks to Tamas Papp for the
77 | idea)
78 |
79 | 15 Nov 2007 - New user guide; bind handles structures and
80 | property lists and is now extensible!
81 |
82 | 13 Nov 2005 - Initial webpage n' stuff.
83 |
84 |
85 |
5 |
86 |
87 | {include resources/footer.md}
88 |
89 |
90 |
--------------------------------------------------------------------------------
/dev/bind-cl-ppcre.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang.bind.developer)
2 |
3 | #+wrong
4 | (defmethod bind-generate-bindings ((kind (eql :re)) variable-form value-form)
5 | ;; (:re "re" vars)
6 | (bind (((regex &rest vars) variable-form)
7 | (gok (gensym "ok"))
8 | (gblock (gensym "block"))
9 | ((:values vars ignores) (bind-fix-nils vars)))
10 | `((let ((,gok nil))
11 | (block ,gblock
12 | (flet ((doit (,@vars)
13 | ,@(when ignores `((declare (ignore ,@ignores))))
14 | (return-from ,gblock
15 | (progn ,@(bind-macro-helper
16 | remaining-bindings declarations body)))))
17 | (cl-ppcre:register-groups-bind
18 | ,vars (,regex ,(first value-form) :sharedp t)
19 | ,(bind-filter-declarations
20 | declarations variable-form)
21 | (setf ,gok t)
22 | (doit ,@vars))
23 | (unless ,gok
24 | (doit ,@(make-list (length vars) :initial-element nil)))))))))
25 |
26 | ;; simple but doesn't execute inner code if no bindings found
27 | ;; which isn't very bind-like
28 | (defmethod bind-generate-bindings ((kind (eql :regex)) variable-form value-form)
29 | ;; (:re "re" vars)
30 | (bind (((regex &rest vars) variable-form))
31 | `((cl-ppcre:register-groups-bind ,vars (,regex ,(first value-form) :sharedp t)))))
32 |
33 | #+(or)
34 | ;; doesn't handle ignores
35 | (defmethod bind-generate-bindings
36 | ((kind (eql :re)) variable-form value-form
37 | body declarations remaining-bindings)
38 | ;; (:re "re" vars)
39 | (bind (((regex &rest vars) variable-form)
40 | (gok (gensym "ok"))
41 | (gblock (gensym "block")))
42 | `((let ((,gok nil))
43 | (block ,gblock
44 | (flet ((doit (,@vars)
45 | (return-from ,gblock
46 | ,@(bind-macro-helper
47 | remaining-bindings declarations body))))
48 | (cl-ppcre:register-groups-bind
49 | ,vars (,regex ,(first value-form) :sharedp t)
50 | ,(bind-filter-declarations
51 | declarations variable-form)
52 | (setf ,gok t)
53 | (doit ,@vars))
54 | (unless ,gok
55 | (doit ,@(make-list (length vars) :initial-element nil)))))))))
56 |
57 | #+(or)
58 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
59 | fname lname date month year) "Frank Zappa 21.12.1940"))
60 | (list fname lname date month year))
61 |
62 | #+(or)
63 | (macroexpand-1
64 | '(bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
65 | fname lname date month year) "Frank Zappa 21.12.1940"))
66 | (list fname lname date month year)))
67 |
68 | #+(or)
69 | (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})"
70 | fname lname nil month year) "Frank Zappa 21.12.1940"))
71 | (list fname lname month year))
72 |
73 | #+(or)
74 | (bind (((:re "(a|b)+" first) "cccc"))
75 | (format t "This will still be printed: ~A" first))
76 |
--------------------------------------------------------------------------------
/unit-tests/classes.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang-bind-test)
2 |
3 | (defclass metabang-bind-class-1 ()
4 | ((a :initarg :a :accessor a)
5 | (b :initarg :b :accessor b)
6 | (c :initarg :c :accessor c)))
7 |
8 | (defclass metabang-bind-class-2 (metabang-bind-class-1)
9 | ((d :initarg :d :accessor the-d)
10 | (e :initarg :e :accessor e)))
11 |
12 | (deftestsuite test-classes (metabang-bind-test)
13 | ())
14 |
15 | (addtest (test-classes)
16 | basic-slots
17 | (ensure-same
18 | (bind (((:slots-read-only a c)
19 | (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3)))
20 | (list a c))
21 | '(1 3) :test 'equal))
22 |
23 | (addtest (test-classes)
24 | slots-new-variable-names
25 | (ensure-same
26 | (bind (((:slots-read-only a (my-c c) (the-b b))
27 | (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3)))
28 | (list a the-b my-c))
29 | '(1 2 3) :test 'equal))
30 |
31 | (addtest (test-classes)
32 | writable-slots
33 | (ensure-same
34 | (bind ((instance (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3))
35 | ((:slots a (my-c c) (the-b b)) instance))
36 | (setf a :changed)
37 | (list (slot-value instance 'a) the-b my-c))
38 | '(:changed 2 3) :test 'equal))
39 |
40 | (addtest (test-classes)
41 | slots-r/o-1
42 | (ensure-same
43 | (bind (((:slots-r/o a c)
44 | (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3)))
45 | (list a c))
46 | '(1 3) :test 'equal))
47 |
48 | (addtest (test-classes)
49 | basic-accessors-r/o-1
50 | (ensure-same
51 | (bind (((:accessors-read-only a c e)
52 | (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)))
53 | (list e c a))
54 | '(5 3 1) :test 'equal))
55 |
56 | (addtest (test-classes)
57 | basic-accessors-r/o-2
58 | (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5))
59 | ((:accessors-read-only a c e) obj))
60 | (setf a :a c :c)
61 | (ensure-same (list a c e) '(:a :c 5) :test 'equal)
62 | (ensure-same
63 | (list (e obj) (c obj) (a obj))
64 | '(5 3 1) :test 'equal)))
65 |
66 | (addtest (test-classes)
67 | accessors-new-variable-names-r/o
68 | (ensure-same
69 | (bind (((:accessors-r/o (my-a a) (my-c c) (d the-d))
70 | (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)))
71 | (list d my-c my-a))
72 | '(4 3 1) :test 'equal))
73 |
74 | (addtest (test-classes)
75 | basic-accessors-1
76 | (ensure-same
77 | (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5))
78 | ((:accessors a c e) obj))
79 | (setf a :a c :c)
80 | (list (e obj) (c obj) (a obj)))
81 | '(5 :c :a) :test 'equal))
82 |
83 | (addtest (test-classes)
84 | accessors-new-variable-names
85 | (ensure-same
86 | (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5))
87 | ((:writable-accessors (my-a a) (my-c c) (d the-d))
88 | obj))
89 | (setf my-a 42)
90 | (list d my-c my-a (a obj)))
91 | '(4 3 42 42) :test 'equal))
92 |
--------------------------------------------------------------------------------
/website/source/user-guide.css:
--------------------------------------------------------------------------------
1 | /* @group toc */
2 |
3 | .table-of-contents {
4 | font-size: 90%;
5 | margin-bottom: 1em;
6 | padding-bottom: 1em;
7 | }
8 |
9 | .table-of-contents h2, h3, h4 {
10 | padding-top: 0;
11 | padding-bottom: 0;
12 | margin-top: 0;
13 | margin-bottom: 1px;
14 | }
15 |
16 | .table-of-contents h2 {
17 | font-size: inherit;
18 | font-style: inherit;
19 | position: relative;
20 | left: 2em;
21 | }
22 |
23 | .table-of-contents h3 {
24 | font-size: inherit;
25 | font-style: inherit;
26 | position: relative;
27 | left: 4em;
28 | }
29 |
30 | .table-of-contents h4 {
31 | font-size: inherit;
32 | font-style: inherit;
33 | position: relative;
34 | left: 6em;
35 | }
36 |
37 | .table-of-contents h5 {
38 | font-size: inherit;
39 | font-style: inherit;
40 | position: relative;
41 | left: 8px;
42 | }
43 |
44 | /* @end */
45 |
46 | /* @group anchors */
47 |
48 | a.none {
49 | text-decoration: none;
50 | color:black }
51 |
52 | a.none:visited { text-decoration: none; color:black }
53 |
54 | a.none:active { text-decoration: none; color:black }
55 |
56 | a.none:hover { text-decoration: none; color:black }
57 |
58 | a {
59 | text-decoration: none;
60 | }
61 |
62 | a:visited {
63 | text-decoration: none;
64 | }
65 |
66 | a:active {
67 | text-decoration: underline;
68 | }
69 |
70 | a:hover {
71 | text-decoration: underline;
72 | }
73 |
74 | /* @end */
75 |
76 | /* @group Reference */
77 |
78 | .reference {
79 | padding-bottom: 1em;
80 | }
81 |
82 | .reference h3 {
83 | margin-top: 2em;
84 | font-size: 110%;
85 | border-bottom: 1px solid silver;
86 | border-top: 4px solid gray;
87 | padding-top: 3px;
88 | padding-bottom: 3px;
89 | }
90 |
91 |
92 |
93 | /* @end */
94 |
95 | body {
96 | font-family: Georgia, "Times New Roman", Times, serif;
97 | margin-right: 0.75in;
98 | margin-left: 0.75in;
99 | margin-bottom: 0.25in;
100 | }
101 |
102 | h1, h2, h3, h4 {
103 | font-family: "Lucida Grande", Lucida, Verdana, sans-serif;
104 | }
105 |
106 | h2 {
107 | }
108 |
109 | h3, h4 {
110 | font-style: italic;
111 | }
112 |
113 | .hidden {
114 | visibility: hidden;
115 | }
116 |
117 | .documentation {
118 | margin-right: 1em;
119 | margin-left: 1em;
120 | }
121 |
122 | .function {
123 |
124 | }
125 |
126 | .documentation.header {
127 | display: block;
128 | position: relative;
129 | border-top-style: solid;
130 | border-top-width: 1pt;
131 | padding-top: 4px;
132 | margin-top: 2em;
133 | }
134 |
135 | .documentation.contents {
136 | top: 10px;
137 | position: relative;
138 | }
139 |
140 | .documentation-name {
141 | font-weight: bold;
142 | float: left;
143 | padding-right: 10px;
144 | width: 125px;
145 | }
146 |
147 | .documentation-kind {
148 | float: right;
149 | font-style: italic;
150 | color: gray;
151 | padding-left: 10px;
152 | }
153 |
154 | .documentation-arguments {
155 | float: left;
156 | width: 350px;
157 | font-style: italic;
158 | }
159 |
160 | .documentation p {
161 | clear: both;
162 | margin-right: 1em;
163 | margin-left: 1em;
164 | }
165 |
166 | pre {
167 | background-color: #ffc8ff;
168 | overflow: auto;
169 | padding-bottom: 5px;
170 | margin-right: 1cm;
171 | margin-left: 1cm;
172 | font-family: "Courier New", Courier, mono;
173 | }
174 |
175 | .note {
176 | border: 2px inset gray;
177 | padding: 0.5em;
178 | margin-right: 2em;
179 | margin-left: 2em;
180 | }
181 | #navigation li {
182 | display: inline;
183 | border-right-style: dotted;
184 | border-right-width: 1px;
185 | border-left-style: dotted;
186 | border-left-width: 1px;
187 | border-collapse: collapse;
188 | padding-right: 0.25em;
189 | padding-left: 0.25em;
190 | margin-right: 1em;
191 | }
192 |
193 | #navigation {
194 | text-align: center;
195 | }
196 |
197 | #footer {
198 | margin-top: 2em;
199 | padding-bottom: 2em;
200 | padding-top: 1em;
201 | border-top-style: inset;
202 | border-top-width: 2px;
203 | font-size: 80%;
204 | line-height: 110%;
205 | }
206 |
207 | #timestamp {
208 | font-size: 90%;
209 | text-align: right;
210 | float: right;
211 | }
212 |
213 | #license-note {
214 | float: left;
215 | }
216 |
217 | #copyright {
218 | float: left;
219 | }
220 |
221 |
--------------------------------------------------------------------------------
/dev/macros.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang.bind)
2 |
3 | #|
4 |
5 | use
6 |
7 | (defmethod documentation (object doc-type)
8 | body...)
9 |
10 | instead
11 |
12 | (documentation :plist 'binding-form)
13 |
14 | |#
15 |
16 | (defmethod documentation (what (doc-type (eql 'metabang.bind:binding-form)))
17 | (binding-form-docstring what))
18 |
19 | (defun binding-form-docstring (name)
20 | "Returns the docstring for a binding form named `name`."
21 | (let* ((docstrings (get 'bind :docstrings))
22 | (forms (get 'bind :binding-forms))
23 | (canonical-name (first (assoc name forms)))
24 | )
25 | (and canonical-name
26 | (assoc canonical-name docstrings))))
27 |
28 | (defun (setf binding-form-docstring) (docstring name/s)
29 | (when (atom name/s)
30 | (setf name/s (list name/s)))
31 | (let* ((docstrings (get 'bind :docstrings))
32 | (forms (get 'bind :binding-forms))
33 | (canonical-name (first name/s))
34 | (current-docstring-pair (assoc canonical-name docstrings)))
35 | (loop for name in name/s do
36 | (let ((names-pair (assoc name forms)))
37 | (if names-pair
38 | (setf (cdr names-pair) name/s)
39 | (push (cons name name/s) forms))))
40 | (if current-docstring-pair
41 | (setf (cdr current-docstring-pair) docstring)
42 | (push (cons canonical-name docstring) docstrings))
43 | (setf (get 'bind :docstrings) docstrings)
44 | (setf (get 'bind :binding-forms) forms)
45 | docstring))
46 |
47 | (defmacro defbinding-form ((name/s &key docstring remove-nils-p
48 | description (use-values-p t)
49 | (accept-multiple-forms-p nil)) &body body)
50 | "Describe how `bind` should expand particular binding-forms.
51 |
52 | `defbinding-form` links a name or type with an expansion. These
53 | definitions are used by `bind` at macro-expansion time to generate
54 | the code that actually does the bindings for you. For example:
55 |
56 | (defbinding-form (symbol :use-values-p nil)
57 | (if (keywordp kind)
58 | (error \"Don't have a binding form for ~s\" kind)
59 | `(let (,@(if values
60 | `((,variables ,values))
61 | `(,variables))))))
62 |
63 | This binding form tells to expand clauses whose first element is
64 | a symbol using `let`. (It also gets `bind` to signal an error if
65 | the first element is a keyword that doesn't have a defined binding
66 | form.)
67 | "
68 | (declare (ignorable remove-nils-p description))
69 | (let* ((multiple-names? (consp name/s))
70 | (main-method-name nil)
71 | (force-keyword? (or multiple-names?
72 | (eq (symbol-package name/s)
73 | (load-time-value (find-package :keyword)))))
74 | (gnew-form (gensym "new-form")))
75 | (cond (multiple-names?
76 | (setf main-method-name (gensym (symbol-name '#:binding-generator))))
77 | (t
78 | (setf main-method-name 'bind-generate-bindings)))
79 | (flet ((form-keyword (name)
80 | (intern (symbol-name name)
81 | (load-time-value (find-package :keyword)))))
82 | (when force-keyword?
83 | (setf name/s (if multiple-names?
84 | (mapcar #'form-keyword name/s)
85 | (form-keyword name/s))))
86 | `(let ()
87 | (setf (binding-form-docstring ',name/s) ,docstring)
88 | ,@(loop for name in (if multiple-names? name/s (list name/s))
89 | when (keywordp name) collect
90 | `(defmethod binding-form-accepts-multiple-forms-p
91 | ((binding-form (eql ,name)))
92 | ,accept-multiple-forms-p))
93 | (,(if multiple-names? 'defun 'defmethod) ,main-method-name
94 | (,@(unless multiple-names?
95 | (if force-keyword?
96 | `((kind (eql ,name/s)))
97 | `((kind ,name/s))))
98 | variable-form value-form)
99 | ;;?? Can (symbolp (first body)) ever be true?
100 | ,(if use-values-p
101 | `(let* ((gvalues (next-value "values-"))
102 | (,gnew-form (funcall (lambda (variables values) ,@body)
103 | variable-form gvalues)))
104 | (destructuring-bind (TAG . REST)
105 | ,gnew-form
106 | ;;?? CASE
107 | (if (or (eq TAG 'let) (eq TAG 'let*))
108 | (destructuring-bind (let-bindings . after-bindings)
109 | REST
110 | (values `(let* ((,gvalues ,,(if accept-multiple-forms-p
111 | `value-form
112 | `(first value-form)))
113 | ,@let-bindings)
114 | (declare (ignorable ,gvalues))
115 | ,@after-bindings)
116 | nil))
117 | (values `(let* ((,gvalues ,,(if accept-multiple-forms-p
118 | `value-form
119 | `(first value-form))))
120 | (declare (ignorable ,gvalues))
121 | ,,gnew-form)
122 | t))))
123 | `(let ((,gnew-form (funcall (lambda (variables values) ,@body)
124 | variable-form ,(if accept-multiple-forms-p
125 | `value-form
126 | `(first value-form)))))
127 | (values ,gnew-form nil))))
128 | ,@(when multiple-names?
129 | (loop for name in name/s collect
130 | `(defmethod bind-generate-bindings ((kind (eql ,name)) variable-form value-form)
131 | (,main-method-name variable-form value-form))))))))
132 |
133 | (defun next-value (x)
134 | (gensym x))
135 |
136 | (defmacro lambda-bind ((&rest instrs) &body body)
137 | "Use `bind' to allow restructuring of argument to lambda expressions.
138 |
139 | This lets you funcall and destructure simultaneously. For example
140 |
141 | (let ((fn (lambda-bind ((a b) c) (cons a c))))
142 | (funcall fn '(1 2) 3))
143 | ;; => (1 . 3)
144 |
145 | Via eschulte (see git://gist.github.com/902174.git).
146 | "
147 | #+(or)
148 | (declare (indent 1))
149 | (let* ((evald-instrs instrs)
150 | (syms (mapcar (lambda (_)
151 | (declare (ignore _))
152 | (gensym))
153 | evald-instrs)))
154 | `(lambda ,syms (bind ,(mapcar #'list evald-instrs syms) ,@body))))
155 |
156 |
--------------------------------------------------------------------------------
/unit-tests/test-bind.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:metabang-bind-test)
2 |
3 | (deftestsuite metabang-bind-test () ())
4 |
5 | (deftestsuite test-bind-fix-nils-destructured (metabang-bind-test)
6 | ())
7 |
8 | (addtest (test-bind-fix-nils-destructured)
9 | simple-list
10 | (ensure-same (bind-fix-nils-destructured '(a b c)) (values '(a b c) nil)
11 | :test #'equal))
12 |
13 | (addtest (test-bind-fix-nils-destructured)
14 | simple-list-with-nil
15 | (multiple-value-bind (vars ignores)
16 | (bind-fix-nils-destructured '(a nil c))
17 | (ensure-same (first vars) 'a)
18 | (ensure-same (third vars) 'c)
19 | (ensure-same (second vars) (first ignores))))
20 |
21 | (addtest (test-bind-fix-nils-destructured)
22 | simple-list-with-_
23 | (multiple-value-bind (vars ignores)
24 | (bind-fix-nils-destructured '(a _ c))
25 | (ensure-same (first vars) 'a)
26 | (ensure-same (third vars) 'c)
27 | (ensure-same (second vars) (first ignores))))
28 |
29 | (addtest (test-bind-fix-nils-destructured)
30 | simple-list-with-_-2
31 | (multiple-value-bind (vars ignores)
32 | (bind-fix-nils-destructured '(a _ c _ _))
33 | (ensure-same (first vars) 'a)
34 | (ensure-same (third vars) 'c)
35 | (ensure (member (second vars) ignores))
36 | (ensure (member (fourth vars) ignores))
37 | (ensure (member (fifth vars) ignores))))
38 |
39 | (addtest (test-bind-fix-nils-destructured)
40 | dotted-list
41 | (multiple-value-bind (vars ignores)
42 | (bind-fix-nils-destructured '(a . b))
43 | (ensure-same (car vars) 'a)
44 | (ensure-same (cdr vars) 'b)
45 | (ensure-same ignores nil)))
46 |
47 | (addtest (test-bind-fix-nils-destructured)
48 | dotted-list-with-nil-1
49 | (multiple-value-bind (vars ignores)
50 | (bind-fix-nils-destructured '(nil . b))
51 | (ensure-same (car vars) (first ignores))
52 | (ensure-same (cdr vars) 'b)
53 | (ensure-same (length ignores) 1)))
54 |
55 | (addtest (test-bind-fix-nils-destructured)
56 | keyword-list
57 | (multiple-value-bind (vars ignores)
58 | (bind-fix-nils-destructured '(a b &key (c 1) d (e x y)))
59 | (ensure-same (length vars) 6)
60 | (ensure-same (length ignores) 0)
61 | (ensure-same vars '(a b &key (c 1) d (e x y)) :test #'equal)))
62 |
63 | (addtest (test-bind-fix-nils-destructured)
64 | keyword-list-with-nil-non-keyword
65 | (multiple-value-bind (vars ignores)
66 | (bind-fix-nils-destructured '(nil b &key (c 1) d (e x y)))
67 | (ensure-same (length ignores) 1)
68 | (ensure-same (rest vars) '(b &key (c 1) d (e x y)) :test #'equal)
69 | (ensure-same (first vars) (first ignores))))
70 |
71 | (addtest (test-bind-fix-nils-destructured)
72 | keyword-list-with-nil-keyword
73 | (multiple-value-bind (vars ignores)
74 | (bind-fix-nils-destructured '(a b &key (c 1) nil (e x y)))
75 | (ensure-same (length ignores) 1)
76 | (ensure-same (subseq vars 0 3) '(a b &key) :test #'equal)
77 | (ensure-same (fifth vars) (first ignores))
78 | (ensure-same (fourth vars) '(c 1) :test 'equal)))
79 |
80 | (addtest (test-bind-fix-nils-destructured)
81 | keyword-list-with-nil-default
82 | (multiple-value-bind (vars ignores)
83 | (bind-fix-nils-destructured '(a b &key (c nil c?)))
84 | (ensure-same (length ignores) 0)
85 | (ensure-same (subseq vars 0 3) '(a b &key) :test #'equal)
86 | (ensure-same (fourth vars) '(c nil c?) :test 'equal)))
87 |
88 | #+Ignore
89 | ;;?? not yet
90 | (addtest (test-bind-fix-nils-destructured)
91 | keyword-list-with-bad-nil-keyword-syntax
92 | (ensure-condition 'bind-keyword/optional-nil-with-default-error
93 | (bind-fix-nils-destructured '(a b &key (nil 1) d (e x y)))))
94 |
95 | (addtest (test-bind-fix-nils-destructured)
96 | keyword-list-with-allow-other-keys
97 | (multiple-value-bind (vars ignores)
98 | (bind-fix-nils-destructured '(a b &key (c 1) d (e x y)
99 | &allow-other-keys))
100 | (ensure-same (length ignores) 0)
101 | (ensure-same vars '(a b &key (c 1) d (e x y)
102 | &allow-other-keys) :test #'equal)))
103 |
104 | ;;;;
105 |
106 | (deftestsuite test-bind-style-warnings (metabang-bind-test)
107 | ())
108 |
109 | (addtest (test-bind-style-warnings)
110 | missing-value-1
111 | (ensure-condition metabang-bind:bind-missing-value-form-warning
112 | (macroexpand '(bind (((:values a b))) (list a b)))))
113 |
114 | (addtest (test-bind-style-warnings)
115 | missing-value-2
116 | (ensure-no-warning
117 | (macroexpand '(bind (((:values a b) (foo))) (list a b)))))
118 |
119 | (addtest (test-bind-style-warnings)
120 | missing-value-3
121 | (ensure-no-warning
122 | (macroexpand '(bind (a) (list a)))))
123 |
124 | (addtest (test-bind-style-warnings)
125 | missing-value-4
126 | (ensure-no-warning
127 | (macroexpand '(bind ((a nil)) (list a)))))
128 |
129 | (addtest (test-bind-style-warnings)
130 | two-many-value-forms-error
131 | (ensure-cases (form)
132 | '((a b c)
133 | ((:values a b) 1 2 3))
134 | (ensure-condition metabang-bind:bind-too-many-value-forms-error
135 | (macroexpand `(bind (,form) (list a))))))
136 |
137 | (addtest (test-bind-style-warnings)
138 | two-many-value-forms-warnings-with-flet
139 | (ensure-no-warning
140 | (macroexpand `(bind (((:flet x (a)) (setf a (* 2 a)) (list a))) (x 2)))))
141 |
142 | ;;;;
143 |
144 | (deftestsuite test-ignore-underscores (metabang-bind-test)
145 | ()
146 | (:equality-test (lambda (a b)
147 | (equalp (remove-gensyms a) (remove-gensyms b)))))
148 |
149 | (addtest (test-ignore-underscores)
150 | test-simple-destructuring
151 | (ensure-same
152 | (macroexpand '(bind (((nil a b) (foo)))
153 | (list a b)))
154 | (macroexpand '(bind (((_ a b) (foo)))
155 | (list a b)))))
156 |
157 | (addtest (test-ignore-underscores)
158 | test-multiple-values
159 | (ensure-same
160 | (macroexpand '(bind (((:values a nil b) (foo)))
161 | (list a b)))
162 | (macroexpand '(bind (((:values a _ b) (foo)))
163 | (list a b)))))
164 |
165 | (addtest (test-ignore-underscores)
166 | test-array
167 | (ensure-same
168 | (macroexpand '(bind ((#(a nil b) (foo)))
169 | (list a b)))
170 | (macroexpand '(bind ((#(a _ b) (foo)))
171 | (list a b)))))
172 |
173 | ;;;
174 |
175 | (deftestsuite test-for-unused-declarations (metabang-bind-test)
176 | ())
177 |
178 | (addtest (test-for-unused-declarations)
179 | test-error-1
180 | (let ((bind:*unused-declarations-behavior* :error))
181 | (ensure-condition bind::bind-unused-declarations-error
182 | (eval '(bind:bind ((a 2) (b 3))
183 | (declare (type fixnum a b c) (optimize (speed 3)))
184 | a b)))))
185 |
186 | (addtest (test-for-unused-declarations)
187 | test-error-2
188 | (let ((bind:*unused-declarations-behavior* :error))
189 | (ensure-condition bind:bind-unused-declarations-error
190 | (eval '(bind:bind (((:values _ b ) (values 1 2)))
191 | (declare (type fixnum b) (ignorable b)
192 | (simple-vector d) (optimize (speed 3)))
193 | b)))))
194 |
195 | (addtest (test-for-unused-declarations)
196 | test-warning-1
197 | (let ((bind:*unused-declarations-behavior* :warn))
198 | (ensure-condition bind::bind-unused-declarations-warning
199 | (eval '(bind:bind ((a 2) (b 3))
200 | (declare (type fixnum a b c) (optimize (speed 3)))
201 | a b)))))
202 |
203 | (addtest (test-for-unused-declarations)
204 | test-warning-2
205 | (let ((bind:*unused-declarations-behavior* :warn))
206 | (ensure-condition bind::bind-unused-declarations-warning
207 | (eval '(bind:bind (((:values _ b ) (values 1 2)))
208 | (declare (type fixnum b) (ignorable b)
209 | (simple-vector d) (optimize (speed 3)))
210 | b)))))
211 |
212 | (addtest (test-for-unused-declarations)
213 | test-no-warning-1
214 | (let ((bind:*unused-declarations-behavior* nil))
215 | (ensure-no-warning
216 | (eval '(bind:bind (((:values _ b ) (values 1 2)))
217 | (declare (type fixnum b) (ignorable b)
218 | (simple-vector d) (optimize (speed 3)))
219 | b)))))
220 |
221 | ;;;
222 |
223 | #|
224 |
225 | (defun x (a b)
226 | (declare (fixnum a b))
227 | (+ a b))
228 |
229 | (defun x (c)
230 | (bind (((:structure/rw c- a b) c))
231 | (declare (fixnum a b))
232 | (declare (optimize (speed 3) (safety 0)))
233 | (+ a b)))
234 |
235 | (disassemble 'x)
236 |
237 | (bind (((:structure/rw foo- a b c) (bar)))
238 | (declare (type fixnum a) (double b))
239 | (declare (optimize (speed 3)))
240 | )
241 |
242 | |#
243 |
--------------------------------------------------------------------------------
/website/source/user-guide.mmd:
--------------------------------------------------------------------------------
1 | {comment http://metabang.com/unclogit/?p=154}
2 |
3 | {include resources/guide-header.md}
4 | {set-property title "metabang-bind user guide"}
5 |
6 | {set-property html yes}
7 | {set-property title "metabang-bind | Guide to the perplexed"}
8 | {set-property style-sheet user-guide}
9 | {set-property docs-package metabang-bind}
10 |
11 | # metabang-bind user guide
12 |
13 | {table-of-contents :start 2 :depth 3}
14 |
15 | ## Introduction
16 |
17 | `bind` combines _let_, _destructuring-bind_, _multiple-value-bind_
18 | *and** a whole lot more into a single form. It has two goals:
19 |
20 | 1. reduce the number of nesting levels
21 |
22 | 2. make it easier to understand all of the different forms of
23 | destructuring and variable binding by unifying the multiple forms of
24 | syntax and reducing special cases.
25 |
26 | `bind` is extensible. It handles the traditional multiple-values,
27 | destructuring, and let-forms as well as property-lists, classes, and
28 | structures. Even better, you can create your own binding forms to make
29 | your code cleaner and easier to follow (for others _and_ yourself!).
30 |
31 | Simple bindings are as in _let*_. Destructuring is done if the first
32 | item in a binding is a list. Multiple value binding is done if the
33 | first item in a binding is a list and the first item in the list is
34 | the keyword ':values'.
35 |
36 |
37 | {remark
38 | ### Summary
39 |
40 |
6 |
7 | * [User's guide](user-guide.html)
8 | * [Issue tracker](https://github.com/gwkkwg/metabang-bind/issues)
9 | * [Mailing Lists][3]
10 | * [Getting it][4]
11 | * [News][6]
12 | * [Changelog][7]
13 |
14 | [3]: #mailing-lists
15 | [4]: #downloads
16 | [5]: documentation/ (documentation link)
17 | [6]: #news
18 | [7]: changelog.html
19 |
20 |
21 |
22 |
23 |
24 | ### What it is
25 |
26 | Bind extends the idea of of `let` and destructing to provide
27 | a uniform syntax for all your accessor needs. It combines
28 | _let_, _destructuring-bind_, `with-slots`, `with-accessors`,
29 | structure editing, property or association-lists, and
30 | _multiple-value-bind_ and a whole lot more into a single
31 | form. The [user guide][user-guide] has all the details but
32 | here is example to whet your appetite:
33 |
34 | (bind ((a 2)
35 | ((b &rest args &key (c 2) &allow-other-keys) '(:a :c 5 :d 10 :e 54))
36 | ((:values d e) (truncate 4.5)))
37 | (list a b c d e args))
38 | ==> (2 :A 5 4 0.5 (:C 5 :D 10 :E 54))
39 |
40 | Bind is especially handy when you have more than one layer of
41 | `multiple-value-bind` or `destructuring-bind`. Since `bind` is a
42 | single form, you don't end up too far off to the right in
43 | editor land.
44 |
45 | Bind is released under the [MIT license][mit-license].
46 |
47 | {anchor mailing-lists}
48 |
49 | ### Mailing Lists
50 |
51 | Use the developer [mailing list][metabang-bind-devel] for any questions or comments regarding bind.
52 |
53 | {anchor downloads}
54 |
55 | ### Where is it
56 |
57 | metabang.com is switching from [darcs][] to [git][] for source control; the current metabang-bind repository is on [github][github-metabang-bind] and you can clone it using:
58 |
59 | git clone git://github.com/gwkkwg/metabang-bind
60 |
61 | metabang-bind is also [ASDF installable][asdf-install]. Its
62 | CLiki home is right [where][cliki-home] you'd expect.
63 |
64 | There's also a handy [gzipped tar file][tarball].
65 |
66 | {anchor news}
67 |
68 | ### What is happening
69 |
70 | 10 April 2010 - moved to github; added flet support
71 |
72 | 28 May 2009 - added `:structure/rw` binding form; updated
73 | webpage to link to the user's guide
74 |
75 | 1 Dec 2007 - Added support for [array
76 | destructuring][array-bindings] (Thanks to Tamas Papp for the
77 | idea)
78 |
79 | 15 Nov 2007 - New user guide; bind handles structures and
80 | property lists and is now extensible!
81 |
82 | 13 Nov 2005 - Initial webpage n' stuff.
83 |
84 |
85 | | symbol | `x` or `(x 45)` | `let` | 43 |array | `(#(a b) #(4 5))` | `let` | 44 |