From: Christophe Rhodes Date: Mon, 28 Oct 2002 21:37:30 +0000 (+0000) Subject: 0.7.9.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a260738d7a71680079d972b102b4e4db4e8dc3ae;p=sbcl.git 0.7.9.9: Fix entomotomy bug ccase-and-ecase-error-on-t-and-otherwise (and for CTYPECASE/ETYPECASE too!) ... actual change to CASE-BODY ... fix to logic of compiler warning handling when compiled under CMUCL ... cosmetic fix to use macroexpanded EXP rather than ORIGINAL-EXP in EVAL, so we don't get STYLE-WARNING twice ... correct an SB-IMPL::COMPILER-STYLE-WARN -> SB-C::COMPILER-STYLE-WARN bogosity Include tests of EVAL from previous refactor to get LOCALLY et al. right. --- diff --git a/src/code/eval.lisp b/src/code/eval.lisp index e9721f2..f8ef5b0 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -204,7 +204,7 @@ (dolist (arg (rest exp)) (args (eval-in-lexenv arg lexenv))) (apply (symbol-function name) (args))) - (%eval original-exp lexenv)))))) + (%eval exp lexenv)))))) (t exp)))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 32cc184..2574cac 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -122,7 +122,7 @@ ;; (DEFINE-COMPILER-MACRO (SETF FOO) ...) could easily be surprised ;; by this way of complying with a rather screwy aspect of the ANSI ;; spec, so at least we can warn him... - (compiler-style-warn + (sb!c::compiler-style-warn "defining compiler macro of (SETF ...), which will not be expanded")) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) @@ -173,10 +173,13 @@ (destructuring-bind (keyoid &rest forms) case (cond ((memq keyoid '(t otherwise)) (if errorp - (error 'simple-program-error - :format-control - "No default clause is allowed in ~S: ~S" - :format-arguments (list name case)) + (progn + ;; FIXME: this message could probably do with + ;; some loving pretty-printer format controls. + (style-warn "Treating bare ~A in ~A as introducing a normal-clause, not an otherwise-clause" keyoid name) + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) nil ,@forms) + clauses)) (push `(t nil ,@forms) clauses))) ((and multi-p (listp keyoid)) (setf keys (append keyoid keys)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 265034e..5343ea7 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -657,27 +657,12 @@ ;; or the cross-compiler which encountered the problem?" #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" form)))) - (handler-bind (;; When cross-compiling, we can get style warnings - ;; about e.g. undefined functions. An unhandled - ;; CL:STYLE-WARNING (as opposed to a - ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be - ;; set on the return from #'SB!XC:COMPILE-FILE, which - ;; would falsely indicate an error sufficiently - ;; serious that we should stop the build process. To - ;; avoid this, we translate CL:STYLE-WARNING - ;; conditions from the host Common Lisp into - ;; cross-compiler SB!C::COMPILER-NOTE calls. (It - ;; might be cleaner to just make Python use - ;; CL:STYLE-WARNING internally, so that the - ;; significance of any host Common Lisp - ;; CL:STYLE-WARNINGs is understood automatically. But - ;; for now I'm not motivated to do this. -- WHN - ;; 19990412) - (style-warning (lambda (c) - (compiler-note "~@<~A~:@_~A~:@_~A~:>" - (wherestring) hint c) - (muffle-warning-or-die))) - ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for + (handler-bind ((style-warning (lambda (c) + (compiler-style-warn + "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c) + (muffle-warning-or-die))) + ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for ;; Debian Linux, anyway) raises a CL:WARNING ;; condition (not a CL:STYLE-WARNING) for undefined ;; symbols when converting interpreted functions, @@ -692,7 +677,7 @@ ;; and this code does so, by crudely suppressing all ;; warnings in cross-compilation macroexpansion. -- ;; WHN 19990412 - #+cmu + #+(and cmu sb-xc-host) (warning (lambda (c) (compiler-note "~@<~A~:@_~ @@ -709,6 +694,11 @@ (wherestring) c) (muffle-warning-or-die))) + #-(and cmu sb-xc-host) + (warning (lambda (c) + (compiler-warn "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c) + (muffle-warning-or-die))) (error (lambda (c) (compiler-error "~@<~A~:@_~A~@:_~A~:>" (wherestring) hint c)))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 5abc69e..704a693 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -222,5 +222,15 @@ (assert (null result)) (assert (typep error 'program-error))) +(multiple-value-bind (result error) + (ignore-errors (ecase 1 (t 0))) + (assert (null result)) + (assert (typep error 'type-error))) + +(multiple-value-bind (result error) + (ignore-errors (ecase 1 (t 0) (1 2))) + (assert (eql result 2)) + (assert (null error))) + ;;; FTYPE should accept any functional type specifier (compile nil '(lambda (x) (declare (ftype function f)) (f x))) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp new file mode 100644 index 0000000..9b8a0b6 --- /dev/null +++ b/tests/eval.impure.lisp @@ -0,0 +1,98 @@ +;;;; various tests of EVAL with side effects + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;;; Note: this stuff gets loaded in (by LOAD) and is therefore +;;;; evaluated by EVAL, rather than compiled and then loaded; this is +;;;; why this idiom (a sequence of top-level forms) works as a test of +;;;; EVAL. + +(cl:in-package :cl-user) + +;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY, +;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness +;;; of their body forms: + +;;; LOCALLY +(locally (defstruct locally-struct a (b t))) + +(let ((x (make-locally-struct :a 1))) + (assert (eql (locally-struct-a x) 1)) + (assert (eql (locally-struct-b x) t))) + +(locally + (defmacro locally-macro (x) `(+ ,x 1)) + (assert (= (locally-macro 3) 4))) + +(locally (declare (special x)) + (defun locally-special-test () + x) + (defun locally-special-test-aux () + (let ((x 1)) + (declare (special x)) + (locally-special-test))) + (assert (= (locally-special-test-aux) 1))) + +;;; MACROLET +(macrolet () + (defstruct macrolet-struct a (b t))) + +(let ((x (make-macrolet-struct :a 1))) + (assert (eql (macrolet-struct-a x) 1)) + (assert (eql (macrolet-struct-b x) t))) + +(macrolet () + (defmacro macrolet-macro (x) `(+ ,x 1)) + (assert (= (macrolet-macro 3) 4))) + +(locally (declare (special x)) + (defun macrolet-special-test () + x) + (defun macrolet-special-test-aux () + (let ((x 1)) + (declare (special x)) + (macrolet-special-test))) + (assert (= (macrolet-special-test-aux) 1))) + +(macrolet ((foo (x) `(macrolet-bar ,x))) + (defmacro macrolet-bar (x) `(+ ,x 1)) + (assert (= (foo 1) 2))) + +;;; SYMBOL-MACROLET +(symbol-macrolet () + (defstruct symbol-macrolet-struct a (b t))) + +(let ((x (make-symbol-macrolet-struct :a 1))) + (assert (eql (symbol-macrolet-struct-a x) 1)) + (assert (eql (symbol-macrolet-struct-b x) t))) + +(symbol-macrolet () + (defmacro symbol-macrolet-macro (x) `(+ ,x 1)) + (assert (= (symbol-macrolet-macro 3) 4))) + +(locally (declare (special x)) + (defun symbol-macrolet-special-test () + x) + (defun symbol-macrolet-special-test-aux () + (let ((x 1)) + (declare (special x)) + (symbol-macrolet-special-test))) + (assert (= (symbol-macrolet-special-test-aux) 1))) + +(symbol-macrolet ((foo (symbol-macrolet-bar 1))) + (defmacro symbol-macrolet-bar (x) `(+ ,x 1)) + (assert (= foo 2))) + +;;; success +(sb-ext:quit :unix-status 104) + + diff --git a/version.lisp-expr b/version.lisp-expr index b97da0f..c420583 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.9.8" +"0.7.9.9"