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

[Git][cmucl/cmucl][rtoy-fix-59-derive-decode-float] 3 commits: Fix typo. double-double-float is in the kernel package
by Raymond Toy 04 Feb '18

04 Feb '18

Raymond Toy pushed to branch rtoy-fix-59-derive-decode-float at cmucl / cmucl Commits: 2292400e by Raymond Toy at 2018-02-04T08:16:35-08:00 Fix typo. double-double-float is in the kernel package - - - - - 4e58e53c by Raymond Toy at 2018-02-04T08:19:13-08:00 Be more careful in computing the decode-float bounds If 0 is the lower bound then the smallest exponent is not for 0, but for the least positive float because of denormals. Also handle exclusive bounds. - - - - - 7b336362 by Raymond Toy at 2018-02-04T08:19:37-08:00 Add more tests decode-float. - - - - - 3 changed files: - src/compiler/float-tran.lisp - tests/float-tran.lisp - tests/issues.lisp Changes: ===================================== src/compiler/float-tran.lisp ===================================== --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -2031,29 +2031,33 @@ (labels ((calc-exp (x) (when x - (nth-value 1 (decode-float x)))) - (min-exp () - ;; 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). - (calc-exp (if (eq 'single-float (numeric-type-format arg)) - least-positive-single-float - least-positive-double-float))) - (max-exp () + (bound-func #'(lambda (arg) + (nth-value 1 (decode-float arg))) + x))) + (min-exp (interval) + ;; (decode-float 0d0) returns an exponent of -1022. But + ;; (decode-float least-positive-double-float returns -1073. + ;; Hence, if the low value is less than this, we need to + ;; return the exponent of the least positive number. + (let ((least (if (eq 'single-float (numeric-type-format arg)) + least-positive-single-float + least-positive-double-float))) + (if (or (interval-contains-p 0 interval) + (interval-contains-p least interval)) + (calc-exp least) + (calc-exp (bound-value (interval-low interval)))))) + (max-exp (interval) ;; Use decode-float on the most postive number of the ;; appropriate type to find the max exponent. If we don't ;; know the actual number format, use double, which has the ;; widest range (including double-double-float). - (calc-exp (if (eq 'single-float (numeric-type-format arg)) - most-positive-single-float - most-positive-double-float)))) - (let* ((interval (interval-func #'calc-exp - (interval-abs (numeric-type->interval arg)))) - (lo (or (interval-low interval) - (min-exp))) - (hi (or (interval-high interval) - (max-exp)))) + (or (calc-exp (bound-value (interval-high interval))) + (calc-exp (if (eq 'single-float (numeric-type-format arg)) + most-positive-single-float + most-positive-double-float))))) + (let* ((interval (interval-abs (numeric-type->interval arg))) + (lo (min-exp interval)) + (hi (max-exp interval))) (specifier-type `(integer ,(or lo '*) ,(or hi '*)))))) (defun decode-float-sign-derive-type-aux (arg) ===================================== tests/float-tran.lisp ===================================== --- a/tests/float-tran.lisp +++ b/tests/float-tran.lisp @@ -28,7 +28,7 @@ #+double-double (assert-equalp (c::specifier-type '(integer -1073 1024)) (c::decode-float-exp-derive-type-aux - (c::specifier-type 'double-double-float))) + (c::specifier-type 'kernel: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))))) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -450,3 +450,57 @@ (declare (type (double-float -2d0 0d0) z)) (nth-value 2 (decode-float z)))))) (assert-equal -1d0 (funcall f -1d0)))) + +(define-test issue.59.1-double + (:tag :issues) + (dolist (entry '(((-2d0 2d0) (-1073 2)) + ((-2d0 0d0) (-1073 2)) + ((0d0 2d0) (-1073 2)) + ((1d0 4d0) (1 3)) + ((-4d0 -1d0) (1 3)) + (((0d0) (10d0)) (-1073 4)) + ((-2f0 2f0) (-148 2)) + ((-2f0 0f0) (-148 2)) + ((0f0 2f0) (-148 2)) + ((1f0 4f0) (1 3)) + ((-4f0 -1f0) (1 3)) + ((0f0) (10f0)) (-148 4))) + (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi)) + entry + (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type `(double-float ,arg-lo ,arg-hi))))))) + +(define-test issue.59.1-double + (:tag :issues) + (dolist (entry '(((-2d0 2d0) (-1073 2)) + ((-2d0 0d0) (-1073 2)) + ((0d0 2d0) (-1073 2)) + ((1d0 4d0) (1 3)) + ((-4d0 -1d0) (1 3)) + (((0d0) (10d0)) (-1073 4)) + (((0.5d0) (4d0)) (0 3)))) + (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi)) + entry + (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type `(double-float ,arg-lo ,arg-hi))) + arg-lo + arg-hi)))) + +(define-test issue.59.1-float + (:tag :issues) + (dolist (entry '(((-2f0 2f0) (-148 2)) + ((-2f0 0f0) (-148 2)) + ((0f0 2f0) (-148 2)) + ((1f0 4f0) (1 3)) + ((-4f0 -1f0) (1 3)) + (((0f0) (10f0)) (-148 4)) + (((0.5f0) (4f0)) (0 3)))) + (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi)) + entry + (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi)) + (c::decode-float-exp-derive-type-aux + (c::specifier-type `(single-float ,arg-lo ,arg-hi))) + arg-lo + arg-hi)))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/62c5f3e9a170e5f8799f37b3… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/62c5f3e9a170e5f8799f37b3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-fix-59-derive-decode-float
by Raymond Toy 03 Feb '18

