Skip to content

Commit

Permalink
rfe12140: update metabang-bind
Browse files Browse the repository at this point in the history 
tests added    : no
tests run      : yes
performance    : modest improvements due to better declarations, etc.
release note   : none, internal change

Added declare ignorable to one defbinding-form macro expansion to
prevent unnecessary warnings.

Update with latest code from github

Lots of minor changes and improvements including:

added docstring support to :flet and :labels (reported by https://github.com/tpapp)

... and also fix the problem with non-list first elements for flet and labels

added Eric Schulte's lambda-bind

declare indent was a no-no (See https://github.com/gwkkwg/metabang-bind/issues/closed#issue/3)

Added unused declaration checks

added *unused-declarations-behavior*

Use `the` in :structure/rw to handle declarations

Fix the implicit generic definition and undefined function warnings.

docstring and userguide improvements

tweak declaration handling

Some declarations could lead to parsing errors and general bind
confusion. Corrected.

Change-Id: I2bfeefb8a2e820a6108d2b04cdbc4cdfc716477d
Reviewed-on: https://gerrit.franz.com:9080/2932
Reviewed-by: Ahmon Dancy <dancy@franz.com>
Reviewed-by: John O'Rourke <jor@franz.com>
Tested-by: Kevin Layer <layer@franz.com>
  • Loading branch information
Gary King authored and Gary King committed Oct 4, 2014
1 parent cde1d7b commit 77dab3e
Show file tree
Hide file tree
Showing 3 changed files with 33 additions and 32 deletions.
58 changes: 29 additions & 29 deletions dev/bind.lisp
View file
Expand Up @@ -6,8 +6,8 @@ See the file COPYING for details
|#

(in-package #:metabang.bind)
(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)"))
Expand All @@ -21,27 +21,27 @@ See the file COPYING for details
The possible options are
* :print-warning (the current default) - print a warning about the problem
* :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
'(dynamic-extent ignore optimize ftype inline
special ignorable notinline type))

(defparameter *bind-non-var-declarations*
'(optimize ftype inline notinline
'(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*
(defparameter *bind-lambda-list-markers*
'(&key &body &rest &args &optional))

(define-condition simple-style-warning (style-warning simple-warning)
Expand Down Expand Up @@ -74,7 +74,7 @@ The possible options are
:reader binding)))

(define-condition bind-keyword/optional-nil-with-default-error (bind-error)
((bad-variable
((bad-variable
:initform nil
:initarg :bad-variable
:reader bad-variable))
Expand Down Expand Up @@ -107,14 +107,14 @@ The possible options are
(let ((binding-forms (get 'bind :binding-forms))
(canonical-names
(sort
(delete-duplicates
(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`.
"Return a list of synonyms for the binding-form `name`.
For example
Expand All @@ -130,7 +130,7 @@ For example
(defvar *all-declarations*)

(defmacro bind ((&rest bindings) &body body)
"Bind is a replacement for let*, destructuring-bind, multiple-value-bind and more.
"Bind is a replacement for let*, destructuring-bind, multiple-value-bind and more.
An example is probably the best way to describe its syntax:
Expand All @@ -157,7 +157,7 @@ in a binding is a list and the first item in the list is ':values'."

(defun check-for-unused-variable-declarations (declarations)
(when declarations
(case *unused-declarations-behavior*
(case *unused-declarations-behavior*
(:warn
(warn 'bind-unused-declarations-warning :unused-declarations declarations))
(:error
Expand Down Expand Up @@ -185,15 +185,15 @@ in a binding is a list and the first item in the list is ':values'."
(eq (symbol-package (first variable-form))
(load-time-value (find-package :keyword)))
(first variable-form))))
(when (and (consp value-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
(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
(bind-generate-bindings
(first variable-form)
(rest variable-form)
value-form body declarations remaining-bindings)
Expand All @@ -206,7 +206,7 @@ in a binding is a list and the first item in the list is ':values'."
;;;;

(defun var-ignorable-p (var)
(or (null var)
(or (null var)
(and (symbolp var) (string= (symbol-name var) (symbol-name '_)))))

(defun mint-ignorable-variable ()
Expand All @@ -224,7 +224,7 @@ in a binding is a list and the first item in the list is ':values'."

(defun bind-fix-nils-destructured (var-list)
(let ((ignores nil))
(labels (;; adapted from metatilities
(labels (;; adapted from metatilities
(tree-map (fn tree)
"Maps FN over every atom in TREE."
(cond
Expand All @@ -234,10 +234,10 @@ in a binding is a list and the first item in the list is ':values'."
(cons
(tree-map fn (car tree))
(when (cdr tree) (tree-map fn (cdr tree))))))))

(values (tree-map
(lambda (x)
(cond ((var-ignorable-p x)
(cond ((var-ignorable-p x)
(let ((ignore (mint-ignorable-variable)))
(push ignore ignores)
ignore))
Expand All @@ -254,12 +254,12 @@ in a binding is a list and the first item in the list is ':values'."
(defun bind-get-vars-from-lambda-list (lambda-list)
(let ((result nil))
(labels ((do-it (thing)
(cond ((atom 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 (car thing))
(do-it (cdr thing)))
(t
(do-it (car thing))
Expand All @@ -268,7 +268,7 @@ in a binding is a list and the first item in the list is ':values'."
(nreverse result)))

#+(or)
(loop for item in lambda-list
(loop for item in lambda-list
unless (member item *bind-lambda-list-markers*) collect
(if (consp item) (first item) item))

Expand All @@ -288,16 +288,16 @@ in a binding is a list and the first item in the list is ':values'."
`(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 (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
(loop for declaration in declarations
when (or (member (first declaration)
*bind-non-var-declarations*)
(and (member (first declaration)
*bind-simple-var-declarations*)
(member
(member
(if (atom (second declaration))
(second declaration)
;; ... (function foo) ...)
Expand All @@ -308,13 +308,13 @@ in a binding is a list and the first item in the list is ':values'."
(progn
(setf *all-declarations* (remove declaration *all-declarations*))
declaration))))
(when 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 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\)\)\)
Expand All @@ -327,7 +327,7 @@ This is similar to dynamic-binding but _much_ less robust."
(cleanup-forms nil)
(gensyms nil))
(loop for binding in bindings collect
(destructuring-bind
(destructuring-bind
(setup-form cleanup-form)
(cond ((consp binding)
(destructuring-bind (var value) binding
Expand Down Expand Up @@ -396,8 +396,8 @@ This is similar to dynamic-binding but _much_ less robust."
(bind ((a 3))
(list *last-world* *foo* a)))
(setf *foo #:2)))
(set *last-world* #:g1))
(set *last-world* #:g1))
(fluid-bind (a b)
(+ a a))
|#
Expand Down
1 change: 1 addition & 0 deletions dev/macros.lisp
View file
Expand Up @@ -105,6 +105,7 @@ form.)
`((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)
Expand Down
6 changes: 3 additions & 3 deletions dev/packages.lisp
View file
Expand Up @@ -3,12 +3,12 @@
(defpackage #:metabang.bind
(:use #:common-lisp)
(:nicknames #:bind #:metabang-bind)
(:intern
(:intern
#:bind-generate-bindings
#:bind-filter-declarations
#:bind-macro-helper
#:bind-fix-nils)
(:export
(:export
#:bind
#:fluid-bind

Expand Down Expand Up @@ -41,7 +41,7 @@
#:bind-filter-declarations
#:bind-macro-helper
#:bind-fix-nils)
(:export
(:export
#:bind-generate-bindings
#:bind-filter-declarations
#:bind-macro-helper
Expand Down

0 comments on commit 77dab3e

Please sign in to comment.