Changeset 15004


Ignore:
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:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp

    r14018 r15004  
    4141(defvar *compiler-error-context* nil)
    4242
    43 (define-condition compiler-error (error))
    44 (define-condition internal-compiler-error (compiler-error))
    45 (define-condition compiler-unsupported-feature-error (compiler-error))
     43(define-condition compiler-error (error) ())
     44(define-condition internal-compiler-error (compiler-error) ())
     45(define-condition compiler-unsupported-feature-error (compiler-error) ())
    4646
    4747(defun compiler-style-warn (format-control &rest format-arguments)
  • trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp

    r14133 r15004  
    142142    (when (eq keyword (car remaining))
    143143      (return t))))
     144
     145(defun dot-length (cons)
     146  (do ((rest cons (cdr rest))
     147       (length 0 (1+ length)))
     148      ((or (null rest) (atom rest)) length)))
    144149
    145150(defun parse-defmacro-lambda-list
     
    194199                            env-arg-used t))
    195200         (t
    196           (defmacro-error "&ENVIRONMENT" error-kind name))))
     201          (defmacro-error "&ENVIRONMENT" name))))
    197202        ((or (eq var '&rest) (eq var '&body))
    198203         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
     
    210215       destructuring-lambda-list sub name error-kind error-fun)))
    211216         (t
    212           (defmacro-error (symbol-name var) error-kind name))))
     217          (defmacro-error (symbol-name var) name))))
    213218        ((eq var '&optional)
    214219         (setq now-processing :optionals))
     
    280285        (t
    281286         (error "non-symbol in lambda-list: ~S" var)))))
    282     ;; Generate code to check the number of arguments, unless dotted
    283     ;; in which case length will not work.
    284     (unless restp
    285       (push `(unless (<= ,minimum
    286                          (length ,path-0)
    287                          ,@(unless restp
    288                              (list maximum)))
    289                ,(if (eq error-fun 'error)
    290                     `(arg-count-error ',error-kind ',name ,path-0
    291                                       ',lambda-list ,minimum
    292                                       ,(unless restp maximum))
    293                     `(,error-fun 'arg-count-error
    294                       :kind ',error-kind
    295                       ,@(when name `(:name ',name))
    296                       :argument ,path-0
    297                       :lambda-list ',lambda-list
    298                       :minimum ,minimum
    299                       ,@(unless restp `(:maximum ,maximum)))))
    300             *arg-tests*))
     287    ;; Generate code to check the number of arguments.
     288    (push `(unless (<= ,minimum
     289                       (dot-length ,path-0)
     290                       ,@(unless restp
     291                           (list maximum)))
     292             ,(if (eq error-fun 'error)
     293                  `(arg-count-error ',error-kind ',name ,path-0
     294                                    ',lambda-list ,minimum
     295                                    ,(unless restp maximum))
     296                  `(,error-fun 'arg-count-error
     297                    :kind ',error-kind
     298                    ,@(when name `(:name ',name))
     299                    :argument ,path-0
     300                    :lambda-list ',lambda-list
     301                    :minimum ,minimum
     302                    ,@(unless restp `(:maximum ,maximum)))))
     303          *arg-tests*)
    301304    (if keys
    302305        (let ((problem (gensym "KEY-PROBLEM-"))
  • trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp

    r14914 r15004  
    217217  s)
    218218
    219 (defclass fundamental-input-stream (fundamental-stream))
     219(defclass fundamental-input-stream (fundamental-stream) ())
    220220
    221221(defmethod gray-input-character-stream-p (s)  ;; # fb 1.01
     
    227227  t)
    228228
    229 (defclass fundamental-output-stream (fundamental-stream))
     229(defclass fundamental-output-stream (fundamental-stream) ())
    230230
    231231(defmethod gray-input-stream-p ((s fundamental-output-stream))
     
    239239  (typep s 'fundamental-output-stream))
    240240
    241 (defclass fundamental-character-stream (fundamental-stream))
     241(defclass fundamental-character-stream (fundamental-stream) ())
    242242
    243243(defmethod gray-stream-element-type ((s fundamental-character-stream))
     
    245245  'character)
    246246
    247 (defclass fundamental-binary-stream (fundamental-stream))
     247(defclass fundamental-binary-stream (fundamental-stream) ())
    248248
    249249(defgeneric stream-read-byte (stream))
     
    251251
    252252(defclass fundamental-character-input-stream
    253   (fundamental-input-stream fundamental-character-stream))
     253  (fundamental-input-stream fundamental-character-stream) ())
    254254
    255255(defgeneric stream-read-char (stream))
     
    293293
    294294(defclass fundamental-character-output-stream
    295   (fundamental-output-stream fundamental-character-stream))
     295  (fundamental-output-stream fundamental-character-stream) ())
    296296
    297297(defgeneric stream-write-char (stream character))
     
    387387
    388388(defclass fundamental-binary-input-stream
    389   (fundamental-input-stream fundamental-binary-stream))
     389  (fundamental-input-stream fundamental-binary-stream) ())
    390390
    391391(defclass fundamental-binary-output-stream
    392   (fundamental-output-stream fundamental-binary-stream))
     392  (fundamental-output-stream fundamental-binary-stream) ())
    393393
    394394(defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
  • trunk/abcl/test/lisp/abcl/misc-tests.lisp

    r14857 r15004  
    119119               (get-output-stream-string stream)))
    120120  T)
     121
     122(deftest destructuring-bind.1
     123  (signals-error (destructuring-bind (a b &rest c) '(1) (list a b)) 'program-error)
     124  T)
     125
     126(deftest destructuring-bind.2
     127  (signals-error (destructuring-bind (a . b) '() (list a b)) 'program-error)
     128  T)
     129
     130(deftest destructuring-bind.3
     131  (destructuring-bind (a . b) '(1) (list a b))
     132  (1 NIL))
Note: See TracChangeset for help on using the changeset viewer.