CVS: sbcl/tests eval.impure.lisp,NONE,1.1 compiler.pure.lisp,1.20,1.21

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv19626/tests

Modified Files:
        compiler.pure.lisp 
Added Files:
        eval.impure.lisp 
Log Message:
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.


--- NEW FILE: eval.impure.lisp ---
;;;; 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)

    

Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- compiler.pure.lisp  15 Oct 2002 12:20:35 -0000      1.20
+++ compiler.pure.lisp  28 Oct 2002 21:37:31 -0000      1.21
@@ -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)))



-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf