0.7.8.41:

        Proclaimed function type is checked in the XEP.

diff --git a/BUGS b/BUGS
index 308c7cc..dd7758f 100644 (file)
--- 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 3fb91d1..8ec2cfc 100644 (file)
--- 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"))))
+\f
+;;;;
 (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 2298154..14823c9 100644 (file)
--- 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))
 \f
 ;;;; FUNCALL
 

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index fd27819..b4c90eb 100644 (file)
--- 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 e898b54..e1270e1 100644 (file)
--- 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 180a3ac..354881e 100644 (file)
--- 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"