mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Adjust test files for interpreted code.
The following categories of tests are not expected behaviors, or would be "nice to have but can't" in the interpreter: - explicitly unsafe code to explore edge cases - inlining, use of compiler-macros - non-consing (especially dx allocation) A few places that appeared to assume that EVAL meant "compile" are changed to call COMPILE. The test driver will cons :INTERPRETER onto *FEATURES* around each test file when actually interpreting, so that tests can use :SKIPPED-ON instead of testing SB-EXT:*EVALUATOR-MODE*. After this, an almost-fully-passing run of tests is possible in the new interpreter; not nearly so in sb-eval though.
This commit is contained in:
Douglas Katzman
parent
769a2cc53a
commit
278038f2bb
|
|
@ -15,6 +15,8 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
|
||||
(cl:in-package :cl-user)
|
||||
|
||||
;;; In sbcl-0.6.10, Douglas Brebner reported that (SETF EXTERN-ALIEN)
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
(:export "GRAB-CONDITION" "ASSERT-ERROR"
|
||||
"HAS-ERROR?" "IS" "ASSERTOID"
|
||||
"ASSERT-SIGNAL" "ASSERT-NO-SIGNAL"
|
||||
"LEGACY-EVAL-P"
|
||||
"EQUAL-MOD-GENSYMS"))
|
||||
|
||||
(cl:in-package "ASSERTOID")
|
||||
|
|
@ -191,3 +192,7 @@
|
|||
(t ; strings, numbers
|
||||
(funcall pred a b)))))
|
||||
(recurse a b))))
|
||||
|
||||
(defun legacy-eval-p ()
|
||||
(and (eq sb-ext:*evaluator-mode* :interpret)
|
||||
(find-package "SB-EVAL")))
|
||||
|
|
|
|||
|
|
@ -12,6 +12,9 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
;;; Typechecking should be working, but it isn't.
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
|
||||
(shadow 'slot)
|
||||
|
||||
(declaim (optimize safety))
|
||||
|
|
|
|||
|
|
@ -11,6 +11,8 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
|
||||
(load "compiler-test-util.lisp")
|
||||
(defpackage "CLOS-IMPURE"
|
||||
(:use "CL" "ASSERTOID" "TEST-UTIL" "COMPILER-TEST-UTIL"))
|
||||
|
|
|
|||
|
|
@ -17,7 +17,11 @@
|
|||
|
||||
(in-package :cl-user)
|
||||
|
||||
(when (eq sb-ext:*evaluator-mode* :interpret)
|
||||
;; The tests in this file do not work under the legacy interpreter.
|
||||
;; They mostly do work in the fast interpreter, and are either harmless
|
||||
;; or actually reasonable things to test.
|
||||
(when (and (eq sb-ext:*evaluator-mode* :interpret)
|
||||
(not (member :sb-fasteval *features*)))
|
||||
(sb-ext:exit :code 104))
|
||||
|
||||
(load "compiler-test-util.lisp")
|
||||
|
|
@ -522,7 +526,9 @@
|
|||
(assert (equal *symbol-macrolet-test-status* '(2))))
|
||||
(ignore-errors (delete-file obj)))))
|
||||
|
||||
(symbol-macrolet-test)
|
||||
;;; FIXME:
|
||||
;; I didn't look into why this fails in the interpreter, but it does.
|
||||
#-interpreter (symbol-macrolet-test)
|
||||
|
||||
;;; On the x86, this code failed to compile until sbcl-0.7.8.37:
|
||||
(defun x86-assembler-failure (x)
|
||||
|
|
@ -647,16 +653,17 @@
|
|||
(macrolet ((frob (x) `(+ ,x 3)))
|
||||
(defun to-be-inlined (y)
|
||||
(frob y)))
|
||||
#-interpreter
|
||||
(assert (= (call-inlined 3)
|
||||
;; we should have inlined the previous definition, so the
|
||||
;; new one won't show up yet.
|
||||
4))
|
||||
(defun call-inlined (z)
|
||||
(to-be-inlined z))
|
||||
(assert (= (call-inlined 3) 6))
|
||||
#-interpreter (assert (= (call-inlined 3) 6))
|
||||
(defun to-be-inlined (y)
|
||||
(+ y 5))
|
||||
(assert (= (call-inlined 3) 6))
|
||||
#-interpreter (assert (= (call-inlined 3) 6))
|
||||
|
||||
;;; DEFINE-COMPILER-MACRO to work as expected, not via weird magical
|
||||
;;; IR1 pseudo-:COMPILE-TOPLEVEL handling
|
||||
|
|
@ -1769,7 +1776,7 @@
|
|||
(setf (fill-pointer result) index)
|
||||
(coerce result 'string)))))
|
||||
|
||||
;;; Callign thru constant symbols
|
||||
;;; Calling thru constant symbols
|
||||
(require :sb-introspect)
|
||||
|
||||
(declaim (inline target-fun))
|
||||
|
|
@ -1777,6 +1784,10 @@
|
|||
(+ arg0 arg1))
|
||||
(declaim (notinline target-fun))
|
||||
|
||||
;; FIXME: should use compiler-test-util, not sb-introspect here.
|
||||
;; That issue aside, neither sb-introspect nor ctu:find-named-callees
|
||||
;; can examine an interpreted function for its callees,
|
||||
;; so we can't actually use this function.
|
||||
(defun test-target-fun-called (fun res)
|
||||
(assert (member #'target-fun
|
||||
(sb-introspect:find-function-callees #'caller-fun-1)))
|
||||
|
|
@ -1784,18 +1795,18 @@
|
|||
|
||||
(defun caller-fun-1 ()
|
||||
(funcall 'target-fun 1 2))
|
||||
(test-target-fun-called #'caller-fun-1 3)
|
||||
#-interpreter(test-target-fun-called #'caller-fun-1 3)
|
||||
|
||||
(defun caller-fun-2 ()
|
||||
(declare (inline target-fun))
|
||||
(apply 'target-fun 1 '(3)))
|
||||
(test-target-fun-called #'caller-fun-2 4)
|
||||
#-interpreter(test-target-fun-called #'caller-fun-2 4)
|
||||
|
||||
(defun caller-fun-3 ()
|
||||
(flet ((target-fun (a b)
|
||||
(- a b)))
|
||||
(list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
|
||||
(test-target-fun-called #'caller-fun-3 (list -3 5))
|
||||
#-interpreter(test-target-fun-called #'caller-fun-3 (list -3 5))
|
||||
|
||||
;;; Reported by NIIMI Satoshi
|
||||
;;; Subject: [Sbcl-devel] compilation error with optimization
|
||||
|
|
@ -1833,7 +1844,9 @@
|
|||
;;; Basic compiler-macro expansion
|
||||
(define-compiler-macro test-cmacro-0 () ''expanded)
|
||||
|
||||
(assert (eq 'expanded (funcall (lambda () (test-cmacro-0)))))
|
||||
;; The interpreter is not required to expand compiler-macros.
|
||||
;; (Actually neither is the compiler!)
|
||||
#-interpreter(assert (eq 'expanded (funcall (lambda () (test-cmacro-0)))))
|
||||
|
||||
;;; FUNCALL forms in compiler macros, lambda-list parsing
|
||||
(define-compiler-macro test-cmacro-1
|
||||
|
|
@ -1856,8 +1869,8 @@
|
|||
;;; FUNCALL forms in compiler macros, expansions
|
||||
(define-compiler-macro test-cmacro-2 () ''ok)
|
||||
|
||||
(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2)))))
|
||||
(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2)))))
|
||||
#-interpreter(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2)))))
|
||||
#-interpreter(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2)))))
|
||||
|
||||
;;; Shadowing of compiler-macros by local functions
|
||||
(define-compiler-macro test-cmacro-3 () ''global)
|
||||
|
|
@ -1872,6 +1885,7 @@
|
|||
(test-cmacro-3))))))
|
||||
(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
|
||||
(funcall #'test-cmacro-3))))))
|
||||
#-interpreter
|
||||
(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local))
|
||||
(funcall 'test-cmacro-3))))))
|
||||
|
||||
|
|
@ -1883,6 +1897,7 @@
|
|||
(declare (notinline test-cmacro-4))
|
||||
(test-cmacro-4)))))
|
||||
|
||||
#-interpreter
|
||||
(assert (eq 'macro (funcall (lambda ()
|
||||
(declare (inline test-cmacro-4))
|
||||
(test-cmacro-4)))))
|
||||
|
|
@ -1890,7 +1905,9 @@
|
|||
;;; SETF function compiler macros
|
||||
(define-compiler-macro (setf test-cmacro-4) (&whole form value) ''ok)
|
||||
|
||||
#-interpreter
|
||||
(assert (eq 'ok (funcall (lambda () (setf (test-cmacro-4) 'zot)))))
|
||||
#-interpreter
|
||||
(assert (eq 'ok (funcall (lambda () (funcall #'(setf test-cmacro-4) 'zot)))))
|
||||
|
||||
;;; Step instrumentation breaking type-inference
|
||||
|
|
@ -2566,7 +2583,8 @@
|
|||
|
||||
;; %MORE-ARG-VALUES was wrong on x86 and x86-64 with nonzero 'skip'.
|
||||
;; It's entirely possible that other backends are also not working.
|
||||
(test-util:with-test (:name more-arg-fancy)
|
||||
(test-util:with-test (:name :more-arg-fancy
|
||||
:skipped-on :interpreter)
|
||||
(assert (equal (skip-1-passthrough 0 0 'a 'b 'c 'd 'e 'f)
|
||||
'(start b c d e f end)))
|
||||
(assert (equal (skip-2-passthrough 0 0 'a 'b 'c 'd 'e 'f)
|
||||
|
|
|
|||
|
|
@ -15,8 +15,9 @@
|
|||
|
||||
(load "compiler-test-util.lisp")
|
||||
|
||||
;; The tests in this file assume that EVAL will use the compiler
|
||||
(when (eq sb-ext:*evaluator-mode* :interpret)
|
||||
;; The tests in this file do not work under the legacy interpreter.
|
||||
(when (and (eq sb-ext:*evaluator-mode* :interpret)
|
||||
(not (member :sb-fasteval *features*)))
|
||||
(invoke-restart 'run-tests::skip-file))
|
||||
|
||||
;;; Exercise a compiler bug (by crashing the compiler).
|
||||
|
|
@ -325,6 +326,9 @@
|
|||
|
||||
;;; FUNCALL of special operators and macros should signal an
|
||||
;;; UNDEFINED-FUNCTION error
|
||||
;;; But note the subtle distinction between writing (FUNCALL 'QUOTE 1)
|
||||
;;; and (FUNCALL #'QUOTE 1). In the latter, the error must be signaled
|
||||
;;; by the FUNCTION special operator, but the error class is unspecified.
|
||||
(multiple-value-bind (result error)
|
||||
(ignore-errors (funcall 'quote 1))
|
||||
(assert (null result))
|
||||
|
|
@ -1580,16 +1584,18 @@
|
|||
(frob (x) (aref x 0)))
|
||||
|
||||
(macrolet ((frob (style-warn-p form)
|
||||
(unless (eq (car form) 'lambda)
|
||||
(setq form `(lambda () ,form)))
|
||||
(if style-warn-p
|
||||
`(let ((gotit nil))
|
||||
(handler-bind ((style-warning
|
||||
(lambda (c)
|
||||
(setq gotit t) (muffle-warning c))))
|
||||
(eval ',form))
|
||||
(compile nil ',form))
|
||||
(unless gotit
|
||||
(error "missing style-warning for ~S" ',form)))
|
||||
`(handler-case
|
||||
(eval ',form)
|
||||
(compile nil ',form)
|
||||
(style-warning (e)
|
||||
(error "bad style-warning for ~S: ~A" ',form e))))))
|
||||
(frob t (lambda (x &optional y &key z) (list x y z)))
|
||||
|
|
@ -3327,7 +3333,7 @@
|
|||
(labels ((k (&optional x) #'k)))))))
|
||||
(assert (null (funcall f)))))
|
||||
|
||||
(with-test (:name :flush-vector-creation)
|
||||
(with-test (:name :flush-vector-creation :skipped-on :interpreter)
|
||||
(let ((f (compile nil `(lambda ()
|
||||
(dotimes (i 1024)
|
||||
(vector i i i))
|
||||
|
|
@ -3924,7 +3930,7 @@
|
|||
|
||||
;;; This doesn't test LVAR-FUN-IS directly, but captures it
|
||||
;;; pretty accurately anyways.
|
||||
(with-test (:name :lvar-fun-is)
|
||||
(with-test (:name :lvar-fun-is :skipped-on :interpreter)
|
||||
(dolist (fun (list
|
||||
(lambda (x) (member x x :test #'eq))
|
||||
(lambda (x) (member x x :test 'eq))
|
||||
|
|
@ -3944,7 +3950,7 @@
|
|||
(assert (member #'sb-kernel:%member-test
|
||||
(ctu:find-named-callees fun)))))
|
||||
|
||||
(with-test (:name :delete-to-delq-opt)
|
||||
(with-test (:name :delete-to-delq-opt :skipped-on :interpreter)
|
||||
(dolist (fun (list (lambda (x y)
|
||||
(declare (list y))
|
||||
(delete x y :test #'eq))
|
||||
|
|
@ -4267,7 +4273,8 @@
|
|||
(let ((i (unwind-protect 32 (shiftf d -1))))
|
||||
(or (if (= d c) 2 (= 3 b)) 4)))))
|
||||
|
||||
(with-test (:name :bug-913232)
|
||||
(with-test (:name :bug-913232
|
||||
:fails-on :interpreter) ; no idea why it fails randomly
|
||||
(compile nil `(lambda (x)
|
||||
(declare (optimize speed)
|
||||
(type (or (and (or (integer -100 -50)
|
||||
|
|
@ -4354,7 +4361,7 @@
|
|||
collect (expt 2 i)))))))
|
||||
(assert (every #'plusp (funcall f #'list)))))
|
||||
|
||||
(with-test (:name (:malformed-ignore :lp-1000239))
|
||||
(with-test (:name (:malformed-ignore :lp-1000239) :skipped-on :interpreter)
|
||||
(assert-error
|
||||
(eval '(lambda () (declare (ignore (function . a)))))
|
||||
sb-int:simple-program-error)
|
||||
|
|
@ -4382,7 +4389,7 @@
|
|||
(let ((source (read-from-string (sb-kernel::program-error-source e))))
|
||||
(equal source '#'(lambda ("foo"))))))))
|
||||
|
||||
(with-test (:name :escape-analysis-for-nlxs)
|
||||
(with-test (:name :escape-analysis-for-nlxs :skipped-on :interpreter)
|
||||
(flet ((test (check lambda &rest args)
|
||||
(let* ((cell-note nil)
|
||||
(fun (handler-bind ((compiler-note
|
||||
|
|
@ -4972,7 +4979,7 @@
|
|||
(assert failure-p)))
|
||||
|
||||
;; quantifiers shouldn't cons themselves.
|
||||
(with-test (:name :quantifiers-no-consing)
|
||||
(with-test (:name :quantifiers-no-consing :skipped-on :interpreter)
|
||||
(let ((constantly-t (lambda (x) x t))
|
||||
(constantly-nil (lambda (x) x nil))
|
||||
(list (make-list 1000 :initial-element nil))
|
||||
|
|
@ -5305,7 +5312,7 @@
|
|||
(values c b a)))
|
||||
(assert (and f (not warningp)))))
|
||||
|
||||
(with-test (:name :nth-value-of-non-constant-N)
|
||||
(with-test (:name :nth-value-of-non-constant-N :skipped-on :interpreter)
|
||||
(labels ((foo (n f) (nth-value n (funcall f)))
|
||||
(bar () (values 0 1 2 3 4 5 6 7 8 9)))
|
||||
(assert (= (foo 5 #'bar) 5)) ; basic correctness
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
|
||||
(defun unbound-marker ()
|
||||
(sb-c::%primitive sb-c:make-unbound-marker))
|
||||
(compile 'unbound-marker)
|
||||
|
||||
(defun assert-foo-not-checked (fun)
|
||||
(let* ((marker (unbound-marker))
|
||||
|
|
@ -47,6 +48,9 @@
|
|||
(defun foo-safe ()
|
||||
(declare (optimize (safety 3)))
|
||||
*foo*)
|
||||
;; When run interpreted, FOO-SAFE cannot help but check BOUNDP on *foo*
|
||||
;; so the assertion would fail.
|
||||
(compile 'foo-safe)
|
||||
|
||||
(with-test (:name :always-bound-elides-boundness-checking)
|
||||
(assert-foo-not-checked #'foo-safe))
|
||||
|
|
|
|||
|
|
@ -21,11 +21,11 @@
|
|||
(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-error (make-person) type-error)
|
||||
#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
|
||||
(assert-error (setf (person-name (make-person :name "Q")) 1)
|
||||
type-error)
|
||||
#.(if (legacy-eval-p) (values)
|
||||
'(assert-error (make-person) type-error))
|
||||
#.(if (legacy-eval-p) (values)
|
||||
'(assert-error (setf (person-name (make-person :name "Q")) 1)
|
||||
type-error))
|
||||
|
||||
;;; An &AUX variable in a boa-constructor without a default value
|
||||
;;; means "do not initialize slot" and does not cause type error
|
||||
|
|
|
|||
|
|
@ -11,6 +11,8 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
|
||||
(cl:in-package :cl-user)
|
||||
|
||||
(load "test-util.lisp")
|
||||
|
|
|
|||
|
|
@ -287,6 +287,7 @@
|
|||
;; in mind at all times when working with SSE or similar instruction sets.
|
||||
;;
|
||||
;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
|
||||
#-interpreter
|
||||
(macrolet ((with-pinned-floats ((count type &rest names) &body body)
|
||||
"Force COUNT float values to be kept live (and hopefully in registers),
|
||||
fill a temporary register with noise, and execute BODY."
|
||||
|
|
|
|||
|
|
@ -39,7 +39,8 @@
|
|||
(assert (/= (sxhash (list 1 2 3)) (sxhash (list 3 2 1))))
|
||||
(assert (/= (sxhash #*1010) (sxhash #*0101))))
|
||||
|
||||
(with-test (:name :address-based-hash-counter)
|
||||
;;; This test supposes that no un-accounted-for consing occurs.
|
||||
(with-test (:name :address-based-hash-counter :skipped-on :interpreter)
|
||||
;; It doesn't particularly matter what ADDRESS-BASED-COUNTER-VAL returns,
|
||||
;; but it's best to verify the assumption that each cons bumps the count
|
||||
;; by 1, lest it be violated in a way that affects the quality of CTYPE
|
||||
|
|
|
|||
|
|
@ -17,16 +17,24 @@
|
|||
(use-package "TEST-UTIL")
|
||||
|
||||
|
||||
(with-test (:name :disassemble)
|
||||
;; Interpreted closure is a problem for COMPILE
|
||||
(with-test (:name :disassemble :skipped-on :interpreter)
|
||||
;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
|
||||
(defun disassemble-fun (x) x)
|
||||
(disassemble 'disassemble-fun))
|
||||
|
||||
(with-test (:name :disassemble-closure)
|
||||
(with-test (:name :disassemble-closure :skipped-on :interpreter)
|
||||
(let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
|
||||
(disassemble 'disassemble-closure))
|
||||
|
||||
#+sb-eval
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(import 'sb-eval:interpreted-function-p))
|
||||
#+sb-fasteval
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(import 'sb-interpreter:interpreted-function-p))
|
||||
|
||||
#+(or sb-eval sb-fasteval)
|
||||
(with-test (:name :disassemble-interpreted)
|
||||
;; Nor should it fail on interpreted functions
|
||||
(let ((sb-ext:*evaluator-mode* :interpret))
|
||||
|
|
@ -37,7 +45,7 @@
|
|||
;; clhs disassemble: "(If that function is an interpreted function,
|
||||
;; it is first compiled but the result of this implicit compilation
|
||||
;; is not installed.)"
|
||||
(assert (sb-eval:interpreted-function-p #'disassemble-eval)))
|
||||
(assert (interpreted-function-p #'disassemble-eval)))
|
||||
|
||||
(with-test (:name :disassemble-generic)
|
||||
;; nor should it fail on generic functions or other funcallable instances
|
||||
|
|
@ -64,14 +72,14 @@
|
|||
(make-instance 'generic-function))
|
||||
(function-lambda-expression
|
||||
(make-instance 'standard-generic-function))
|
||||
#+sb-eval
|
||||
#+(or sb-eval sb-fasteval)
|
||||
(progn
|
||||
(let ((sb-ext:*evaluator-mode* :interpret))
|
||||
(eval `(defun fle-eval (x) x))
|
||||
(assert (eql (fle-name #'fle-eval) 'fle-eval)))
|
||||
|
||||
;; fle-eval should still be an interpreted function.
|
||||
(assert (sb-eval:interpreted-function-p #'fle-eval)))))
|
||||
(assert (interpreted-function-p #'fle-eval)))))
|
||||
|
||||
|
||||
;;; support for DESCRIBE tests
|
||||
|
|
|
|||
|
|
@ -91,7 +91,8 @@
|
|||
|
||||
;;; SLEEP should not cons except on 32-bit platforms when
|
||||
;;; (> (mod seconds 1) (* most-positive-fixnum 1e-9))
|
||||
(with-test (:name (sleep :non-consing) :fails-on :win32)
|
||||
(with-test (:name (sleep :non-consing) :fails-on :win32
|
||||
:skipped-on :interpreter)
|
||||
(handler-case (sb-ext:with-timeout 5
|
||||
(ctu:assert-no-consing (sleep 0.00001s0))
|
||||
(locally (declare (notinline sleep))
|
||||
|
|
@ -168,11 +169,13 @@
|
|||
;;; so that the disassembler threw an error when they were used with
|
||||
;;; one operand in memory.
|
||||
(with-test (:name :bug-814702)
|
||||
(disassemble (lambda (x)
|
||||
;; Quote the lambdas, because WITH-TEST produces a hairy lexical environment
|
||||
;; which make an interpreted lambda uncompilable.
|
||||
(disassemble '(lambda (x)
|
||||
(= #C(2.0f0 3.0f0)
|
||||
(the (complex single-float) x)))
|
||||
:stream (make-broadcast-stream))
|
||||
(disassemble (lambda (x y)
|
||||
(disassemble '(lambda (x y)
|
||||
(= (the (complex single-float) x)
|
||||
(the (complex single-float) y)))
|
||||
:stream (make-broadcast-stream)))
|
||||
|
|
|
|||
|
|
@ -19,11 +19,11 @@
|
|||
(throw 'd-b-error c)))))
|
||||
(funcall fun form env))))))
|
||||
(macrolet ((maybe-funcall (&rest args)
|
||||
;; The evaluator will delay lambda-list checks until
|
||||
;; The interpreters will delay lambda-list checks until
|
||||
;; the lambda is actually called.
|
||||
(if (eq sb-ext:*evaluator-mode* :interpret)
|
||||
`(funcall ,@args)
|
||||
`(progn ,@args)))
|
||||
(if (eq sb-ext:*evaluator-mode* :compile)
|
||||
`(progn ,@args)
|
||||
`(funcall ,@args)))
|
||||
(error-p (ll)
|
||||
`(progn
|
||||
(multiple-value-bind (result error)
|
||||
|
|
|
|||
|
|
@ -336,7 +336,7 @@
|
|||
(assert (equal '((:b)) (funcall
|
||||
(compile nil '(lambda (x y) (adjoin x y :key #'car :test #'string=)))
|
||||
(list 'b) (list '(:b)))))
|
||||
#+sb-eval
|
||||
#+(or sb-eval sb-fasteval)
|
||||
(assert (equal '((:b))
|
||||
(let ((sb-ext:*evaluator-mode* :interpret))
|
||||
(eval '(adjoin (list 'b) (list '(:b)) :key #'car :test #'string=)))))
|
||||
|
|
|
|||
|
|
@ -35,31 +35,41 @@
|
|||
|
||||
(define-symbol-macro .foo. 'foobar)
|
||||
|
||||
;;; An evaluated macroexpand-hook leads to infinite recursion.
|
||||
;;; These tests used to be runnable only if *evaluator-mode* started out
|
||||
;;; as :compile, but now we support running the test suite with any
|
||||
;;; *evaluator-mode*, so must explicitly COMPILE the macroexpand hook.
|
||||
;;; Notice that the lambda expressions being compiled are closures.
|
||||
;;; This is allowed by sb-interpreter but not sb-eval.
|
||||
|
||||
(let* ((expanded-p nil)
|
||||
(*macroexpand-hook* #'(lambda (fn form env)
|
||||
(when (eq form '.foo.)
|
||||
(setq expanded-p t))
|
||||
(funcall fn form env))))
|
||||
(*macroexpand-hook*
|
||||
(compile nil #'(lambda (fn form env)
|
||||
(when (eq form '.foo.)
|
||||
(setq expanded-p t))
|
||||
(funcall fn form env)))))
|
||||
(multiple-value-bind (expansion flag) (macroexpand '.foo.)
|
||||
(assert (equal expansion '(quote foobar)))
|
||||
(assert flag)
|
||||
(assert expanded-p)))
|
||||
|
||||
#+sb-eval
|
||||
(let ((sb-ext::*evaluator-mode* :interpret))
|
||||
#+(or sb-eval sb-fasteval)
|
||||
(let ((sb-ext:*evaluator-mode* :interpret))
|
||||
(let* ((expanded-p nil)
|
||||
(*macroexpand-hook* #'(lambda (fn form env)
|
||||
(when (eq form '.foo.)
|
||||
(setq expanded-p t))
|
||||
(funcall fn form env))))
|
||||
(*macroexpand-hook*
|
||||
(compile nil #'(lambda (fn form env)
|
||||
(when (eq form '.foo.)
|
||||
(setq expanded-p t))
|
||||
(funcall fn form env)))))
|
||||
(eval '.foo.)
|
||||
(assert expanded-p)))
|
||||
|
||||
(let* ((expanded-p nil)
|
||||
(*macroexpand-hook* #'(lambda (fn form env)
|
||||
(when (eq form '/foo/)
|
||||
(setq expanded-p t))
|
||||
(funcall fn form env))))
|
||||
(*macroexpand-hook*
|
||||
(compile nil #'(lambda (fn form env)
|
||||
(when (eq form '/foo/)
|
||||
(setq expanded-p t))
|
||||
(funcall fn form env)))))
|
||||
(compile nil '(lambda ()
|
||||
(symbol-macrolet ((/foo/ 'foobar))
|
||||
(macrolet ((expand (symbol &environment env)
|
||||
|
|
|
|||
|
|
@ -687,7 +687,13 @@
|
|||
(slot-value o 'instance))))))
|
||||
|
||||
(defgeneric definitely-a-funcallable-instance (x))
|
||||
(with-test (:name (set-funcallable-instance-function :typechecking))
|
||||
(with-test (:name (set-funcallable-instance-function :typechecking)
|
||||
;; This is a bit of a problem. SET-FUNCALLABLE-INSTANCE-FUNCTION
|
||||
;; accepts any funcallable-instance as its first argument,
|
||||
;; not just a generic-function.
|
||||
;; But an interpreted function *is* a funcallable-instance
|
||||
;; See comment in src/pcl/low about possibly tightening this up.
|
||||
:fails-on :interpreter)
|
||||
(assert-error (set-funcallable-instance-function
|
||||
(lambda (y) (declare (ignore y)) nil)
|
||||
#'definitely-a-funcallable-instance)
|
||||
|
|
|
|||
|
|
@ -362,7 +362,12 @@
|
|||
(with-error-info ("compile locked illegal lexical form: ~S~%" form)
|
||||
(let ((fun (compile nil `(lambda () ,form))))
|
||||
(assert-error (funcall fun) program-error))
|
||||
(assert-error (eval form) program-error)))))
|
||||
(assert-error (eval form)
|
||||
;; Let's not be pedantic here.
|
||||
;; PACKAGE-LOCK-VIOLATION is right,
|
||||
;; because the distinction between lexical analysis
|
||||
;; and running is artificial for interpreted code.
|
||||
(or sb-ext:package-lock-violation program-error))))))
|
||||
|
||||
;;; Locked, WITHOUT-PACKAGE-LOCKS
|
||||
(reset-test t)
|
||||
|
|
@ -456,7 +461,7 @@
|
|||
,form
|
||||
(locally (declare (enable-package-locks ,sym))
|
||||
,form)))
|
||||
program-error)))
|
||||
(or sb-ext:package-lock-violation program-error))))
|
||||
|
||||
;;;; See that trace on functions in locked packages doesn't break
|
||||
;;;; anything.
|
||||
|
|
|
|||
|
|
@ -15,7 +15,9 @@
|
|||
(declare (optimize (safety 0)))
|
||||
(setq *package* x))
|
||||
|
||||
(with-test (:name :set-bad-package)
|
||||
;; When interpreting, the error occurs in SET-BAD-PACKAGE,
|
||||
;; not at the INTERN call.
|
||||
(with-test (:name :set-bad-package :skipped-on :interpreter)
|
||||
(set-bad-package :cl-user)
|
||||
(assert-error (intern "FRED") type-error))
|
||||
|
||||
|
|
|
|||
|
|
@ -412,9 +412,11 @@
|
|||
(let ((x 3)) (defmacro macdaddy (a b &body z) a b z `(who-cares ,x)) (incf x))
|
||||
|
||||
(with-test (:name :closure-macro-arglist)
|
||||
;; assert correct test setup - MACDADDY is a closure
|
||||
;; assert correct test setup - MACDADDY is a closure if compiling,
|
||||
;; or a funcallable-instance if not
|
||||
(assert (eq (sb-kernel:fun-subtype (macro-function 'macdaddy))
|
||||
sb-vm:closure-header-widetag))
|
||||
#-interpreter sb-vm:closure-header-widetag
|
||||
#+interpreter sb-vm:funcallable-instance-header-widetag))
|
||||
;; MACRO-INDENTATION used %simple-fun-arglist instead of %fun-arglist.
|
||||
;; Depending on your luck it would either not return the right answer,
|
||||
;; or crash, depending on what lay at 4 words past the function address.
|
||||
|
|
|
|||
|
|
@ -482,8 +482,9 @@
|
|||
(write-to-string *random-state*)))))
|
||||
|
||||
(with-test (:name :write-return-value)
|
||||
(assert (= 123 (funcall (compile nil (lambda ()
|
||||
(write 123)))))))
|
||||
;; COMPILE is called explicitly because there was a bug in the
|
||||
;; compiler-macro for WRITE, which isn't expanded by the evaluator.
|
||||
(assert (= 123 (funcall (compile nil '(lambda () (write 123)))))))
|
||||
|
||||
(with-test (:name :write/write-to-string-compiler-macro-lp/598374+581564)
|
||||
(let ((test (compile nil
|
||||
|
|
|
|||
|
|
@ -347,7 +347,6 @@
|
|||
;; it is hardcoded to *keyword-package*.
|
||||
(assert (equal (read-from-string "::(foo bar)") '(:foo :bar))))
|
||||
|
||||
#+x86-64
|
||||
;; I do not know the complete list of platforms for which this test
|
||||
;; will not cons, but there were four different heap allocations
|
||||
;; instead of using dx allocation or a recyclable resource:
|
||||
|
|
@ -355,7 +354,8 @@
|
|||
;; - calling SUBSEQ for package names
|
||||
;; - multiple-value-call in WITH-CHAR-MACRO-RESULT
|
||||
;; - the initial cons cell in READ-LIST
|
||||
(with-test (:name :read-does-not-cons-per-se)
|
||||
(with-test (:name :read-does-not-cons-per-se
|
||||
:skipped-on '(:or :interpreter (:not :x86-64)))
|
||||
(flet ((test-reading (string)
|
||||
(let ((s (make-string-input-stream string)))
|
||||
(read s) ; once outside the loop, to make A-SYMBOL
|
||||
|
|
|
|||
|
|
@ -91,7 +91,11 @@
|
|||
(format t "// Running ~a~%" file)
|
||||
(restart-case
|
||||
(handler-bind ((error (make-error-handler file)))
|
||||
(eval (funcall test-fun file)))
|
||||
(let ((*features*
|
||||
(if (eq sb-ext:*evaluator-mode* :interpret)
|
||||
(cons :interpreter *features*)
|
||||
*features*)))
|
||||
(eval (funcall test-fun file))))
|
||||
(skip-file ())))
|
||||
(append-failures))))
|
||||
|
||||
|
|
@ -136,6 +140,10 @@
|
|||
(setf test-util:*break-on-expected-failure*
|
||||
,test-util:*break-on-expected-failure*)
|
||||
(let ((file ,test-file)
|
||||
(*features*
|
||||
(if (eq sb-ext:*evaluator-mode* :interpret)
|
||||
(cons :interpreter *features*)
|
||||
*features*))
|
||||
(*break-on-error* ,run-tests::*break-on-error*))
|
||||
(declare (special *break-on-error*))
|
||||
(format t "// Running ~a~%" file)
|
||||
|
|
|
|||
|
|
@ -254,7 +254,12 @@
|
|||
;; *MACROEXPAND-HOOK* would see the SETF but not the expansion
|
||||
;; of the symbol, except those expansions occurring with GET-SETF-EXPANSION.
|
||||
;; Now it can see the first-round expansion too.
|
||||
(with-test (:name :compiled-setq-macroexpand-hook)
|
||||
;; The macroexpand hook for this test needs to be compiled, but you can't
|
||||
;; pass a quoted lambda (as a sexpr) to COMPILE because it needs to
|
||||
;; capture EXPANSIONS, but you can't pass an function-quoted lambda
|
||||
;; because WITH-TEST creates a too-complex environment for conversion
|
||||
;; from an interpreted lambda.
|
||||
(with-test (:name :compiled-setq-macroexpand-hook :skipped-on :interpreter)
|
||||
(sb-int:collect ((expansions))
|
||||
(let ((*macroexpand-hook*
|
||||
(lambda (expander form env)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
|
||||
(in-package :cl-user)
|
||||
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
;; No stepper support on some platforms.
|
||||
#-(or x86 x86-64 ppc sparc mips arm)
|
||||
(sb-ext:exit :code 104)
|
||||
|
|
|
|||
|
|
@ -16,6 +16,9 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
;; These tests don't work unless compiling
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
|
||||
(defun f-with-macro (arg) (list arg))
|
||||
(defun f2-with-macro (a b) (list a b))
|
||||
(defun map-f-with-macro (l) (mapcar #'f-with-macro l))
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
;;; This file defines a structure, so is an 'impure' test
|
||||
(defstruct my-struct one two three four)
|
||||
|
||||
#+(or x86 x86-64)
|
||||
#-(and (or x86 x86-64) (not interpreter)) (sb-ext:exit :code 104)
|
||||
|
||||
(test-util:with-test (:name :basic-cpuid)
|
||||
(flet ((to-ascii (bits)
|
||||
(let ((s (make-array 4 :element-type 'base-char)))
|
||||
|
|
@ -27,7 +28,6 @@
|
|||
(concatenate 'string (to-ascii b) (to-ascii d) (to-ascii c))
|
||||
a))))
|
||||
|
||||
#+(or x86 x86-64)
|
||||
(progn
|
||||
(defun test-a-cons (acons oldcar oldcdr newcar newcdr)
|
||||
(declare (optimize (safety 0)))
|
||||
|
|
@ -61,7 +61,6 @@
|
|||
(eq (my-struct-four s) 'bootee)))))
|
||||
t))
|
||||
|
||||
#+(or x86 x86-64)
|
||||
(test-util:with-test (:name :wide-compare-and-exchange)
|
||||
(multiple-value-bind (a b c d) (%cpu-identification 0 0)
|
||||
(declare (ignore b c d))
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
#+interpreter (sb-ext:exit :code 104)
|
||||
|
||||
(in-package "CL-USER")
|
||||
|
||||
(use-package :test-util)
|
||||
|
|
|
|||
|
|
@ -575,6 +575,11 @@
|
|||
(subtypep '(and function (not compiled-function)
|
||||
(not sb-eval:interpreted-function))
|
||||
nil))
|
||||
#+sb-fasteval
|
||||
(assert-t-t
|
||||
(subtypep '(and function (not compiled-function)
|
||||
(not sb-interpreter:interpreted-function))
|
||||
nil))
|
||||
|
||||
;;; weakening of union type checks
|
||||
(defun weaken-union-1 (x)
|
||||
|
|
|
|||
Loading…
Reference in a new issue