Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

6 changed files:

Changes:

  • src/code/misc-doc.lisp
    1 
    +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
    2 
    +;;;
    3 
    +;;; **********************************************************************
    4 
    +;;; This code was written as part of the CMU Common Lisp project at
    5 
    +;;; Carnegie Mellon University, and has been placed in the public domain.
    6 
    +;;;
    7 
    +(ext:file-comment
    8 
    +  "$Header: src/code/misc.lisp $")
    9 
    +;;;
    10 
    +;;; **********************************************************************
    11 
    +;;;
    12 
    +;;; Documentation functions.  Needed by pclcom.lisp
    13 
    +(in-package "LISP")
    14 
    +(intl:textdomain "cmucl")
    15 
    +
    16 
    +(export '(documentation))
    17 
    +
    18 
    +;;; cobbled from stuff in describe.lisp.
    19 
    +(defun function-doc (x)
    20 
    +  (let ((name
    21 
    +	 (case (kernel:get-type x)
    22 
    +	   (#.vm:closure-header-type
    23 
    +	    (kernel:%function-name (%closure-function x)))
    24 
    +	   ((#.vm:function-header-type #.vm:closure-function-header-type)
    25 
    +	    (kernel:%function-name x))
    26 
    +	   (#.vm:funcallable-instance-header-type
    27 
    +	    (typecase x
    28 
    +	      (kernel:byte-function
    29 
    +	       (c::byte-function-name x))
    30 
    +	      (kernel:byte-closure
    31 
    +	       (c::byte-function-name (byte-closure-function x)))
    32 
    +	      (eval:interpreted-function
    33 
    +	       (multiple-value-bind
    34 
    +		     (exp closure-p dname)
    35 
    +		   (eval:interpreted-function-lambda-expression x)
    36 
    +		 (declare (ignore exp closure-p))
    37 
    +		 dname))
    38 
    +	      (t ;; funcallable-instance
    39 
    +	       (kernel:%function-name
    40 
    +		(kernel:funcallable-instance-function x))))))))
    41 
    +    (when (and name (typep name '(or symbol cons)))
    42 
    +      (values (info function documentation name)))))
    43 
    +
    44 
    +(defun documentation (x doc-type)
    45 
    +  "Returns the documentation string of Doc-Type for X, or NIL if
    46 
    +  none exists.  System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
    47 
    +  SETF, and T."
    48 
    +  (flet (;; CMUCL random-documentation.
    49 
    +	 (try-cmucl-random-doc (x doc-type)
    50 
    +	   (declare (symbol doc-type))
    51 
    +	   (cdr (assoc doc-type
    52 
    +		       (values (info random-documentation stuff x))))))
    53 
    +    (case doc-type
    54 
    +      (variable
    55 
    +       (typecase x
    56 
    +	 (symbol (values (info variable documentation x)))))
    57 
    +      (function
    58 
    +       (typecase x
    59 
    +	 (symbol (values (info function documentation x)))
    60 
    +	 (function (function-doc x))
    61 
    +	 (list ;; Must be '(setf symbol)
    62 
    +	  (values (info function documentation (cadr x))))))
    63 
    +      (structure
    64 
    +       (typecase x
    65 
    +	 (symbol (when (eq (info type kind x) :instance)
    66 
    +		   (values (info type documentation x))))))
    67 
    +      (type
    68 
    +       (typecase x
    69 
    +	 (kernel::structure-class (values (info type documentation (%class-name x))))
    70 
    +	 (t (and (typep x 'symbol) (values (info type documentation x))))))
    71 
    +      (setf (info setf documentation x))
    72 
    +      ((t)
    73 
    +       (typecase x
    74 
    +	 (function (function-doc x))
    75 
    +	 (package (package-doc-string x))
    76 
    +	 (kernel::structure-class (values (info type documentation (%class-name x))))
    77 
    +	 (symbol (try-cmucl-random-doc x doc-type))))
    78 
    +      (t
    79 
    +       (typecase x
    80 
    +	 (symbol (try-cmucl-random-doc x doc-type)))))))
    81 
    +
    82 
    +(defun (setf documentation) (string name doc-type)
    83 
    +  #-no-docstrings
    84 
    +  (case doc-type
    85 
    +    (variable
    86 
    +     #+nil
    87 
    +     (when string
    88 
    +       (%primitive print "Set variable text domain")
    89 
    +       (%primitive print (symbol-name name))
    90 
    +       (%primitive print intl::*default-domain*))
    91 
    +     (setf (info variable textdomain name) intl::*default-domain*)
    92 
    +     (setf (info variable documentation name) string))
    93 
    +    (function
    94 
    +     #+nil
    95 
    +     (when intl::*default-domain*
    96 
    +       (%primitive print "Set function text domain")
    97 
    +       (%primitive print (symbol-name name))
    98 
    +       (%primitive print intl::*default-domain*))
    99 
    +     (setf (info function textdomain name) intl::*default-domain*)
    100 
    +     (setf (info function documentation name) string))
    101 
    +    (structure
    102 
    +     (unless (eq (info type kind name) :instance)
    103 
    +       (error (intl:gettext "~S is not the name of a structure type.") name))
    104 
    +     (setf (info type textdomain name) intl::*default-domain*)
    105 
    +     (setf (info type documentation name) string))
    106 
    +    (type
    107 
    +     (setf (info type textdomain name) intl::*default-domain*)
    108 
    +     (setf (info type documentation name) string))
    109 
    +    (setf
    110 
    +     (setf (info setf textdomain name) intl::*default-domain*)
    111 
    +     (setf (info setf documentation name) string))
    112 
    +    (t
    113 
    +     (let ((pair (assoc doc-type (info random-documentation stuff name))))
    114 
    +       (if pair
    115 
    +	   (setf (cdr pair) string)
    116 
    +	   (push (cons doc-type string)
    117 
    +		 (info random-documentation stuff name))))))
    118 
    +  string)
    119 
    +

  • src/code/misc.lisp
    ... ... @@ -30,109 +30,6 @@
    30 30
    31 31 
     (in-package "LISP")
    32 32
    33 
    -;;; cobbled from stuff in describe.lisp.
    34 
    -(defun function-doc (x)
    35 
    -  (let ((name
    36 
    -	 (case (kernel:get-type x)
    37 
    -	   (#.vm:closure-header-type
    38 
    -	    (kernel:%function-name (%closure-function x)))
    39 
    -	   ((#.vm:function-header-type #.vm:closure-function-header-type)
    40 
    -	    (kernel:%function-name x))
    41 
    -	   (#.vm:funcallable-instance-header-type
    42 
    -	    (typecase x
    43 
    -	      (kernel:byte-function
    44 
    -	       (c::byte-function-name x))
    45 
    -	      (kernel:byte-closure
    46 
    -	       (c::byte-function-name (byte-closure-function x)))
    47 
    -	      (eval:interpreted-function
    48 
    -	       (multiple-value-bind
    49 
    -		     (exp closure-p dname)
    50 
    -		   (eval:interpreted-function-lambda-expression x)
    51 
    -		 (declare (ignore exp closure-p))
    52 
    -		 dname))
    53 
    -	      (t ;; funcallable-instance
    54 
    -	       (kernel:%function-name
    55 
    -		(kernel:funcallable-instance-function x))))))))
    56 
    -    (when (and name (typep name '(or symbol cons)))
    57 
    -      (values (info function documentation name)))))
    58 
    -
    59 
    -(defun documentation (x doc-type)
    60 
    -  "Returns the documentation string of Doc-Type for X, or NIL if
    61 
    -  none exists.  System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
    62 
    -  SETF, and T."
    63 
    -  (flet (;; CMUCL random-documentation.
    64 
    -	 (try-cmucl-random-doc (x doc-type)
    65 
    -	   (declare (symbol doc-type))
    66 
    -	   (cdr (assoc doc-type
    67 
    -		       (values (info random-documentation stuff x))))))
    68 
    -    (case doc-type
    69 
    -      (variable
    70 
    -       (typecase x
    71 
    -	 (symbol (values (info variable documentation x)))))
    72 
    -      (function
    73 
    -       (typecase x
    74 
    -	 (symbol (values (info function documentation x)))
    75 
    -	 (function (function-doc x))
    76 
    -	 (list ;; Must be '(setf symbol)
    77 
    -	  (values (info function documentation (cadr x))))))
    78 
    -      (structure
    79 
    -       (typecase x
    80 
    -	 (symbol (when (eq (info type kind x) :instance)
    81 
    -		   (values (info type documentation x))))))
    82 
    -      (type
    83 
    -       (typecase x
    84 
    -	 (kernel::structure-class (values (info type documentation (%class-name x))))
    85 
    -	 (t (and (typep x 'symbol) (values (info type documentation x))))))
    86 
    -      (setf (info setf documentation x))
    87 
    -      ((t)
    88 
    -       (typecase x
    89 
    -	 (function (function-doc x))
    90 
    -	 (package (package-doc-string x))
    91 
    -	 (kernel::structure-class (values (info type documentation (%class-name x))))
    92 
    -	 (symbol (try-cmucl-random-doc x doc-type))))
    93 
    -      (t
    94 
    -       (typecase x
    95 
    -	 (symbol (try-cmucl-random-doc x doc-type)))))))
    96 
    -
    97 
    -(defun (setf documentation) (string name doc-type)
    98 
    -  #-no-docstrings
    99 
    -  (case doc-type
    100 
    -    (variable
    101 
    -     #+nil
    102 
    -     (when string
    103 
    -       (%primitive print "Set variable text domain")
    104 
    -       (%primitive print (symbol-name name))
    105 
    -       (%primitive print intl::*default-domain*))
    106 
    -     (setf (info variable textdomain name) intl::*default-domain*)
    107 
    -     (setf (info variable documentation name) string))
    108 
    -    (function
    109 
    -     #+nil
    110 
    -     (when intl::*default-domain*
    111 
    -       (%primitive print "Set function text domain")
    112 
    -       (%primitive print (symbol-name name))
    113 
    -       (%primitive print intl::*default-domain*))
    114 
    -     (setf (info function textdomain name) intl::*default-domain*)
    115 
    -     (setf (info function documentation name) string))
    116 
    -    (structure
    117 
    -     (unless (eq (info type kind name) :instance)
    118 
    -       (error (intl:gettext "~S is not the name of a structure type.") name))
    119 
    -     (setf (info type textdomain name) intl::*default-domain*)
    120 
    -     (setf (info type documentation name) string))
    121 
    -    (type
    122 
    -     (setf (info type textdomain name) intl::*default-domain*)
    123 
    -     (setf (info type documentation name) string))
    124 
    -    (setf
    125 
    -     (setf (info setf textdomain name) intl::*default-domain*)
    126 
    -     (setf (info setf documentation name) string))
    127 
    -    (t
    128 
    -     (let ((pair (assoc doc-type (info random-documentation stuff name))))
    129 
    -       (if pair
    130 
    -	   (setf (cdr pair) string)
    131 
    -	   (push (cons doc-type string)
    132 
    -		 (info random-documentation stuff name))))))
    133 
    -  string)
    134 
    -
    135 
    -
    136 33 
     ;;; Register various Lisp features
    137 34 
     #+sparc-v7
    138 35 
     (sys:register-lisp-runtime-feature :sparc-v7)

  • src/i18n/locale/cmucl.pot
    ... ... @@ -5605,17 +5605,6 @@ msgid ""
    5605 5605 
     "  NIL if no such character exists."
    5606 5606 
     msgstr ""
    5607 5607
    5608 
    -#: src/code/misc.lisp
    5609 
    -msgid ""
    5610 
    -"Returns the documentation string of Doc-Type for X, or NIL if\n"
    5611 
    -"  none exists.  System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,\n"
    5612 
    -"  SETF, and T."
    5613 
    -msgstr ""
    5614 
    -
    5615 
    -#: src/code/misc.lisp
    5616 
    -msgid "~S is not the name of a structure type."
    5617 
    -msgstr ""
    5618 
    -
    5619 5608 
     #: src/code/misc.lisp
    5620 5609 
     msgid ""
    5621 5610 
     "If X is an atom, see if it is present in *FEATURES*.  Also\n"
    ... ... @@ -5701,6 +5690,17 @@ msgid ""
    5701 5690 
     "  disassemble."
    5702 5691 
     msgstr ""
    5703 5692
    5693 
    +#: src/code/misc-doc.lisp
    5694 
    +msgid ""
    5695 
    +"Returns the documentation string of Doc-Type for X, or NIL if\n"
    5696 
    +"  none exists.  System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,\n"
    5697 
    +"  SETF, and T."
    5698 
    +msgstr ""
    5699 
    +
    5700 
    +#: src/code/misc-doc.lisp
    5701 
    +msgid "~S is not the name of a structure type."
    5702 
    +msgstr ""
    5703 
    +
    5704 5704 
     #: src/code/extensions.lisp
    5705 5705 
     msgid ""
    5706 5706 
     "This function can be used as the default value for keyword arguments that\n"

  • src/tools/pclcom.lisp
    ... ... @@ -12,7 +12,7 @@
    12 12
    13 13 
     (when (find-package "PCL")
    14 14 
       ;; Load the lisp:documentation functions.
    15 
    -  (load "target:code/misc")
    15 
    +  (load "target:code/misc-doc")
    16 16
    17 17 
       ;;
    18 18 
       ;; Blow away make-instance optimizer so that it doesn't confuse

  • src/tools/worldbuild.lisp
    ... ... @@ -113,6 +113,7 @@
    113 113 
         "target:code/string"
    114 114 
         "target:code/mipsstrops"
    115 115 
         "target:code/misc"
    116 
    +    "target:code/misc-doc"
    116 117 
         "target:code/dfixnum"
    117 118 
         ,@(unless (c:backend-featurep :gengc)
    118 119 
     	'("target:code/gc"))

  • src/tools/worldcom.lisp
    ... ... @@ -211,6 +211,7 @@
    211 211 
     (comf "target:code/unidata")
    212 212 
     (comf "target:code/char")
    213 213 
     (comf "target:code/misc")
    214 
    +(comf "target:code/misc-doc")
    214 215 
     (comf "target:code/extensions" :byte-compile t)
    215 216 
     (comf "target:code/commandline")
    216 217 
     (comf "target:code/env-access")

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help