diff --git a/BUGS b/BUGS index 308c7ccd0..dd7758f54 100644 --- a/BUGS +++ b/BUGS @@ -1268,6 +1268,14 @@ WORKAROUND: 210: "unsafe evaluation of DEFSTRUCT slot initforms in BOA constructors" (fixed in sbcl-0.7.8.35) +211: "keywords processing" + a. :ALLOW-OTHER-KEYS T should allow a function to receive an odd + number of keyword arguments. + b. Compiling of a local call with an unknown key and + :ALLOW-OTHER-KEYS T should not cause a WARNING. + c. Compiler should not warn on an unknown key :ALLOW-OTHER-KEYS. + d. :ALLOW-OTHER-KEYS should be allowed as an ordinary key parameter. + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 3fb91d173..8ec2cfc5d 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -672,7 +672,7 @@ (try-type-intersections (vars) (res) where)))) -;;; Check that Type doesn't specify any funny args, and do the +;;; Check that TYPE doesn't specify any funny args, and do the ;;; intersection. (defun find-lambda-types (lambda type where) (declare (type clambda lambda) (type fun-type type) (string where)) @@ -760,6 +760,17 @@ (derive-node-type ref type))))) t)))))) +(defun assert-global-function-definition-type (name fun) + (declare (type functional fun)) + (let ((type (info :function :type name)) + (where (info :function :where-from name))) + (when (eq where :declared) + (setf (leaf-type fun) type) + (assert-definition-type fun type + :unwinnage-fun #'compiler-note + :where "proclamation")))) + +;;;; (defun check-catch-tag-type (tag) (declare (type continuation tag)) (let ((ctype (continuation-type tag))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 229815410..14823c990 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -461,13 +461,15 @@ ;;; for the function used to implement ;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). (def-ir1-translator named-lambda ((name &rest rest) start cont) - (reference-leaf start - cont - (if (legal-fun-name-p name) - (ir1-convert-lambda `(lambda ,@rest) - :source-name name) - (ir1-convert-lambda `(lambda ,@rest) - :debug-name name)))) + (let* ((fun (if (legal-fun-name-p name) + (ir1-convert-lambda `(lambda ,@rest) + :source-name name) + (ir1-convert-lambda `(lambda ,@rest) + :debug-name name))) + (leaf (reference-leaf start cont fun))) + (when (legal-fun-name-p name) + (assert-global-function-definition-type name fun)) + leaf)) ;;;; FUNCALL diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index fd278191a..b4c90eb5c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -871,13 +871,15 @@ (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) (let* ((locall-fun (ir1-convert-lambda - definition - :debug-name (debug-namify "top level local call ~S" - name))) + definition + :debug-name (debug-namify "top level local call ~S" + name))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) :debug-name (unless name "top level form")))) + (when name + (assert-global-function-definition-type name locall-fun)) (setf (functional-entry-fun fun) locall-fun (functional-kind fun) :external (functional-has-external-references-p fun) t) diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index e898b542a..e1270e15a 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -21,11 +21,6 @@ '((:args ((1 2 3 4 5)) :result (1 2 3 4)) (:args ((1 2 3 4 5) 6) :result nil) (:args (nil) :result nil) - (:args (t) :result nil) - (:args (foosymbol 0) :result foosymbol) - (:args (foosymbol) :result nil) - (:args (foosymbol 1) :result nil) - (:args (foosymbol 2) :result nil) (:args ((1 2 3) 0) :result (1 2 3)) (:args ((1 2 3) 1) :result (1 2)) (:args ((1 2 3)) :result (1 2)) @@ -51,3 +46,12 @@ (actual-result (apply #'nbutlast copied-list rest))) (unless (equal actual-result result) (error "failed NBUTLAST for ~S" args)))))) + +(multiple-value-bind (result error) + (ignore-errors (apply #'butlast (list t))) + (assert (null result)) + (assert (typep error 'type-error))) + +;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of +;;; its first argument +(assert (not (ignore-errors (ldiff 1 2)))) diff --git a/version.lisp-expr b/version.lisp-expr index 180a3ac6e..354881e95 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.8.40" +"0.7.8.41"