March 2023 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-120-software-type-in-c] Return "Unknown" if uname fails
by Raymond Toy (＠rtoy) 25 Mar '23

25 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 4abd7935 by Raymond Toy at 2023-03-25T08:02:09-07:00 Return "Unknown" if uname fails Remove the check for NULL from os_software_version since that can't happen anymore. - - - - - 2 changed files: - src/code/misc.lisp - src/lisp/os-common.c Changes: ===================================== src/code/misc.lisp ===================================== @@ -101,8 +101,7 @@ (alien:alien-funcall (alien:extern-alien "os_software_version" (function (alien:* c-call:c-string))))) - (unless (zerop (sap-int (alien:alien-sap version))) - (alien:cast version c-call:c-string)))))) + (alien:cast version c-call:c-string))))) *software-version*)) (defvar *short-site-name* nil ===================================== src/lisp/os-common.c ===================================== @@ -828,19 +828,20 @@ os_software_version(void) int status; + strcpy(result, "Unknown"); + status = uname(&uts); - if (status != 0) { - return NULL; - } + if (status == 0) { #if defined(UNAME_RELEASE_AND_VERSION) - strcpy(result, uts.release); - strcat(result, " "); - strcat(result, uts.version); + strcpy(result, uts.release); + strcat(result, " "); + strcat(result, uts.version); #else - strcpy(result, uts.version); + strcpy(result, uts.version); #endif - + } + return result; } #undef UNAME_RELEASE_AND_VERSION View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4abd79359ba5607a1351f22… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4abd79359ba5607a1351f22… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] 5 commits: Address #158: Filename encoding for Darwin
by Raymond Toy (＠rtoy) 25 Mar '23

