From 182c5bd0c2c800f35f70ef2513d8e8a4e031310a Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 16 Sep 2013 10:01:23 -0400 Subject: [PATCH] Fix lp#1225898: ENSURE-FUNCTION must specially treat LAMBDA. --- ...test-around-compile-lambda.script.dont-run | 12 --------- test/test-around-compile.script | 27 ++++++++++++------- uiop/utility.lisp | 7 +++-- 3 files changed, 23 insertions(+), 23 deletions(-) delete mode 100644 test/test-around-compile-lambda.script.dont-run diff --git a/test/test-around-compile-lambda.script.dont-run b/test/test-around-compile-lambda.script.dont-run deleted file mode 100644 index 767a94d5..00000000 --- a/test/test-around-compile-lambda.script.dont-run +++ /dev/null @@ -1,12 +0,0 @@ -;;; -*- Lisp -*- - - -(progn - (def-test-system test-around-compile-lambda - :around-compile (lambda (thunk) - (let ((*read-base* 2)) - (funcall thunk))) - ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. - :components ((:file "test"))) - (load-system 'test-around-compile-lambda :force t) - (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2 diff --git a/test/test-around-compile.script b/test/test-around-compile.script index babd00e3..33e8fcac 100644 --- a/test/test-around-compile.script +++ b/test/test-around-compile.script @@ -1,15 +1,24 @@ ;;; -*- Lisp -*- - - (defun call-in-base-2 (thunk) (let ((*read-base* 2)) (funcall thunk))) -(progn - (def-test-system test-around-compile - :around-compile call-in-base-2 - ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. - :components ((:file "test"))) - (load-system 'test-around-compile :force t) - (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2 +(DBG "Testing around-compile with a function name") +(def-test-system test-around-compile + :around-compile call-in-base-2 + ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. + :components ((:file "test"))) +(load-system 'test-around-compile :force t) +(assert (= 3 (funcall 'add10 1))) ;; add10 must have been compiled in base 2 + +(fmakunbound 'add10) + +(DBG "Testing around-compile with a lambda") +(def-test-system test-around-compile-lambda + :around-compile (lambda (thunk) + (let ((*read-base* 2)) + (funcall thunk))) + :components ((:file "test"))) +(load-system 'test-around-compile-lambda :force t) +(assert (= 3 (funcall 'add10 1))) ;; add10 must have been compiled in base 2 diff --git a/uiop/utility.lisp b/uiop/utility.lisp index ab0b99c7..685859bf 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -318,14 +318,17 @@ If the FUN is a non-sequence literal constant, return constantly that, i.e. for a boolean keyword character number or pathname. Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. If FUN is a CONS, return the function that applies its CAR -to the appended list of the rest of its CDR and the arguments. +to the appended list of the rest of its CDR and the arguments, +unless the CAR is LAMBDA, in which case the expression is evaluated. If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) and EVAL that in a (FUNCTION ...) context." (etypecase fun (function fun) ((or boolean keyword character number pathname) (constantly fun)) ((or function symbol) fun) - (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))) + (cons (if (eq 'lambda (car fun)) + (eval fun) + #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) (string (eval `(function ,(with-standard-io-syntax (let ((*package* (find-package package))) (read-from-string fun)))))))) -- GitLab