[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] 10 commits: Fix #177: Add pprinter for deftransform and defoptimizer
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Thu Mar 23 14:24:42 UTC 2023
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/07cc6791a1b285aca7d733f296d560d7ee070f3d...b84c734965e4abdf14b6ac2f69c9b7f80117588e
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/07cc6791a1b285aca7d733f296d560d7ee070f3d...b84c734965e4abdf14b6ac2f69c9b7f80117588e
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/54e0c8c5/attachment-0001.html>
More information about the cmucl-cvs
mailing list