25 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 5dc0d7bf by Raymond Toy at 2023-03-24T14:31:40+00:00 Address #158: Filename encoding for Darwin - - - - - 3578e015 by Raymond Toy at 2023-03-24T14:31:42+00:00 Merge branch 'issue-158-darwin-pathnames-utf8' into 'master' Address #158: Filename encoding for Darwin Closes #166 and #159 See merge request cmucl/cmucl!113 - - - - - ce823be4 by Raymond Toy at 2023-03-24T08:17:30-07:00 Update release notes with recently closed issues We left out a few issues that probably aren't relevant to users like #175 and #170. We also added #158 which isn't closed, but explains we support utf-8 on Darwin. - - - - - b9b145ab by Raymond Toy at 2023-03-24T08:23:42-07:00 Add period at the end of each bug item - - - - - a06dad9b by Raymond Toy at 2023-03-25T07:48:32-07:00 Merge branch 'master' into issue-120-software-type-in-c - - - - - 8 changed files: - src/code/pathname.lisp - src/code/save.lisp - src/code/string.lisp - src/code/unicode.lisp - src/general-info/release-21e.md - src/i18n/locale/cmucl.pot - tests/issues.lisp - + tests/resources/darwin/안녕하십니까.txt Changes: ===================================== src/code/pathname.lisp ===================================== @@ -252,6 +252,14 @@ ;;; This constructor is used to make an instance of the correct type ;;; from parsed arguments. +#+darwin +(defvar *enable-darwin-path-normalization* nil + "When non-NIL, pathnames are on Darwin are normalized when created. + Otherwise, the pathnames are unchanged. + + This must be NIL during bootstrapping because Unicode is not yet + available.") + (defun %make-pathname-object (host device directory name type version) (if (typep host 'logical-host) (flet ((upcasify (thing) @@ -271,7 +279,30 @@ (upcasify name) (upcasify type) (upcasify version))) - (%make-pathname host device directory name type version))) + #-darwin + (%make-pathname host device directory name type version) + #+darwin + (flet ((normalize-name (piece) + ;; Normalize Darwin pathnames by converting Hangul + ;; syllables to conjoining jamo, and converting the + ;; string to NFD form, but skipping over a range of + ;; characters. + (typecase piece + (string + (if *enable-darwin-path-normalization* + (decompose (unicode::decompose-hangul piece) + :compatibility nil + :darwinp t) + piece)) + (t + ;; What should we do about lisp::pattern objects + ;; that occur in the name component? + piece)))) + (%make-pathname host device + (mapcar #'normalize-name directory) + (normalize-name name) + (normalize-name type) + version)))) ;;; *LOGICAL-HOSTS* --internal. ;;; ===================================== src/code/save.lisp ===================================== @@ -202,7 +202,7 @@ (site-init "library:site-init") (print-herald t) (process-command-line t) - #+:executable + #+:executable (executable nil) (batch-mode nil) (quiet nil)) ===================================== src/code/string.lisp ===================================== @@ -1097,7 +1097,10 @@ #+unicode (progn -(defun decompose (string &optional (compatibility t)) +(defun decompose (string &key (compatibility t) (start 0) end darwinp) + "Convert STRING to NFD (or NFKD). If :darwinp is non-NIL, then + characters in the ranges U2000-U2FFF, UF900-UFA6A, and U2F800-U2FA1D + are not decomposed, as specified for Darwin pathnames." (declare (type string string)) (let ((result (make-string (cond ((< (length string) 40) (* 5 (length string))) @@ -1113,8 +1116,13 @@ (declare (type kernel:index i)) (multiple-value-bind (code wide) (codepoint string i) (when wide (incf i)) - (let ((decomp (unicode-decomp code compatibility))) - (if decomp (rec decomp 0 (length decomp)) (out code)))))) + (if (and darwinp + (or (<= #x2000 code #x2fff) + (<= #xf900 code #xfa6a) + (<= #x2f800 code #x2fa1d))) + (out code) + (let ((decomp (unicode-decomp code compatibility))) + (if decomp (rec decomp 0 (length decomp)) (out code))))))) (out (code) (multiple-value-bind (hi lo) (surrogates code) (outch hi) @@ -1151,7 +1159,7 @@ (schar result (1+ last))))) (decf last (if wide2 2 1))) (t (return)))))))) - (with-string string + (with-one-string string start end offset-var (rec string start end)) (shrink-vector result fillptr)))) @@ -1251,12 +1259,12 @@ (defun string-to-nfd (string) _N"Convert String to Unicode Normalization Form D (NFD) using the canonical decomposition. The NFD string is returned" - (decompose string nil)) + (decompose string :compatibility nil)) (defun string-to-nfkd (string) _N"Convert String to Unicode Normalization Form KD (NFKD) uisng the compatible decomposition form. The NFKD string is returned." - (decompose string t)) + (decompose string :compatibility t)) (defun string-to-nfc (string) _N"Convert String to Unicode Normalization Form C (NFC). If the ===================================== src/code/unicode.lisp ===================================== @@ -517,3 +517,55 @@ (if (eq casing :simple) (cl:string-capitalize string :start start :end end) (string-capitalize-full string :start start :end end :casing casing)))) + + +(defun decompose-hangul-syllable (cp stream) + "Decompose the Hangul syllable codepoint CP to an equivalent sequence + of conjoining jamo and print the decomposed result to the stream + STREAM." + (let* ((s-base #xac00) + (l-base #x1100) + (v-base #x1161) + (t-base #x11a7) + (v-count 21) + (t-count 28) + (n-count (* v-count t-count))) + ;; Step 1: Compute index of the syllable S + (let ((s-index (- cp s-base))) + ;; Step 2: If s is in the range 0 <= s <= s-count, the compute + ;; the components. + (let ((l (+ l-base (truncate s-index n-count))) + (v (+ v-base (truncate (mod s-index n-count) t-count))) + (tt (+ t-base (mod s-index t-count)))) + ;; Step 3: If tt = t-base, then there is no trailing character + ;; so replace s by the sequence <l,v>. Otherwise there is a + ;; trailing character, so replace s by the sequence <l,v,tt>. + (princ (code-char l) stream) + (princ (code-char v) stream) + (unless (= tt t-base) + (princ (code-char tt) stream))))) + (values)) + +(defun is-hangul-syllable (codepoint) + "Test if CODEPOINT is a Hangul syllable" + (let* ((s-base #xac00) + (l-count 19) + (v-count 21) + (t-count 28) + (n-count (* v-count t-count)) + (number-of-syllables (* l-count n-count))) + (<= 0 (- codepoint s-base) number-of-syllables))) + +(defun decompose-hangul (string) + "Decompose any Hangul syllables in STRING to an equivalent sequence of + conjoining jamo characters." + (with-output-to-string (s) + (loop for cp being the codepoints of string + do + (if (is-hangul-syllable cp) + (decompose-hangul-syllable cp s) + (multiple-value-bind (high low) + (surrogates cp) + (princ high s) + (when low + (princ low s))))))) ===================================== src/general-info/release-21e.md ===================================== @@ -22,63 +22,68 @@ public domain. * Feature enhancements * Changes * Update to ASDF 3.3.6 - * The default external format is `:utf-8` instead of `:iso8859-1` + * The default external format is `:utf-8` instead of `:iso8859-1`. * ANSI compliance fixes: * Bug fixes: * ~~#97~~ Fixes stepping through the source forms in the debugger. This has been broken for quite some time, but it works now. * Gitlab tickets: - * ~~#68~~ gcc8.1.1 can't build lisp. Change optimization from `-O2` to `-O1` - * ~~#72~~ CMU user manual now part of cmucl-site - * ~~#73~~ Update clx from upstream clx - * ~~#77~~ Added tests for sqrt for exceptional values + * ~~#68~~ gcc8.1.1 can't build lisp. Change optimization from `-O2` to `-O1`. + * ~~#72~~ CMU user manual now part of cmucl-site. + * ~~#73~~ Update clx from upstream clx. + * ~~#77~~ Added tests for sqrt for exceptional values. * ~~#79~~ Autoload ASDF when calling `REQUIRE` the first time. User's no longer have to explicitly load ASDF anymore. * ~~#80~~ Use ASDF to load contribs. cmu-contribs still exists but does nothing. The contrib names are the same, except it's best to use a keyword instead of a string. So, `:contrib-demos` instead of `"contrib-demos"`. - * ~~#81~~ Added contribs from Eric Marsden - * ~~#82~~ Replace bc with expr in GNUMakefile - * ~~#86~~ Building with gcc 8 and later works when using -O2 optimization + * ~~#81~~ Added contribs from Eric Marsden. + * ~~#82~~ Replace bc with expr in GNUMakefile. + * ~~#86~~ Building with gcc 8 and later works when using -O2 optimization. * ~~#90~~ Some static symbols have been removed. This probably makes the fasl files incompatible with older versions. - * ~~#91~~ Loop destructuring no longer incorrectly signals an error - * ~~#95~~ Disassembler syntax of x86 je and movzx is incorrect + * ~~#91~~ Loop destructuring no longer incorrectly signals an error. + * ~~#95~~ Disassembler syntax of x86 je and movzx is incorrect. * ~~#97~~ Define and use ud2 instruction instead of int3. Fixes single-stepping. - * ~~#98~~ fstpd is not an Intel instruction; disassemble as `fstp dword ptr [addr]` + * ~~#98~~ fstpd is not an Intel instruction; disassemble as `fstp dword ptr [addr]`. * ~~#100~~ ldb prints out Unicode base-chars correctly instead of just the low 8 bits. - * ~~#103~~ RANDOM-MT19937-UPDATE assembly routine still exists + * ~~#103~~ RANDOM-MT19937-UPDATE assembly routine still exists. * ~~#104~~ Single-stepping broken (fixed via #97). - * ~~#107~~ Replace u_int8_t with uint8_t - * ~~#108~~ Update ASDF - * ~~#112~~ CLX can't connect to X server via inet sockets + * ~~#107~~ Replace u_int8_t with uint8_t. + * ~~#108~~ Update ASDF. + * ~~#112~~ CLX can't connect to X server via inet sockets. * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF.. - * ~~#120~~ `SOFTWARE-TYPE` and `SOFTWARE-VERSION` are implemented in C. + * ~~#120~~ `SOFTWARE-VERSION` is implemented in C. * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM * ~~#122~~ gcc 11 can't build cmucl * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories * ~~#125~~ Linux `unix-stat` returning incorrect values * ~~#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 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 - * ~~#140~~ External format for streams that are not `file-stream`'s - * ~~#141~~ Disallow locales that are pathnames to a localedef file - * ~~#142~~ `(random 0)` signals incorrect error - * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream` - * ~~#149~~ Call setlocale(3C) on startup - * ~~#150~~ Add aliases for external format cp949 and euckr + * ~~#128~~ `QUIT` accepts an exit code. + * ~~#130~~ Move file-author to C. + * ~~#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. + * ~~#140~~ External format for streams that are not `file-stream`'s. + * ~~#141~~ Disallow locales that are pathnames to a localedef file. + * ~~#142~~ `(random 0)` signals incorrect error. + * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream`. + * ~~#149~~ Call setlocale(3C) on startup. + * ~~#150~~ Add aliases for external format cp949 and euckr. * ~~#151~~ Change `*default-external-format*` to `:utf-8`. - * ~~#155~~ Wrap help strings neatly - * ~~#157~~ `(directory "foo/**/")` only returns directories now - * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version - * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` - * ~~#166~~ Fix incorrect type declaration for exponent from `integer-decode-float` + * ~~#152~~ Add new external format, `:locale` as an alias to the codeset from LANG and friends. + * ~~#!53~~ Terminals default to an encoding of `:locale`. + * ~~#155~~ Wrap help strings neatly. + * ~~#157~~ `(directory "foo/**/")` only returns directories now. + * #158 Darwin uses utf-8, but we don't support all the rules for pathnames. + * ~~#162~~ `*filename-encoding*` defaults to `:null` to mean no encoding. + * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version. + * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT`. + * ~~#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` + * ~~#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` + * ~~#173~~ Add pprinter for `define-assembly-routine`. * ~~#176~~ `SHORT-SITE-NAME` and `LONG-SITE-NAME` return `NIL`. + * ~~#177~~ Add pprinter for `deftransform` and `defoptimizer`. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -4012,6 +4012,14 @@ msgid "" " string is returned." msgstr "" +#: src/code/string.lisp +msgid "" +"Convert String to NFD (or NFKD). If :darwinp is non-NIL, then\n" +" characters in the ranges U2000-U2FFF, UF900-UFA6A, and\n" +" U2F800-U2FA1D are not decomposed, as specified for Darwin\n" +" pathnames." +msgstr "" + #: src/code/string.lisp msgid "" "Convert a sequence of codepoints to a string. Codepoints outside\n" @@ -15267,6 +15275,23 @@ msgid "" " delimited by non-case-modifiable chars. " msgstr "" +#: src/code/unicode.lisp +msgid "" +"Decompose the Hangul syllable codepoint CP to an equivalent sequence\n" +" of conjoining jamo and print the decomposed result to the stream\n" +" STREAM." +msgstr "" + +#: src/code/unicode.lisp +msgid "Test if CODEPOINT is a Hangul syllable" +msgstr "" + +#: src/code/unicode.lisp +msgid "" +"Decompose any Hangul syllables in STRING to an equivalent sequence of\n" +" conjoining jamo characters." +msgstr "" + #: src/compiler/macros.lisp msgid "" "Policy Node Condition*\n" ===================================== tests/issues.lisp ===================================== @@ -832,6 +832,54 @@ +(define-test issue.158 + (:tag :issues) + (let* ((name (string #\Hangul_Syllable_Gyek)) + (path (make-pathname :directory (list :relative name) + :name name + :type name))) + ;; Enable this when we implement normalization for Darwin + #+(and nil darwin) + (let ((expected '(4352 4456 4543))) + ;; Tests that on Darwin the Hangul pathname has been normalized + ;; correctly. We fill in the directory, name, and type components + ;; with the same thing since it shouldn't really matter. + ;; + ;; The expected value is the conjoining jamo for the character + ;; #\Hangul_Syllable_Gyek. + (assert-equal (map 'list #'char-code (second (pathname-directory path))) + expected) + (assert-equal (map 'list #'char-code (pathname-name path)) + expected) + (assert-equal (map 'list #'char-code (pathname-type path)) + expected)) + #-darwin + (let ((expected (list (char-code #\Hangul_Syllable_Gyek)))) + ;; For other OSes, just assume that the pathname is unchanged. + (assert-equal (map 'list #'char-code (second (pathname-directory path))) + expected) + (assert-equal (map 'list #'char-code (pathname-name path)) + expected) + (assert-equal (map 'list #'char-code (pathname-type path)) + expected)))) + +(define-test issue.158.dir + (:tag :issues) + (flet ((get-file () + ;; This assumes that there is only one file in resources/darwin + (let ((files (directory (merge-pathnames "resources/darwin/*.txt" *test-path*)))) + (assert-equal (length files) 1) + (first files)))) + (let ((f (get-file)) + (expected-name "안녕하십니까")) + #+darwin + (assert-equal (pathname-name f) + (unicode::decompose-hangul expected-name)) + #-darwin + (assert-equal (pathname-name f) expected-name)))) + + + (define-test issue.166 (:tag :issues) ;; While this tests for the correct return value, the problem was @@ -896,4 +944,3 @@ (assert-true (typep idf-max-expo 'kernel:double-float-int-exponent)) (assert-true (typep (1- idf-max-expo) 'kernel:double-float-int-exponent)) (assert-false (typep (1+ idf-max-expo) 'kernel:double-float-int-exponent)))) - ===================================== tests/resources/darwin/안녕하십니까.txt ===================================== @@ -0,0 +1,3 @@ +The file name of this file is "안녕하십니까.txt" ("Hello" in Korean.) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/531ea53c4501269b59aa81… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/531ea53c4501269b59aa81… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] Revert changes to software-type
by Raymond Toy (＠rtoy) 25 Mar '23

