1 ;;;; rudimentary tests ("smoke tests") for miscellaneous stuff which
2 ;;;; doesn't seem to deserve specialized files at the moment
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (cl:in-package
:cl-user
)
17 ;;; ROOM should run without signalling an error. (bug 247)
18 (let ((*standard-output
* (make-broadcast-stream)))
23 ;;; COPY-SYMBOL should work without signalling an error, even if the
24 ;;; symbol is unbound.
28 (copy-symbol '*baz
* t
)
30 ;;; SETQ should return its value.
31 (assert (typep (setq *baz
* 1) 'integer
))
32 (assert (typep (in-package :cl-user
) 'package
))
34 ;;; PROFILE should run without obvious breakage
36 (defun profiled-fun ()
38 (profile profiled-fun
)
39 (loop repeat
100000 do
(profiled-fun))
40 (let ((*trace-output
* (make-broadcast-stream)))
43 ;;; Defconstant should behave as the documentation specifies,
44 ;;; including documented condition type.
45 (defun oidentity (x) x
)
46 (defconstant +const
+ 1)
47 (assert (= (oidentity +const
+) 1))
48 (let ((error (nth-value 1 (ignore-errors (defconstant +const
+ 2)))))
49 (assert (typep error
'sb-ext
:defconstant-uneql
))
50 (assert (= (sb-ext:defconstant-uneql-old-value error
) 1))
51 (assert (= (sb-ext:defconstant-uneql-new-value error
) 2))
52 (assert (eql (sb-ext:defconstant-uneql-name error
) '+const
+)))
53 (assert (= (oidentity +const
+) 1))
55 ((sb-ext:defconstant-uneql
56 (lambda (c) (abort c
))))
57 (defconstant +const
+ 3))
58 (assert (= (oidentity +const
+) 1))
60 ((sb-ext:defconstant-uneql
61 (lambda (c) (continue c
))))
62 (defconstant +const
+ 3))
63 (assert (= (oidentity +const
+) 3))
65 ;;; MULTIPLE-VALUE-BIND and lambda list keywords
66 (multiple-value-bind (&rest
&optional
&key
&allow-other-keys
)
69 (assert (= &optional
2))
71 (assert (null &allow-other-keys
)))
73 (with-test (:name
(:lambda-list
:suspicious-variables
))
74 (multiple-value-bind (fun failure-p warnings style-warnings
)
75 (checked-compile `(lambda (&foo
&rest
&bar
) (cons &foo
&bar
))
76 :allow-style-warnings t
)
77 (declare (ignore failure-p warnings
))
78 (assert (= 2 (length style-warnings
)))
79 (assert (equal (funcall fun
1) '(1)))
80 (assert (equal (funcall fun
1 2 3) '(1 2 3)))))
82 ;;; Failure to save a core is an error
83 (with-test (:name
:save-lisp-and-die-error
)
85 (handler-case (save-lisp-and-die "/")