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

[git] CMU Common Lisp annotated tag snapshot-2014-09 created. snapshot-2014-09
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2014-09 has been created at 15b34683012e3681f157ece707a5b6afc080e246 (tag) tagging ac320f2c22d0532b7920257f0487c449028c81fc (commit) replaces snapshot-2014-08 tagged by Raymond Toy on Tue Sep 2 20:38:26 2014 -0700 - Log ----------------------------------------------------------------- Snapshot 2014-09 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlQGjToACgkQJ5IjUmgZO7JznACfRQbbX4uG1ruzJKpjVkYx41NS vVQAoIbu2TqfvkUNydBVlBAGsiuZ/nhP =JM+6 -----END PGP SIGNATURE----- Raymond Toy (44): Forgot a few items that were done in the snapshot. Update it now (post Remove Config.FreeBSD* and Config.NetBSD*. These were replaced by Fix ticket #100 by implementing STREAM-FILE-POSITION Fix ticket:105 by not flaming out on a closed stream. Add test for ticket:101 for the case of CLEAR-OUTPUT of a lisp Clean up the CLEAR-OUTPUT test a bit. Regenerated. Fix ticket:101, implementing STREAM-ADVANCE-TO-COLUMN for FORMAT ~T. Fix ticket:106 by returning the correctly rounded value. Micro optimize float bits getters. Make cosh signal overflow when it should overflow. Add -ffp-contract=off to make sure no fused-multiply instructions are Make sure floating-point exceptions are signaled. Ensure acosh signals appropriate exceptions. Add -fno-omit-frame-pointer; we want the frame pointer to make it Handle invalid correctly. Make expm1 signal errors using fdlibm_setexception. Update tests to Add -fno-omit-frame-pointer; we want the frame pointer to make it Make log1p signal errors using fdlibm_setexception. Fix some typos and remove redundant test for expm1. Make exp signal errors using fdlibm_setexception. Re-enable the x87 floating-point mode stuff. On x86/darwin, we want and only need the sse2 mode bits. Darwin Give up trying to get the operands if we don't know what the FP Make log signal errors using fdlibm_setexception. Fix typo. Make asinh signal errors using fdlibm_setexception. Make atanh signal errors using fdlibm_setexception. Make inverse trig signal errors using fdlibm_setexception. Rename fdlibm tests to include a % prefix to distinguish these from Deprecate FLOAT-TRAPPING-NAN-P in favor of FLOAT-SIGNALING-NAN-P. Update documentation to include float-signaling-nan-p. Oops. Fix mistake in handling underflow for %exp. Use the two-prod algorithm from crlibm documentation. Implement a simpler (and faster?) algorithm to convert a double to an Correct the comment. Tests for double-double arithmetic. Add support for deriving the type of ROUND. Needs work. Move the test cases from compiler/srctran.lisp to tests/srctran.lisp. Add function to run selected tests. Makes it a bit easier to run a Add some tests for ROUND. Two tests currently fail. Fix round-quotient-bound to handle exclusive bounds better. If a process is not schedulable because it has no run-reasons and/or Update from the commit logs. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2013-04 created. snapshot-2013-04
by rtoy＠alpha-cl-net.common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2013-04 has been created at f52f77edb11c8c5fc50fa832d019809140b5a8e4 (tag) tagging b722521aea8ccd801d12afe519871ab34b8d789f (commit) replaces snapshot-2013-03-a tagged by Raymond Toy on Sat Apr 13 22:13:01 2013 -0700 - Log ----------------------------------------------------------------- Snapshot 2013-04 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (Darwin) iEYEABECAAYFAlFqOuUACgkQJ5IjUmgZO7LB9ACbBn5ax+8Bt3TzmAihJEjTcfCA 9W8AoKjAN2UCcd0M1OiG64xW43CH7Sjo =hzuc -----END PGP SIGNATURE----- Raymond Toy (12): Support ppc. Try to be careful about extracting the linux version from the (uname) Fix ticket:79 Update from logs. Fix ticket:77 by adding the code given in the ticket. Fix ticket:77 correctly, using the supplied patch link. Fix ticket:80 Update from logs. Update -u option so that asdf is always built. Update from logs. Update from logs. Oops. Always build asdf and friends. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-14-ge5ce88c
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via e5ce88c766cd83f58a0b4e3d0e99bdd24d92b86a (commit) via f9be60b19ca38fbbf34dc64bf5442f119afe2725 (commit) via aa05f53d8b1fa758d0768ccec0462a9ad9f1f601 (commit) via ebc07aeb9114976829a26667ac2b88ce7a49bdcb (commit) from 8a5b49ec0af3c4cad29a26e8dc3f9cee029fd67d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit e5ce88c766cd83f58a0b4e3d0e99bdd24d92b86a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:43:49 2014 -0800 Regenerated. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 2034dac..fdbb637 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -182,9 +182,9 @@ msgid "" " setf." msgstr "" -#: src/code/reader.lisp src/code/format.lisp src/code/print.lisp -#: src/code/irrat-dd.lisp src/code/irrat.lisp src/code/float.lisp -#: src/code/numbers.lisp src/code/kernel.lisp +#: src/code/format.lisp src/code/print.lisp src/code/irrat-dd.lisp +#: src/code/irrat.lisp src/code/float.lisp src/code/numbers.lisp +#: src/code/kernel.lisp msgid "Argument ~A is not a ~S: ~S." msgstr "" @@ -8553,7 +8553,7 @@ msgid "Underflow" msgstr "" #: src/code/reader.lisp -msgid "Number not representable as ~S: ~S" +msgid "Number not representable as a ~S: ~S" msgstr "" #: src/code/reader.lisp commit f9be60b19ca38fbbf34dc64bf5442f119afe2725 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:43:26 2014 -0800 Fix ticket 93. * Round the number to least-positive-foo-float when possible, but still throw an error if it's too small but not zero. * Update comments to mention CLHS 2.3.1.1. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 27c18ae..b06230c 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1839,15 +1839,15 @@ the end of the stream." least-positive-single-float) (double-float least-positive-double-float) + #+double-double (double-double-float - (kernel:make-double-double-float least-positive-double-float - 0d0))))) + ext:least-positive-double-double-float)))) (if (>= (* 2 ratio) float-limit) (setf result float-limit) (error _"Underflow")))) result)) (error () - (%reader-error stream _"Number not representable as ~S: ~S" + (%reader-error stream _"Number not representable as a ~S: ~S" float-format (/ number divisor))))) commit aa05f53d8b1fa758d0768ccec0462a9ad9f1f601 Merge: ebc07ae 8a5b49e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:31:39 2014 -0800 Merge branch 'master' into rtoy-round-float-in-reader commit ebc07aeb9114976829a26667ac2b88ce7a49bdcb Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Feb 28 19:49:04 2014 -0800 Fix ticket 93. * src/code/reader.lisp: * Try to round really small numbers * Add somewhat more informative message when the number is not representable. * src/i18n/local/cmucl.pot: * Update * tests/trac.lisp: * Add test for ticket 93 * Add a few comments for test trac.87. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 4eabc4e..27c18ae 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1824,17 +1824,31 @@ the end of the stream." (defun make-float-aux (number divisor float-format stream) (handler-case (with-float-traps-masked (:underflow) - (let ((result (coerce (/ number divisor) float-format))) + (let* ((ratio (/ number divisor)) + (result (coerce ratio float-format))) (when (and (zerop result) (not (zerop number))) - ;; With underflow traps disabled, reading any number - ;; smaller than least-positive-foo-float will return zero. - ;; But we really want to indicate that we can't read it. - ;; So if we converted the number to zero, but the number - ;; wasn't actually zero, throw an error. - (error _"Underflow")) + ;; The number we've read is so small that it gets + ;; converted to 0.0, but is not actually zero. In this + ;; case, we want to round such small numbers to + ;; least-positive-foo-float. If it's still too small, we + ;; want to signal an error saying that we can't really + ;; convert it because the exponent is too small. + ;; See CLHS 2.3.1.1. + (let ((float-limit (ecase float-format + ((short-float single-float) + least-positive-single-float) + (double-float + least-positive-double-float) + (double-double-float + (kernel:make-double-double-float least-positive-double-float + 0d0))))) + (if (>= (* 2 ratio) float-limit) + (setf result float-limit) + (error _"Underflow")))) result)) (error () - (%reader-error stream _"Floating-point number not representable")))) + (%reader-error stream _"Number not representable as ~S: ~S" + float-format (/ number divisor))))) (defun make-ratio (stream) diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 8ae0b93..2034dac 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -182,9 +182,9 @@ msgid "" " setf." msgstr "" -#: src/code/format.lisp src/code/print.lisp src/code/irrat-dd.lisp -#: src/code/irrat.lisp src/code/float.lisp src/code/numbers.lisp -#: src/code/kernel.lisp +#: src/code/reader.lisp src/code/format.lisp src/code/print.lisp +#: src/code/irrat-dd.lisp src/code/irrat.lisp src/code/float.lisp +#: src/code/numbers.lisp src/code/kernel.lisp msgid "Argument ~A is not a ~S: ~S." msgstr "" @@ -8553,7 +8553,7 @@ msgid "Underflow" msgstr "" #: src/code/reader.lisp -msgid "Floating-point number not representable" +msgid "Number not representable as ~S: ~S" msgstr "" #: src/code/reader.lisp @@ -13084,7 +13084,11 @@ msgid "" " process changes. The function takes the process as an argument.\n" " :external-format -\n" " This is the external-format used for communication with the subproce" -"ss." +"ss.\n" +" :element-type -\n" +" When a stream is created for :input or :output, the stream\n" +" uses this element-type instead of the default 'BASE-CHAR type.\n" +"" msgstr "" #: src/code/run-program.lisp diff --git a/tests/trac.lisp b/tests/trac.lisp index 87e3ca7..7fd9408 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -276,7 +276,9 @@ (define-test trac.87.output (:tag :trac) - (let ((path "/tmp/trac.87") + ;; Test that run-program accepts :element-type and produces the + ;; correct output. + (let ((path "/tmp/trac.87.output") (string "Hello")) (unwind-protect (progn @@ -297,7 +299,9 @@ (define-test trac.87.input (:tag :trac) - (let ((path "/tmp/trac.87") + ;; Test that run-program accepts :element-type and produces the + ;; correct input (and output). + (let ((path "/tmp/trac.87.input") (string "Hello")) (unwind-protect (progn @@ -328,3 +332,23 @@ 'double-float (third (kernel:%function-type f))))) +(define-test trac.93 + (:tag :trac) + ;; These small values should read to least-positive-foo-float + ;; because that's the closest non-zero float. + (assert-eql least-positive-short-float + (values (read-from-string ".8s-45"))) + (assert-eql least-positive-single-float + (values (read-from-string ".8e-45"))) + (assert-eql least-positive-double-float + (values (read-from-string "4d-324"))) + (assert-eql (kernel:make-double-double-float least-positive-double-float 0d0) + (values (read-from-string "4w-324"))) + ;; These should signal reader errors because the numbers are not + ;; zero, but are too small to be represented by the corresponding + ;; float type. + (assert-error 'reader-error (read-from-string ".1s-45")) + (assert-error 'reader-error (read-from-string ".1e-45")) + (assert-error 'reader-error (read-from-string "1d-324")) + (assert-error 'reader-error (read-from-string "1w-324"))) + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: src/code/reader.lisp | 30 ++++++++++++++++++++++-------- src/i18n/locale/cmucl.pot | 2 +- tests/trac.lisp | 28 ++++++++++++++++++++++++++-- 3 files changed, 49 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-39-gf849f4d
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via f849f4dba02f2b41d78ffe21d43be5b184aa7cdf (commit) via 16c06cb82aa0e6b6f8866fb227dd608af4c06027 (commit) from b3b6dce07ceb5538e89ce8c49a8bd1fe2d6a15d1 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f849f4dba02f2b41d78ffe21d43be5b184aa7cdf Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 22 23:06:58 2013 -0800 Simple test script to run all of the tests in the tests directory. diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp new file mode 100644 index 0000000..0a7da54 --- /dev/null +++ b/tests/run-tests.lisp @@ -0,0 +1,96 @@ +;;;; -*- Mode: lisp -*- + +;;;; Main script to run all of the tests in the tests directory. +;;;; It is intended to be run using something like +;;;; +;;;; lisp -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)' +;;;; +;;;; The exit code indicates whether there were any test failures. A +;;;; non-zero code indicates a failure of some sort. +;;;; +;;;; It is assumed that either asdf or quicklisp is set up +;;;; appropriately so that lisp-unit can be automatically loaded + +(defpackage :cmucl-test-runner + (:use :cl) + (:export #:run-all-tests + #:load-and-run-all-tests + #:print-test-results)) + +(in-package :cmucl-test-runner) + +(require :lisp-unit) + +;; Be rather verbose in printing the tests +(setf lisp-unit:*print-summary* t) +(setf lisp-unit:*print-failures* t) +(setf lisp-unit:*print-errors* t) + +(defvar *load-path* *load-pathname*) + +;; Look through all the files in the tests directory and load them. +;; Then run all of the tests. For each file, it ia assumed that a +;; package is created that is named with "-TESTS" appended to he +;; pathname-name of the file. +(defun load-and-run-all-tests () + (let (test-names + test-results) + (dolist (file (directory "tests/*.lisp")) + (unless (equal file *load-path*) + (let ((basename (pathname-name file))) + ;; Create the package name from the pathname name so we know + ;; how to run the test. + (push (concatenate 'string (string-upcase basename) "-TESTS") + test-names) + (load file)))) + (setf test-names (nreverse test-names)) + (dolist (test test-names) + (push (lisp-unit:run-tests :all test) + test-results)) + (nreverse test-results))) + +(defun print-test-results (results) + (let ((passed 0) + (failed 0) + (execute-errors 0) + failed-tests + execute-error-tests) + (dolist (result results) + (incf passed (lisp-unit::pass result)) + (incf failed (lisp-unit::fail result)) + (incf execute-errors (lisp-unit::exerr result)) + (when (lisp-unit::failed-tests result) + (setf failed-tests + (append (lisp-unit::failed-tests result) + failed-tests))) + (when (lisp-unit::error-tests result) + (setf execute-error-tests + (append (lisp-unit::error-tests result) + execute-error-tests)))) + (format t "~2&-------------------------------------------------~%") + (format t "Summary of all testsuites~2%") + (format t "~D testsuites were run~%" (length results)) + (format t " ~5D tests total~%" (+ passed failed execute-errors)) + (format t " ~5D tests failed~%" failed) + (format t " ~5D tests with execution errors~%" execute-errors) + (format t "~5,2f% of the tests passed~%" + (float (* 100 + (- 1 (/ (+ failed execute-errors) + (+ passed failed execute-errors)))))) + ;; Print some info about any failed tests. Then exit. We want to + ;; set the exit code so that any scripts runnning this can + ;; determine if there were any test failures. + (cond ((plusp (+ failed execute-errors)) + (when failed-tests + (format t "~2&Failed tests: ~S~%" failed-tests)) + (when execute-error-tests + (format t "~2&Execute failures: ~S~%" execute-error-tests)) + (unix:unix-exit 1)) + (t + (unix:unix-exit 0))))) + +(defun run-all-tests () + (print-test-results (load-and-run-all-tests))) + +;;(run-all-tests) +;;(quit) commit 16c06cb82aa0e6b6f8866fb227dd608af4c06027 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 22 23:00:04 2013 -0800 Regenerated. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 0c327c9..d38bc65 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -5040,9 +5040,9 @@ msgid "" "Z may be any number, but the result is always a complex." msgstr "" -#: src/code/irrat-dd.lisp src/code/irrat.lisp +#: src/code/irrat.lisp msgid "" -"Compute asin z = asinh(i*z)/i\n" +"Compute asin z = -i*log(i*z + sqrt(1-z^2))\n" "\n" "Z may be any number, but the result is always a complex." msgstr "" @@ -5054,9 +5054,9 @@ msgid "" "Z may be any number, but the result is always a complex." msgstr "" -#: src/code/irrat-dd.lisp src/code/irrat.lisp +#: src/code/irrat.lisp msgid "" -"Compute atan z = atanh (i*z) / i\n" +"Compute atan z = (log(1+i*z) - log(1-i*z))/(2*i)\n" "\n" "Z may be any number, but the result is always a complex." msgstr "" @@ -5116,6 +5116,20 @@ msgstr "" msgid "Overflow" msgstr "" +#: src/code/irrat-dd.lisp +msgid "" +"Compute asin z = asinh(i*z)/i\n" +"\n" +"Z may be any number, but the result is always a complex." +msgstr "" + +#: src/code/irrat-dd.lisp +msgid "" +"Compute atan z = atanh (i*z) / i\n" +"\n" +"Z may be any number, but the result is always a complex." +msgstr "" + #: src/compiler/proclaim.lisp msgid "" "~S uses lambda-list keyword naming convention, but is not a recognized " ----------------------------------------------------------------------- Summary of changes: src/i18n/locale/cmucl.pot | 22 +++++++++-- tests/run-tests.lisp | 96 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 114 insertions(+), 4 deletions(-) create mode 100644 tests/run-tests.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-05-14-gb8c0807
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via b8c080759c41e1a16d0468a4138799e4a3d02151 (commit) via a3f78ebd73e13965fb0d609f639737a1428d6578 (commit) via 49f041ad84bf812b25d4fffc210da123400cb6f0 (commit) via 9d66b2585eb33ff8106511da512b4772a3887aab (commit) from 9f62dcdfab39ef03cf01969b6ea88b962073d09f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit b8c080759c41e1a16d0468a4138799e4a3d02151 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun May 26 08:24:37 2013 -0700 Update. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 90df1d4..ee290d9 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -43,10 +43,15 @@ New in this release: Pentium.) * Update unicode to support Unicode 6.2. * Add MP:PROCESS-JOIN, as given in ticket #77. + * Added UNICODE package to hold Unicode-related functions. + Currently contains Unicode extended versions of STRING-UPCASE, + STRING-DOWNCASE, and STRING-CAPITALIZE. * ANSI compliance fixes: * Attempts to modify the standard readtable or the standard pprint dispatch table will now signal a continuable error. + * Remove the Unicode extensions from string-upcase and friends. + This functionality is moved to the new UNICODE package. * Bugfixes: * REPLACE and friends on strings were limited to strings less than commit a3f78ebd73e13965fb0d609f639737a1428d6578 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun May 26 08:22:00 2013 -0700 Import many unicode symbols from LISP into the UNICODE package. src/code/exports.lisp:: * Import symbols src/code/unicode.lisp:: * Remove LISP package prefix from all unicode-related symbols. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 249bc32..b2bdeab 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2447,6 +2447,20 @@ (:shadow "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE") + (:import-from "LISP" + "CODEPOINT" + "SURROGATES" + "UNICODE-FULL-CASE-LOWER" + "UNICODE-FULL-CASE-UPPER" + "UNICODE-FULL-CASE-TITLE" + "UNICODE-CATEGORY" + "+UNICODE-CATEGORY-LOWER+" + "+UNICODE-CATEGORY-OTHER+" + "+UNICODE-CATEGORY-GRAPHIC+" + "+UNICODE-CATEGORY-UPPER+" + "+UNICODE-CATEGORY-TITLE+" + "UNICODE-UPPER" + "UNICODE-WORD-BREAK") (:export "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE" diff --git a/src/code/unicode.lisp b/src/code/unicode.lisp index 98fe880..cbd7713 100644 --- a/src/code/unicode.lisp +++ b/src/code/unicode.lisp @@ -36,14 +36,14 @@ ((= index (the fixnum end))) (declare (fixnum index)) (multiple-value-bind (code wide) - (lisp:codepoint string index) + (codepoint string index) (when wide (incf index)) ;; Handle ASCII specially because this is called early in ;; initialization, before unidata is available. (cond ((< 96 code 123) (write-char (code-char (decf code 32)) s)) ((> code 127) - (write-string (lisp:unicode-full-case-upper code) s)) + (write-string (unicode-full-case-upper code) s)) (t (multiple-value-bind (hi lo) (surrogates code) @@ -82,14 +82,14 @@ ((= index (the fixnum end))) (declare (fixnum index)) (multiple-value-bind (code wide) - (lisp:codepoint string index) + (codepoint string index) (when wide (incf index)) ;; Handle ASCII specially because this is called early in ;; initialization, before unidata is available. (cond ((< 64 code 91) (write-char (code-char (incf code 32)) s)) ((> code 127) - (write-string (lisp:unicode-full-case-lower code) s)) + (write-string (unicode-full-case-lower code) s)) (t ;; Handle codes below 64 (multiple-value-bind (hi lo) @@ -230,7 +230,7 @@ ((char-word-break-category (c) ;; Map our unicode word break property into what this ;; algorithm wants. - (let ((cat (lisp::unicode-word-break c))) + (let ((cat (unicode-word-break c))) (case cat ((:lf :cr :newline) :sep) @@ -241,7 +241,7 @@ ;; Given a valid index i into s, returns the left context ;; at i. (multiple-value-bind (c widep) - (lisp:codepoint s i n) + (codepoint s i n) (let* ((back ;; If we're at a regular character or a leading ;; surrogate, decrementing by 1 gets us the to @@ -279,7 +279,7 @@ (let* ((j1 (- j 1))) (multiple-value-bind (c widep) - (lisp:codepoint s j1) + (codepoint s j1) (when (eql widep -1) ;; Back up one more if we're at the trailing ;; surrogate. @@ -302,7 +302,7 @@ (if (< i j) j n))) (otherwise n)) (multiple-value-bind (c widep) - (lisp:codepoint s j) + (codepoint s j) (let* ((next-j ;; The next character is either 1 or 2 code ;; units away. For a leading surrogate, it's @@ -394,7 +394,7 @@ n) (t (multiple-value-bind (c widep) - (lisp:codepoint s i) + (codepoint s i) (declare (ignore c)) (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) @@ -416,15 +416,15 @@ (:simple #'(lambda (ch) (multiple-value-bind (hi lo) - (lisp::surrogates (lisp::unicode-upper ch)) + (surrogates (unicode-upper ch)) (write-char hi result) (when lo (write-char lo result))))) (:full #'(lambda (ch) - (write-string (lisp::unicode-full-case-upper ch) result))) + (write-string (unicode-full-case-upper ch) result))) (:title #'(lambda (ch) - (write-string (lisp::unicode-full-case-title ch) result)))))) + (write-string (unicode-full-case-title ch) result)))))) (do ((start start next) (next (string-next-word-break string start) (string-next-word-break string next))) @@ -432,7 +432,7 @@ (>= start end))) ;; Convert the first character of the word to upper ;; case, and then make the rest of the word lowercase. - (funcall upper (lisp:codepoint string start)) + (funcall upper (codepoint string start)) (write-string (string-downcase string :start (1+ start) :end next :casing casing) @@ -459,29 +459,29 @@ (or (< 47 m 58) (< 64 m 91) (< 96 m 123) #+(and unicode (not unicode-bootstrap)) (and (> m 127) - (<= lisp::+unicode-category-letter+ - (lisp::unicode-category m) - (+ lisp::+unicode-category-letter+ #x0F))))) + (<= +unicode-category-letter+ + (unicode-category m) + (+ +unicode-category-letter+ #x0F))))) (upper (ch) (ecase casing (:simple #'(lambda (ch) (multiple-value-bind (hi lo) - (lisp::surrogates (lisp::unicode-upper ch)) + (surrogates (unicode-upper ch)) (write-char hi s) (when lo (write-char lo s))))) (:full #'(lambda (ch) - (write-string (lisp::unicode-full-case-upper ch) s))) + (write-string (unicode-full-case-upper ch) s))) (:title #'(lambda (ch) - (write-string (lisp::unicode-full-case-title ch) s)))))) + (write-string (unicode-full-case-title ch) s)))))) (do ((index start (1+ index)) (newword t)) ((= index (the fixnum end))) (declare (fixnum index)) (multiple-value-bind (code wide) - (lisp:codepoint string index) + (codepoint string index) (when wide (incf index)) (cond ((not (alphanump code)) (multiple-value-bind (hi lo) @@ -495,7 +495,7 @@ (setq newword ())) (t ;; char is case-modifiable, but not first - (write-string (lisp:unicode-full-case-lower code) s)))))) + (write-string (unicode-full-case-lower code) s)))))) (write-string string s :start end :end offset-slen)))))) (defun string-capitalize (string &key (start 0) end commit 49f041ad84bf812b25d4fffc210da123400cb6f0 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 25 14:38:36 2013 -0700 Remove all the extensions to string-upcase and friends. The extended functions now live in the new UNICODE package. src/code/exports.lisp:: * Export some unicode functions and constants. src/code/string.lisp:: * Removed the extended versions of string-upcase and friends. * Export surrogates function. * Make sure with-one-string is defined so the unicode package can use it. src/code/unicode.lisp:; * New file with extended versions of string-upcase and friends. src/code/unidata.lisp:: * Export some unicode functions and constants. src/compiler/fndb.lisp:: * Update defknowns for string-upcase and friends. src/tools/worldbuild.lisp:: * Build unicode.lisp src/tools/worldcom.lisp:: * Load unicode.lisp diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 6c7bbed..249bc32 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -913,7 +913,17 @@ (:export "STRING-TO-NFC" "STRING-TO-NFD" "STRING-TO-NFKC" "STRING-TO-NFKD" "UNICODE-COMPLETE" "UNICODE-COMPLETE-NAME" - "LOAD-ALL-UNICODE-DATA")) + "UNICODE-FULL-CASE-LOWER" + "UNICODE-FULL-CASE-UPPER" + "UNICODE-FULL-CASE-TITLE" + "UNICODE-CATEGORY" + "+UNICODE-CATEGORY-LOWER+" + "+UNICODE-CATEGORY-OTHER+" + "+UNICODE-CATEGORY-GRAPHIC+" + "+UNICODE-CATEGORY-UPPER+" + "+UNICODE-CATEGORY-TITLE+" + "LOAD-ALL-UNICODE-DATA" + "SURROGATES")) (defpackage "EVAL" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" @@ -2432,4 +2442,14 @@ "LAST-FWRAPPER" "DO-FWRAPPERS")) +(defpackage "UNICODE" + (:use "COMMON-LISP") + (:shadow "STRING-CAPITALIZE" + "STRING-DOWNCASE" + "STRING-UPCASE") + (:export "STRING-CAPITALIZE" + "STRING-DOWNCASE" + "STRING-UPCASE" + "STRING-NEXT-WORD-BREAK")) + diff --git a/src/code/string.lisp b/src/code/string.lisp index 5176edf..8005cda 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -30,7 +30,7 @@ nstring-capitalize)) #+unicode -(export '(string-to-nfd string-to-nfkd string-to-nfkc)) +(export '(string-to-nfd string-to-nfkd string-to-nfkc surrogates)) (declaim (inline surrogatep surrogates-to-codepoint codepoint surrogates)) @@ -159,7 +159,7 @@ ;;; With-One-String is used to set up some string hacking things. The keywords ;;; are parsed, and the string is hacked into a simple-string. -(eval-when (compile) +(eval-when (compile load eval) (defmacro with-one-string (string start end cum-offset &rest forms) `(let ((,string (if (stringp ,string) ,string (string ,string)))) @@ -594,7 +594,9 @@ (setf (schar string i) fill-char)) (make-string count))) -(defun string-upcase-simple (string &key (start 0) end) +(defun string-upcase (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with all + lower case alphabetic characters converted to uppercase." (declare (fixnum start)) (let* ((string (if (stringp string) string (string string))) (slen (length string))) @@ -634,54 +636,9 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+unicode -(defun string-upcase-full (string &key (start 0) end) - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (s) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - (write-string string s :start offset :end start) - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (multiple-value-bind (code wide) - (codepoint string index) - (when wide (incf index)) - ;; Handle ASCII specially because this is called early in - ;; initialization, before unidata is available. - (cond ((< 96 code 123) - (write-char (code-char (decf code 32)) s)) - ((> code 127) - (write-string (unicode-full-case-upper code) s)) - (t - (multiple-value-bind (hi lo) - (surrogates code) - (write-char hi s) - (when lo - (write-char lo s))))))) - (write-string string s :start end :end offset-slen)))))) - -(defun string-upcase (string &key (start 0) end #+unicode (casing :simple)) - #-unicode +(defun string-downcase (string &key (start 0) end) _N"Given a string, returns a new string that is a copy of it with all - lower case alphabetic characters converted to uppercase." - #+unicode - _N"Given a string, returns a new string that is a copy of it with all - lower case alphabetic characters converted to uppercase. Casing is - :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - #-unicode - (string-upcase-simple string :start start :end end) - #+unicode - (if (eq casing :simple) - (string-upcase-simple string :start start :end end) - (string-upcase-full string :start start :end end))) - -(defun string-downcase-simple (string &key (start 0) end) + upper case alphabetic characters converted to lowercase." (declare (fixnum start)) (let* ((string (if (stringp string) string (string string))) (slen (length string))) @@ -720,54 +677,12 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+unicode -(defun string-downcase-full (string &key (start 0) end) - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (s) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - (write-string string s :start offset :end start) - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (multiple-value-bind (code wide) - (codepoint string index) - (when wide (incf index)) - ;; Handle ASCII specially because this is called early in - ;; initialization, before unidata is available. - (cond ((< 64 code 91) - (write-char (code-char (incf code 32)) s)) - ((> code 127) - (write-string (unicode-full-case-lower code) s)) - (t - (multiple-value-bind (hi lo) - (surrogates code) - (write-char hi s) - (when lo - (write-char lo s))))))) - (write-string string s :start end :end offset-slen)))))) - -(defun string-downcase (string &key (start 0) end #+unicode (casing :simple)) - #-unicode - _N"Given a string, returns a new string that is a copy of it with all - upper case alphabetic characters converted to lowercase." - #+unicode - _N"Given a string, returns a new string that is a copy of it with all - upper case alphabetic characters converted to lowercase. Casing is - :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - #-unicode - (string-downcase-simple string :start start :end end) - #+unicode - (if (eq casing :simple) - (string-downcase-simple string :start start :end end) - (string-downcase-full string :start start :end end))) - -(defun string-capitalize-simple (string &key (start 0) end) +(defun string-capitalize (string &key (start 0) end) + _N"Given a string, returns a copy of the string with the first + character of each ``word'' converted to upper-case, and remaining + chars in the word converted to lower case. A ``word'' is defined + to be a string of case-modifiable characters delimited by + non-case-modifiable chars." (declare (fixnum start)) (let* ((string (if (stringp string) string (string string))) (slen (length string))) @@ -804,74 +719,6 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+unicode -(defun string-capitalize-full (string &key (start 0) end) - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (s) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - (write-string string s :start offset :end start) - (flet ((alphanump (m) - (or (< 47 m 58) (< 64 m 91) (< 96 m 123) - #+(and unicode (not unicode-bootstrap)) - (and (> m 127) - (<= +unicode-category-letter+ (unicode-category m) - (+ +unicode-category-letter+ #x0F)))))) - (do ((index start (1+ index)) - (newword t)) - ((= index (the fixnum end))) - (declare (fixnum index)) - (multiple-value-bind (code wide) - (codepoint string index) - (when wide (incf index)) - (cond ((not (alphanump code)) - (multiple-value-bind (hi lo) - (surrogates code) - (write-char hi s) - (when lo (write-char lo s))) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (write-string (unicode-full-case-title code) s) - (setq newword ())) - ;;char is case-modifiable, but not first - (t - (write-string (unicode-full-case-lower code) s)))))) - (write-string string s :start end :end offset-slen)))))) - -(defun string-capitalize (string &key (start 0) end - #+unicode (casing :simple) - #+unicode unicode-word-break) - #-unicode - _N"Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - #+unicode - _N"Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. Casing is :simple or - :full for simple or full case conversion, respectively. If - Unicode-Word-Break is non-Nil, then the Unicode word-breaking - algorithm is used to determine the word boundaries. Otherwise, A - ``word'' is defined to be a string of case-modifiable characters - delimited by non-case-modifiable chars. " - - (declare (fixnum start)) - #-unicode - (string-capitalize-simple string :start start :end end) - #+unicode - (if unicode-word-break - (string-capitalize-unicode string :start start :end end :casing casing) - (if (eq casing :simple) - (string-capitalize-simple string :start start :end end) - (string-capitalize-full string :start start :end end)))) - (defun nstring-upcase (string &key (start 0) end) "Given a string, returns that string with all lower case alphabetic characters converted to uppercase." @@ -1390,322 +1237,6 @@ (if (simple-string-p string) string (coerce string 'simple-string))) -;;; -;;; This is a Lisp translation of the Scheme code from William -;;; D. Clinger that implements the word-breaking algorithm. This is -;;; used with permission. -;;; -;;; This version is modified from the original at -;;; http://www.ccs.neu.edu/home/will/R6RS/ to conform to CMUCL's -;;; implementation of the word break properties. -;;; -;;; -;;; Copyright statement and original comments: -;;; -;;;-------------------------------------------------------------------------------- - -;; Copyright 2006 William D Clinger. -;; -;; Permission to copy this software, in whole or in part, to use this -;; software for any lawful purpose, and to redistribute this software -;; is granted subject to the restriction that all copies made of this -;; software must include this copyright and permission notice in full. -;; -;; I also request that you send me a copy of any improvements that you -;; make to this software so that they may be incorporated within it to -;; the benefit of the Scheme community. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Word-breaking as defined by Unicode Standard Annex #29. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Implementation notes. -;; -;; The string-foldcase, string-downcase, and string-titlecase -;; procedures rely on the notion of a word, which is defined -;; by Unicode Standard Annex 29. -;; -;; The string-foldcase and string-downcase procedures rely on -;; word boundaries only when they encounter a Greek sigma, so -;; their performance should not be greatly affected by the -;; performance of the word-breaking algorithm. -;; -;; The string-titlecase procedure must find all word boundaries, -;; but it is typically used on short strings (titles). -;; -;; Hence the performance of the word-breaking algorithm should -;; not matter too much for this reference implementation. -;; Word-breaking is more generally useful, however, so I tried -;; to make this implementation reasonably efficient. -;; -;; Word boundaries are defined by 14 different rules in -;; Unicode Standard Annex #29, and by GraphemeBreakProperty.txt -;; and WordBreakProperty.txt. See also WordBreakTest.html. -;; -;; My original implementation of those specifications failed -;; 6 of the 494 tests in auxiliary/WordBreakTest.txt, but it -;; appeared to me that those tests were inconsistent with the -;; word-breaking rules in UAX #29. John Cowan forwarded my -;; bug report to the Unicode experts, and Mark Davis responded -;; on 29 May 2007: -;; -;; Thanks for following up on this. I think you have found a problem in the -;; formulation of word break, not the test. The intention was to break after a -;; Sep character, as is done in Sentence break. So my previous suggestion was -;; incorrect; instead, what we need is a new rule: -;; -;; *Break after paragraph separators.* -;; WB3a. Sep � -;; I'll make a propose to the UTC for this. -;; -;; Here is Will's translation of those rules (including WB3a) -;; into a finite state machine that searches forward within a -;; string, looking for the next position at which a word break -;; is allowed. The current state consists of an index i into -;; the string and a summary of the left context whose rightmost -;; character is at index i. The left context is usually -;; determined by the character at index i, but there are three -;; complications: -;; -;; Extend and Format characters are ignored unless they -;; follow a separator or the beginning of the text. -;; ALetter followed by MidLetter is treated specially. -;; Numeric followed by MidNum is treated specially. -;; -;; In the implementation below, the left context ending at i -;; is encoded by the following symbols: -;; -;; CR -;; Sep (excluding CR) -;; ALetter -;; MidLetter -;; ALetterMidLetter (ALetter followed by MidLetter) -;; Numeric -;; MidNum -;; NumericMidNum (Numeric followed by MidNum) -;; Katakana -;; ExtendNumLet -;; other (none of the above) -;; -;; Given a string s and an exact integer i (which need not be -;; a valid index into s), returns the index of the next character -;; that is not part of the word containing the character at i, -;; or the length of s if the word containing the character at i -;; extends through the end of s. If i is negative or a valid -;; index into s, then the returned value will be greater than i. -;; -;;;-------------------------------------------------------------------------------- - -(defun string-next-word-break (s i) - (let ((n (length s))) - (labels - ((char-word-break-category (c) - ;; Map our unicode word break property into what this - ;; algorithm wants. - (let ((cat (lisp::unicode-word-break c))) - (case cat - ((:lf :cr :newline) - :sep) - ((:extend :format) - :extend-or-format) - (otherwise cat)))) - (left-context (i) - ;; Given a valid index i into s, returns the left context - ;; at i. - (multiple-value-bind (c widep) - (lisp::codepoint s i n) - (let* ((back - ;; If we're at a regular character or a leading - ;; surrogate, decrementing by 1 gets us the to - ;; previous character. But for a trailing - ;; surrogate, we need to decrement by 2! - (if (eql widep -1) - 2 - 1)) - (cat (char-word-break-category c))) - (case cat - ((:sep) - (if (= c (char-code #\return)) :cr cat)) - ((:midletter :midnumlet) - (let ((i-1 (- i back))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :aletter)) - :aletter-midletter - cat))) - ((:midnum :midnumlet) - (let ((i-1 (- i back))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :numeric)) - :numeric-midnum - cat))) - ((:extendorformat) - (if (< 0 i) - (left-context (- i back)) - :other)) - (otherwise cat))))) - - (index-of-previous-non-ignored (j) - ;; Returns the index of the last non-Extend, non-Format - ;; character within (substring s 0 j). Should not be - ;; called unless such a character exists. - - (let* ((j1 (- j 1))) - (multiple-value-bind (c widep) - (lisp::codepoint s j1) - (when (eql widep -1) - ;; Back up one more if we're at the trailing - ;; surrogate. - (decf j1)) - (let ((cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (index-of-previous-non-ignored j1)) - (otherwise j1)))))) - - (lookup (j context) - ;; Given j and the context to the left of (not including) j, - ;; returns the index at the start of the next word - ;; (or before which a word break is permitted). - - (if (>= j n) - (case context - ((:aletter-midletter :numeric-midnum) - (let ((j (index-of-previous-non-ignored n))) - (if (< i j) j n))) - (otherwise n)) - (multiple-value-bind (c widep) - (lisp::codepoint s j) - (let* ((next-j - ;; The next character is either 1 or 2 code - ;; units away. For a leading surrogate, it's - ;; 2; Otherwise just 1. - (if (eql widep 1) - 2 - 1)) - (cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (case context - ((:cr :sep) j) - (otherwise (lookup (+ j next-j) context)))) - (otherwise - (case context - ((:cr) - (if (= c (char-code #\linefeed)) - ;; Rule WB3: Don't break CRLF, continue looking - (lookup (+ j next-j) cat) - j)) - ((:aletter) - (case cat - ((:aletter :numeric :extendnumlet) - ;; Rules WB5, WB9, ? - (lookup (+ j next-j) cat)) - ((:midletter :midnumlet) - ;; Rule WB6, need to keep looking - (lookup (+ j next-j) :aletter-midletter)) - (otherwise j))) - ((:aletter-midletter) - (case cat - ((:aletter) - ;; Rule WB7 - (lookup (+ j next-j) cat)) - (otherwise - ;; Rule WB6 and WB7 were extended, but the - ;; region didn't end with :aletter. So - ;; backup and break at that point. - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:numeric) - (case cat - ((:numeric :aletter :extendnumlet) - ;; Rules WB8, WB10, ? - (lookup (+ j next-j) cat)) - ((:midnum :midnumlet) - ;; Rules WB11, need to keep looking - (lookup (+ j next-j) :numeric-midnum)) - (otherwise j))) - ((:numeric-midnum) - (case cat - ((:numeric) - ;; Rule WB11, keep looking - (lookup (+ j next-j) cat)) - (otherwise - ;; Rule WB11, WB12 were extended, but the - ;; region didn't end with :numeric, so - ;; backup and break at that point. - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:midletter :midnum :midnumlet) - ;; Rule WB14 - j) - ((:katakana) - (case cat - ((:katakana :extendnumlet) - ;; Rule WB13, WB13a - (lookup (+ j next-j) cat)) - (otherwise j))) - ((:extendnumlet) - (case cat - ((:extendnumlet :aletter :numeric :katakana) - ;; Rule WB13a, WB13b - (lookup (+ j next-j) cat)) - (otherwise j))) - ((:regional_indicator) - (case cat - ((:regional_indicator) - ;; Rule WB13c - (lookup (+ j next-j) cat)) - (otherwise j))) - (otherwise j))))))))) - (declare (notinline lookup left-context)) - (cond ((< i 0) - ;; Rule WB1 - 0) - ((<= n i) - ;; Rule WB2 - n) - (t - (multiple-value-bind (c widep) - (lisp::codepoint s i) - (declare (ignore c)) - (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) - -(defun string-capitalize-unicode (string &key (start 0) end (casing :simple)) - (declare (type (member :simple :full) casing)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (result) - (lisp::with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - - (write-string string result :start 0 :end start) - (let ((upper (ecase casing - (:simple - #'(lambda (ch) - (multiple-value-bind (hi lo) - (lisp::surrogates (lisp::unicode-upper ch)) - (write-char hi result) - (when lo (write-char lo result))))) - (:full - #'(lambda (ch) - (write-string (lisp::unicode-full-case-title ch) result)))))) - (do ((start start next) - (next (string-next-word-break string start) - (string-next-word-break string next))) - ((or (= start next) - (>= start end))) - ;; Convert the first character of the word to upper - ;; case, and then make the rest of the word lowercase. - (funcall upper (lisp::codepoint string start)) - (write-string (string-downcase string :start (1+ start) :end next :casing casing) - result :start (1+ start) :end next))) - (write-string string result :start end :end offset-slen)))))) - - ;; Some utilities (defun codepoints-string (seq) "Convert a sequence of codepoints to a string. Codepoints outside diff --git a/src/code/unicode.lisp b/src/code/unicode.lisp new file mode 100644 index 0000000..98fe880 --- /dev/null +++ b/src/code/unicode.lisp @@ -0,0 +1,519 @@ +;;; -*- Log: code.log; Package: Unicode -*- +;;; +;;; ********************************************************************** +;;; 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/unicode.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Functions to process Unicode strings for CMU Common Lisp +;;; Written by Paul Foley and Raymond Toy. +;;; +;;; **************************************************************** +;;; +(in-package "UNICODE") +(intl:textdomain "cmucl") + +;; An example where this differs from cl:string-upcase differ: +;; #\Latin_Small_Letter_Sharp_S +(defun string-upcase-full (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with + all lower case alphabetic characters converted to uppercase using + full case conversion." + (declare (fixnum start)) (let* ((string (if + (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (s) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + (write-string string s :start offset :end start) + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (multiple-value-bind (code wide) + (lisp:codepoint string index) + (when wide (incf index)) + ;; Handle ASCII specially because this is called early in + ;; initialization, before unidata is available. + (cond ((< 96 code 123) + (write-char (code-char (decf code 32)) s)) + ((> code 127) + (write-string (lisp:unicode-full-case-upper code) s)) + (t + (multiple-value-bind (hi lo) + (surrogates code) + (write-char hi s) + (when lo + (write-char lo s))))))) + (write-string string s :start end :end offset-slen)))))) + +(defun string-upcase (string &key (start 0) end (casing :full)) + _N"Given a string, returns a new string that is a copy of it with + all lower case alphabetic characters converted to uppercase. Casing + is :simple or :full for simple or full case conversion, + respectively." + (declare (fixnum start)) + (if (eq casing :simple) + (cl:string-upcase string :start start :end end) + (string-upcase-full string :start start :end end))) + + +;; An example this differs from cl:string-downcase: +;; #\Latin_Capital_Letter_I_With_Dot_Above. +(defun string-downcase-full (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with + all uppercase alphabetic characters converted to lowercase using + full case conversion.." + (declare (fixnum start)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (s) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + (write-string string s :start offset :end start) + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (multiple-value-bind (code wide) + (lisp:codepoint string index) + (when wide (incf index)) + ;; Handle ASCII specially because this is called early in + ;; initialization, before unidata is available. + (cond ((< 64 code 91) + (write-char (code-char (incf code 32)) s)) + ((> code 127) + (write-string (lisp:unicode-full-case-lower code) s)) + (t + ;; Handle codes below 64 + (multiple-value-bind (hi lo) + (surrogates code) + (write-char hi s) + (when lo + (write-char lo s))))))) + (write-string string s :start end :end offset-slen)))))) + +(defun string-downcase (string &key (start 0) end (casing :full)) + _N"Given a string, returns a new string that is a copy of it with all + uppercase alphabetic characters converted to lowercase. Casing is + :simple or :full for simple or full case conversion, respectively." + + (declare (fixnum start)) + (if (eq casing :simple) + (cl:string-downcase string :start start :end end) + (string-downcase-full string :start start :end end))) + + +;;; +;;; This is a Lisp translation of the Scheme code from William +;;; D. Clinger that implements the word-breaking algorithm. This is +;;; used with permission. +;;; +;;; This version is modified from the original at +;;; http://www.ccs.neu.edu/home/will/R6RS/ to conform to CMUCL's +;;; implementation of the word break properties. +;;; +;;; +;;; Copyright statement and original comments: +;;; +;;;-------------------------------------------------------------------------------- + +;; Copyright 2006 William D Clinger. +;; +;; Permission to copy this software, in whole or in part, to use this +;; software for any lawful purpose, and to redistribute this software +;; is granted subject to the restriction that all copies made of this +;; software must include this copyright and permission notice in full. +;; +;; I also request that you send me a copy of any improvements that you +;; make to this software so that they may be incorporated within it to +;; the benefit of the Scheme community. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Word-breaking as defined by Unicode Standard Annex #29. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Implementation notes. +;; +;; The string-foldcase, string-downcase, and string-titlecase +;; procedures rely on the notion of a word, which is defined +;; by Unicode Standard Annex 29. +;; +;; The string-foldcase and string-downcase procedures rely on +;; word boundaries only when they encounter a Greek sigma, so +;; their performance should not be greatly affected by the +;; performance of the word-breaking algorithm. +;; +;; The string-titlecase procedure must find all word boundaries, +;; but it is typically used on short strings (titles). +;; +;; Hence the performance of the word-breaking algorithm should +;; not matter too much for this reference implementation. +;; Word-breaking is more generally useful, however, so I tried +;; to make this implementation reasonably efficient. +;; +;; Word boundaries are defined by 14 different rules in +;; Unicode Standard Annex #29, and by GraphemeBreakProperty.txt +;; and WordBreakProperty.txt. See also WordBreakTest.html. +;; +;; My original implementation of those specifications failed +;; 6 of the 494 tests in auxiliary/WordBreakTest.txt, but it +;; appeared to me that those tests were inconsistent with the +;; word-breaking rules in UAX #29. John Cowan forwarded my +;; bug report to the Unicode experts, and Mark Davis responded +;; on 29 May 2007: +;; +;; Thanks for following up on this. I think you have found a problem in the +;; formulation of word break, not the test. The intention was to break after a +;; Sep character, as is done in Sentence break. So my previous suggestion was +;; incorrect; instead, what we need is a new rule: +;; +;; *Break after paragraph separators.* +;; WB3a. Sep � +;; I'll make a propose to the UTC for this. +;; +;; Here is Will's translation of those rules (including WB3a) +;; into a finite state machine that searches forward within a +;; string, looking for the next position at which a word break +;; is allowed. The current state consists of an index i into +;; the string and a summary of the left context whose rightmost +;; character is at index i. The left context is usually +;; determined by the character at index i, but there are three +;; complications: +;; +;; Extend and Format characters are ignored unless they +;; follow a separator or the beginning of the text. +;; ALetter followed by MidLetter is treated specially. +;; Numeric followed by MidNum is treated specially. +;; +;; In the implementation below, the left context ending at i +;; is encoded by the following symbols: +;; +;; CR +;; Sep (excluding CR) +;; ALetter +;; MidLetter +;; ALetterMidLetter (ALetter followed by MidLetter) +;; Numeric +;; MidNum +;; NumericMidNum (Numeric followed by MidNum) +;; Katakana +;; ExtendNumLet +;; other (none of the above) +;; +;; Given a string s and an exact integer i (which need not be +;; a valid index into s), returns the index of the next character +;; that is not part of the word containing the character at i, +;; or the length of s if the word containing the character at i +;; extends through the end of s. If i is negative or a valid +;; index into s, then the returned value will be greater than i. +;; +;;;-------------------------------------------------------------------------------- + +(defun string-next-word-break (s i) + _N"Given a string, S, and a starting index, return the index of the + next character that is not part of the word containing the character + at the index, or the length of S if the word containing the + character extends to the end of S. If the index is negative or + valid index into S, the returned value will be strictly greater than + the index." + (let ((n (length s))) + (labels + ((char-word-break-category (c) + ;; Map our unicode word break property into what this + ;; algorithm wants. + (let ((cat (lisp::unicode-word-break c))) + (case cat + ((:lf :cr :newline) + :sep) + ((:extend :format) + :extend-or-format) + (otherwise cat)))) + (left-context (i) + ;; Given a valid index i into s, returns the left context + ;; at i. + (multiple-value-bind (c widep) + (lisp:codepoint s i n) + (let* ((back + ;; If we're at a regular character or a leading + ;; surrogate, decrementing by 1 gets us the to + ;; previous character. But for a trailing + ;; surrogate, we need to decrement by 2! + (if (eql widep -1) + 2 + 1)) + (cat (char-word-break-category c))) + (case cat + ((:sep) + (if (= c (char-code #\return)) :cr cat)) + ((:midletter :midnumlet) + (let ((i-1 (- i back))) + (if (and (<= 0 i-1) + (eq (left-context i-1) :aletter)) + :aletter-midletter + cat))) + ((:midnum :midnumlet) + (let ((i-1 (- i back))) + (if (and (<= 0 i-1) + (eq (left-context i-1) :numeric)) + :numeric-midnum + cat))) + ((:extendorformat) + (if (< 0 i) + (left-context (- i back)) + :other)) + (otherwise cat))))) + + (index-of-previous-non-ignored (j) + ;; Returns the index of the last non-Extend, non-Format + ;; character within (substring s 0 j). Should not be + ;; called unless such a character exists. + + (let* ((j1 (- j 1))) + (multiple-value-bind (c widep) + (lisp:codepoint s j1) + (when (eql widep -1) + ;; Back up one more if we're at the trailing + ;; surrogate. + (decf j1)) + (let ((cat (char-word-break-category c))) + (case cat + ((:extend-or-format) + (index-of-previous-non-ignored j1)) + (otherwise j1)))))) + + (lookup (j context) + ;; Given j and the context to the left of (not including) j, + ;; returns the index at the start of the next word + ;; (or before which a word break is permitted). + + (if (>= j n) + (case context + ((:aletter-midletter :numeric-midnum) + (let ((j (index-of-previous-non-ignored n))) + (if (< i j) j n))) + (otherwise n)) + (multiple-value-bind (c widep) + (lisp:codepoint s j) + (let* ((next-j + ;; The next character is either 1 or 2 code + ;; units away. For a leading surrogate, it's + ;; 2; Otherwise just 1. + (if (eql widep 1) + 2 + 1)) + (cat (char-word-break-category c))) + (case cat + ((:extend-or-format) + (case context + ((:cr :sep) j) + (otherwise (lookup (+ j next-j) context)))) + (otherwise + (case context + ((:cr) + (if (= c (char-code #\linefeed)) + ;; Rule WB3: Don't break CRLF, continue looking + (lookup (+ j next-j) cat) + j)) + ((:aletter) + (case cat + ((:aletter :numeric :extendnumlet) + ;; Rules WB5, WB9, ? + (lookup (+ j next-j) cat)) + ((:midletter :midnumlet) + ;; Rule WB6, need to keep looking + (lookup (+ j next-j) :aletter-midletter)) + (otherwise j))) + ((:aletter-midletter) + (case cat + ((:aletter) + ;; Rule WB7 + (lookup (+ j next-j) cat)) + (otherwise + ;; Rule WB6 and WB7 were extended, but the + ;; region didn't end with :aletter. So + ;; backup and break at that point. + (let ((j2 (index-of-previous-non-ignored j))) + (if (< i j2) j2 j))))) + ((:numeric) + (case cat + ((:numeric :aletter :extendnumlet) + ;; Rules WB8, WB10, ? + (lookup (+ j next-j) cat)) + ((:midnum :midnumlet) + ;; Rules WB11, need to keep looking + (lookup (+ j next-j) :numeric-midnum)) + (otherwise j))) + ((:numeric-midnum) + (case cat + ((:numeric) + ;; Rule WB11, keep looking + (lookup (+ j next-j) cat)) + (otherwise + ;; Rule WB11, WB12 were extended, but the + ;; region didn't end with :numeric, so + ;; backup and break at that point. + (let ((j2 (index-of-previous-non-ignored j))) + (if (< i j2) j2 j))))) + ((:midletter :midnum :midnumlet) + ;; Rule WB14 + j) + ((:katakana) + (case cat + ((:katakana :extendnumlet) + ;; Rule WB13, WB13a + (lookup (+ j next-j) cat)) + (otherwise j))) + ((:extendnumlet) + (case cat + ((:extendnumlet :aletter :numeric :katakana) + ;; Rule WB13a, WB13b + (lookup (+ j next-j) cat)) + (otherwise j))) + ((:regional_indicator) + (case cat + ((:regional_indicator) + ;; Rule WB13c + (lookup (+ j next-j) cat)) + (otherwise j))) + (otherwise j))))))))) + (declare (notinline lookup left-context)) + (cond ((< i 0) + ;; Rule WB1 + 0) + ((<= n i) + ;; Rule WB2 + n) + (t + (multiple-value-bind (c widep) + (lisp:codepoint s i) + (declare (ignore c)) + (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) + +(defun string-capitalize-unicode (string &key (start 0) end (casing :simple)) + "Capitalize String using the Unicode word-break algorithm to find + the words in String. The beginning is capitalized depending on the + value of Casing" + (declare (type (member :simple :full :title) casing)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (result) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + + (write-string string result :start 0 :end start) + (let ((upper (ecase casing + (:simple + #'(lambda (ch) + (multiple-value-bind (hi lo) + (lisp::surrogates (lisp::unicode-upper ch)) + (write-char hi result) + (when lo (write-char lo result))))) + (:full + #'(lambda (ch) + (write-string (lisp::unicode-full-case-upper ch) result))) + (:title + #'(lambda (ch) + (write-string (lisp::unicode-full-case-title ch) result)))))) + (do ((start start next) + (next (string-next-word-break string start) + (string-next-word-break string next))) + ((or (= start next) + (>= start end))) + ;; Convert the first character of the word to upper + ;; case, and then make the rest of the word lowercase. + (funcall upper (lisp:codepoint string start)) + (write-string (string-downcase string :start (1+ start) + :end next + :casing casing) + result + :start (1+ start) + :end next))) + (write-string string result :start end :end offset-slen)))))) + +(defun string-capitalize-full (string &key (start 0) end (casing :full)) + "Capitalize String using the Common Lisp word-break algorithm to find + the words in String. The beginning is capitalized depending on the + value of Casing" + (declare (fixnum start) + (type (member :simple :full :title) casing)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (s) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + (write-string string s :start offset :end start) + (flet ((alphanump (m) + (or (< 47 m 58) (< 64 m 91) (< 96 m 123) + #+(and unicode (not unicode-bootstrap)) + (and (> m 127) + (<= lisp::+unicode-category-letter+ + (lisp::unicode-category m) + (+ lisp::+unicode-category-letter+ #x0F))))) + (upper (ch) + (ecase casing + (:simple + #'(lambda (ch) + (multiple-value-bind (hi lo) + (lisp::surrogates (lisp::unicode-upper ch)) + (write-char hi s) + (when lo (write-char lo s))))) + (:full + #'(lambda (ch) + (write-string (lisp::unicode-full-case-upper ch) s))) + (:title + #'(lambda (ch) + (write-string (lisp::unicode-full-case-title ch) s)))))) + (do ((index start (1+ index)) + (newword t)) + ((= index (the fixnum end))) + (declare (fixnum index)) + (multiple-value-bind (code wide) + (lisp:codepoint string index) + (when wide (incf index)) + (cond ((not (alphanump code)) + (multiple-value-bind (hi lo) + (surrogates code) + (write-char hi s) + (when lo (write-char lo s))) + (setq newword t)) + (newword + ;; Char is first case-modifiable after non-case-modifiable + (funcall upper code) + (setq newword ())) + (t + ;; char is case-modifiable, but not first + (write-string (lisp:unicode-full-case-lower code) s)))))) + (write-string string s :start end :end offset-slen)))))) + +(defun string-capitalize (string &key (start 0) end + (casing :title) + (unicode-word-break t)) + _N"Given a string, returns a copy of the string with the first + character of each ``word'' converted to upper-case, and remaining + chars in the word converted to lower case. Casing is :simple, :full + or :title for simple, full or title case conversion, respectively. If + Unicode-Word-Break is non-Nil, then the Unicode word-breaking + algorithm is used to determine the word boundaries. Otherwise, A + ``word'' is defined to be a string of case-modifiable characters + delimited by non-case-modifiable chars. " + + (declare (fixnum start) + (type (member :simple :full :title) casing)) + (if unicode-word-break + (string-capitalize-unicode string :start start :end end :casing casing) + (if (eq casing :simple) + (cl:string-capitalize string :start start :end end) + (string-capitalize-full string :start start :end end :casing casing)))) diff --git a/src/code/unidata.lisp b/src/code/unidata.lisp index 55e3a28..3518100 100644 --- a/src/code/unidata.lisp +++ b/src/code/unidata.lisp @@ -18,6 +18,15 @@ (export '(string-to-nfd string-to-nfkc string-to-nfkd string-to-nfc unicode-complete unicode-complete-name + unicode-full-case-lower + unicode-full-case-upper + unicode-full-case-title + unicode-category + +unicode-category-lower+ + +unicode-category-other+ + +unicode-category-graphic+ + +unicode-category-upper+ + +unicode-category-title+ load-all-unicode-data)) (defvar *unidata-path* #p"ext-formats:unidata.bin") diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 5229915..052b4c1 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -851,13 +851,11 @@ (sequence stringable) simple-string (flushable)) (defknown (string-upcase string-downcase) - (stringable &key (:start index) (:end sequence-end) #+unicode (:casing case-conversion-type)) + (stringable &key (:start index) (:end sequence-end)) simple-string (flushable)) (defknown (string-capitalize) - (stringable &key (:start index) (:end sequence-end) - #+unicode (:casing case-conversion-type) - #+unicode (:unicode-word-break boolean)) + (stringable &key (:start index) (:end sequence-end)) simple-string (flushable)) (defknown (nstring-upcase nstring-downcase nstring-capitalize) diff --git a/src/tools/worldbuild.lisp b/src/tools/worldbuild.lisp index 9d0dbb6..4b5f364 100644 --- a/src/tools/worldbuild.lisp +++ b/src/tools/worldbuild.lisp @@ -186,6 +186,8 @@ ,@(when (c:backend-featurep :mp) '("target:code/multi-proc")) "target:code/intl-tramp" + ,@(when (c::backend-featurep :unicode) + '("target:code/unicode")) )) (setf *genesis-core-name* "target:lisp/kernel.core") diff --git a/src/tools/worldcom.lisp b/src/tools/worldcom.lisp index f8ac65a..150d33c 100644 --- a/src/tools/worldcom.lisp +++ b/src/tools/worldcom.lisp @@ -324,6 +324,8 @@ (comf "target:code/intl-tramp") (comf "target:code/intl") +(when (c:backend-featurep :unicode) + (comf "target:code/unicode")) ); let *byte-compile-top-level* ); with-compiler-log-file commit 9d66b2585eb33ff8106511da512b4772a3887aab Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri May 24 19:18:49 2013 -0700 Fix typo. diff --git a/src/code/multi-proc.lisp b/src/code/multi-proc.lisp index e478a95..4e2b1bc 100644 --- a/src/code/multi-proc.lisp +++ b/src/code/multi-proc.lisp @@ -1977,6 +1977,6 @@ (setf (lock-process ,lock) nil))))))) (defun process-join (process) - (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) - (lambda () (not (mp:process-alive-p thread)))) + (mp:process-wait (format nil "Waiting for thread ~A to complete" process) + (lambda () (not (mp:process-alive-p process)))) (values-list (process-%return-values process))) ----------------------------------------------------------------------- Summary of changes: src/code/exports.lisp | 36 ++- src/code/multi-proc.lisp | 4 +- src/code/string.lisp | 495 +----------------------------------- src/code/unicode.lisp | 519 ++++++++++++++++++++++++++++++++++++++ src/code/unidata.lisp | 9 + src/compiler/fndb.lisp | 6 +- src/general-info/release-20e.txt | 5 + src/tools/worldbuild.lisp | 2 + src/tools/worldcom.lisp | 2 + 9 files changed, 589 insertions(+), 489 deletions(-) create mode 100644 src/code/unicode.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-07-1-gf36a31a
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via f36a31aaf95b60e2cc210648d951b41d3112a73a (commit) from bb56dbb6572939222d731530c3045b4a87ee7f51 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f36a31aaf95b60e2cc210648d951b41d3112a73a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jul 5 06:56:29 2013 -0700 Make NOT-MORE-CONTAGIOUS support member and union types. This change allow cmucl to fold identity operations as in (defun foo (x) (declare (float x)) (* x 1)) Previously, cmucl wouldn't change (* x 1) to just x. because the declaration of x is represented internally as a union type. diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 7888eba..c12251c 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3141,45 +3141,58 @@ ;;; (defun not-more-contagious (x y) (declare (type continuation x y)) - (let ((type1 (continuation-type x)) - (type2 (continuation-type y))) - (if (and (numeric-type-p type1) (numeric-type-p type2)) - (let ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (format1 (numeric-type-format type1)) - (format2 (numeric-type-format type2)) - (complexp1 (numeric-type-complexp type1)) - (complexp2 (numeric-type-complexp type2))) - (cond ((or (null complexp1) (null class1)) Nil) - ((member class1 '(integer rational)) 'T) - ((and (eq class1 'float) (null complexp2)) Nil) - ((and (eq class1 'float) (null class2)) Nil) - ((and (eq class1 'float) (eq class2 'float)) - (and (ecase complexp2 - (:real (eq complexp1 :real)) - (:complex 'T)) - (ecase format2 - ((nil short-float single-float) - (member format1 '(short-float single-float))) - #-double-double - ((double-float long-float) 'T) - #+double-double - (double-float - (member format1 '(short-float single-float - double-float))) - #+long-float - (long-float 'T) - #+double-double - (double-double-float 't)))) - ((and (eq class1 'float) (member class2 '(integer rational))) - Nil) - (t - (error (intl:gettext "Unexpected types: ~s ~s~%") type1 type2))))))) + (let ((x-type (continuation-type x)) + (y-type (continuation-type y))) + (flet + ((not-more-contagious-1 (t1 t2) + (if (and (numeric-type-p t1) (numeric-type-p t2)) + (let ((class1 (numeric-type-class t1)) + (class2 (numeric-type-class t2)) + (format1 (numeric-type-format t1)) + (format2 (numeric-type-format t2)) + (complexp1 (numeric-type-complexp t1)) + (complexp2 (numeric-type-complexp t2))) + (cond ((or (null complexp1) (null class1)) Nil) + ((member class1 '(integer rational)) 'T) + ((and (eq class1 'float) (null complexp2)) Nil) + ((and (eq class1 'float) (null class2)) Nil) + ((and (eq class1 'float) (eq class2 'float)) + (and (ecase complexp2 + (:real (eq complexp1 :real)) + (:complex 'T)) + (ecase format2 + ((nil short-float single-float) + (member format1 '(short-float single-float))) + #-double-double + ((double-float long-float) 'T) + #+double-double + (double-float + (member format1 '(short-float single-float + double-float))) + #+long-float + (long-float 'T) + #+double-double + (double-double-float 't)))) + ((and (eq class1 'float) (member class2 '(integer rational))) + Nil) + (t + (error (intl:gettext "Unexpected types: ~s ~s~%") t1 t2)))))) + (maybe-convert-to-numeric (type) + (if (member-type-p type) + (convert-member-type type) + type))) + (dolist (x (prepare-arg-for-derive-type x-type)) + (dolist (y (prepare-arg-for-derive-type y-type)) + (unless (not-more-contagious-1 + (maybe-convert-to-numeric x) + (maybe-convert-to-numeric y)) + (return-from not-more-contagious nil)))) + t))) ;;; Fold (- x 0). ;;; ;;; If y is not constant, not zerop, or is contagious, or a negative -;;; float -0.0 then give up because (- -0.0 -0.0) is 0.0, not -0.0. +;;; float -0.0 then give up because (- -0.0 0.0) is 0.0, not -0.0. ;;; (deftransform - ((x y) (t (constant-argument number)) * :when :both) "fold zero arg" ----------------------------------------------------------------------- Summary of changes: src/compiler/srctran.lisp | 83 ++++++++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 35 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-05-4-gc1e7b4a
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c1e7b4aad739a7e71d0b0095893df6c257b7724a (commit) from d87bebdf19729956c9a35c734d5d3cced17a5359 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c1e7b4aad739a7e71d0b0095893df6c257b7724a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed May 7 20:42:44 2014 -0700 Oops. Need to add the package prefix for sigcontext. diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp index 33e5ed0..200772f 100644 --- a/src/compiler/ppc/float.lisp +++ b/src/compiler/ppc/float.lisp @@ -1402,7 +1402,7 @@ (export 'get-fp-operands) (defun get-fp-operation (scp) - (declare (type (alien (* sigcontext)) scp)) + (declare (type (alien (* unix:sigcontext)) scp)) ;; Get the offending FP instruction from the context. We return the ;; operation associated with the FP instruction, the precision of ;; the operation, and the operands of the instruction. @@ -1440,7 +1440,7 @@ (values fop format rd ra rb))))) (defun get-fp-operands (scp modes) - (declare (type (alien (* sigcontext)) scp)) + (declare (type (alien (* unix:sigcontext)) scp)) ;; From the offending FP instruction, get the operation and ;; operands, if we can. (multiple-value-bind (fop format rd rs1 rs2) ----------------------------------------------------------------------- Summary of changes: src/compiler/ppc/float.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2013-12-a created. snapshot-2013-12-a
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2013-12-a has been created at df0ffb36456dfa84b53a298757d9e8b432a813e9 (tag) tagging 2527de5ed52be53257a51876fe775630333cfc17 (commit) replaces snapshot-2013-12 tagged by Raymond Toy on Thu Dec 12 17:18:11 2013 -0800 - Log ----------------------------------------------------------------- Snapshot 2013-12-a Fixes a couple of serious issues with sincos support on x86/linux. -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlKqYHQACgkQJ5IjUmgZO7LSdwCfeQAsG8Q+jjjJavQLyuLNoaJ9 GoAAn3DvZx/zrsNTix31Ken5Fo26voJG =YqFa -----END PGP SIGNATURE----- Raymond Toy (1): Make %sincos consistently return sin and cos instead of cos and sin. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-05-11-g19d7d37
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 19d7d37b313c6c252653a6f39f7fbc9c344469f3 (commit) via 55b1eeed5ffe0215cf55149897638ab43c20a003 (commit) from c0a0fc0b9d458cae139b873dc496764d8e8e0113 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 19d7d37b313c6c252653a6f39f7fbc9c344469f3 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jun 16 21:15:46 2014 -0700 Update for snapshot. diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 900898a..1947297 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -78,6 +78,7 @@ New in this release: least-positive-foo-float if possible. * (log -0w0) and (log 0w0) returns values analogous to the double-float versions. + * Fix bug in printint MOST-NEGATIVE-FIXNUM * Trac Tickets: * Ticket #90 fixed. @@ -85,6 +86,7 @@ New in this release: * Ticket #87 fixed. * Ticket #94 fixed. * Ticket #93 fixed. + * Ticket #98 fixed. * Other changes: commit 55b1eeed5ffe0215cf55149897638ab43c20a003 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jun 16 21:15:32 2014 -0700 Regenerate. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index fdbb637..91b8845 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -14662,7 +14662,7 @@ msgid "T and OTHERWISE may not be used as key designators for ~A" msgstr "" #: src/code/macros.lisp -msgid "Bad style to use T or OTHERWISE in ECASE or CCASE" +msgid "Bad style to use ~S in ~S" msgstr "" #: src/code/macros.lisp diff --git a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po index 796760c..c4e0087 100644 --- a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po @@ -20810,8 +20810,9 @@ msgstr "" "~Away" #: src/code/macros.lisp -msgid "Bad style to use T or OTHERWISE in ECASE or CCASE" -msgstr "Adbay tylesay otay useway T orway OTHERWISE inway ECASE orway CCASE" +#, fuzzy +msgid "Bad style to use ~S in ~S" +msgstr "Onay otslay amednay ~S inway ~S" #: src/code/macros.lisp msgid "Supply a new value for ~S." @@ -30707,3 +30708,6 @@ msgstr "" "Ybay efaultday, illegalway inputsway andway illegalway outputsway areway " "eplacedray ybay ethay\n" "Unicodeway eplacementray aracterchay." + +#~ msgid "Bad style to use T or OTHERWISE in ECASE or CCASE" +#~ msgstr "Adbay tylesay otay useway T orway OTHERWISE inway ECASE orway CCASE" diff --git a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po index d705265..f30c434 100644 --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -14690,7 +14690,7 @@ msgid "T and OTHERWISE may not be used as key designators for ~A" msgstr "" #: src/code/macros.lisp -msgid "Bad style to use T or OTHERWISE in ECASE or CCASE" +msgid "Bad style to use ~S in ~S" msgstr "" #: src/code/macros.lisp ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20f.txt | 2 ++ src/i18n/locale/cmucl.pot | 2 +- src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po | 8 ++++++-- src/i18n/locale/ko/LC_MESSAGES/cmucl.po | 2 +- 4 files changed, 10 insertions(+), 4 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-12-gc5f98ef
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c5f98ef90641ec6912e35730b215eaf751841539 (commit) from 80df05a11cc138d18d989a5f8f690627026e3069 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c5f98ef90641ec6912e35730b215eaf751841539 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Aug 17 12:21:27 2014 -0700 Add -ffp-contract=off to make sure no fused-multiply instructions are used. This can have unexpected results, especially in the fdlibm routines if a fused-multiply is used the wrong place. diff --git a/src/lisp/Config.ppc_darwin b/src/lisp/Config.ppc_darwin index eab5efa..4289510 100644 --- a/src/lisp/Config.ppc_darwin +++ b/src/lisp/Config.ppc_darwin @@ -34,7 +34,7 @@ ifdef FEATURE_UNICODE UNICODE = -DUNICODE endif -CFLAGS = $(OSX_VERSION) -g -O3 -DDARWIN -Dppc $(LINKAGE) $(GENCGC) $(UNICODE) +CFLAGS = $(OSX_VERSION) -g -O3 -ffp-contract=off -DDARWIN -Dppc $(LINKAGE) $(GENCGC) $(UNICODE) ASFLAGS = $(OSX_VERSION) -traditional -g -O3 -DDARWIN -Dppc $(LINKAGE) $(GENCGC) UNDEFSYMPATTERN = -Xlinker -u -Xlinker & ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.ppc_darwin | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0