mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
dd0f579028
The feature was checked-in without being completed and it's already bitrotted. Wrapper is folded back into layout name-wise for the most part now because that's how it's been effectively functioning. There are still probably more cleanups to be done, related to this, but this takes care of most of the dead code and unnecessary layers of alternate names/indirection.
156 lines
5.6 KiB
Common Lisp
156 lines
5.6 KiB
Common 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.
|
|
|
|
#-(or sb-eval sb-fasteval) (invoke-restart 'run-tests::skip-file)
|
|
|
|
(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)))))
|
|
|
|
;;; defstruct constructor
|
|
(let ((sb-ext:*evaluator-mode* :interpret))
|
|
(eval '(progn
|
|
(defstruct evaluated-struct
|
|
(pointer nil)
|
|
(word 0 :type sb-ext:word)
|
|
(single 0.0 :type single-float)
|
|
(double 0.0d0 :type double-float)
|
|
(csingle (complex 0.0 0.0) :type (complex single-float))
|
|
(cdouble (complex 0.0d0 0.0d0) :type (complex double-float)))
|
|
(defvar *evaluated-struct* (make-evaluated-struct
|
|
:pointer :foo
|
|
:word 42
|
|
:single 1.23
|
|
:double 2.34d0
|
|
:csingle (complex 1.0 2.0)
|
|
:cdouble (complex 2.0d0 3.0d0)))
|
|
(assert (eq :foo (evaluated-struct-pointer *evaluated-struct*)))
|
|
(assert (eql 42 (evaluated-struct-word *evaluated-struct*)))
|
|
(assert (eql 1.23 (evaluated-struct-single *evaluated-struct*)))
|
|
(assert (eql 2.34d0 (evaluated-struct-double *evaluated-struct*)))
|
|
(assert (eql #c(1.0 2.0) (evaluated-struct-csingle *evaluated-struct*)))
|
|
(assert (eql #c(2.0d0 3.0d0) (evaluated-struct-cdouble *evaluated-struct*))))))
|
|
|
|
;;; Prior to 1.0.25, the interpreter checked for package lock
|
|
;;; violation for a local function in the fbinding form's body's
|
|
;;; lexical environment.
|
|
(let ((sb-ext:*evaluator-mode* :interpret))
|
|
(assert
|
|
(ignore-errors
|
|
(eval
|
|
'(eql
|
|
(locally (declare (disable-package-locks
|
|
;; rather than create a whole new package
|
|
;; just to test this corner case, we'll
|
|
;; lexically shadow something innocuous in
|
|
;; the CL package.
|
|
cl:ed))
|
|
(flet ((cl:ed ()
|
|
42))
|
|
(declare (enable-package-locks cl:ed))
|
|
(cl:ed)))
|
|
42)))))
|
|
|
|
(defvar *file* (scratch-file-name "lisp"))
|
|
(with-test (:name (:full-eval :redefinition-warnings))
|
|
(with-open-file (stream *file* :direction :output :if-exists :supersede)
|
|
(write '(defun function-for-redefinition () nil) :stream stream))
|
|
(handler-bind ((warning #'error))
|
|
(let ((sb-ext:*evaluator-mode* :interpret))
|
|
(load *file*)
|
|
(load *file*))
|
|
(let ((sb-ext:*evaluator-mode* :compile))
|
|
(load *file*))))
|
|
(delete-file *file*)
|
|
|
|
(defvar *stash*)
|
|
(defun save-it (f) (setq *stash* f) 'whatever)
|
|
(with-test (:name (let* :nested-environments))
|
|
(let ((z 'zee) (y 'y) (x 92))
|
|
(let* ((baz (save-it (lambda (what) (assert (equal (list what x y z)
|
|
(list what 92 'y 'zee))))))
|
|
(mum (funcall *stash* :after-binding-baz))
|
|
(y 'new-y)
|
|
(z (progn (funcall *stash* :after-binding-y) 'new-z))
|
|
(x (progn (funcall *stash* :after-binding-z) 'new-x)))
|
|
(funcall *stash* :in-body)
|
|
(values))))
|
|
|
|
(with-test (:name (let* :nested-environment-again))
|
|
(let* ((foo 3)
|
|
(foo (lambda () (typep foo 'integer))))
|
|
(assert (funcall foo))))
|
|
|
|
(declaim (inline some-inline-fun))
|
|
(locally
|
|
(declare (muffle-conditions compiler-note))
|
|
(defun some-inline-fun (x) (- x)))
|
|
(with-test (:name :inline-fun-captures-decl :fails-on (not :sb-fasteval))
|
|
(assert (equal (sb-int:fun-name-inline-expansion 'some-inline-fun)
|
|
'(sb-c:lambda-with-lexenv
|
|
((declare (muffle-conditions compiler-note))) (x)
|
|
(block some-inline-fun (- x))))))
|
|
|
|
(defun typecase-test (node)
|
|
(typecase node
|
|
(sb-c::bind 'a)
|
|
(sb-c::cast 'b)
|
|
(sb-c::cif 'c)
|
|
(sb-c::cset 'd)
|
|
(sb-c::ref 'e)
|
|
(sb-kernel:layout 'winner)))
|
|
|
|
(with-test (:name :interpreted-type-constraint)
|
|
(assert (eq (typecase-test (sb-kernel:find-layout 'cons)) 'winner)))
|
|
|
|
(defclass a-class ()
|
|
((x :initform 123)))
|
|
|
|
(defun a-class-x-0 (a)
|
|
(slot-value a 'x))
|
|
|
|
(defmethod a-class-x-1 ((a a-class))
|
|
(slot-value a 'x))
|
|
|
|
(defmethod a-class-x-2 ((a a-class))
|
|
(let ((%a a))
|
|
(slot-value %a 'x)))
|
|
|
|
(defmethod a-class-x-3 ((a t))
|
|
(slot-value a 'x))
|
|
|
|
(with-test (:name (slot-value defun))
|
|
(assert (= (a-class-x-0 (make-instance 'a-class)) 123)))
|
|
|
|
(with-test (:name (slot-value defmethod))
|
|
(assert (= (a-class-x-1 (make-instance 'a-class)) 123)))
|
|
|
|
(with-test (:name (slot-value defmethod let))
|
|
(assert (= (a-class-x-2 (make-instance 'a-class)) 123)))
|
|
|
|
(with-test (:name (slot-value defmethod t))
|
|
(assert (= (a-class-x-3 (make-instance 'a-class)) 123)))
|