25 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 531ea53c by Raymond Toy at 2023-03-25T07:45:14-07:00 Revert changes to software-type We restore the old code for determining `(software-type)`. This means removing the function from os-common.lisp as well. - - - - - 6 changed files: - src/code/bsd-os.lisp - src/code/linux-os.lisp - src/code/misc.lisp - src/code/sunos-os.lisp - src/i18n/locale/cmucl.pot - src/lisp/os-common.c Changes: ===================================== src/code/bsd-os.lisp ===================================== @@ -42,6 +42,12 @@ #+executable (register-lisp-runtime-feature :executable) +(setq *software-type* #+OpenBSD "OpenBSD" + #+NetBSD "NetBSD" + #+freebsd "FreeBSD" + #+Darwin "Darwin" + #-(or freebsd NetBSD OpenBSD Darwin) "BSD") + ;;; OS-Init initializes our operating-system interface. It sets the values ;;; of the global port variables to what they should be and calls the functions ===================================== src/code/linux-os.lisp ===================================== @@ -26,6 +26,8 @@ (register-lisp-feature :elf) (register-lisp-runtime-feature :executable) +(setq *software-type* "Linux") + ;;; OS-Init initializes our operating-system interface. ;;; (defun os-init () ===================================== src/code/misc.lisp ===================================== @@ -80,23 +80,11 @@ "Returns a string giving the name of the local machine." (unix:unix-gethostname)) -(defvar *software-type* nil - _N"The value of SOFTWARE-TYPE.") +(defvar *software-type* "Unix" + _N"The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") (defun software-type () - _N"Returns a string describing the supporting software." - (unless *software-type* - (setf *software-type* - (let (software-type) - ;; Get the software-type from the C function os_software_type. - (unwind-protect - (progn - (setf software-type - (alien:alien-funcall - (alien:extern-alien "os_software_type" - (function (alien:* c-call:c-string))))) - (unless (zerop (sap-int (alien:alien-sap software-type))) - (alien:cast software-type c-call:c-string))))))) + "Returns a string describing the supporting software." *software-type*) (defvar *software-version* nil ===================================== src/code/sunos-os.lisp ===================================== @@ -31,6 +31,8 @@ #+executable (register-lisp-runtime-feature :executable) +(setq *software-type* "SunOS") + ;;; OS-INIT -- interface. ;;; ;;; Other OS dependent initializations. ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5632,11 +5632,7 @@ msgid "Returns a string giving the name of the local machine." msgstr "" #: src/code/misc.lisp -msgid "The value of SOFTWARE-TYPE." -msgstr "" - -#: src/code/misc.lisp -msgid "Returns a string describing the supporting software." +msgid "The value of SOFTWARE-TYPE. Set in FOO-os.lisp." msgstr "" #: src/code/misc.lisp ===================================== src/lisp/os-common.c ===================================== @@ -844,20 +844,3 @@ os_software_version(void) return result; } #undef UNAME_RELEASE_AND_VERSION - -char* -os_software_type(void) -{ - int status; - struct utsname uts; - static char os_name[sizeof(uts.sysname)]; - - status = uname(&uts); - if (status != 0) { - return NULL; - } - - strcpy(os_name, uts.sysname); - - return os_name; -} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/531ea53c4501269b59aa81e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/531ea53c4501269b59aa81e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Add period at the end of each bug item
by Raymond Toy (＠rtoy) 24 Mar '23

24 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b9b145ab by Raymond Toy at 2023-03-24T08:23:42-07:00 Add period at the end of each bug item - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -22,65 +22,65 @@ public domain. * Feature enhancements * Changes * Update to ASDF 3.3.6 - * The default external format is `:utf-8` instead of `:iso8859-1` + * The default external format is `:utf-8` instead of `:iso8859-1`. * ANSI compliance fixes: * Bug fixes: * ~~#97~~ Fixes stepping through the source forms in the debugger. This has been broken for quite some time, but it works now. * Gitlab tickets: - * ~~#68~~ gcc8.1.1 can't build lisp. Change optimization from `-O2` to `-O1` - * ~~#72~~ CMU user manual now part of cmucl-site - * ~~#73~~ Update clx from upstream clx - * ~~#77~~ Added tests for sqrt for exceptional values + * ~~#68~~ gcc8.1.1 can't build lisp. Change optimization from `-O2` to `-O1`. + * ~~#72~~ CMU user manual now part of cmucl-site. + * ~~#73~~ Update clx from upstream clx. + * ~~#77~~ Added tests for sqrt for exceptional values. * ~~#79~~ Autoload ASDF when calling `REQUIRE` the first time. User's no longer have to explicitly load ASDF anymore. * ~~#80~~ Use ASDF to load contribs. cmu-contribs still exists but does nothing. The contrib names are the same, except it's best to use a keyword instead of a string. So, `:contrib-demos` instead of `"contrib-demos"`. - * ~~#81~~ Added contribs from Eric Marsden - * ~~#82~~ Replace bc with expr in GNUMakefile - * ~~#86~~ Building with gcc 8 and later works when using -O2 optimization + * ~~#81~~ Added contribs from Eric Marsden. + * ~~#82~~ Replace bc with expr in GNUMakefile. + * ~~#86~~ Building with gcc 8 and later works when using -O2 optimization. * ~~#90~~ Some static symbols have been removed. This probably makes the fasl files incompatible with older versions. - * ~~#91~~ Loop destructuring no longer incorrectly signals an error - * ~~#95~~ Disassembler syntax of x86 je and movzx is incorrect + * ~~#91~~ Loop destructuring no longer incorrectly signals an error. + * ~~#95~~ Disassembler syntax of x86 je and movzx is incorrect. * ~~#97~~ Define and use ud2 instruction instead of int3. Fixes single-stepping. - * ~~#98~~ fstpd is not an Intel instruction; disassemble as `fstp dword ptr [addr]` + * ~~#98~~ fstpd is not an Intel instruction; disassemble as `fstp dword ptr [addr]`. * ~~#100~~ ldb prints out Unicode base-chars correctly instead of just the low 8 bits. - * ~~#103~~ RANDOM-MT19937-UPDATE assembly routine still exists + * ~~#103~~ RANDOM-MT19937-UPDATE assembly routine still exists. * ~~#104~~ Single-stepping broken (fixed via #97). - * ~~#107~~ Replace u_int8_t with uint8_t - * ~~#108~~ Update ASDF - * ~~#112~~ CLX can't connect to X server via inet sockets + * ~~#107~~ Replace u_int8_t with uint8_t. + * ~~#108~~ Update ASDF. + * ~~#112~~ CLX can't connect to X server via inet sockets. * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF. - * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM - * ~~#122~~ gcc 11 can't build cmucl - * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories - * ~~#125~~ Linux `unix-stat` returning incorrect values + * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM. + * ~~#122~~ gcc 11 can't build cmucl. + * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories. + * ~~#125~~ Linux `unix-stat` returning incorrect values. * ~~#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 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 - * ~~#140~~ External format for streams that are not `file-stream`'s - * ~~#141~~ Disallow locales that are pathnames to a localedef file - * ~~#142~~ `(random 0)` signals incorrect error - * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream` - * ~~#149~~ Call setlocale(3C) on startup - * ~~#150~~ Add aliases for external format cp949 and euckr + * ~~#128~~ `QUIT` accepts an exit code. + * ~~#130~~ Move file-author to C. + * ~~#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. + * ~~#140~~ External format for streams that are not `file-stream`'s. + * ~~#141~~ Disallow locales that are pathnames to a localedef file. + * ~~#142~~ `(random 0)` signals incorrect error. + * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream`. + * ~~#149~~ Call setlocale(3C) on startup. + * ~~#150~~ Add aliases for external format cp949 and euckr. * ~~#151~~ Change `*default-external-format*` to `:utf-8`. - * ~~#152~~ Add new external format, `:locale` as an alias to the codeset from LANG and friends - * ~~#!53~~ Terminals default to an encoding of `:locale` - * ~~#155~~ Wrap help strings neatly - * ~~#157~~ `(directory "foo/**/")` only returns directories now + * ~~#152~~ Add new external format, `:locale` as an alias to the codeset from LANG and friends. + * ~~#!53~~ Terminals default to an encoding of `:locale`. + * ~~#155~~ Wrap help strings neatly. + * ~~#157~~ `(directory "foo/**/")` only returns directories now. * #158 Darwin uses utf-8, but we don't support all the rules for pathnames. * ~~#162~~ `*filename-encoding*` defaults to `:null` to mean no encoding. - * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version - * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` - * ~~#166~~ Fix incorrect type declaration for exponent from `integer-decode-float` + * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version. + * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT`. + * ~~#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` + * ~~#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` + * ~~#173~~ Add pprinter for `define-assembly-routine`. * ~~#176~~ `SHORT-SITE-NAME` and `LONG-SITE-NAME` return `NIL`. * ~~#177~~ Add pprinter for `deftransform` and `defoptimizer`. * Other changes: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b9b145ab66b7cf2195390c4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b9b145ab66b7cf2195390c4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update release notes with recently closed issues
by Raymond Toy (＠rtoy) 24 Mar '23

