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 (defmacro silently (&rest things)
  15   `(let ((*standard-output* (make-broadcast-stream))) ,@things))
  16 \f
  17 ;; Interpreted closure is a problem for COMPILE
  18 (with-test (:name (disassemble function) :skipped-on :interpreter)
  19   ;; DISASSEMBLE shouldn't fail on closures or unpurified functions
  20   (defun disassemble-fun (x) x)
  21   (silently (disassemble 'disassemble-fun)))
  22
  23 (with-test (:name (disassemble :closure) :skipped-on :interpreter)
  24   (let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
  25   (silently (disassemble 'disassemble-closure)))
  26
  27 (defun interpreted-function-p (x) (typep x 'sb-kernel:interpreted-function))
  28
  29 #+(or sb-eval sb-fasteval)
  30 (with-test (:name (disassemble :interpreted))
  31     ;; Nor should it fail on interpreted functions
  32     (let ((sb-ext:*evaluator-mode* :interpret))
  33       (eval `(defun disassemble-eval (x) x))
  34       (silently (disassemble 'disassemble-eval)))
  35
  36     ;; disassemble-eval should still be an interpreted function.
  37     ;; clhs disassemble: "(If that function is an interpreted function,
  38     ;; it is first compiled but the result of this implicit compilation
  39     ;; is not installed.)"
  40     (assert (interpreted-function-p (symbol-function 'disassemble-eval))))
  41
  42 (with-test (:name (disassemble generic-function))
  43   ;; nor should it fail on generic functions or other funcallable instances
  44   (defgeneric disassemble-generic (x))
  45   (silently (disassemble 'disassemble-generic))
  46   (let ((fin (make-instance 'sb-mop:funcallable-standard-object)))
  47     (silently (disassemble fin))))
  48
  49 ;;; while we're at it, much the same applies to
  50 ;;; FUNCTION-LAMBDA-EXPRESSION:
  51 (defun fle-fun (x) x)
  52
  53 (let ((x 1)) (defun fle-closure (y) (if y (setq x y) x)))
  54
  55 (defclass non-standard-generic-function (generic-function) ()
  56   (:metaclass sb-mop:funcallable-standard-class))
  57 (defmethod sb-mop:generic-function-name ((generic-function non-standard-generic-function))
  58   'name)
  59
  60 (with-test (:name function-lambda-expression)
  61   (flet ((fle-name (x)
  62            (nth-value 2 (function-lambda-expression x))))
  63     (assert (eql (fle-name #'fle-fun) 'fle-fun))
  64     (assert (eql (fle-name #'fle-closure) 'fle-closure))
  65     (assert (eql (fle-name #'disassemble-generic) 'disassemble-generic))
  66     (function-lambda-expression
  67      (make-instance 'sb-mop:funcallable-standard-object))
  68     (function-lambda-expression
  69      (make-instance 'non-standard-generic-function))
  70     (function-lambda-expression
  71      (make-instance 'standard-generic-function))
  72     #+(or sb-eval sb-fasteval)
  73     (progn
  74       (let ((sb-ext:*evaluator-mode* :interpret))
  75         (eval `(defun fle-eval (x) x))
  76         (assert (eql (fle-name (symbol-function 'fle-eval)) 'fle-eval)))
  77
  78       ;; fle-eval should still be an interpreted function.
  79       (assert (interpreted-function-p (symbol-function 'fle-eval))))))
  80
  81 (with-test (:name :nested-function-lambda-expression)
  82   (let* ((lexpr
  83           '(lambda ()
  84             (labels ((f1 (z &rest r &key (b (eval 'foo)) (a 3) w)
  85                        (- a w (length r) (f2 (/  z b))))
  86                      (f2 (w) (* w .3)))
  87               (values #'f1 #'f2))))
  88          (f (compile nil lexpr)))
  89     (assert (equal (function-lambda-expression f) lexpr))
  90     (assert (equal (function-lambda-expression (funcall f))
  91                    '(lambda (z &rest r &key (b (eval 'foo)) (a 3) w)
  92                      (block f1 (- a w (length r) (f2 (/ z b)))))))
  93     (assert (equal (function-lambda-expression
  94                     (nth-value 1 (funcall f)))
  95                    '(lambda (w) (block f2 (* w 0.3)))))))
  96 \f
  97 ;;; Tests of documentation on types and classes
  98
  99 (defun assert-documentation (thing doc-type expected)
 100   ;; This helper function makes ASSERT errors print THING, DOC-TYPE,
 101   ;; the return value of DOCUMENTATION and EXPECTED.
 102   (flet ((assert-documentation-helper (thing doc-type documentation expected)
 103            (declare (ignore thing doc-type))
 104            (equal documentation expected)))
 105     (assert (assert-documentation-helper
 106              thing doc-type (documentation thing doc-type) expected))))
 107
 108 (defpackage #:documentation.package
 109   (:documentation "PACKAGE"))
 110
 111 (with-test (:name (documentation package))
 112   (assert-documentation (find-package '#:documentation.package) t "PACKAGE")
 113   (setf (documentation (find-package '#:documentation.package) t) "PACKAGE2")
 114   (assert-documentation (find-package '#:documentation.package) t "PACKAGE2"))
 115
 116 (defclass foo ()
 117   ()
 118   (:documentation "FOO"))
 119
 120 (defclass documentation.funcallable-instance ()
 121   ()
 122   (:metaclass sb-mop:funcallable-standard-class)
 123   (:documentation "FEZ"))
 124
 125 (defstruct bar "BAR")
 126
 127 (define-condition baz ()
 128   ()
 129   (:documentation "BAZ"))
 130
 131 (macrolet
 132     ((do-class (name expected &optional structurep)
 133        `(progn
 134           (assert-documentation ',name 'type ,expected)
 135           (assert-documentation (find-class ',name) 'type ,expected)
 136           (assert-documentation (find-class ',name) 't ,expected)
 137           ,@(when structurep
 138               `((assert-documentation ',name 'structure ,expected)))
 139
 140           (let ((new1 (symbol-name (gensym "NEW1")))
 141                 (new2 (symbol-name (gensym "NEW2")))
 142                 (new3 (symbol-name (gensym "NEW3")))
 143                 (new4 (symbol-name (gensym "NEW4"))))
 144             (declare (ignorable new4))
 145             (setf (documentation ',name 'type) new1)
 146             (assert-documentation (find-class ',name) 'type new1)
 147             (setf (documentation (find-class ',name) 'type) new2)
 148             (assert-documentation (find-class ',name) 't new2)
 149             (setf (documentation (find-class ',name) 't) new3)
 150             (assert-documentation ',name 'type new3)
 151             ,@(when structurep
 152                 `((assert-documentation ',name 'structure new3)
 153                   (setf (documentation ',name 'structure) new4)
 154                   (assert-documentation ',name 'structure new4)))))))
 155
 156   (with-test (:name (documentation class standard-class))
 157     (do-class foo "FOO"))
 158
 159   (with-test (:name (documentation class sb-mop:funcallable-standard-class))
 160     (do-class documentation.funcallable-instance "FEZ"))
 161
 162   (with-test (:name (documentation struct 1))
 163     (do-class bar "BAR" t))
 164
 165   (with-test (:name (documentation condition))
 166     (do-class baz "BAZ")))
 167
 168 (defclass documentation-metaclass (standard-class)
 169   ()
 170   (:documentation "metaclass with methods on DOCUMENTATION."))
 171
 172 (defmethod documentation ((thing documentation-metaclass)
 173                           (doc-type (eql 't)))
 174   (sb-int:awhen (call-next-method)
 175     (concatenate 'string ":" sb-int:it)))
 176
 177 (defmethod (setf documentation) (new-value
 178                                  (thing documentation-metaclass)
 179                                  (doc-type (eql 't)))
 180   (call-next-method (when new-value
 181                       (substitute #\! #\. new-value))
 182                     thing doc-type))
 183
 184 (defmethod sb-mop:validate-superclass ((class documentation-metaclass)
 185                                        (superclass standard-class))
 186   t)
 187
 188 (defclass documentation-class ()
 189   ()
 190   (:metaclass documentation-metaclass)
 191   (:documentation "normal"))
 192
 193 (with-test (:name (documentation :non-stanadard :metaclass))
 194   (flet ((check (expected class-name)
 195            (let ((class (find-class class-name)))
 196              (assert-documentation class-name 'type expected)
 197              (assert-documentation class 'type expected)
 198              (assert-documentation class t expected))))
 199     ;; Make sure methods specialized on the metaclass are not bypassed
 200     ;; when retrieving and modifying class documentation.
 201     (check ":normal" 'documentation-class)
 202     (setf (documentation 'documentation-class 'type) "2.")
 203     (check ":2!" 'documentation-class)
 204     (setf (documentation 'documentation-class 'type) nil)
 205     (check nil 'documentation-class)
 206
 207     ;; Sanity check: make sure the metaclass has its own documentation
 208     ;; and is not affected by the above modifications.
 209     (check "metaclass with methods on DOCUMENTATION."
 210            'documentation-metaclass)))
 211
 212 (defstruct (frob (:type vector)) "FROB")
 213
 214 (with-test (:name (documentation struct 2))
 215   (assert-documentation 'frob 'structure "FROB")
 216   (setf (documentation 'frob 'structure) "NEW5")
 217   (assert-documentation 'frob 'structure "NEW5"))
 218
 219 (deftype quux ()
 220   "QUUX"
 221   't)
 222
 223 (with-test (:name (documentation type))
 224   (assert-documentation 'quux 'type "QUUX")
 225   (setf (documentation 'quux 'type) "NEW4")
 226   (assert-documentation 'quux 'type "NEW4"))
 227
 228 (define-compiler-macro cmacro (x)
 229   "compiler macro"
 230   x)
 231
 232 (define-compiler-macro (setf cmacro) (y x)
 233   "setf compiler macro"
 234   (declare (ignore x))
 235   y)
 236
 237 (with-test (:name (documentation compiler-macro))
 238   (assert-documentation 'cmacro 'compiler-macro "compiler macro")
 239   (assert-documentation '(setf cmacro) 'compiler-macro "setf compiler macro"))
 240
 241 (defun (setf documentation.setf) (x)
 242   "(setf foo) documentation"
 243   x)
 244
 245 (with-test (:name (documentation function setf))
 246   (flet ((expect (documentation)
 247            (assert-documentation
 248             '(setf documentation.setf) 'function documentation)
 249            (assert-documentation
 250             #'(setf documentation.setf) 'function documentation)
 251            (assert-documentation
 252             #'(setf documentation.setf) t documentation)))
 253     (expect "(setf foo) documentation")
 254     ;; The original test checked this twice. No idea why.
 255     (expect "(setf foo) documentation")
 256
 257     ;; Modification
 258     (setf (documentation '(setf documentation.setf) 'function)
 259           "(setf bar) documentation")
 260     (expect "(setf bar) documentation")
 261
 262     (setf (documentation #'(setf documentation.setf) 'function)
 263           "(setf baz) documentation")
 264     (expect "(setf baz) documentation")
 265
 266     (setf (documentation #'(setf documentation.setf) t)
 267           "(setf fez) documentation")
 268     (expect "(setf fez) documentation")))
 269
 270 (with-test (:name (documentation lambda))
 271   (let ((f (lambda () "aos the zos" t))
 272         (g (sb-int:named-lambda fii () "zoot the fruit" t)))
 273     (dolist (doc-type '(t function))
 274       (assert-documentation f doc-type "aos the zos")
 275       (assert-documentation g doc-type "zoot the fruit"))
 276     (setf (documentation f t) "fire")
 277     (assert-documentation f t "fire")
 278     (assert-documentation g t "zoot the fruit")))
 279
 280 (with-test (:name (documentation flet))
 281   (assert
 282    (string= (documentation
 283              (flet ((quux (x)
 284                       "this is FLET quux"
 285                       (/ x 2)))
 286                #'quux)
 287              t)
 288             "this is FLET quux")))
 289
 290 (with-test (:name (documentation labels))
 291   (assert
 292    (string= (documentation
 293              (labels ((rec (x)
 294                         "this is LABELS rec"
 295                         (if (plusp x)
 296                             (* x (rec (1- x)))
 297                             1)))
 298                #'rec)
 299              t)
 300             "this is LABELS rec")))
 301
 302 (let ((x 1))
 303   (defun docfoo (y)
 304     "bar"
 305     (incf x y)))
 306
 307 (with-test (:name (documentation :closure))
 308   (assert-documentation 'docfoo 'function "bar")
 309   (assert (string= (setf (documentation 'docfoo 'function) "baz") "baz"))
 310   (assert-documentation 'docfoo 'function "baz")
 311   (assert-documentation #'docfoo t "baz")
 312   (assert (string= (setf (documentation #'docfoo t) "zot") "zot"))
 313   (assert-documentation #'docfoo t "zot")
 314   (assert-documentation 'docfoo 'function "zot")
 315   (assert (not (setf (documentation 'docfoo 'function) nil)))
 316   (assert-documentation 'docfoo 'function nil))
 317
 318 (with-test (:name (documentation :built-in-macro) :skipped-on (not :sb-doc))
 319   (assert (documentation 'trace 'function)))
 320
 321 (with-test (:name (documentation :built-in-function) :skipped-on (not :sb-doc))
 322   (assert (documentation 'cons 'function)))
 323
 324 (defvar documentation.variable nil
 325   "foo variable documentation")
 326
 327 (with-test (:name (documentation variable))
 328   (assert-documentation 'documentation.variable 'variable
 329                         "foo variable documentation")
 330   (setf (documentation 'documentation.variable 'variable)
 331         "baz variable documentation")
 332   (assert-documentation 'documentation.variable 'variable
 333                         "baz variable documentation"))
 334
 335 (with-test (:name (documentation :mismatch-for-function))
 336   (defun test ()
 337     "X"
 338     nil)
 339   (setf (symbol-function 'test2) #'test)
 340   (setf (documentation 'test 'function) "Y")
 341   (assert (equal (documentation #'test t)
 342                  (documentation 'test 'function)))
 343   (setf (documentation 'test2 'function) "Z")
 344   (assert (not
 345            (equal (documentation 'test 'function)
 346                   (documentation 'test2 'function)))))
 347
 348 (with-test (:name (documentation setf :on nil))
 349   (assert
 350    (handler-case
 351        (assert (equal (setf (documentation nil 'function) "foo") "foo"))
 352      (style-warning () t)
 353      (:no-error (x)
 354        (declare (ignore x))
 355        nil))))
 356
 357 (with-test (:name (describe generic-function :assumed-type))
 358   ;; Signalled an error at one point
 359   (let ((fun (checked-compile '(lambda ()
 360                                  (flet ((zoo () (gogo)))
 361                                    (defmethod gogo () nil)
 362                                    (describe 'gogo)))
 363                               :allow-style-warnings t)))
 364     (handler-bind ((warning #'muffle-warning)) ; implicit gf
 365       (silently (funcall fun)))))
 366
 367 (defmacro bug-643958-test ()
 368   "foo"
 369   :ding!)
 370
 371 (with-test (:name :bug-643958)
 372   (assert (equal "foo" (documentation 'bug-643958-test 'function)))
 373   (setf (documentation 'bug-643958-test 'function) "bar")
 374   (assert (equal "bar" (documentation 'bug-643958-test 'function))))
 375
 376 (with-test (:name (:endianness :in *features*))
 377   (assert
 378    (or (member :big-endian *features*)
 379        (member :little-endian *features*))))
 380 \f
 381 (with-test (:name (apropos :inherited :bug-1364413))
 382   (let* ((package (make-package "BUGGALO" :use nil))
 383          (symbol (intern "BUGGALO" package)))
 384     (export (list symbol) package)
 385     (let ((inherits (make-package "BUGGALO-INHERITS" :use (list package))))
 386       (assert (= (length (apropos-list "BUGGALO" package)) 1))
 387       (assert (= (length (apropos-list "BUGGALO" inherits)) 1))
 388       (delete-package inherits))
 389     (delete-package package)))
 390
 391 (with-test (:name (apropos :inherited :external-only :bug-1364413))
 392   (let* ((package (make-package "BUGGALO" :use nil))
 393          (symbol (intern "BUGGALO" package)))
 394     (export (list symbol) package)
 395     (let ((inherits (make-package "BUGGALO-INHERITS" :use (list package))))
 396       (assert (= (length (apropos-list "BUGGALO" package t)) 1))
 397       (assert (= (length (apropos-list "BUGGALO" inherits t)) 0))
 398       (delete-package inherits))
 399     (delete-package package)))
 400
 401 (with-test (:name (apropos :once-only))
 402   (assert (= (length (apropos-list "UPDATE-INSTANCE-FOR-REDEFINED-CLASS")) 1)))
 403
 404 (defgeneric gf-arglist-1 (x &key y))
 405 (defmethod gf-arglist-1 (x &key (y nil) (z nil z-p))
 406   (list x y z z-p))
 407
 408 (defgeneric gf-arglist-2 (x &key y))
 409 (defmethod gf-arglist-2 ((x integer) &key (y nil) ((z f) nil z-p)) (list x y f z-p))
 410 (defmethod gf-arglist-2 ((x string) &key (y nil) ((z w) nil z-p)) (list x y w z-p))
 411
 412 (defgeneric gf-arglist-3 (x &key ((:y y))))
 413
 414 (defgeneric gf-arglist-4 (x &key ((:y z))))
 415
 416 (defgeneric gf-arglist-5 (x &key y))
 417 (defmethod gf-arglist-5 ((x integer) &key z &allow-other-keys) (list x z))
 418
 419 (with-test (:name (:generic-function-pretty-arglist 1))
 420   (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-1)
 421                  '(x &key y z))))
 422 (with-test (:name (:generic-function-pretty-arglist 2))
 423   (assert (or (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-2)
 424                      '(x &key y ((z w))))
 425               (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-2)
 426                      '(x &key y ((z f)))))))
 427 (with-test (:name (:generic-function-pretty-arglist 3))
 428   (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-3)
 429                  '(x &key y))))
 430 (with-test (:name (:generic-function-pretty-arglist 4))
 431   (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-4)
 432                  '(x &key ((:y z))))))
 433 (with-test (:name (:generic-function-pretty-arglist 5))
 434   (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-5)
 435                  '(x &key y z &allow-other-keys))))
 436 \f
 437 (defgeneric traced-gf (x))
 438 (defmethod traced-gf (x) (1+ x))
 439
 440 (with-test (:name (trace generic-function))
 441   (assert (= (traced-gf 3) 4))
 442   (trace traced-gf)
 443   (let ((output (with-output-to-string (*trace-output*)
 444                   (assert (= (traced-gf 3) 4)))))
 445     (assert (> (length output) 0))
 446     (assert (search "0: (TRACED-GF 3)" output))
 447     (assert (search "0: TRACED-GF returned 4" output)))
 448   (assert (typep #'traced-gf 'standard-generic-function))
 449   (untrace traced-gf)
 450   (let ((output (with-output-to-string (*trace-output*)
 451                   (assert (= (traced-gf 3) 4)))))
 452     (assert (= (length output) 0))))
 453
 454 (untrace traced-gf)
 455 (with-test (:name (trace generic-function :methods t))
 456   (trace :methods t traced-gf)
 457   (let ((output (with-output-to-string (*trace-output*)
 458                   (assert (= (traced-gf 4) 5)))))
 459     (assert (> (length output) 0))
 460     (assert (search "0: (TRACED-GF 4)" output))
 461     (assert (search "0: TRACED-GF returned 5" output))
 462     (assert (search "1: ((METHOD TRACED-GF (T)) 4)" output))
 463     (assert (search "1: (METHOD TRACED-GF (T)) returned 5" output)))
 464   (untrace traced-gf)
 465   (let ((output (with-output-to-string (*trace-output*)
 466                   (assert (= (traced-gf 3) 4)))))
 467     (assert (= (length output) 0))))
 468
 469 (defmethod traced-gf :before (x) :before)
 470 (defmethod traced-gf :after ((x integer)) :after)
 471
 472 (untrace traced-gf)
 473 (with-test (:name (trace generic-function :methods :combined))
 474   (trace :methods t traced-gf)
 475   (let ((output (with-output-to-string (*trace-output*)
 476                   (assert (= (traced-gf 5) 6)))))
 477     (assert (> (length output) 0))
 478     (assert (search "0: (TRACED-GF 5)" output))
 479     (assert (search "0: TRACED-GF returned 6" output))
 480     (assert (search "1: ((SB-PCL::COMBINED-METHOD TRACED-GF) 5)" output))
 481     (assert (search "1: (SB-PCL::COMBINED-METHOD TRACED-GF) returned 6" output))
 482     (assert (search "2: ((METHOD TRACED-GF :BEFORE (T)) 5)" output))
 483     (assert (search "2: (METHOD TRACED-GF :BEFORE (T)) returned :BEFORE" output))
 484     (assert (search "2: ((METHOD TRACED-GF :AFTER (INTEGER)) 5)" output))
 485     (assert (search "2: (METHOD TRACED-GF :AFTER (INTEGER)) returned :AFTER" output))
 486     (assert (search "2: ((METHOD TRACED-GF (T)) 5)" output))
 487     (assert (search "2: (METHOD TRACED-GF (T)) returned 6" output)))
 488   (untrace traced-gf)
 489   (let ((output (with-output-to-string (*trace-output*)
 490                   (assert (= (traced-gf 3) 4)))))
 491     (assert (= (length output) 0))))
 492
 493 (let* ((mf (lambda (args nms)
 494              (declare (ignore nms))
 495              (* 2 (car args))))
 496        (m (make-instance 'standard-method
 497                          :specializers (list (find-class 'integer))
 498                          :qualifiers nil
 499                          :lambda-list '(x)
 500                          :function mf)))
 501   (add-method #'traced-gf m))
 502
 503 (untrace traced-gf)
 504 (with-test (:name (trace generic-function :methods :method-function))
 505   (trace :methods t traced-gf)
 506   (let ((output (with-output-to-string (*trace-output*)
 507                   (assert (= (traced-gf 5) 10)))))
 508     (assert (> (length output) 0))
 509     (assert (search "0: (TRACED-GF 5)" output))
 510     (assert (search "0: TRACED-GF returned 10" output))
 511     (assert (search "1: ((SB-PCL::COMBINED-METHOD TRACED-GF) 5)" output))
 512     (assert (search "1: (SB-PCL::COMBINED-METHOD TRACED-GF) returned 10" output))
 513     (assert (search "2: ((METHOD TRACED-GF :BEFORE (T)) 5)" output))
 514     (assert (search "2: (METHOD TRACED-GF :BEFORE (T)) returned :BEFORE" output))
 515     (assert (search "2: ((METHOD TRACED-GF :AFTER (INTEGER)) 5)" output))
 516     (assert (search "2: (METHOD TRACED-GF :AFTER (INTEGER)) returned :AFTER" output))
 517     (assert (search "2: ((METHOD TRACED-GF (INTEGER)) 5)" output))
 518     (assert (search "2: (METHOD TRACED-GF (INTEGER)) returned 10" output)))
 519   (untrace traced-gf)
 520   (let ((output (with-output-to-string (*trace-output*)
 521                   (assert (= (traced-gf 5) 10)))))
 522     (assert (= (length output) 0))))
 523
 524 (with-test (:name :undefined-fun-macro-error)
 525   (assert (search "is a macro" (princ-to-string (make-condition 'undefined-function :name 'cond)))))
 526
 527 (defun testme (a b) (values "nice" (+ a b)))
 528 (compile 'testme)
 529 (defparameter trace-this-f1 #'testme)
 530 (sb-int:encapsulate-funobj trace-this-f1 'testme)
 531
 532 (defun funky (a b c) (lambda (z) (values "nice" a b (+ (incf a) (decf c) z))))
 533 (compile 'funky)
 534 (defparameter trace-this-f2 (funky 10 'wat 19))
 535 (setf (symbol-function 'funky-closure) trace-this-f2)
 536 (sb-int:encapsulate-funobj trace-this-f2 'trace-this-f2)
 537
 538 (with-test (:name :trace-funobj-encapsulation)
 539   (assert (search "returned \"nice\""
 540                   (with-output-to-string (*trace-output*) (funcall trace-this-f1 1 2))))
 541   (assert (search "returned \"nice\""
 542                   (with-output-to-string (*trace-output*) (testme 3 4))))
 543   (assert (search "returned \"nice\""
 544                   (with-output-to-string (*trace-output*) (funcall trace-this-f2 1))))
 545   (assert (search "returned \"nice\""
 546                   (with-output-to-string (*trace-output*) (funky-closure 5)))))
 547
 548 ;;; https://bugs.launchpad.net/sbcl/+bug/1850531
 549 (with-test (:name :describe-function-not-named-by-designator)
 550   (describe (formatter "~&~A~A") (make-broadcast-stream))) ; should not crash
 551
 552 (defun test-intercepted-load (arg) (apply #'load arg (list :foo :bar :allow-other-keys t)))
 553 (compile 'test-intercepted-load)
 554 (sb-int:encapsulate 'load 'interceptor
 555  (compile nil '(lambda (realfun pathname &rest things)
 556                 (if (eq pathname :testme)
 557                     :yes
 558                     (apply realfun pathname things)))))
 559
 560 (with-test (:name :load-encapsulatable)
 561   (assert (eq (test-intercepted-load :testme) :yes)))
 562
 563 ;;;; success