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/eb415b6d325669213ddb5946...