- (flet ((try-cmucl-random-doc (x doc-type)
- (declare (symbol doc-type))
- (cdr (assoc doc-type
- (values (info :random-documentation :stuff x))))))
- (case doc-type
- (variable
- (typecase x
- (symbol (values (info :variable :documentation x)))))
- (function
- (cond ((functionp x)
- (%fun-doc x))
- ((legal-fun-name-p x)
- ;; FIXME: Is it really right to make
- ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
- ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
- ;; did, so we do it, but I'm not sure it's what ANSI wants.
- (values (info :function :documentation
- (fun-name-block-name x))))))
- (structure
- (typecase x
- (symbol (cond
- ((eq (info :type :kind x) :instance)
- (values (info :type :documentation x)))
- ((info :typed-structure :info x)
- (values (info :typed-structure :documentation x)))))))
- (type
- (typecase x
- (structure-class (values (info :type :documentation (class-name x))))
- (t (and (typep x 'symbol) (values (info :type :documentation x))))))
- (setf (values (info :setf :documentation x)))
- ((t)
- (typecase x
- (function (%fun-doc x))
- (package (package-doc-string x))
- (structure-class (values (info :type :documentation (class-name x))))
- (symbol (try-cmucl-random-doc x doc-type))))
- (t
- (typecase x
- ;; FIXME: This code comes from CMU CL, but
- ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
- ;; in CMU CL. Perhaps it could be defined by analogy with the
- ;; corresponding SETF FDOCUMENTATION code.
- (symbol (try-cmucl-random-doc x doc-type)))))))
+ (case doc-type
+ (variable
+ (typecase x
+ (symbol (values (info :variable :documentation x)))))
+ (function
+ (cond ((functionp x)
+ (%fun-doc x))
+ ((legal-fun-name-p x)
+ (values (info :function :documentation x)))))
+ (structure
+ (typecase x
+ (symbol (cond
+ ((eq (info :type :kind x) :instance)
+ (values (info :type :documentation x)))
+ ((info :typed-structure :info x)
+ (values (info :typed-structure :documentation x)))))))
+ (type
+ (typecase x
+ (structure-class (values (info :type :documentation (class-name x))))
+ (t (and (typep x 'symbol) (values (info :type :documentation x))))))
+ (setf (values (info :setf :documentation x)))
+ ((t)
+ (typecase x
+ (function (%fun-doc x))
+ (package (package-doc-string x))
+ (structure-class (values (info :type :documentation (class-name x))))
+ ((or symbol cons)
+ (random-documentation x doc-type))))
+ (t
+ (when (typep x '(or symbol cons))
+ (random-documentation x doc-type)))))
+