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 @@
(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)
(warn 'style-warning
......
......@@ -142,6 +142,11 @@
(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
(lambda-list arg-list-name name error-kind error-fun
&optional top-level env-illegal ;;env-arg-name
......@@ -193,7 +198,7 @@
(setq *env-var* (car rest-of-args)
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)))
(setq rest-of-args (cdr rest-of-args))
......@@ -209,7 +214,7 @@
(parse-defmacro-lambda-list
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))
((eq var '&key)
......@@ -279,25 +284,23 @@
(push-let-binding var nil nil))))
(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-"))
(info (gensym "INFO-")))
......
......@@ -216,7 +216,7 @@
(defmethod gray-streamp ((s fundamental-stream))
s)
(defclass fundamental-input-stream (fundamental-stream))
(defclass fundamental-input-stream (fundamental-stream) ())
(defmethod gray-input-character-stream-p (s) ;; # fb 1.01
(and (gray-input-stream-p s)
......@@ -226,7 +226,7 @@
(declare (ignore s))
t)
(defclass fundamental-output-stream (fundamental-stream))
(defclass fundamental-output-stream (fundamental-stream) ())
(defmethod gray-input-stream-p ((s fundamental-output-stream))
(typep s 'fundamental-input-stream))
......@@ -238,19 +238,19 @@
(defmethod gray-output-stream-p ((s fundamental-input-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))
(declare (ignore s))
'character)
(defclass fundamental-binary-stream (fundamental-stream))
(defclass fundamental-binary-stream (fundamental-stream) ())
(defgeneric stream-read-byte (stream))
(defgeneric stream-write-byte (stream integer))
(defclass fundamental-character-input-stream
(fundamental-input-stream fundamental-character-stream))
(fundamental-input-stream fundamental-character-stream) ())
(defgeneric stream-read-char (stream))
(defgeneric stream-unread-char (stream character))
......@@ -292,7 +292,7 @@
nil)
(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-line-column (stream))
......@@ -386,10 +386,10 @@
'character #'stream-write-char))
(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)
sequence &optional (start 0) end)
......
......@@ -118,3 +118,15 @@
(write-string "Goodbye, World!" stream)
(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))
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