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

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-19-g315ea23
by Raymond Toy 27 Sep '14

27 Sep '14

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 315ea23408772763fc0f141d51bf5038269f0b7c (commit) from b35582689da356d07250728b74f22d7c55e81000 (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 315ea23408772763fc0f141d51bf5038269f0b7c Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Sep 26 20:20:54 2014 -0700 Fix incorrect value from INTEGER-DECODE-FLOAT for denormals. This is a long standing bug where INTEGER-DECODE-FLOAT returned incorrect values for denormal double-float numbers. The lower 32 bits of the double were not shifted enough when creating the integer result. As a side-effect, DECODE-FLOAT decodes denormal double-float's correctly and SCALE-FLOAT scales denormals correctly too. * src/code/float.lisp: * Shift the lower 32-bit of the fraction one more time to adjust for the fact that the upper 20 bits were shifted an extra time. * tests/float.lisp: * Add several tests for INTEGER-DECODE-FLOAT, SCALE-FLOAT, and DECODE-FLOAT. * src/general-info/release-20f.txt: * Add this bug fix to the notes. diff --git a/src/code/float.lisp b/src/code/float.lisp index cace1a4..3ac6512 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -581,7 +581,7 @@ (return)) (setq sig (ash sig 1)) (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) + (values (logior (ash sig 32) (ash low-bits (1+ extra-bias))) (truly-the fixnum (- biased extra-bias)) sign))))) diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 0327f5b..4fd57e3 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -123,6 +123,10 @@ New in this release: * For linux, motifd is no longer a 64-bit app. * (exp 1d0) now returns the correctly rounded value of e. Previously, it was off by one bit. + * INTEGER-DECODE-FLOAT returns the correct values for denormal + doubles. As a side-effect of this fix, DECODE-FLOAT returns the + correct values for denormals, and SCALE-FLOAT scales denormals + correctly. * Trac Tickets: * Ticket #90 fixed. diff --git a/tests/float.lisp b/tests/float.lisp index 55b9013..71cdeb8 100644 --- a/tests/float.lisp +++ b/tests/float.lisp @@ -42,4 +42,77 @@ (assert-equalp k (clog10 x))))) +(define-test integer-decode-float.double + ;; Generate 100 random denormal values and compare what + ;; integer-decode-float returns against what it should return. + (dotimes (k 100) + (let ((x (random least-positive-normalized-double-float))) + (multiple-value-bind (hi lo) + (kernel:double-float-bits x) + ;; Verify that the exponent is 0, which it must be for a + ;; denormal number. + (assert-equal 0 + (ldb vm:double-float-exponent-byte hi) + x) + ;; Print out the fraction bits, and the bits returned by + ;; INTEGER-DECODE-FLOAT. We could do this differently, but + ;; this has the nice side effect of making it easy to see what + ;; is expected and what went wrong. + (let* ((expected (format nil "~b~32,'0b" hi lo)) + (actual (format nil "~b" (integer-decode-float x))) + (tail (subseq actual (length expected)))) + ;; If everything is working correctly, the beginning of the + ;; actual bits must exactly match the expected bits. + (assert-true (every #'char= + expected + actual) + x + expected + actual) + ;; And finally, the trailing part of the actual bits must be + ;; all zeroes, but this is a denormal number. + (assert-true (every #'(lambda (c) + (char= c #\0)) + tail) + x + tail)))))) + +(define-test scale-float.double + ;; As a side-effect of fixing INTEGER-DECODE-FLOAT, SCALE-FLOAT + ;; should return the correct values now when scaling + ;; denormals. Check a few denormal values. + (dotimes (k 100) + (let* ((x (random least-positive-normalized-double-float)) + (scaled (scale-float x 54)) + (mult (* x (scale-float 1d0 54)))) + ;; The result of SCALE-FLOAT and the multiplication should be + ;; exactly equal because the multiplication by 2^54 is exactly + ;; representable. + (assert-equal scaled + mult + x + scaled + mult))) + ;; Add the test caused the investigation of SCALE-FLOAT + (let* ((x 1d-310) + (scaled (scale-float x 54)) + (mult (* x (scale-float 1d0 54)))) + (assert-equal scaled + mult + x + scaled + mult))) + +(define-test decode-float.double + ;; As a side-effect of fixing INTEGER-DECODE-FLOAT, DECODE-FLOAT + ;; should return the correct values now. We just spot check one + ;; value here. + (dotimes (k 100) + (let ((x (random least-positive-normalized-double-float))) + (multiple-value-bind (f e) + (decode-float x) + (assert-equal x + (scale-float f e) + f + e))))) ----------------------------------------------------------------------- Summary of changes: src/code/float.lisp | 2 +- src/general-info/release-20f.txt | 4 +++ tests/float.lisp | 73 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 78 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-18-gb355826
by Raymond Toy 26 Sep '14

26 Sep '14

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 b35582689da356d07250728b74f22d7c55e81000 (commit) from 0855c18dc2b20c196a0f1167765dc87601658d81 (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 b35582689da356d07250728b74f22d7c55e81000 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Sep 25 19:57:41 2014 -0700 Regenerate. 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 c4e0087..df7d5b1 100644 --- a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po @@ -6834,17 +6834,24 @@ msgstr "" "Eturnray uetray ifway ethay oatflay X isway anway infinityway (+ orway -)." #: src/code/float.lisp -msgid "Return true if the float X is a NaN (Not a Number)." +#, fuzzy +msgid "Return true if the float X is a quiet or signaling NaN (Not a Number)." msgstr "" -"Eturnray uetray ifway ethay oatflay X isway away Annay (Otnay away Umbernay)." +"Eturnray uetray ifway ethay oatflay X isway away appingtray Annay (Otnay " +"away Umbernay)." #: src/code/float.lisp -msgid "Return true if the float X is a trapping NaN (Not a Number)." +#, fuzzy +msgid "Return true if the float X is a signaling NaN (Not a Number)." msgstr "" "Eturnray uetray ifway ethay oatflay X isway away appingtray Annay (Otnay " "away Umbernay)." #: src/code/float.lisp +msgid "Deprecated. Use FLOAT-SIGNALING-NAN-P instead." +msgstr "" + +#: src/code/float.lisp msgid "" "Returns a non-negative number of significant digits in it's float argument.\n" " Will be less than FLOAT-DIGITS if denormalized or zero." @@ -23332,6 +23339,7 @@ msgid "Expected ~D variant values: ~S." msgstr "Expectedway ~D ariantvay aluesvay: ~S." #: src/compiler/meta-vmdef.lisp +#, fuzzy msgid "" "Define-VOP (Name [Inherits]) Spec*\n" " Define the symbol Name to be a Virtual OPeration in the compiler. If\n" @@ -23382,9 +23390,9 @@ msgid "" " :To Time-Spec\n" "\t Specify the beginning or end of the operand's lifetime. :From can\n" "\t only be used with results, and :To only with arguments. The default\n" -"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These\n" -"\t options are necessary primarily when operands are read or written out\n" -"\t of order.\n" +"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). (The\n" +" first argument/result is number 0.) These options are necessary\n" +" primarily when operands are read or written out of order.\n" " \n" " :Conditional\n" " This is used in place of :RESULTS with conditional branch VOPs. " @@ -30074,6 +30082,19 @@ msgid "Implements WRITE-SEQUENCE for the stream." msgstr "Implementsway WRITE-SEQUENCE orfay ethay eamstray." #: src/pcl/gray-streams.lisp +#, fuzzy +msgid "Implements FILE-POSITION for the stream." +msgstr "Implementsway WRITE-SEQUENCE orfay ethay eamstray." + +#: src/pcl/gray-streams.lisp +#, fuzzy +msgid "Implements FILE-POSITION for the stream for setting the position." +msgstr "" +"Implementsway CLEAR-INPUT orfay ethay eamstray, eturningray NIL. Ethay " +"efaultday\n" +" ethodmay oesday othingnay." + +#: src/pcl/gray-streams.lisp msgid "" "Used by READ-BYTE; returns either an integer, or the symbol :EOF\n" " if the stream is at end-of-file." @@ -30709,5 +30730,10 @@ msgstr "" "eplacedray ybay ethay\n" "Unicodeway eplacementray aracterchay." +#~ msgid "Return true if the float X is a NaN (Not a Number)." +#~ msgstr "" +#~ "Eturnray uetray ifway ethay oatflay X isway away Annay (Otnay away " +#~ "Umbernay)." + #~ 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 f30c434..b73bf6a 100644 --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -4780,11 +4780,15 @@ msgid "Return true if the float X is an infinity (+ or -)." msgstr "" #: src/code/float.lisp -msgid "Return true if the float X is a NaN (Not a Number)." +msgid "Return true if the float X is a quiet or signaling NaN (Not a Number)." msgstr "" #: src/code/float.lisp -msgid "Return true if the float X is a trapping NaN (Not a Number)." +msgid "Return true if the float X is a signaling NaN (Not a Number)." +msgstr "" + +#: src/code/float.lisp +msgid "Deprecated. Use FLOAT-SIGNALING-NAN-P instead." msgstr "" #: src/code/float.lisp @@ -16359,9 +16363,9 @@ msgid "" " :To Time-Spec\n" "\t Specify the beginning or end of the operand's lifetime. :From can\n" "\t only be used with results, and :To only with arguments. The default\n" -"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These\n" -"\t options are necessary primarily when operands are read or written out\n" -"\t of order.\n" +"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). (The\n" +" first argument/result is number 0.) These options are necessary\n" +" primarily when operands are read or written out of order.\n" " \n" " :Conditional\n" " This is used in place of :RESULTS with conditional branch VOPs. " @@ -21087,6 +21091,14 @@ msgid "Implements WRITE-SEQUENCE for the stream." msgstr "" #: src/pcl/gray-streams.lisp +msgid "Implements FILE-POSITION for the stream." +msgstr "" + +#: src/pcl/gray-streams.lisp +msgid "Implements FILE-POSITION for the stream for setting the position." +msgstr "" + +#: src/pcl/gray-streams.lisp msgid "" "Used by READ-BYTE; returns either an integer, or the symbol :EOF\n" " if the stream is at end-of-file." ----------------------------------------------------------------------- Summary of changes: src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po | 38 ++++++++++++++++++---- src/i18n/locale/ko/LC_MESSAGES/cmucl.po | 22 ++++++++++--- 2 files changed, 49 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch 20f-branch updated. snapshot-2014-09-11-g878f7c4
by Raymond Toy 26 Sep '14

26 Sep '14

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, 20f-branch has been updated via 878f7c4337d04265d067a90d29acca0d868cd35d (commit) from 44697013015d63a72c1dc5b0a62f4331c333931c (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 878f7c4337d04265d067a90d29acca0d868cd35d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Sep 25 20:06:31 2014 -0700 Regenerate. 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 c4e0087..df7d5b1 100644 --- a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po @@ -6834,17 +6834,24 @@ msgstr "" "Eturnray uetray ifway ethay oatflay X isway anway infinityway (+ orway -)." #: src/code/float.lisp -msgid "Return true if the float X is a NaN (Not a Number)." +#, fuzzy +msgid "Return true if the float X is a quiet or signaling NaN (Not a Number)." msgstr "" -"Eturnray uetray ifway ethay oatflay X isway away Annay (Otnay away Umbernay)." +"Eturnray uetray ifway ethay oatflay X isway away appingtray Annay (Otnay " +"away Umbernay)." #: src/code/float.lisp -msgid "Return true if the float X is a trapping NaN (Not a Number)." +#, fuzzy +msgid "Return true if the float X is a signaling NaN (Not a Number)." msgstr "" "Eturnray uetray ifway ethay oatflay X isway away appingtray Annay (Otnay " "away Umbernay)." #: src/code/float.lisp +msgid "Deprecated. Use FLOAT-SIGNALING-NAN-P instead." +msgstr "" + +#: src/code/float.lisp msgid "" "Returns a non-negative number of significant digits in it's float argument.\n" " Will be less than FLOAT-DIGITS if denormalized or zero." @@ -23332,6 +23339,7 @@ msgid "Expected ~D variant values: ~S." msgstr "Expectedway ~D ariantvay aluesvay: ~S." #: src/compiler/meta-vmdef.lisp +#, fuzzy msgid "" "Define-VOP (Name [Inherits]) Spec*\n" " Define the symbol Name to be a Virtual OPeration in the compiler. If\n" @@ -23382,9 +23390,9 @@ msgid "" " :To Time-Spec\n" "\t Specify the beginning or end of the operand's lifetime. :From can\n" "\t only be used with results, and :To only with arguments. The default\n" -"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These\n" -"\t options are necessary primarily when operands are read or written out\n" -"\t of order.\n" +"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). (The\n" +" first argument/result is number 0.) These options are necessary\n" +" primarily when operands are read or written out of order.\n" " \n" " :Conditional\n" " This is used in place of :RESULTS with conditional branch VOPs. " @@ -30074,6 +30082,19 @@ msgid "Implements WRITE-SEQUENCE for the stream." msgstr "Implementsway WRITE-SEQUENCE orfay ethay eamstray." #: src/pcl/gray-streams.lisp +#, fuzzy +msgid "Implements FILE-POSITION for the stream." +msgstr "Implementsway WRITE-SEQUENCE orfay ethay eamstray." + +#: src/pcl/gray-streams.lisp +#, fuzzy +msgid "Implements FILE-POSITION for the stream for setting the position." +msgstr "" +"Implementsway CLEAR-INPUT orfay ethay eamstray, eturningray NIL. Ethay " +"efaultday\n" +" ethodmay oesday othingnay." + +#: src/pcl/gray-streams.lisp msgid "" "Used by READ-BYTE; returns either an integer, or the symbol :EOF\n" " if the stream is at end-of-file." @@ -30709,5 +30730,10 @@ msgstr "" "eplacedray ybay ethay\n" "Unicodeway eplacementray aracterchay." +#~ msgid "Return true if the float X is a NaN (Not a Number)." +#~ msgstr "" +#~ "Eturnray uetray ifway ethay oatflay X isway away Annay (Otnay away " +#~ "Umbernay)." + #~ 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 f30c434..b73bf6a 100644 --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -4780,11 +4780,15 @@ msgid "Return true if the float X is an infinity (+ or -)." msgstr "" #: src/code/float.lisp -msgid "Return true if the float X is a NaN (Not a Number)." +msgid "Return true if the float X is a quiet or signaling NaN (Not a Number)." msgstr "" #: src/code/float.lisp -msgid "Return true if the float X is a trapping NaN (Not a Number)." +msgid "Return true if the float X is a signaling NaN (Not a Number)." +msgstr "" + +#: src/code/float.lisp +msgid "Deprecated. Use FLOAT-SIGNALING-NAN-P instead." msgstr "" #: src/code/float.lisp @@ -16359,9 +16363,9 @@ msgid "" " :To Time-Spec\n" "\t Specify the beginning or end of the operand's lifetime. :From can\n" "\t only be used with results, and :To only with arguments. The default\n" -"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These\n" -"\t options are necessary primarily when operands are read or written out\n" -"\t of order.\n" +"\t for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). (The\n" +" first argument/result is number 0.) These options are necessary\n" +" primarily when operands are read or written out of order.\n" " \n" " :Conditional\n" " This is used in place of :RESULTS with conditional branch VOPs. " @@ -21087,6 +21091,14 @@ msgid "Implements WRITE-SEQUENCE for the stream." msgstr "" #: src/pcl/gray-streams.lisp +msgid "Implements FILE-POSITION for the stream." +msgstr "" + +#: src/pcl/gray-streams.lisp +msgid "Implements FILE-POSITION for the stream for setting the position." +msgstr "" + +#: src/pcl/gray-streams.lisp msgid "" "Used by READ-BYTE; returns either an integer, or the symbol :EOF\n" " if the stream is at end-of-file." ----------------------------------------------------------------------- Summary of changes: src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po | 38 ++++++++++++++++++---- src/i18n/locale/ko/LC_MESSAGES/cmucl.po | 22 ++++++++++--- 2 files changed, 49 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch 20f-branch updated. snapshot-2014-09-10-g4469701
by Raymond Toy 26 Sep '14

26 Sep '14

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, 20f-branch has been updated via 44697013015d63a72c1dc5b0a62f4331c333931c (commit) via bcc8cd7dd797fe3998efdca0cf2adfe49150bb3f (commit) via b51c9978bcfab5952438a1c831949c8f387cfc90 (commit) via 8fb489459a9f50049a5eb8cf3ccc06f8225e98bc (commit) from 02c1bde6f02c195a17d76dc57fd18562ef52bbea (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 44697013015d63a72c1dc5b0a62f4331c333931c Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Sep 25 19:24:02 2014 -0700 Oops. Remove debugging print left in from commit [c0052f55] diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 996b1f3..03f03a0 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -62,7 +62,6 @@ (reader-error-format-arguments condition)) nil error-stream (file-position error-stream))) - (format t "open-stream-p ~A~%" (open-stream-p error-stream)) (format stream (intl:gettext "Reader error ~@[at ~D ~]on ~S:~%~?") (and (open-stream-p error-stream) (file-position error-stream)) commit bcc8cd7dd797fe3998efdca0cf2adfe49150bb3f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Sep 24 20:27:54 2014 -0700 Fix type derivation of the exponent for DECODE-FLOAT. The minimum exponent is from 0, it's from least-positive float. * src/compiler/float-tran.lisp: * Derive the correct minimum exponent by using the exponent from the least-positive float value of the appropriate type. * tests/float-tran.lisp: * Add tests for the derived exponent type for DECODE-FLOAT. Conflicts: tests/float-tran.lisp diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 4aecd5c..ff09474 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -2057,13 +2057,13 @@ (when x (nth-value 1 (decode-float x)))) (min-exp () - ;; Use decode-float on 0 of the appropriate type to find - ;; the min exponent. If we don't know the actual number - ;; format, use double, which has the widest range - ;; (including double-double-float). - (if (numeric-type-format arg) - (nth-value 1 (decode-float (coerce 0 (numeric-type-format arg)))) - (nth-value 1 (decode-float (coerce 0 'double-float))))) + ;; Use decode-float on the least positive float of the + ;; appropriate type to find the min exponent. If we don't + ;; know the actual number format, use double, which has the + ;; widest range (including double-double-float). + (nth-value 1 (decode-float (if (eq 'single-float (numeric-type-format arg)) + least-positive-single-float + least-positive-double-float)))) (max-exp () ;; Use decode-float on the most postive number of the ;; appropriate type to find the max exponent. If we don't diff --git a/tests/float-tran.lisp b/tests/float-tran.lisp index 9c81882..713d399 100644 --- a/tests/float-tran.lisp +++ b/tests/float-tran.lisp @@ -1,3 +1,4 @@ + ;; Tests for various float transformations. (defpackage :float-tran-tests @@ -14,4 +15,18 @@ (assert-equalp (c::make-member-type :members (list 1f0)) (c::decode-float-sign-derive-type-aux (c::specifier-type '(single-float (0f0)))))) - \ No newline at end of file +(define-test decode-float-exp + "Test type derivation of the exponent from decode-float" + (assert-equalp (c::specifier-type '(integer -148 128)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type 'single-float))) + (assert-equalp (c::specifier-type '(integer -1073 1024)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type 'double-float))) + #+double-double + (assert-equalp (c::specifier-type '(integer -1073 1024)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type 'double-double-float))) + (assert-equalp (c::specifier-type '(integer 2 8)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type '(double-float 2d0 128d0))))) commit b51c9978bcfab5952438a1c831949c8f387cfc90 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Sep 19 22:35:27 2014 -0700 Fix error in type derivation for the sign in DECODE-FLOAT. Type derivation of the sign of (DECODE-FLOAT X) returned the incorrect value when x was declared to be of type (DOUBLE-FLOAT (0d0)). * src/compiler/float-tran.lisp * Fix type derivation * tests/float-tran.lisp * New file for tests of DECODE-FLOAT-SIGN-DERIVE-TYPE-AUX. * tests/float.lisp * New file to test that decode-float is compiled correctly. diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index ccb6e06..4aecd5c 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -2082,24 +2082,19 @@ (defun decode-float-sign-derive-type-aux (arg) ;; Derive the sign of the float. - (flet ((calc-sign (x) - (when x - (nth-value 2 (decode-float x))))) - (let* ((lo (bound-func #'calc-sign - (numeric-type-low arg))) - (hi (bound-func #'calc-sign - (numeric-type-high arg)))) - (if (numeric-type-format arg) - (specifier-type `(,(numeric-type-format arg) - ;; If lo or high bounds are NIL, use -1 - ;; or 1 of the appropriate type instead. - ,(or lo (coerce -1 (numeric-type-format arg))) - ,(or hi (coerce 1 (numeric-type-format arg))))) - (specifier-type '(or (member 1f0 -1f0 - 1d0 -1d0 - #+double-double 1w0 - #+double-double -1w0))))))) - + (if (numeric-type-format arg) + (let ((arg-range (interval-range-info (numeric-type->interval arg)))) + (case arg-range + (+ (make-member-type :members (list (coerce 1 (numeric-type-format arg))))) + (- (make-member-type :members (list (coerce -1 (numeric-type-format arg))))) + (otherwise + (make-member-type :members (list (coerce 1 (numeric-type-format arg)) + (coerce -1 (numeric-type-format arg))))))) + (specifier-type '(or (member 1f0 -1f0 + 1d0 -1d0 + #+double-double 1w0 + #+double-double -1w0))))) + (defoptimizer (decode-float derive-type) ((num)) (let ((f (one-arg-derive-type num #'(lambda (arg) diff --git a/tests/float-tran.lisp b/tests/float-tran.lisp new file mode 100644 index 0000000..9c81882 --- /dev/null +++ b/tests/float-tran.lisp @@ -0,0 +1,17 @@ +;; Tests for various float transformations. + +(defpackage :float-tran-tests + (:use :cl :lisp-unit)) + +(in-package "FLOAT-TRAN-TESTS") + +(define-test decode-float-sign + "Test type derivation of the sign from decode-float" + (assert-equalp (c::make-member-type :members (list 1f0 -1f0)) + (c::decode-float-sign-derive-type-aux (c::specifier-type 'single-float))) + (assert-equalp (c::make-member-type :members (list 1d0 -1d0)) + (c::decode-float-sign-derive-type-aux (c::specifier-type 'double-float))) + (assert-equalp (c::make-member-type :members (list 1f0)) + (c::decode-float-sign-derive-type-aux (c::specifier-type '(single-float (0f0)))))) + + \ No newline at end of file diff --git a/tests/float.lisp b/tests/float.lisp new file mode 100644 index 0000000..6fe1f50 --- /dev/null +++ b/tests/float.lisp @@ -0,0 +1,12 @@ +;; Tests of float functions + +(defpackage :float-tests + (:use :cl :lisp-unit)) + +(in-package "FLOAT-TESTS") + +(define-test decode-float + (assert-true (funcall (compile nil #'(lambda (x) + (declare (type (double-float (0d0)) x)) + (decode-float x))) + 1d0))) commit 8fb489459a9f50049a5eb8cf3ccc06f8225e98bc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Sep 12 00:29:00 2014 -0700 Remove the NetBSD setexception changes on the master branch. This is only for the upcoming release. diff --git a/src/lisp/GNUmakefile b/src/lisp/GNUmakefile index 056e9ea..c557d3b 100644 --- a/src/lisp/GNUmakefile +++ b/src/lisp/GNUmakefile @@ -12,7 +12,7 @@ FDLIBM = k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c \ e_acosh.c s_asinh.c e_atanh.c \ e_atan2.c \ e_rem_pio2.c k_rem_pio2.c \ - setexception.c double-values.c + setexception.c SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ vars.c parse.c interrupt.c search.c validate.c globals.c \ diff --git a/src/lisp/double-values.c b/src/lisp/double-values.c deleted file mode 100644 index 79d5921..0000000 --- a/src/lisp/double-values.c +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Some helper functions to return specific double values for use by - * fdlibm_setexceptions on NetBSD. Currently, NetBSD doesn't have - * feraiseexcept so we have to do something special. See - * fdlibm_setexceptions. - */ - -#include "fdlibm.h" - -double -double_zero() -{ - return 0.0; -} - -/* - * Return most-positive-double-float - */ -double -double_huge() -{ - union { int i[2]; double d; } ux; - ux.i[HIWORD] = 0x7fefffff; - ux.i[LOWORD] = 0xffffffff; - - return ux.d; -} - -/* - * Return least-positive-double-float - */ -double -double_tiny() -{ - union { int i[2]; double d; } ux; - ux.i[HIWORD] = 0; - ux.i[LOWORD] = 1; - - return ux.d; -} diff --git a/src/lisp/setexception.c b/src/lisp/setexception.c index d0f4519..a77a9d8 100644 --- a/src/lisp/setexception.c +++ b/src/lisp/setexception.c @@ -1,25 +1,4 @@ -#if defined(__NetBSD__) -/* - * NetBSD doesn't have fenv.h. At least the version currently being - * used to build cmucl doesn't. Assume this also means we don't have - * feraiseexcept. So, to generate the desired exceptions, we have to - * create the appropriate operations to generate the desired - * exceptions. - */ -#undef HAVE_FERAISEEXCEPT - -extern double double_zero(); -extern double double_huge(); -extern double double_tiny(); - -#else -#define HAVE_FERAISEEXCEPT -#endif - -#ifdef HAVE_FERAISEEXCEPT #include <fenv.h> -#endif - #include <math.h> #include <stdio.h> @@ -71,48 +50,32 @@ fdlibm_setexception(double x, enum FDLIBM_EXCEPTION type) /* Division by zero. Use the sign of x to get the correct * signed infinity */ -#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_DIVBYZERO); - ret = copysign(INFINITY, x); -#else - ret = copysign(1, x) / double_zero(); -#endif + ret = copysign(INFINITY, x); break; case 1: /* Underflow. Use the sign of x to get a signed zero. */ -#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_UNDERFLOW); ret = copysign(0.0, x); -#else - ret = double_tiny() * double_tiny();; -#endif break; case 2: /* overflow */ -#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_OVERFLOW); ret = copysign(INFINITY, x); -#else - ret = double_huge() * copysign(double_huge(), x); -#endif break; case 3: { - /* if */ + /* invalid */ if (!isQNaN(x)) { /* * If it's not a quiet NaN, we want to signal an invalid * operation. Otherwise, we silently return a NaN. */ -#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_INVALID); -#else - ret = double_zero() / double_zero(); - return ret; -#endif } + /* * FIXME: Of the many NaN values that we have, what NaN * should we return? ----------------------------------------------------------------------- Summary of changes: src/code/reader.lisp | 1 - src/compiler/float-tran.lisp | 45 +++++++++++++++++++----------------------- src/lisp/GNUmakefile | 2 +- src/lisp/double-values.c | 40 ------------------------------------- src/lisp/setexception.c | 43 +++------------------------------------- tests/float-tran.lisp | 32 ++++++++++++++++++++++++++++++ tests/float.lisp | 12 +++++++++++ 7 files changed, 68 insertions(+), 107 deletions(-) delete mode 100644 src/lisp/double-values.c create mode 100644 tests/float-tran.lisp create mode 100644 tests/float.lisp hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-17-g0855c18
by Raymond Toy 26 Sep '14

26 Sep '14

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 0855c18dc2b20c196a0f1167765dc87601658d81 (commit) from 6f288c11cde92ce34b55d8c00df8095f00671be2 (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 0855c18dc2b20c196a0f1167765dc87601658d81 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Sep 25 19:24:02 2014 -0700 Oops. Remove debugging print left in from commit [c0052f55] diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 996b1f3..03f03a0 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -62,7 +62,6 @@ (reader-error-format-arguments condition)) nil error-stream (file-position error-stream))) - (format t "open-stream-p ~A~%" (open-stream-p error-stream)) (format stream (intl:gettext "Reader error ~@[at ~D ~]on ~S:~%~?") (and (open-stream-p error-stream) (file-position error-stream)) ----------------------------------------------------------------------- Summary of changes: src/code/reader.lisp | 1 - 1 file changed, 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-16-g6f288c1
by Raymond Toy 25 Sep '14

25 Sep '14

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 6f288c11cde92ce34b55d8c00df8095f00671be2 (commit) from 24c656a5824bfd4fb9d45dfd88a25f6015e56db4 (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 6f288c11cde92ce34b55d8c00df8095f00671be2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Sep 24 20:27:54 2014 -0700 Fix type derivation of the exponent for DECODE-FLOAT. The minimum exponent is from 0, it's from least-positive float. * src/compiler/float-tran.lisp: * Derive the correct minimum exponent by using the exponent from the least-positive float value of the appropriate type. * tests/float-tran.lisp: * Add tests for the derived exponent type for DECODE-FLOAT. diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index f474429..23aa93f 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -2084,13 +2084,13 @@ (when x (nth-value 1 (decode-float x)))) (min-exp () - ;; Use decode-float on 0 of the appropriate type to find - ;; the min exponent. If we don't know the actual number - ;; format, use double, which has the widest range - ;; (including double-double-float). - (if (numeric-type-format arg) - (nth-value 1 (decode-float (coerce 0 (numeric-type-format arg)))) - (nth-value 1 (decode-float (coerce 0 'double-float))))) + ;; Use decode-float on the least positive float of the + ;; appropriate type to find the min exponent. If we don't + ;; know the actual number format, use double, which has the + ;; widest range (including double-double-float). + (nth-value 1 (decode-float (if (eq 'single-float (numeric-type-format arg)) + least-positive-single-float + least-positive-double-float)))) (max-exp () ;; Use decode-float on the most postive number of the ;; appropriate type to find the max exponent. If we don't diff --git a/tests/float-tran.lisp b/tests/float-tran.lisp index 0c47dce..9b84659 100644 --- a/tests/float-tran.lisp +++ b/tests/float-tran.lisp @@ -17,6 +17,22 @@ (c::decode-float-sign-derive-type-aux (c::specifier-type '(single-float (0f0)))))) +(define-test decode-float-exp + "Test type derivation of the exponent from decode-float" + (assert-equalp (c::specifier-type '(integer -148 128)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type 'single-float))) + (assert-equalp (c::specifier-type '(integer -1073 1024)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type 'double-float))) + #+double-double + (assert-equalp (c::specifier-type '(integer -1073 1024)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type 'double-double-float))) + (assert-equalp (c::specifier-type '(integer 2 8)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type '(double-float 2d0 128d0))))) + (define-test log2-single-transform "Test tranform of (log x 2) to (kernel::log2 x)" (let ((test-fun ----------------------------------------------------------------------- Summary of changes: src/compiler/float-tran.lisp | 14 +++++++------- tests/float-tran.lisp | 16 ++++++++++++++++ 2 files changed, 23 insertions(+), 7 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-15-g24c656a
by Raymond Toy 25 Sep '14

25 Sep '14

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 24c656a5824bfd4fb9d45dfd88a25f6015e56db4 (commit) from 106bf4fc7687741b27523b23db3c9b2443237b2d (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 24c656a5824bfd4fb9d45dfd88a25f6015e56db4 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Sep 24 19:57:01 2014 -0700 Add tests for compiled log2 and log10. diff --git a/tests/float.lisp b/tests/float.lisp index eeb221b..55b9013 100644 --- a/tests/float.lisp +++ b/tests/float.lisp @@ -21,3 +21,25 @@ (let ((x (float (expt 10 k) 1d0))) (assert-equalp k (log x 10))))) +(compile 'clog2 + #'(lambda (x) + (declare (type (double-float (0d0)) x)) + (log x 2))) + +(compile 'clog10 + #'(lambda (x) + (declare (type (double-float (0d0)) x)) + (log x 10))) + +(define-test log2.compiled + (loop for k from -1074 to 1023 do + (let ((x (scale-float 1d0 k))) + (assert-equalp k (clog2 x))))) + +(define-test log10.compiled + (loop for k from 0 to 22 do + (let ((x (float (expt 10 k) 1d0))) + (assert-equalp k (clog10 x))))) + + + ----------------------------------------------------------------------- Summary of changes: tests/float.lisp | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[Cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2014-09-14-g106bf4f
by Raymond Toy 25 Sep '14

25 Sep '14

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 106bf4fc7687741b27523b23db3c9b2443237b2d (commit) from db25e3e006f90d031ecca30aa1b04e77fc1be619 (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 106bf4fc7687741b27523b23db3c9b2443237b2d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Sep 24 19:53:07 2014 -0700 Make the LOG function match what the deftransform for LOG does. Without this, compiled code produces different answers from interpreted code. * src/code/irrat.lisp: * Add cases where the base is 2 or 10 to compute the log in the same way as the deftransform for LOG does. * tests/float.lisp: * Fix comparison to use equalp, not equal. * Add test for log10. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 61d4314..daf6166 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -645,74 +645,112 @@ ;; ANSI spec base) ((and (realp number) (realp base)) - ;; CLHS 12.1.4.1 says - ;; - ;; When rationals and floats are combined by a - ;; numerical function, the rational is first converted - ;; to a float of the same format. - ;; - ;; So assume this applies to floats as well convert all - ;; numbers to the largest float format before computing - ;; the log. - ;; - ;; This makes (log 17 10.0) = (log 17.0 10) and so on. - (number-dispatch ((number real) (base real)) - ((double-float - (foreach double-float single-float)) - (/ (log2 number) (log2 base))) - (((foreach fixnum bignum ratio) - (foreach fixnum bignum ratio single-float)) - (let* ((result (/ (log2 number) (log2 base)))) - ;; Figure out the right result type - (if (realp result) - (coerce result 'single-float) - (coerce result '(complex single-float))))) - (((foreach fixnum bignum ratio) - double-float) - (/ (log2 number) (log2 base))) - ((single-float - (foreach fixnum bignum ratio)) - (let* ((result (/ (log2 number) (log2 base)))) - ;; Figure out the right result type - (if (realp result) - (coerce result 'single-float) - (coerce result '(complex single-float))))) - ((double-float - (foreach fixnum bignum ratio)) - (/ (log2 number) (log2 base))) - ((single-float double-float) - (/ (log (coerce number 'double-float)) (log base))) - #+double-double - ((double-double-float - (foreach fixnum bignum ratio)) - (/ (log2 number 1w0) (log2 base 1w0))) - #+double-double - ((double-double-float - (foreach double-double-float double-float single-float)) - (/ (log number) (log (coerce base 'double-double-float)))) - #+double-double - (((foreach fixnum bignum ratio) - double-double-float) - (/ (log2 number 1w0) (log2 base 1w0))) - #+double-double - (((foreach double-float single-float) - double-double-float) - (/ (log (coerce number 'double-double-float)) (log base))) - (((foreach single-float) - (foreach single-float)) - ;; Converting everything to double-float helps the - ;; cases like (log 17 10) = (/ (log 17) (log 10)). - ;; This is usually handled above, but if we compute (/ - ;; (log 17) (log 10)), we get a slightly different - ;; answer due to roundoff. This makes it a bit more - ;; consistent. + (cond + ((and (= base 2) + (floatp number) + #+double-double + (not (typep number 'ext:double-double-float)) + (or (plusp number) + (eql number 0.0) + (eql number 0d0))) + ;; Do the same thing as the deftranform does for + ;; log base 2 and 10 for non-negative arguments. + (number-dispatch ((number real) (base real)) + ((double-float + (foreach integer single-float double-float)) + (log2 number)) + ((single-float + (foreach integer single-float)) + (float (log2 (float number 1d0)) 1f0)) + ((single-float double-float) + (log2 (float number 1d0))))) + ((and (= base 10) + (floatp number) + #+double-double + (not (typep number 'double-double-float)) + (or (plusp number) + (eql number 0.0) + (eql number 0d0))) + ;; Do the same thing as the deftranform does for + ;; log base 2 and 10 for non-negative arguments. + (number-dispatch ((number real) (base real)) + ((double-float + (foreach double-float single-float integer)) + (%log10 number)) + ((single-float + (foreach single-float integer)) + (float (%log10 (float number 1d0)) 1f0)) + ((single-float double-float) + (%log10 (float number 1d0))))) + (t + ;; CLHS 12.1.4.1 says + ;; + ;; When rationals and floats are combined by a + ;; numerical function, the rational is first converted + ;; to a float of the same format. + ;; + ;; So assume this applies to floats as well convert all + ;; numbers to the largest float format before computing + ;; the log. ;; - ;; FIXME: This probably needs more work. - (let ((result (/ (log (float number 1d0)) - (log (float base 1d0))))) - (if (realp result) - (coerce result 'single-float) - (coerce result '(complex single-float))))))) + ;; This makes (log 17 10.0) = (log 17.0 10) and so on. + (number-dispatch ((number real) (base real)) + ((double-float + (foreach double-float single-float)) + (/ (log2 number) (log2 base))) + (((foreach fixnum bignum ratio) + (foreach fixnum bignum ratio single-float)) + (let* ((result (/ (log2 number) (log2 base)))) + ;; Figure out the right result type + (if (realp result) + (coerce result 'single-float) + (coerce result '(complex single-float))))) + (((foreach fixnum bignum ratio) + double-float) + (/ (log2 number) (log2 base))) + ((single-float + (foreach fixnum bignum ratio)) + (let* ((result (/ (log2 number) (log2 base)))) + ;; Figure out the right result type + (if (realp result) + (coerce result 'single-float) + (coerce result '(complex single-float))))) + ((double-float + (foreach fixnum bignum ratio)) + (/ (log2 number) (log2 base))) + ((single-float double-float) + (/ (log (coerce number 'double-float)) (log base))) + #+double-double + ((double-double-float + (foreach fixnum bignum ratio)) + (/ (log2 number 1w0) (log2 base 1w0))) + #+double-double + ((double-double-float + (foreach double-double-float double-float single-float)) + (/ (log number) (log (coerce base 'double-double-float)))) + #+double-double + (((foreach fixnum bignum ratio) + double-double-float) + (/ (log2 number 1w0) (log2 base 1w0))) + #+double-double + (((foreach double-float single-float) + double-double-float) + (/ (log (coerce number 'double-double-float)) (log base))) + (((foreach single-float) + (foreach single-float)) + ;; Converting everything to double-float helps the + ;; cases like (log 17 10) = (/ (log 17) (log 10)). + ;; This is usually handled above, but if we compute (/ + ;; (log 17) (log 10)), we get a slightly different + ;; answer due to roundoff. This makes it a bit more + ;; consistent. + ;; + ;; FIXME: This probably needs more work. + (let ((result (/ (log (float number 1d0)) + (log (float base 1d0))))) + (if (realp result) + (coerce result 'single-float) + (coerce result '(complex single-float))))))))) (t ;; FIXME: This probably needs some work as well. (/ (log number) (log base)))) diff --git a/tests/float.lisp b/tests/float.lisp index ff07270..eeb221b 100644 --- a/tests/float.lisp +++ b/tests/float.lisp @@ -11,7 +11,13 @@ (decode-float x))) 1d0))) -(define-test log2 +(define-test log2.interp (loop for k from -1074 to 1023 do (let ((x (scale-float 1d0 k))) - (assert-equal k (log x 2))))) + (assert-equalp k (log x 2))))) + +(define-test log10.interp + (loop for k from 0 to 22 do + (let ((x (float (expt 10 k) 1d0))) + (assert-equalp k (log x 10))))) + ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 172 +++++++++++++++++++++++++++++++-------------------- tests/float.lisp | 10 ++- 2 files changed, 113 insertions(+), 69 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-03-a-6-gc94b32f
by Raymond Toy 25 Mar '13

25 Mar '13

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 c94b32f927061d6e7b7ea1ebf92ccdb4c3b1a842 (commit) from 0232d2242e5acf9d1654cd0e4d7883de9e9f4705 (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 c94b32f927061d6e7b7ea1ebf92ccdb4c3b1a842 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Mar 24 20:13:56 2013 -0700 Fix ticket:77 correctly, using the supplied patch link. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 2c3e0ff..6c7bbed 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2388,6 +2388,7 @@ "ATOMIC-PUSH" "CURRENT-PROCESS" "DESTROY-PROCESS" "DISABLE-PROCESS" "ENABLE-PROCESS" "INIT-STACK-GROUPS" "LOCK" "MAKE-STACK-GROUP" "MAKE-LOCK" "MAKE-PROCESS" "PROCESS-ACTIVE-P" + "PROCESS-JOIN" "PROCESS-ADD-ARREST-REASON" "PROCESS-ADD-RUN-REASON" "PROCESS-ALIVE-P" "PROCESS-ARREST-REASONS" "PROCESS-IDLE-TIME" "PROCESS-INTERRUPT" "PROCESS-NAME" diff --git a/src/code/multi-proc.lisp b/src/code/multi-proc.lisp index b0ce883..e478a95 100644 --- a/src/code/multi-proc.lisp +++ b/src/code/multi-proc.lisp @@ -298,6 +298,7 @@ (%real-time 0d0 :type double-float) (%run-time 0d0 :type double-float) (property-list nil :type list) + (%return-values nil :type list) (initial-bindings nil :type list)) @@ -956,9 +957,11 @@ (with-simple-restart (destroy "Destroy the process") (setf *inhibit-scheduling* nil) - (apply-with-bindings function - nil - initial-bindings)) + (setf (process-%return-values *current-process*) + (multiple-value-list + (apply-with-bindings function + nil + initial-bindings)))) ;; Normal exit. (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) @@ -1973,19 +1976,7 @@ #-x86 (when (eq (lock-process ,lock) *current-process*) (setf (lock-process ,lock) nil))))))) -(defun %make-thread (function name) - (mp:make-process (lambda () - (let ((return-values - (multiple-value-list (funcall function)))) - (setf (getf (mp:process-property-list mp:*current-process*) - 'return-values) - return-values) - (values-list return-values))) - :name name)) - -(defun join-thread (thread) +(defun process-join (process) (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (lambda () (not (mp:process-alive-p thread)))) - (let ((return-values - (getf (mp:process-property-list thread) 'return-values))) - (values-list return-values))) + (values-list (process-%return-values process))) diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 06c2fc6..d38c14c 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -42,7 +42,7 @@ New in this release: * :I486 and :PENTIUM (Always assume we're running on at least a Pentium.) * Update unicode to support Unicode 6.2. - * Add MP:JOIN-THREAD, as given in ticket #77. + * Add MP:PROCESS-JOIN, as given in ticket #77. * ANSI compliance fixes: * Attempts to modify the standard readtable or the standard pprint ----------------------------------------------------------------------- Summary of changes: src/code/exports.lisp | 1 + src/code/multi-proc.lisp | 25 ++++++++----------------- src/general-info/release-20e.txt | 2 +- 3 files changed, 10 insertions(+), 18 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-03-a-5-g0232d22
by Raymond Toy 24 Mar '13

24 Mar '13

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 0232d2242e5acf9d1654cd0e4d7883de9e9f4705 (commit) from 50b13399f16ca49f7b54a0b5bc427ad0a67b9579 (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 0232d2242e5acf9d1654cd0e4d7883de9e9f4705 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Mar 24 09:43:33 2013 -0700 Fix ticket:77 by adding the code given in the ticket. diff --git a/src/code/multi-proc.lisp b/src/code/multi-proc.lisp index 8b2df04..b0ce883 100644 --- a/src/code/multi-proc.lisp +++ b/src/code/multi-proc.lisp @@ -1972,3 +1972,20 @@ ,lock 2 *current-process* nil) #-x86 (when (eq (lock-process ,lock) *current-process*) (setf (lock-process ,lock) nil))))))) + +(defun %make-thread (function name) + (mp:make-process (lambda () + (let ((return-values + (multiple-value-list (funcall function)))) + (setf (getf (mp:process-property-list mp:*current-process*) + 'return-values) + return-values) + (values-list return-values))) + :name name)) + +(defun join-thread (thread) + (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) + (lambda () (not (mp:process-alive-p thread)))) + (let ((return-values + (getf (mp:process-property-list thread) 'return-values))) + (values-list return-values))) diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 5ec6b03..06c2fc6 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -42,6 +42,7 @@ New in this release: * :I486 and :PENTIUM (Always assume we're running on at least a Pentium.) * Update unicode to support Unicode 6.2. + * Add MP:JOIN-THREAD, as given in ticket #77. * ANSI compliance fixes: * Attempts to modify the standard readtable or the standard pprint @@ -70,6 +71,7 @@ New in this release: * Ticket #74 fixed. * Ticket #76 fixed. * Ticket #79 fixed. + * Ticket #77 fixed. * Other changes: * -8 option for build-all.sh is deprecated since we don't ----------------------------------------------------------------------- Summary of changes: src/code/multi-proc.lisp | 17 +++++++++++++++++ src/general-info/release-20e.txt | 2 ++ 2 files changed, 19 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0