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

Commits: 6b28a906 by Raymond Toy at 2023-03-15T14:06:28+00:00 Fix #177: Add pprinter for deftransform and defoptimizer

- - - - - 75e0b7e3 by Raymond Toy at 2023-03-15T14:06:31+00:00 Merge branch 'issue-177-pprint-deftransform' into 'master'

Fix #177: Add pprinter for deftransform and defoptimizer

Closes #177

See merge request cmucl/cmucl!132 - - - - - 6b3ceb28 by Raymond Toy at 2023-03-16T17:08:32+00:00 Fix #172: Declare pathname-match-p to return NIL or a pathname

- - - - - 0b9e41a4 by Raymond Toy at 2023-03-16T17:08:35+00:00 Merge branch 'issue-172-pathname-match-p-return-type' into 'master'

Fix #172: Declare pathname-match-p to return NIL or a pathname

Closes #172

See merge request cmucl/cmucl!131 - - - - - b329b385 by Raymond Toy at 2023-03-16T10:18:39-07:00 Fix some typos

- - - - - 5958fd8d by Raymond Toy at 2023-03-23T13:45:44+00:00 Fix #176: short-site-name and long-site-name return NIL

- - - - - b758b5aa by Raymond Toy at 2023-03-23T13:45:46+00:00 Merge branch 'issue-176-site-name-is-nil' into 'master'

Fix #176: short-site-name and long-site-name return NIL

Closes #176

See merge request cmucl/cmucl!130 - - - - - 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 - - - - - b84c7349 by Raymond Toy at 2023-03-23T07:24:02-07:00 Merge branch 'master' into issue-156-take-2-nan-comparison

- - - - -

9 changed files:

- + src/code/misc-doc.lisp - src/code/misc.lisp - src/code/pprint.lisp - src/compiler/fndb.lisp - src/general-info/release-21e.md - 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) @@ -190,14 +87,14 @@ "Returns a string describing the supporting software." *software-type*)

-(defvar *short-site-name* (intl:gettext "Unknown") +(defvar *short-site-name* nil "The value of SHORT-SITE-NAME. Set in library:site-init.lisp.")

(defun short-site-name () "Returns a string with the abbreviated site name." *short-site-name*)

-(defvar *long-site-name* (intl:gettext "Site name not initialized") +(defvar *long-site-name* nil "The value of LONG-SITE-NAME. Set in library:site-init.lisp.")

(defun long-site-name ()

===================================== src/code/pprint.lisp ===================================== @@ -2074,7 +2074,9 @@ When annotations are present, invoke them at the right positions." (lisp::with-array-data pprint-with-like) (c:define-vop pprint-define-vop) (c:sc-case pprint-sc-case) - (c:define-assembly-routine pprint-define-assembly))) + (c:define-assembly-routine pprint-define-assembly) + (c:deftransform pprint-defun) + (c:defoptimizer pprint-defun)))

(defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

===================================== src/compiler/fndb.lisp ===================================== @@ -1027,7 +1027,10 @@ :type :version)) boolean (flushable)) -(defknown pathname-match-p (pathnamelike pathnamelike) boolean +(defknown pathname-match-p (pathnamelike pathnamelike) + ;; CLHS says the return type is a generalized boolean. We currently + ;; return a pathname on a match. + (or null pathname) (flushable)) (defknown translate-pathname (pathnamelike pathnamelike pathnamelike &key) pathname

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

===================================== 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/07cc6791a1b285aca7d733f...