pax_global_header00006660000000000000000000000064124145301000014500gustar00rootroot0000000000000052 comment=f2214a8597457ea72bbeb9ba40fa7d187d3faff9 metabang-bind-20141106-git/000077500000000000000000000000001241453010000152115ustar00rootroot00000000000000metabang-bind-20141106-git/.boring000066400000000000000000000010231241453010000164660ustar00rootroot00000000000000# Boring file regexps: \.hi$ \.o$ \.o\.cmd$ \.ko$ \.ko\.cmd$ \.mod\.c$ (^|/)\.tmp_versions($|/) (^|/)CVS($|/) (^|/)RCS($|/) ~$ #(^|/)\.[^/] (^|/)_darcs($|/) \.bak$ \.BAK$ \.orig$ (^|/)vssver\.scc$ \.swp$ (^|/)MT($|/) (^|/)\{arch\}($|/) (^|/).arch-ids($|/) (^|/), \.class$ \.prof$ (^|/)\.DS_Store$ (^|/)BitKeeper($|/) (^|/)ChangeSet($|/) (^|/)\.svn($|/) \.py[co]$ \# \.cvsignore$ (^|/)Thumbs\.db$ (^|/)test-results($|/) \.dribble (^|/)make($|/) (^|/)benchmark-data($|/) (^|/)test-report-.*($|/) (^)init-lisp.lisp$ common-lisp\.net$ metabang-bind-20141106-git/.gitignore000066400000000000000000000003111241453010000171740ustar00rootroot00000000000000# really this is private to my build process make/ common-lisp.net .vcs GNUmakefile init-lisp.lisp website/changelog.xml lift.tar.gz website/output/ test-results*/ lift-local.config *.dribble *.fasl metabang-bind-20141106-git/COPYING000066400000000000000000000021161241453010000162440ustar00rootroot00000000000000Copyright (c) 2004-2008 Gary Warren King (gwking@metabang.com) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. metabang-bind-20141106-git/README000066400000000000000000000000001241453010000160570ustar00rootroot00000000000000metabang-bind-20141106-git/dev/000077500000000000000000000000001241453010000157675ustar00rootroot00000000000000metabang-bind-20141106-git/dev/bind-cl-ppcre.lisp000066400000000000000000000052461241453010000213060ustar00rootroot00000000000000(in-package #:metabang.bind.developer) (defmethod bind-generate-bindings ((kind (eql :re)) variable-form value-form body declarations remaining-bindings) ;; (:re "re" vars) (bind (((regex &rest vars) variable-form) (gok (gensym "ok")) (gblock (gensym "block")) ((:values vars ignores) (bind-fix-nils vars))) `((let ((,gok nil)) (block ,gblock (flet ((doit (,@vars) ,@(when ignores `((declare (ignore ,@ignores)))) (return-from ,gblock (progn ,@(bind-macro-helper remaining-bindings declarations body))))) (cl-ppcre:register-groups-bind ,vars (,regex ,(first value-form) :sharedp t) ,(bind-filter-declarations declarations variable-form) (setf ,gok t) (doit ,@vars)) (unless ,gok (doit ,@(make-list (length vars) :initial-element nil))))))))) #+(or) ;; simple but doesn't execute inner code if no bindings found ;; which isn't very bind-like (defmethod bind-generate-bindings ((kind (eql :re)) variable-form value-form body declarations remaining-bindings) ;; (:re "re" vars) (bind (((regex &rest vars) variable-form)) `((cl-ppcre:register-groups-bind ,vars (,regex ,(first value-form) :sharedp t) ,(bind-filter-declarations declarations variable-form) ,@(bind-macro-helper remaining-bindings declarations body))))) #+(or) ;; doesn't handle ignores (defmethod bind-generate-bindings ((kind (eql :re)) variable-form value-form body declarations remaining-bindings) ;; (:re "re" vars) (bind (((regex &rest vars) variable-form) (gok (gensym "ok")) (gblock (gensym "block"))) `((let ((,gok nil)) (block ,gblock (flet ((doit (,@vars) (return-from ,gblock ,@(bind-macro-helper remaining-bindings declarations body)))) (cl-ppcre:register-groups-bind ,vars (,regex ,(first value-form) :sharedp t) ,(bind-filter-declarations declarations variable-form) (setf ,gok t) (doit ,@vars)) (unless ,gok (doit ,@(make-list (length vars) :initial-element nil))))))))) #+(or) (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname date month year) "Frank Zappa 21.12.1940")) (list fname lname date month year)) #+(or) (macroexpand-1 '(bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname date month year) "Frank Zappa 21.12.1940")) (list fname lname date month year))) #+(or) (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname nil month year) "Frank Zappa 21.12.1940")) (list fname lname month year)) #+(or) (bind (((:re "(a|b)+" first) "cccc")) (format t "This will still be printed: ~A" first)) metabang-bind-20141106-git/dev/bind-re-allegro.lisp000066400000000000000000000020411241453010000216200ustar00rootroot00000000000000(in-package #:metabang.bind.developer) (defmethod bind-generate-bindings ((kind (eql :re)) variable-form value-form body declarations remaining-bindings) ;; (:re "re" vars) (bind (((regex &rest vars) variable-form) (gok (gensym "ok")) (gblock (gensym "block")) ((:values vars ignores) (bind-fix-nils vars))) `((let ((,gok nil)) (block ,gblock (flet ((doit (,@vars) ,@(when ignores `((declare (ignore ,@ignores)))) (return-from ,gblock (progn ,@(bind-macro-helper remaining-bindings declarations body))))) (excl:re-let ,regex ,(first value-form) ,(loop for var in vars for i from 1 collect `(,var ,i)) ,(bind-filter-declarations declarations variable-form) (setf ,gok t) (doit ,@vars)) (unless ,gok (doit ,@(make-list (length vars) :initial-element nil))))))))) #+(or) (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname date month year) "Frank Zappa 21.12.1940")) (list fname lname date month year)) metabang-bind-20141106-git/dev/bind.lisp000066400000000000000000000320331241453010000175750ustar00rootroot00000000000000;;;-*- Mode: Lisp; Package: bind -*- #| simple-header See the file COPYING for details |# (in-package #:metabang.bind) (defgeneric binding-form-accepts-multiple-forms-p (binding-form) (:documentation "Returns true if a binding form can accept multiple forms (e.g., :flet)")) (defmethod binding-form-accepts-multiple-forms-p ((binding-form t)) nil) (defparameter *unused-declarations-behavior* :print-warning "Tells bind how to behave when it encounters an unused declaration. The possible options are * :print-warning (the current default) - print a warning about the problem and signal a `bind-unused-declarations-condition` * :warn - signal a `bind-unused-declarations-warning` warning * :error - signal a `bind-unused-declarations-error` error") (defparameter *bind-all-declarations* '(dynamic-extent ignore optimize ftype inline special ignorable notinline type)) (defparameter *bind-non-var-declarations* '(optimize ftype inline notinline #+allegro :explain)) (defparameter *bind-simple-var-declarations* (remove 'type (set-difference *bind-all-declarations* *bind-non-var-declarations*))) (defparameter *bind-lambda-list-markers* '(&key &body &rest &args &optional)) (define-condition simple-style-warning (style-warning simple-warning) ()) (defun simple-style-warning (message &rest args) (warn 'simple-style-warning :format-control message :format-arguments args)) (define-condition bind-missing-value-form-warning (simple-style-warning) ((variable-form :initform nil :initarg :variable-form :reader variable-form)) (:report (lambda (c s) (format s "Missing value form for ~s" (variable-form c))))) (define-condition bind-too-many-value-forms-error (error) ((variable-form :initform nil :initarg :variable-form :reader variable-form) (value-form :initform nil :initarg :value-form :reader value-form)) (:report (lambda (c s) (format s "Two many value forms for ~s" (variable-form c))))) (define-condition bind-error (error) ((binding :initform nil :initarg :binding :reader binding))) (define-condition bind-keyword/optional-nil-with-default-error (bind-error) ((bad-variable :initform nil :initarg :bad-variable :reader bad-variable)) (:report (lambda (c s) (format s "Bad binding '~S' in '~A'; cannot use a default value for &key or &optional arguments." (bad-variable c) (binding c))))) (define-condition bind-unused-declarations-condition () ((unused-declarations :initform (error "must supply unused-declarations") :initarg :unused-declarations :reader unused-declarations)) (:report (lambda (c s) (format s "Unused declarations in bind: ~{~s~^, ~}" (unused-declarations c))))) (define-condition bind-unused-declarations-warning (bind-unused-declarations-condition simple-style-warning) ()) (define-condition bind-unused-declarations-error (bind-unused-declarations-condition error) ()) (defun binding-forms () "Return a list of all binding-forms that bind supports in alphabetical order." (let* ((forms (get 'bind :binding-forms))) (sort (loop for form in forms collect (car form)) 'string-lessp))) (defun binding-form-groups () "Return a list of the available binding-forms grouped into their synonyms." (let ((binding-forms (get 'bind :binding-forms)) (canonical-names (sort (delete-duplicates (mapcar #'second (get 'bind :binding-forms))) #'string-lessp))) (loop for form in canonical-names collect (cdr (assoc form binding-forms))))) (defun binding-form-synonyms (name) "Return a list of synonyms for the binding-form `name`. For example > (binding-form-synonyms :accessors) (:accessors :writable-accessors) " (let* ((forms (get 'bind :binding-forms)) (datum (assoc name forms))) (and datum (rest datum)))) (defvar *all-declarations*) (defmacro bind ((&rest bindings) &body body) "Bind is a replacement for let*, destructuring-bind, multiple-value-bind and more. An example is probably the best way to describe its syntax: \(bind \(\(a 2\) \(\(b &rest args &key \(c 2\) &allow-other-keys\) '\(:a :c 5 :d 10 :e 54\)\) \(\(:values d e\) \(truncate 4.5\)\)\) \(list a b c d e args\)\) Simple bindings are as in let*. Destructuring is done if the first item in a binding is a list. Multiple value binding is done if the first item in a binding is a list and the first item in the list is ':values'." (let (declarations) (loop while (and (consp (car body)) (eq (caar body) 'declare)) do (push (first body) declarations) (setf body (rest body))) (if bindings (let ((*all-declarations* (bind-expand-declarations (nreverse declarations)))) (prog1 (first (bind-macro-helper bindings *all-declarations* body)) (check-for-unused-variable-declarations *all-declarations*))) `(locally ,@declarations ,@body)))) (defun check-for-unused-variable-declarations (declarations) (when declarations (case *unused-declarations-behavior* (:warn (warn 'bind-unused-declarations-warning :unused-declarations declarations)) (:error (error 'bind-unused-declarations-error :unused-declarations declarations)) (t (format *error-output* "~&;;; warning: wnused declarations found in form: ~{~s~^, ~}." declarations) (signal 'bind-unused-declarations-condition :unused-declarations declarations))))) (defun bind-macro-helper (bindings declarations body) (if bindings (let ((binding (first bindings)) (remaining-bindings (rest bindings)) variable-form value-form atomp binding-form) (if (consp binding) (setf variable-form (first binding) value-form (rest binding) ;; (second binding) atomp (if (consp variable-form) nil (null value-form))) (setf variable-form binding atomp t)) (unless (or atomp value-form) (warn 'bind-missing-value-form-warning :variable-form variable-form)) (setf binding-form (and (consp variable-form) (and (symbolp (first variable-form)) (eq (symbol-package (first variable-form)) (load-time-value (find-package :keyword))) (first variable-form)))) (when (and (consp value-form) (cdr value-form) (or (null binding-form) (not (binding-form-accepts-multiple-forms-p binding-form)))) (error 'bind-too-many-value-forms-error :variable-form variable-form :value-form value-form)) ;;(print (list :vf variable-form :value value-form :a atomp :b binding-form)) (if binding-form (bind-generate-bindings (first variable-form) (rest variable-form) value-form body declarations remaining-bindings) (bind-generate-bindings variable-form variable-form value-form body declarations remaining-bindings))) body)) ;;;; (defun var-ignorable-p (var) (or (null var) (and (symbolp var) (string= (symbol-name var) (symbol-name '_))))) (defun mint-ignorable-variable () (gensym (symbol-name '#:bind-ignore-))) (defun bind-fix-nils (var-list) (let (vars ignores) (loop for v in var-list do (cond ((var-ignorable-p v) (let ((ignore (mint-ignorable-variable))) (push ignore vars) (push ignore ignores))) (t (push v vars)))) (values (nreverse vars) ignores))) (defun bind-fix-nils-destructured (var-list) (let ((ignores nil)) (labels (;; adapted from metatilities (tree-map (fn tree) "Maps FN over every atom in TREE." (cond ;; ((null tree) nil) ((atom tree) (funcall fn tree)) (t (cons (tree-map fn (car tree)) (when (cdr tree) (tree-map fn (cdr tree)))))))) (values (tree-map (lambda (x) (cond ((var-ignorable-p x) (let ((ignore (mint-ignorable-variable))) (push ignore ignores) ignore)) (t x))) var-list) ignores)))) (defun dotted-pair-p (putative-pair) "Returns true if and only if `putative-pair` is a dotted-list. I.e., if `putative-pair` is a cons cell with a non-nil cdr." (and (consp putative-pair) (cdr putative-pair) (not (consp (cdr putative-pair))))) (defun bind-get-vars-from-lambda-list (lambda-list) (let ((result nil)) (labels ((do-it (thing) (cond ((atom thing) (unless (or (member thing *bind-lambda-list-markers*) (null thing)) (push thing result))) ((dotted-pair-p thing) (do-it (car thing)) (do-it (cdr thing))) (t (do-it (car thing)) (do-it (cdr thing)))))) (do-it lambda-list)) (nreverse result))) #+(or) (loop for item in lambda-list unless (member item *bind-lambda-list-markers*) collect (if (consp item) (first item) item)) (defun bind-expand-declarations (declarations) (loop for declaration in declarations append (loop for decl in (rest declaration) append (cond ((member (first decl) *bind-non-var-declarations*) (list decl)) ((member (first decl) *bind-simple-var-declarations*) (loop for var in (rest decl) collect `(,(first decl) ,var))) (t ;; a type spec (when (eq (first decl) 'type) (setf decl (rest decl))) (loop for var in (rest decl) collect `(type ,(first decl) ,var))))))) (defun bind-filter-declarations (declarations var-names) (setf var-names (if (consp var-names) var-names (list var-names))) (setf var-names (bind-get-vars-from-lambda-list var-names)) ;; each declaration is separate (let ((declaration (loop for declaration in declarations when (or (member (first declaration) *bind-non-var-declarations*) (and (member (first declaration) *bind-simple-var-declarations*) (member (if (atom (second declaration)) (second declaration) ;; ... (function foo) ...) (second (second declaration))) var-names)) ;; type (member (third declaration) var-names)) collect (progn (setf *all-declarations* (remove declaration *all-declarations*)) declaration)))) (when declaration `((declare ,@declaration))))) ;;; fluid-bind (defmacro fluid-bind ((&rest bindings) &body body) "Fluid-bind is an extension of bind that handles setting and resetting places. For example, suppose that an object of class foo has a slot named bar whose value is currently 3. The following code would evaluate the inner body with bar bound to 17 and restore it when the inner body is exited. \(fluid-bind \(\(\(bar foo\) 17\)\) \(print \(bar foo\)\)\) \(print \(bar foo\)\) ==> \(prints 17, then 3\) This is similar to dynamic-binding but _much_ less robust." ;; does not handle declarations correctly (let ((setup-forms nil) (cleanup-forms nil) (gensyms nil)) (loop for binding in bindings collect (destructuring-bind (setup-form cleanup-form) (cond ((consp binding) (destructuring-bind (var value) binding (let ((g (gensym))) (push g gensyms) (cond ((atom var) `((:bind (,var ,value)) nil) #+(or) ;; lexical or special? (if (boundp var) `((:bind (,var ,value)) nil) `((:setf (setf ,g ,var ,var ,value)) (setf ,var ,g)))) ((and (fboundp (first var)) (not (eq (first var) 'values))) ;; putative place `((:setf (setf ,g ,var ,var ,value)) (setf ,var ,g))) (t `((:bind (,var ,value)) nil)))))) (t `((:bind (,binding nil)) nil))) (push setup-form setup-forms) (push cleanup-form cleanup-forms))) (let ((result body)) (mapc (lambda (setup cleanup) (setf result (ecase (first setup) (:setf `((unwind-protect (progn ,(second setup) ,@result) ,cleanup))) (:bind `((bind (,(second setup)) ,@result))))) result) setup-forms cleanup-forms) `(let ,gensyms (declare (ignorable ,@gensyms)) ,@result)))) #| (let ((a 2)) (fluid-bind ((a 3)) (print a)) (print a)) (fluid-bind (((population (current-world-state)) t)) (print (population (current-world-state)))) (fluid-bind ((a 3) (*last-world* t) (*foo* nil)) (declare (fixnum a)) (print (list *last-world* *foo* a)) (error "Ouch")) (defvar *foo* 3) (unwind-protect (bind ((#:g1 *last-world*)) (setf *last-world* t) (unwind-protect (bind ((#:2 *foo*)) (setf *foo* nil) (bind ((a 3)) (list *last-world* *foo* a))) (setf *foo #:2))) (set *last-world* #:g1)) (fluid-bind (a b) (+ a a)) |# metabang-bind-20141106-git/dev/binding-forms.lisp000066400000000000000000000421611241453010000214220ustar00rootroot00000000000000(in-package #:metabang.bind) (defgeneric bind-generate-bindings (kind variable-form value-form body declarations remaining-bindings) (:documentation "Handle the expansion for a particular binding-form. `kind` specifies the binding form. It can be a type (e.g., symbol or array) or a keyword (e.g., :flet or :plist). `variable-form` and `value-form` are taken from the binding-form given to `bind`. E.g., if you have a bind like (bind (((:values a b c) (foo)) (x 2)) (declare (optimize (speed 3)) (type simple-array a)) ...) then `kind` will be :values, `variable-form` will be the list `(a b c)` and `value-form` will be the expression `(foo)`. `bind-generate-bindings` uses these variables as data to construct the generated code. `body` contains the rest of the code passed to `bind` (the `...`) above in this case) and can usually be ignored. `declarations` contains all of the declarations from the `bind` form (e.g. the `optimize (speed 3)` and so on) and should be used to insert whatever declarations match at this particular point in the expansion. Use [bind-filter-declarations][] to do this easily). Finally, remaining-bindings contains the rest of the binding-forms. It can also be safely ignored.")) (defbinding-form (array :use-values-p t) (let* ((dimensions (array-dimensions variables)) (array-size (array-total-size variables)) (accessor (if (cdr dimensions) 'row-major-aref 'aref))) `(let* (,@(loop for i below array-size for var = (row-major-aref variables i) unless (var-ignorable-p var) collect `(,var (,accessor ,values ,i))))))) (defbinding-form (symbol :use-values-p nil) (if (keywordp kind) (error "Don't have a binding form for ~s" kind) `(let (,@(if values `((,variables ,values)) `(,variables)))))) (defbinding-form (:flet :docstring "Local functions are defined using \(:flet \(\) \) When the function definition occurs in a progn. For example: \(bind \(\(\(:flet double-list \(x\)\) \(setf x \(* 2 x\)\) \(list x x\)\)\) \(double-list 45\)\) ==> (90 90) " :use-values-p nil :accept-multiple-forms-p t) (destructuring-bind (name args) variables (let* (declaration body docstring) (when (typep (first values) 'string) (setf docstring (first values) values (rest values))) (when (and (listp (first values)) (eq (caar values) 'declare)) (setf declaration (first values) values (rest values))) (setf body values) `(flet ((,name ,args ,@(when docstring `(,docstring)) ,@(when declaration `(,declaration)) (progn ,@body))))))) (defbinding-form ((:dynamic-flet :dflet) :docstring "Local functions are defined using \(:dynamic-flet \(\) \) Where the function definition occurs in a progn. For example: \(bind \(\(\(:flet double-list \(x\)\) \(setf x \(* 2 x\)\) \(list x x\)\)\) \(double-list 45\)\) ==> (90 90) The functions are automatically declared dynamic-extent " :use-values-p nil :accept-multiple-forms-p t) (destructuring-bind (name args) variables (let* (declaration body docstring) (when (typep (first values) 'string) (setf docstring (first values) values (rest values))) (when (and (listp (first values)) (eq (caar values) 'declare)) (setf declaration (first values) values (rest values))) (setf body values) `(flet ((,name ,args ,@(when docstring `(,docstring)) ,@(when declaration `(,declaration)) (progn ,@body))) (declare (dynamic-extent (function ,name))))))) (defbinding-form (:labels :docstring "Local functions are defined using \(:labels \(\) \) When the function definition occurs in a progn. For example: \(bind \(\(\(:flet double-list \(x\)\) \(setf x \(* 2 x\)\) \(list x x\)\)\) \(double-list 45\)\) ==> (90 90) " :use-values-p nil :accept-multiple-forms-p t) (destructuring-bind (name args) variables (let* (declaration body docstring) (when (typep (first values) 'string) (setf docstring (first values) values (rest values))) (when (and (listp (first values)) (eq (caar values) 'declare)) (setf declaration (first values) values (rest values))) (setf body values) `(labels ((,name ,args ,@(when docstring `(,docstring)) ,@(when declaration `(,declaration)) (progn ,@body))))))) (defbinding-form ((:dynamic-labels :flabels) :docstring "Local functions are defined using \(:dynamic-labels \(\) \) When the function definition occurs in a progn. For example: \(bind \(\(\(:flet double-list \(x\)\) \(setf x \(* 2 x\)\) \(list x x\)\)\) \(double-list 45\)\) ==> (90 90) The functions are automatically declared dynamic-extent " :use-values-p nil :accept-multiple-forms-p t) (destructuring-bind (name args) variables (let* (declaration body docstring) (when (typep (first values) 'string) (setf docstring (first values) values (rest values))) (when (and (listp (first values)) (eq (caar values) 'declare)) (setf declaration (first values) values (rest values))) (setf body values) `(labels ((,name ,args ,@(when docstring `(,docstring)) ,@(when declaration `(,declaration)) (progn ,@body))) (declare (dynamic-extent (function ,name))))))) (defbinding-form (cons :use-values-p nil) (multiple-value-bind (vars ignores) (bind-fix-nils-destructured variables) `(destructuring-bind ,vars ,values ,@(when ignores `((declare (ignore ,@ignores))))))) (defbinding-form (:values :docstring "" :use-values-p nil) (multiple-value-bind (vars ignores) (bind-fix-nils variables) `(multiple-value-bind ,vars ,values ,@(when ignores `((declare (ignore ,@ignores))))))) (defbinding-form ((:struct :structure) :docstring "Structure fields are accessed using a concatenation of the structure's `conc-name` and the name of the field. Bind therefore needs to know two things: the conc-name and the field-names. The binding-form looks like (:structure structure-spec*) where each `structure-spec` is an atom or list with two elements: * an atom specifies both the name of the variable to which the structure field is bound and the field-name in the structure. * a list has the variable name as its first item and the structure field name as its second. ") (let ((conc-name (first variables)) (vars (rest variables))) (assert conc-name) (assert vars) `(let* ,(loop for var in vars collect (let ((var-var (or (and (consp var) (first var)) var)) (var-conc (or (and (consp var) (second var)) var))) `(,var-var (,(intern (format nil "~a~a" conc-name var-conc) (symbol-package conc-name)) ,values))))))) (defbinding-form ((:structure/rw) :docstring "Structure fields are accessed using a concatenation of the structure's `conc-name` and the name of the field. Bind therefore needs to know two things: the conc-name and the field-names. The binding-form looks like (:structure structure-spec*) where each `structure-spec` is an atom or list with two elements: * an atom specifies both the name of the variable to which the structure field is bound and the field-name in the structure. * a list has the variable name as its first item and the structure field name as its second. The expansion uses symbol-macrolet to convert variables references to structure references. Declarations are handled using `the`. ") (let ((conc-name (first variables)) (vars (rest variables))) (assert conc-name) (assert vars) `(symbol-macrolet ,(loop for var in vars collect (let* ((var-var (or (and (consp var) (first var)) var)) (var-conc (or (and (consp var) (second var)) var)) (var-name (intern (format nil "~a~a" conc-name var-conc) (symbol-package conc-name))) (type-declaration (find-type-declaration var-var declarations))) `(,var-var ,(if type-declaration `(the ,type-declaration (,var-name ,values)) `(,var-name ,values)))))))) (defun find-type-declaration (var declarations) ;; declarations looks like ((declare (type fixnum a) (optimize ...) ...) ;; or ((type fixnum a) ...?) (let* ((declarations (if (eq (first (first declarations)) 'declare) (rest (first declarations)) declarations)) (result (find-if (lambda (declaration) (and (eq (first declaration) 'type) (member var (cddr declaration)))) declarations))) (when result (second result)))) #| (defbinding-form (:function :docstring "" :use-values-p nil) (destructuring-bind (name args) variables `(labels ((,name ,args (progn ,values)))))) (bind (((:function foo (x a)) (list a x)) ((:function bar (a)) (foo a a))) (bar 3)) (bind (((:function fib (x)) (cond ((< x 2) 1) (t (+ (fib (- x 1)) (fib (- x 2))))))) (fib 5)) 1 1 2 3 5 ;;; fails, need to combine like forms... (bind (((:function ep (x)) ;;; failure, need to use rest instead of second in bind-macro-helper (progn (print (list :e x)) (if (= x 0) t (not (op (1- x)))))) ((:function op (x)) (progn (print (list :o x)) (if (= x 1) t (not (ep (1- x))))))) (ep 5)) (cond ((< x 2) 1) (t (+ (fib (- x 1)) (fib (- x 2))))))) (fib 5)) |# (defbinding-form ((:alist :assoc) :docstring "The binding form for association-list is as follows: (:alist assoc-spec*) where each assoc-spec is an atom or a list of up to three elements: * atoms bind a variable with that name to an item with the same name. * lists with a single element are treated like atoms. * lists with two elements specify the variable in the first and the name of the accessor in the second. * Lists with three elements use the third element to specify a default value (if the second element is #\_, then the accessor name is taken to be the same as the variable name). Note that the variables are bound to the `cdr` of the item in the list rather than the `(item . value)` pair.") `(let* ,(loop for spec in variables collect (let* ((spec (if (consp spec) spec (list spec))) (var-name (first spec)) var-key var-default) (case (length spec) (1 (setf var-key (first spec))) (2 (setf var-key (second spec))) (3 (setf var-key (second spec) var-default (third spec))) (t (error "bad properly list variable specification: ~s" spec))) (when (string= (symbol-name var-key) "_") (setf var-key var-name)) `(,var-name (or (cdr (assoc ',var-key ,values)) ,@(when var-default `(,var-default)))))))) ;;;; (defbinding-form ((:read-only-slots :slots-read-only :slots-r/o) :docstring "The `:read-only-slots` binding form is short hand for the `with-slots` macro except that it provides only read access to the class. The syntax is (:read-only-slots slot-spec*) Where `slot-spec` can be an atom or a list with two elements. * an atom tells bind to use it as the name of the new variable _and_ to treat this name as the name of the slot. * If the specification is a list, then bind will use the first item for the variable's name and the second item for the slot-name. See [slots][slots-binding-spec] for a variant that provides only read-write access to the class." ) `(let* (,@(loop for var in variables collect (let ((var-var (or (and (consp var) (first var)) var)) (var-slot (or (and (consp var) (second var)) var))) `(,var-var (slot-value ,values ',var-slot))))))) (defbinding-form (:slots :docstring "The `:slots` binding form is short hand for the `with-slots` macro. The syntax is (:slots slot-spec*) Where `slot-spec` can be an atom or a list with two elements. * an atom tells bind to use it as the name of the new variable _and_ to treat this name as the name of the slot. * If the specification is a list, then bind will use the first item for the variable's name and the second item for the slot-name. See [read-only-slots][read-only-slots-binding-spec] for a variant that provides only read-write access to the class." ) `(with-slots (,@(loop for var in variables collect (let ((var-var (or (and (consp var) (first var)) var)) (var-accessor (or (and (consp var) (second var)) var))) `(,var-var ,var-accessor)))) ,values)) ;;;; (defbinding-form ((:read-only-accessors :accessors-read-only :accessors-r/o) :docstring "The `:read-only-accessors` binding form is short hand for `with-accessors` macro that provides only read access to the class. The syntax is (:read-only-accessors accessor-spec*) Where `accessor-spec` can be an atom or a list with two elements. * an atom tells bind to use it as the name of the new variable _and_ to treat this name as the name of the accessor. * If the specification is a list, then bind will use the first item for the variable's name and the second item for the accessor name. See [accessors][accessors-binding-spec] for a variant that provides only read-write access to the class." ) `(let* ,(loop for var in variables collect (let ((var-var (or (and (consp var) (first var)) var)) (var-accessor (or (and (consp var) (second var)) var))) `(,var-var (,var-accessor ,values)))))) (defbinding-form ((:accessors :writable-accessors) :docstring "The `:accessors` binding form is short hand for the `with-accessors` macro. The syntax is (:accessors accessor-spec*) Where `accessor-spec` can be an atom or a list with two elements. * an atom tells bind to use it as the name of the new variable _and_ to treat this name as the name of the accessor. * If the specification is a list, then bind will use the first item for the variable's name and the second item for the accessor name. See [read-only-accessors][read-only-accessors-binding-spec] for a variant that provides only read-only access to the class." ) `(with-accessors (,@(loop for var in variables collect (let ((var-var (or (and (consp var) (first var)) var)) (var-accessor (or (and (consp var) (second var)) var))) `(,var-var ,var-accessor)))) ,values)) (defbinding-form ((:plist :property-list :properties) :docstring "The binding form for property-lists is as follows: (:plist property-spec*) where each property-spec is an atom or a list of up to three elements: * atoms bind a variable with that name to a property with the same name (converting the name to a keyword in order to do the lookup). * lists with a single element are treated like atoms. * lists with two elements specify the variable in the first and the name of the property in the second. * Lists with three elements use the third element to specify a default value (if the second element is #\_, then the property name is taken to be the same as the variable name). Putting this altogether we can code the above let statement as: (setf plist '(:start 368421722 :end 368494926 :flavor :lemon :content :ragged)) (bind (((:plist (start _ 0) end (fuzz fuzziness 'no)) plist)) (list start end fuzz)) ==> (368421722 368494926 no) (which takes some getting used to but has the advantage of brevity). ") (handle-plist variables values t)) (defbinding-form (:plist- :docstring "The `:plist-` binding-form is exactly like that of [plist][binding-form-plist] except that the name is not converted to a keyword. This allows for the case when your property list uses symbols other than keywords as keys. For example: \(bind \(\(\(:plist- a b \(c _ 34\)\) '\(a 5 b 2\)\)\) \(list a b c\)\) ==> \(5 2 34\) " ) (handle-plist variables values nil)) (defun handle-plist (variables values form-keywords?) `(let* ,(loop for spec in variables collect (let* ((spec (if (consp spec) spec (list spec))) (var-name (first spec)) var-key var-default) (case (length spec) (1 (setf var-key (first spec))) (2 (setf var-key (second spec))) (3 (setf var-key (second spec) var-default (third spec))) (t (error "bad properly list variable specification: ~s" spec))) (when (string= (symbol-name var-key) "_") (setf var-key var-name)) (when form-keywords? (setf var-key (intern (symbol-name var-key) :keyword))) `(,var-name (getf ,values ,(if form-keywords? var-key `',var-key) ,@(when var-default `(,var-default)))))))) #+(or) (bind (((:plist a (b _) (c _ 2) (dd d)) '(:b "B" :a "A" :d "D"))) (list a b c dd)) #+(or) (bind (((:plist- a (b _) (c _ 2) (dd d)) '(b "B" a "A" d "D"))) (list a b c dd)) (defbinding-form (:file :use-values-p nil :accept-multiple-forms-p t) "The binding form for a file is as follows: ((:file stream-var) file-name | (file-name arguments*)) E.g., (bind (((:file s) (\"/tmp/foo.tmp\" :direction :output :if-does-not-exist :create))) ...) " ;; thanks to https://github.com/hyotang666 for the idea and initial code! `(with-open-file ,(append variables (if (null (cdr values)) values (car values))))) metabang-bind-20141106-git/dev/macros.lisp000066400000000000000000000132471241453010000201530ustar00rootroot00000000000000(in-package #:metabang.bind) #| use (defmethod documentation (object doc-type) body...) instead (documentation :plist 'binding-form) |# (defmethod documentation (what (doc-type (eql 'metabang.bind:binding-form))) (binding-form-docstring what)) (defun binding-form-docstring (name) "Returns the docstring for a binding form named `name`." (let* ((docstrings (get 'bind :docstrings)) (forms (get 'bind :binding-forms)) (canonical-name (first (assoc name forms))) ) (and canonical-name (assoc canonical-name docstrings)))) (defun (setf binding-form-docstring) (docstring name/s) (when (atom name/s) (setf name/s (list name/s))) (let* ((docstrings (get 'bind :docstrings)) (forms (get 'bind :binding-forms)) (canonical-name (first name/s)) (current-docstring-pair (assoc canonical-name docstrings))) (loop for name in name/s do (let ((names-pair (assoc name forms))) (if names-pair (setf (cdr names-pair) name/s) (push (cons name name/s) forms)))) (if current-docstring-pair (setf (cdr current-docstring-pair) docstring) (push (cons canonical-name docstring) docstrings)) (setf (get 'bind :docstrings) docstrings) (setf (get 'bind :binding-forms) forms) docstring)) (defmacro defbinding-form ((name/s &key docstring remove-nils-p description (use-values-p t) (accept-multiple-forms-p nil)) &body body) "Describe how `bind` should expand particular binding-forms. `defbinding-form` links a name or type with an expansion. These definitions are used by `bind` at macro-expansion time to generate the code that actually does the bindings for you. For example: (defbinding-form (symbol :use-values-p nil) (if (keywordp kind) (error \"Don't have a binding form for ~s\" kind) `(let (,@(if values `((,variables ,values)) `(,variables)))))) This binding form tells to expand clauses whose first element is a symbol using `let`. (It also gets `bind` to signal an error if the first element is a keyword that doesn't have a defined binding form.) " (declare (ignorable remove-nils-p description)) (let* ((multiple-names? (consp name/s)) (main-method-name nil) (force-keyword? (or multiple-names? (eq (symbol-package name/s) (load-time-value (find-package :keyword))))) #+(or) (gignores (gensym "ignores"))) (cond (multiple-names? (setf main-method-name (gentemp (symbol-name '#:binding-generator))) ) (t (setf main-method-name 'bind-generate-bindings) )) (flet ((form-keyword (name) (intern (symbol-name name) (load-time-value (find-package :keyword))))) (when force-keyword? (setf name/s (if multiple-names? (mapcar #'form-keyword name/s) (form-keyword name/s)))) `(progn (setf (binding-form-docstring ',name/s) ,docstring) ,@(loop for name in (if multiple-names? name/s (list name/s)) when (keywordp name) collect `(defmethod binding-form-accepts-multiple-forms-p ((binding-form (eql ,name))) ,accept-multiple-forms-p)) (,(if multiple-names? 'defun 'defmethod) ,main-method-name (,@(unless multiple-names? (if force-keyword? `((kind (eql ,name/s))) `((kind ,name/s)))) variable-form value-form body declarations remaining-bindings) ,(if use-values-p ;; surely this could be simpler! `(let ((gvalues (next-value "values-"))) `((let ((,gvalues ,,(if accept-multiple-forms-p `value-form `(first value-form)))) (declare (ignorable ,gvalues)) (,@,(if (symbolp (first body)) `(,(first body) variable-form gvalues) `(funcall (lambda (variables values) ,@body) variable-form gvalues)) ; ,@(when ,gignores `((declare (ignore ,@gignores)))) ,@(bind-filter-declarations declarations variable-form) ,@(bind-macro-helper remaining-bindings declarations body))))) ``((,@,(if (symbolp (first body)) `(,(first body) variable-form ,(if accept-multiple-forms-p `value-form `(first value-form))) `(funcall (lambda (variables values) ,@body) variable-form ,(if accept-multiple-forms-p `value-form `(first value-form)))) ,@(bind-filter-declarations declarations variable-form) ,@(bind-macro-helper remaining-bindings declarations body))))) ,@(when multiple-names? (loop for name in name/s collect `(defmethod bind-generate-bindings ((kind (eql ,name)) variable-form value-form body declarations remaining-bindings) (,main-method-name variable-form value-form body declarations remaining-bindings)))) #+(or) ,@(when multiple-names? (loop for name in name/s collect `(defmethod bind-generate-bindings ((kind (eql ,name)) variable-form value-form body declarations remaining-bindings) (,main-method-name variable-form ,(if accept-multiple-forms-p `value-form `(first value-form)) body declarations remaining-bindings)))) )))) (defun next-value (x) (gensym x)) (defmacro lambda-bind ((&rest instrs) &rest body) "Use `bind' to allow restructuring of argument to lambda expressions. This lets you funcall and destructure simultaneously. For example (let ((fn (lambda-bind ((a b) c) (cons a c)))) (funcall fn '(1 2) 3)) ;; => (1 . 3) Via eschulte (see git://gist.github.com/902174.git). " #+(or) (declare (indent 1)) (let* ((evald-instrs instrs) (syms (mapcar (lambda (_) (declare (ignore _)) (gensym)) evald-instrs))) `(lambda ,syms (bind ,(mapcar #'list evald-instrs syms) ,@body)))) metabang-bind-20141106-git/dev/packages.lisp000066400000000000000000000025641241453010000204450ustar00rootroot00000000000000(in-package #:common-lisp-user) (defpackage #:metabang.bind (:use #:common-lisp) (:nicknames #:bind #:metabang-bind) (:intern #:bind-generate-bindings #:bind-filter-declarations #:bind-macro-helper #:bind-fix-nils) (:export #:bind #:fluid-bind #:binding-forms #:binding-form-synonyms #:binding-form-groups #:binding-form-docstring #:binding-form ;for documentation #:*bind-all-declarations* #:*bind-non-var-declarations* #:*bind-lambda-list-markers* #:bind-error #:bind-keyword/optional-nil-with-default-error #:bind-missing-value-form-warning #:bind-too-many-value-forms-error #:*unused-declarations-behavior* #:bind-unused-declarations-condition #:bind-unused-declarations-warning #:bind-unused-declarations-error #:*unused-declarations-behavior* #:bind-unused-declarations-condition #:bind-unused-declarations-warning #:bind-unused-declarations-error #:lambda-bind)) (defpackage #:metabang.bind.developer (:use #:common-lisp #:metabang-bind) (:import-from #:metabang-bind #:bind-generate-bindings #:bind-filter-declarations #:bind-macro-helper #:bind-fix-nils) (:export #:bind-generate-bindings #:bind-filter-declarations #:bind-macro-helper #:bind-fix-nils #:defbinding-form)) metabang-bind-20141106-git/lift-standard.config000066400000000000000000000016721241453010000211420ustar00rootroot00000000000000;;; configuration for LIFT tests ;; settings (:if-dribble-exists :supersede) (:dribble "metabang-bind.dribble") (:print-length 10) (:print-level 5) (:print-test-case-names t) ;; suites to run (metabang-bind-test) ;; report properties (:report-property :title "Metabang-Bind | Test results") (:report-property :relative-to metabang-bind-test) (:report-property :style-sheet "test-style.css") (:report-property :if-exists :supersede) (:report-property :format :html) (:report-property :full-pathname "test-results/test-report") (:report-property :unique-name t) (:build-report) (:report-property :unique-name t) (:report-property :format :describe) (:report-property :full-pathname "test-results/test-report.txt") (:build-report) (:report-property :format :save) (:report-property :full-pathname "test-results/test-report.sav") (:build-report) (:report-property :format :describe) (:report-property :full-pathname *standard-output*) (:build-report) metabang-bind-20141106-git/metabang-bind-test.asd000066400000000000000000000023141241453010000213470ustar00rootroot00000000000000(in-package common-lisp-user) (defpackage #:metabang-bind-test-system (:use #:common-lisp #:asdf)) (in-package #:metabang-bind-test-system) (defsystem metabang-bind-test :version "0.1" :author "Gary Warren King " :maintainer "Gary Warren King " :licence "MIT Style License" :description "Tests for metabang-bind" :components ((:module "setup" :pathname "unit-tests/" :components ((:file "package") (:file "utilities" :depends-on ("package")) (:file "test-bind" :depends-on ("package")))) (:module "tests" :pathname "unit-tests/" :depends-on ("setup") :components ((:file "structures") (:file "classes") (:file "plists") (:file "arrays") (:file "functions") #+allegro (:file "regex")))) :depends-on (:metabang-bind :lift)) #+asdf-system-connections (asdf:defsystem-connection bind-and-cl-ppcre-test :requires (metabang-bind-test cl-ppcre) :components ((:module "bind-and-cl-ppcre" :pathname "unit-tests/" :components ((:file "regex"))))) metabang-bind-20141106-git/metabang-bind.asd000066400000000000000000000016021241453010000203710ustar00rootroot00000000000000(defpackage #:metabang.bind-system (:use #:cl #:asdf)) (in-package #:metabang.bind-system) (defsystem metabang-bind :version "0.8.0" :author "Gary Warren King " :licence "MIT License" :description "Bind is a macro that generalizes multiple-value-bind, let, let*, destructuring-bind, structure and slot accessors, and a whole lot more." :components ((:module "dev" :serial t :components ((:file "packages") (:file "macros") (:file "bind") (:file "binding-forms") #+allegro (:file "bind-re-allegro" :depends-on ("bind"))))) :in-order-to ((test-op (load-op metabang-bind-test))) :perform (test-op :after (op c) (funcall (intern (symbol-name '#:run-tests) :lift) :config :generic)) :depends-on ()) (defmethod operation-done-p ((o test-op) (c (eql (find-system 'metabang-bind)))) (values nil)) metabang-bind-20141106-git/unit-tests/000077500000000000000000000000001241453010000173305ustar00rootroot00000000000000metabang-bind-20141106-git/unit-tests/arrays.lisp000066400000000000000000000010131241453010000215150ustar00rootroot00000000000000(in-package #:metabang-bind-test) (deftestsuite test-arrays (metabang-bind-test) ()) (addtest (test-arrays) basic-access (ensure-same (bind ((#(a b c) #(1 2 3))) (list a b c)) '(1 2 3) :test 'equal)) (addtest (test-arrays) two-dimensional (ensure-same (bind ((#2a((a b c) (d e f)) #2a((1 2 3) (4 5 6)))) (list a b c d e f)) '(1 2 3 4 5 6) :test 'equal)) (addtest (test-arrays) basic-access-nils (ensure-same (bind ((#(a nil c) #(1 2 3))) (list a c)) '(1 3) :test 'equal)) metabang-bind-20141106-git/unit-tests/classes.lisp000066400000000000000000000050331241453010000216570ustar00rootroot00000000000000(in-package #:metabang-bind-test) (defclass metabang-bind-class-1 () ((a :initarg :a :accessor a) (b :initarg :b :accessor b) (c :initarg :c :accessor c))) (defclass metabang-bind-class-2 (metabang-bind-class-1) ((d :initarg :d :accessor the-d) (e :initarg :e :accessor e))) (deftestsuite test-classes (metabang-bind-test) ()) (addtest (test-classes) basic-slots (ensure-same (bind (((:slots-read-only a c) (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3))) (list a c)) '(1 3) :test 'equal)) (addtest (test-classes) slots-new-variable-names (ensure-same (bind (((:slots-read-only a (my-c c) (the-b b)) (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3))) (list a the-b my-c)) '(1 2 3) :test 'equal)) (addtest (test-classes) writable-slots (ensure-same (bind ((instance (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3)) ((:slots a (my-c c) (the-b b)) instance)) (setf a :changed) (list (slot-value instance 'a) the-b my-c)) '(:changed 2 3) :test 'equal)) (addtest (test-classes) slots-r/o-1 (ensure-same (bind (((:slots-r/o a c) (make-instance 'metabang-bind-class-1 :a 1 :b 2 :c 3))) (list a c)) '(1 3) :test 'equal)) (addtest (test-classes) basic-accessors-r/o-1 (ensure-same (bind (((:accessors-read-only a c e) (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5))) (list e c a)) '(5 3 1) :test 'equal)) (addtest (test-classes) basic-accessors-r/o-2 (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)) ((:accessors-read-only a c e) obj)) (setf a :a c :c) (ensure-same (list a c e) '(:a :c 5) :test 'equal) (ensure-same (list (e obj) (c obj) (a obj)) '(5 3 1) :test 'equal))) (addtest (test-classes) accessors-new-variable-names-r/o (ensure-same (bind (((:accessors-r/o (my-a a) (my-c c) (d the-d)) (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5))) (list d my-c my-a)) '(4 3 1) :test 'equal)) (addtest (test-classes) basic-accessors-1 (ensure-same (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)) ((:accessors a c e) obj)) (setf a :a c :c) (list (e obj) (c obj) (a obj))) '(5 :c :a) :test 'equal)) (addtest (test-classes) accessors-new-variable-names (ensure-same (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)) ((:writable-accessors (my-a a) (my-c c) (d the-d)) obj)) (setf my-a 42) (list d my-c my-a (a obj))) '(4 3 42 42) :test 'equal)) metabang-bind-20141106-git/unit-tests/functions.lisp000066400000000000000000000041721241453010000222350ustar00rootroot00000000000000(in-package #:metabang-bind-test) (deftestsuite test-flet (metabang-bind-test) ()) (addtest (test-flet) basic-access (bind (((:flet doit (x)) (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-flet) declarations (bind (((:flet doit (x)) (declare (type fixnum x)) (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-flet) docstring (bind (((:flet doit (x)) "if I knew how to get the docstring out of flet, I'd test it." (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-flet) docstring-and-declarations (bind (((:flet doit (x)) "whatever" (declare (type fixnum x)) (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-flet) docstring-and-declarations (bind (((:flet constant (x)) (declare (ignore x)) 42)) (ensure-same (constant 1) 42))) (deftestsuite test-labels (metabang-bind-test) ()) (addtest (test-labels) basic-access (bind (((:labels my-oddp (x)) (cond ((<= x 0) nil) ((= x 1) t) (t (my-oddp (- x 2)))))) (ensure (my-oddp 1)) (ensure (my-oddp 7)) (ensure-null (my-oddp 2)))) (addtest (test-labels) declarations (bind (((:labels doit (x)) (declare (type fixnum x)) (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-labels) docstring (bind (((:labels doit (x)) "if I knew how to get the docstring out of flet, I'd test it." (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-labels) docstring-and-declarations (bind (((:labels doit (x)) "whatever" (declare (type fixnum x)) (setf x (* 2 x)) (setf x (+ x 3)) x)) (ensure-same (doit 1) 5) (ensure-same (doit 2) 7))) (addtest (test-labels) docstring-and-declarations (bind (((:labels constant (x)) (declare (ignore x)) 42)) (ensure-same (constant 1) 42))) metabang-bind-20141106-git/unit-tests/package.lisp000066400000000000000000000003411241453010000216120ustar00rootroot00000000000000(in-package #:common-lisp-user) (defpackage #:metabang-bind-test (:use #:common-lisp #:lift #:metabang-bind) (:import-from #:metabang-bind #:bind-fix-nils-destructured #:bind-get-vars-from-lambda-list))metabang-bind-20141106-git/unit-tests/plists.lisp000066400000000000000000000004151241453010000215370ustar00rootroot00000000000000(in-package #:metabang-bind-test) (deftestsuite test-plists (metabang-bind-test) ()) (addtest (test-plists) basic-access (ensure-same (bind (((:plist a (b _) (c _ 2) (dd d)) '(:b #\b :a #\a :d #\d))) (list a b c dd)) '(#\a #\b 2 #\d) :test 'equalp)) metabang-bind-20141106-git/unit-tests/regex.lisp000066400000000000000000000042761241453010000213440ustar00rootroot00000000000000(in-package #:metabang-bind-test) #+(or) (run-tests :suite 'test-regex) (deftestsuite test-regex (metabang-bind-test) () (:equality-test #'equalp)) (addtest (test-regex) simple-bind (ensure-same (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname date month year) "Frank Zappa 21.12.1940")) (list fname lname date month year)) (list "Frank" "Zappa" "21" "12" "1940"))) (addtest (test-regex) nils-are-ignored-1 (ensure-same (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname nil month year) "Frank Zappa 21.12.1940")) (list fname lname month year)) (list "Frank" "Zappa" "12" "1940"))) (addtest (test-regex) nils-are-ignored-2 (ensure-same (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" nil lname nil month year) "Frank Zappa 21.12.1940")) (list lname month year)) (list "Zappa" "12" "1940"))) #+(or) (addtest (test-regex) nils-are-ignored-1 (let ((result (lambda () (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname nil month year) "Frank Zappa 21.12.1940")) (list lname month year))))) (ensure-same (funcall result) (list "Zappa" "12" "1940")) (ensure-warning (compile nil (lambda () (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname nil month year) "Frank Zappa 21.12.1940")) (list lname month year))))))) (addtest (test-regex) executes-when-no-bindings (ensure-same (bind (((:re "(a|b)+" first) "cccc")) (list "still seen" first)) (list "still seen" nil))) #+(or) (addtest (test-regex) you-can-use-doit (ensure-same (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname nil month year) "Frank Zappa 21.12.1940")) (flet ((doit (&rest vars) (reverse vars))) (doit fname lname month year))) (reverse (list "Frank" "Zappa" "12" "1940")))) #+(or) (defun xxx () (let ((result '(lambda () (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" nil lname nil month year) "Frank Zappa 21.12.1940")) (list lname month year))))) (compile nil result))) metabang-bind-20141106-git/unit-tests/structures.lisp000066400000000000000000000035561241453010000224550ustar00rootroot00000000000000(in-package #:metabang-bind-test) (defstruct (metabang-bind-test-1) a b c) (defstruct (metabang-bind-test-2 (:conc-name bind-test-)) d e) (deftestsuite test-structures (metabang-bind-test) ()) (addtest (test-structures) basic-access (ensure-same (bind (((:struct metabang-bind-test-1- a c) (make-metabang-bind-test-1 :a 1 :b 2 :c 3))) (list a c)) '(1 3) :test 'equal)) (addtest (test-structures) no-capture (let ((values 4)) (bind (((:struct metabang-bind-test-1- a c) (make-metabang-bind-test-1 :a 1 :b 2 :c 3))) (ensure-same '(4 1 3) (list values a c) :test 'equal)))) (addtest (test-structures) changed-variable-name (ensure-same (bind (((:struct metabang-bind-test-1- (my-a a) c) (make-metabang-bind-test-1 :a 1 :b 2 :c 3))) (list c my-a)) '(3 1) :test 'equal)) (addtest (test-structures) changed-variable-name-2 (ensure-same (bind (((:structure metabang-bind-test-1- (my-a a) c) (make-metabang-bind-test-1 :a 1 :b 2 :c 3))) (list c my-a)) '(3 1) :test 'equal)) (addtest (test-structures) nested-read-only (let ((c1 (make-metabang-bind-test-1 :a 1 :b 2 :c 3)) (c2 (make-metabang-bind-test-1 :a 4 :b 5 :c 6))) (ensure-same (bind (((:structure metabang-bind-test-1- (my-a a) c) c1) ((:structure metabang-bind-test-1- a b (second-c c)) c2)) (list my-a c a b second-c)) '(1 3 4 5 6) :test 'equal))) (addtest (test-structures) read-write-nested (let ((c1 (make-metabang-bind-test-1 :a 1 :b 2 :c 3)) (c2 (make-metabang-bind-test-1 :a 4 :b 5 :c 6))) (bind (((:structure/rw metabang-bind-test-1- (my-a a) c) c1) ((:structure/rw metabang-bind-test-1- a b (second-c c)) c2)) (setf my-a :a second-c :c b :b)) (ensure-same (metabang-bind-test-1-a c1) :a) (ensure-same (metabang-bind-test-1-b c2) :b) (ensure-same (metabang-bind-test-1-c c2) :c))) metabang-bind-20141106-git/unit-tests/test-bind.lisp000066400000000000000000000161371241453010000221220ustar00rootroot00000000000000(in-package #:metabang-bind-test) (deftestsuite metabang-bind-test () ()) (deftestsuite test-bind-fix-nils-destructured (metabang-bind-test) ()) (addtest (test-bind-fix-nils-destructured) simple-list (ensure-same (bind-fix-nils-destructured '(a b c)) (values '(a b c) nil) :test #'equal)) (addtest (test-bind-fix-nils-destructured) simple-list-with-nil (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a nil c)) (ensure-same (first vars) 'a) (ensure-same (third vars) 'c) (ensure-same (second vars) (first ignores)))) (addtest (test-bind-fix-nils-destructured) simple-list-with-_ (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a _ c)) (ensure-same (first vars) 'a) (ensure-same (third vars) 'c) (ensure-same (second vars) (first ignores)))) (addtest (test-bind-fix-nils-destructured) simple-list-with-_-2 (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a _ c _ _)) (ensure-same (first vars) 'a) (ensure-same (third vars) 'c) (ensure (member (second vars) ignores)) (ensure (member (fourth vars) ignores)) (ensure (member (fifth vars) ignores)))) (addtest (test-bind-fix-nils-destructured) dotted-list (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a . b)) (ensure-same (car vars) 'a) (ensure-same (cdr vars) 'b) (ensure-same ignores nil))) (addtest (test-bind-fix-nils-destructured) dotted-list-with-nil-1 (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(nil . b)) (ensure-same (car vars) (first ignores)) (ensure-same (cdr vars) 'b) (ensure-same (length ignores) 1))) (addtest (test-bind-fix-nils-destructured) keyword-list (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a b &key (c 1) d (e x y))) (ensure-same (length vars) 6) (ensure-same (length ignores) 0) (ensure-same vars '(a b &key (c 1) d (e x y)) :test #'equal))) (addtest (test-bind-fix-nils-destructured) keyword-list-with-nil-non-keyword (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(nil b &key (c 1) d (e x y))) (ensure-same (length ignores) 1) (ensure-same (rest vars) '(b &key (c 1) d (e x y)) :test #'equal) (ensure-same (first vars) (first ignores)))) (addtest (test-bind-fix-nils-destructured) keyword-list-with-nil-keyword (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a b &key (c 1) nil (e x y))) (ensure-same (length ignores) 1) (ensure-same (subseq vars 0 3) '(a b &key) :test #'equal) (ensure-same (fifth vars) (first ignores)) (ensure-same (fourth vars) '(c 1) :test 'equal))) #+Ignore ;;?? not yet (addtest (test-bind-fix-nils-destructured) keyword-list-with-bad-nil-keyword-syntax (ensure-condition 'bind-keyword/optional-nil-with-default-error (bind-fix-nils-destructured '(a b &key (nil 1) d (e x y))))) (addtest (test-bind-fix-nils-destructured) keyword-list-with-allow-other-keys (multiple-value-bind (vars ignores) (bind-fix-nils-destructured '(a b &key (c 1) d (e x y) &allow-other-keys)) (ensure-same (length ignores) 0) (ensure-same vars '(a b &key (c 1) d (e x y) &allow-other-keys) :test #'equal))) ;;;; (deftestsuite test-bind-style-warnings (metabang-bind-test) ()) (addtest (test-bind-style-warnings) missing-value-1 (ensure-condition metabang-bind:bind-missing-value-form-warning (macroexpand '(bind (((:values a b))) (list a b))))) (addtest (test-bind-style-warnings) missing-value-2 (ensure-no-warning (macroexpand '(bind (((:values a b) (foo))) (list a b))))) (addtest (test-bind-style-warnings) missing-value-3 (ensure-no-warning (macroexpand '(bind (a) (list a))))) (addtest (test-bind-style-warnings) missing-value-4 (ensure-no-warning (macroexpand '(bind ((a nil)) (list a))))) (addtest (test-bind-style-warnings) two-many-value-forms-error (ensure-cases (form) '((a b c) ((:values a b) 1 2 3)) (ensure-condition metabang-bind:bind-too-many-value-forms-error (macroexpand `(bind (,form) (list a)))))) (addtest (test-bind-style-warnings) two-many-value-forms-warnings-with-flet (ensure-no-warning (macroexpand `(bind (((:flet x (a)) (setf a (* 2 a)) (list a))) (x 2))))) ;;;; (deftestsuite test-ignore-underscores (metabang-bind-test) () (:equality-test (lambda (a b) (equalp (remove-gensyms a) (remove-gensyms b))))) (addtest (test-ignore-underscores) test-simple-destructuring (ensure-same (macroexpand '(bind (((nil a b) (foo))) (list a b))) (macroexpand '(bind (((_ a b) (foo))) (list a b))))) (addtest (test-ignore-underscores) test-multiple-values (ensure-same (macroexpand '(bind (((:values a nil b) (foo))) (list a b))) (macroexpand '(bind (((:values a _ b) (foo))) (list a b))))) (addtest (test-ignore-underscores) test-array (ensure-same (macroexpand '(bind ((#(a nil b) (foo))) (list a b))) (macroexpand '(bind ((#(a _ b) (foo))) (list a b))))) ;;; (deftestsuite test-for-unused-declarations (metabang-bind-test) ()) (addtest (test-for-unused-declarations) test-error-1 (let ((bind:*unused-declarations-behavior* :error)) (ensure-condition bind::bind-unused-declarations-error (eval '(bind:bind ((a 2) (b 3)) (declare (type fixnum a b c) (optimize (speed 3))) a b))))) (addtest (test-for-unused-declarations) test-error-2 (let ((bind:*unused-declarations-behavior* :error)) (ensure-condition bind:bind-unused-declarations-error (eval '(bind:bind (((:values _ b ) (values 1 2))) (declare (type fixnum b) (ignorable b) (simple-vector d) (optimize (speed 3))) b))))) (addtest (test-for-unused-declarations) test-warning-1 (let ((bind:*unused-declarations-behavior* :warn)) (ensure-condition bind::bind-unused-declarations-warning (eval '(bind:bind ((a 2) (b 3)) (declare (type fixnum a b c) (optimize (speed 3))) a b))))) (addtest (test-for-unused-declarations) test-warning-2 (let ((bind:*unused-declarations-behavior* :warn)) (ensure-condition bind::bind-unused-declarations-warning (eval '(bind:bind (((:values _ b ) (values 1 2))) (declare (type fixnum b) (ignorable b) (simple-vector d) (optimize (speed 3))) b))))) (addtest (test-for-unused-declarations) test-no-warning-1 (let ((bind:*unused-declarations-behavior* nil)) (ensure-no-warning (eval '(bind:bind (((:values _ b ) (values 1 2))) (declare (type fixnum b) (ignorable b) (simple-vector d) (optimize (speed 3))) b))))) ;;; #| (defun x (a b) (declare (fixnum a b)) (+ a b)) (defun x (c) (bind (((:structure/rw c- a b) c)) (declare (fixnum a b)) (declare (optimize (speed 3) (safety 0))) (+ a b))) (disassemble 'x) (bind (((:structure/rw foo- a b c) (bar))) (declare (type fixnum a) (double b)) (declare (optimize (speed 3))) ) |# metabang-bind-20141106-git/unit-tests/utilities.lisp000066400000000000000000000007721241453010000222420ustar00rootroot00000000000000(in-package #:metabang-bind-test) (defun collect-tree (tree &key transform) "Maps FN over every atom in TREE." (bind ((transform (or transform #'identity)) ((:labels doit (x)) (cond ;; ((null x) nil) ((atom x) (funcall transform x)) (t (cons (doit (car x)) (when (cdr x) (doit (cdr x)))))))) (doit tree))) (defun remove-gensyms (tree) (collect-tree tree :transform (lambda (x) (when (or (not (symbolp x)) (symbol-package x)) x)))) metabang-bind-20141106-git/website/000077500000000000000000000000001241453010000166535ustar00rootroot00000000000000metabang-bind-20141106-git/website/source/000077500000000000000000000000001241453010000201535ustar00rootroot00000000000000metabang-bind-20141106-git/website/source/index.mmd000066400000000000000000000045651241453010000217730ustar00rootroot00000000000000{include resources/header.md} {set-property title "metabang-bind - Sticking it the to metal..."}
* [User's guide](user-guide.html) * [Issue tracker](https://github.com/gwkkwg/metabang-bind/issues) * [Mailing Lists][3] * [Getting it][4] * [News][6] * [Changelog][7] [3]: #mailing-lists [4]: #downloads [5]: documentation/ (documentation link) [6]: #news [7]: changelog.html
### What it is Bind extends the idea of of `let` and destructing to provide a uniform syntax for all your accessor needs. It combines _let_, _destructuring-bind_, `with-slots`, `with-accessors`, structure editing, property or association-lists, and _multiple-value-bind_ and a whole lot more into a single form. The [user guide][user-guide] has all the details but here is example to whet your appetite: (bind ((a 2) ((b &rest args &key (c 2) &allow-other-keys) '(:a :c 5 :d 10 :e 54)) ((:values d e) (truncate 4.5))) (list a b c d e args)) ==> (2 :A 5 4 0.5 (:C 5 :D 10 :E 54)) Bind is especially handy when you have more than one layer of `multiple-value-bind` or `destructuring-bind`. Since `bind` is a single form, you don't end up too far off to the right in editor land. Bind is released under the [MIT license][mit-license]. {anchor mailing-lists} ### Mailing Lists Use the developer [mailing list][metabang-bind-devel] for any questions or comments regarding bind. {anchor downloads} ### Where is it 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: git clone git://github.com/gwkkwg/metabang-bind metabang-bind is also [ASDF installable][asdf-install]. Its CLiki home is right [where][cliki-home] you'd expect. There's also a handy [gzipped tar file][tarball]. {anchor news} ### What is happening 10 April 2010 - moved to github; added flet support 28 May 2009 - added `:structure/rw` binding form; updated webpage to link to the user's guide 1 Dec 2007 - Added support for [array destructuring][array-bindings] (Thanks to Tamas Papp for the idea) 15 Nov 2007 - New user guide; bind handles structures and property lists and is now extensible! 13 Nov 2005 - Initial webpage n' stuff.
{include resources/footer.md} metabang-bind-20141106-git/website/source/resources/000077500000000000000000000000001241453010000221655ustar00rootroot00000000000000metabang-bind-20141106-git/website/source/resources/footer.md000066400000000000000000000026621241453010000240130ustar00rootroot00000000000000metabang-bind-20141106-git/website/source/resources/guide-footer.md000066400000000000000000000003711241453010000251010ustar00rootroot00000000000000 metabang-bind-20141106-git/website/source/resources/guide-header.md000066400000000000000000000002561241453010000250350ustar00rootroot00000000000000{set-property html yes} {set-property style-sheet user-guide} {set-property author "Gary Warren King"} {include shared.md} metabang-bind-20141106-git/website/source/resources/header.md000066400000000000000000000017231241453010000237420ustar00rootroot00000000000000{set-property html yes} {set-property style-sheet "http://common-lisp.net/project/cl-containers/shared/style-200.css"} {set-property author "Gary Warren King"} {include shared.md} {include shared-links.md} [tr]: test-report.html [user-guide]: user-guide.html [tarball]: http://common-lisp.net/project/cl-containers/bundler/bundler_latest.tar.gz [metabang-bind-tar]: http://common-lisp.net/project/metabang-bind/metabang-bind_latest.tar.gz [devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/metabang-bind-devel [cliki-home]: http://www.cliki.net//metabang-bind [tarball]: http://common-lisp.net/project/metabang-bind/metabang-bind.tar.gz metabang-bind-20141106-git/website/source/resources/navigation.md000066400000000000000000000001051241453010000246420ustar00rootroot00000000000000 metabang-bind-20141106-git/website/source/resources/shared.md000066400000000000000000000011201241453010000237470ustar00rootroot00000000000000 [darcs]: http://www.darcs.net/ [asdf-install]: http://common-lisp.net/project/asdf-install [gwking]: http://www.metabang.com/ [Home]: index.html [user-guide]: user-guide.html [bundler-cliki]: http://www.cliki.net/bundler [ASDF-Extension]: http://www.cliki.net/asdf-extension [gwking-mail]: mailto:gwking@metabang.com [CL-Markdown]: http://common-lisp.net/project/cl-markdown/ [asdf-install]: http://www.cliki.net/asdf-install [metabang-bind-cliki]: http://www.cliki.net/metabang-bind [metabang-bind-devel]: http://common-lisp.net/cgi-bin/mailman/listinfo/metabang-bind-devel metabang-bind-20141106-git/website/source/user-guide.css000066400000000000000000000057301241453010000227430ustar00rootroot00000000000000/* @group toc */ .table-of-contents { font-size: 90%; margin-bottom: 1em; padding-bottom: 1em; } .table-of-contents h2, h3, h4 { padding-top: 0; padding-bottom: 0; margin-top: 0; margin-bottom: 1px; } .table-of-contents h2 { font-size: inherit; font-style: inherit; position: relative; left: 2em; } .table-of-contents h3 { font-size: inherit; font-style: inherit; position: relative; left: 4em; } .table-of-contents h4 { font-size: inherit; font-style: inherit; position: relative; left: 6em; } .table-of-contents h5 { font-size: inherit; font-style: inherit; position: relative; left: 8px; } /* @end */ /* @group anchors */ a.none { text-decoration: none; color:black } a.none:visited { text-decoration: none; color:black } a.none:active { text-decoration: none; color:black } a.none:hover { text-decoration: none; color:black } a { text-decoration: none; } a:visited { text-decoration: none; } a:active { text-decoration: underline; } a:hover { text-decoration: underline; } /* @end */ /* @group Reference */ .reference { padding-bottom: 1em; } .reference h3 { margin-top: 2em; font-size: 110%; border-bottom: 1px solid silver; border-top: 4px solid gray; padding-top: 3px; padding-bottom: 3px; } /* @end */ body { font-family: Georgia, "Times New Roman", Times, serif; margin-right: 0.75in; margin-left: 0.75in; margin-bottom: 0.25in; } h1, h2, h3, h4 { font-family: "Lucida Grande", Lucida, Verdana, sans-serif; } h2 { } h3, h4 { font-style: italic; } .hidden { visibility: hidden; } .documentation { margin-right: 1em; margin-left: 1em; } .function { } .documentation.header { display: block; position: relative; border-top-style: solid; border-top-width: 1pt; padding-top: 4px; margin-top: 2em; } .documentation.contents { top: 10px; position: relative; } .documentation-name { font-weight: bold; float: left; padding-right: 10px; width: 125px; } .documentation-kind { float: right; font-style: italic; color: gray; padding-left: 10px; } .documentation-arguments { float: left; width: 350px; font-style: italic; } .documentation p { clear: both; margin-right: 1em; margin-left: 1em; } pre { background-color: #ffc8ff; overflow: auto; padding-bottom: 5px; margin-right: 1cm; margin-left: 1cm; font-family: "Courier New", Courier, mono; } .note { border: 2px inset gray; padding: 0.5em; margin-right: 2em; margin-left: 2em; } #navigation li { display: inline; border-right-style: dotted; border-right-width: 1px; border-left-style: dotted; border-left-width: 1px; border-collapse: collapse; padding-right: 0.25em; padding-left: 0.25em; margin-right: 1em; } #navigation { text-align: center; } #footer { margin-top: 2em; padding-bottom: 2em; padding-top: 1em; border-top-style: inset; border-top-width: 2px; font-size: 80%; line-height: 110%; } #timestamp { font-size: 90%; text-align: right; float: right; } #license-note { float: left; } #copyright { float: left; } metabang-bind-20141106-git/website/source/user-guide.mmd000066400000000000000000000252321241453010000227270ustar00rootroot00000000000000{comment http://metabang.com/unclogit/?p=154} {include resources/guide-header.md} {set-property title "metabang-bind user guide"} {set-property html yes} {set-property title "metabang-bind | Guide to the perplexed"} {set-property style-sheet user-guide} {set-property docs-package metabang-bind} # metabang-bind user guide {table-of-contents :start 2 :depth 3} ## Introduction `bind` combines _let_, _destructuring-bind_, _multiple-value-bind_ *and** a whole lot more into a single form. It has two goals: 1. reduce the number of nesting levels 2. make it easier to understand all of the different forms of destructuring and variable binding by unifying the multiple forms of syntax and reducing special cases. `bind` is extensible. It handles the traditional multiple-values, destructuring, and let-forms as well as property-lists, classes, and structures. Even better, you can create your own binding forms to make your code cleaner and easier to follow (for others _and_ yourself!). Simple bindings are as in _let*_. Destructuring is done if the first item in a binding is a list. Multiple value binding is done if the first item in a binding is a list and the first item in the list is the keyword ':values'. {remark ### Summary
symbol`x` or `(x 45)``let` array`(#(a b) #(4 5))``let`
} ## Some examples Bind mimics let in its general syntax: (bind (&rest bindings) ) where each `binding` can either be an symbol or a list. If the binding is an atom, then this atom will be bound to nil within the body (just as in let). If it is a list, then it will be interpreted depending on its first form. (bind (a (...)) ...) ### Bind as a replacement for let You can use `bind` as a direct replacement for `let*`: (bind ((a 2) b) (list a b)) => (2 nil) As in `let*`, atoms are initially bound to `nil`. ### Bind with multiple-values and destructuring Suppose we define two silly functions: (defun return-values (x y) (values x y)) (defun return-list (x y) (list x y)) How could we use bind for these: (bind (((:values a b) (return-values 1 2)) ((c d) (return-list 3 4))) (list a b c d)) => (1 2 3 4) Note that `bind` makes it a little easier to ignore variables you don't care about. Suppose I've got a function `ijara` that returns 3 values and I happen to need only the second two. Using `destructuring-bind`, I'd write: (destructuring-bind (foo value-1 value-2) (ijira) (declare (ignore foo)) ...) With `bind`, you use `nil` or `_` in place of a variable name and it will make up temporary variables names and add the necessary declarations for you. (bind (((_ value-1 value-2) (ijira))) ...) {anchor property-list-bindings} ### Bind with property lists A property-list or `plist` is a list of alternating keywords and values. Each keyword specifies a property name; each value specifies the value of that name. (setf plist '(:start 368421722 :end 368494926 :flavor :lemon :content :ragged) You can use `getf` to find the current value of a property in a list (and `setf` to change them). The optional third argument to `getf` is used to specify a default value in case the list doesn't have a binding for the requested property already. (let ((start (getf plist :start 0)) (end (getf plist :end)) (fuzz (getf plist :fuzziness 'no))) (list start end fuzz)) => (368421722 368494926 no) The binding form for property-lists is as follows: (:plist property-spec*) where each property-spec is an atom or a list of up to three elements: * atoms bind a variable with that name to a property with the same name (converting the name to a keyword in order to do the lookup). * lists with a single element are treated like atoms. * lists with two elements specify the variable in the first and the name of the property in the second. * Lists with three elements use the third element to specify a default value (if the second element is #\_, then the property name is taken to be the same as the variable name). Putting this altogether we can code the above let statement as: (bind (((:plist (start _ 0) end (fuzz fuzziness 'no)) plist)) => (list start end fuzz)) (which takes some getting used to but has the advantage of brevity). {anchor structure-bindings} ### Bind with structures Structure fields are accessed using a concatenation of the structure's `conc-name` and the name of the field. Bind therefore needs to know two things: the conc-name and the field-names. The binding-form looks like (:structure structure-spec*) where each `structure-spec` is an atom or list with two elements: * an atom specifies both the name of the variable to which the structure field is bound and the field-name in the structure. * a list has the variable name as its first item and the structure field name as its second. So if we have a structure like: (defstruct minimal-trout a b c) (setf trout (make-minimal-trout :a 2 :b 3 :c 'yes)) We can bind these fields using: (bind (((:structure minimal-trout- (my-name a) b c) trout)) (list my-name b c)) => (2 3 yes) {anchor class-bindings} ### Bind with classes You can read the slot of an instance with an accessor (if one exists) or by using slot-value{footnote Note that if an accessor exists, it will generally be much faster than slot-value because CLOS is able to cache information about the accessor and the instance.}. Bind also provides two slot-binding mechanisms: `:slots` and `:accessors`. Both look the same: (:slots slot-spec*) (:accessors accessor-spec*) Where both slot-spec and accessor-spec can be atoms or lists with two elements. * an atom tells bind to use it as the name of the new variable _and_ to treat this name as the name of the slot or the name of the accessor, respectively. * If the specification is a list, then bind will use the first item as the variable's name and the second item as the slot-name or accessor. Support we had a class like: (defclass wicked-cool-class () ((a :initarg :a :accessor its-a) (b :initarg :b :accessor b) (c :initarg :c :accessor just-c))) If we don't mind using the slot-names as variable names, then we can use the simplest form of `:slots`: (bind (((:slots a b c) (make-instance 'wicked-cool-class :a 1 :b 2 :c 3))) (list a b c)) ==> (1 2 3) We can also change the names within the context of our bind form: (bind (((:slots a b (dance-count c)) (make-instance 'wicked-cool-class :a 1 :b 2 :c 3))) (list a b dance-count)) ==> (1 2 3) Similarly, we can use `:accessors` with variable names that are the same as the accessor names... (bind (((:accessors its-a b just-c) (make-instance 'wicked-cool-class :a 1 :b 2 :c 3))) (list its-a b just-c)) ==> (1 2 3) or that are different: (bind (((:accessors (a its-a) b (c just-c)) (make-instance 'wicked-cool-class :a 1 :b 2 :c 3))) (list a b c)) ==> (1 2 3) {anchor array-bindings} ### Bind with arrays Tamas Papp had the idea of letting `bind` handle arrays too. For example, (bind ((#(a b c) #(1 2 3))) (list a b c)) ==> (1 2 3) One quick method definition and a few unit-tests later and bind does! ### Bind with regular expressions If you have CL-PPCRE or run with Allegro Common Lisp, you can use `bind` with regular expressions too. The syntax is (:re expression &rest vars) string) and will bind each grouped item in the expression to the corresponding var. For example: (bind (((:re "(\\w+)\\s+(\\w+)\\s+(\\d{1,2})\\.(\\d{1,2})\\.(\\d{4})" fname lname nil month year) "Frank Zappa 21.12.1940")) (list fname lname month year)) The body of bind form will be evaluated even if the expression does not match. ### Bind with `flet` and `labels` Bind can even be used as a replacement for `flet` and `labels`. The syntax is (:flet function-name (arguments*)) definition) (:labels function-name (arguments*)) definition) for example: (bind (((:flet square (x)) (* x x))) (square 4)) ==> 16 (bind (((:labels my-oddp (x)) (cond ((<= x 0) nil) ((= x 1) t) (t (my-oddp (- x 2)))))) (my-oddp 7)) ==> t Note that bind currently expands each binding-form into a new context. In particular, this means that (bind (((:flet x (a)) (* a 2)) ((:flet y (b)) (+ b 2))) ...) expands as (flet ((x (a) (progn (* a 2)))) (flet ((y (b) (progn (+ b 2)))) ...)) rather than (flet ((x (a) (progn (* a 2))) (y (b) (progn (+ b 2)))) ...) Generally speaking, this shouldn't make much of a difference. ## `bind` and declarations `bind` handles declarations transparently by splitting them up and moving them to the correct place in the expansion. For example (bind (((:values a b) (foo x)) (#(d e) (bar y))) (declare (type fixnum a d) (optimize (speed 3))) (list a b d e)) becomes (multiple-value-bind (a b) (foo x) (declare (type fixnum a) (optimize (speed 3))) (let ((#:values-258889 (bar y))) (let* ((d (row-major-aref #:values-258889 0)) (e (row-major-aref #:values-258889 1))) (declare (optimize (speed 3))) (list a b d e)))) because `bind` knows to keep the variable declarations (like `type`) with their variables and to repeat other declarations (like `optimize`) at each level. `bind` keeps track of variables declarations that are not used. The configuration variable `*unused-declarations-behavior*` controls what `bind` does: {docs *unused-declarations-behavior*} ## More bindings Since bind is extensible and I'm fallible, there are probably things bind can do that haven't made it into this guide. Use the following commands to see what bind can do: {docs binding-forms} {docs binding-form-docstring} {docs binding-form-groups} {docs binding-form-synonyms} ## `lambda-bind` Eric Schulte contributed `lambda-bind` (note, he called it `lambdab` but I dislike abbreviations so...): {docs lambda-bind} ## Extending bind yourself Bind's syntax is extensible: the work for each binding-specification is handled by a generic function. This means that you can evolve bind to fit your program for whatever sort of data-structure makes sense for you. To make a binding form, you can either define a method for `bind-generate-bindings` or you can use the `defbinding-form` macro. {docs bind-generate-bindings} {docs defbinding-form} There are many more examples included in the source code. {include resources/guide-footer.md} metabang-bind-20141106-git/website/website.tmproj000066400000000000000000000141411241453010000215530ustar00rootroot00000000000000 currentDocument source/resources/footer.md documents expanded name images regexFolderFilter !.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$ sourceDirectory source/images expanded name resources regexFolderFilter !.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$ sourceDirectory source/resources filename source/user-guide.css lastUsed 2011-02-12T16:05:38Z filename source/user-guide.mmd lastUsed 2011-04-05T16:58:22Z filename ../../shared/shared-links.md lastUsed 2010-04-10T15:11:40Z filename source/index.mmd lastUsed 2011-04-05T16:59:24Z fileHierarchyDrawerWidth 200 metaData ../../shared/shared-links.md caret column 9 line 68 firstVisibleColumn 0 firstVisibleLine 39 source/index.mmd caret column 10 line 7 firstVisibleColumn 0 firstVisibleLine 0 source/resources/footer.md caret column 37 line 8 firstVisibleColumn 0 firstVisibleLine 0 source/resources/guide-footer.md caret column 0 line 6 columnSelection firstVisibleColumn 0 firstVisibleLine 0 selectFrom column 0 line 0 selectTo column 0 line 6 source/resources/guide-header.md caret column 0 line 9 columnSelection firstVisibleColumn 0 firstVisibleLine 0 selectFrom column 0 line 0 selectTo column 0 line 9 source/resources/header.md caret column 0 line 2 columnSelection firstVisibleColumn 0 firstVisibleLine 0 selectFrom column 0 line 1 selectTo column 0 line 2 source/resources/navigation.md caret column 0 line 3 firstVisibleColumn 0 firstVisibleLine 0 source/resources/shared.md caret column 15 line 5 firstVisibleColumn 0 firstVisibleLine 0 source/user-guide.css caret column 0 line 0 firstVisibleColumn 0 firstVisibleLine 0 source/user-guide.mmd caret column 0 line 307 firstVisibleColumn 0 firstVisibleLine 276 openDocuments source/resources/guide-footer.md source/user-guide.mmd source/index.mmd source/resources/header.md source/user-guide.css source/resources/footer.md source/resources/shared.md source/resources/guide-header.md source/resources/navigation.md ../../shared/shared-links.md showFileHierarchyDrawer windowFrame {{76, 32}, {578, 746}}