24 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: ce823be4 by Raymond Toy at 2023-03-24T08:17:30-07:00 Update release notes with recently closed issues We left out a few issues that probably aren't relevant to users like #175 and #170. We also added #158 which isn't closed, but explains we support utf-8 on Darwin. - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -67,8 +67,12 @@ public domain. * ~~#149~~ Call setlocale(3C) on startup * ~~#150~~ Add aliases for external format cp949 and euckr * ~~#151~~ Change `*default-external-format*` to `:utf-8`. + * ~~#152~~ Add new external format, `:locale` as an alias to the codeset from LANG and friends + * ~~#!53~~ Terminals default to an encoding of `:locale` * ~~#155~~ Wrap help strings neatly * ~~#157~~ `(directory "foo/**/")` only returns directories now + * #158 Darwin uses utf-8, but we don't support all the rules for pathnames. + * ~~#162~~ `*filename-encoding*` defaults to `:null` to mean no encoding. * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` * ~~#166~~ Fix incorrect type declaration for exponent from `integer-decode-float` @@ -78,6 +82,7 @@ public domain. * ~~#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`. + * ~~#177~~ Add pprinter for `deftransform` and `defoptimizer`. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ce823be49f25fee853310b2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ce823be49f25fee853310b2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #158: Filename encoding for Darwin
by Raymond Toy (＠rtoy) 24 Mar '23

