From: Nikodemus S. <de...@us...> - 2014-05-31 17:53:55
|
The branch "master" has been updated in SBCL: via 9595dc575aaf32f409ff67d101db90216ffeba66 (commit) from 7166b6985991e6246b42c9757dca1c137f277071 (commit) - Log ----------------------------------------------------------------- commit 9595dc575aaf32f409ff67d101db90216ffeba66 Author: Nikodemus Siivola <nik...@ra...> Date: Sat May 31 18:10:00 2014 +0300 include function name in errors about invalid local calls They call won't appear in the backtrace, so it really needs to be in the error message to avoid confusion -- prior to this the information about which function was the responsible one was hidden in the compilation log. --- NEWS | 1 + src/code/interr.lisp | 12 ++++++++---- src/compiler/alpha/call.lisp | 2 +- src/compiler/arm/call.lisp | 2 +- src/compiler/fndb.lisp | 2 +- src/compiler/hppa/call.lisp | 2 +- src/compiler/ir1util.lisp | 3 +++ src/compiler/locall.lisp | 13 +++++++------ src/compiler/mips/call.lisp | 2 +- src/compiler/ppc/call.lisp | 2 +- src/compiler/sparc/call.lisp | 2 +- src/compiler/x86-64/call.lisp | 2 +- src/compiler/x86/call.lisp | 2 +- tests/compiler.pure.lisp | 8 ++++++++ 14 files changed, 36 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 2f1871d..c10ce84 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.2.0: * enhancement: GENCGC is enabled on ARM. + * enhancement: better error reporting for invalid calls to local functions. * bug fix: TYPE-OF must not return AND/OR/NOT expressions. (lp#1317308) * bug fix: accessing NIL arrays stopped producing errors. (lp#1311421) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index f2dd34c..f1cdc49 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -47,10 +47,14 @@ (defun undefined-alien-fun-error () (error 'undefined-alien-function-error)) -(deferr invalid-arg-count-error (nargs) - (error 'simple-program-error - :format-control "invalid number of arguments: ~S" - :format-arguments (list nargs))) +(deferr invalid-arg-count-error (nargs &optional (fname nil fnamep)) + (if fnamep + (error 'simple-program-error + :format-control "~S called with invalid number of arguments: ~S" + :format-arguments (list fname nargs)) + (error 'simple-program-error + :format-control "invalid number of arguments: ~S" + :format-arguments (list nargs)))) (deferr bogus-arg-to-values-list-error (list) (error 'simple-type-error diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 0172f66..7143f19 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -1250,7 +1250,7 @@ default-value-8 (:generator 1000 (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/arm/call.lisp b/src/compiler/arm/call.lisp index f0cc8c1..239e33d 100644 --- a/src/compiler/arm/call.lisp +++ b/src/compiler/arm/call.lisp @@ -607,7 +607,7 @@ (:generator 1000 (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index a296280..4d6db64 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1519,7 +1519,7 @@ (defknown %more-kw-arg (t fixnum) (values t t)) (defknown %more-arg-values (t index index) * (flushable)) (defknown %verify-arg-count (index index) (values)) -(defknown %arg-count-error (t) nil) +(defknown %arg-count-error (t t) nil) (defknown %unknown-values () *) (defknown %catch (t t) t) (defknown %unwind-protect (t t) t) diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp index be8e880..cfaedde 100644 --- a/src/compiler/hppa/call.lisp +++ b/src/compiler/hppa/call.lisp @@ -1259,7 +1259,7 @@ default-value-8 (:generator 1000 (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 7d9f2f3..b9b3ec7 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -2099,6 +2099,9 @@ is :ANY, the function name is not checked." (values (leaf-source-name leaf) t) (values nil nil)))) +(defun combination-fun-debug-name (combination) + (leaf-debug-name (ref-leaf (lvar-uses (combination-fun combination))))) + ;;; Return the COMBINATION node that is the call to the LET FUN. (defun let-combination (fun) (declare (type clambda fun)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d7b3a63..5287678 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -190,7 +190,7 @@ (%more-arg-context ,n-supplied ,max) (%funcall ,more ,@temps ,n-context ,n-count)))))) (t - (%arg-count-error ,n-supplied))))))))) + (%arg-count-error ,n-supplied ',(leaf-debug-name fun)))))))))) ;;; Make an external entry point (XEP) for FUN and return it. We ;;; convert the result of MAKE-XEP-LAMBDA in the correct environment, @@ -502,11 +502,12 @@ (aver (combination-p node)) (aver (typep count 'unsigned-byte)) (apply 'warn warn-arguments) - (transform-call-with-ir1-environment node - `(lambda (&rest args) - (declare (ignore args)) - (%arg-count-error ,count)) - '%arg-count-error)) + (transform-call-with-ir1-environment + node + `(lambda (&rest args) + (declare (ignore args)) + (%arg-count-error ,count ',(combination-fun-debug-name node))) + '%arg-count-error)) ;;; Attempt to convert a call to a lambda. If the number of args is ;;; wrong, we give a warning and mark the call as :ERROR to remove it diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp index 0a42bdc..0918fc3 100644 --- a/src/compiler/mips/call.lisp +++ b/src/compiler/mips/call.lisp @@ -1291,7 +1291,7 @@ default-value-8 (:generator 1000 (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index 825784f..1e0b5c5 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -1247,7 +1247,7 @@ default-value-8 (:generator 1000 (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp index d47d1e7..23de71d 100644 --- a/src/compiler/sparc/call.lisp +++ b/src/compiler/sparc/call.lisp @@ -1235,7 +1235,7 @@ default-value-8 (:generator 1000 (error-call vop ',error ,@args))))) (frob arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (frob type-check-error object-not-type-error sb!c::%type-check-error object type) (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index 2d7c117..791596a 100644 --- a/src/compiler/x86-64/call.lisp +++ b/src/compiler/x86-64/call.lisp @@ -1386,7 +1386,7 @@ (:generator 1000 (error-call vop ',error ,@args))))) (def arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (def type-check-error object-not-type-error sb!c::%type-check-error object type) (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 95aaf4c..3d57363 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1476,7 +1476,7 @@ (:generator 1000 (error-call vop ',error ,@args))))) (def arg-count-error invalid-arg-count-error - sb!c::%arg-count-error nargs) + sb!c::%arg-count-error nargs fname) (def type-check-error object-not-type-error sb!c::%type-check-error object type) (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index cb38871..f3fe5fe 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -5136,3 +5136,11 @@ (assert (< (approx-lines-of-assembly-code '(or system-area-pointer (sb-kernel:simple-unboxed-array (*)))) 27)))) + +(with-test (:name :local-argument-mismatch-error-string) + (let ((f (compile nil `(lambda (x) + (flet ((foo ())) + (foo x)))))) + (multiple-value-bind (ok err) (ignore-errors (funcall f 42)) + (assert (not ok)) + (assert (search "FLET FOO" (princ-to-string err)))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |