Changeset 15004

Timestamp:

05/15/17 20:37:26 (6 years ago)

Author:

Mark Evenson

Message:

Fix DESTRUCTURING-BIND with &rest arguments

(Olof-Joachim Frahm)

Fixes <​http://abcl.org/trac/ticket/417> aka
<​https://github.com/armedbear/abcl/issues/8>.

Merges <​https://github.com/armedbear/abcl/pull/42>.

Location:

trunk/abcl

Files:

• src/org/armedbear/lisp/compiler-error.lisp (modified) (1 diff)
• src/org/armedbear/lisp/destructuring-bind.lisp (modified) (4 diffs)
• src/org/armedbear/lisp/gray-streams.lisp (modified) (7 diffs)
• test/lisp/abcl/misc-tests.lisp (modified) (1 diff)

trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp

@@ -41 +41 @@
 (defvar *compiler-error-context* nil)
 
-(define-condition compiler-error (error))
-(define-condition internal-compiler-error (compiler-error))
-(define-condition compiler-unsupported-feature-error (compiler-error))
+(define-condition compiler-error (error) ())
+(define-condition internal-compiler-error (compiler-error) ())
+(define-condition compiler-unsupported-feature-error (compiler-error) ())
 
 (defun compiler-style-warn (format-control &rest format-arguments)

trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp

@@ -142 +142 @@
     (when (eq keyword (car remaining))
       (return t))))
+
+(defun dot-length (cons)
+  (do ((rest cons (cdr rest))
+       (length 0 (1+ length)))
+      ((or (null rest) (atom rest)) length)))
 
 (defun parse-defmacro-lambda-list
@@ -194 +199 @@
                             env-arg-used t))
          (t
-          (defmacro-error "&ENVIRONMENT" error-kind name))))
+          (defmacro-error "&ENVIRONMENT" name))))
         ((or (eq var '&rest) (eq var '&body))
          (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
@@ -210 +215 @@
        destructuring-lambda-list sub name error-kind error-fun)))
          (t
-          (defmacro-error (symbol-name var) error-kind name))))
+          (defmacro-error (symbol-name var) name))))
         ((eq var '&optional)
          (setq now-processing :optionals))
@@ -280 +285 @@
         (t
          (error "non-symbol in lambda-list: ~S" var)))))
-    ;; Generate code to check the number of arguments, unless dotted
-    ;; in which case length will not work.
-    (unless restp
-      (push `(unless (<= ,minimum
-                         (length ,path-0)
-                         ,@(unless restp
-                             (list maximum)))
-               ,(if (eq error-fun 'error)
-                    `(arg-count-error ',error-kind ',name ,path-0
-                                      ',lambda-list ,minimum
-                                      ,(unless restp maximum))
-                    `(,error-fun 'arg-count-error
-                      :kind ',error-kind
-                      ,@(when name `(:name ',name))
-                      :argument ,path-0
-                      :lambda-list ',lambda-list
-                      :minimum ,minimum
-                      ,@(unless restp `(:maximum ,maximum)))))
-            *arg-tests*))
+    ;; Generate code to check the number of arguments.
+    (push `(unless (<= ,minimum
+                       (dot-length ,path-0)
+                       ,@(unless restp
+                           (list maximum)))
+             ,(if (eq error-fun 'error)
+                  `(arg-count-error ',error-kind ',name ,path-0
+                                    ',lambda-list ,minimum
+                                    ,(unless restp maximum))
+                  `(,error-fun 'arg-count-error
+                    :kind ',error-kind
+                    ,@(when name `(:name ',name))
+                    :argument ,path-0
+                    :lambda-list ',lambda-list
+                    :minimum ,minimum
+                    ,@(unless restp `(:maximum ,maximum)))))
+          *arg-tests*)
     (if keys
         (let ((problem (gensym "KEY-PROBLEM-"))

trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp

@@ -217 +217 @@
   s)
 
-(defclass fundamental-input-stream (fundamental-stream))
+(defclass fundamental-input-stream (fundamental-stream) ())
 
 (defmethod gray-input-character-stream-p (s)  ;; # fb 1.01
@@ -227 +227 @@
   t)
 
-(defclass fundamental-output-stream (fundamental-stream))
+(defclass fundamental-output-stream (fundamental-stream) ())
 
 (defmethod gray-input-stream-p ((s fundamental-output-stream))
@@ -239 +239 @@
   (typep s 'fundamental-output-stream))
 
-(defclass fundamental-character-stream (fundamental-stream))
+(defclass fundamental-character-stream (fundamental-stream) ())
 
 (defmethod gray-stream-element-type ((s fundamental-character-stream))
@@ -245 +245 @@
   'character)
 
-(defclass fundamental-binary-stream (fundamental-stream))
+(defclass fundamental-binary-stream (fundamental-stream) ())
 
 (defgeneric stream-read-byte (stream))
@@ -251 +251 @@
 
 (defclass fundamental-character-input-stream
-  (fundamental-input-stream fundamental-character-stream))
+  (fundamental-input-stream fundamental-character-stream) ())
 
 (defgeneric stream-read-char (stream))
@@ -293 +293 @@
 
 (defclass fundamental-character-output-stream
-  (fundamental-output-stream fundamental-character-stream))
+  (fundamental-output-stream fundamental-character-stream) ())
 
 (defgeneric stream-write-char (stream character))
@@ -387 +387 @@
 
 (defclass fundamental-binary-input-stream
-  (fundamental-input-stream fundamental-binary-stream))
+  (fundamental-input-stream fundamental-binary-stream) ())
 
 (defclass fundamental-binary-output-stream
-  (fundamental-output-stream fundamental-binary-stream))
+  (fundamental-output-stream fundamental-binary-stream) ())
 
 (defmethod stream-read-sequence ((stream fundamental-binary-input-stream)

trunk/abcl/test/lisp/abcl/misc-tests.lisp

@@ -119 +119 @@
                (get-output-stream-string stream)))
   T)
+
+(deftest destructuring-bind.1
+  (signals-error (destructuring-bind (a b &rest c) '(1) (list a b)) 'program-error)
+  T)
+
+(deftest destructuring-bind.2
+  (signals-error (destructuring-bind (a . b) '() (list a b)) 'program-error)
+  T)
+
+(deftest destructuring-bind.3
+  (destructuring-bind (a . b) '(1) (list a b))
+  (1 NIL))