[5eb98a]: tests / full-eval.impure.lisp  Maximize  Restore  History

Download this file

107 lines (95 with data), 4.3 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
;;;; 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:exit :code 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)))))
;;; defstruct constructor
(let ((sb-ext:*evaluator-mode* :interpret))
(eval '(progn
(defstruct evaluated-struct
(pointer nil)
(word 0 :type (unsigned-byte #.sb-vm:n-word-bytes))
(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* #p"full-eval-temp.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))))

Get latest updates about Open Source Projects, Conferences and News.

Sign up for the SourceForge newsletter:

JavaScript is required for this form.





No, thanks