tests/smoke.impure.lisp

   1 ;;;; rudimentary tests ("smoke tests") for miscellaneous stuff which
   2 ;;;; doesn't seem to deserve specialized files at the moment
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   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
   9 ;;;; from CMU CL.
  10 ;;;;
  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.
  14
  15 (cl:in-package :cl-user)
  16
  17 ;;; ROOM should run without signalling an error. (bug 247)
  18 (let ((*standard-output* (make-broadcast-stream)))
  19   (room)
  20   (room t)
  21   (room nil))
  22
  23 ;;; COPY-SYMBOL should work without signalling an error, even if the
  24 ;;; symbol is unbound.
  25 (copy-symbol 'foo)
  26 (copy-symbol 'bar t)
  27 (defvar *baz* nil)
  28 (copy-symbol '*baz* t)
  29
  30 ;;; SETQ should return its value.
  31 (assert (typep (setq *baz* 1) 'integer))
  32 (assert (typep (in-package :cl-user) 'package))
  33
  34 ;;; PROFILE should run without obvious breakage
  35 (progn
  36   (defun profiled-fun ()
  37     (random 1d0))
  38   (profile profiled-fun)
  39   (loop repeat 100000 do (profiled-fun))
  40   (let ((*trace-output* (make-broadcast-stream)))
  41     (report)))
  42
  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))
  54 (handler-bind
  55     ((sb-ext:defconstant-uneql
  56          (lambda (c) (abort c))))
  57   (defconstant +const+ 3))
  58 (assert (= (oidentity +const+) 1))
  59 (handler-bind
  60     ((sb-ext:defconstant-uneql
  61          (lambda (c) (continue c))))
  62   (defconstant +const+ 3))
  63 (assert (= (oidentity +const+) 3))
  64
  65 ;;; MULTIPLE-VALUE-BIND and lambda list keywords
  66 (multiple-value-bind (&rest &optional &key &allow-other-keys)
  67     (values 1 2 3)
  68   (assert (= &rest 1))
  69   (assert (= &optional 2))
  70   (assert (= &key 3))
  71   (assert (null &allow-other-keys)))
  72
  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)))))
  81
  82 ;;; Failure to save a core is an error
  83 (with-test (:name :save-lisp-and-die-error)
  84   (assert (eq :oops
  85               (handler-case (save-lisp-and-die "/")
  86                 (error () :oops)))))
  87
  88 ;;; success