24 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 5dc0d7bf by Raymond Toy at 2023-03-24T14:31:40+00:00 Address #158: Filename encoding for Darwin - - - - - 3578e015 by Raymond Toy at 2023-03-24T14:31:42+00:00 Merge branch 'issue-158-darwin-pathnames-utf8' into 'master' Address #158: Filename encoding for Darwin Closes #166 and #159 See merge request cmucl/cmucl!113 - - - - - 7 changed files: - src/code/pathname.lisp - src/code/save.lisp - src/code/string.lisp - src/code/unicode.lisp - src/i18n/locale/cmucl.pot - tests/issues.lisp - + tests/resources/darwin/안녕하십니까.txt Changes: ===================================== src/code/pathname.lisp ===================================== @@ -252,6 +252,14 @@ ;;; This constructor is used to make an instance of the correct type ;;; from parsed arguments. +#+darwin +(defvar *enable-darwin-path-normalization* nil + "When non-NIL, pathnames are on Darwin are normalized when created. + Otherwise, the pathnames are unchanged. + + This must be NIL during bootstrapping because Unicode is not yet + available.") + (defun %make-pathname-object (host device directory name type version) (if (typep host 'logical-host) (flet ((upcasify (thing) @@ -271,7 +279,30 @@ (upcasify name) (upcasify type) (upcasify version))) - (%make-pathname host device directory name type version))) + #-darwin + (%make-pathname host device directory name type version) + #+darwin + (flet ((normalize-name (piece) + ;; Normalize Darwin pathnames by converting Hangul + ;; syllables to conjoining jamo, and converting the + ;; string to NFD form, but skipping over a range of + ;; characters. + (typecase piece + (string + (if *enable-darwin-path-normalization* + (decompose (unicode::decompose-hangul piece) + :compatibility nil + :darwinp t) + piece)) + (t + ;; What should we do about lisp::pattern objects + ;; that occur in the name component? + piece)))) + (%make-pathname host device + (mapcar #'normalize-name directory) + (normalize-name name) + (normalize-name type) + version)))) ;;; *LOGICAL-HOSTS* --internal. ;;; ===================================== src/code/save.lisp ===================================== @@ -202,7 +202,7 @@ (site-init "library:site-init") (print-herald t) (process-command-line t) - #+:executable + #+:executable (executable nil) (batch-mode nil) (quiet nil)) ===================================== src/code/string.lisp ===================================== @@ -1097,7 +1097,10 @@ #+unicode (progn -(defun decompose (string &optional (compatibility t)) +(defun decompose (string &key (compatibility t) (start 0) end darwinp) + "Convert STRING to NFD (or NFKD). If :darwinp is non-NIL, then + characters in the ranges U2000-U2FFF, UF900-UFA6A, and U2F800-U2FA1D + are not decomposed, as specified for Darwin pathnames." (declare (type string string)) (let ((result (make-string (cond ((< (length string) 40) (* 5 (length string))) @@ -1113,8 +1116,13 @@ (declare (type kernel:index i)) (multiple-value-bind (code wide) (codepoint string i) (when wide (incf i)) - (let ((decomp (unicode-decomp code compatibility))) - (if decomp (rec decomp 0 (length decomp)) (out code)))))) + (if (and darwinp + (or (<= #x2000 code #x2fff) + (<= #xf900 code #xfa6a) + (<= #x2f800 code #x2fa1d))) + (out code) + (let ((decomp (unicode-decomp code compatibility))) + (if decomp (rec decomp 0 (length decomp)) (out code))))))) (out (code) (multiple-value-bind (hi lo) (surrogates code) (outch hi) @@ -1151,7 +1159,7 @@ (schar result (1+ last))))) (decf last (if wide2 2 1))) (t (return)))))))) - (with-string string + (with-one-string string start end offset-var (rec string start end)) (shrink-vector result fillptr)))) @@ -1251,12 +1259,12 @@ (defun string-to-nfd (string) _N"Convert String to Unicode Normalization Form D (NFD) using the canonical decomposition. The NFD string is returned" - (decompose string nil)) + (decompose string :compatibility nil)) (defun string-to-nfkd (string) _N"Convert String to Unicode Normalization Form KD (NFKD) uisng the compatible decomposition form. The NFKD string is returned." - (decompose string t)) + (decompose string :compatibility t)) (defun string-to-nfc (string) _N"Convert String to Unicode Normalization Form C (NFC). If the ===================================== src/code/unicode.lisp ===================================== @@ -517,3 +517,55 @@ (if (eq casing :simple) (cl:string-capitalize string :start start :end end) (string-capitalize-full string :start start :end end :casing casing)))) + + +(defun decompose-hangul-syllable (cp stream) + "Decompose the Hangul syllable codepoint CP to an equivalent sequence + of conjoining jamo and print the decomposed result to the stream + STREAM." + (let* ((s-base #xac00) + (l-base #x1100) + (v-base #x1161) + (t-base #x11a7) + (v-count 21) + (t-count 28) + (n-count (* v-count t-count))) + ;; Step 1: Compute index of the syllable S + (let ((s-index (- cp s-base))) + ;; Step 2: If s is in the range 0 <= s <= s-count, the compute + ;; the components. + (let ((l (+ l-base (truncate s-index n-count))) + (v (+ v-base (truncate (mod s-index n-count) t-count))) + (tt (+ t-base (mod s-index t-count)))) + ;; Step 3: If tt = t-base, then there is no trailing character + ;; so replace s by the sequence <l,v>. Otherwise there is a + ;; trailing character, so replace s by the sequence <l,v,tt>. + (princ (code-char l) stream) + (princ (code-char v) stream) + (unless (= tt t-base) + (princ (code-char tt) stream))))) + (values)) + +(defun is-hangul-syllable (codepoint) + "Test if CODEPOINT is a Hangul syllable" + (let* ((s-base #xac00) + (l-count 19) + (v-count 21) + (t-count 28) + (n-count (* v-count t-count)) + (number-of-syllables (* l-count n-count))) + (<= 0 (- codepoint s-base) number-of-syllables))) + +(defun decompose-hangul (string) + "Decompose any Hangul syllables in STRING to an equivalent sequence of + conjoining jamo characters." + (with-output-to-string (s) + (loop for cp being the codepoints of string + do + (if (is-hangul-syllable cp) + (decompose-hangul-syllable cp s) + (multiple-value-bind (high low) + (surrogates cp) + (princ high s) + (when low + (princ low s))))))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -4012,6 +4012,14 @@ msgid "" " string is returned." msgstr "" +#: src/code/string.lisp +msgid "" +"Convert String to NFD (or NFKD). If :darwinp is non-NIL, then\n" +" characters in the ranges U2000-U2FFF, UF900-UFA6A, and\n" +" U2F800-U2FA1D are not decomposed, as specified for Darwin\n" +" pathnames." +msgstr "" + #: src/code/string.lisp msgid "" "Convert a sequence of codepoints to a string. Codepoints outside\n" @@ -15271,6 +15279,23 @@ msgid "" " delimited by non-case-modifiable chars. " msgstr "" +#: src/code/unicode.lisp +msgid "" +"Decompose the Hangul syllable codepoint CP to an equivalent sequence\n" +" of conjoining jamo and print the decomposed result to the stream\n" +" STREAM." +msgstr "" + +#: src/code/unicode.lisp +msgid "Test if CODEPOINT is a Hangul syllable" +msgstr "" + +#: src/code/unicode.lisp +msgid "" +"Decompose any Hangul syllables in STRING to an equivalent sequence of\n" +" conjoining jamo characters." +msgstr "" + #: src/compiler/macros.lisp msgid "" "Policy Node Condition*\n" ===================================== tests/issues.lisp ===================================== @@ -832,6 +832,54 @@ +(define-test issue.158 + (:tag :issues) + (let* ((name (string #\Hangul_Syllable_Gyek)) + (path (make-pathname :directory (list :relative name) + :name name + :type name))) + ;; Enable this when we implement normalization for Darwin + #+(and nil darwin) + (let ((expected '(4352 4456 4543))) + ;; Tests that on Darwin the Hangul pathname has been normalized + ;; correctly. We fill in the directory, name, and type components + ;; with the same thing since it shouldn't really matter. + ;; + ;; The expected value is the conjoining jamo for the character + ;; #\Hangul_Syllable_Gyek. + (assert-equal (map 'list #'char-code (second (pathname-directory path))) + expected) + (assert-equal (map 'list #'char-code (pathname-name path)) + expected) + (assert-equal (map 'list #'char-code (pathname-type path)) + expected)) + #-darwin + (let ((expected (list (char-code #\Hangul_Syllable_Gyek)))) + ;; For other OSes, just assume that the pathname is unchanged. + (assert-equal (map 'list #'char-code (second (pathname-directory path))) + expected) + (assert-equal (map 'list #'char-code (pathname-name path)) + expected) + (assert-equal (map 'list #'char-code (pathname-type path)) + expected)))) + +(define-test issue.158.dir + (:tag :issues) + (flet ((get-file () + ;; This assumes that there is only one file in resources/darwin + (let ((files (directory (merge-pathnames "resources/darwin/*.txt" *test-path*)))) + (assert-equal (length files) 1) + (first files)))) + (let ((f (get-file)) + (expected-name "안녕하십니까")) + #+darwin + (assert-equal (pathname-name f) + (unicode::decompose-hangul expected-name)) + #-darwin + (assert-equal (pathname-name f) expected-name)))) + + + (define-test issue.166 (:tag :issues) ;; While this tests for the correct return value, the problem was @@ -896,4 +944,3 @@ (assert-true (typep idf-max-expo 'kernel:double-float-int-exponent)) (assert-true (typep (1- idf-max-expo) 'kernel:double-float-int-exponent)) (assert-false (typep (1+ idf-max-expo) 'kernel:double-float-int-exponent)))) - ===================================== tests/resources/darwin/안녕하십니까.txt ===================================== @@ -0,0 +1,3 @@ +The file name of this file is "안녕하십니까.txt" ("Hello" in Korean.) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c26f8ede5b0828a2db337f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c26f8ede5b0828a2db337f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-158-darwin-pathnames-utf8] Fix typo: (or (or ...)) only needs one or
by Raymond Toy (＠rtoy) 24 Mar '23

24 Mar '23

