X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Finterface.impure.lisp;h=60795ad665ce27712d40ea73212404951dee0a6c;hb=35f870eecfcaaba496d54e0f290b09e63884f74c;hp=ea21552ecb74f32016bc11c429e10f0ecd3c26b3;hpb=ed3295bc583cd14104130441e9ff1ad40fa5e484;p=sbcl.git

diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp
index ea21552..60795ad 100644
--- a/tests/interface.impure.lisp
+++ b/tests/interface.impure.lisp
@@ -34,6 +34,49 @@
 
 (let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
 (disassemble 'disassemble-closure)
+
+#+sb-eval
+(progn
+  ;; Nor should it fail on interpreted functions
+  (let ((sb-ext:*evaluator-mode* :interpret))
+    (eval `(defun disassemble-eval (x) x))
+    (disassemble 'disassemble-eval))
+
+  ;; disassemble-eval should still be an interpreted function.
+  ;; clhs disassemble: "(If that function is an interpreted function,
+  ;; it is first compiled but the result of this implicit compilation
+  ;; is not installed.)"
+  (assert (sb-eval:interpreted-function-p #'disassemble-eval)))
+
+;; nor should it fail on generic functions or other funcallable instances
+(defgeneric disassemble-generic (x))
+(disassemble 'disassemble-generic)
+(let ((fin (sb-mop:make-instance 'sb-mop:funcallable-standard-object)))
+  (disassemble fin))
+
+;;; while we're at it, much the same applies to
+;;; FUNCTION-LAMBDA-EXPRESSION:
+(defun fle-fun (x) x)
+(function-lambda-expression #'fle-fun)
+
+(let ((x 1)) (defun fle-closure (y) (if y (setq x y) x)))
+(function-lambda-expression #'fle-closure)
+
+#+sb-eval
+(progn
+  ;; Nor should it fail on interpreted functions
+  (let ((sb-ext:*evaluator-mode* :interpret))
+    (eval `(defun fle-eval (x) x))
+    (function-lambda-expression #'fle-eval))
+
+  ;; fle-eval should still be an interpreted function.
+  (assert (sb-eval:interpreted-function-p #'fle-eval)))
+
+;; nor should it fail on generic functions or other funcallable instances
+(defgeneric fle-generic (x))
+(function-lambda-expression #'fle-generic)
+(let ((fin (sb-mop:make-instance 'sb-mop:funcallable-standard-object)))
+  (function-lambda-expression fin))
 
 ;;; support for DESCRIBE tests
 (defstruct to-be-described a b)
@@ -79,4 +122,51 @@
       (error "misbehavior in DESCRIBE of ~S" i))))
 
 
+;;; Tests of documentation on types and classes
+(defclass foo ()
+  ()
+  (:documentation "FOO"))
+(defstruct bar "BAR")
+(define-condition baz ()
+  ()
+  (:documentation "BAZ"))
+(deftype quux ()
+  "QUUX"
+  't)
+(defstruct (frob (:type vector)) "FROB")
+(macrolet
+    ((do-class (name expected &optional structurep)
+       `(progn
+         (assert (string= (documentation ',name 'type) ,expected))
+         (assert (string= (documentation (find-class ',name) 'type) ,expected))
+         (assert (string= (documentation (find-class ',name) 't) ,expected))
+         ,@(when structurep
+            `((assert (string= (documentation ',name 'structure) ,expected))))
+         (let ((new1 (symbol-name (gensym "NEW1")))
+               (new2 (symbol-name (gensym "NEW2")))
+               (new3 (symbol-name (gensym "NEW3")))
+               (new4 (symbol-name (gensym "NEW4"))))
+           (declare (ignorable new4))
+           (setf (documentation ',name 'type) new1)
+           (assert (string= (documentation (find-class ',name) 'type) new1))
+           (setf (documentation (find-class ',name) 'type) new2)
+           (assert (string= (documentation (find-class ',name) 't) new2))
+           (setf (documentation (find-class ',name) 't) new3)
+           (assert (string= (documentation ',name 'type) new3))
+           ,@(when structurep
+              `((assert (string= (documentation ',name 'structure) new3))
+                (setf (documentation ',name 'structure) new4)
+                (assert (string= (documentation ',name 'structure) new4))))))))
+  (do-class foo "FOO")
+  (do-class bar "BAR" t)
+  (do-class baz "BAZ"))
+
+(assert (string= (documentation 'quux 'type) "QUUX"))
+(setf (documentation 'quux 'type) "NEW4")
+(assert (string= (documentation 'quux 'type) "NEW4"))
+
+(assert (string= (documentation 'frob 'structure) "FROB"))
+(setf (documentation 'frob 'structure) "NEW5")
+(assert (string= (documentation 'frob 'structure) "NEW5"))
+
 ;;;; success