03 Feb '18

Raymond Toy pushed new branch rtoy-fix-59-derive-decode-float at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-fix-59-derive-decode-f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new tag snapshot-2017-10
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed new tag snapshot-2017-10 at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/snapshot-2017-10 You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Move defsystem for pcl-tests to its own file.
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: a368558e by Raymond Toy at 2017-10-08T15:17:59-07:00 Move defsystem for pcl-tests to its own file. The upgrade to ASDF 3.3.0 broke the pcl-tests; this version doesn't like having the defsystem in the same file. Thus, move the defsystem to its own file and load it up in pcl.lisp (via require). - - - - - 2 changed files: - + tests/pcl-tests.asd - tests/pcl.lisp Changes: ===================================== tests/pcl-tests.asd ===================================== --- /dev/null +++ b/tests/pcl-tests.asd @@ -0,0 +1,39 @@ +;;; -*- Mode: lisp -*- + +(asdf:defsystem :pcl-tests + :pathname "pcl/" + :components + ((:file "pkg") + #+gerds-pcl + (:file "ctor" + :depends-on ("pkg")) + (:file "defclass" + :depends-on ("pkg")) + (:file "make-instance" + :depends-on ("pkg" #+gerds-pcl "ctor")) + (:file "reinitialize-instance" + :depends-on ("pkg" "make-instance")) + (:file "slot-value" + :depends-on ("pkg" "make-instance")) + (:file "slot-boundp" + :depends-on ("pkg" "make-instance")) + (:file "slot-missing" + :depends-on ("pkg" "make-instance")) + (:file "slot-accessors" + :depends-on ("pkg" "make-instance")) + (:file "slot-type" + :depends-on ("pkg" "slot-value")) + (:file "inline-access" + :depends-on ("pkg" "slot-type")) + (:file "method-combination" + :depends-on ("pkg")) + (:file "pv" + :depends-on ("pkg")) + (:file "defgeneric" + :depends-on ("pkg")) + (:file "defmethod" + :depends-on ("pkg")) + (:file "find-method" + :depends-on ("pkg")) + (:file "methods" + :depends-on ("pkg")))) ===================================== tests/pcl.lisp ===================================== --- a/tests/pcl.lisp +++ b/tests/pcl.lisp @@ -26,42 +26,11 @@ (merge-pathnames #p"pcl/*.*" *load-truename*)))) -(asdf:defsystem :pcl-test - :pathname "pcl/" - :components - ((:file "pkg") - #+gerds-pcl - (:file "ctor" - :depends-on ("pkg")) - (:file "defclass" - :depends-on ("pkg")) - (:file "make-instance" - :depends-on ("pkg" #+gerds-pcl "ctor")) - (:file "reinitialize-instance" - :depends-on ("pkg" "make-instance")) - (:file "slot-value" - :depends-on ("pkg" "make-instance")) - (:file "slot-boundp" - :depends-on ("pkg" "make-instance")) - (:file "slot-missing" - :depends-on ("pkg" "make-instance")) - (:file "slot-accessors" - :depends-on ("pkg" "make-instance")) - (:file "slot-type" - :depends-on ("pkg" "slot-value")) - (:file "inline-access" - :depends-on ("pkg" "slot-type")) - (:file "method-combination" - :depends-on ("pkg")) - (:file "pv" - :depends-on ("pkg")) - (:file "defgeneric" - :depends-on ("pkg")) - (:file "defmethod" - :depends-on ("pkg")) - (:file "find-method" - :depends-on ("pkg")) - (:file "methods" - :depends-on ("pkg")))) +;; Just smash it with our path so we don't accidentally look up +;; pcl-files somewhere else. +(setf asdf:*central-registry* + (list (make-pathname :directory (pathname-directory *load-pathname*)))) -(asdf:oos 'asdf:load-op :pcl-test) +(require :pcl-tests) + +(asdf:oos 'asdf:load-op :pcl-tests) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/a368558eacabee5d8b099dc07… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/a368558eacabee5d8b099dc07… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #47: Print backquote multiple splices correctly
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: dc4a7e00 by Raymond Toy at 2018-01-28T18:20:20-08:00 Fix #47: Print backquote multiple splices correctly * Print multiple splices correclty without the extra set of parenthesis around each splice. * Add test for this. - - - - - e7f97a5d by Raymond Toy at 2018-01-30T03:04:30+00:00 Merge branch 'rtoy-fix-47-backq-splice-printer' into 'master' Fix #47: Print backquote multiple splices correctly Closes #47 See merge request cmucl/cmucl!33 - - - - - 2 changed files: - src/code/backq.lisp - tests/issues.lisp Changes: ===================================== src/code/backq.lisp ===================================== --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -263,7 +263,8 @@ (backq-unparse (car tail) t))) (push (backq-unparse (car tail)) accum))) (backq-append - (mapcar #'(lambda (el) (backq-unparse el t)) + (mapcar #'(lambda (el) + (car (backq-unparse el t))) (cdr form))) (backq-nconc (mapcar #'(lambda (el) (backq-unparse el :nconc)) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -434,4 +434,12 @@ "./" test-dir-name "ls-link"))))) - + +(define-test issue.47 + (:tag :issues) + (with-standard-io-syntax + (assert-equal "`(,@VARS ,@VARS)" + (with-output-to-string (s) + (write (read-from-string "`(,@vars ,@vars)") + :pretty t + :stream s))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/380759e3d91a1d6517a20254… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/380759e3d91a1d6517a20254… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-fix-47-backq-splice-printer
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed new branch rtoy-fix-47-backq-splice-printer at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-fix-47-backq-splice-pr… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Restore ability to compile in mt19937 rng.
by Raymond Toy 28 Jan '18

