CMUCL commit: intl-branch src (code/misc.lisp pcl/cmucl-documentation.lisp)
Raymond Toy
rtoy at common-lisp.net
Mon Feb 8 17:41:41 CET 2010
Date: Monday, February 8, 2010 @ 11:41:41
Author: rtoy
Path: /project/cmucl/cvsroot/src
Tag: intl-branch
Modified: code/misc.lisp pcl/cmucl-documentation.lisp
When setting documentation strings, save the default-domain in the
textdomain info-type so we know what domain to use with docstrings.
------------------------------+
code/misc.lisp | 30 +++++++++++++++++++++++++-----
pcl/cmucl-documentation.lisp | 36 +++++++++++++++++++++++++++++++-----
2 files changed, 56 insertions(+), 10 deletions(-)
Index: src/code/misc.lisp
diff -u src/code/misc.lisp:1.38 src/code/misc.lisp:1.38.8.1
--- src/code/misc.lisp:1.38 Wed Sep 9 11:51:27 2009
+++ src/code/misc.lisp Mon Feb 8 11:41:41 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/misc.lisp,v 1.38 2009-09-09 15:51:27 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/misc.lisp,v 1.38.8.1 2010-02-08 16:41:41 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -15,6 +15,8 @@
;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
;;;
(in-package "LISP")
+(intl:textdomain "cmucl")
+
(export '(documentation *features* variable room
lisp-implementation-type lisp-implementation-version machine-type
machine-version machine-instance software-type software-version
@@ -95,14 +97,32 @@
(defun (setf documentation) (string name doc-type)
#-no-docstrings
(case doc-type
- (variable (setf (info variable documentation name) string))
- (function (setf (info function documentation name) string))
+ (variable
+ (when intl::*default-domain*
+ (%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 "~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))
- (type (setf (info type documentation name) string))
- (setf (setf (info setf 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
Index: src/pcl/cmucl-documentation.lisp
diff -u src/pcl/cmucl-documentation.lisp:1.16 src/pcl/cmucl-documentation.lisp:1.16.32.1
--- src/pcl/cmucl-documentation.lisp:1.16 Thu Dec 1 12:08:26 2005
+++ src/pcl/cmucl-documentation.lisp Mon Feb 8 11:41:41 2010
@@ -4,7 +4,7 @@
;;; the public domain, and is provided 'as is'.
(file-comment
- "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.16 2005-12-01 17:08:26 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.16.32.1 2010-02-08 16:41:41 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -45,20 +45,34 @@
(unless (valid-function-name-p x)
(simple-program-error "Invalid function name ~s" x))
(if (eq 'setf (cadr x))
- (setf (info setf documentation (cadr x)) new-value)
- (setf (info function documentation x) new-value))
+ (progn
+ (format t "Setting function ~S domain to ~A~%"
+ (cadr x) intl::*default-domain*)
+ (setf (info setf textdomain (cadr x)) intl::*default-domain*)
+ (setf (info setf documentation (cadr x)) new-value))
+ (progn
+ (setf (info function textdomain x) intl::*default-domain*)
+ (setf (info function documentation x) new-value)))
new-value)
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
+ (format t "Setting function ~S domain to ~A~%" x intl::*default-domain*)
+ (setf (info function textdomain x) intl::*default-domain*)
(setf (info function documentation x) new-value))
(defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function)))
+ (format t "Setting function ~S domain to ~A~%" x intl::*default-domain*)
+ (setf (info function textdomain x) intl::*default-domain*)
(setf (info function documentation x) new-value))
(defmethod (setf documentation) (new-value (x function) (doc-type (eql 't)))
+ (format t "Setting function ~S domain to ~A~%" x intl::*default-domain*)
+ (setf (info function textdomain x) intl::*default-domain*)
(setf (info function documentation x) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
+ (format t "Setting setf function ~S domain to ~A~%" x intl::*default-domain*)
+ (setf (info setf textdomain x) intl::*default-domain*)
(setf (info setf documentation x) new-value))
;;; Packages.
@@ -111,24 +125,32 @@
nil)))
(defmethod (setf documentation) (new-value (x kernel::structure-class) (doc-type (eql 't)))
+ (setf (info type textdomain (kernel:%class-name x)) intl::*default-domain*)
(setf (info type documentation (kernel:%class-name x)) new-value))
(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
+ (setf (info type textdomain x) intl::*default-domain*)
(setf (info type documentation (class-name x)) new-value))
(defmethod (setf documentation) (new-value (x kernel::structure-class) (doc-type (eql 'type)))
+ (setf (info type textdomain x) intl::*default-domain*)
(setf (info type documentation (kernel:%class-name x)) new-value))
(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
+ (setf (info type textdomain x) intl::*default-domain*)
(setf (info type documentation (class-name x)) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
(if (or (structure-type-p x) (condition-type-p x))
- (setf (info type documentation x) new-value)
+ (progn
+ (setf (info type textdomain x) intl::*default-domain*)
+ (setf (info type documentation x) new-value))
(let ((class (find-class x nil)))
(if class
(setf (plist-value class 'documentation) new-value)
- (setf (info type documentation x) new-value)))))
+ (progn
+ (setf (info type textdomain x) intl::*default-domain*)
+ (setf (info type documentation x) new-value))))))
#+nil
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'structure)))
@@ -138,8 +160,10 @@
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'structure)))
(cond ((eq (info type kind x) :instance)
+ (setf (info type textdomain x) intl::*default-domain*)
(setf (info type documentation x) new-value))
((info typed-structure info x)
+ (setf (info typed-structure textdomain x) intl::*default-domain*)
(setf (info typed-structure documentation x) new-value))
(t
(simple-program-error "~@<~S is not the name of a structure type.~@:>" x))))
@@ -149,6 +173,8 @@
(values (info variable documentation x)))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'variable)))
+ (format t "Setting variable ~S domain to ~A~%" x intl::*default-domain*)
+ (setf (info variable textdomain x) intl::*default-domain*)
(setf (info variable documentation x) new-value))
;;; Compiler macros
More information about the cmucl-commit
mailing list