[Git][cmucl/cmucl][issue-120-software-type-in-c] Move documentation function from misc.lisp to misc-doc.lisp
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Wed Aug 31 00:04:34 UTC 2022
Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl
Commits:
eb415b6d by Raymond Toy at 2022-08-30T17:04:01-07:00
Move documentation function from misc.lisp to misc-doc.lisp
pclcom.lisp loads misc to get the documentation functions. This
causes a problem when building cmucl with the new os_software_type
function because it's undefined on the first build because we haven't
defined it yet.
To simplify things, move the documentation functions from misc.lisp to
misc-doc.lisp so that pclcom can just load misc-doc to get just what
is needed.
This allows the build to proceed with os_software_type being undefined
in the first build.
- - - - -
5 changed files:
- + src/code/misc-doc.lisp
- src/code/misc.lisp
- src/tools/pclcom.lisp
- src/tools/worldbuild.lisp
- src/tools/worldcom.lisp
Changes:
=====================================
src/code/misc-doc.lisp
=====================================
@@ -0,0 +1,119 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+ "$Header: src/code/misc.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Documentation functions. Needed by pclcom.lisp
+(in-package "LISP")
+(intl:textdomain "cmucl")
+
+(export '(documentation))
+
+;;; cobbled from stuff in describe.lisp.
+(defun function-doc (x)
+ (let ((name
+ (case (kernel:get-type x)
+ (#.vm:closure-header-type
+ (kernel:%function-name (%closure-function x)))
+ ((#.vm:function-header-type #.vm:closure-function-header-type)
+ (kernel:%function-name x))
+ (#.vm:funcallable-instance-header-type
+ (typecase x
+ (kernel:byte-function
+ (c::byte-function-name x))
+ (kernel:byte-closure
+ (c::byte-function-name (byte-closure-function x)))
+ (eval:interpreted-function
+ (multiple-value-bind
+ (exp closure-p dname)
+ (eval:interpreted-function-lambda-expression x)
+ (declare (ignore exp closure-p))
+ dname))
+ (t ;; funcallable-instance
+ (kernel:%function-name
+ (kernel:funcallable-instance-function x))))))))
+ (when (and name (typep name '(or symbol cons)))
+ (values (info function documentation name)))))
+
+(defun documentation (x doc-type)
+ "Returns the documentation string of Doc-Type for X, or NIL if
+ none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
+ SETF, and T."
+ (flet (;; CMUCL random-documentation.
+ (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
+ (typecase x
+ (symbol (values (info function documentation x)))
+ (function (function-doc x))
+ (list ;; Must be '(setf symbol)
+ (values (info function documentation (cadr x))))))
+ (structure
+ (typecase x
+ (symbol (when (eq (info type kind x) :instance)
+ (values (info type documentation x))))))
+ (type
+ (typecase x
+ (kernel::structure-class (values (info type documentation (%class-name x))))
+ (t (and (typep x 'symbol) (values (info type documentation x))))))
+ (setf (info setf documentation x))
+ ((t)
+ (typecase x
+ (function (function-doc x))
+ (package (package-doc-string x))
+ (kernel::structure-class (values (info type documentation (%class-name x))))
+ (symbol (try-cmucl-random-doc x doc-type))))
+ (t
+ (typecase x
+ (symbol (try-cmucl-random-doc x doc-type)))))))
+
+(defun (setf documentation) (string name doc-type)
+ #-no-docstrings
+ (case doc-type
+ (variable
+ #+nil
+ (when string
+ (%primitive print "Set variable text domain")
+ (%primitive print (symbol-name name))
+ (%primitive print intl::*default-domain*))
+ (setf (info variable textdomain name) intl::*default-domain*)
+ (setf (info variable documentation name) string))
+ (function
+ #+nil
+ (when intl::*default-domain*
+ (%primitive print "Set function text domain")
+ (%primitive print (symbol-name name))
+ (%primitive print intl::*default-domain*))
+ (setf (info function textdomain name) intl::*default-domain*)
+ (setf (info function documentation name) string))
+ (structure
+ (unless (eq (info type kind name) :instance)
+ (error (intl:gettext "~S is not the name of a structure type.") name))
+ (setf (info type textdomain name) intl::*default-domain*)
+ (setf (info type documentation name) string))
+ (type
+ (setf (info type textdomain name) intl::*default-domain*)
+ (setf (info type documentation name) string))
+ (setf
+ (setf (info setf textdomain name) intl::*default-domain*)
+ (setf (info setf documentation name) string))
+ (t
+ (let ((pair (assoc doc-type (info random-documentation stuff name))))
+ (if pair
+ (setf (cdr pair) string)
+ (push (cons doc-type string)
+ (info random-documentation stuff name))))))
+ string)
+
=====================================
src/code/misc.lisp
=====================================
@@ -17,7 +17,7 @@
(in-package "LISP")
(intl:textdomain "cmucl")
-(export '(documentation *features* variable room
+(export '(*features* variable room
lisp-implementation-type lisp-implementation-version machine-type
machine-version machine-instance software-type software-version
short-site-name long-site-name dribble compiler-macro))
=====================================
src/tools/pclcom.lisp
=====================================
@@ -12,7 +12,7 @@
(when (find-package "PCL")
;; Load the lisp:documentation functions.
- (load "target:code/misc")
+ (load "target:code/misc-doc")
;;
;; Blow away make-instance optimizer so that it doesn't confuse
=====================================
src/tools/worldbuild.lisp
=====================================
@@ -113,6 +113,7 @@
"target:code/string"
"target:code/mipsstrops"
"target:code/misc"
+ "target:code/misc-doc"
"target:code/dfixnum"
,@(unless (c:backend-featurep :gengc)
'("target:code/gc"))
=====================================
src/tools/worldcom.lisp
=====================================
@@ -211,6 +211,7 @@
(comf "target:code/unidata")
(comf "target:code/char")
(comf "target:code/misc")
+(comf "target:code/misc-doc")
(comf "target:code/extensions" :byte-compile t)
(comf "target:code/commandline")
(comf "target:code/env-access")
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/eb415b6d325669213ddb59464d8895e039b82d2d
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/eb415b6d325669213ddb59464d8895e039b82d2d
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20220831/496d8190/attachment-0001.html>
More information about the cmucl-cvs
mailing list