(dolist (arg (rest exp))
(args (eval-in-lexenv arg lexenv)))
(apply (symbol-function name) (args)))
- (%eval original-exp lexenv))))))
+ (%eval exp lexenv))))))
(t
exp))))
\f
;; (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-")))
(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))
;; 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,
;; 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~:@_~
(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))))
(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)))
--- /dev/null
+;;;; 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)))
+\f
+;;; success
+(sb-ext:quit :unix-status 104)
+
+
;;; 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"
projects / sbcl.git / commitdiff