Raymond Toy pushed to branch issue-158-darwin-pathnames-utf8 at cmucl / cmucl Commits: beee0969 by Raymond Toy at 2023-03-24T07:13:43-07:00 Fix typo: (or (or ...)) only needs one or - - - - - 1 changed file: - src/code/string.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -1117,9 +1117,9 @@ (multiple-value-bind (code wide) (codepoint string i) (when wide (incf i)) (if (and darwinp - (or (or (<= #x2000 code #x2fff) - (<= #xf900 code #xfa6a) - (<= #x2f800 code #x2fa1d)))) + (or (<= #x2000 code #x2fff) + (<= #xf900 code #xfa6a) + (<= #x2f800 code #x2fa1d))) (out code) (let ((decomp (unicode-decomp code compatibility))) (if decomp (rec decomp 0 (length decomp)) (out code))))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/beee0969a1d9c376378e61e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/beee0969a1d9c376378e61e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] 10 commits: Fix #177: Add pprinter for deftransform and defoptimizer
by Raymond Toy (＠rtoy) 23 Mar '23

23 Mar '23

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/07cc6791a1b285aca7d733… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/07cc6791a1b285aca7d733… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] 6 commits: Fix #176: short-site-name and long-site-name return NIL
by Raymond Toy (＠rtoy) 23 Mar '23

23 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 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 - - - - - 128b152e by Raymond Toy at 2023-03-23T07:02:30-07:00 Merge branch 'master' into issue-120-software-type-in-c - - - - - d0623e5c by Raymond Toy at 2023-03-23T07:11:54-07:00 Update cmucl.pot - - - - - 3 changed files: - src/code/misc.lisp - src/general-info/release-21e.md - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/misc.lisp ===================================== @@ -117,14 +117,14 @@ (alien:cast version c-call:c-string)))))) *software-version*)) -(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/general-info/release-21e.md ===================================== @@ -78,6 +78,7 @@ public domain. * ~~#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-doc.lisp 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-doc.lisp 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" @@ -5662,10 +5651,6 @@ msgstr "" msgid "The value of SHORT-SITE-NAME. Set in library:site-init.lisp." msgstr "" -#: src/code/misc.lisp -msgid "Unknown" -msgstr "" - #: src/code/misc.lisp msgid "Returns a string with the abbreviated site name." msgstr "" @@ -5674,10 +5659,6 @@ msgstr "" msgid "The value of LONG-SITE-NAME. Set in library:site-init.lisp." msgstr "" -#: src/code/misc.lisp -msgid "Site name not initialized" -msgstr "" - #: src/code/misc.lisp msgid "Returns a string with the long form of the site name." msgstr "" @@ -5709,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" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e7fc70da2269c8fcbf960d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e7fc70da2269c8fcbf960d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #120: Move misc doc stuff to misc-doc.lisp
by Raymond Toy (＠rtoy) 23 Mar '23

23 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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 - - - - - 6 changed files: - + src/code/misc-doc.lisp - src/code/misc.lisp - 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) ===================================== 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/b758b5aaed45e7e3885378… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b758b5aaed45e7e3885378… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #176: short-site-name and long-site-name return NIL
by Raymond Toy (＠rtoy) 23 Mar '23

23 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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 - - - - - 2 changed files: - src/code/misc.lisp - src/general-info/release-21e.md Changes: ===================================== src/code/misc.lisp ===================================== @@ -190,14 +190,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/general-info/release-21e.md ===================================== @@ -77,6 +77,7 @@ public domain. * ~~#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: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b329b3853e0686f175dfb0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b329b3853e0686f175dfb0… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] 13 commits: Fix #157: (directory "**/") only returns directories
by Raymond Toy (＠rtoy) 22 Mar '23

22 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: b3de9354 by Raymond Toy at 2023-03-09T14:46:48+00:00 Fix #157: (directory "**/") only returns directories - - - - - 39e30fad by Raymond Toy at 2023-03-09T14:46:48+00:00 Merge branch 'issue-157-directory-no-magic-wildcarding' into 'master' Fix #157: (directory "**/") only returns directories Closes #157 See merge request cmucl/cmucl!127 - - - - - 0038d3d9 by Raymond Toy at 2023-03-09T11:18:21-08:00 Update release notes with recently closed bugs - - - - - d51eb4b8 by Raymond Toy at 2023-03-12T19:05:39+00:00 Fix #175: Simplify branching in x86 float compare vops - - - - - a7237e1d by Raymond Toy at 2023-03-12T19:05:39+00:00 Merge branch 'issue-175-simplify-float-compare-vops' into 'master' Fix #175: Simplify branching in x86 float compare vops Closes #175 See merge request cmucl/cmucl!129 - - - - - 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 - - - - - 4b75969a by Raymond Toy at 2023-03-16T10:42:53-07:00 Address #120: Move misc doc stuff to misc-doc.lisp As mentioned in https://gitlab.common-lisp.net/cmucl/cmucl/-/merge_requests/93#note_11267, this moves some parts of misc.lisp to misc-doc.lisp that is needed to implement #120. - - - - - 6751cc90 by Raymond Toy at 2023-03-16T12:18:09-07:00 Add new file misc-doc.lisp Forgot to chech this in. - - - - - e7fc70da by Raymond Toy at 2023-03-22T10:42:08-07:00 Merge branch 'issue-120-move-misc-first' into issue-120-software-type-in-c - - - - - 8 changed files: - src/code/filesys.lisp - src/code/misc.lisp - src/code/pprint.lisp - src/compiler/fndb.lisp - src/compiler/x86/float-sse2.lisp - src/general-info/release-21e.md - + tests/nan.lisp - tests/pathname.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -1122,11 +1122,7 @@ optionally keeping some of the most recent old versions." (let ((results nil)) (enumerate-search-list (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild - :defaults *default-pathname-defaults*) - :wild)) + *default-pathname-defaults*)) (enumerate-matches (name pathname nil :follow-links follow-links) (when (or all (let ((slash (position #\/ name :from-end t))) ===================================== 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) ===================================== 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/compiler/x86/float-sse2.lisp ===================================== @@ -945,7 +945,7 @@ (frob double ucomisd)) (macrolet - ((frob (op size inst yep nope) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -953,28 +953,52 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp ,nope target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp ,yep target) - (emit-label not-lab))))))))) - (frob < single comiss :b :nb) - (frob > single comiss :a :na) - (frob < double comisd :b :nb) - (frob > double comisd :a :na)) + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) + ;; Consider the case of x > y. + ;; + ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In + ;; the normal case (not-p false), we want to jump to the + ;; target when x > y. This happens when CF = 0. Hence, + ;; we won't jump to the target when there's a NaN, as + ;; desired. + ;; + ;; For the not-p case, we want to jump to target when x + ;; <= y. This means CF = 1 or ZF = 1. But NaN sets + ;; these bits too, so we jump to the target for NaN or x + ;; <= y, as desired. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. + (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) + (frob < single comiss) + (frob < double comisd)) ;;;; Conversion: ===================================== src/general-info/release-21e.md ===================================== @@ -57,7 +57,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 @@ -66,7 +66,18 @@ public domain. * ~~#142~~ `(random 0)` signals incorrect error * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream` * ~~#149~~ Call setlocale(3C) on startup + * ~~#150~~ Add aliases for external format cp949 and euckr + * ~~#151~~ Change `*default-external-format*` to `:utf-8`. * ~~#155~~ Wrap help strings neatly + * ~~#157~~ `(directory "foo/**/")` only returns directories now + * ~~#163~~ Add command-line option `-version` and `--version` to get lisp version + * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` + * ~~#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` * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,209 @@ +;;; Tests for NaN comparisons. +(defpackage :nan-tests + (:use :cl :lisp-unit)) + +(in-package :nan-tests) + +(defparameter *single-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + +(defparameter *double-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (macrolet + ((frob (ntype op) + (let* ((name (ext:symbolicate (if (eq ntype 'single-float) + "S" + "D") + "TST-" op)) + (name3 (ext:symbolicate name "3"))) + + `(progn + (defun ,name (x y) + (declare (,ntype x y)) + (,op x y)) + (defun ,name3 (x y z) + (declare (,ntype x y z)) + (,op x y z)))))) + (frob single-float <) + (frob single-float >) + (frob double-float <) + (frob double-float >) + (frob single-float =) + (frob double-float =))) + +(define-test nan-single.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-< 1f0 2f0)) + (assert-false (stst-< 1f0 1f0)) + (assert-false (stst-< 1f0 0f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-< *single-float-nan* 1f0)) + (assert-false (stst-< 1f0 *single-float-nan*)) + (assert-false (stst-< *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-< 1d0 2d0)) + (assert-false (dtst-< 1d0 1d0)) + (assert-false (dtst-< 1d0 0d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-< *double-float-nan* 1d0)) + (assert-false (dtst-< 1d0 *double-float-nan*)) + (assert-false (dtst-< *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-> 2f0 1f0)) + (assert-false (stst-> 1f0 1f0)) + (assert-false (stst-> 0f0 1f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-> *single-float-nan* 1f0)) + (assert-false (stst-> 1f0 *single-float-nan*)) + (assert-false (stst-> *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-> 2d0 1d0)) + (assert-false (dtst-> 1d0 1d0)) + (assert-false (dtst-> 0d0 1d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-> *double-float-nan* 1d0)) + (assert-false (dtst-> 1d0 *double-float-nan*)) + (assert-false (dtst-> *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.<3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-<3 1f0 2f0 3f0)) + (assert-false (stst-<3 1f0 2f0 2f0)) + (assert-false (stst-<3 1f0 1f0 2f0)) + (assert-false (stst-<3 1f0 0f0 2f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.<3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst-<3 1d0 2d0 3d0)) + (assert-false (dtst-<3 1d0 2d0 2d0)) + (assert-false (dtst-<3 1d0 1d0 2d0)) + (assert-false (dtst-<3 1d0 0d0 2d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.>3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst->3 3f0 2f0 1f0)) + (assert-false (stst->3 3f0 1f0 1f0)) + (assert-false (stst->3 2f0 2f0 1f0)) + (assert-false (stst->3 0f0 2f0 1f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->3 *single-float-nan* 2f0 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.>3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst->3 3d0 2d0 1d0)) + (assert-false (dtst->3 3d0 1d0 1d0)) + (assert-false (dtst->3 2d0 2d0 1d0)) + (assert-false (dtst->3 0d0 2d0 1d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) ===================================== tests/pathname.lisp ===================================== @@ -72,4 +72,14 @@ :directory '(:absolute "system2" "module4") :name nil :type nil) (parse-namestring "ASDFTEST:system2;module4;")))) - + + + +(define-test directory.dirs + (let ((files (directory "src/assembly/**/"))) + ;; Verify that we only returned directories + (loop for f in files + for name = (pathname-name f) + and type = (pathname-type f) + do + (assert-true (and (null name) (null type)) f)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6e59b0b21eabe3bf27347b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6e59b0b21eabe3bf27347b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-171-readable-unspecific-pathnames
by Raymond Toy (＠rtoy) 17 Mar '23

