Several things

* finally removed the long deprecated *bind-treat-values-as-values*

* added :labels to complement :flet and fixed :flet to accept an
optional declaration form (coincidently noticed by me and
https://github.com/scymtym in the same week!)

* fixed bug where the array binding form wasn't correctly handling
underscore as ignore

* added tests for flet with declarations, labels and handling
underscore as ignore (only some binding forms are checked so I
should write some more...)

dev/bind.lisp

@@ -19,12 +19,6 @@ See the file COPYING for details
   '(dynamic-extent ignore optimize ftype inline 
     special ignorable notinline type))
 
-;; tvav: change this
-(defparameter *bind-treat-values-as-values* nil
-  "**Deprecated** - this variable no longer has any effect on
-the parsing of a binding form. `bind` now requires that you use
-the `:values` form to request multiple-values.")
-
 (defparameter *bind-non-var-declarations*
   '(optimize ftype inline notinline 
     #+allegro

dev/binding-forms.lisp

@@ -9,7 +9,7 @@
   (let ((array-size (array-total-size variables)))
     `(let* (,@(loop for i below array-size
 		 for var = (row-major-aref variables i)
-		 unless (eq var nil) collect
+		 unless (var-ignorable-p var) collect
 		 `(,var (row-major-aref ,values ,i)))))))
 
 (defbinding-form (symbol
@@ -21,7 +21,7 @@
 		   `(,variables))))))
 
 (defbinding-form (:flet
-		  :docstring "Local functions are defined using
+		     :docstring "Local functions are defined using
 
     \(:flet <name> \(<lambda list>\) <function definition>\)
 
@@ -32,10 +32,38 @@ When the function definition occurs in a progn. For example:
     ==> (90 90)
 
 "
-		  :use-values-p nil
-		  :accept-multiple-forms-p t)
+		     :use-values-p nil
+		     :accept-multiple-forms-p t)
   (destructuring-bind (name args) variables
-      `(flet ((,name ,args (progn ,@values))))))
+    (let* ((declaration (when (eq (caar values) 'declare)
+			  (first values)))
+	   (body        (if declaration (rest values) values)))
+      `(flet ((,name ,args
+		,@(when declaration `(,declaration))
+		(progn ,@body)))))))
+
+(defbinding-form (:labels
+		     :docstring "Local functions are defined using
+
+    \(:flet <name> \(<lambda list>\) <function definition>\)
+
+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 (when (eq (caar values) 'declare)
+			  (first values)))
+	   (body        (if declaration (rest values) values)))
+      `(labels ((,name ,args
+		  ,@(when declaration `(,declaration))
+		  (progn ,@body)))))))
+
 
 (defbinding-form (cons
 		  :use-values-p nil)

dev/macros.lisp

@@ -55,7 +55,7 @@ instead
 	 #+(or)
 	 (gignores (gensym "ignores")))    
     (cond (multiple-names?
-	   (setf main-method-name (gensym "binding-generator"))
+	   (setf main-method-name (gensym (symbol-name '#:binding-generator)))
 	   )
 	  (t
 	   (setf main-method-name 'bind-generate-bindings)

dev/packages.lisp

@@ -22,9 +22,6 @@
      #:*bind-non-var-declarations*
      #:*bind-lambda-list-markers*
 
-     ;; this will be removed ... someday
-     #:*bind-treat-values-as-values*
-
      #:bind-error
      #:bind-keyword/optional-nil-with-default-error
      #:bind-missing-value-form-warning

metabang-bind-test.asd

@@ -13,6 +13,7 @@
   :components ((:module "setup"
 			:pathname "unit-tests/"
                         :components ((:file "package")
+				     (:file "utilities" :depends-on ("package"))
                                      (:file "test-bind" 
                                             :depends-on ("package"))))
                (:module "tests"

unit-tests/functions.lisp

@@ -11,3 +11,26 @@
 	  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)))
+
+(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))))

unit-tests/test-bind.lisp

@@ -95,74 +95,6 @@
 
 ;;;;
 
-(deftestsuite test-treat-values-as-values (metabang-bind-test)
-  ())
-
-(deftestsuite test-treat-values-as-values-true (test-treat-values-as-values)
-  ()
-  (:documentation "treat-values-as-values is no longer supported.")
-  (:dynamic-variables 
-   (*bind-treat-values-as-values* t)))
-
-(addtest (test-treat-values-as-values-true
-	  :expected-failure t)
-  generate-warning
-  (ensure-warning 
-    (macroexpand '(bind (((values a b) (foo)))
-		   (list a b)))))
-
-(addtest (test-treat-values-as-values-true)
-  generate-no-warning-on-simple-binding
-  (ensure-no-warning 
-    (macroexpand '(bind ((values 42))
-		   (list values)))))
-
-(addtest (test-treat-values-as-values-true)
-  generate-no-warning-on-simple-binding-works
-  (ensure-same
-   (eval '(bind ((values 42))
-	   (list values)))
-   '(42)
-   :test 'equal))
-
-(addtest (test-treat-values-as-values-true)
-  generate-destructuring-if-atom
-  (ensure-same 
-   (eval '(let ((foo (list 0 1 2)))
-	   (bind (((values a b) foo))
-	     (list values a b))))
-   (list 0 1 2) :test 'equal))
-
-(addtest (test-treat-values-as-values-true
-	  :expected-error t)
-  generate-values-if-cons
-  (ensure-same 
-   (eval '(bind (((values a b) (values 1 2)))
-	     (list a b)))
-   (list 1 2) :test 'equal))
-
-(deftestsuite test-treat-values-as-values-false (test-treat-values-as-values)
-  ()
-  (:dynamic-variables 
-   (*bind-treat-values-as-values* nil)))
-
-(addtest (test-treat-values-as-values-false)
-  generate-no-warning
-  (handler-case
-      (macroexpand '(bind (((values a b) (foo)))
-		     (list a b)))
-    (warning (c) (declare (ignore c))
-	     (ensure nil))))
-
-(addtest (test-treat-values-as-values-false)
-  generate-destructuring-if-cons
-  (ensure-same 
-   (eval '(bind (((values a b) (list 0 1 2)))
-	     (list values a b)))
-   (list 0 1 2) :test 'equal))
-
-;;;;;;;
-
 (deftestsuite test-bind-style-warnings (metabang-bind-test)
   ())
 
@@ -198,3 +130,34 @@
   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)))))

unit-tests/utilities.lisp

@@ -0,0 +1,19 @@
+(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))))