[Git][cmucl/cmucl][master] 2 commits: Address #120: Move misc doc stuff to misc-doc.lisp
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Thu Mar 23 13:46:18 UTC 2023
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
927c2ae9 by Raymond Toy at 2023-03-23T13:46:03+00:00
Address #120: Move misc doc stuff to misc-doc.lisp
- - - - -
c26f8ede by Raymond Toy at 2023-03-23T13:46:05+00:00
Merge branch 'issue-120-move-misc-first' into 'master'
Address #120: Move misc doc stuff to misc-doc.lisp
Closes #120
See merge request cmucl/cmucl!133
- - - - -
6 changed files:
- + src/code/misc-doc.lisp
- src/code/misc.lisp
- src/i18n/locale/cmucl.pot
- 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
=====================================
@@ -30,109 +30,6 @@
(in-package "LISP")
-;;; 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)
-
-
;;; Register various Lisp features
#+sparc-v7
(sys:register-lisp-runtime-feature :sparc-v7)
=====================================
src/i18n/locale/cmucl.pot
=====================================
@@ -5605,17 +5605,6 @@ msgid ""
" NIL if no such character exists."
msgstr ""
-#: src/code/misc.lisp
-msgid ""
-"Returns the documentation string of Doc-Type for X, or NIL if\n"
-" none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,\n"
-" SETF, and T."
-msgstr ""
-
-#: src/code/misc.lisp
-msgid "~S is not the name of a structure type."
-msgstr ""
-
#: src/code/misc.lisp
msgid ""
"If X is an atom, see if it is present in *FEATURES*. Also\n"
@@ -5701,6 +5690,17 @@ msgid ""
" disassemble."
msgstr ""
+#: src/code/misc-doc.lisp
+msgid ""
+"Returns the documentation string of Doc-Type for X, or NIL if\n"
+" none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,\n"
+" SETF, and T."
+msgstr ""
+
+#: src/code/misc-doc.lisp
+msgid "~S is not the name of a structure type."
+msgstr ""
+
#: src/code/extensions.lisp
msgid ""
"This function can be used as the default value for keyword arguments that\n"
=====================================
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/-/compare/b758b5aaed45e7e38853782d9101229a3280abe4...c26f8ede5b0828a2db337fc372ab09d7b49fd5e1
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b758b5aaed45e7e38853782d9101229a3280abe4...c26f8ede5b0828a2db337fc372ab09d7b49fd5e1
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/20230323/afe5f434/attachment-0001.html>
More information about the cmucl-cvs
mailing list