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

[git] CMU Common Lisp branch master updated. snapshot-2014-05-6-gc34d88b
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 c34d88b5fb3e8a27a3ac5605f96ddd77aa29ae3b (commit) from 7534898c2e414172cda3d7d8486a868038420398 (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 c34d88b5fb3e8a27a3ac5605f96ddd77aa29ae3b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon May 12 20:06:36 2014 -0700 Fix bug in printing most-negative-fixnum * src/code/print.lisp: * Type declaration in {{{SUB-OUTPUT-INTEGER}}} was incorrect because we want to be able to print {{{(- most-negative-fixnum)}}}. * tests/printer.lisp: * Add test for this. diff --git a/src/code/print.lisp b/src/code/print.lisp index 999bc94..f2a1205 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1297,7 +1297,7 @@ (write-char #\. stream))) (defun sub-output-integer (integer stream) - (declare (type (and fixnum unsigned-byte) integer)) + (declare (type (integer 0 #.(- most-negative-fixnum)) integer)) (let ((quotient 0) (remainder 0)) (declare (fixnum quotient remainder)) diff --git a/tests/printer.lisp b/tests/printer.lisp index b511f0b..5c95844 100644 --- a/tests/printer.lisp +++ b/tests/printer.lisp @@ -111,3 +111,5 @@ (assert-equal "Scale factor 6: | 314159.0e-05|" (test-scale 11)) (assert-equal "Scale factor 7: | 3141590.e-06|" (test-scale 12)))) +(define-test sub-output-integer.1 + (assert-prints "-536870912" (princ most-negative-fixnum))) ----------------------------------------------------------------------- Summary of changes: src/code/print.lisp | 2 +- tests/printer.lisp | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[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