tests/interface.impure.lisp

   1 ;;;; tests for problems in the interface presented to the user/programmer
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (load "assertoid.lisp")
  15 (load "test-util.lisp")
  16 (use-package "ASSERTOID")
  17 (use-package "TEST-UTIL")
  18
  19 (defun (setf foo) (x)
  20   "(setf foo) documentation"
  21   x)
  22
  23 (assert (string= (documentation '(setf foo) 'function)
  24                  "(setf foo) documentation"))
  25 (assert (string= (documentation #'(setf foo) 'function)
  26                  "(setf foo) documentation"))
  27
  28 (assert (string= (documentation '(setf foo) 'function)
  29                  "(setf foo) documentation"))
  30 (assert (string= (documentation #'(setf foo) 'function)
  31                  "(setf foo) documentation"))
  32 \f
  33 (with-test (:name :disassemble)
  34 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
  35   (defun disassemble-fun (x) x)
  36   (disassemble 'disassemble-fun)
  37
  38   (let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
  39   (disassemble 'disassemble-closure)
  40
  41   #+sb-eval
  42   (progn
  43     ;; Nor should it fail on interpreted functions
  44     (let ((sb-ext:*evaluator-mode* :interpret))
  45       (eval `(defun disassemble-eval (x) x))
  46       (disassemble 'disassemble-eval))
  47
  48     ;; disassemble-eval should still be an interpreted function.
  49     ;; clhs disassemble: "(If that function is an interpreted function,
  50     ;; it is first compiled but the result of this implicit compilation
  51     ;; is not installed.)"
  52     (assert (sb-eval:interpreted-function-p #'disassemble-eval)))
  53
  54   ;; nor should it fail on generic functions or other funcallable instances
  55   (defgeneric disassemble-generic (x))
  56   (disassemble 'disassemble-generic)
  57   (let ((fin (make-instance 'sb-mop:funcallable-standard-object)))
  58     (disassemble fin)))
  59
  60 ;;; while we're at it, much the same applies to
  61 ;;; FUNCTION-LAMBDA-EXPRESSION:
  62 (defun fle-fun (x) x)
  63
  64 (let ((x 1)) (defun fle-closure (y) (if y (setq x y) x)))
  65
  66 (with-test (:name :function-lambda-expression)
  67   (flet ((fle-name (x)
  68            (nth-value 2 (function-lambda-expression x))))
  69     (assert (eql (fle-name #'fle-fun) 'fle-fun))
  70     (assert (eql (fle-name #'fle-closure) 'fle-closure))
  71     (assert (eql (fle-name #'disassemble-generic) 'disassemble-generic))
  72     (function-lambda-expression
  73      (make-instance 'sb-mop:funcallable-standard-object))
  74     (function-lambda-expression
  75      (make-instance 'generic-function))
  76     (function-lambda-expression
  77      (make-instance 'standard-generic-function))
  78     #+sb-eval
  79     (progn
  80       (let ((sb-ext:*evaluator-mode* :interpret))
  81         (eval `(defun fle-eval (x) x))
  82         (assert (eql (fle-name #'fle-eval) 'fle-eval)))
  83
  84       ;; fle-eval should still be an interpreted function.
  85       (assert (sb-eval:interpreted-function-p #'fle-eval)))))
  86
  87 \f
  88 ;;; support for DESCRIBE tests
  89 (defstruct to-be-described a b)
  90 (defclass forward-describe-class (forward-describe-ref) (a))
  91 (let ((sb-ext:*evaluator-mode* :compile))
  92   (eval `(let (x) (defun closure-to-describe () (incf x)))))
  93
  94 (with-test (:name :describe-empty-gf)
  95   (describe (make-instance 'generic-function))
  96   (describe (make-instance 'standard-generic-function)))
  97
  98 ;;; DESCRIBE should run without signalling an error.
  99 (with-test (:name (describe :no-error))
 100   (describe (make-to-be-described))
 101   (describe 12)
 102   (describe "a string")
 103   (describe 'symbolism)
 104   (describe (find-package :cl))
 105   (describe '(a list))
 106   (describe #(a vector))
 107 ;; bug 824974
 108   (describe 'closure-to-describe))
 109
 110 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
 111 ;;; FRESH-LINE and TERPRI neatly.
 112 (dolist (i (list (make-to-be-described :a 14) 12 "a string"
 113                  #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword
 114                  (find-package :keyword) (list 1 2 3)
 115                  nil (cons 1 2) (make-hash-table)
 116                  (let ((h (make-hash-table)))
 117                    (setf (gethash 10 h) 100
 118                          (gethash 11 h) 121)
 119                    h)
 120                  (make-condition 'simple-error)
 121                  (make-condition 'simple-error :format-control "fc")
 122                  #'car #'make-to-be-described (lambda (x) (+ x 11))
 123                  (constantly 'foo) #'(setf to-be-described-a)
 124                  #'describe-object (find-class 'to-be-described)
 125                  (find-class 'forward-describe-class)
 126                  (find-class 'forward-describe-ref) (find-class 'cons)))
 127   (let ((s (with-output-to-string (s)
 128              (write-char #\x s)
 129              (describe i s))))
 130     (macrolet ((check (form)
 131                  `(or ,form
 132                       (error "misbehavior in DESCRIBE of ~S:~%   ~S" i ',form))))
 133       (check (char= #\x (char s 0)))
 134       ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
 135       (check (char= #\newline (char s 1)))
 136       (check (char/= #\newline (char s 2)))
 137       ;; one trailing #\NEWLINE from TERPRI or the like, no more
 138       (let ((n (length s)))
 139         (check (char= #\newline (char s (- n 1))))
 140         (check (char/= #\newline (char s (- n 2))))))))
 141
 142 \f
 143 ;;; Tests of documentation on types and classes
 144 (defclass foo ()
 145   ()
 146   (:documentation "FOO"))
 147 (defstruct bar "BAR")
 148 (define-condition baz ()
 149   ()
 150   (:documentation "BAZ"))
 151 (deftype quux ()
 152   "QUUX"
 153   't)
 154 (defstruct (frob (:type vector)) "FROB")
 155 (macrolet
 156     ((do-class (name expected &optional structurep)
 157        `(progn
 158          (assert (string= (documentation ',name 'type) ,expected))
 159          (assert (string= (documentation (find-class ',name) 'type) ,expected))
 160          (assert (string= (documentation (find-class ',name) 't) ,expected))
 161          ,@(when structurep
 162             `((assert (string= (documentation ',name 'structure) ,expected))))
 163          (let ((new1 (symbol-name (gensym "NEW1")))
 164                (new2 (symbol-name (gensym "NEW2")))
 165                (new3 (symbol-name (gensym "NEW3")))
 166                (new4 (symbol-name (gensym "NEW4"))))
 167            (declare (ignorable new4))
 168            (setf (documentation ',name 'type) new1)
 169            (assert (string= (documentation (find-class ',name) 'type) new1))
 170            (setf (documentation (find-class ',name) 'type) new2)
 171            (assert (string= (documentation (find-class ',name) 't) new2))
 172            (setf (documentation (find-class ',name) 't) new3)
 173            (assert (string= (documentation ',name 'type) new3))
 174            ,@(when structurep
 175               `((assert (string= (documentation ',name 'structure) new3))
 176                 (setf (documentation ',name 'structure) new4)
 177                 (assert (string= (documentation ',name 'structure) new4))))))))
 178   (do-class foo "FOO")
 179   (do-class bar "BAR" t)
 180   (do-class baz "BAZ"))
 181
 182 (assert (string= (documentation 'quux 'type) "QUUX"))
 183 (setf (documentation 'quux 'type) "NEW4")
 184 (assert (string= (documentation 'quux 'type) "NEW4"))
 185
 186 (assert (string= (documentation 'frob 'structure) "FROB"))
 187 (setf (documentation 'frob 'structure) "NEW5")
 188 (assert (string= (documentation 'frob 'structure) "NEW5"))
 189
 190 (define-compiler-macro cmacro (x)
 191   "compiler macro"
 192   x)
 193
 194 (define-compiler-macro (setf cmacro) (y x)
 195   "setf compiler macro"
 196   y)
 197
 198 (with-test (:name (documentation compiler-macro))
 199   (unless (equal "compiler macro"
 200                  (documentation 'cmacro 'compiler-macro))
 201     (error "got ~S for cmacro"
 202            (documentation 'cmacro 'compiler-macro)))
 203   (unless (equal "setf compiler macro"
 204                  (documentation '(setf cmacro) 'compiler-macro))
 205     (error "got ~S for setf macro" (documentation '(setf cmacro) 'compiler-macro))))
 206
 207 (with-test (:name (documentation lambda))
 208   (let ((f (lambda () "aos the zos" t))
 209         (g (sb-int:named-lambda fii () "zoot the fruit" t)))
 210     (dolist (doc-type '(t function))
 211       (assert (string= (documentation f doc-type) "aos the zos"))
 212       (assert (string= (documentation g doc-type) "zoot the fruit")))
 213     (setf (documentation f t) "fire")
 214     (assert (string= (documentation f t) "fire"))
 215     (assert (string= (documentation g t) "zoot the fruit"))))
 216
 217 (with-test (:name (documentation flet))
 218   (assert
 219    (string= (documentation
 220              (flet ((quux (x)
 221                       "this is FLET quux"
 222                       (/ x 2)))
 223                #'quux)
 224              t)
 225             "this is FLET quux")))
 226
 227 (with-test (:name (documentation labels))
 228   (assert
 229    (string= (documentation
 230              (labels ((rec (x)
 231                         "this is LABELS rec"
 232                         (if (plusp x)
 233                             (* x (rec (1- x)))
 234                             1)))
 235                #'rec)
 236              t)
 237             "this is LABELS rec")))
 238
 239 (let ((x 1))
 240   (defun docfoo (y)
 241     "bar"
 242     (incf x y)))
 243
 244 (with-test (:name (documentation :closure))
 245   (assert (string= (documentation 'docfoo 'function) "bar"))
 246   (assert (string= (setf (documentation 'docfoo 'function) "baz") "baz"))
 247   (assert (string= (documentation 'docfoo 'function) "baz"))
 248   (assert (string= (documentation #'docfoo t) "baz"))
 249   (assert (string= (setf (documentation #'docfoo t) "zot") "zot"))
 250   (assert (string= (documentation #'docfoo t) "zot"))
 251   (assert (string= (documentation 'docfoo 'function) "zot"))
 252   (assert (not (setf (documentation 'docfoo 'function) nil)))
 253   (assert (not (documentation 'docfoo 'function))))
 254
 255 (with-test (:name (documentation :built-in-macro) :skipped-on '(not :sb-doc))
 256   (assert (documentation 'trace 'function)))
 257
 258 (with-test (:name (documentation :built-in-function) :skipped-on '(not :sb-doc))
 259   (assert (documentation 'cons 'function)))
 260
 261 (with-test (:name :describe-generic-function-with-assumed-type)
 262   ;; Signalled an error at one point
 263   (flet ((zoo () (gogo)))
 264     (defmethod gogo () nil)
 265     (describe 'gogo)))
 266
 267 (defmacro bug-643958-test ()
 268   "foo"
 269   :ding!)
 270
 271 (with-test (:name :bug-643958)
 272   (assert (equal "foo" (documentation 'bug-643958-test 'function)))
 273   (setf (documentation 'bug-643958-test 'function) "bar")
 274   (assert (equal "bar" (documentation 'bug-643958-test 'function))))
 275
 276 (defclass cannot-print-this ()
 277   ())
 278 (defmethod print-object ((oops cannot-print-this) stream)
 279   (error "No go!"))
 280 (with-test (:name :describe-suppresses-print-errors)
 281   (handler-bind ((error #'continue))
 282     (with-output-to-string (s)
 283       (describe (make-instance 'cannot-print-this) s))))
 284 (with-test (:name :backtrace-suppresses-print-errors)
 285   (handler-bind ((error #'continue))
 286     (with-output-to-string (s)
 287       (labels ((foo (n x)
 288                  (when (plusp n)
 289                    (foo (1- n) x))
 290                  (when (zerop n)
 291                    (sb-debug:backtrace 100 s))))
 292         (foo 100 (make-instance 'cannot-print-this))))))
 293 (with-test (:name :backtrace-and-circles)
 294   (handler-bind ((error #'continue))
 295     (with-output-to-string (s)
 296       (labels ((foo (n x)
 297                  (when (plusp n)
 298                    (foo (1- n) x))
 299                  (when (zerop n)
 300                    (sb-debug:backtrace 100 s))))
 301         (foo 100 (let ((list (list t)))
 302                    (nconc list list)))))))
 303
 304 (with-test (:name :endianness-in-features)
 305   (assert
 306    (or (member :big-endian *features*)
 307        (member :little-endian *features*))))
 308
 309 (with-test (:name :function-documentation-mismatch)
 310   (defun test ()
 311     "X"
 312     nil)
 313   (setf (symbol-function 'test2) #'test)
 314   (setf (documentation 'test 'function) "Y")
 315   (assert (equal (documentation #'test t)
 316                  (documentation 'test 'function)))
 317   (setf (documentation 'test2 'function) "Z")
 318   (assert (not
 319            (equal (documentation 'test 'function)
 320                   (documentation 'test2 'function)))))
 321
 322 (with-test (:name :setf-documentation-on-nil)
 323   (assert
 324    (handler-case
 325        (assert (equal (setf (documentation nil 'function) "foo") "foo"))
 326      (style-warning () t)
 327      (:no-error (x)
 328        (declare (ignore x))
 329        nil))))
 330
 331 (with-test (:name (trace generic-function))
 332   (defgeneric traced-gf (x))
 333   (defmethod traced-gf (x) (1+ x))
 334   (assert (= (traced-gf 3) 4))
 335   (trace traced-gf)
 336   (let ((output (with-output-to-string (*trace-output*)
 337                   (assert (= (traced-gf 3) 4)))))
 338     (assert (> (length output) 0)))
 339   (assert (typep #'traced-gf 'standard-generic-function))
 340   (untrace traced-gf)
 341   (let ((output (with-output-to-string (*trace-output*)
 342                   (assert (= (traced-gf 3) 4)))))
 343     (assert (= (length output) 0))))
 344 \f
 345 ;;;; success