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

[git] CMU Common Lisp branch master updated. snapshot-2014-06-85-g4db363e
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 4db363eca4f5a2c282f7b46bd1509095bcb6efec (commit) via b0b34eafd682046f8345beeb5df24e8c1eacc231 (commit) via 87b9cd66d418314bee5318d0c80181c6572d0d85 (commit) via edaa999ed44d1df6c361c594932eaa5d03f208a5 (commit) from 0a2163ec1c2ed6cd9711dab63f92c42e246e0b81 (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 4db363eca4f5a2c282f7b46bd1509095bcb6efec Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Aug 3 15:21:24 2014 -0700 Update from commit logs. diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 1947297..b49ecc6 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -32,7 +32,7 @@ New in this release: ticket:92) * Changes - * Update to ASDF 3.1.2. + * Update to ASDF 3.1.3. * When *PRINT-CASE* is :DOWNCASE, integers are printed with lowercase letters when needed. * Micro-optimize KERNEL:DOUBLE-FLOAT-BITS for x86/sse2. @@ -53,6 +53,15 @@ New in this release: the default for several months now. * Add lisp-unit as a contrib. Use (require :lisp-unit) to load it. Precompiled fasls are not included. + * CMUCL now uses fdlibm C functions to implement the special + functions. All platforms use this so they should produce + identical results everywhere. + * Consing for the trig functions is removed now since we call out + to fdlibm instead of implementing them in Lisp. + * Source location information has been added for + DEFINE-CONDITION. (From Helmut Eller.) + * The lisp executable is now compiled to use SSE2 on x86 machines; + CMUCL will not run on chips without SSE2 anymore. * ANSI compliance fixes: * The values on the branch cuts for the inverse trig and @@ -62,6 +71,9 @@ New in this release: and on the branch cut is now continuous with different quadrants. This differs from the description of the branch cut for atanh in the CLHS. + * CLEAR-OUTPUT was not actually doing anything. Now, CLEAR-OUTPUT + will discard any buffered data that has not been written out + yet. * Bugfixes: * Fix error in pi reduction on x87. It was not noticed previously @@ -78,7 +90,11 @@ New in this release: least-positive-foo-float if possible. * (log -0w0) and (log 0w0) returns values analogous to the double-float versions. - * Fix bug in printint MOST-NEGATIVE-FIXNUM + * Fix bug in printing MOST-NEGATIVE-FIXNUM. + * For Gray streams, CLEAR-OUTPUT was calling STREAM-FORCE-OUTPUT + instead of STREAM-CLEAR-OUTPUT, so the output wasn't actually + cleared. + * Trac Tickets: * Ticket #90 fixed. @@ -87,6 +103,8 @@ New in this release: * Ticket #94 fixed. * Ticket #93 fixed. * Ticket #98 fixed. + * Ticket #104 fixed. + * Ticket #101, item 1 fixed. * Other changes: commit b0b34eafd682046f8345beeb5df24e8c1eacc231 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Aug 3 08:43:08 2014 -0700 add -mtune=generic to get optimization for the most common x86 processors. diff --git a/src/lisp/Config.x86_common b/src/lisp/Config.x86_common index 1873f7d..ad2b1a0 100644 --- a/src/lisp/Config.x86_common +++ b/src/lisp/Config.x86_common @@ -54,7 +54,7 @@ CPP_INCLUDE_OPTIONS := -I. -I$(PATH1) -I- endif CPPFLAGS := $(CPP_DEFINE_OPTIONS) $(CPP_INCLUDE_OPTIONS) -CFLAGS += -Wstrict-prototypes -Wall -O2 -g +CFLAGS += -Wstrict-prototypes -Wall -O2 -g -mtune=generic ASFLAGS = -g ASSEM_SRC = x86-assem.S commit 87b9cd66d418314bee5318d0c80181c6572d0d85 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Aug 3 08:37:50 2014 -0700 Remove CC_REM_PIO2 and add new CPPFLAGS to force compiling with sse2 instructions. This is completely untested. diff --git a/src/lisp/Config.x86_freebsd b/src/lisp/Config.x86_freebsd index 911e2c2..cf8089f 100644 --- a/src/lisp/Config.x86_freebsd +++ b/src/lisp/Config.x86_freebsd @@ -1,9 +1,7 @@ # -*- Mode: makefile -*- include Config.x86_common -# Need -ffloat-store for e_rem_pio2 and k_rem_pio2 to get properly -# rounded double-floats while using x87 extended precision. -CC_REM_PIO2 = -ffloat-store +CPPFLAGS += -march=pentium4 -mfpmath=sse UNDEFSYMPATTERN = -Xlinker -u -Xlinker & OS_SRC += FreeBSD-os.c elf.c commit edaa999ed44d1df6c361c594932eaa5d03f208a5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Aug 3 08:35:51 2014 -0700 Forgot to remove e_rem_pio2 and friends from a few more Config files since they're in GNUMakefile now. diff --git a/src/lisp/Config.sparc_common b/src/lisp/Config.sparc_common index c4a8ed6..2ad8aed 100644 --- a/src/lisp/Config.sparc_common +++ b/src/lisp/Config.sparc_common @@ -56,6 +56,6 @@ ASSEM_SRC = sparc-assem.S ARCH_SRC = sparc-arch.c DEPEND=$(CC) -OS_SRC = solaris-os.c os-common.c undefineds.c elf.c e_rem_pio2.c k_rem_pio2.c +OS_SRC = solaris-os.c os-common.c undefineds.c elf.c OS_LIBS= -lsocket -lnsl -ldl EXEC_FINAL_OBJ = exec-final.o diff --git a/src/lisp/Config.x86_solaris_sunc b/src/lisp/Config.x86_solaris_sunc index 2b6ed8d..0c137ae 100644 --- a/src/lisp/Config.x86_solaris_sunc +++ b/src/lisp/Config.x86_solaris_sunc @@ -9,6 +9,6 @@ DEPEND_FLAGS = -xM1 ASSEM_SRC = x86-assem.S ARCH_SRC = x86-arch.c -OS_SRC = solaris-os.c os-common.c undefineds.c elf.c e_rem_pio2.c k_rem_pio2.c +OS_SRC = solaris-os.c os-common.c undefineds.c elf.c OS_LINK_FLAGS= OS_LIBS= -lsocket -lnsl -ldl ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20f.txt | 22 ++++++++++++++++++++-- src/lisp/Config.sparc_common | 2 +- src/lisp/Config.x86_common | 2 +- src/lisp/Config.x86_freebsd | 4 +--- src/lisp/Config.x86_solaris_sunc | 2 +- 5 files changed, 24 insertions(+), 8 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-9-g513c3b2
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 513c3b23e97cf7e1af4da202053bedf96e70cc44 (commit) from 0e94b217534b1306e73ab5b61fd34060311c1608 (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 513c3b23e97cf7e1af4da202053bedf96e70cc44 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:30:18 2014 -0800 Fix ticket 94. * Add least-positive-normalized-double-double-float, least-negative-normalized-double-double-float, least-positive-double-double-float, least-negative-double-double-float, most-positive-double-double-float, most-negative-double-double-float to the extensions package. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 9322c5d..a5f5ca6 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1418,6 +1418,14 @@ "FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P" "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" "WITH-FLOAT-TRAPS-MASKED") + ;; More float extensions + #+double-double + (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-DOUBLE-DOUBLE-FLOAT" + "MOST-POSITIVE-DOUBLE-DOUBLE-FLOAT" + "MOST-NEGATIVE-DOUBLE-DOUBLE-FLOAT") ;; Spice lisp extensions (:export "LETF*" "LETF" "DOVECTOR" "DELETEF" "INDENTING-FURTHER" "FILE-COMMENT" diff --git a/src/code/float.lisp b/src/code/float.lisp index ce7e572..01b7002 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -59,6 +59,14 @@ set-floating-point-modes float-denormalized-p float-nan-p float-trapping-nan-p float-infinity-p)) +#+double-double +(export '(least-positive-normalized-double-double-float + least-negative-normalized-double-double-float + least-positive-double-double-float + least-negative-double-double-float + most-positive-double-double-float + most-negative-double-double-float)) + (in-package "KERNEL") @@ -127,6 +135,32 @@ #+(and long-float x86) (defconstant least-negative-long-float (long-from-bits 1 0 1)) +#+double-double +(progn +(defconstant least-positive-normalized-double-double-float + ;; What is the right value? + (kernel:make-double-double-float least-positive-normalized-double-float + 0d0)) +(defconstant least-negative-normalized-double-double-float + ;; What is the right value? + (kernel:make-double-double-float least-negative-normalized-double-float + 0d0)) +(defconstant least-positive-double-double-float + (kernel:make-double-double-float least-positive-double-float + 0d0)) +(defconstant least-negative-double-double-float + (kernel:make-double-double-float least-negative-double-float + 0d0)) +(defconstant most-positive-double-double-float + ;; What is the right value? + (kernel:make-double-double-float most-positive-double-float + 0d0)) +(defconstant most-negative-double-double-float + ;; What is the right value? + (kernel:make-double-double-float most-negative-double-float + 0d0)) +); double-double + (defconstant least-positive-normalized-single-float (single-from-bits 0 vm:single-float-normal-exponent-min 0)) (defconstant least-positive-normalized-short-float ----------------------------------------------------------------------- Summary of changes: src/code/exports.lisp | 8 ++++++++ src/code/float.lisp | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 42 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-03-a-10-gc647866
by rtoy＠alpha-cl-net.common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c647866d61b29968c39d1722ad61d02061acfe7a (commit) via 82fac7da35ba098a3f294a946e39714b58740b69 (commit) from 25047afd964691f70669318e97164c4d81ecb3a7 (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 c647866d61b29968c39d1722ad61d02061acfe7a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Apr 13 14:57:27 2013 -0700 Update from logs. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 9ebd374..06f5173 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -56,6 +56,9 @@ New in this release: other than latin1 has been fixed. See ticket #74. * Fix startup crashes on some Debian Linux versions. This was caused by the release string not having a patch version. + * FILE-POSITION no longer returns incorrect values. See ticket + #79. + * Trac Tickets: * Ticket #52 reopened. @@ -86,6 +89,9 @@ New in this release: * In make-dist.sh, the version is now optional. If not given, a version is derived from the git hash returned by "git describe". + * build.sh -u used to disable building of asdf and friends. This + is incorrect. Asdf is always built now (during the last stage). + This release is not binary compatible with code compiled using CMUCL 20d; you will need to recompile FASL files. commit 82fac7da35ba098a3f294a946e39714b58740b69 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Apr 13 14:54:15 2013 -0700 Update -u option so that asdf is always built. bin/build-utils.sh:: * asdf is not part of build-utils.sh bin/build.sh:: * Build asdf as part of the normal build because it's always part of the main tarball, not the extras tarball. diff --git a/bin/build-utils.sh b/bin/build-utils.sh index 7f5862e..e59fd19 100755 --- a/bin/build-utils.sh +++ b/bin/build-utils.sh @@ -15,18 +15,6 @@ fi TARGET="`echo $1 | sed 's:/*$::'`" shift -# Compile up the asdf and defsystem modules -$TARGET/lisp/lisp -noinit -nositeinit -batch "$@" << EOF || exit 3 -(in-package :cl-user) -(setf (ext:search-list "target:") - '("$TARGET/" "src/")) -(setf (ext:search-list "modules:") - '("target:contrib/")) - -(compile-file "modules:asdf/asdf") -(compile-file "modules:defsystem/defsystem") -EOF - $TARGET/lisp/lisp \ -noinit -nositeinit -batch "$@" <<EOF || exit 3 (in-package :cl-user) diff --git a/bin/build.sh b/bin/build.sh index f451ac1..99d0a43 100755 --- a/bin/build.sh +++ b/bin/build.sh @@ -251,6 +251,19 @@ if [ "$SKIPUTILS" = "no" ]; then OLDLISP="${BASE}-4/lisp/lisp $OLDLISPFLAGS $FPU_MODE" time $TOOLDIR/build-utils.sh $TARGET $FPU_MODE +else +# But asdf and friends are part of the base install, so we need to build them. + $TARGET/lisp/lisp -noinit -nositeinit -batch "$@" << EOF || exit 3 + (in-package :cl-user) + (setf (ext:search-list "target:") + '("$TARGET/" "src/")) + (setf (ext:search-list "modules:") + '("target:contrib/")) + + (compile-file "modules:asdf/asdf") + (compile-file "modules:defsystem/defsystem") +EOF + fi build_finished=`date` ----------------------------------------------------------------------- Summary of changes: bin/build-utils.sh | 12 ------------ bin/build.sh | 13 +++++++++++++ src/general-info/release-20e.txt | 6 ++++++ 3 files changed, 19 insertions(+), 12 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-6-gd5983ca
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 d5983ca74965ef16fb3cb47d78024c3eb68a4a59 (commit) from 3a09aa24b038be094140ddc86069d0a89eeea5c2 (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 d5983ca74965ef16fb3cb47d78024c3eb68a4a59 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Nov 24 20:23:46 2013 -0800 Better error message for an empty cond clause. Bug noted by Pascal Bourguignon on cmucl-help, 2013-11-24. diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 892e1cf..9bc774f 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -559,7 +559,7 @@ nil (let ((clause (first clauses))) (when (atom clause) - (error (intl:gettext "Cond clause is not a list: ~S.") clause)) + (error (intl:gettext "Cond clause should be a non-empty list: ~S.") clause)) (let ((test (first clause)) (forms (rest clause))) (if (endp forms) ----------------------------------------------------------------------- Summary of changes: src/code/macros.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[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