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>.
parent 0ba471ef
...@@ -40,9 +40,9 @@ ...@@ -40,9 +40,9 @@
(defvar *compiler-error-context* nil) (defvar *compiler-error-context* nil)
(define-condition compiler-error (error)) (define-condition compiler-error (error) ())
(define-condition internal-compiler-error (compiler-error)) (define-condition internal-compiler-error (compiler-error) ())
(define-condition compiler-unsupported-feature-error (compiler-error)) (define-condition compiler-unsupported-feature-error (compiler-error) ())
(defun compiler-style-warn (format-control &rest format-arguments) (defun compiler-style-warn (format-control &rest format-arguments)
(warn 'style-warning (warn 'style-warning
......
...@@ -142,6 +142,11 @@ ...@@ -142,6 +142,11 @@
(when (eq keyword (car remaining)) (when (eq keyword (car remaining))
(return t)))) (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 (defun parse-defmacro-lambda-list
(lambda-list arg-list-name name error-kind error-fun (lambda-list arg-list-name name error-kind error-fun
&optional top-level env-illegal ;;env-arg-name &optional top-level env-illegal ;;env-arg-name
...@@ -193,7 +198,7 @@ ...@@ -193,7 +198,7 @@
(setq *env-var* (car rest-of-args) (setq *env-var* (car rest-of-args)
env-arg-used t)) env-arg-used t))
(t (t
(defmacro-error "&ENVIRONMENT" error-kind name)))) (defmacro-error "&ENVIRONMENT" name))))
((or (eq var '&rest) (eq var '&body)) ((or (eq var '&rest) (eq var '&body))
(cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
(setq rest-of-args (cdr rest-of-args)) (setq rest-of-args (cdr rest-of-args))
...@@ -209,7 +214,7 @@ ...@@ -209,7 +214,7 @@
(parse-defmacro-lambda-list (parse-defmacro-lambda-list
destructuring-lambda-list sub name error-kind error-fun))) destructuring-lambda-list sub name error-kind error-fun)))
(t (t
(defmacro-error (symbol-name var) error-kind name)))) (defmacro-error (symbol-name var) name))))
((eq var '&optional) ((eq var '&optional)
(setq now-processing :optionals)) (setq now-processing :optionals))
((eq var '&key) ((eq var '&key)
...@@ -279,25 +284,23 @@ ...@@ -279,25 +284,23 @@
(push-let-binding var nil nil)))) (push-let-binding var nil nil))))
(t (t
(error "non-symbol in lambda-list: ~S" var))))) (error "non-symbol in lambda-list: ~S" var)))))
;; Generate code to check the number of arguments, unless dotted ;; Generate code to check the number of arguments.
;; in which case length will not work. (push `(unless (<= ,minimum
(unless restp (dot-length ,path-0)
(push `(unless (<= ,minimum ,@(unless restp
(length ,path-0) (list maximum)))
,@(unless restp ,(if (eq error-fun 'error)
(list maximum))) `(arg-count-error ',error-kind ',name ,path-0
,(if (eq error-fun 'error) ',lambda-list ,minimum
`(arg-count-error ',error-kind ',name ,path-0 ,(unless restp maximum))
',lambda-list ,minimum `(,error-fun 'arg-count-error
,(unless restp maximum)) :kind ',error-kind
`(,error-fun 'arg-count-error ,@(when name `(:name ',name))
:kind ',error-kind :argument ,path-0
,@(when name `(:name ',name)) :lambda-list ',lambda-list
:argument ,path-0 :minimum ,minimum
:lambda-list ',lambda-list ,@(unless restp `(:maximum ,maximum)))))
:minimum ,minimum *arg-tests*)
,@(unless restp `(:maximum ,maximum)))))
*arg-tests*))
(if keys (if keys
(let ((problem (gensym "KEY-PROBLEM-")) (let ((problem (gensym "KEY-PROBLEM-"))
(info (gensym "INFO-"))) (info (gensym "INFO-")))
......
...@@ -216,7 +216,7 @@ ...@@ -216,7 +216,7 @@
(defmethod gray-streamp ((s fundamental-stream)) (defmethod gray-streamp ((s fundamental-stream))
s) s)
(defclass fundamental-input-stream (fundamental-stream)) (defclass fundamental-input-stream (fundamental-stream) ())
(defmethod gray-input-character-stream-p (s) ;; # fb 1.01 (defmethod gray-input-character-stream-p (s) ;; # fb 1.01
(and (gray-input-stream-p s) (and (gray-input-stream-p s)
...@@ -226,7 +226,7 @@ ...@@ -226,7 +226,7 @@
(declare (ignore s)) (declare (ignore s))
t) t)
(defclass fundamental-output-stream (fundamental-stream)) (defclass fundamental-output-stream (fundamental-stream) ())
(defmethod gray-input-stream-p ((s fundamental-output-stream)) (defmethod gray-input-stream-p ((s fundamental-output-stream))
(typep s 'fundamental-input-stream)) (typep s 'fundamental-input-stream))
...@@ -238,19 +238,19 @@ ...@@ -238,19 +238,19 @@
(defmethod gray-output-stream-p ((s fundamental-input-stream)) (defmethod gray-output-stream-p ((s fundamental-input-stream))
(typep s 'fundamental-output-stream)) (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)) (defmethod gray-stream-element-type ((s fundamental-character-stream))
(declare (ignore s)) (declare (ignore s))
'character) 'character)
(defclass fundamental-binary-stream (fundamental-stream)) (defclass fundamental-binary-stream (fundamental-stream) ())
(defgeneric stream-read-byte (stream)) (defgeneric stream-read-byte (stream))
(defgeneric stream-write-byte (stream integer)) (defgeneric stream-write-byte (stream integer))
(defclass fundamental-character-input-stream (defclass fundamental-character-input-stream
(fundamental-input-stream fundamental-character-stream)) (fundamental-input-stream fundamental-character-stream) ())
(defgeneric stream-read-char (stream)) (defgeneric stream-read-char (stream))
(defgeneric stream-unread-char (stream character)) (defgeneric stream-unread-char (stream character))
...@@ -292,7 +292,7 @@ ...@@ -292,7 +292,7 @@
nil) nil)
(defclass fundamental-character-output-stream (defclass fundamental-character-output-stream
(fundamental-output-stream fundamental-character-stream)) (fundamental-output-stream fundamental-character-stream) ())
(defgeneric stream-write-char (stream character)) (defgeneric stream-write-char (stream character))
(defgeneric stream-line-column (stream)) (defgeneric stream-line-column (stream))
...@@ -386,10 +386,10 @@ ...@@ -386,10 +386,10 @@
'character #'stream-write-char)) 'character #'stream-write-char))
(defclass fundamental-binary-input-stream (defclass fundamental-binary-input-stream
(fundamental-input-stream fundamental-binary-stream)) (fundamental-input-stream fundamental-binary-stream) ())
(defclass fundamental-binary-output-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) (defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
sequence &optional (start 0) end) sequence &optional (start 0) end)
......
...@@ -118,3 +118,15 @@ ...@@ -118,3 +118,15 @@
(write-string "Goodbye, World!" stream) (write-string "Goodbye, World!" stream)
(get-output-stream-string stream))) (get-output-stream-string stream)))
T) 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))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment