Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl

Commits:

9 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)
    ... ... @@ -190,14 +87,14 @@
    190 87 
       "Returns a string describing the supporting software."
    191 88 
       *software-type*)
    192 89
    193 
    -(defvar *short-site-name* (intl:gettext "Unknown")
    90 
    +(defvar *short-site-name* nil
    194 91 
       "The value of SHORT-SITE-NAME.  Set in library:site-init.lisp.")
    195 92
    196 93 
     (defun short-site-name ()
    197 94 
       "Returns a string with the abbreviated site name."
    198 95 
       *short-site-name*)
    199 96
    200 
    -(defvar *long-site-name* (intl:gettext "Site name not initialized")
    97 
    +(defvar *long-site-name* nil
    201 98 
       "The value of LONG-SITE-NAME.  Set in library:site-init.lisp.")
    202 99
    203 100 
     (defun long-site-name ()

  • src/code/pprint.lisp
    ... ... @@ -2074,7 +2074,9 @@ When annotations are present, invoke them at the right positions."
    2074 2074 
         (lisp::with-array-data pprint-with-like)
    2075 2075 
         (c:define-vop pprint-define-vop)
    2076 2076 
         (c:sc-case pprint-sc-case)
    2077 
    -    (c:define-assembly-routine pprint-define-assembly)))
    2077 
    +    (c:define-assembly-routine pprint-define-assembly)
    2078 
    +    (c:deftransform pprint-defun)
    2079 
    +    (c:defoptimizer pprint-defun)))
    2078 2080
    2079 2081 
     (defun pprint-init ()
    2080 2082 
       (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

  • src/compiler/fndb.lisp
    ... ... @@ -1027,7 +1027,10 @@
    1027 1027 
     							  :type :version))
    1028 1028 
       boolean
    1029 1029 
       (flushable))
    1030 
    -(defknown pathname-match-p (pathnamelike pathnamelike) boolean
    1030 
    +(defknown pathname-match-p (pathnamelike pathnamelike)
    1031 
    +  ;; CLHS says the return type is a generalized boolean.  We currently
    1032 
    +  ;; return a pathname on a match.
    1033 
    +  (or null pathname)
    1031 1034 
       (flushable))
    1032 1035 
     (defknown translate-pathname (pathnamelike pathnamelike pathnamelike &key)
    1033 1036 
       pathname

  • src/general-info/release-21e.md
    ... ... @@ -56,7 +56,7 @@ public domain.
    56 56 
         * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid.
    57 57 
         * ~~#128~~ `QUIT` accepts an exit code
    58 58 
         * ~~#130~~ Move file-author to C
    59 
    -    * ~~#132~~ Ansi test `RENAME-FILE.1` no fails
    59 
    +    * ~~#132~~ Ansi test `RENAME-FILE.1` no longer fails
    60 60 
         * ~~#134~~ Handle the case of `(expt complex complex-rational)`
    61 61 
         * ~~#136~~ `ensure-directories-exist` should return the given pathspec
    62 62 
         * #139 `*default-external-format*` defaults to `:utf-8`; add alias for `:locale` external format
    ... ... @@ -69,13 +69,15 @@ public domain.
    69 69 
         * ~~#151~~ Change `*default-external-format*` to `:utf-8`.
    70 70 
         * ~~#155~~ Wrap help strings neatly
    71 71 
         * ~~#157~~ `(directory "foo/**/")` only returns directories now
    72 
    -    * ~~#163~~ Add commandline option `-version` and `--version` to get lisp version
    72 
    +    * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version
    73 73 
         * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT`
    74 
    -    * ~~#166~~ Fix incorect type declaration for exponent from `integer-decode-float`
    75 
    -    * ~~#167~~ Lowe bound for `decode-float-exponent` type was off by one.
    74 
    +    * ~~#166~~ Fix incorrect type declaration for exponent from `integer-decode-float`
    75 
    +    * ~~#167~~ Low bound for `decode-float-exponent` type was off by one.
    76 76 
         * ~~#168~~ Don't use negated forms for jmp instructions when possible
    77 77 
         * ~~#169~~ Add pprinter for `define-vop` and `sc-case`
    78 
    +    * ~~#172~~ Declare `pathname-match-p` as returning `nil` or `pathname`.
    78 79 
         * ~~#173~~ Add pprinter for `define-assembly-routine`
    80 
    +    * ~~#176~~ `SHORT-SITE-NAME` and `LONG-SITE-NAME` return `NIL`.
    79 81 
       * Other changes:
    80 82 
       * Improvements to the PCL implementation of CLOS:
    81 83 
       * Changes to building procedure:

  • 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