Menu
▾
▴
[Sbcl-commits] CVS: sbcl/tests full-eval.impure.lisp, NONE, 1.1 arith.pure.lisp, 1.29, 1.30 clos.impure.lisp, 1.86, 1.87 compiler.impure.lisp, 1.77, 1.78 compiler.pure.lisp, 1.151, 1.152 compiler.test.sh, 1.17, 1.18 debug.impure.lisp, 1.29, 1.30 defstruct.impure.lisp, 1.28, 1.29 dynamic-extent.impure.lisp, 1.14, 1.15 finalize.test.sh, 1.4, 1.5 lambda-list.pure.lisp, 1.3, 1.4 loop.pure.lisp, 1.21, 1.22 package-locks.impure.lisp, 1.10, 1.11 seq.impure.lisp, 1.29, 1.30 type.pure.lisp, 1.31, 1.32
Update of /cvsroot/sbcl/sbcl/tests In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10189/tests Modified Files: arith.pure.lisp clos.impure.lisp compiler.impure.lisp compiler.pure.lisp compiler.test.sh debug.impure.lisp defstruct.impure.lisp dynamic-extent.impure.lisp finalize.test.sh lambda-list.pure.lisp loop.pure.lisp package-locks.impure.lisp seq.impure.lisp type.pure.lisp Added Files: full-eval.impure.lisp Log Message: 0.9.16.27: Add an interpreting EVAL, for cases where the compiler is unsuitable due to e.g. compilation overhead. * The old EVAL is still the default. To use the new one, (SETF SB-EXT:*EVALUATOR-MODE* :INTERPRET). Making the interpreter the default might be the purer choice, since there's a standard way of ensuring that code is compiled, and no standard way of ensuring that it's not. On the other hand, there are practical reasons for keeping the compiler as the default. The interpreter is very slow, doesn't have proper debugger support (either for backtraces or inspecting frames), and it doesn't have stepper support. * The interpreter doesn't treat THE or type declarations for lexical variables as assertions. The regression tests that assume otherwise have been disabled when running in interpreted mode. The intepreter will however type-check the proclaimed types of specials. --- NEW FILE: full-eval.impure.lisp --- ;;;; various tests of the interpreter ;;;; 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. #-sb-eval (sb-ext:quit :unix-status 104) (setf sb-ext:*evaluator-mode* :interpret) (assert (not (typep (lambda ()) 'compiled-function))) (assert (not (compiled-function-p (lambda ())))) (let ((seen-forms (make-hash-table :test 'equal))) (let ((*macroexpand-hook* (compile nil `(lambda (fun form env) (setf (gethash form ,seen-forms) t) (funcall fun form env))))) (let ((fun (lambda () (when t nil)))) (assert (not (gethash '(when t nil) seen-forms))) (funcall fun) (assert (gethash '(when t nil) seen-forms))))) Index: arith.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/arith.pure.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- arith.pure.lisp 28 Jul 2006 01:08:40 -0000 1.29 +++ arith.pure.lisp 13 Sep 2006 15:59:33 -0000 1.30 @@ -21,9 +21,9 @@ `(progn (assert (= (,op 4 2) ,res1)) (assert (= (,op 2 4) ,res2)) - (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 4 2) + (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 4 2) ,res1)) - (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 2 4) + (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 2 4) ,res2))))) (test + 6 6) (test - 2 -2) Index: clos.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure.lisp,v retrieving revision 1.86 retrieving revision 1.87 diff -u -d -r1.86 -r1.87 --- clos.impure.lisp 15 Aug 2006 08:49:51 -0000 1.86 +++ clos.impure.lisp 13 Sep 2006 15:59:33 -0000 1.87 @@ -11,8 +11,6 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(load "assertoid.lisp") - (defpackage "CLOS-IMPURE" (:use "CL" "ASSERTOID" "TEST-UTIL")) (in-package "CLOS-IMPURE") @@ -654,6 +652,7 @@ (assert (= (bug222 t) 1)) ;;; also, a test case to guard against bogus environment hacking: + (eval-when (:compile-toplevel :load-toplevel :execute) (setq bug222-b 3)) ;;; this should at the least compile: @@ -664,8 +663,10 @@ ;;; and it would be nice (though not specified by ANSI) if the answer ;;; were as follows: (let ((x (make-string-output-stream))) - ;; not specified by ANSI - (assert (= (bug222-b t x) 3)) + (let ((value (bug222-b t x))) + ;; not specified by ANSI + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) + (assert (= value 3))) ;; specified. (assert (char= (char (get-output-stream-string x) 0) #\1))) Index: compiler.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/compiler.impure.lisp,v retrieving revision 1.77 retrieving revision 1.78 diff -u -d -r1.77 -r1.78 --- compiler.impure.lisp 2 Sep 2006 11:38:24 -0000 1.77 +++ compiler.impure.lisp 13 Sep 2006 15:59:33 -0000 1.78 @@ -15,6 +15,9 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(when (eq sb-ext:*evaluator-mode* :interpret) + (sb-ext:quit :unix-status 104)) + (load "test-util.lisp") (load "assertoid.lisp") (use-package "TEST-UTIL") Index: compiler.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v retrieving revision 1.151 retrieving revision 1.152 diff -u -d -r1.151 -r1.152 --- compiler.pure.lisp 14 Aug 2006 09:21:58 -0000 1.151 +++ compiler.pure.lisp 13 Sep 2006 15:59:33 -0000 1.152 @@ -13,6 +13,10 @@ (cl:in-package :cl-user) +;; The tests in this file assume that EVAL will use the compiler +(when (eq sb-ext:*evaluator-mode* :interpret) + (invoke-restart 'run-tests::skip-file)) + ;;; Exercise a compiler bug (by crashing the compiler). ;;; ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG Index: compiler.test.sh =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/compiler.test.sh,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- compiler.test.sh 9 Jan 2006 13:00:18 -0000 1.17 +++ compiler.test.sh 13 Sep 2006 15:59:33 -0000 1.18 @@ -161,6 +161,9 @@ # test case from Rudi for some CLOS WARNINGness that shouldn't have # been there cat > $tmpfilename <<EOF + #+sb-eval (eval-when (:compile-toplevel) + (setf sb-ext:*evaluator-mode* :compile)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct buffer-state (output-index 0))) Index: debug.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/debug.impure.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- debug.impure.lisp 13 May 2006 19:50:32 -0000 1.29 +++ debug.impure.lisp 13 Sep 2006 15:59:33 -0000 1.30 @@ -14,6 +14,11 @@ ;;;; more information. (cl:in-package :cl-user) + +;;; The debugger doesn't have any native knowledge of the interpreter +(when (eq sb-ext:*evaluator-mode* :interpret) + (sb-ext:quit :unix-status 104)) + ;;;; Check that we get debug arglists right. @@ -38,7 +43,13 @@ ;; happen to be the two case that I had my nose rubbed in when ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to ;; a closure. -- WHN 2001-06-05) - (t :unknown))) + (t + #+sb-eval + (if (typep fun 'sb-eval::interpreted-function) + (sb-eval::interpreted-function-lambda-list fun) + :unknown) + #-sb-eval + :unknown))) (defun zoop (zeep &key beep) blurp) Index: defstruct.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/defstruct.impure.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- defstruct.impure.lisp 4 Jul 2006 12:40:03 -0000 1.28 +++ defstruct.impure.lisp 13 Sep 2006 15:59:33 -0000 1.29 @@ -19,7 +19,10 @@ ;;; somewhat bogus, but the requirement is clear.) (defstruct person age (name 007 :type string)) ; not an error until 007 used (make-person :name "James") ; not an error, 007 not used + +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (assert (raises-error? (make-person) type-error)) +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (assert (raises-error? (setf (person-name (make-person :name "Q")) 1) type-error)) @@ -43,6 +46,8 @@ (assert (eql (boa-saux-c s) 5))) ; these two checks should be ; kept separated + +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (let ((s (make-boa-saux))) (locally (declare (optimize (safety 0)) (inline boa-saux-a)) @@ -577,7 +582,9 @@ (assert (not (vector-struct-p nil))) (assert (not (vector-struct-p #()))) + ;;; bug 3d: type safety with redefined type constraints on slots +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (macrolet ((test (type) (let* ((base-name (intern (format nil "bug3d-~A" type))) Index: dynamic-extent.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/dynamic-extent.impure.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- dynamic-extent.impure.lisp 29 Sep 2005 06:36:17 -0000 1.14 +++ dynamic-extent.impure.lisp 13 Sep 2006 15:59:33 -0000 1.15 @@ -11,6 +11,9 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(when (eq sb-ext:*evaluator-mode* :interpret) + (sb-ext:quit :unix-status 104)) + (setq sb-c::*check-consistency* t) (defmacro defun-with-dx (name arglist &body body) Index: finalize.test.sh =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/finalize.test.sh,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- finalize.test.sh 7 Apr 2006 12:50:00 -0000 1.4 +++ finalize.test.sh 13 Sep 2006 15:59:33 -0000 1.5 @@ -16,15 +16,15 @@ (declare (ignore _)) nil) -(let ((junk (mapcar (lambda (_) - (declare (ignore _)) - (let ((x (gensym))) - (finalize x (lambda () - ;; cons in finalizer - (setf *tmp* (make-list 10000)) - (incf *count*))) - x)) - (make-list 10000)))) +(let ((junk (mapcar (compile nil '(lambda (_) + (declare (ignore _)) + (let ((x (gensym))) + (finalize x (lambda () + ;; cons in finalizer + (setf *tmp* (make-list 10000)) + (incf *count*))) + x))) + (make-list 10000)))) (setf junk (foo junk)) (foo junk)) Index: lambda-list.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/lambda-list.pure.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- lambda-list.pure.lisp 14 Jul 2005 16:30:44 -0000 1.3 +++ lambda-list.pure.lisp 13 Sep 2006 15:59:33 -0000 1.4 @@ -11,18 +11,29 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(let ((*macroexpand-hook* (lambda (fun form env) - (handler-bind ((error (lambda (c) - (when (eq 'destructuring-bind (car form)) - (throw 'd-b-error c))))) - (funcall fun form env))))) - (macrolet ((error-p (ll) +(let ((*macroexpand-hook* + (compile nil + (lambda (fun form env) + (handler-bind ((error (lambda (c) + (when (eq 'destructuring-bind (car form)) + (throw 'd-b-error c))))) + (funcall fun form env)))))) + (macrolet ((maybe-funcall (&rest args) + ;; The evaluator will delay lambda-list checks until + ;; the lambda is actually called. + (if (eq sb-ext:*evaluator-mode* :interpret) + `(funcall ,@args) + `(progn ,@args))) + (error-p (ll) `(progn - (multiple-value-bind (result error) (ignore-errors (eval `(lambda ,',ll 'ok))) + (multiple-value-bind (result error) + (ignore-errors (maybe-funcall (eval `(lambda ,',ll 'ok)))) (unless (and (not result) error) (error "No error from lambda ~S." ',ll))) (catch 'd-b-error - (eval `(lambda (x) (destructuring-bind ,',ll x 'ok))) + (maybe-funcall + (eval `(lambda (x) (destructuring-bind ,',ll x 'ok))) + nil) (error "No error from d-b ~S." ',ll))))) (error-p (&aux (foo 1) &aux (bar 2))) (error-p (&aux (foo 1) &key bar)) Index: loop.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/loop.pure.lisp,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- loop.pure.lisp 14 Jul 2005 16:30:44 -0000 1.21 +++ loop.pure.lisp 13 Sep 2006 15:59:33 -0000 1.22 @@ -33,7 +33,8 @@ ;;; a bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-05: ;;; The type declarations should apply, hence under Python's ;;; declarations-are-assertions rule, the code should signal a type -;;; error. +;;; error. (Except when running interpreted code) +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (assert (typep (nth-value 1 (ignore-errors (funcall (lambda () @@ -177,6 +178,7 @@ (setf (gethash 7 ht) 15) (assert (= (loop for v fixnum being each hash-key in ht sum v) 8)) (assert (= (loop for v fixnum being each hash-value in ht sum v) 18)) + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (assert (raises-error? (loop for v float being each hash-value in ht sum v) type-error))) Index: package-locks.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/package-locks.impure.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- package-locks.impure.lisp 14 Apr 2006 08:18:20 -0000 1.10 +++ package-locks.impure.lisp 13 Sep 2006 15:59:33 -0000 1.11 @@ -294,11 +294,17 @@ (setf (test:function) 1))) ;; ftype + ;; + ;; The interpreter doesn't do anything with ftype declarations + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (test:function . (locally (declare (ftype function test:function)) (cons t t))) ;; type + ;; + ;; Nor with type declarations + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (test:num . (locally (declare (type fixnum test:num)) (cons t t))) @@ -309,6 +315,7 @@ (cons t t))) ;; declare ftype + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (test:numfun . (locally (declare (ftype (function (fixnum) fixnum) test:numfun)) (cons t t))))) @@ -468,6 +475,8 @@ (defmethod pcl-type-declaration-method-bug ((test:*special* stream)) test:*special*) (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*))) + +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (assert (raises-error? (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) Index: seq.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/seq.impure.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- seq.impure.lisp 5 Feb 2006 23:29:16 -0000 1.29 +++ seq.impure.lisp 13 Sep 2006 15:59:33 -0000 1.30 @@ -990,6 +990,8 @@ bashed-dst) (return-from test-copy-bashing nil)))))))) +;; Too slow for the interpreter +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (loop for i = 1 then (* i 2) do ;; the bare '32' here is fairly arbitrary; '8' provides a good ;; range of lengths over which to fill and copy, which should tease Index: type.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/type.pure.lisp,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- type.pure.lisp 16 Aug 2006 18:04:34 -0000 1.31 +++ type.pure.lisp 13 Sep 2006 15:59:34 -0000 1.32 @@ -237,6 +237,10 @@ ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments. ;;; ;;; Fear the Loop of Doom! +;;; +;;; (In fact, this is such a fearsome loop that executing it with the +;;; evaluator would take ages... Disable it under those circumstances.) +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (let* ((bits 5) (size (ash 1 bits))) (flet ((brute-force (a b c d op minimize) |