28 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 380759e3 by Raymond Toy at 2018-01-27T21:59:25-08:00 Restore ability to compile in mt19937 rng. - src/tools/worldbuild.lisp - only compile rand-xoroshiro if :random-xoroshiro is a feature - src/tools/worldload.lisp - only load rand-xoroshiro if :random-xoroshiro is a feature - tests/rng.lisp - Add a quick test that the state vector of the *random-state* has the correct type. - - - - - 3 changed files: - src/tools/worldbuild.lisp - src/tools/worldload.lisp - tests/rng.lisp Changes: ===================================== src/tools/worldbuild.lisp ===================================== --- a/src/tools/worldbuild.lisp +++ b/src/tools/worldbuild.lisp @@ -127,7 +127,6 @@ '("target:code/rand-xoroshiro")) (t '("target:code/rand"))) - "target:code/rand-xoroshiro" "target:code/alieneval" "target:code/c-call" "target:code/sap" ===================================== src/tools/worldload.lisp ===================================== --- a/src/tools/worldload.lisp +++ b/src/tools/worldload.lisp @@ -102,7 +102,6 @@ (maybe-byte-load "code:rand-xoroshiro") #-(or random-mt19937 random-xoroshiro) (maybe-byte-load "code:rand") -(maybe-byte-load "code:rand-xoroshiro") (maybe-byte-load "target:pcl/walk") (maybe-byte-load "code:fwrappers") (maybe-byte-load "code:ntrace") ===================================== tests/rng.lisp ===================================== --- a/tests/rng.lisp +++ b/tests/rng.lisp @@ -20,6 +20,13 @@ (defvar *test-state*) +(define-test rng.state + (let ((s (kernel::random-state-state *random-state*))) + #+random-xoroshiro + (assert-true (typep s '(simple-array double-float (2)))) + #+random-mt19937 + (assert-true (typep s '(simple-array (unsigned-byte 32) (627)))))) + #+random-xoroshiro (define-test rng.initial-state (setf *test-state* @@ -56,6 +63,7 @@ (assert-equal value (64-bit-value *test-state*)) (assert-equal state (multiple-value-list (64-bit-rng-state *test-state*)))))) +#+random-xoroshiro (define-test rng.jump (setf *test-state* (kernel::make-random-object :state (kernel::init-random-state #x12345678) @@ -68,3 +76,4 @@ (kernel:random-state-jump *test-state*) (assert-equal result (multiple-value-list (64-bit-rng-state *test-state*))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/380759e3d91a1d6517a202545… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/380759e3d91a1d6517a202545… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 3 commits: Fix #49: CLM crashes
by Raymond Toy 28 Jan '18