17 Mar '23

Raymond Toy pushed new branch issue-171-readable-unspecific-pathnames at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-171-readable-unspec… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-move-misc-first] Add new file misc-doc.lisp
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch issue-120-move-misc-first at cmucl / cmucl Commits: 6751cc90 by Raymond Toy at 2023-03-16T12:18:09-07:00 Add new file misc-doc.lisp Forgot to chech this in. - - - - - 1 changed file: - + src/code/misc-doc.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) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6751cc9068596eddfffbfc8… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6751cc9068596eddfffbfc8… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-120-move-misc-first
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed new branch issue-120-move-misc-first at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-120-move-misc-first You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Add some comments and indent code neatly.
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 07cc6791 by Raymond Toy at 2023-03-16T10:26:24-07:00 Add some comments and indent code neatly. - - - - - 1 changed file: - src/compiler/srctran.lisp Changes: ===================================== src/compiler/srctran.lisp ===================================== @@ -3537,6 +3537,11 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) +;;; Ir1-transform->=-helper -- Internal +;;; +;;; Derives the result type of the comparison X >= Y returning two +;;; values: the first true if X >= Y, and the second true if X < Y. +;;; This is the equivalent of ir1-transform-<-helper, but for >=. #+(and x86) (defun ir1-transform->=-helper (x y) (flet ((maybe-convert (type) @@ -3558,34 +3563,33 @@ (interval-< x-arg y-arg))))) (values definitely-true definitely-false)))) +;;; IR1-TRANSFORM->= -- Internal +;;; +;;; Like IR1-TRANSFORM-< but for >=. This is needed so that the +;;; compiler can statically determine (>= X Y) using type information. #+(and x86) (defun ir1-transform->= (x y first second inverse) - (if (same-leaf-ref-p x y) - 't - (multiple-value-bind (definitely-true definitely-false) - (ir1-transform->=-helper x y) - (cond (definitely-true - t) - (definitely-false - nil) - ((and (constant-continuation-p first) - (not (constant-continuation-p second))) - #+nil - (format t "swapping ~A~%" inverse) - `(,inverse y x)) - (t - (give-up)))))) + ;; If the leaves are the same, the (>= X Y) is true. + (if (same-leaf-ref-p x y) + 't + (multiple-value-bind (definitely-true definitely-false) + (ir1-transform->=-helper x y) + (cond (definitely-true + t) + (definitely-false + nil) + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + `(,inverse y x)) + (t + (give-up)))))) #+(and x86) (deftransform <= ((x y) (real real) * :when :both) - #+nli - (format t "transform <=~%") (ir1-transform->= y x x y '>=)) #+(and x86) (deftransform >= ((x y) (real real) * :when :both) - #+nil - (format t "transform >=~%") (ir1-transform->= x y x y '<=)) @@ -3605,7 +3609,6 @@ ;; (<= x y) is the same as (not (> x y)) `(not (> x y))) - (deftransform >= ((x y) (integer integer) * :when :both) ;; (>= x y) is the same as (not (< x y)) `(not (< x y)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/07cc6791a1b285aca7d733f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/07cc6791a1b285aca7d733f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Fix some typos
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b329b385 by Raymond Toy at 2023-03-16T10:18:39-07:00 Fix some typos - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== 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,13 @@ 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 a null or pathname + * ~~#172~~ Declare `pathname-match-p` as returning `nil` or `pathname`. * ~~#173~~ Add pprinter for `define-assembly-routine` * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b329b3853e0686f175dfb0f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b329b3853e0686f175dfb0f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] 2 commits: Add ir1 transform for >=
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: cd340ff8 by Raymond Toy at 2023-03-16T10:10:00-07:00 Add ir1 transform for >= Without this, the compiler can't statically determine if x >= y is always T or NIL, like it can for x < y (and x > y). We choose >= because only `interval-<` and `interval->=` are implemented so >= is a natural choice. - - - - - 49d36d2d by Raymond Toy at 2023-03-16T10:12:24-07:00 Update cmucl.pot - - - - - 2 changed files: - src/compiler/srctran.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/compiler/srctran.lisp ===================================== @@ -3537,8 +3537,59 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) +#+(and x86) +(defun ir1-transform->=-helper (x y) + (flet ((maybe-convert (type) + (numeric-type->interval + (cond ((numeric-type-p type) type) + ((member-type-p type) (convert-member-type type)) + (t (give-up)))))) + (let ((xi (mapcar #'maybe-convert + (prepare-arg-for-derive-type (continuation-type x)))) + (yi (mapcar #'maybe-convert + (prepare-arg-for-derive-type (continuation-type y)))) + (definitely-true t) + (definitely-false t)) + (dolist (x-arg xi) + (dolist (y-arg yi) + (setf definitely-true (and definitely-true + (interval->= x-arg y-arg))) + (setf definitely-false (and definitely-false + (interval-< x-arg y-arg))))) + (values definitely-true definitely-false)))) -#+x86 +#+(and x86) +(defun ir1-transform->= (x y first second inverse) + (if (same-leaf-ref-p x y) + 't + (multiple-value-bind (definitely-true definitely-false) + (ir1-transform->=-helper x y) + (cond (definitely-true + t) + (definitely-false + nil) + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + #+nil + (format t "swapping ~A~%" inverse) + `(,inverse y x)) + (t + (give-up)))))) + +#+(and x86) +(deftransform <= ((x y) (real real) * :when :both) + #+nli + (format t "transform <=~%") + (ir1-transform->= y x x y '>=)) + +#+(and x86) +(deftransform >= ((x y) (real real) * :when :both) + #+nil + (format t "transform >=~%") + (ir1-transform->= x y x y '<=)) + + +#+(and nil x86) (progn ;; When x and y are integers, we want to transform <= to > and >= to ;; <. But we don't want to do this for floats because it messes up ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -21588,3 +21588,9 @@ msgid "" "Unicode replacement character." msgstr "" +transform <= +transform >= +transform <= +transform >= +transform >= +transform <= View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/29cd008228a0d93a40a380… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/29cd008228a0d93a40a380… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #172: Declare pathname-match-p to return NIL or a pathname
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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 - - - - - 2 changed files: - src/compiler/fndb.lisp - src/general-info/release-21e.md Changes: ===================================== 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 ===================================== @@ -75,6 +75,7 @@ public domain. * ~~#167~~ Lowe 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 a null or pathname * ~~#173~~ Add pprinter for `define-assembly-routine` * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/75e0b7e3ff1c8f52fd5aad… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/75e0b7e3ff1c8f52fd5aad… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #177: Add pprinter for deftransform and defoptimizer
by Raymond Toy (＠rtoy) 15 Mar '23

15 Mar '23

Raymond Toy pushed to branch master 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 - - - - - 1 changed file: - src/code/pprint.lisp Changes: ===================================== 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)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a7237e1d632c5d13ed5266… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a7237e1d632c5d13ed5266… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Add more NaN tests
by Raymond Toy (＠rtoy) 14 Mar '23

14 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 29cd0082 by Raymond Toy at 2023-03-14T13:02:52-07:00 Add more NaN tests Add tests to verify that we handle NaNs correctly in comparisons. This includes adding tests for <= and >=, and also updating the existing tests for < and > to handle NaN in the second or third arg. - - - - - 1 changed file: - tests/nan.lisp Changes: ===================================== tests/nan.lisp ===================================== @@ -34,7 +34,11 @@ (frob double-float <) (frob double-float >) (frob single-float =) - (frob double-float =))) + (frob double-float =) + (frob single-float >=) + (frob double-float >=) + (frob single-float <=) + (frob double-float <=))) (define-test nan-single.< (:tag :nan) @@ -101,7 +105,10 @@ (ext:with-float-traps-masked (:invalid) (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) - (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)) + (assert-false (stst-<3 1f0 2f0 *single-float-nan*)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* *single-float-nan*)))) (define-test nan-double.<3 (:tag :nan) @@ -120,7 +127,10 @@ (ext:with-float-traps-masked (:invalid) (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) - (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)) + (assert-false (dtst-<3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* *double-float-nan*)))) (define-test nan-single.>3 (:tag :nan) @@ -139,7 +149,10 @@ (ext:with-float-traps-masked (:invalid) (assert-false (stst->3 *single-float-nan* 2f0 3f0)) (assert-false (stst->3 1f0 *single-float-nan* 3f0)) - (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)) + (assert-false (stst->3 1f0 2f0 *single-float-nan*)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* *single-float-nan*)))) (define-test nan-double.>3 (:tag :nan) @@ -158,7 +171,118 @@ (ext:with-float-traps-masked (:invalid) (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) - (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)) + (assert-false (dtst->3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.>= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst->= 1f0 1f0)) + (assert-true (stst->= 2f0 1f0)) + (assert-false (stst->= 0f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->= 1f0 *single-float-nan*)) + (assert-false (stst->= *single-float-nan* 1f0)) + (assert-false (stst->= *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.<= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst-<= 1f0 1f0)) + (assert-true (stst-<= 1f0 2f0)) + (assert-false (stst-<= 2f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<= 1f0 *single-float-nan*)) + (assert-false (stst-<= *single-float-nan* 1f0)) + (assert-false (stst-<= *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.>=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst->=3 1f0 1f0 1f0)) + (assert-true (stst->=3 2f0 1f0 1f0)) + (assert-false (stst->=3 0f0 1f0 1f0)) + (assert-false (stst->=3 2f0 0f0 1f0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->=3 1f0 *single-float-nan* 2f0)) + (assert-false (stst->=3 *single-float-nan* 1f0 2f0)) + (assert-false (stst->=3 *single-float-nan* *single-float-nan* 2f0)) + (assert-false (stst->=3 2f0 1f0 *single-float-nan*)) + (assert-false (stst->=3 2f0 *single-float-nan* 1f0)) + (assert-false (stst->=3 2f0 *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.<=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst-<=3 1f0 1f0 1f0)) + (assert-true (stst-<=3 1f0 2f0 2f0)) + (assert-false (stst-<=3 1f0 3f0 2f0)) + (assert-false (stst-<=3 2f0 1f0 1f0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<=3 1f0 *single-float-nan* 2f0)) + (assert-false (stst-<=3 *single-float-nan* 1f0 2f0)) + (assert-false (stst-<=3 *single-float-nan* *single-float-nan* 2f0)) + (assert-false (stst-<=3 1f0 2f0 *single-float-nan*)) + (assert-false (stst-<=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-<=3 1f0 *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.>= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst->= 1f0 1f0)) + (assert-true (dtst->= 2f0 1f0)) + (assert-false (dtst->= 0f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->= 1f0 *double-float-nan*)) + (assert-false (dtst->= *double-float-nan* 1f0)) + (assert-false (dtst->= *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.<= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst-<= 1f0 1f0)) + (assert-true (dtst-<= 1f0 2f0)) + (assert-false (dtst-<= 2f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<= 1f0 *double-float-nan*)) + (assert-false (dtst-<= *double-float-nan* 1f0)) + (assert-false (dtst-<= *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.>=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst->=3 1d0 1d0 1d0)) + (assert-true (dtst->=3 2d0 1d0 1d0)) + (assert-false (dtst->=3 0d0 1d0 1d0)) + (assert-false (dtst->=3 2d0 0d0 1d0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->=3 1d0 *double-float-nan* 2d0)) + (assert-false (dtst->=3 *double-float-nan* 1d0 2d0)) + (assert-false (dtst->=3 *double-float-nan* *double-float-nan* 2d0)) + (assert-false (dtst->=3 2d0 1d0 *double-float-nan*)) + (assert-false (dtst->=3 2d0 *double-float-nan* 1d0)) + (assert-false (dtst->=3 2d0 *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.<=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst-<=3 1d0 1d0 1d0)) + (assert-true (dtst-<=3 1d0 2d0 2d0)) + (assert-false (dtst-<=3 1d0 3d0 2d0)) + (assert-false (dtst-<=3 2d0 1d0 1d0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<=3 1d0 *double-float-nan* 2d0)) + (assert-false (dtst-<=3 *double-float-nan* 1d0 2d0)) + (assert-false (dtst-<=3 *double-float-nan* *double-float-nan* 2d0)) + (assert-false (dtst-<=3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst-<=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-<=3 1d0 *double-float-nan* *double-float-nan*)))) (define-test nan-single.= (:tag :nan) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/29cd008228a0d93a40a3803… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/29cd008228a0d93a40a3803… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Fix bug in two-arg->= and two-arg-<=
by Raymond Toy (＠rtoy) 14 Mar '23

14 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 8bb4ed86 by Raymond Toy at 2023-03-14T11:56:27-07:00 Fix bug in two-arg->= and two-arg-<= We were handling comparisons of a ratio to an integer and vice versa incorrectly. Use the floor/ceiling appropriately. Now `(kernel::two-arg->= 4e-8 1)` returns `NIL` as expected instead of `T`. - - - - - 1 changed file: - src/code/numbers.lisp Changes: ===================================== src/code/numbers.lisp ===================================== @@ -1038,7 +1038,7 @@ ;; issue #156. #+x86 (progn - (two-arg-</> two-arg-<= <= floor ceiling + (two-arg-</> two-arg-<= <= ceiling floor ((fixnum bignum) (bignum-plus-p y)) ((bignum fixnum) @@ -1046,7 +1046,7 @@ ((bignum bignum) (not (plusp (bignum-compare x y))))) - (two-arg-</> two-arg->= >= ceiling floor + (two-arg-</> two-arg->= >= floor ceiling ((fixnum bignum) (not (bignum-plus-p y))) ((bignum fixnum) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8bb4ed863f8dcf1ac5c49c8… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8bb4ed863f8dcf1ac5c49c8… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-177-pprint-deftransform
by Raymond Toy (＠rtoy) 14 Mar '23

14 Mar '23

Raymond Toy pushed new branch issue-177-pprint-deftransform at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-177-pprint-deftrans… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-172-pathname-match-p-return-type] Update release notes.
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-172-pathname-match-p-return-type at cmucl / cmucl Commits: 8211fa9d by Raymond Toy at 2023-03-13T10:20:45-07:00 Update release notes. - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -75,6 +75,7 @@ public domain. * ~~#167~~ Lowe 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 a null or pathname * ~~#173~~ Add pprinter for `define-assembly-routine` * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8211fa9da9e6aaed592a4bc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8211fa9da9e6aaed592a4bc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-172-pathname-match-p-return-type
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed new branch issue-172-pathname-match-p-return-type at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-172-pathname-match-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0