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

[git] CMU Common Lisp branch master updated. snapshot-2014-09-2-g2ec1fda
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 2ec1fda2a83f17fe9ee580ef14b887b5c66f844a (commit) from 17f45333fcd83fa81e82cf382bcc78cf20b3d826 (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 2ec1fda2a83f17fe9ee580ef14b887b5c66f844a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Sep 4 21:11:41 2014 -0700 Export of double-double-float-digits should be within eval-when. diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp index deac614..dab5ce5 100644 --- a/src/compiler/ppc/parms.lisp +++ b/src/compiler/ppc/parms.lisp @@ -67,10 +67,10 @@ float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit float-invalid-op-1-byte)) -) #+double-double (export '(double-double-float-digits)) +) ; eval-when diff --git a/src/compiler/sparc/parms.lisp b/src/compiler/sparc/parms.lisp index be73a40..ec151f4 100644 --- a/src/compiler/sparc/parms.lisp +++ b/src/compiler/sparc/parms.lisp @@ -87,10 +87,10 @@ float-underflow-trap-bit float-overflow-trap-bit float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) -) #+double-double (export '(double-double-float-digits)) +) ; eval-when (eval-when (compile load eval) @@ -388,8 +388,10 @@ (defparameter *assembly-unit-length* 8) +(eval-when (:compile-toplevel :load-toplevel :execute) (export '(pseudo-atomic-trap allocation-trap pseudo-atomic-value pseudo-atomic-interrupted-value)) +) ;;;; Pseudo-atomic trap number. ;;;; ;;;; This is the trap number to use when a pseudo-atomic section has diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 39ea767..228df99 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -97,10 +97,10 @@ float-underflow-trap-bit float-overflow-trap-bit float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) -) #+double-double (export '(double-double-float-digits)) +) ; eval-when (eval-when (compile load eval) ----------------------------------------------------------------------- Summary of changes: src/compiler/ppc/parms.lisp | 2 +- src/compiler/sparc/parms.lisp | 4 +++- src/compiler/x86/parms.lisp | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-20-gb6bd0b5
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 b6bd0b590e541a159c4b5eb7e31b64c2ef0b47dc (commit) from 44f82278524424b6022353ca288b21e422655203 (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 b6bd0b590e541a159c4b5eb7e31b64c2ef0b47dc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jul 25 21:05:19 2014 -0700 All platforms have sincos now, so remove the deftransform for cis that converted cis to (complex (cos x) (sin x)). Besides, that was blocking the other deftransform for cis that replaced cis with a call to %sincos. diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 39e960b..41e0d42 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -1802,10 +1802,6 @@ (deftransform * ((z w) (,real-type (complex ,type)) *) ;; Real * complex '(complex (* z (realpart w)) (* z (imagpart w)))) - #-(or (and linux x86)) - (deftransform cis ((z) ((,type)) *) - ;; Cis. - '(complex (cos z) (sin z))) (deftransform / ((rx y) (,real-type (complex ,type)) *) ;; Real/complex '(let* ((ry (realpart y)) ----------------------------------------------------------------------- Summary of changes: src/compiler/float-tran.lisp | 4 ---- 1 file changed, 4 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-01-3-g89a16ec
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 89a16ec62716a5eaf544d8aa0bd490e0c3c267ff (commit) from b039aef5dc968d954b2da2c0987a4dd24fc4d32c (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 89a16ec62716a5eaf544d8aa0bd490e0c3c267ff Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Jan 5 20:27:34 2014 -0800 In trac.65, make comparison test an assertion test to show failures more clearly. diff --git a/tests/trac.lisp b/tests/trac.lisp index 4cffa78..3e23d3e 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -184,23 +184,19 @@ (define-test trac.65 (:tag :trac) - (assert-false - (let (failures) - (dolist (base '(2 2f0 2d0 2w0 #c(0 1) #c(0f0 1) #c(0d0 1) #c(0w0 1))) - (dolist (power '(2 3 1/2 -2 -3 -1/2 5)) - (dolist (power-type '(rational single-float double-float ext:double-double-float - (complex single-float) (complex double-float) - (complex ext:double-double-float))) - (let* ((pp (coerce power power-type)) - (interp (expt base pp)) - (*compile-print* nil) - (compiled (funcall (compile nil `(lambda (b) - (declare (type ,(type-of base) b)) - (expt b ,pp))) - base))) - (unless (= interp compiled) - (push (list base pp interp compiled) failures)))))) - failures))) + (dolist (base '(2 2f0 2d0 2w0 #c(0 1) #c(0f0 1) #c(0d0 1) #c(0w0 1))) + (dolist (power '(2 3 1/2 -2 -3 -1/2 5)) + (dolist (power-type '(rational single-float double-float ext:double-double-float + (complex single-float) (complex double-float) + (complex ext:double-double-float))) + (let* ((pp (coerce power power-type)) + (interp (expt base pp)) + (*compile-print* nil) + (compiled (funcall (compile nil `(lambda (b) + (declare (type ,(type-of base) b)) + (expt b ,pp))) + base))) + (assert-eql interp compiled base pp)))))) (define-test trac.67 (:tag :trac) ----------------------------------------------------------------------- Summary of changes: tests/trac.lisp | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-01-8-g189dc5b
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 189dc5b6a717ad0a93354e55d87bc0ab41e6745d (commit) via 866c8bcf2fc93eb6dacd5707ff0e4cacea72734b (commit) from 87ef443f0e2df10676b2680c31e0a3cf459882da (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 189dc5b6a717ad0a93354e55d87bc0ab41e6745d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jan 7 20:29:16 2014 -0800 Convert to using lisp-unit. Disable the two inet tests since the echo server is not running on my machines. diff --git a/tests/simple-streams.lisp b/tests/simple-streams.lisp index 7a9a24f..9d70d55 100644 --- a/tests/simple-streams.lisp +++ b/tests/simple-streams.lisp @@ -2,11 +2,11 @@ (require :simple-streams) -(defpackage simple-streams-test - (:use #:common-lisp #:stream #:rt)) +(defpackage simple-streams-tests + (:use #:common-lisp #:stream #:lisp-unit)) -(in-package #:simple-streams-test) +(in-package #:simple-streams-tests) (defparameter *dumb-string* "This file was created by simple-stream-tests.lisp. Nothing to see here, move along.") @@ -69,176 +69,190 @@ (progn ,@body)) ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) -(deftest create-file-1 - ;; Create a file-simple-stream, write data. - (prog1 - (with-open-stream (s (make-instance 'file-simple-stream - :filename *test-file* - :direction :output - :external-format :latin-1 - :if-exists :overwrite - :if-does-not-exist :create)) - (string= (write-string *dumb-string* s) *dumb-string*)) - (delete-file *test-file*)) - t) - -(deftest create-file-2 - ;; Create a file-simple-stream via :class argument to open, write data. - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :output :if-exists :overwrite - :if-does-not-exist :create) - (string= (write-string *dumb-string* s) *dumb-string*)) - t) - -(deftest create-read-file-1 +(define-test create-file-1 + ;; Create a file-simple-stream, write data. + (assert-eql + t + (prog1 + (with-open-stream (s (make-instance 'file-simple-stream + :filename *test-file* + :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (string= (write-string *dumb-string* s) *dumb-string*)) + (delete-file *test-file*)))) + +(define-test create-file-2 + ;; Create a file-simple-stream via :class argument to open, write data. + (assert-eql + t + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :output :if-exists :overwrite + :if-does-not-exist :create) + (string= (write-string *dumb-string* s) *dumb-string*)))) + +(define-test create-read-file-1 ;; Via file-simple-stream objects, write and then re-read data. - (let ((result t)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :output :if-exists :overwrite - :if-does-not-exist :create :delete-afterwards nil) - (write-line *dumb-string* s) - (setf result (and result (string= (write-string *dumb-string* s) - *dumb-string*)))) - - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - ;; Check first line - (multiple-value-bind (string missing-newline-p) - (read-line s) - (setf result (and result (string= string *dumb-string*) - (not missing-newline-p)))) - ;; Check second line - (multiple-value-bind (string missing-newline-p) - (read-line s) - (setf result (and result (string= string *dumb-string*) - missing-newline-p)))) - result) - t) - -(deftest create-read-mapped-file-1 + (assert-eql + t + (let ((result t)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :output :if-exists :overwrite + :if-does-not-exist :create :delete-afterwards nil) + (write-line *dumb-string* s) + (setf result (and result (string= (write-string *dumb-string* s) + *dumb-string*)))) + + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + ;; Check first line + (multiple-value-bind (string missing-newline-p) + (read-line s) + (setf result (and result (string= string *dumb-string*) + (not missing-newline-p)))) + ;; Check second line + (multiple-value-bind (string missing-newline-p) + (read-line s) + (setf result (and result (string= string *dumb-string*) + missing-newline-p)))) + result))) + +(define-test create-read-mapped-file-1 ;; Read data via a mapped-file-simple-stream object. - (let ((result t)) - (with-test-file (s *test-file* :class 'mapped-file-simple-stream - :direction :input :if-does-not-exist :error - :initial-content *dumb-string*) - (setf result (and result (string= (read-line s) *dumb-string*)))) - result) - t) - -(deftest write-read-inet + (assert-eql + t + (let ((result t)) + (with-test-file (s *test-file* :class 'mapped-file-simple-stream + :direction :input :if-does-not-exist :error + :initial-content *dumb-string*) + (setf result (and result (string= (read-line s) *dumb-string*)))) + result))) + +#+(or) +(define-test write-read-inet ;; Open a socket-simple-stream to the echo service and test if we ;; get it echoed back. Obviously fails if the echo service isn't ;; enabled. - (with-open-stream (s (make-instance 'socket-simple-stream - :remote-host *echo-server* - :remote-port 7 - :direction :io)) - (string= (prog1 - (write-line "Got it!" s) - (finish-output s)) - (read-line s))) - t) - -(deftest write-read-large-sc-1 + (assert-eql + t + (with-open-stream (s (make-instance 'socket-simple-stream + :remote-host *echo-server* + :remote-port 7 + :direction :io)) + (string= (prog1 + (write-line "Got it!" s) + (finish-output s)) + (read-line s))))) + +(define-test write-read-large-sc-1 ;; Do write and read with more data than the buffer will hold ;; (single-channel simple-stream) - (let* ((stream (make-instance 'file-simple-stream - :filename *test-file* :direction :output - :external-format :latin-1 - :if-exists :overwrite - :if-does-not-exist :create)) - (content (make-string (1+ (device-buffer-length stream)) - :initial-element #\x))) - (with-open-stream (s stream) - (write-string content s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (string= content (read-line s)))) - t) - -(deftest write-read-large-sc-2 - (let* ((stream (make-instance 'file-simple-stream - :filename *test-file* :direction :output - :external-format :latin-1 - :if-exists :overwrite - :if-does-not-exist :create)) - (length (1+ (* 3 (device-buffer-length stream)))) - (content (make-string length))) - (dotimes (i (length content)) - (setf (aref content i) (code-char (random 256)))) - (with-open-stream (s stream) - (write-string content s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (let ((seq (make-string length))) - #+nil (read-sequence seq s) - #-nil (dotimes (i length) - (setf (char seq i) (read-char s))) - (string= content seq)))) - t) - -(deftest write-read-large-sc-read-seq-2 - (let* ((stream (make-instance 'file-simple-stream - :filename *test-file* :direction :output - :external-format :latin-1 - :if-exists :overwrite - :if-does-not-exist :create)) - (length (1+ (* 3 (device-buffer-length stream)))) - (content (make-string length))) - (dotimes (i (length content)) - (setf (aref content i) (code-char (random 256)))) - (with-open-stream (s stream) - (write-string content s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (let ((seq (make-string length))) - (read-sequence seq s) - (string= content seq)))) - t) - -(deftest write-read-large-sc-3 - (let* ((stream (make-instance 'file-simple-stream - :filename *test-file* :direction :output - :external-format :latin-1 - :if-exists :overwrite - :if-does-not-exist :create)) - (length (1+ (* 3 (device-buffer-length stream)))) - (content (make-array length :element-type '(unsigned-byte 8)))) - (dotimes (i (length content)) - (setf (aref content i) (random 256))) - (with-open-stream (s stream) - (write-sequence content s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (let ((seq (make-array length :element-type '(unsigned-byte 8)))) - #+nil (read-sequence seq s) - #-nil (dotimes (i length) - (setf (aref seq i) (read-byte s))) - (equalp content seq)))) - t) - -(deftest write-read-large-sc-read-seq-3 - (let* ((stream (make-instance 'file-simple-stream - :filename *test-file* :direction :output - :external-format :latin-1 - :if-exists :overwrite - :if-does-not-exist :create)) - (length (1+ (* 3 (device-buffer-length stream)))) - (content (make-array length :element-type '(unsigned-byte 8)))) - (dotimes (i (length content)) - (setf (aref content i) (random 256))) - (with-open-stream (s stream) - (write-sequence content s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (let ((seq (make-array length :element-type '(unsigned-byte 8)))) - (read-sequence seq s) - (equalp content seq)))) - t) - -(deftest write-read-large-dc-1 + (assert-eql + t + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (content (make-string (1+ (device-buffer-length stream)) + :initial-element #\x))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (string= content (read-line s)))))) + +(define-test write-read-large-sc-2 + (assert-eql + t + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-string length))) + (dotimes (i (length content)) + (setf (aref content i) (code-char (random 256)))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-string length))) + #+nil (read-sequence seq s) + #-nil (dotimes (i length) + (setf (char seq i) (read-char s))) + (string= content seq)))))) + +(define-test write-read-large-sc-read-seq-2 + (assert-eql + t + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-string length))) + (dotimes (i (length content)) + (setf (aref content i) (code-char (random 256)))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-string length))) + (read-sequence seq s) + (string= content seq)))))) + +(define-test write-read-large-sc-3 + (assert-eql + t + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-array length :element-type '(unsigned-byte 8)))) + (dotimes (i (length content)) + (setf (aref content i) (random 256))) + (with-open-stream (s stream) + (write-sequence content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-array length :element-type '(unsigned-byte 8)))) + #+nil (read-sequence seq s) + #-nil (dotimes (i length) + (setf (aref seq i) (read-byte s))) + (equalp content seq)))))) + +(define-test write-read-large-sc-read-seq-3 + (assert-eql + t + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-array length :element-type '(unsigned-byte 8)))) + (dotimes (i (length content)) + (setf (aref content i) (random 256))) + (with-open-stream (s stream) + (write-sequence content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence seq s) + (equalp content seq)))))) + +#+(or) +(define-test write-read-large-dc-1 ;; Do write and read with more data than the buffer will hold ;; (dual-channel simple-stream; we only have socket streams atm) + (assert-eql + t (let* ((stream (make-instance 'socket-simple-stream :remote-host *echo-server* :remote-port 7 @@ -247,293 +261,309 @@ :initial-element #\x))) (with-open-stream (s stream) (string= (prog1 (write-line content s) (finish-output s)) - (read-line s)))) - t) - - -(deftest file-position-1 - ;; Test reading of file-position - (with-test-file (s *test-file* :class 'file-simple-stream :direction :input - :initial-content *dumb-string*) - (file-position s)) - 0) - -(deftest file-position-2 - ;; Test reading of file-position - (with-test-file (s *test-file* :class 'file-simple-stream :direction :input - :initial-content *dumb-string*) - (read-byte s) - (file-position s)) - 1) - -(deftest file-position-3 - ;; Test reading of file-position in the presence of unsaved data - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :output :if-exists :supersede - :if-does-not-exist :create) - (write-byte 50 s) - (file-position s)) - 1) - -(deftest file-position-4 - ;; Test reading of file-position in the presence of unsaved data and - ;; filled buffer - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-exists :overwrite :if-does-not-exist :create - :initial-content *dumb-string*) - (read-byte s) ; fill buffer - (write-byte 50 s) ; advance file-position - (file-position s)) - 2) - -(deftest file-position-5 - ;; Test file position when opening with :if-exists :append - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-exists :append :if-does-not-exist :create - :initial-content *dumb-string*) - (= (file-length s) (file-position s))) - T) - -(deftest write-read-unflushed-sc-1 - ;; Write something into a single-channel stream and read it back - ;; without explicitly flushing the buffer in-between - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-does-not-exist :create :if-exists :supersede) - (write-char #\x s) - (file-position s :start) - (read-char s)) - #\x) - -(deftest write-read-unflushed-sc-2 - ;; Write something into a single-channel stream, try to read back too much - (handler-case - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :io :if-does-not-exist :create - :if-exists :supersede) - (write-char #\x s) - (file-position s :start) - (read-char s) - (read-char s) - nil) - (end-of-file () t)) - t) - -(deftest write-read-unflushed-sc-3 - ;; Test writing in a buffer filled with previous file contents - (let ((result t)) - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-exists :overwrite :if-does-not-exist :create - :initial-content *dumb-string*) - (setq result (and result (char= (read-char s) (schar *dumb-string* 0)))) - (setq result (and result (= (file-position s) 1))) - (let ((pos (file-position s))) - (write-char #\x s) - (file-position s pos) - (setq result (and result (char= (read-char s) #\x))))) - result) - t) - -(deftest write-read-unflushed-sc-4 - ;; Test flushing of buffers - (progn - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-exists :overwrite :if-does-not-exist :create - :initial-content "Foo" - :delete-afterwards nil) - (read-char s) ; Fill the buffer. - (file-position s :start) ; Change existing data. - (write-char #\X s) - (file-position s :end) ; Extend file. - (write-char #\X s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (read-line s))) - "XooX" - T) - -(deftest write-read-append-sc-1 - ;; Test writing in the middle of a stream opened in append mode - (progn - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-exists :append :if-does-not-exist :create - :initial-content "Foo" - :delete-afterwards nil) - (file-position s :start) ; Jump to beginning. - (write-char #\X s) - (file-position s :end) ; Extend file. - (write-char #\X s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error) - (read-line s))) - "XooX" - T) - -(deftest write-read-mixed-sc-1 - ;; Test read/write-sequence of types string and (unsigned-byte 8) - (let ((uvector (make-array '(10) :element-type '(unsigned-byte 8) - :initial-element 64)) - (svector (make-array '(10) :element-type '(signed-byte 8) - :initial-element -1)) - (result-uvector (make-array '(10) :element-type '(unsigned-byte 8) - :initial-element 0)) - (result-svector (make-array '(10) :element-type '(signed-byte 8) - :initial-element 0)) - (result-string (make-string (length *dumb-string*) - :initial-element #\Space))) - (with-test-file (s *test-file* :class 'file-simple-stream :direction :io - :if-exists :overwrite :if-does-not-exist :create - :delete-afterwards nil) - (write-sequence svector s) - (write-sequence uvector s) - (write-sequence *dumb-string* s)) - (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error - :delete-afterwards nil) - (read-sequence result-svector s) - (read-sequence result-uvector s) - (read-sequence result-string s)) - (and (string= *dumb-string* result-string) - (equalp uvector result-uvector) - (equalp svector result-svector))) - T) - -(deftest create-read-mapped-file-read-seq-1 - ;; Read data via a mapped-file-simple-stream object using - ;; read-sequence. - (let ((result t)) - (with-test-file (s *test-file* :class 'mapped-file-simple-stream - :direction :input :if-does-not-exist :error - :initial-content *dumb-string*) - (let ((seq (make-string (length *dumb-string*)))) - (read-sequence seq s) - (setf result (and result (string= seq *dumb-string*))))) - result) - t) - -(deftest create-read-mapped-file-read-seq-2 - ;; Read data via a mapped-file-simple-stream object using - ;; read-sequence. - (let ((result t)) - (with-test-file (s *test-file* :class 'mapped-file-simple-stream - :direction :input :if-does-not-exist :error - :initial-content *dumb-string*) - (let ((seq (make-string (+ 10 (length *dumb-string*))))) - (read-sequence seq s) - (setf result (and result - (string= seq *dumb-string* - :end1 (length *dumb-string*)))))) - result) - t) + (read-line s)))))) + + +(define-test file-position-1 + ;; Test reading of file-position + (assert-eql + 0 + (with-test-file (s *test-file* :class 'file-simple-stream :direction :input + :initial-content *dumb-string*) + (file-position s)))) + +(define-test file-position-2 + ;; Test reading of file-position + (assert-eql + 1 + (with-test-file (s *test-file* :class 'file-simple-stream :direction :input + :initial-content *dumb-string*) + (read-byte s) + (file-position s)))) + +(define-test file-position-3 + ;; Test reading of file-position in the presence of unsaved data + (assert-eql + 1 + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (write-byte 50 s) + (file-position s)))) + +(define-test file-position-4 + ;; Test reading of file-position in the presence of unsaved data and + ;; filled buffer + (assert-eql + 2 + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :initial-content *dumb-string*) + (read-byte s) ; fill buffer + (write-byte 50 s) ; advance file-position + (file-position s)))) + +(define-test file-position-5 + ;; Test file position when opening with :if-exists :append + (assert-eql + t + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :append :if-does-not-exist :create + :initial-content *dumb-string*) + (= (file-length s) (file-position s))))) + +(define-test write-read-unflushed-sc-1 + ;; Write something into a single-channel stream and read it back + ;; without explicitly flushing the buffer in-between + (assert-eql + #\x + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-does-not-exist :create :if-exists :supersede) + (write-char #\x s) + (file-position s :start) + (read-char s)))) + +(define-test write-read-unflushed-sc-2 + ;; Write something into a single-channel stream, try to read back too much + (assert-eql + t + (handler-case + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :io :if-does-not-exist :create + :if-exists :supersede) + (write-char #\x s) + (file-position s :start) + (read-char s) + (read-char s) + nil) + (end-of-file () t)))) + +(define-test write-read-unflushed-sc-3 + ;; Test writing in a buffer filled with previous file contents + (assert-eql + t + (let ((result t)) + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :initial-content *dumb-string*) + (setq result (and result (char= (read-char s) (schar *dumb-string* 0)))) + (setq result (and result (= (file-position s) 1))) + (let ((pos (file-position s))) + (write-char #\x s) + (file-position s pos) + (setq result (and result (char= (read-char s) #\x))))) + result))) + +(define-test write-read-unflushed-sc-4 + ;; Test flushing of buffers + (assert-equal + '("XooX" T) + (progn + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :initial-content "Foo" + :delete-afterwards nil) + (read-char s) ; Fill the buffer. + (file-position s :start) ; Change existing data. + (write-char #\X s) + (file-position s :end) ; Extend file. + (write-char #\X s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (multiple-value-list (read-line s)))))) + +(define-test write-read-append-sc-1 + ;; Test writing in the middle of a stream opened in append mode + (assert-equal + '("XooX" T) + (progn + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :append :if-does-not-exist :create + :initial-content "Foo" + :delete-afterwards nil) + (file-position s :start) ; Jump to beginning. + (write-char #\X s) + (file-position s :end) ; Extend file. + (write-char #\X s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (multiple-value-list (read-line s)))))) + +(define-test write-read-mixed-sc-1 + ;; Test read/write-sequence of types string and (unsigned-byte 8) + (assert-eql + t + (let ((uvector (make-array '(10) :element-type '(unsigned-byte 8) + :initial-element 64)) + (svector (make-array '(10) :element-type '(signed-byte 8) + :initial-element -1)) + (result-uvector (make-array '(10) :element-type '(unsigned-byte 8) + :initial-element 0)) + (result-svector (make-array '(10) :element-type '(signed-byte 8) + :initial-element 0)) + (result-string (make-string (length *dumb-string*) + :initial-element #\Space))) + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :delete-afterwards nil) + (write-sequence svector s) + (write-sequence uvector s) + (write-sequence *dumb-string* s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error + :delete-afterwards nil) + (read-sequence result-svector s) + (read-sequence result-uvector s) + (read-sequence result-string s)) + (and (string= *dumb-string* result-string) + (equalp uvector result-uvector) + (equalp svector result-svector))))) + +(define-test create-read-mapped-file-read-seq-1 + ;; Read data via a mapped-file-simple-stream object using + ;; read-sequence. + (assert-eql + t + (let ((result t)) + (with-test-file (s *test-file* :class 'mapped-file-simple-stream + :direction :input :if-does-not-exist :error + :initial-content *dumb-string*) + (let ((seq (make-string (length *dumb-string*)))) + (read-sequence seq s) + (setf result (and result (string= seq *dumb-string*))))) + result))) + +(define-test create-read-mapped-file-read-seq-2 + ;; Read data via a mapped-file-simple-stream object using + ;; read-sequence. + (assert-eql + t + (let ((result t)) + (with-test-file (s *test-file* :class 'mapped-file-simple-stream + :direction :input :if-does-not-exist :error + :initial-content *dumb-string*) + (let ((seq (make-string (+ 10 (length *dumb-string*))))) + (read-sequence seq s) + (setf result (and result + (string= seq *dumb-string* + :end1 (length *dumb-string*)))))) + result))) ;;; From Lynn Quam, cmucl-imp, 2004-12-04: After doing a READ-VECTOR, ;;; FILE-POSITION returns the wrong value. -(deftest file-position-6 - ;; Test the file-position is right. - (with-open-file (st1 "/etc/passwd" :class 'stream:file-simple-stream) - (with-open-file (st2 "/etc/passwd" :element-type '(unsigned-byte 8)) - (let* ((buf1 (make-array 100 :element-type '(unsigned-byte 8))) - (buf2 (make-array 100 :element-type '(unsigned-byte 8))) - (n1 (stream:read-vector buf1 st1)) - (n2 (read-sequence buf2 st2))) - (list n1 (file-position st1) - n2 (file-position st2))))) - (100 100 100 100) - ) +(lisp-unit:define-test file-position-6 + ;; Test the file-position is right. + (assert-equal + '(100 100 100 100) + (with-open-file (st1 "/etc/passwd" :class 'stream:file-simple-stream) + (with-open-file (st2 "/etc/passwd" :element-type '(unsigned-byte 8)) + (let* ((buf1 (make-array 100 :element-type '(unsigned-byte 8))) + (buf2 (make-array 100 :element-type '(unsigned-byte 8))) + (n1 (stream:read-vector buf1 st1)) + (n2 (read-sequence buf2 st2))) + (list n1 (file-position st1) + n2 (file-position st2))))))) ;;; From Madhu, cmucl-imp, 2006-12-16 -(deftest file-position-7 - (with-open-file (st1 "/etc/passwd" :mapped t :class 'stream:file-simple-stream) - (let* ((posn1 (file-position st1)) - (line1 (read-line st1)) - (posn2 (file-position st1))) - (list posn1 (= posn2 (1+ (length line1)))))) - (0 t)) - -(deftest file-position-8 - (with-open-file (st1 "/etc/passwd" :mapped t :class 'stream:file-simple-stream) - (let* ((posn1 (file-position st1)) - (c1 (read-char st1)) - (posn2 (file-position st1))) - (list posn1 posn2))) - (0 1)) +(define-test file-position-7 + (assert-equal + '(0 t) + (with-open-file (st1 "/etc/passwd" :mapped t :class 'stream:file-simple-stream) + (let* ((posn1 (file-position st1)) + (line1 (read-line st1)) + (posn2 (file-position st1))) + (list posn1 (= posn2 (1+ (length line1)))))))) + +(define-test file-position-8 + (assert-equal + '(0 1) + (with-open-file (st1 "/etc/passwd" :mapped t :class 'stream:file-simple-stream) + (let* ((posn1 (file-position st1)) + (c1 (read-char st1)) + (posn2 (file-position st1))) + (list posn1 posn2))))) ;;; Some specific tests for full unicode support. #+unicode -(deftest unicode-read-1 - ;; Tests if reading unicode surrogates works - (let ((string (map 'string #'code-char '(#xd800 #xdc00)))) - (with-open-file (s *test-file* - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :external-format :utf8) - (write-string string s)) - (with-open-file (s *test-file* :class 'file-simple-stream - :direction :input - :if-does-not-exist :error - :external-format :utf8) - (let ((seq (read-line s))) - (string= string seq)))) - t) +(define-test unicode-read-1 + ;; Tests if reading unicode surrogates works + (assert-eql + t + (let ((string (map 'string #'code-char '(#xd800 #xdc00)))) + (with-open-file (s *test-file* + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* :class 'file-simple-stream + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))))) #+unicode -(deftest unicode-read-large-1 - ;; Tests if reading unicode surrogates works - (let ((string (concatenate 'string - (map 'string #'code-char '(#xd800 #xdc00)) - (make-string 5000 :initial-element #\X)))) - (with-open-file (s *test-file* - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :external-format :utf8) - (write-string string s)) - (with-open-file (s *test-file* :class 'file-simple-stream - :direction :input - :if-does-not-exist :error - :external-format :utf8) - (let ((seq (read-line s))) - (string= string seq)))) - t) +(define-test unicode-read-large-1 + ;; Tests if reading unicode surrogates works + (assert-eql + t + (let ((string (concatenate 'string + (map 'string #'code-char '(#xd800 #xdc00)) + (make-string 5000 :initial-element #\X)))) + (with-open-file (s *test-file* + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* :class 'file-simple-stream + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))))) #+unicode -(deftest unicode-write-1 - ;; Tests if writing unicode surrogates work - (let ((string (map 'string #'code-char '(#xd800 #xdc00)))) - (with-open-file (s *test-file* - :class 'file-simple-stream - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :external-format :utf8) - (write-string string s)) - (with-open-file (s *test-file* - :direction :input - :if-does-not-exist :error - :external-format :utf8) - (let ((seq (read-line s))) - (string= string seq)))) - t) +(define-test unicode-write-1 + ;; Tests if writing unicode surrogates work + (assert-eql + t + (let ((string (map 'string #'code-char '(#xd800 #xdc00)))) + (with-open-file (s *test-file* + :class 'file-simple-stream + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))))) #+unicode -(deftest unicode-write-large-1 - ;; Tests if writing unicode surrogates work - (let ((string (concatenate 'string - (map 'string #'code-char '(#xd800 #xdc00)) - (make-string 5000 :initial-element #\X)))) - (with-open-file (s *test-file* - :class 'file-simple-stream - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :external-format :utf8) - (write-string string s)) - (with-open-file (s *test-file* - :direction :input - :if-does-not-exist :error - :external-format :utf8) - (let ((seq (read-line s))) - (string= string seq)))) - t) +(define-test unicode-write-large-1 + ;; Tests if writing unicode surrogates work + (assert-eql + t + (let ((string (concatenate 'string + (map 'string #'code-char '(#xd800 #xdc00)) + (make-string 5000 :initial-element #\X)))) + (with-open-file (s *test-file* + :class 'file-simple-stream + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))))) commit 866c8bcf2fc93eb6dacd5707ff0e4cacea72734b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jan 7 19:48:15 2014 -0800 Copy src/pcl/simple-streams/rt/simple-streams-tests.lisp to tests/simple-streams.lisp. Unchanged. diff --git a/tests/simple-streams.lisp b/tests/simple-streams.lisp new file mode 100644 index 0000000..7a9a24f --- /dev/null +++ b/tests/simple-streams.lisp @@ -0,0 +1,539 @@ +;;;; -*- lisp -*- + +(require :simple-streams) + +(defpackage simple-streams-test + (:use #:common-lisp #:stream #:rt)) + + +(in-package #:simple-streams-test) + +(defparameter *dumb-string* + "This file was created by simple-stream-tests.lisp. Nothing to see here, move along.") + +(defparameter *test-path* + (merge-pathnames (make-pathname :name :unspecific :type :unspecific + :version :unspecific) + *load-truename*) + "Directory for temporary test files.") + +(defparameter *test-file* + (merge-pathnames #p"test-data.tmp" *test-path*)) + +(defparameter *echo-server* "127.0.0.1") + +(eval-when (:load-toplevel) + (ensure-directories-exist *test-path* :verbose t)) + +;;; Non-destructive functional analog of REMF +(defun remove-key (key list) + (loop for (current-key val . rest) on list by #'cddr + until (eql current-key key) + collect current-key into result + collect val into result + finally (return (nconc result rest)))) + +(defun create-test-file (&key (filename *test-file*) (content *dumb-string*)) + (with-open-file (s filename :direction :output + :external-format :latin-1 + :if-does-not-exist :create + :if-exists :supersede) + (write-sequence content s))) + +(defun remove-test-file (&key (filename *test-file*)) + (delete-file filename)) + +(defmacro with-test-file ((stream file &rest open-arguments + &key (delete-afterwards t) + initial-content + &allow-other-keys) + &body body) + (setq open-arguments (remove-key :delete-afterwards open-arguments)) + (setq open-arguments (remove-key :initial-content open-arguments)) + (if initial-content + (let ((create-file-stream (gensym))) + `(progn + (with-open-file (,create-file-stream ,file :direction :output + :external-format :latin-1 + :if-exists :supersede + :if-does-not-exist :create) + (write-sequence ,initial-content ,create-file-stream)) + (unwind-protect + (with-open-file (,stream ,file ,@open-arguments + :external-format :latin-1) + (progn ,@body)) + ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) + `(unwind-protect + (with-open-file (,stream ,file ,@open-arguments + :external-format :latin-1) + (progn ,@body)) + ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) + +(deftest create-file-1 + ;; Create a file-simple-stream, write data. + (prog1 + (with-open-stream (s (make-instance 'file-simple-stream + :filename *test-file* + :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (string= (write-string *dumb-string* s) *dumb-string*)) + (delete-file *test-file*)) + t) + +(deftest create-file-2 + ;; Create a file-simple-stream via :class argument to open, write data. + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :output :if-exists :overwrite + :if-does-not-exist :create) + (string= (write-string *dumb-string* s) *dumb-string*)) + t) + +(deftest create-read-file-1 + ;; Via file-simple-stream objects, write and then re-read data. + (let ((result t)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :output :if-exists :overwrite + :if-does-not-exist :create :delete-afterwards nil) + (write-line *dumb-string* s) + (setf result (and result (string= (write-string *dumb-string* s) + *dumb-string*)))) + + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + ;; Check first line + (multiple-value-bind (string missing-newline-p) + (read-line s) + (setf result (and result (string= string *dumb-string*) + (not missing-newline-p)))) + ;; Check second line + (multiple-value-bind (string missing-newline-p) + (read-line s) + (setf result (and result (string= string *dumb-string*) + missing-newline-p)))) + result) + t) + +(deftest create-read-mapped-file-1 + ;; Read data via a mapped-file-simple-stream object. + (let ((result t)) + (with-test-file (s *test-file* :class 'mapped-file-simple-stream + :direction :input :if-does-not-exist :error + :initial-content *dumb-string*) + (setf result (and result (string= (read-line s) *dumb-string*)))) + result) + t) + +(deftest write-read-inet + ;; Open a socket-simple-stream to the echo service and test if we + ;; get it echoed back. Obviously fails if the echo service isn't + ;; enabled. + (with-open-stream (s (make-instance 'socket-simple-stream + :remote-host *echo-server* + :remote-port 7 + :direction :io)) + (string= (prog1 + (write-line "Got it!" s) + (finish-output s)) + (read-line s))) + t) + +(deftest write-read-large-sc-1 + ;; Do write and read with more data than the buffer will hold + ;; (single-channel simple-stream) + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (content (make-string (1+ (device-buffer-length stream)) + :initial-element #\x))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (string= content (read-line s)))) + t) + +(deftest write-read-large-sc-2 + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-string length))) + (dotimes (i (length content)) + (setf (aref content i) (code-char (random 256)))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-string length))) + #+nil (read-sequence seq s) + #-nil (dotimes (i length) + (setf (char seq i) (read-char s))) + (string= content seq)))) + t) + +(deftest write-read-large-sc-read-seq-2 + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-string length))) + (dotimes (i (length content)) + (setf (aref content i) (code-char (random 256)))) + (with-open-stream (s stream) + (write-string content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-string length))) + (read-sequence seq s) + (string= content seq)))) + t) + +(deftest write-read-large-sc-3 + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-array length :element-type '(unsigned-byte 8)))) + (dotimes (i (length content)) + (setf (aref content i) (random 256))) + (with-open-stream (s stream) + (write-sequence content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-array length :element-type '(unsigned-byte 8)))) + #+nil (read-sequence seq s) + #-nil (dotimes (i length) + (setf (aref seq i) (read-byte s))) + (equalp content seq)))) + t) + +(deftest write-read-large-sc-read-seq-3 + (let* ((stream (make-instance 'file-simple-stream + :filename *test-file* :direction :output + :external-format :latin-1 + :if-exists :overwrite + :if-does-not-exist :create)) + (length (1+ (* 3 (device-buffer-length stream)))) + (content (make-array length :element-type '(unsigned-byte 8)))) + (dotimes (i (length content)) + (setf (aref content i) (random 256))) + (with-open-stream (s stream) + (write-sequence content s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (let ((seq (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence seq s) + (equalp content seq)))) + t) + +(deftest write-read-large-dc-1 + ;; Do write and read with more data than the buffer will hold + ;; (dual-channel simple-stream; we only have socket streams atm) + (let* ((stream (make-instance 'socket-simple-stream + :remote-host *echo-server* + :remote-port 7 + :direction :io)) + (content (make-string (1+ (device-buffer-length stream)) + :initial-element #\x))) + (with-open-stream (s stream) + (string= (prog1 (write-line content s) (finish-output s)) + (read-line s)))) + t) + + +(deftest file-position-1 + ;; Test reading of file-position + (with-test-file (s *test-file* :class 'file-simple-stream :direction :input + :initial-content *dumb-string*) + (file-position s)) + 0) + +(deftest file-position-2 + ;; Test reading of file-position + (with-test-file (s *test-file* :class 'file-simple-stream :direction :input + :initial-content *dumb-string*) + (read-byte s) + (file-position s)) + 1) + +(deftest file-position-3 + ;; Test reading of file-position in the presence of unsaved data + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (write-byte 50 s) + (file-position s)) + 1) + +(deftest file-position-4 + ;; Test reading of file-position in the presence of unsaved data and + ;; filled buffer + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :initial-content *dumb-string*) + (read-byte s) ; fill buffer + (write-byte 50 s) ; advance file-position + (file-position s)) + 2) + +(deftest file-position-5 + ;; Test file position when opening with :if-exists :append + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :append :if-does-not-exist :create + :initial-content *dumb-string*) + (= (file-length s) (file-position s))) + T) + +(deftest write-read-unflushed-sc-1 + ;; Write something into a single-channel stream and read it back + ;; without explicitly flushing the buffer in-between + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-does-not-exist :create :if-exists :supersede) + (write-char #\x s) + (file-position s :start) + (read-char s)) + #\x) + +(deftest write-read-unflushed-sc-2 + ;; Write something into a single-channel stream, try to read back too much + (handler-case + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :io :if-does-not-exist :create + :if-exists :supersede) + (write-char #\x s) + (file-position s :start) + (read-char s) + (read-char s) + nil) + (end-of-file () t)) + t) + +(deftest write-read-unflushed-sc-3 + ;; Test writing in a buffer filled with previous file contents + (let ((result t)) + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :initial-content *dumb-string*) + (setq result (and result (char= (read-char s) (schar *dumb-string* 0)))) + (setq result (and result (= (file-position s) 1))) + (let ((pos (file-position s))) + (write-char #\x s) + (file-position s pos) + (setq result (and result (char= (read-char s) #\x))))) + result) + t) + +(deftest write-read-unflushed-sc-4 + ;; Test flushing of buffers + (progn + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :initial-content "Foo" + :delete-afterwards nil) + (read-char s) ; Fill the buffer. + (file-position s :start) ; Change existing data. + (write-char #\X s) + (file-position s :end) ; Extend file. + (write-char #\X s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (read-line s))) + "XooX" + T) + +(deftest write-read-append-sc-1 + ;; Test writing in the middle of a stream opened in append mode + (progn + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :append :if-does-not-exist :create + :initial-content "Foo" + :delete-afterwards nil) + (file-position s :start) ; Jump to beginning. + (write-char #\X s) + (file-position s :end) ; Extend file. + (write-char #\X s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error) + (read-line s))) + "XooX" + T) + +(deftest write-read-mixed-sc-1 + ;; Test read/write-sequence of types string and (unsigned-byte 8) + (let ((uvector (make-array '(10) :element-type '(unsigned-byte 8) + :initial-element 64)) + (svector (make-array '(10) :element-type '(signed-byte 8) + :initial-element -1)) + (result-uvector (make-array '(10) :element-type '(unsigned-byte 8) + :initial-element 0)) + (result-svector (make-array '(10) :element-type '(signed-byte 8) + :initial-element 0)) + (result-string (make-string (length *dumb-string*) + :initial-element #\Space))) + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :delete-afterwards nil) + (write-sequence svector s) + (write-sequence uvector s) + (write-sequence *dumb-string* s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error + :delete-afterwards nil) + (read-sequence result-svector s) + (read-sequence result-uvector s) + (read-sequence result-string s)) + (and (string= *dumb-string* result-string) + (equalp uvector result-uvector) + (equalp svector result-svector))) + T) + +(deftest create-read-mapped-file-read-seq-1 + ;; Read data via a mapped-file-simple-stream object using + ;; read-sequence. + (let ((result t)) + (with-test-file (s *test-file* :class 'mapped-file-simple-stream + :direction :input :if-does-not-exist :error + :initial-content *dumb-string*) + (let ((seq (make-string (length *dumb-string*)))) + (read-sequence seq s) + (setf result (and result (string= seq *dumb-string*))))) + result) + t) + +(deftest create-read-mapped-file-read-seq-2 + ;; Read data via a mapped-file-simple-stream object using + ;; read-sequence. + (let ((result t)) + (with-test-file (s *test-file* :class 'mapped-file-simple-stream + :direction :input :if-does-not-exist :error + :initial-content *dumb-string*) + (let ((seq (make-string (+ 10 (length *dumb-string*))))) + (read-sequence seq s) + (setf result (and result + (string= seq *dumb-string* + :end1 (length *dumb-string*)))))) + result) + t) + + +;;; From Lynn Quam, cmucl-imp, 2004-12-04: After doing a READ-VECTOR, +;;; FILE-POSITION returns the wrong value. + +(deftest file-position-6 + ;; Test the file-position is right. + (with-open-file (st1 "/etc/passwd" :class 'stream:file-simple-stream) + (with-open-file (st2 "/etc/passwd" :element-type '(unsigned-byte 8)) + (let* ((buf1 (make-array 100 :element-type '(unsigned-byte 8))) + (buf2 (make-array 100 :element-type '(unsigned-byte 8))) + (n1 (stream:read-vector buf1 st1)) + (n2 (read-sequence buf2 st2))) + (list n1 (file-position st1) + n2 (file-position st2))))) + (100 100 100 100) + ) + +;;; From Madhu, cmucl-imp, 2006-12-16 +(deftest file-position-7 + (with-open-file (st1 "/etc/passwd" :mapped t :class 'stream:file-simple-stream) + (let* ((posn1 (file-position st1)) + (line1 (read-line st1)) + (posn2 (file-position st1))) + (list posn1 (= posn2 (1+ (length line1)))))) + (0 t)) + +(deftest file-position-8 + (with-open-file (st1 "/etc/passwd" :mapped t :class 'stream:file-simple-stream) + (let* ((posn1 (file-position st1)) + (c1 (read-char st1)) + (posn2 (file-position st1))) + (list posn1 posn2))) + (0 1)) + +;;; Some specific tests for full unicode support. +#+unicode +(deftest unicode-read-1 + ;; Tests if reading unicode surrogates works + (let ((string (map 'string #'code-char '(#xd800 #xdc00)))) + (with-open-file (s *test-file* + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* :class 'file-simple-stream + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))) + t) + +#+unicode +(deftest unicode-read-large-1 + ;; Tests if reading unicode surrogates works + (let ((string (concatenate 'string + (map 'string #'code-char '(#xd800 #xdc00)) + (make-string 5000 :initial-element #\X)))) + (with-open-file (s *test-file* + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* :class 'file-simple-stream + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))) + t) + +#+unicode +(deftest unicode-write-1 + ;; Tests if writing unicode surrogates work + (let ((string (map 'string #'code-char '(#xd800 #xdc00)))) + (with-open-file (s *test-file* + :class 'file-simple-stream + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))) + t) + +#+unicode +(deftest unicode-write-large-1 + ;; Tests if writing unicode surrogates work + (let ((string (concatenate 'string + (map 'string #'code-char '(#xd800 #xdc00)) + (make-string 5000 :initial-element #\X)))) + (with-open-file (s *test-file* + :class 'file-simple-stream + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf8) + (write-string string s)) + (with-open-file (s *test-file* + :direction :input + :if-does-not-exist :error + :external-format :utf8) + (let ((seq (read-line s))) + (string= string seq)))) + t) ----------------------------------------------------------------------- Summary of changes: tests/simple-streams.lisp | 569 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 569 insertions(+) create mode 100644 tests/simple-streams.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-62-gf399fc8
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 f399fc8dab36676d617b1fa7e1e2c70bc5ddbffa (commit) via d29ef8f73a446d978406fec5bccbdf8882964870 (commit) from 28ca34951c313162068768fb80742254dd7af1b6 (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 f399fc8dab36676d617b1fa7e1e2c70bc5ddbffa Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 14:33:26 2014 -0700 Import hyperbolic functions from fdlibm, as is. diff --git a/src/lisp/e_cosh.c b/src/lisp/e_cosh.c new file mode 100644 index 0000000..204017d --- /dev/null +++ b/src/lisp/e_cosh.c @@ -0,0 +1,89 @@ + +/* @(#)e_cosh.c 1.3 95/01/18 */ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunSoft, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* __ieee754_cosh(x) + * Method : + * mathematically cosh(x) if defined to be (exp(x)+exp(-x))/2 + * 1. Replace x by |x| (cosh(x) = cosh(-x)). + * 2. + * [ exp(x) - 1 ]^2 + * 0 <= x <= ln2/2 : cosh(x) := 1 + ------------------- + * 2*exp(x) + * + * exp(x) + 1/exp(x) + * ln2/2 <= x <= 22 : cosh(x) := ------------------- + * 2 + * 22 <= x <= lnovft : cosh(x) := exp(x)/2 + * lnovft <= x <= ln2ovft: cosh(x) := exp(x/2)/2 * exp(x/2) + * ln2ovft < x : cosh(x) := huge*huge (overflow) + * + * Special cases: + * cosh(x) is |x| if x is +INF, -INF, or NaN. + * only cosh(0)=1 is exact for finite x. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double one = 1.0, half=0.5, huge = 1.0e300; +#else +static double one = 1.0, half=0.5, huge = 1.0e300; +#endif + +#ifdef __STDC__ + double __ieee754_cosh(double x) +#else + double __ieee754_cosh(x) + double x; +#endif +{ + double t,w; + int ix; + unsigned lx; + + /* High word of |x|. */ + ix = __HI(x); + ix &= 0x7fffffff; + + /* x is INF or NaN */ + if(ix>=0x7ff00000) return x*x; + + /* |x| in [0,0.5*ln2], return 1+expm1(|x|)^2/(2*exp(|x|)) */ + if(ix<0x3fd62e43) { + t = expm1(fabs(x)); + w = one+t; + if (ix<0x3c800000) return w; /* cosh(tiny) = 1 */ + return one+(t*t)/(w+w); + } + + /* |x| in [0.5*ln2,22], return (exp(|x|)+1/exp(|x|)/2; */ + if (ix < 0x40360000) { + t = __ieee754_exp(fabs(x)); + return half*t+half/t; + } + + /* |x| in [22, log(maxdouble)] return half*exp(|x|) */ + if (ix < 0x40862E42) return half*__ieee754_exp(fabs(x)); + + /* |x| in [log(maxdouble), overflowthresold] */ + lx = *( (((*(unsigned*)&one)>>29)) + (unsigned*)&x); + if (ix<0x408633CE || + (ix==0x408633ce)&&(lx<=(unsigned)0x8fb9f87d)) { + w = __ieee754_exp(half*fabs(x)); + t = half*w; + return t*w; + } + + /* |x| > overflowthresold, cosh(x) overflow */ + return huge*huge; +} diff --git a/src/lisp/e_sinh.c b/src/lisp/e_sinh.c new file mode 100644 index 0000000..8af8a11 --- /dev/null +++ b/src/lisp/e_sinh.c @@ -0,0 +1,82 @@ + +/* @(#)e_sinh.c 1.3 95/01/18 */ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunSoft, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* __ieee754_sinh(x) + * Method : + * mathematically sinh(x) if defined to be (exp(x)-exp(-x))/2 + * 1. Replace x by |x| (sinh(-x) = -sinh(x)). + * 2. + * E + E/(E+1) + * 0 <= x <= 22 : sinh(x) := --------------, E=expm1(x) + * 2 + * + * 22 <= x <= lnovft : sinh(x) := exp(x)/2 + * lnovft <= x <= ln2ovft: sinh(x) := exp(x/2)/2 * exp(x/2) + * ln2ovft < x : sinh(x) := x*shuge (overflow) + * + * Special cases: + * sinh(x) is |x| if x is +INF, -INF, or NaN. + * only sinh(0)=0 is exact for finite x. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double one = 1.0, shuge = 1.0e307; +#else +static double one = 1.0, shuge = 1.0e307; +#endif + +#ifdef __STDC__ + double __ieee754_sinh(double x) +#else + double __ieee754_sinh(x) + double x; +#endif +{ + double t,w,h; + int ix,jx; + unsigned lx; + + /* High word of |x|. */ + jx = __HI(x); + ix = jx&0x7fffffff; + + /* x is INF or NaN */ + if(ix>=0x7ff00000) return x+x; + + h = 0.5; + if (jx<0) h = -h; + /* |x| in [0,22], return sign(x)*0.5*(E+E/(E+1))) */ + if (ix < 0x40360000) { /* |x|<22 */ + if (ix<0x3e300000) /* |x|<2**-28 */ + if(shuge+x>one) return x;/* sinh(tiny) = tiny with inexact */ + t = expm1(fabs(x)); + if(ix<0x3ff00000) return h*(2.0*t-t*t/(t+one)); + return h*(t+t/(t+one)); + } + + /* |x| in [22, log(maxdouble)] return 0.5*exp(|x|) */ + if (ix < 0x40862E42) return h*__ieee754_exp(fabs(x)); + + /* |x| in [log(maxdouble), overflowthresold] */ + lx = *( (((*(unsigned*)&one)>>29)) + (unsigned*)&x); + if (ix<0x408633CE || (ix==0x408633ce)&&(lx<=(unsigned)0x8fb9f87d)) { + w = __ieee754_exp(0.5*fabs(x)); + t = h*w; + return t*w; + } + + /* |x| > overflowthresold, sinh(x) overflow */ + return x*shuge; +} diff --git a/src/lisp/s_tanh.c b/src/lisp/s_tanh.c new file mode 100644 index 0000000..7d77c2e --- /dev/null +++ b/src/lisp/s_tanh.c @@ -0,0 +1,82 @@ + +/* @(#)s_tanh.c 1.3 95/01/18 */ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunSoft, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* Tanh(x) + * Return the Hyperbolic Tangent of x + * + * Method : + * x -x + * e - e + * 0. tanh(x) is defined to be ----------- + * x -x + * e + e + * 1. reduce x to non-negative by tanh(-x) = -tanh(x). + * 2. 0 <= x <= 2**-55 : tanh(x) := x*(one+x) + * -t + * 2**-55 < x <= 1 : tanh(x) := -----; t = expm1(-2x) + * t + 2 + * 2 + * 1 <= x <= 22.0 : tanh(x) := 1- ----- ; t=expm1(2x) + * t + 2 + * 22.0 < x <= INF : tanh(x) := 1. + * + * Special cases: + * tanh(NaN) is NaN; + * only tanh(0)=0 is exact for finite argument. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double one=1.0, two=2.0, tiny = 1.0e-300; +#else +static double one=1.0, two=2.0, tiny = 1.0e-300; +#endif + +#ifdef __STDC__ + double tanh(double x) +#else + double tanh(x) + double x; +#endif +{ + double t,z; + int jx,ix; + + /* High word of |x|. */ + jx = __HI(x); + ix = jx&0x7fffffff; + + /* x is INF or NaN */ + if(ix>=0x7ff00000) { + if (jx>=0) return one/x+one; /* tanh(+-inf)=+-1 */ + else return one/x-one; /* tanh(NaN) = NaN */ + } + + /* |x| < 22 */ + if (ix < 0x40360000) { /* |x|<22 */ + if (ix<0x3c800000) /* |x|<2**-55 */ + return x*(one+x); /* tanh(small) = small */ + if (ix>=0x3ff00000) { /* |x|>=1 */ + t = expm1(two*fabs(x)); + z = one - two/(t+two); + } else { + t = expm1(-two*fabs(x)); + z= -t/(t+two); + } + /* |x| > 22, return +-1 */ + } else { + z = one - tiny; /* raised inexact flag */ + } + return (jx>=0)? z: -z; +} commit d29ef8f73a446d978406fec5bccbdf8882964870 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:56:04 2014 -0700 Add some braces to silence the warning from clang about dangling else statements. diff --git a/src/lisp/s_log1p.c b/src/lisp/s_log1p.c index eaec38a..87ed927 100644 --- a/src/lisp/s_log1p.c +++ b/src/lisp/s_log1p.c @@ -159,8 +159,14 @@ static double zero = 0.0; } hfsq=0.5*f*f; if(hu==0) { /* |f| < 2**-20 */ - if(f==zero) if(k==0) return zero; - else {c += k*ln2_lo; return k*ln2_hi+c;} + if(f==zero) { + if(k==0) + return zero; + else { + c += k*ln2_lo; return k*ln2_hi+c; + } + } + R = hfsq*(1.0-0.66666666666666666*f); if(k==0) return f-R; else return k*ln2_hi-((R-(k*ln2_lo+c))-f); ----------------------------------------------------------------------- Summary of changes: src/lisp/e_cosh.c | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp/e_sinh.c | 82 +++++++++++++++++++++++++++++++++++++++++++++++ src/lisp/s_log1p.c | 10 ++++-- src/lisp/s_tanh.c | 82 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 261 insertions(+), 2 deletions(-) create mode 100644 src/lisp/e_cosh.c create mode 100644 src/lisp/e_sinh.c create mode 100644 src/lisp/s_tanh.c hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-24-g2ade088
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 2ade088e991102f642e20a3d20239bf8b2b52633 (commit) from 06ca7d326f688d40ad8730bbd2faa8ca7813d2f0 (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 2ade088e991102f642e20a3d20239bf8b2b52633 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Jul 26 09:00:35 2014 -0700 Some cleanup of the trig code. * code/exports.lisp: * Export %ieee754-rem-pi/2 and %sincos. * code/irrat.lisp: * Remove some conditionalization that is always true now. * compiler/float-tran.lisp: * %sincos is exported so we don't need the package qualifier. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index ca0a60b..5c8168d 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2342,7 +2342,10 @@ "%COMPLEX-DOUBLE-FLOAT" "%COMPLEX-DOUBLE-DOUBLE-FLOAT" "STANDARD-READTABLE-MODIFIED-ERROR" - "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR") + "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" + + "%IEEE754-REM-PI/2" + "%SINCOS") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 032a6ac..c48d09d 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -64,19 +64,11 @@ ;;; Please refer to the Unix man pages for details about these routines. ;;; Trigonometric. -#-(and x86 (not sse2)) -(progn - ;; For x86 (without sse2), we can use x87 instructions to implement - ;; these. With sse2, we don't currently support that, so these - ;; should be disabled. -;; (def-math-rtn "sin" 1) -;; (def-math-rtn "cos" 1) - ;; (def-math-rtn "tan" 1) - (def-math-rtn ("fdlibm_sin" %sin) 1) - (def-math-rtn ("fdlibm_cos" %cos) 1) - (def-math-rtn ("fdlibm_tan" %tan) 1) - (def-math-rtn "atan" 1) - (def-math-rtn "atan2" 2)) +(def-math-rtn ("fdlibm_sin" %sin) 1) +(def-math-rtn ("fdlibm_cos" %cos) 1) +(def-math-rtn ("fdlibm_tan" %tan) 1) +(def-math-rtn "atan" 1) +(def-math-rtn "atan2" 2) (def-math-rtn "asin" 1) (def-math-rtn "acos" 1) (def-math-rtn "sinh" 1) @@ -87,19 +79,15 @@ (def-math-rtn "atanh" 1) ;;; Exponential and Logarithmic. -#-(and x86 (not sse2)) -(progn - (def-math-rtn "exp" 1) - (def-math-rtn "log" 1) - (def-math-rtn "log10" 1)) +(def-math-rtn "exp" 1) +(def-math-rtn "log" 1) +(def-math-rtn "log10" 1) (def-math-rtn "pow" 2) #-(or x86 sparc-v7 sparc-v8 sparc-v9) (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) -;; Don't want log1p to use the x87 instruction. -#-(or hpux (and x86 (not sse2))) (def-math-rtn "log1p" 1) ;; These are needed for use by byte-compiled files. But don't use @@ -199,6 +187,7 @@ ;; easier for the user, and we don't have to wrap calls with ;; without-gcing. (declaim (inline %ieee754-rem-pi/2)) +(export '%ieee754-rem-pi/2) (alien:def-alien-routine ("ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int (x double-float) (y0 double-float :out) @@ -211,6 +200,7 @@ (c double-float :out)) (declaim (inline %sincos)) +(export '%sincos) (defun %sincos (x) (declare (double-float x)) (multiple-value-bind (ign s c) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 41e0d42..7da6b95 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -734,19 +734,19 @@ (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) `(,prim x)))) -(defknown (kernel::%sincos) +(defknown (%sincos) (double-float) (values double-float double-float) (movable foldable flushable)) (deftransform cis ((x) (single-float) * :when :both) `(multiple-value-bind (s c) - (kernel::%sincos (coerce x 'double-float)) + (%sincos (coerce x 'double-float)) (complex (coerce c 'single-float) (coerce s 'single-float)))) (deftransform cis ((x) (double-float) * :when :both) `(multiple-value-bind (s c) - (kernel::%sincos x) + (%sincos x) (complex c s))) #+double-double ----------------------------------------------------------------------- Summary of changes: src/code/exports.lisp | 5 ++++- src/code/irrat.lisp | 30 ++++++++++-------------------- src/compiler/float-tran.lisp | 6 +++--- 3 files changed, 17 insertions(+), 24 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-08-2-gdcaac99
by cshapiro＠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 dcaac995271f5ec60221877673e080361b1d2d27 (commit) from b90e144d86ca206d498891a2eb4b552cecef59ab (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 dcaac995271f5ec60221877673e080361b1d2d27 Author: Carl Shapiro <cshapiro(a)common-lisp.net> Date: Thu Aug 8 00:19:52 2013 -0700 Allow any unsigned-reg for the check-type and type-predicate temporary. diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 2597c6d..95ede9d 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -60,7 +60,7 @@ (emit-test))) (results))) -(defmacro test-type (value target not-p &rest type-codes) +(defmacro test-type (value temp target not-p &rest type-codes) ;; Determine what interesting combinations we need to test for. (let* ((type-codes (mapcar #'eval type-codes)) (fixnump (and (member even-fixnum-type type-codes) @@ -90,7 +90,7 @@ (when immediates (error "Can't mix fixnum testing with other immediates.")) (if headers - `(%test-fixnum-and-headers ,value ,target ,not-p + `(%test-fixnum-and-headers ,value ,temp ,target ,not-p ',(canonicalize-headers headers)) `(%test-fixnum ,value ,target ,not-p))) (immediates @@ -100,17 +100,17 @@ (error "Can't mix testing of immediates with testing of lowtags.")) (when (cdr immediates) (error "Can't test multiple immediates at the same time.")) - `(%test-immediate ,value ,target ,not-p ,(car immediates))) + `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates))) (lowtags (when (cdr lowtags) (error "Can't test multiple lowtags at the same time.")) (if headers `(%test-lowtag-and-headers - ,value ,target ,not-p ,(car lowtags) + ,value ,temp ,target ,not-p ,(car lowtags) ,function-p ',(canonicalize-headers headers)) - `(%test-lowtag ,value ,target ,not-p ,(car lowtags)))) + `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags)))) (headers - `(%test-headers ,value ,target ,not-p ,function-p + `(%test-headers ,value ,temp ,target ,not-p ,function-p ',(canonicalize-headers headers))) (t (error "Nothing to test?"))))) @@ -143,13 +143,13 @@ (generate-fixnum-test value) (inst jmp (if not-p :nz :z) target)) -(defun %test-fixnum-and-headers (value target not-p headers) +(defun %test-fixnum-and-headers (value temp target not-p headers) (let ((drop-through (gen-label))) (generate-fixnum-test value) (inst jmp :z (if not-p drop-through target)) - (%test-headers value target not-p nil headers drop-through))) + (%test-headers value temp target not-p nil headers drop-through))) -(defun %test-immediate (value target not-p immediate) +(defun %test-immediate (value temp target not-p immediate) ;; Code a single instruction byte test if possible. (let ((offset (tn-offset value))) (cond ((and (sc-is value any-reg descriptor-reg) @@ -160,25 +160,27 @@ :offset offset) immediate)) (t - (move eax-tn value) - (inst cmp al-tn immediate)))) + (move temp value) + (inst and temp type-mask) + (inst cmp temp immediate)))) (inst jmp (if not-p :ne :e) target)) -(defun %test-lowtag (value target not-p lowtag &optional al-loaded) - (unless al-loaded - (move eax-tn value) - (inst and al-tn lowtag-mask)) - (inst cmp al-tn lowtag) +(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded) + (unless temp-loaded + (move temp value) + (inst and temp lowtag-mask)) + (inst cmp temp lowtag) (inst jmp (if not-p :ne :e) target)) -(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers) +(defun %test-lowtag-and-headers (value temp target not-p lowtag + function-p headers) (let ((drop-through (gen-label))) - (%test-lowtag value (if not-p drop-through target) nil lowtag) - (%test-headers value target not-p function-p headers drop-through t))) + (%test-lowtag value temp (if not-p drop-through target) nil lowtag) + (%test-headers value temp target not-p function-p headers drop-through t))) -(defun %test-headers (value target not-p function-p headers - &optional (drop-through (gen-label)) al-loaded) +(defun %test-headers (value temp target not-p function-p headers + &optional (drop-through (gen-label)) temp-loaded) (let ((lowtag (if function-p function-pointer-type other-pointer-type))) (multiple-value-bind (equal less-or-equal when-true when-false) @@ -188,15 +190,15 @@ (if not-p (values :ne :a drop-through target) (values :e :na target drop-through)) - (%test-lowtag value when-false t lowtag al-loaded) - (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (%test-lowtag value temp when-false t lowtag temp-loaded) + (load-type temp value (- lowtag)) (do ((remaining headers (cdr remaining))) ((null remaining)) (let ((header (car remaining)) (last (null (cdr remaining)))) (cond ((atom header) - (inst cmp al-tn header) + (inst cmp temp header) (if last (inst jmp equal target) (inst jmp :e when-true))) @@ -204,9 +206,9 @@ (let ((start (car header)) (end (cdr header))) (unless (= start bignum-type) - (inst cmp al-tn start) + (inst cmp temp start) (inst jmp :b when-false)) ; was :l - (inst cmp al-tn end) + (inst cmp temp end) (if last (inst jmp less-or-equal target) (inst jmp :be when-true))))))) ; was :le @@ -217,7 +219,7 @@ ;; both cmp and sub take 2 cycles so maybe its a wash #+nil (defun %test-headers (value target not-p function-p headers - &optional (drop-through (gen-label)) al-loaded) + &optional (drop-through (gen-label)) temp-loaded) (let ((lowtag (if function-p function-pointer-type other-pointer-type))) (multiple-value-bind (equal less-or-equal when-true when-false) @@ -227,8 +229,8 @@ (if not-p (values :ne :a drop-through target) (values :e :na target drop-through)) - (%test-lowtag value when-false t lowtag al-loaded) - (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (%test-lowtag value when-false t lowtag temp-loaded) + (load-type temp value (- lowtag)) (let ((delta 0)) (do ((remaining headers (cdr remaining))) ((null remaining)) @@ -236,7 +238,7 @@ (last (null (cdr remaining)))) (cond ((atom header) - (inst sub al-tn (- header delta)) + (inst sub temp (- header delta)) (setf delta header) (if last (inst jmp equal target) @@ -245,10 +247,10 @@ (let ((start (car header)) (end (cdr header))) (unless (= start bignum-type) - (inst sub al-tn (- start delta)) + (inst sub temp (- start delta)) (setf delta start) (inst jmp :l when-false)) - (inst sub al-tn (- end delta)) + (inst sub temp (- end delta)) (setf delta end) (if last (inst jmp less-or-equal target) @@ -261,15 +263,13 @@ (define-vop (check-type) (:args (value :target result :scs (any-reg descriptor-reg))) (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax) - (:ignore eax) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:vop-var vop) (:save-p :compute-only)) (define-vop (type-predicate) (:args (value :scs (any-reg descriptor-reg))) - (:temporary (:sc unsigned-reg :offset eax-offset) eax) - (:ignore eax) + (:temporary (:scs (unsigned-reg)) temp) (:conditional) (:info target not-p) (:policy :fast-safe)) @@ -303,13 +303,13 @@ `((define-vop (,pred-name type-predicate) (:translate ,pred-name) (:generator ,cost - (test-type value target not-p ,@type-codes))))) + (test-type value temp target not-p ,@type-codes))))) ,@(when check-name `((define-vop (,check-name check-type) (:generator ,cost (let ((err-lab (generate-error-code vop ,error-code value))) - (test-type value err-lab t ,@type-codes) + (test-type value temp err-lab t ,@type-codes) (move result value)))))) ,@(when ptype `((primitive-type-vop ,check-name (:check) ,ptype)))))) @@ -322,13 +322,13 @@ `((define-vop (,pred-name simple-type-predicate) (:translate ,pred-name) (:generator ,cost - (test-type value target not-p ,@type-codes))))) + (test-type value temp target not-p ,@type-codes))))) ,@(when check-name `((define-vop (,check-name simple-check-type) (:generator ,cost (let ((err-lab (generate-error-code vop ,error-code value))) - (test-type value err-lab t ,@type-codes) + (test-type value temp err-lab t ,@type-codes) (move result value)))))) ,@(when ptype `((primitive-type-vop ,check-name (:check) ,ptype)))))) @@ -634,12 +634,12 @@ (values target not-target)) (generate-fixnum-test value) (inst jmp :e yep) - (move eax-tn value) - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (move temp value) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) - (loadw eax-tn value 0 other-pointer-type) - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (loadw temp value 0 other-pointer-type) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp (if not-p :ne :e) target)) NOT-TARGET)) @@ -650,12 +650,12 @@ value))) (generate-fixnum-test value) (inst jmp :e yep) - (move eax-tn value) - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (move temp value) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) - (loadw eax-tn value 0 other-pointer-type) - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (loadw temp value 0 other-pointer-type) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp :ne nope)) YEP (move result value))) @@ -677,35 +677,35 @@ (values target not-target)) ;; Is it a fixnum? (generate-fixnum-test value) - (move eax-tn value) + (move temp value) (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) ;; Get the header. - (loadw eax-tn value 0 other-pointer-type) + (loadw temp value 0 other-pointer-type) ;; Is it one? - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp :e single-word) ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type)) + (inst cmp temp (+ (ash 2 type-bits) bignum-type)) (inst jmp :ne nope) ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type) + (loadw temp value (1+ bignum-digits-offset) other-pointer-type) ;; All zeros, its an (unsigned-byte 32). - (inst or eax-tn eax-tn) + (inst test temp temp) (inst jmp :z yep) (inst jmp nope) (emit-label single-word) ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-type) + (loadw temp value bignum-digits-offset other-pointer-type) ;; positive implies (unsigned-byte 32). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst test temp temp) (inst jmp (if not-p :s :ns) target) (emit-label not-target))))) @@ -720,35 +720,35 @@ ;; Is it a fixnum? (generate-fixnum-test value) - (move eax-tn value) + (move temp value) (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (inst and temp lowtag-mask) + (inst cmp temp other-pointer-type) (inst jmp :ne nope) ;; Get the header. - (loadw eax-tn value 0 other-pointer-type) + (loadw temp value 0 other-pointer-type) ;; Is it one? - (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst cmp temp (+ (ash 1 type-bits) bignum-type)) (inst jmp :e single-word) ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type)) + (inst cmp temp (+ (ash 2 type-bits) bignum-type)) (inst jmp :ne nope) ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type) + (loadw temp value (1+ bignum-digits-offset) other-pointer-type) ;; All zeros, its an (unsigned-byte 32). - (inst or eax-tn eax-tn) + (inst or temp temp) (inst jmp :z yep) (inst jmp nope) (emit-label single-word) ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-type) + (loadw temp value bignum-digits-offset other-pointer-type) ;; positive implies (unsigned-byte 32). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst or temp temp) (inst jmp :s nope) (emit-label yep) @@ -766,7 +766,7 @@ (let ((is-symbol-label (if not-p drop-thru target))) (inst cmp value nil-value) (inst jmp :e is-symbol-label) - (test-type value target not-p symbol-header-type)) + (test-type value temp target not-p symbol-header-type)) DROP-THRU)) (define-vop (check-symbol check-type) @@ -774,7 +774,7 @@ (let ((error (generate-error-code vop object-not-symbol-error value))) (inst cmp value nil-value) (inst jmp :e drop-thru) - (test-type value error t symbol-header-type)) + (test-type value temp error t symbol-header-type)) DROP-THRU (move result value))) @@ -784,7 +784,7 @@ (let ((is-not-cons-label (if not-p target drop-thru))) (inst cmp value nil-value) (inst jmp :e is-not-cons-label) - (test-type value target not-p list-pointer-type)) + (test-type value temp target not-p list-pointer-type)) DROP-THRU)) (define-vop (check-cons check-type) @@ -792,5 +792,5 @@ (let ((error (generate-error-code vop object-not-cons-error value))) (inst cmp value nil-value) (inst jmp :e error) - (test-type value error t list-pointer-type) + (test-type value temp error t list-pointer-type) (move result value)))) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/type-vops.lisp | 148 +++++++++++++++++++-------------------- 1 file changed, 74 insertions(+), 74 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-05-4-g0b5c125
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 0b5c1254cc522e4e10d0f14ea248cc74b82fae69 (commit) from 7889e989541ed40a753b2a884f7fbcf25e0a951d (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 0b5c1254cc522e4e10d0f14ea248cc74b82fae69 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 16 19:17:56 2013 -0700 Forgot to commit changes to code/x86-vm.lisp to: Wrap exports in eval-when for x86 as was done for sparc and add CHAR-BYTES to x86-x86 cross-compile script. diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 961dacb..6b7c881 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -26,10 +26,12 @@ (intl:textdomain "cmucl-x86-vm") +(eval-when (:compile-toplevel :load-toplevel :execute) (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution)) +) #+complex-fp-vops (sys:register-lisp-feature :complex-fp-vops) ----------------------------------------------------------------------- Summary of changes: src/code/x86-vm.lisp | 2 ++ 1 file changed, 2 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-41-gd08b5bf
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 d08b5bf8259bcd458beec17ba65a7b85f454edda (commit) from b48c235255ef3e9cf0f47446a3adf8ce0abbe07f (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 d08b5bf8259bcd458beec17ba65a7b85f454edda Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Aug 27 21:22:18 2014 -0700 Add some tests for ROUND. Two tests currently fail. diff --git a/tests/srctran.lisp b/tests/srctran.lisp index f88e977..e3cba34 100644 --- a/tests/srctran.lisp +++ b/tests/srctran.lisp @@ -80,3 +80,25 @@ (c::ceiling-rem-bound (c::make-interval :low '(-1.3) :high 10.3))) (assert-equalp (c::make-interval :low '(-20.3) :high '(20.3)) (c::ceiling-rem-bound (c::make-interval :low '(-20.3) :high 10.3)))) + +(define-test round-quotient-bound + "Test the first value of ROUND returns the correct interval" + (assert-equalp (c::make-interval :low 0 :high 10) + (c::round-quotient-bound (c::make-interval :low 0.3 :high 10.5))) + (assert-equalp (c::make-interval :low 0 :high 12) + (c::round-quotient-bound (c::make-interval :low 0.3 :high 11.5))) + (assert-equalp (c::make-interval :low 0 :high 10) + (c::round-quotient-bound (c::make-interval :low 0.3 :high '(10.5)))) + ;; Known failure: returns high limit of 12 instead of 11 + (assert-equalp (c::make-interval :low 0 :high 11) + (c::round-quotient-bound (c::make-interval :low 0.3 :high '(11.5)))) + (assert-equalp (c::make-interval :low 2 :high 10) + (c::round-quotient-bound (c::make-interval :low 1.5 :high 10.5))) + (assert-equalp (c::make-interval :low 2 :high 10) + (c::round-quotient-bound (c::make-interval :low '(1.5) :high 10.5))) + ;; Known failure: returns high limit of 0 instead of 1 + (assert-equalp (c::make-interval :low 1 :high 10) + (c::round-quotient-bound (c::make-interval :low '(0.5) :high 10.5))) + ) + + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: tests/srctran.lisp | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-22-g2c4a13a
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 2c4a13afde093c0e1eb415c7252efaad6ca362f5 (commit) from 33097329493c7a767bcc4434f3212badcb33236a (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 2c4a13afde093c0e1eb415c7252efaad6ca362f5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Aug 21 21:56:26 2014 -0700 Re-enable the x87 floating-point mode stuff. On 32-bit linux, we can still get FP exceptions using x87 because 32-bit linux can still use x87 instructions for arithmetic. Because of this, we need to re-enable the support x87 floating-point modes, including getting and setting the modes and also extracting the modes from a sigcontext. * src/code/float-trap.lisp: * Put back support for getting and setting the x87 FP modes. * src/compiler/x86/float.lisp: * Add comment on the layout of the status and control words for x87. * src/lisp/Linux-os.c: * Put back support for getting the x87 (and sse2) FP modes. Needed in the sigfpe-handler in float-trap.lisp. Some of this needs to be cleaned up because we always require sse2 now. diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 7f27ffd..d97d04e 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -64,17 +64,62 @@ (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new)) ) +#+(and x86 (not sse2)) +(progn + (defun floating-point-modes () + (let ((x87-modes (vm::x87-floating-point-modes))) + ;; Massage the bits from x87-floating-point-modes into the order + ;; that the rest of the system wants them to be. (Must match + ;; format in the SSE2 mxcsr register.) + (logior (ash (logand #x3f x87-modes) 7) ; control + (logand #x3f (ash x87-modes -16))))) + (defun (setf floating-point-modes) (new) + (let* ((rc (ldb float-rounding-mode new)) + (x87-modes + (logior (ash (logand #x3f new) 16) + (ash rc 10) + (logand #x3f (ash new -7)) + ;; Set precision control to be 53-bit, always. + ;; (The compiler takes care of handling + ;; single-float precision, and we don't support + ;; long-floats.) + (ash 2 8)))) + (setf (x87-floating-point-modes) x87-modes))) + ) + #+sse2 (progn (defun floating-point-modes () - ;; Get just the SSE2 mode bits. - (vm::sse2-floating-point-modes)) + ;; Combine the modes from the FPU and SSE2 units. Since the sse + ;; mode contains all of the common information we want, we massage + ;; the x87-modes to match, and then OR the x87 and sse2 modes + ;; together. Note: We ignore the rounding control bits from the + ;; FPU and only use the SSE2 rounding control bits. + (let* ((x87-modes (vm::x87-floating-point-modes)) + (sse-modes (vm::sse2-floating-point-modes)) + (final-mode (logior sse-modes + (ash (logand #x3f x87-modes) 7) ; control + (logand #x3f (ash x87-modes -16))))) + + final-mode)) (defun (setf floating-point-modes) (new-mode) (declare (type (unsigned-byte 24) new-mode)) - ;; Set the floating point modes for SSE2. - (setf (vm::sse2-floating-point-modes) new-mode) + ;; Set the floating point modes for both X87 and SSE2. This + ;; include the rounding control bits. + (let* ((rc (ldb float-rounding-mode new-mode)) + (x87-modes + (logior (ash (logand #x3f new-mode) 16) + (ash rc 10) + (logand #x3f (ash new-mode -7)) + ;; Set precision control to be 64-bit, always. We + ;; don't use the x87 registers with sse2, so this + ;; is ok and would be the correct setting if we + ;; ever support long-floats. + (ash 3 8)))) + (setf (vm::sse2-floating-point-modes) new-mode) + (setf (vm::x87-floating-point-modes) x87-modes)) new-mode) - ) +) ;;; SET-FLOATING-POINT-MODES -- Public ;;; diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index a515e40..e617149 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -2303,6 +2303,43 @@ (defknown ((setf x87-floating-point-modes)) (float-modes) float-modes) +;; For the record, here is the format of the x86 FPU status word +;; +;; Bit +;; 15 FPU Busy +;; 14 C3 (condition code) +;; 13-11 Top of stack +;; 10 C2 (condition code) +;; 9 C1 (condition code) +;; 8 C0 (condition code) +;; 7 Error summary status +;; 6 Stack fault +;; 5 precision flag (inexact) +;; 4 underflow flag +;; 3 overflow flag +;; 2 divide-by-zero flag +;; 1 denormalized operand flag +;; 0 invalid operation flag +;; +;; When one of the flag bits (0-5) is set, then that exception has +;; been detected since the bits were last cleared. +;; +;; The control word: +;; +;; 15-13 reserved +;; 12 infinity control +;; 11-10 rounding control +;; 9-8 precision control +;; 7-6 reserved +;; 5 precision masked +;; 4 underflow masked +;; 3 overflow masked +;; 2 divide-by-zero masked +;; 1 denormal operand masked +;; 0 invalid operation masked +;; +;; When one of the mask bits (0-5) is set, then that exception is +;; masked so that no exception is generated. (define-vop (x87-floating-point-modes) (:results (res :scs (unsigned-reg))) (:result-types unsigned-num) diff --git a/src/lisp/Linux-os.c b/src/lisp/Linux-os.c index 2da60fb..7f7a4d7 100644 --- a/src/lisp/Linux-os.c +++ b/src/lisp/Linux-os.c @@ -217,13 +217,16 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) if (fpregs) { if (offset < 8) { reg = (unsigned char *) &fpregs->_st[offset]; - } else if (offset < 16) { + } +#ifdef FEATURE_SSE2 + else { struct _fpstate *fpstate; fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; if (fpstate->magic != 0xffff) { reg = (unsigned char *) &fpstate->_xmm[offset - 8]; } } +#endif } return reg; } @@ -231,27 +234,39 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) { - unsigned int modes = 0; - - /* - * Get the SSE2 modes. FIXME: What should we do if the magic - * value indicates that the mxcsr value is not in the context? - */ - struct _fpstate *fpstate; - unsigned long mxcsr; + unsigned int modes; + unsigned short cw, sw; - fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; - if (fpstate->magic == 0xffff) { - mxcsr = 0; + if (scp->uc_mcontext.fpregs == NULL) { + cw = 0; + sw = 0x3f; } else { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); + cw = scp->uc_mcontext.fpregs->cw & 0xffff; + sw = scp->uc_mcontext.fpregs->sw & 0xffff; } - modes |= mxcsr; + modes = ((cw & 0x3f) << 7) | (sw & 0x3f); + +#ifdef FEATURE_SSE2 + /* + * Add in the SSE2 part, if we're running the sse2 core. + */ + if (fpu_mode == SSE2) { + struct _fpstate *fpstate; + unsigned long mxcsr; + + fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; + if (fpstate->magic == 0xffff) { + mxcsr = 0; + } else { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); + } + modes |= mxcsr; + } +#endif - /* Convert exception mask to exception enable */ modes ^= (0x3f << 7); return modes; } @@ -528,19 +543,25 @@ void restore_fpu(ucontext_t *context) { if (context->uc_mcontext.fpregs) { - struct _fpstate *fpstate; - unsigned int mxcsr; + short cw = context->uc_mcontext.fpregs->cw; + DPRINTF(0, (stderr, "restore_fpu: cw = %08x\n", cw)); + __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)); +#ifdef FEATURE_SSE2 + if (fpu_mode == SSE2) { + struct _fpstate *fpstate; + unsigned int mxcsr; - fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; - if (fpstate->magic != 0xffff) { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); - __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); + fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; + if (fpstate->magic != 0xffff) { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); + __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); + } } +#endif } } - #ifdef i386 boolean os_support_sse2() ----------------------------------------------------------------------- Summary of changes: src/code/float-trap.lisp | 55 ++++++++++++++++++++++++++++++---- src/compiler/x86/float.lisp | 37 +++++++++++++++++++++++ src/lisp/Linux-os.c | 69 ++++++++++++++++++++++++++++--------------- 3 files changed, 132 insertions(+), 29 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0