From af4276830f299244920d0e131e1e5e088383b763 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 13 Oct 2010 13:13:35 +0000 Subject: [PATCH] 1.0.43.50: better function signature checking for self-calls Fixes bug 655126. Allow passing a lambda-list to GET-DEFINED-FUN, and when provided one, make up an FTYPE based on that lambda-list. --- NEWS | 3 +++ src/compiler/ir1tran-lambda.lisp | 46 +++++++++++++++++++++++++++++++++----- tests/compiler.impure.lisp | 23 +++++++++++++++++++ tests/compiler.test.sh | 9 ++++++++ version.lisp-expr | 2 +- 5 files changed, 76 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index 1c07af4..0b256df 100644 --- a/NEWS +++ b/NEWS @@ -53,6 +53,9 @@ changes relative to sbcl-1.0.43: greater value than n-word-bits. (lp#309063) * bug fix: (SETF SYMBOL-FUNCTION) and (SETF FDEFINITION) clear derived type information for the function being set. (lp#659220) + * bug fix: the system used to signal bogus STYLE-WARNINGs when functions + containing self-calls were recompiled with a new signature, and failed + to warn when a self-call using the old signature was left in. (lp#655126) changes in sbcl-1.0.43 relative to sbcl-1.0.42: * incompatible change: FD-STREAMS no longer participate in the serve-event diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index b1ee7ee..93e739e 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -1015,7 +1015,7 @@ (let ((name (cadr thing)) (lambda-expression `(lambda ,@(cddr thing)))) (if (and name (legal-fun-name-p name)) - (let ((defined-fun-res (get-defined-fun name)) + (let ((defined-fun-res (get-defined-fun name (second lambda-expression))) (res (ir1-convert-lambda lambda-expression :maybe-add-debug-catch t :source-name name))) @@ -1073,10 +1073,37 @@ (setf (functional-inline-expanded clambda) t) clambda))) +;;; Given a lambda-list, return a FUN-TYPE object representing the signature: +;;; return type is *, and each individual arguments type is T -- but we get +;;; the argument counts and keywords. +(defun ftype-from-lambda-list (lambda-list) + (multiple-value-bind (req opt restp rest-name keyp key-list allowp morep) + (parse-lambda-list lambda-list) + (declare (ignore rest-name)) + (flet ((t (list) + (mapcar (constantly t) list))) + (let ((reqs (t req)) + (opts (when opt (cons '&optional (t opt)))) + ;; When it comes to building a type, &REST means pretty much the + ;; same thing as &MORE. + (rest (when (or morep restp) (list '&rest t))) + (keys (when keyp + (cons '&key (mapcar (lambda (spec) + (let ((key/var (if (consp spec) + (car spec) + spec))) + (list (if (consp key/var) + (car key/var) + (keywordicate key/var)) + t))) + key-list)))) + (allow (when allowp (list '&allow-other-keys)))) + (specifier-type `(function (,@reqs ,@opts ,@rest ,@keys ,@allow) *)))))) + ;;; Get a DEFINED-FUN object for a function we are about to define. If ;;; the function has been forward referenced, then substitute for the ;;; previous references. -(defun get-defined-fun (name) +(defun get-defined-fun (name &optional (lambda-list nil lp)) (proclaim-as-fun-name name) (when (boundp '*free-funs*) (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) @@ -1087,15 +1114,20 @@ (res (make-defined-fun :%source-name name :where-from (if (eq where-from :declared) - :declared :defined) - :type (leaf-type found)))) + :declared + :defined) + :type (if (eq :declared where-from) + (leaf-type found) + (if lp + (ftype-from-lambda-list lambda-list) + (specifier-type 'function)))))) (substitute-leaf res found) (setf (gethash name *free-funs*) res))) ;; If *FREE-FUNS* has a previously converted definition ;; for this name, then blow it away and try again. ((defined-fun-functionals found) (remhash name *free-funs*) - (get-defined-fun name)) + (get-defined-fun name lambda-list)) (t found))))) ;;; Check a new global function definition for consistency with @@ -1184,7 +1216,9 @@ (defun %compiler-defun (name lambda-with-lexenv compile-toplevel) (let ((defined-fun nil)) ; will be set below if we're in the compiler (when compile-toplevel - (setf defined-fun (get-defined-fun name)) + (setf defined-fun (if lambda-with-lexenv + (get-defined-fun name (fifth lambda-with-lexenv)) + (get-defined-fun name))) (when (boundp '*lexenv*) (remhash name *free-funs*) (aver (fasl-output-p *compile-object*)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 195a2f4..a454e59 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -2018,4 +2018,27 @@ (length (clear-derived-types-on-set-fdefn-1))))) (assert (= 6 (clear-derived-types-on-set-fdefn-2))))) +(test-util:with-test (:name :bug-655126) + (let ((*evaluator-mode* :compile) + (*derive-function-types* t)) + (eval `(defun bug-655126 (x) x)) + (assert (eq :style-warning + (handler-case + (eval `(defun bug-655126-2 () + (bug-655126))) + (style-warning () + :style-warning)))) + (assert (eq 'bug-655126 + (handler-case + (eval `(defun bug-655126 (x y) + (cons x y))) + ((and style-warning (not sb-kernel:redefinition-warning)) () + :oops)))) + (assert (eq :style-warning + (handler-case + (eval `(defun bug-655126 (x) + (bug-655126 x y))) + ((and style-warning (not sb-kernel:redefinition-warning)) () + :style-warning)))))) + ;;; success diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh index 13d1c75..549141d 100644 --- a/tests/compiler.test.sh +++ b/tests/compiler.test.sh @@ -26,6 +26,15 @@ cat > $tmpfilename < $tmpfilename < $tmpfilename <