28 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b8841170 by Raymond Toy at 2018-01-27T13:04:52-08:00 Fix #49: CLM crashes When invoking motifd, the program name is #p:'library:motifd". This is passed directly to spawn (a C routine), which only accepts strings. So, before calling spawn, convert the program path to a unix namestring. This allows the example from the bug to run without crashing. - - - - - 87c07e5d by Raymond Toy at 2018-01-27T18:19:56-08:00 Make sure spawn is called with a string The previous commit worked for search lists, but the program could be a string. Take care to convert pathnames to strings so that spawn is always called with a string. - - - - - 99eb4311 by Raymond Toy at 2018-01-28T02:54:17+00:00 Merge branch 'rtoy-fix-49-clm-crash' into 'master' Fix #49: CLM crashes Closes #49 See merge request cmucl/cmucl!32 - - - - - 1 changed file: - src/code/run-program.lisp Changes: ===================================== src/code/run-program.lisp ===================================== --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -522,8 +522,18 @@ ;; Make sure all the args are okay. (unless (every #'simple-string-p args) (error (intl:gettext "All args to program must be simple strings -- ~S.") args)) + + ;; Make sure program is a string that we can use with spawn. + (setf program + (if (pathnamep program) + (lisp::with-pathname (p program) + (or (unix::unix-namestring p) + (namestring p))) + (namestring program))) + (check-type program string) + ;; Prepend the program to the argument list. - (push (namestring program) args) + (push program args) ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup ;; info. Also, establish proc at this level so we can return it. (let (*close-on-error* *close-in-parent* *handlers-installed* proc) @@ -566,9 +576,10 @@ (cdr entry))) env)) (let ((child-pid - (without-gcing - (spawn program argv envp pty-name - stdin stdout stderr)))) + (without-gcing + (spawn program + argv envp pty-name + stdin stdout stderr)))) (when (< child-pid 0) (error (intl:gettext "Could not fork child process: ~A") (unix:get-unix-error-msg))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b464fc941ebe07fb0e11ef8d… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b464fc941ebe07fb0e11ef8d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-fix-49-clm-crash] Make sure spawn is called with a string
by Raymond Toy 28 Jan '18

28 Jan '18

Raymond Toy pushed to branch rtoy-fix-49-clm-crash at cmucl / cmucl Commits: 87c07e5d by Raymond Toy at 2018-01-27T18:19:56-08:00 Make sure spawn is called with a string The previous commit worked for search lists, but the program could be a string. Take care to convert pathnames to strings so that spawn is always called with a string. - - - - - 1 changed file: - src/code/run-program.lisp Changes: ===================================== src/code/run-program.lisp ===================================== --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -522,8 +522,18 @@ ;; Make sure all the args are okay. (unless (every #'simple-string-p args) (error (intl:gettext "All args to program must be simple strings -- ~S.") args)) + + ;; Make sure program is a string that we can use with spawn. + (setf program + (if (pathnamep program) + (lisp::with-pathname (p program) + (or (unix::unix-namestring p) + (namestring p))) + (namestring program))) + (check-type program string) + ;; Prepend the program to the argument list. - (push (namestring program) args) + (push program args) ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup ;; info. Also, establish proc at this level so we can return it. (let (*close-on-error* *close-in-parent* *handlers-installed* proc) @@ -566,10 +576,10 @@ (cdr entry))) env)) (let ((child-pid - (without-gcing - (spawn (unix::unix-namestring program) - argv envp pty-name - stdin stdout stderr)))) + (without-gcing + (spawn program + argv envp pty-name + stdin stdout stderr)))) (when (< child-pid 0) (error (intl:gettext "Could not fork child process: ~A") (unix:get-unix-error-msg))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/87c07e5d7b5c882422bf3089d… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/87c07e5d7b5c882422bf3089d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-fix-49-clm-crash
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed new branch rtoy-fix-49-clm-crash at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-fix-49-clm-crash You're receiving this email because of your account on gitlab.common-lisp.net.

1 0