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

[git] CMU Common Lisp branch master updated. snapshot-2014-08-17-ga206017
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 a206017de697d0bd41545b300669138d5d5533ff (commit) via 7758900b5e12172d7b0306e67a9dc045e7c33643 (commit) from 81ebae1c1af846d41fd128703b2357e83736d90d (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 a206017de697d0bd41545b300669138d5d5533ff Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Aug 21 20:41:10 2014 -0700 Make expm1 signal errors using fdlibm_setexception. Update tests to handle signaling and quite NaN * src/lisp/s_expm1.c: * Use fdlibm_setexception * tests/trig.lisp: * Add additional tests to existing testsuite to distinguish signaling and quiet NaN. The functions should signal on quiet NaN. * Add tests for expm1. diff --git a/src/lisp/s_expm1.c b/src/lisp/s_expm1.c index 7431885..4e9bae8 100644 --- a/src/lisp/s_expm1.c +++ b/src/lisp/s_expm1.c @@ -150,10 +150,14 @@ Q5 = -2.01099218183624371326e-07; /* BE8AFDB7 6E09C32D */ if(hx >= 0x40862E42) { /* if |x|>=709.78... */ if(hx>=0x7ff00000) { if(((hx&0xfffff)|ux.i[LOWORD])!=0) - return x+x; /* NaN */ - else return (xsb==0)? x:-1.0;/* exp(+-inf)={inf,-1} */ + return fdlibm_setexception(x, FDLIBM_INVALID); /* NaN */ + else return (xsb==0)? x:-1.0;/* exp(+-inf)={inf,-1} */ } - if(x > o_threshold) return huge*huge; /* overflow */ + if(x > o_threshold) { + /* overflow */ + return fdlibm_setexception(x, FDLIBM_OVERFLOW); + } + } if(xsb!=0) { /* x < -56*ln2, return -1.0 with inexact */ if(x+tiny<0.0) /* raise inexact */ diff --git a/tests/trig.lisp b/tests/trig.lisp index 62ac377..07cd6bd 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -794,10 +794,14 @@ ;; Test that fdlibm routines signals exceptions as expected. -(defparameter *nan* +(defparameter *qnan* (kernel::with-float-traps-masked (:invalid) (* 0 ext:double-float-positive-infinity)) - "Some randon MaN value") + "Some randon quiet MaN value") + +(defparameter *snan* + (kernel:make-double-float #x7ff00000 1) + "A randon signaling MaN value") (define-test cosh.exceptions (:tag :fdlibm) @@ -806,7 +810,9 @@ (assert-error 'floating-point-overflow (kernel:%cosh -1000d0)) (assert-error 'floating-point-invalid-operation - (kernel:%cosh *nan*)) + (kernel:%cosh *snan*)) + (assert-true (ext:float-nan-p (kernel:%cosh *qnan*))) + ;; Same, but with overflow's masked (kernel::with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity @@ -819,7 +825,7 @@ (kernel:%cosh ext:double-float-negative-infinity))) ;; Test NaN (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%cosh *nan*))))) + (assert-true (ext:float-nan-p (kernel:%cosh *snan*))))) (define-test sinh.exceptions (:tag :fdlibm) @@ -828,7 +834,8 @@ (assert-error 'floating-point-overflow (kernel:%sinh -1000d0)) (assert-error 'floating-point-invalid-operation - (kernel:%sinh *nan*)) + (kernel:%sinh *snan*)) + (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))) ;; Same, but with overflow's masked (kernel::with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity @@ -841,12 +848,16 @@ (kernel:%sinh ext:double-float-negative-infinity))) ;; Test NaN (kernel::with-float-traps-masked (:invalid) - (assert-true (ext:float-nan-p (kernel:%sinh *nan*))))) + (assert-true (ext:float-nan-p (kernel:%sinh *qnan*))))) (define-test tanh.exceptions (:tag :fdlibm) - (assert-true (ext:float-nan-p (kernel:%tanh *nan*)))) + (assert-true (ext:float-nan-p (kernel:%tanh *qnan*))) + (assert-error 'floating-point-invalid-operation + (kernel:%tanh *snan*)) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p (kernel:%tanh *snan*))))) (define-test acosh.exceptions (:tag :fdlibm) @@ -860,3 +871,19 @@ (kernel::with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%acosh 0d0))))) +(define-test expm1.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%expm1 709.8d0)) + (assert-equal 'ext:double-float-positive-infinity + (kernel:%expm1 ext:double-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (kernel:%expm1 *snan*)) + (assert-true (ext:float-nan-p (kernel:%expm1 *qnan*))) + (kernel::with-float-traps-masked (:overflow) + (assert-true ext:double-float-positive-infinity + (kernel:%expm1 709.8d0)) + (assert-true ext:double-float-positive-infinity + (kernel:%expm1 ext:double-float-positive-infinity))) + (kernel::with-float-traps-masked (:invalid) + (assert-true (ext::float-nan-p (kernel:%expm1 *snan*))))) commit 7758900b5e12172d7b0306e67a9dc045e7c33643 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Aug 21 20:32:32 2014 -0700 Handle invalid correctly. If the argument is a quiet NaN, then we don't want to signal an invalid operation. For all other floats, we do want to signal that. Add function isQNaN to detect quiet NaN. diff --git a/src/lisp/setexception.c b/src/lisp/setexception.c index a0f568c..a77a9d8 100644 --- a/src/lisp/setexception.c +++ b/src/lisp/setexception.c @@ -5,6 +5,37 @@ #include "fdlibm.h" /* + * Test if the given number is a quiet NaN + */ + +int +isQNaN(double x) +{ + int hx; + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD] & 0x7fffffff; + + if (hx >= 0x7ff00000) { + /* + * We have some kind of infinity or NaN. Get the (top) + * mantissa bits. We have a quiet NaN if the most significant + * bit is 1. The other bits of the mantissa don't matter. We + * also don't distinguish this from the quiet NaN + * floating-point indefinite which only has the most + * significant bit set. These are all considered NaNs for our + * purposes. + */ + hx &= 0xfffff; + + return hx & 0x80000; + } + + return 0; +} + +/* * Signal the floating-point exception of the given |type|, based on * the value of |x|. */ @@ -36,13 +67,21 @@ fdlibm_setexception(double x, enum FDLIBM_EXCEPTION type) case 3: { /* invalid */ - feraiseexcept(FE_INVALID); + + if (!isQNaN(x)) { + /* + * If it's not a quiet NaN, we want to signal an invalid + * operation. Otherwise, we silently return a NaN. + */ + feraiseexcept(FE_INVALID); + } + /* * FIXME: Of the many NaN values that we have, what NaN * should we return? */ union { int i[2]; double d; } ux; - ux.i[HIWORD] = 0x7ff00000; + ux.i[HIWORD] = 0x7ff80000; ux.i[LOWORD] = 0xdeadbeef; ret = ux.d; ----------------------------------------------------------------------- Summary of changes: src/lisp/s_expm1.c | 10 +++++++--- src/lisp/setexception.c | 43 +++++++++++++++++++++++++++++++++++++++++-- tests/trig.lisp | 41 ++++++++++++++++++++++++++++++++++------- 3 files changed, 82 insertions(+), 12 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-5-g3a09aa2
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 3a09aa24b038be094140ddc86069d0a89eeea5c2 (commit) from f3c9558971d5b0b6aa2b34feb22f44396c90ae33 (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 3a09aa24b038be094140ddc86069d0a89eeea5c2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Nov 22 20:10:50 2013 -0800 Darwin doesn't need pi reduction; the C library is accurate enough. o Make %trig call the C routines directly on Darwin/x86. o Add some extra documentation, and a test case. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 927a5fb..5944182 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -187,14 +187,17 @@ (%sqrt x)) ) -;;; The standard libm routines for sin, cos, and tan on x86 (Linux) -;;; and ppc are not very accurate for large arguments when compared to -;;; sparc (and maxima). This is basically caused by the fact that -;;; those libraries do not do an accurate argument reduction. The -;;; following functions use some routines Sun's free fdlibm library to -;;; do accurate reduction. Then we call the standard C functions (or -;;; vops for x86) on the reduced argument. This produces much more -;;; accurate values. +;;; The standard libm routines for sin, cos, and tan on x86 (Linux, +;;; 32-bit. 64-bit is apparently ok) and ppc are not very accurate +;;; for large arguments when compared to sparc (and maxima). This is +;;; basically caused by the fact that those libraries do not do an +;;; accurate argument reduction. The following functions use some +;;; routines Sun's free fdlibm library to do accurate reduction. Then +;;; we call the standard C functions (or vops for x86) on the reduced +;;; argument. This produces much more accurate values. +;;; +;;; You can test this by computing (cos (scale-float 1d0 120)). The +;;; true answer is -0.9258790228548379d0. #+(or ppc x86) (progn @@ -220,7 +223,22 @@ ) -#+(or ppc sse2) +;; If the C library is accurate, use %trig as the Lisp name. +#-(or ppc (and sse2 (not darwin))) +(progn +(declaim (inline %sin %cos %tan)) +(macrolet ((frob (alien-name lisp-name) + `(alien:def-alien-routine (,alien-name ,lisp-name) double-float + (x double-float)))) + (frob "sin" %sin) + (frob "cos" %cos) + (frob "tan" %tan)) +) + +;; Make %%trig be the C library routines that don't do accurate +;; reduction. This is for PPC and for any SSE2 build except on +;; Darwin. Darwin has accurate C library routines. +#+(or ppc (and sse2 (not darwin))) (progn (declaim (inline %%sin %%cos %%tan)) (macrolet ((frob (alien-name lisp-name) @@ -231,7 +249,10 @@ (frob "tan" %%tan)) ) -#+(or ppc x86) +;; When the C library is not accurate, define %trig to do accurate +;; argument reduction and call the appropriate C function on the +;; reduced arg. For x87, we can use the x87 FPU trig instructions. +#+(or ppc (and x86 (not darwin))) (macrolet ((frob (sin cos tan) `(progn ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 41 +++++++++++++++++++++++++++++++---------- 1 file changed, 31 insertions(+), 10 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-56-gc2e152b
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 c2e152be334f9e1272db737e2eb5056e67def8d0 (commit) via 381ee3ea819551345913ff2fe761571d4100aff1 (commit) via 9adcb02d4500ccf87a18f8c3b9a9ebbddb4751d0 (commit) via 359d84fb9e0a22ae9d6def2bc1a002542354c50c (commit) from 7adafd921406485dfea0fb8e9290f5ae7f8aa5e5 (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 c2e152be334f9e1272db737e2eb5056e67def8d0 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:31:18 2014 -0700 Use the fdlibm asin, acos, and atan routines. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index df0bb8c..ef1628b 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -67,10 +67,10 @@ (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 ("fdlibm_atan" %atan) 1) (def-math-rtn "atan2" 2) -(def-math-rtn "asin" 1) -(def-math-rtn "acos" 1) +(def-math-rtn ("__ieee754_asin" %asin) 1) +(def-math-rtn ("__ieee754_acos" %acos) 1) (def-math-rtn "sinh" 1) (def-math-rtn "cosh" 1) (def-math-rtn "tanh" 1) commit 381ee3ea819551345913ff2fe761571d4100aff1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:30:49 2014 -0700 Compile the asin, acos, and atan routines. diff --git a/src/lisp/Config.x86_darwin b/src/lisp/Config.x86_darwin index 8c7c37b..9a2c467 100644 --- a/src/lisp/Config.x86_darwin +++ b/src/lisp/Config.x86_darwin @@ -18,7 +18,7 @@ OS_LIBS = EXEC_FINAL_OBJ = exec-final.o -OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c s_log1p.c s_expm1.c e_pow.c e_exp.c e_log.c +OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c s_log1p.c s_expm1.c e_pow.c e_exp.c e_log.c e_acos.c e_asin.c s_atan.c k_sin.o : k_sin.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< @@ -48,3 +48,10 @@ e_exp.o : e_exp.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< e_log.o : e_log.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + +e_acos.o : e_acos.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +e_asin.o : e_asin.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +s_atan.o : s_atan.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< commit 9adcb02d4500ccf87a18f8c3b9a9ebbddb4751d0 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:30:17 2014 -0700 Use unions to access the high and low parts of a double. diff --git a/src/lisp/e_acos.c b/src/lisp/e_acos.c index d7c9ed2..bd54a04 100644 --- a/src/lisp/e_acos.c +++ b/src/lisp/e_acos.c @@ -66,10 +66,13 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ { double z,p,q,r,w,s,c,df; int hx,ix; - hx = __HI(x); + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; ix = hx&0x7fffffff; if(ix>=0x3ff00000) { /* |x| >= 1 */ - if(((ix-0x3ff00000)|__LO(x))==0) { /* |x|==1 */ + if(((ix-0x3ff00000)|ux.i[LOWORD])==0) { /* |x|==1 */ if(hx>0) return 0.0; /* acos(1) = 0 */ else return pi+2.0*pio2_lo; /* acos(-1)= pi */ } @@ -94,7 +97,9 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ z = (one-x)*0.5; s = sqrt(z); df = s; - __LO(df) = 0; + ux.d = df; + ux.i[LOWORD] = 0; + df = ux.d; c = (z-df*df)/(s+df); p = z*(pS0+z*(pS1+z*(pS2+z*(pS3+z*(pS4+z*pS5))))); q = one+z*(qS1+z*(qS2+z*(qS3+z*qS4))); diff --git a/src/lisp/e_asin.c b/src/lisp/e_asin.c index 8e37e22..9b476a4 100644 --- a/src/lisp/e_asin.c +++ b/src/lisp/e_asin.c @@ -75,10 +75,13 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ { double t,w,p,q,c,r,s; int hx,ix; - hx = __HI(x); + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; ix = hx&0x7fffffff; if(ix>= 0x3ff00000) { /* |x|>= 1 */ - if(((ix-0x3ff00000)|__LO(x))==0) + if(((ix-0x3ff00000)|ux.i[LOWORD])==0) /* asin(1)=+-pi/2 with inexact */ return x*pio2_hi+x*pio2_lo; return (x-x)/(x-x); /* asin(|x|>1) is NaN */ @@ -103,7 +106,9 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ t = pio2_hi-(2.0*(s+s*w)-pio2_lo); } else { w = s; - __LO(w) = 0; + ux.d = w; + ux.i[LOWORD] = 0; + w = ux.d; c = (t-w*w)/(s+w); r = p/q; p = 2.0*s*r-(pio2_lo-2.0*c); diff --git a/src/lisp/s_atan.c b/src/lisp/s_atan.c index 0093eaf..003f057 100644 --- a/src/lisp/s_atan.c +++ b/src/lisp/s_atan.c @@ -83,20 +83,22 @@ one = 1.0, huge = 1.0e300; #ifdef __STDC__ - double atan(double x) + double fdlibm_atan(double x) #else - double atan(x) + double fdlibm_atan(x) double x; #endif { double w,s1,s2,z; int ix,hx,id; + union { int i[2]; double d; } ux; - hx = __HI(x); + ux.d = x; + hx = ux.i[HIWORD]; ix = hx&0x7fffffff; if(ix>=0x44100000) { /* if |x| >= 2^66 */ if(ix>0x7ff00000|| - (ix==0x7ff00000&&(__LO(x)!=0))) + (ix==0x7ff00000&&(ux.i[LOWORD]!=0))) return x+x; /* NaN */ if(hx>0) return atanhi[3]+atanlo[3]; else return -atanhi[3]-atanlo[3]; commit 359d84fb9e0a22ae9d6def2bc1a002542354c50c Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 08:35:39 2014 -0700 Import inverse trig functions from fdlibm, as is. diff --git a/src/lisp/e_acos.c b/src/lisp/e_acos.c new file mode 100644 index 0000000..d7c9ed2 --- /dev/null +++ b/src/lisp/e_acos.c @@ -0,0 +1,105 @@ + +/* @(#)e_acos.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_acos(x) + * Method : + * acos(x) = pi/2 - asin(x) + * acos(-x) = pi/2 + asin(x) + * For |x|<=0.5 + * acos(x) = pi/2 - (x + x*x^2*R(x^2)) (see asin.c) + * For x>0.5 + * acos(x) = pi/2 - (pi/2 - 2asin(sqrt((1-x)/2))) + * = 2asin(sqrt((1-x)/2)) + * = 2s + 2s*z*R(z) ...z=(1-x)/2, s=sqrt(z) + * = 2f + (2c + 2s*z*R(z)) + * where f=hi part of s, and c = (z-f*f)/(s+f) is the correction term + * for f so that f+c ~ sqrt(z). + * For x<-0.5 + * acos(x) = pi - 2asin(sqrt((1-|x|)/2)) + * = pi - 0.5*(s+s*z*R(z)), where z=(1-|x|)/2,s=sqrt(z) + * + * Special cases: + * if x is NaN, return x itself; + * if |x|>1, return NaN with invalid signal. + * + * Function needed: sqrt + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +one= 1.00000000000000000000e+00, /* 0x3FF00000, 0x00000000 */ +pi = 3.14159265358979311600e+00, /* 0x400921FB, 0x54442D18 */ +pio2_hi = 1.57079632679489655800e+00, /* 0x3FF921FB, 0x54442D18 */ +pio2_lo = 6.12323399573676603587e-17, /* 0x3C91A626, 0x33145C07 */ +pS0 = 1.66666666666666657415e-01, /* 0x3FC55555, 0x55555555 */ +pS1 = -3.25565818622400915405e-01, /* 0xBFD4D612, 0x03EB6F7D */ +pS2 = 2.01212532134862925881e-01, /* 0x3FC9C155, 0x0E884455 */ +pS3 = -4.00555345006794114027e-02, /* 0xBFA48228, 0xB5688F3B */ +pS4 = 7.91534994289814532176e-04, /* 0x3F49EFE0, 0x7501B288 */ +pS5 = 3.47933107596021167570e-05, /* 0x3F023DE1, 0x0DFDF709 */ +qS1 = -2.40339491173441421878e+00, /* 0xC0033A27, 0x1C8A2D4B */ +qS2 = 2.02094576023350569471e+00, /* 0x40002AE5, 0x9C598AC8 */ +qS3 = -6.88283971605453293030e-01, /* 0xBFE6066C, 0x1B8D0159 */ +qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ + +#ifdef __STDC__ + double __ieee754_acos(double x) +#else + double __ieee754_acos(x) + double x; +#endif +{ + double z,p,q,r,w,s,c,df; + int hx,ix; + hx = __HI(x); + ix = hx&0x7fffffff; + if(ix>=0x3ff00000) { /* |x| >= 1 */ + if(((ix-0x3ff00000)|__LO(x))==0) { /* |x|==1 */ + if(hx>0) return 0.0; /* acos(1) = 0 */ + else return pi+2.0*pio2_lo; /* acos(-1)= pi */ + } + return (x-x)/(x-x); /* acos(|x|>1) is NaN */ + } + if(ix<0x3fe00000) { /* |x| < 0.5 */ + if(ix<=0x3c600000) return pio2_hi+pio2_lo;/*if|x|<2**-57*/ + z = x*x; + p = z*(pS0+z*(pS1+z*(pS2+z*(pS3+z*(pS4+z*pS5))))); + q = one+z*(qS1+z*(qS2+z*(qS3+z*qS4))); + r = p/q; + return pio2_hi - (x - (pio2_lo-x*r)); + } else if (hx<0) { /* x < -0.5 */ + z = (one+x)*0.5; + p = z*(pS0+z*(pS1+z*(pS2+z*(pS3+z*(pS4+z*pS5))))); + q = one+z*(qS1+z*(qS2+z*(qS3+z*qS4))); + s = sqrt(z); + r = p/q; + w = r*s-pio2_lo; + return pi - 2.0*(s+w); + } else { /* x > 0.5 */ + z = (one-x)*0.5; + s = sqrt(z); + df = s; + __LO(df) = 0; + c = (z-df*df)/(s+df); + p = z*(pS0+z*(pS1+z*(pS2+z*(pS3+z*(pS4+z*pS5))))); + q = one+z*(qS1+z*(qS2+z*(qS3+z*qS4))); + r = p/q; + w = r*s+c; + return 2.0*(df+w); + } +} diff --git a/src/lisp/e_asin.c b/src/lisp/e_asin.c new file mode 100644 index 0000000..8e37e22 --- /dev/null +++ b/src/lisp/e_asin.c @@ -0,0 +1,114 @@ + +/* @(#)e_asin.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_asin(x) + * Method : + * Since asin(x) = x + x^3/6 + x^5*3/40 + x^7*15/336 + ... + * we approximate asin(x) on [0,0.5] by + * asin(x) = x + x*x^2*R(x^2) + * where + * R(x^2) is a rational approximation of (asin(x)-x)/x^3 + * and its remez error is bounded by + * |(asin(x)-x)/x^3 - R(x^2)| < 2^(-58.75) + * + * For x in [0.5,1] + * asin(x) = pi/2-2*asin(sqrt((1-x)/2)) + * Let y = (1-x), z = y/2, s := sqrt(z), and pio2_hi+pio2_lo=pi/2; + * then for x>0.98 + * asin(x) = pi/2 - 2*(s+s*z*R(z)) + * = pio2_hi - (2*(s+s*z*R(z)) - pio2_lo) + * For x<=0.98, let pio4_hi = pio2_hi/2, then + * f = hi part of s; + * c = sqrt(z) - f = (z-f*f)/(s+f) ...f+c=sqrt(z) + * and + * asin(x) = pi/2 - 2*(s+s*z*R(z)) + * = pio4_hi+(pio4-2s)-(2s*z*R(z)-pio2_lo) + * = pio4_hi+(pio4-2f)-(2s*z*R(z)-(pio2_lo+2c)) + * + * Special cases: + * if x is NaN, return x itself; + * if |x|>1, return NaN with invalid signal. + * + */ + + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +one = 1.00000000000000000000e+00, /* 0x3FF00000, 0x00000000 */ +huge = 1.000e+300, +pio2_hi = 1.57079632679489655800e+00, /* 0x3FF921FB, 0x54442D18 */ +pio2_lo = 6.12323399573676603587e-17, /* 0x3C91A626, 0x33145C07 */ +pio4_hi = 7.85398163397448278999e-01, /* 0x3FE921FB, 0x54442D18 */ + /* coefficient for R(x^2) */ +pS0 = 1.66666666666666657415e-01, /* 0x3FC55555, 0x55555555 */ +pS1 = -3.25565818622400915405e-01, /* 0xBFD4D612, 0x03EB6F7D */ +pS2 = 2.01212532134862925881e-01, /* 0x3FC9C155, 0x0E884455 */ +pS3 = -4.00555345006794114027e-02, /* 0xBFA48228, 0xB5688F3B */ +pS4 = 7.91534994289814532176e-04, /* 0x3F49EFE0, 0x7501B288 */ +pS5 = 3.47933107596021167570e-05, /* 0x3F023DE1, 0x0DFDF709 */ +qS1 = -2.40339491173441421878e+00, /* 0xC0033A27, 0x1C8A2D4B */ +qS2 = 2.02094576023350569471e+00, /* 0x40002AE5, 0x9C598AC8 */ +qS3 = -6.88283971605453293030e-01, /* 0xBFE6066C, 0x1B8D0159 */ +qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ + +#ifdef __STDC__ + double __ieee754_asin(double x) +#else + double __ieee754_asin(x) + double x; +#endif +{ + double t,w,p,q,c,r,s; + int hx,ix; + hx = __HI(x); + ix = hx&0x7fffffff; + if(ix>= 0x3ff00000) { /* |x|>= 1 */ + if(((ix-0x3ff00000)|__LO(x))==0) + /* asin(1)=+-pi/2 with inexact */ + return x*pio2_hi+x*pio2_lo; + return (x-x)/(x-x); /* asin(|x|>1) is NaN */ + } else if (ix<0x3fe00000) { /* |x|<0.5 */ + if(ix<0x3e400000) { /* if |x| < 2**-27 */ + if(huge+x>one) return x;/* return x with inexact if x!=0*/ + } else + t = x*x; + p = t*(pS0+t*(pS1+t*(pS2+t*(pS3+t*(pS4+t*pS5))))); + q = one+t*(qS1+t*(qS2+t*(qS3+t*qS4))); + w = p/q; + return x+x*w; + } + /* 1> |x|>= 0.5 */ + w = one-fabs(x); + t = w*0.5; + p = t*(pS0+t*(pS1+t*(pS2+t*(pS3+t*(pS4+t*pS5))))); + q = one+t*(qS1+t*(qS2+t*(qS3+t*qS4))); + s = sqrt(t); + if(ix>=0x3FEF3333) { /* if |x| > 0.975 */ + w = p/q; + t = pio2_hi-(2.0*(s+s*w)-pio2_lo); + } else { + w = s; + __LO(w) = 0; + c = (t-w*w)/(s+w); + r = p/q; + p = 2.0*s*r-(pio2_lo-2.0*c); + q = pio4_hi-2.0*w; + t = pio4_hi-(p-q); + } + if(hx>0) return t; else return -t; +} diff --git a/src/lisp/s_atan.c b/src/lisp/s_atan.c new file mode 100644 index 0000000..0093eaf --- /dev/null +++ b/src/lisp/s_atan.c @@ -0,0 +1,134 @@ + +/* @(#)s_atan.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. + * ==================================================== + * + */ + +/* atan(x) + * Method + * 1. Reduce x to positive by atan(x) = -atan(-x). + * 2. According to the integer k=4t+0.25 chopped, t=x, the argument + * is further reduced to one of the following intervals and the + * arctangent of t is evaluated by the corresponding formula: + * + * [0,7/16] atan(x) = t-t^3*(a1+t^2*(a2+...(a10+t^2*a11)...) + * [7/16,11/16] atan(x) = atan(1/2) + atan( (t-0.5)/(1+t/2) ) + * [11/16.19/16] atan(x) = atan( 1 ) + atan( (t-1)/(1+t) ) + * [19/16,39/16] atan(x) = atan(3/2) + atan( (t-1.5)/(1+1.5t) ) + * [39/16,INF] atan(x) = atan(INF) + atan( -1/t ) + * + * Constants: + * The hexadecimal values are the intended ones for the following + * constants. The decimal values may be used, provided that the + * compiler will convert from decimal to binary accurately enough + * to produce the hexadecimal values shown. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double atanhi[] = { +#else +static double atanhi[] = { +#endif + 4.63647609000806093515e-01, /* atan(0.5)hi 0x3FDDAC67, 0x0561BB4F */ + 7.85398163397448278999e-01, /* atan(1.0)hi 0x3FE921FB, 0x54442D18 */ + 9.82793723247329054082e-01, /* atan(1.5)hi 0x3FEF730B, 0xD281F69B */ + 1.57079632679489655800e+00, /* atan(inf)hi 0x3FF921FB, 0x54442D18 */ +}; + +#ifdef __STDC__ +static const double atanlo[] = { +#else +static double atanlo[] = { +#endif + 2.26987774529616870924e-17, /* atan(0.5)lo 0x3C7A2B7F, 0x222F65E2 */ + 3.06161699786838301793e-17, /* atan(1.0)lo 0x3C81A626, 0x33145C07 */ + 1.39033110312309984516e-17, /* atan(1.5)lo 0x3C700788, 0x7AF0CBBD */ + 6.12323399573676603587e-17, /* atan(inf)lo 0x3C91A626, 0x33145C07 */ +}; + +#ifdef __STDC__ +static const double aT[] = { +#else +static double aT[] = { +#endif + 3.33333333333329318027e-01, /* 0x3FD55555, 0x5555550D */ + -1.99999999998764832476e-01, /* 0xBFC99999, 0x9998EBC4 */ + 1.42857142725034663711e-01, /* 0x3FC24924, 0x920083FF */ + -1.11111104054623557880e-01, /* 0xBFBC71C6, 0xFE231671 */ + 9.09088713343650656196e-02, /* 0x3FB745CD, 0xC54C206E */ + -7.69187620504482999495e-02, /* 0xBFB3B0F2, 0xAF749A6D */ + 6.66107313738753120669e-02, /* 0x3FB10D66, 0xA0D03D51 */ + -5.83357013379057348645e-02, /* 0xBFADDE2D, 0x52DEFD9A */ + 4.97687799461593236017e-02, /* 0x3FA97B4B, 0x24760DEB */ + -3.65315727442169155270e-02, /* 0xBFA2B444, 0x2C6A6C2F */ + 1.62858201153657823623e-02, /* 0x3F90AD3A, 0xE322DA11 */ +}; + +#ifdef __STDC__ + static const double +#else + static double +#endif +one = 1.0, +huge = 1.0e300; + +#ifdef __STDC__ + double atan(double x) +#else + double atan(x) + double x; +#endif +{ + double w,s1,s2,z; + int ix,hx,id; + + hx = __HI(x); + ix = hx&0x7fffffff; + if(ix>=0x44100000) { /* if |x| >= 2^66 */ + if(ix>0x7ff00000|| + (ix==0x7ff00000&&(__LO(x)!=0))) + return x+x; /* NaN */ + if(hx>0) return atanhi[3]+atanlo[3]; + else return -atanhi[3]-atanlo[3]; + } if (ix < 0x3fdc0000) { /* |x| < 0.4375 */ + if (ix < 0x3e200000) { /* |x| < 2^-29 */ + if(huge+x>one) return x; /* raise inexact */ + } + id = -1; + } else { + x = fabs(x); + if (ix < 0x3ff30000) { /* |x| < 1.1875 */ + if (ix < 0x3fe60000) { /* 7/16 <=|x|<11/16 */ + id = 0; x = (2.0*x-one)/(2.0+x); + } else { /* 11/16<=|x|< 19/16 */ + id = 1; x = (x-one)/(x+one); + } + } else { + if (ix < 0x40038000) { /* |x| < 2.4375 */ + id = 2; x = (x-1.5)/(one+1.5*x); + } else { /* 2.4375 <= |x| < 2^66 */ + id = 3; x = -1.0/x; + } + }} + /* end of argument reduction */ + z = x*x; + w = z*z; + /* break sum from i=0 to 10 aT[i]z**(i+1) into odd and even poly */ + s1 = z*(aT[0]+w*(aT[2]+w*(aT[4]+w*(aT[6]+w*(aT[8]+w*aT[10]))))); + s2 = w*(aT[1]+w*(aT[3]+w*(aT[5]+w*(aT[7]+w*aT[9])))); + if (id<0) return x - x*(s1+s2); + else { + z = atanhi[id] - ((x*(s1+s2) - atanlo[id]) - x); + return (hx<0)? -z:z; + } +} ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 6 +- src/lisp/Config.x86_darwin | 9 ++- src/lisp/e_acos.c | 110 +++++++++++++++++++++++++++++++++++ src/lisp/e_asin.c | 119 ++++++++++++++++++++++++++++++++++++++ src/lisp/s_atan.c | 136 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 376 insertions(+), 4 deletions(-) create mode 100644 src/lisp/e_acos.c create mode 100644 src/lisp/e_asin.c create mode 100644 src/lisp/s_atan.c hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-1-g2527de5
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 2527de5ed52be53257a51876fe775630333cfc17 (commit) from d669c129619ad3952fcabb263e307e3d48b12969 (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 2527de5ed52be53257a51876fe775630333cfc17 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 11 10:40:30 2013 -0800 Make %sincos consistently return sin and cos instead of cos and sin. Update users accordingly. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 8e17a45..270f1dc 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -342,24 +342,25 @@ (- c (* s y)))) (case (logand n 3) (0 - (values (cos2 s c y1) - (sin2 s c y1))) - (1 - (values (- (sin2 s c y1)) + (values (sin2 s c y1) (cos2 s c y1))) - (2 - (values (- (cos2 s c y1)) + (1 + (values (cos2 s c y1) (- (sin2 s c y1)))) + (2 + (values (- (sin2 s c y1)) + (- (cos2 s c y1)))) (3 - (values (sin2 s c y1) - (- (cos2 s c y1))))))))) + (values (- (cos2 s c y1)) + (sin2 s c y1)))))))) #+sparc (declaim (inline %sinccos)) #+sparc (defun %sincos (theta) (multiple-value-bind (ignore s c) (%%sincos theta) - (values c s))) + (declare (ignore ignore)) + (values s c))) ) @@ -1025,13 +1026,13 @@ (let ((arg (coerce theta 'double-float))) (multiple-value-bind (s c) (%sincos arg) - (complex (coerce s 'single-float) - (coerce c 'single-float))))) + (complex (coerce c 'single-float) + (coerce s 'single-float))))) (((foreach single-float double-float)) (multiple-value-bind (s c) (%sincos (coerce theta 'double-float)) - (complex (coerce s '(dispatch-type theta)) - (coerce c '(dispatch-type theta))))) + (complex (coerce c '(dispatch-type theta)) + (coerce s '(dispatch-type theta))))) #+double-double ((double-double-float) (complex (cos theta) (sin theta)))))) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index fba199b..a8147d9 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -740,14 +740,13 @@ (deftransform cis ((x) (single-float) * :when :both) `(multiple-value-bind (s c) (kernel::%sincos (coerce x 'double-float)) - (complex (coerce s 'single-float) - (coerce c 'single-float)))) + (complex (coerce c 'single-float) + (coerce s 'single-float)))) (deftransform cis ((x) (double-float) * :when :both) - `(multiple-value-bind (ignore s c) - (kernel::%%sincos x) - (declare (ignore ignore)) - (complex s c))) + `(multiple-value-bind (s c) + (kernel::%sincos x) + (complex c s))) #+double-double (deftransform cis ((z) (double-double-float) *) ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 27 ++++++++++++++------------- src/compiler/float-tran.lisp | 11 +++++------ 2 files changed, 19 insertions(+), 19 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2014-09 created. snapshot-2014-09
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 annotated tag, snapshot-2014-09 has been created at 15b34683012e3681f157ece707a5b6afc080e246 (tag) tagging ac320f2c22d0532b7920257f0487c449028c81fc (commit) replaces snapshot-2014-08 tagged by Raymond Toy on Tue Sep 2 20:38:26 2014 -0700 - Log ----------------------------------------------------------------- Snapshot 2014-09 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlQGjToACgkQJ5IjUmgZO7JznACfRQbbX4uG1ruzJKpjVkYx41NS vVQAoIbu2TqfvkUNydBVlBAGsiuZ/nhP =JM+6 -----END PGP SIGNATURE----- Raymond Toy (44): Forgot a few items that were done in the snapshot. Update it now (post Remove Config.FreeBSD* and Config.NetBSD*. These were replaced by Fix ticket #100 by implementing STREAM-FILE-POSITION Fix ticket:105 by not flaming out on a closed stream. Add test for ticket:101 for the case of CLEAR-OUTPUT of a lisp Clean up the CLEAR-OUTPUT test a bit. Regenerated. Fix ticket:101, implementing STREAM-ADVANCE-TO-COLUMN for FORMAT ~T. Fix ticket:106 by returning the correctly rounded value. Micro optimize float bits getters. Make cosh signal overflow when it should overflow. Add -ffp-contract=off to make sure no fused-multiply instructions are Make sure floating-point exceptions are signaled. Ensure acosh signals appropriate exceptions. Add -fno-omit-frame-pointer; we want the frame pointer to make it Handle invalid correctly. Make expm1 signal errors using fdlibm_setexception. Update tests to Add -fno-omit-frame-pointer; we want the frame pointer to make it Make log1p signal errors using fdlibm_setexception. Fix some typos and remove redundant test for expm1. Make exp signal errors using fdlibm_setexception. Re-enable the x87 floating-point mode stuff. On x86/darwin, we want and only need the sse2 mode bits. Darwin Give up trying to get the operands if we don't know what the FP Make log signal errors using fdlibm_setexception. Fix typo. Make asinh signal errors using fdlibm_setexception. Make atanh signal errors using fdlibm_setexception. Make inverse trig signal errors using fdlibm_setexception. Rename fdlibm tests to include a % prefix to distinguish these from Deprecate FLOAT-TRAPPING-NAN-P in favor of FLOAT-SIGNALING-NAN-P. Update documentation to include float-signaling-nan-p. Oops. Fix mistake in handling underflow for %exp. Use the two-prod algorithm from crlibm documentation. Implement a simpler (and faster?) algorithm to convert a double to an Correct the comment. Tests for double-double arithmetic. Add support for deriving the type of ROUND. Needs work. Move the test cases from compiler/srctran.lisp to tests/srctran.lisp. Add function to run selected tests. Makes it a bit easier to run a Add some tests for ROUND. Two tests currently fail. Fix round-quotient-bound to handle exclusive bounds better. If a process is not schedulable because it has no run-reasons and/or Update from the commit logs. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2013-04 created. snapshot-2013-04
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 annotated tag, snapshot-2013-04 has been created at f52f77edb11c8c5fc50fa832d019809140b5a8e4 (tag) tagging b722521aea8ccd801d12afe519871ab34b8d789f (commit) replaces snapshot-2013-03-a tagged by Raymond Toy on Sat Apr 13 22:13:01 2013 -0700 - Log ----------------------------------------------------------------- Snapshot 2013-04 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (Darwin) iEYEABECAAYFAlFqOuUACgkQJ5IjUmgZO7LB9ACbBn5ax+8Bt3TzmAihJEjTcfCA 9W8AoKjAN2UCcd0M1OiG64xW43CH7Sjo =hzuc -----END PGP SIGNATURE----- Raymond Toy (12): Support ppc. Try to be careful about extracting the linux version from the (uname) Fix ticket:79 Update from logs. Fix ticket:77 by adding the code given in the ticket. Fix ticket:77 correctly, using the supplied patch link. Fix ticket:80 Update from logs. Update -u option so that asdf is always built. Update from logs. Update from logs. Oops. Always build asdf and friends. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-14-ge5ce88c
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 e5ce88c766cd83f58a0b4e3d0e99bdd24d92b86a (commit) via f9be60b19ca38fbbf34dc64bf5442f119afe2725 (commit) via aa05f53d8b1fa758d0768ccec0462a9ad9f1f601 (commit) via ebc07aeb9114976829a26667ac2b88ce7a49bdcb (commit) from 8a5b49ec0af3c4cad29a26e8dc3f9cee029fd67d (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 e5ce88c766cd83f58a0b4e3d0e99bdd24d92b86a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:43:49 2014 -0800 Regenerated. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 2034dac..fdbb637 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -182,9 +182,9 @@ msgid "" " setf." msgstr "" -#: src/code/reader.lisp src/code/format.lisp src/code/print.lisp -#: src/code/irrat-dd.lisp src/code/irrat.lisp src/code/float.lisp -#: src/code/numbers.lisp src/code/kernel.lisp +#: src/code/format.lisp src/code/print.lisp src/code/irrat-dd.lisp +#: src/code/irrat.lisp src/code/float.lisp src/code/numbers.lisp +#: src/code/kernel.lisp msgid "Argument ~A is not a ~S: ~S." msgstr "" @@ -8553,7 +8553,7 @@ msgid "Underflow" msgstr "" #: src/code/reader.lisp -msgid "Number not representable as ~S: ~S" +msgid "Number not representable as a ~S: ~S" msgstr "" #: src/code/reader.lisp commit f9be60b19ca38fbbf34dc64bf5442f119afe2725 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:43:26 2014 -0800 Fix ticket 93. * Round the number to least-positive-foo-float when possible, but still throw an error if it's too small but not zero. * Update comments to mention CLHS 2.3.1.1. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 27c18ae..b06230c 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1839,15 +1839,15 @@ the end of the stream." least-positive-single-float) (double-float least-positive-double-float) + #+double-double (double-double-float - (kernel:make-double-double-float least-positive-double-float - 0d0))))) + ext:least-positive-double-double-float)))) (if (>= (* 2 ratio) float-limit) (setf result float-limit) (error _"Underflow")))) result)) (error () - (%reader-error stream _"Number not representable as ~S: ~S" + (%reader-error stream _"Number not representable as a ~S: ~S" float-format (/ number divisor))))) commit aa05f53d8b1fa758d0768ccec0462a9ad9f1f601 Merge: ebc07ae 8a5b49e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Mar 1 08:31:39 2014 -0800 Merge branch 'master' into rtoy-round-float-in-reader commit ebc07aeb9114976829a26667ac2b88ce7a49bdcb Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Feb 28 19:49:04 2014 -0800 Fix ticket 93. * src/code/reader.lisp: * Try to round really small numbers * Add somewhat more informative message when the number is not representable. * src/i18n/local/cmucl.pot: * Update * tests/trac.lisp: * Add test for ticket 93 * Add a few comments for test trac.87. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 4eabc4e..27c18ae 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1824,17 +1824,31 @@ the end of the stream." (defun make-float-aux (number divisor float-format stream) (handler-case (with-float-traps-masked (:underflow) - (let ((result (coerce (/ number divisor) float-format))) + (let* ((ratio (/ number divisor)) + (result (coerce ratio float-format))) (when (and (zerop result) (not (zerop number))) - ;; With underflow traps disabled, reading any number - ;; smaller than least-positive-foo-float will return zero. - ;; But we really want to indicate that we can't read it. - ;; So if we converted the number to zero, but the number - ;; wasn't actually zero, throw an error. - (error _"Underflow")) + ;; The number we've read is so small that it gets + ;; converted to 0.0, but is not actually zero. In this + ;; case, we want to round such small numbers to + ;; least-positive-foo-float. If it's still too small, we + ;; want to signal an error saying that we can't really + ;; convert it because the exponent is too small. + ;; See CLHS 2.3.1.1. + (let ((float-limit (ecase float-format + ((short-float single-float) + least-positive-single-float) + (double-float + least-positive-double-float) + (double-double-float + (kernel:make-double-double-float least-positive-double-float + 0d0))))) + (if (>= (* 2 ratio) float-limit) + (setf result float-limit) + (error _"Underflow")))) result)) (error () - (%reader-error stream _"Floating-point number not representable")))) + (%reader-error stream _"Number not representable as ~S: ~S" + float-format (/ number divisor))))) (defun make-ratio (stream) diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 8ae0b93..2034dac 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -182,9 +182,9 @@ msgid "" " setf." msgstr "" -#: src/code/format.lisp src/code/print.lisp src/code/irrat-dd.lisp -#: src/code/irrat.lisp src/code/float.lisp src/code/numbers.lisp -#: src/code/kernel.lisp +#: src/code/reader.lisp src/code/format.lisp src/code/print.lisp +#: src/code/irrat-dd.lisp src/code/irrat.lisp src/code/float.lisp +#: src/code/numbers.lisp src/code/kernel.lisp msgid "Argument ~A is not a ~S: ~S." msgstr "" @@ -8553,7 +8553,7 @@ msgid "Underflow" msgstr "" #: src/code/reader.lisp -msgid "Floating-point number not representable" +msgid "Number not representable as ~S: ~S" msgstr "" #: src/code/reader.lisp @@ -13084,7 +13084,11 @@ msgid "" " process changes. The function takes the process as an argument.\n" " :external-format -\n" " This is the external-format used for communication with the subproce" -"ss." +"ss.\n" +" :element-type -\n" +" When a stream is created for :input or :output, the stream\n" +" uses this element-type instead of the default 'BASE-CHAR type.\n" +"" msgstr "" #: src/code/run-program.lisp diff --git a/tests/trac.lisp b/tests/trac.lisp index 87e3ca7..7fd9408 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -276,7 +276,9 @@ (define-test trac.87.output (:tag :trac) - (let ((path "/tmp/trac.87") + ;; Test that run-program accepts :element-type and produces the + ;; correct output. + (let ((path "/tmp/trac.87.output") (string "Hello")) (unwind-protect (progn @@ -297,7 +299,9 @@ (define-test trac.87.input (:tag :trac) - (let ((path "/tmp/trac.87") + ;; Test that run-program accepts :element-type and produces the + ;; correct input (and output). + (let ((path "/tmp/trac.87.input") (string "Hello")) (unwind-protect (progn @@ -328,3 +332,23 @@ 'double-float (third (kernel:%function-type f))))) +(define-test trac.93 + (:tag :trac) + ;; These small values should read to least-positive-foo-float + ;; because that's the closest non-zero float. + (assert-eql least-positive-short-float + (values (read-from-string ".8s-45"))) + (assert-eql least-positive-single-float + (values (read-from-string ".8e-45"))) + (assert-eql least-positive-double-float + (values (read-from-string "4d-324"))) + (assert-eql (kernel:make-double-double-float least-positive-double-float 0d0) + (values (read-from-string "4w-324"))) + ;; These should signal reader errors because the numbers are not + ;; zero, but are too small to be represented by the corresponding + ;; float type. + (assert-error 'reader-error (read-from-string ".1s-45")) + (assert-error 'reader-error (read-from-string ".1e-45")) + (assert-error 'reader-error (read-from-string "1d-324")) + (assert-error 'reader-error (read-from-string "1w-324"))) + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: src/code/reader.lisp | 30 ++++++++++++++++++++++-------- src/i18n/locale/cmucl.pot | 2 +- tests/trac.lisp | 28 ++++++++++++++++++++++++++-- 3 files changed, 49 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-39-gf849f4d
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 f849f4dba02f2b41d78ffe21d43be5b184aa7cdf (commit) via 16c06cb82aa0e6b6f8866fb227dd608af4c06027 (commit) from b3b6dce07ceb5538e89ce8c49a8bd1fe2d6a15d1 (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 f849f4dba02f2b41d78ffe21d43be5b184aa7cdf Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 22 23:06:58 2013 -0800 Simple test script to run all of the tests in the tests directory. diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp new file mode 100644 index 0000000..0a7da54 --- /dev/null +++ b/tests/run-tests.lisp @@ -0,0 +1,96 @@ +;;;; -*- Mode: lisp -*- + +;;;; Main script to run all of the tests in the tests directory. +;;;; It is intended to be run using something like +;;;; +;;;; lisp -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)' +;;;; +;;;; The exit code indicates whether there were any test failures. A +;;;; non-zero code indicates a failure of some sort. +;;;; +;;;; It is assumed that either asdf or quicklisp is set up +;;;; appropriately so that lisp-unit can be automatically loaded + +(defpackage :cmucl-test-runner + (:use :cl) + (:export #:run-all-tests + #:load-and-run-all-tests + #:print-test-results)) + +(in-package :cmucl-test-runner) + +(require :lisp-unit) + +;; Be rather verbose in printing the tests +(setf lisp-unit:*print-summary* t) +(setf lisp-unit:*print-failures* t) +(setf lisp-unit:*print-errors* t) + +(defvar *load-path* *load-pathname*) + +;; Look through all the files in the tests directory and load them. +;; Then run all of the tests. For each file, it ia assumed that a +;; package is created that is named with "-TESTS" appended to he +;; pathname-name of the file. +(defun load-and-run-all-tests () + (let (test-names + test-results) + (dolist (file (directory "tests/*.lisp")) + (unless (equal file *load-path*) + (let ((basename (pathname-name file))) + ;; Create the package name from the pathname name so we know + ;; how to run the test. + (push (concatenate 'string (string-upcase basename) "-TESTS") + test-names) + (load file)))) + (setf test-names (nreverse test-names)) + (dolist (test test-names) + (push (lisp-unit:run-tests :all test) + test-results)) + (nreverse test-results))) + +(defun print-test-results (results) + (let ((passed 0) + (failed 0) + (execute-errors 0) + failed-tests + execute-error-tests) + (dolist (result results) + (incf passed (lisp-unit::pass result)) + (incf failed (lisp-unit::fail result)) + (incf execute-errors (lisp-unit::exerr result)) + (when (lisp-unit::failed-tests result) + (setf failed-tests + (append (lisp-unit::failed-tests result) + failed-tests))) + (when (lisp-unit::error-tests result) + (setf execute-error-tests + (append (lisp-unit::error-tests result) + execute-error-tests)))) + (format t "~2&-------------------------------------------------~%") + (format t "Summary of all testsuites~2%") + (format t "~D testsuites were run~%" (length results)) + (format t " ~5D tests total~%" (+ passed failed execute-errors)) + (format t " ~5D tests failed~%" failed) + (format t " ~5D tests with execution errors~%" execute-errors) + (format t "~5,2f% of the tests passed~%" + (float (* 100 + (- 1 (/ (+ failed execute-errors) + (+ passed failed execute-errors)))))) + ;; Print some info about any failed tests. Then exit. We want to + ;; set the exit code so that any scripts runnning this can + ;; determine if there were any test failures. + (cond ((plusp (+ failed execute-errors)) + (when failed-tests + (format t "~2&Failed tests: ~S~%" failed-tests)) + (when execute-error-tests + (format t "~2&Execute failures: ~S~%" execute-error-tests)) + (unix:unix-exit 1)) + (t + (unix:unix-exit 0))))) + +(defun run-all-tests () + (print-test-results (load-and-run-all-tests))) + +;;(run-all-tests) +;;(quit) commit 16c06cb82aa0e6b6f8866fb227dd608af4c06027 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 22 23:00:04 2013 -0800 Regenerated. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 0c327c9..d38bc65 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -5040,9 +5040,9 @@ msgid "" "Z may be any number, but the result is always a complex." msgstr "" -#: src/code/irrat-dd.lisp src/code/irrat.lisp +#: src/code/irrat.lisp msgid "" -"Compute asin z = asinh(i*z)/i\n" +"Compute asin z = -i*log(i*z + sqrt(1-z^2))\n" "\n" "Z may be any number, but the result is always a complex." msgstr "" @@ -5054,9 +5054,9 @@ msgid "" "Z may be any number, but the result is always a complex." msgstr "" -#: src/code/irrat-dd.lisp src/code/irrat.lisp +#: src/code/irrat.lisp msgid "" -"Compute atan z = atanh (i*z) / i\n" +"Compute atan z = (log(1+i*z) - log(1-i*z))/(2*i)\n" "\n" "Z may be any number, but the result is always a complex." msgstr "" @@ -5116,6 +5116,20 @@ msgstr "" msgid "Overflow" msgstr "" +#: src/code/irrat-dd.lisp +msgid "" +"Compute asin z = asinh(i*z)/i\n" +"\n" +"Z may be any number, but the result is always a complex." +msgstr "" + +#: src/code/irrat-dd.lisp +msgid "" +"Compute atan z = atanh (i*z) / i\n" +"\n" +"Z may be any number, but the result is always a complex." +msgstr "" + #: src/compiler/proclaim.lisp msgid "" "~S uses lambda-list keyword naming convention, but is not a recognized " ----------------------------------------------------------------------- Summary of changes: src/i18n/locale/cmucl.pot | 22 +++++++++-- tests/run-tests.lisp | 96 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 114 insertions(+), 4 deletions(-) create mode 100644 tests/run-tests.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-05-14-gb8c0807
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 b8c080759c41e1a16d0468a4138799e4a3d02151 (commit) via a3f78ebd73e13965fb0d609f639737a1428d6578 (commit) via 49f041ad84bf812b25d4fffc210da123400cb6f0 (commit) via 9d66b2585eb33ff8106511da512b4772a3887aab (commit) from 9f62dcdfab39ef03cf01969b6ea88b962073d09f (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 b8c080759c41e1a16d0468a4138799e4a3d02151 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun May 26 08:24:37 2013 -0700 Update. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 90df1d4..ee290d9 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -43,10 +43,15 @@ New in this release: Pentium.) * Update unicode to support Unicode 6.2. * Add MP:PROCESS-JOIN, as given in ticket #77. + * Added UNICODE package to hold Unicode-related functions. + Currently contains Unicode extended versions of STRING-UPCASE, + STRING-DOWNCASE, and STRING-CAPITALIZE. * ANSI compliance fixes: * Attempts to modify the standard readtable or the standard pprint dispatch table will now signal a continuable error. + * Remove the Unicode extensions from string-upcase and friends. + This functionality is moved to the new UNICODE package. * Bugfixes: * REPLACE and friends on strings were limited to strings less than commit a3f78ebd73e13965fb0d609f639737a1428d6578 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun May 26 08:22:00 2013 -0700 Import many unicode symbols from LISP into the UNICODE package. src/code/exports.lisp:: * Import symbols src/code/unicode.lisp:: * Remove LISP package prefix from all unicode-related symbols. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 249bc32..b2bdeab 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2447,6 +2447,20 @@ (:shadow "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE") + (:import-from "LISP" + "CODEPOINT" + "SURROGATES" + "UNICODE-FULL-CASE-LOWER" + "UNICODE-FULL-CASE-UPPER" + "UNICODE-FULL-CASE-TITLE" + "UNICODE-CATEGORY" + "+UNICODE-CATEGORY-LOWER+" + "+UNICODE-CATEGORY-OTHER+" + "+UNICODE-CATEGORY-GRAPHIC+" + "+UNICODE-CATEGORY-UPPER+" + "+UNICODE-CATEGORY-TITLE+" + "UNICODE-UPPER" + "UNICODE-WORD-BREAK") (:export "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE" diff --git a/src/code/unicode.lisp b/src/code/unicode.lisp index 98fe880..cbd7713 100644 --- a/src/code/unicode.lisp +++ b/src/code/unicode.lisp @@ -36,14 +36,14 @@ ((= index (the fixnum end))) (declare (fixnum index)) (multiple-value-bind (code wide) - (lisp:codepoint string index) + (codepoint string index) (when wide (incf index)) ;; Handle ASCII specially because this is called early in ;; initialization, before unidata is available. (cond ((< 96 code 123) (write-char (code-char (decf code 32)) s)) ((> code 127) - (write-string (lisp:unicode-full-case-upper code) s)) + (write-string (unicode-full-case-upper code) s)) (t (multiple-value-bind (hi lo) (surrogates code) @@ -82,14 +82,14 @@ ((= index (the fixnum end))) (declare (fixnum index)) (multiple-value-bind (code wide) - (lisp:codepoint string index) + (codepoint string index) (when wide (incf index)) ;; Handle ASCII specially because this is called early in ;; initialization, before unidata is available. (cond ((< 64 code 91) (write-char (code-char (incf code 32)) s)) ((> code 127) - (write-string (lisp:unicode-full-case-lower code) s)) + (write-string (unicode-full-case-lower code) s)) (t ;; Handle codes below 64 (multiple-value-bind (hi lo) @@ -230,7 +230,7 @@ ((char-word-break-category (c) ;; Map our unicode word break property into what this ;; algorithm wants. - (let ((cat (lisp::unicode-word-break c))) + (let ((cat (unicode-word-break c))) (case cat ((:lf :cr :newline) :sep) @@ -241,7 +241,7 @@ ;; Given a valid index i into s, returns the left context ;; at i. (multiple-value-bind (c widep) - (lisp:codepoint s i n) + (codepoint s i n) (let* ((back ;; If we're at a regular character or a leading ;; surrogate, decrementing by 1 gets us the to @@ -279,7 +279,7 @@ (let* ((j1 (- j 1))) (multiple-value-bind (c widep) - (lisp:codepoint s j1) + (codepoint s j1) (when (eql widep -1) ;; Back up one more if we're at the trailing ;; surrogate. @@ -302,7 +302,7 @@ (if (< i j) j n))) (otherwise n)) (multiple-value-bind (c widep) - (lisp:codepoint s j) + (codepoint s j) (let* ((next-j ;; The next character is either 1 or 2 code ;; units away. For a leading surrogate, it's @@ -394,7 +394,7 @@ n) (t (multiple-value-bind (c widep) - (lisp:codepoint s i) + (codepoint s i) (declare (ignore c)) (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) @@ -416,15 +416,15 @@ (:simple #'(lambda (ch) (multiple-value-bind (hi lo) - (lisp::surrogates (lisp::unicode-upper ch)) + (surrogates (unicode-upper ch)) (write-char hi result) (when lo (write-char lo result))))) (:full #'(lambda (ch) - (write-string (lisp::unicode-full-case-upper ch) result))) + (write-string (unicode-full-case-upper ch) result))) (:title #'(lambda (ch) - (write-string (lisp::unicode-full-case-title ch) result)))))) + (write-string (unicode-full-case-title ch) result)))))) (do ((start start next) (next (string-next-word-break string start) (string-next-word-break string next))) @@ -432,7 +432,7 @@ (>= start end))) ;; Convert the first character of the word to upper ;; case, and then make the rest of the word lowercase. - (funcall upper (lisp:codepoint string start)) + (funcall upper (codepoint string start)) (write-string (string-downcase string :start (1+ start) :end next :casing casing) @@ -459,29 +459,29 @@ (or (< 47 m 58) (< 64 m 91) (< 96 m 123) #+(and unicode (not unicode-bootstrap)) (and (> m 127) - (<= lisp::+unicode-category-letter+ - (lisp::unicode-category m) - (+ lisp::+unicode-category-letter+ #x0F))))) + (<= +unicode-category-letter+ + (unicode-category m) + (+ +unicode-category-letter+ #x0F))))) (upper (ch) (ecase casing (:simple #'(lambda (ch) (multiple-value-bind (hi lo) - (lisp::surrogates (lisp::unicode-upper ch)) + (surrogates (unicode-upper ch)) (write-char hi s) (when lo (write-char lo s))))) (:full #'(lambda (ch) - (write-string (lisp::unicode-full-case-upper ch) s))) + (write-string (unicode-full-case-upper ch) s))) (:title #'(lambda (ch) - (write-string (lisp::unicode-full-case-title ch) s)))))) + (write-string (unicode-full-case-title ch) s)))))) (do ((index start (1+ index)) (newword t)) ((= index (the fixnum end))) (declare (fixnum index)) (multiple-value-bind (code wide) - (lisp:codepoint string index) + (codepoint string index) (when wide (incf index)) (cond ((not (alphanump code)) (multiple-value-bind (hi lo) @@ -495,7 +495,7 @@ (setq newword ())) (t ;; char is case-modifiable, but not first - (write-string (lisp:unicode-full-case-lower code) s)))))) + (write-string (unicode-full-case-lower code) s)))))) (write-string string s :start end :end offset-slen)))))) (defun string-capitalize (string &key (start 0) end commit 49f041ad84bf812b25d4fffc210da123400cb6f0 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 25 14:38:36 2013 -0700 Remove all the extensions to string-upcase and friends. The extended functions now live in the new UNICODE package. src/code/exports.lisp:: * Export some unicode functions and constants. src/code/string.lisp:: * Removed the extended versions of string-upcase and friends. * Export surrogates function. * Make sure with-one-string is defined so the unicode package can use it. src/code/unicode.lisp:; * New file with extended versions of string-upcase and friends. src/code/unidata.lisp:: * Export some unicode functions and constants. src/compiler/fndb.lisp:: * Update defknowns for string-upcase and friends. src/tools/worldbuild.lisp:: * Build unicode.lisp src/tools/worldcom.lisp:: * Load unicode.lisp diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 6c7bbed..249bc32 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -913,7 +913,17 @@ (:export "STRING-TO-NFC" "STRING-TO-NFD" "STRING-TO-NFKC" "STRING-TO-NFKD" "UNICODE-COMPLETE" "UNICODE-COMPLETE-NAME" - "LOAD-ALL-UNICODE-DATA")) + "UNICODE-FULL-CASE-LOWER" + "UNICODE-FULL-CASE-UPPER" + "UNICODE-FULL-CASE-TITLE" + "UNICODE-CATEGORY" + "+UNICODE-CATEGORY-LOWER+" + "+UNICODE-CATEGORY-OTHER+" + "+UNICODE-CATEGORY-GRAPHIC+" + "+UNICODE-CATEGORY-UPPER+" + "+UNICODE-CATEGORY-TITLE+" + "LOAD-ALL-UNICODE-DATA" + "SURROGATES")) (defpackage "EVAL" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" @@ -2432,4 +2442,14 @@ "LAST-FWRAPPER" "DO-FWRAPPERS")) +(defpackage "UNICODE" + (:use "COMMON-LISP") + (:shadow "STRING-CAPITALIZE" + "STRING-DOWNCASE" + "STRING-UPCASE") + (:export "STRING-CAPITALIZE" + "STRING-DOWNCASE" + "STRING-UPCASE" + "STRING-NEXT-WORD-BREAK")) + diff --git a/src/code/string.lisp b/src/code/string.lisp index 5176edf..8005cda 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -30,7 +30,7 @@ nstring-capitalize)) #+unicode -(export '(string-to-nfd string-to-nfkd string-to-nfkc)) +(export '(string-to-nfd string-to-nfkd string-to-nfkc surrogates)) (declaim (inline surrogatep surrogates-to-codepoint codepoint surrogates)) @@ -159,7 +159,7 @@ ;;; With-One-String is used to set up some string hacking things. The keywords ;;; are parsed, and the string is hacked into a simple-string. -(eval-when (compile) +(eval-when (compile load eval) (defmacro with-one-string (string start end cum-offset &rest forms) `(let ((,string (if (stringp ,string) ,string (string ,string)))) @@ -594,7 +594,9 @@ (setf (schar string i) fill-char)) (make-string count))) -(defun string-upcase-simple (string &key (start 0) end) +(defun string-upcase (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with all + lower case alphabetic characters converted to uppercase." (declare (fixnum start)) (let* ((string (if (stringp string) string (string string))) (slen (length string))) @@ -634,54 +636,9 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+unicode -(defun string-upcase-full (string &key (start 0) end) - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (s) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - (write-string string s :start offset :end start) - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (multiple-value-bind (code wide) - (codepoint string index) - (when wide (incf index)) - ;; Handle ASCII specially because this is called early in - ;; initialization, before unidata is available. - (cond ((< 96 code 123) - (write-char (code-char (decf code 32)) s)) - ((> code 127) - (write-string (unicode-full-case-upper code) s)) - (t - (multiple-value-bind (hi lo) - (surrogates code) - (write-char hi s) - (when lo - (write-char lo s))))))) - (write-string string s :start end :end offset-slen)))))) - -(defun string-upcase (string &key (start 0) end #+unicode (casing :simple)) - #-unicode +(defun string-downcase (string &key (start 0) end) _N"Given a string, returns a new string that is a copy of it with all - lower case alphabetic characters converted to uppercase." - #+unicode - _N"Given a string, returns a new string that is a copy of it with all - lower case alphabetic characters converted to uppercase. Casing is - :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - #-unicode - (string-upcase-simple string :start start :end end) - #+unicode - (if (eq casing :simple) - (string-upcase-simple string :start start :end end) - (string-upcase-full string :start start :end end))) - -(defun string-downcase-simple (string &key (start 0) end) + upper case alphabetic characters converted to lowercase." (declare (fixnum start)) (let* ((string (if (stringp string) string (string string))) (slen (length string))) @@ -720,54 +677,12 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+unicode -(defun string-downcase-full (string &key (start 0) end) - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (s) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - (write-string string s :start offset :end start) - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (multiple-value-bind (code wide) - (codepoint string index) - (when wide (incf index)) - ;; Handle ASCII specially because this is called early in - ;; initialization, before unidata is available. - (cond ((< 64 code 91) - (write-char (code-char (incf code 32)) s)) - ((> code 127) - (write-string (unicode-full-case-lower code) s)) - (t - (multiple-value-bind (hi lo) - (surrogates code) - (write-char hi s) - (when lo - (write-char lo s))))))) - (write-string string s :start end :end offset-slen)))))) - -(defun string-downcase (string &key (start 0) end #+unicode (casing :simple)) - #-unicode - _N"Given a string, returns a new string that is a copy of it with all - upper case alphabetic characters converted to lowercase." - #+unicode - _N"Given a string, returns a new string that is a copy of it with all - upper case alphabetic characters converted to lowercase. Casing is - :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - #-unicode - (string-downcase-simple string :start start :end end) - #+unicode - (if (eq casing :simple) - (string-downcase-simple string :start start :end end) - (string-downcase-full string :start start :end end))) - -(defun string-capitalize-simple (string &key (start 0) end) +(defun string-capitalize (string &key (start 0) end) + _N"Given a string, returns a copy of the string with the first + character of each ``word'' converted to upper-case, and remaining + chars in the word converted to lower case. A ``word'' is defined + to be a string of case-modifiable characters delimited by + non-case-modifiable chars." (declare (fixnum start)) (let* ((string (if (stringp string) string (string string))) (slen (length string))) @@ -804,74 +719,6 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+unicode -(defun string-capitalize-full (string &key (start 0) end) - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (s) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - (write-string string s :start offset :end start) - (flet ((alphanump (m) - (or (< 47 m 58) (< 64 m 91) (< 96 m 123) - #+(and unicode (not unicode-bootstrap)) - (and (> m 127) - (<= +unicode-category-letter+ (unicode-category m) - (+ +unicode-category-letter+ #x0F)))))) - (do ((index start (1+ index)) - (newword t)) - ((= index (the fixnum end))) - (declare (fixnum index)) - (multiple-value-bind (code wide) - (codepoint string index) - (when wide (incf index)) - (cond ((not (alphanump code)) - (multiple-value-bind (hi lo) - (surrogates code) - (write-char hi s) - (when lo (write-char lo s))) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (write-string (unicode-full-case-title code) s) - (setq newword ())) - ;;char is case-modifiable, but not first - (t - (write-string (unicode-full-case-lower code) s)))))) - (write-string string s :start end :end offset-slen)))))) - -(defun string-capitalize (string &key (start 0) end - #+unicode (casing :simple) - #+unicode unicode-word-break) - #-unicode - _N"Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - #+unicode - _N"Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. Casing is :simple or - :full for simple or full case conversion, respectively. If - Unicode-Word-Break is non-Nil, then the Unicode word-breaking - algorithm is used to determine the word boundaries. Otherwise, A - ``word'' is defined to be a string of case-modifiable characters - delimited by non-case-modifiable chars. " - - (declare (fixnum start)) - #-unicode - (string-capitalize-simple string :start start :end end) - #+unicode - (if unicode-word-break - (string-capitalize-unicode string :start start :end end :casing casing) - (if (eq casing :simple) - (string-capitalize-simple string :start start :end end) - (string-capitalize-full string :start start :end end)))) - (defun nstring-upcase (string &key (start 0) end) "Given a string, returns that string with all lower case alphabetic characters converted to uppercase." @@ -1390,322 +1237,6 @@ (if (simple-string-p string) string (coerce string 'simple-string))) -;;; -;;; This is a Lisp translation of the Scheme code from William -;;; D. Clinger that implements the word-breaking algorithm. This is -;;; used with permission. -;;; -;;; This version is modified from the original at -;;; http://www.ccs.neu.edu/home/will/R6RS/ to conform to CMUCL's -;;; implementation of the word break properties. -;;; -;;; -;;; Copyright statement and original comments: -;;; -;;;-------------------------------------------------------------------------------- - -;; Copyright 2006 William D Clinger. -;; -;; Permission to copy this software, in whole or in part, to use this -;; software for any lawful purpose, and to redistribute this software -;; is granted subject to the restriction that all copies made of this -;; software must include this copyright and permission notice in full. -;; -;; I also request that you send me a copy of any improvements that you -;; make to this software so that they may be incorporated within it to -;; the benefit of the Scheme community. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Word-breaking as defined by Unicode Standard Annex #29. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Implementation notes. -;; -;; The string-foldcase, string-downcase, and string-titlecase -;; procedures rely on the notion of a word, which is defined -;; by Unicode Standard Annex 29. -;; -;; The string-foldcase and string-downcase procedures rely on -;; word boundaries only when they encounter a Greek sigma, so -;; their performance should not be greatly affected by the -;; performance of the word-breaking algorithm. -;; -;; The string-titlecase procedure must find all word boundaries, -;; but it is typically used on short strings (titles). -;; -;; Hence the performance of the word-breaking algorithm should -;; not matter too much for this reference implementation. -;; Word-breaking is more generally useful, however, so I tried -;; to make this implementation reasonably efficient. -;; -;; Word boundaries are defined by 14 different rules in -;; Unicode Standard Annex #29, and by GraphemeBreakProperty.txt -;; and WordBreakProperty.txt. See also WordBreakTest.html. -;; -;; My original implementation of those specifications failed -;; 6 of the 494 tests in auxiliary/WordBreakTest.txt, but it -;; appeared to me that those tests were inconsistent with the -;; word-breaking rules in UAX #29. John Cowan forwarded my -;; bug report to the Unicode experts, and Mark Davis responded -;; on 29 May 2007: -;; -;; Thanks for following up on this. I think you have found a problem in the -;; formulation of word break, not the test. The intention was to break after a -;; Sep character, as is done in Sentence break. So my previous suggestion was -;; incorrect; instead, what we need is a new rule: -;; -;; *Break after paragraph separators.* -;; WB3a. Sep � -;; I'll make a propose to the UTC for this. -;; -;; Here is Will's translation of those rules (including WB3a) -;; into a finite state machine that searches forward within a -;; string, looking for the next position at which a word break -;; is allowed. The current state consists of an index i into -;; the string and a summary of the left context whose rightmost -;; character is at index i. The left context is usually -;; determined by the character at index i, but there are three -;; complications: -;; -;; Extend and Format characters are ignored unless they -;; follow a separator or the beginning of the text. -;; ALetter followed by MidLetter is treated specially. -;; Numeric followed by MidNum is treated specially. -;; -;; In the implementation below, the left context ending at i -;; is encoded by the following symbols: -;; -;; CR -;; Sep (excluding CR) -;; ALetter -;; MidLetter -;; ALetterMidLetter (ALetter followed by MidLetter) -;; Numeric -;; MidNum -;; NumericMidNum (Numeric followed by MidNum) -;; Katakana -;; ExtendNumLet -;; other (none of the above) -;; -;; Given a string s and an exact integer i (which need not be -;; a valid index into s), returns the index of the next character -;; that is not part of the word containing the character at i, -;; or the length of s if the word containing the character at i -;; extends through the end of s. If i is negative or a valid -;; index into s, then the returned value will be greater than i. -;; -;;;-------------------------------------------------------------------------------- - -(defun string-next-word-break (s i) - (let ((n (length s))) - (labels - ((char-word-break-category (c) - ;; Map our unicode word break property into what this - ;; algorithm wants. - (let ((cat (lisp::unicode-word-break c))) - (case cat - ((:lf :cr :newline) - :sep) - ((:extend :format) - :extend-or-format) - (otherwise cat)))) - (left-context (i) - ;; Given a valid index i into s, returns the left context - ;; at i. - (multiple-value-bind (c widep) - (lisp::codepoint s i n) - (let* ((back - ;; If we're at a regular character or a leading - ;; surrogate, decrementing by 1 gets us the to - ;; previous character. But for a trailing - ;; surrogate, we need to decrement by 2! - (if (eql widep -1) - 2 - 1)) - (cat (char-word-break-category c))) - (case cat - ((:sep) - (if (= c (char-code #\return)) :cr cat)) - ((:midletter :midnumlet) - (let ((i-1 (- i back))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :aletter)) - :aletter-midletter - cat))) - ((:midnum :midnumlet) - (let ((i-1 (- i back))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :numeric)) - :numeric-midnum - cat))) - ((:extendorformat) - (if (< 0 i) - (left-context (- i back)) - :other)) - (otherwise cat))))) - - (index-of-previous-non-ignored (j) - ;; Returns the index of the last non-Extend, non-Format - ;; character within (substring s 0 j). Should not be - ;; called unless such a character exists. - - (let* ((j1 (- j 1))) - (multiple-value-bind (c widep) - (lisp::codepoint s j1) - (when (eql widep -1) - ;; Back up one more if we're at the trailing - ;; surrogate. - (decf j1)) - (let ((cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (index-of-previous-non-ignored j1)) - (otherwise j1)))))) - - (lookup (j context) - ;; Given j and the context to the left of (not including) j, - ;; returns the index at the start of the next word - ;; (or before which a word break is permitted). - - (if (>= j n) - (case context - ((:aletter-midletter :numeric-midnum) - (let ((j (index-of-previous-non-ignored n))) - (if (< i j) j n))) - (otherwise n)) - (multiple-value-bind (c widep) - (lisp::codepoint s j) - (let* ((next-j - ;; The next character is either 1 or 2 code - ;; units away. For a leading surrogate, it's - ;; 2; Otherwise just 1. - (if (eql widep 1) - 2 - 1)) - (cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (case context - ((:cr :sep) j) - (otherwise (lookup (+ j next-j) context)))) - (otherwise - (case context - ((:cr) - (if (= c (char-code #\linefeed)) - ;; Rule WB3: Don't break CRLF, continue looking - (lookup (+ j next-j) cat) - j)) - ((:aletter) - (case cat - ((:aletter :numeric :extendnumlet) - ;; Rules WB5, WB9, ? - (lookup (+ j next-j) cat)) - ((:midletter :midnumlet) - ;; Rule WB6, need to keep looking - (lookup (+ j next-j) :aletter-midletter)) - (otherwise j))) - ((:aletter-midletter) - (case cat - ((:aletter) - ;; Rule WB7 - (lookup (+ j next-j) cat)) - (otherwise - ;; Rule WB6 and WB7 were extended, but the - ;; region didn't end with :aletter. So - ;; backup and break at that point. - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:numeric) - (case cat - ((:numeric :aletter :extendnumlet) - ;; Rules WB8, WB10, ? - (lookup (+ j next-j) cat)) - ((:midnum :midnumlet) - ;; Rules WB11, need to keep looking - (lookup (+ j next-j) :numeric-midnum)) - (otherwise j))) - ((:numeric-midnum) - (case cat - ((:numeric) - ;; Rule WB11, keep looking - (lookup (+ j next-j) cat)) - (otherwise - ;; Rule WB11, WB12 were extended, but the - ;; region didn't end with :numeric, so - ;; backup and break at that point. - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:midletter :midnum :midnumlet) - ;; Rule WB14 - j) - ((:katakana) - (case cat - ((:katakana :extendnumlet) - ;; Rule WB13, WB13a - (lookup (+ j next-j) cat)) - (otherwise j))) - ((:extendnumlet) - (case cat - ((:extendnumlet :aletter :numeric :katakana) - ;; Rule WB13a, WB13b - (lookup (+ j next-j) cat)) - (otherwise j))) - ((:regional_indicator) - (case cat - ((:regional_indicator) - ;; Rule WB13c - (lookup (+ j next-j) cat)) - (otherwise j))) - (otherwise j))))))))) - (declare (notinline lookup left-context)) - (cond ((< i 0) - ;; Rule WB1 - 0) - ((<= n i) - ;; Rule WB2 - n) - (t - (multiple-value-bind (c widep) - (lisp::codepoint s i) - (declare (ignore c)) - (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) - -(defun string-capitalize-unicode (string &key (start 0) end (casing :simple)) - (declare (type (member :simple :full) casing)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-output-to-string (result) - (lisp::with-one-string string start end offset - (let ((offset-slen (+ slen offset))) - (declare (fixnum offset-slen)) - - (write-string string result :start 0 :end start) - (let ((upper (ecase casing - (:simple - #'(lambda (ch) - (multiple-value-bind (hi lo) - (lisp::surrogates (lisp::unicode-upper ch)) - (write-char hi result) - (when lo (write-char lo result))))) - (:full - #'(lambda (ch) - (write-string (lisp::unicode-full-case-title ch) result)))))) - (do ((start start next) - (next (string-next-word-break string start) - (string-next-word-break string next))) - ((or (= start next) - (>= start end))) - ;; Convert the first character of the word to upper - ;; case, and then make the rest of the word lowercase. - (funcall upper (lisp::codepoint string start)) - (write-string (string-downcase string :start (1+ start) :end next :casing casing) - result :start (1+ start) :end next))) - (write-string string result :start end :end offset-slen)))))) - - ;; Some utilities (defun codepoints-string (seq) "Convert a sequence of codepoints to a string. Codepoints outside diff --git a/src/code/unicode.lisp b/src/code/unicode.lisp new file mode 100644 index 0000000..98fe880 --- /dev/null +++ b/src/code/unicode.lisp @@ -0,0 +1,519 @@ +;;; -*- Log: code.log; Package: Unicode -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/unicode.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Functions to process Unicode strings for CMU Common Lisp +;;; Written by Paul Foley and Raymond Toy. +;;; +;;; **************************************************************** +;;; +(in-package "UNICODE") +(intl:textdomain "cmucl") + +;; An example where this differs from cl:string-upcase differ: +;; #\Latin_Small_Letter_Sharp_S +(defun string-upcase-full (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with + all lower case alphabetic characters converted to uppercase using + full case conversion." + (declare (fixnum start)) (let* ((string (if + (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (s) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + (write-string string s :start offset :end start) + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (multiple-value-bind (code wide) + (lisp:codepoint string index) + (when wide (incf index)) + ;; Handle ASCII specially because this is called early in + ;; initialization, before unidata is available. + (cond ((< 96 code 123) + (write-char (code-char (decf code 32)) s)) + ((> code 127) + (write-string (lisp:unicode-full-case-upper code) s)) + (t + (multiple-value-bind (hi lo) + (surrogates code) + (write-char hi s) + (when lo + (write-char lo s))))))) + (write-string string s :start end :end offset-slen)))))) + +(defun string-upcase (string &key (start 0) end (casing :full)) + _N"Given a string, returns a new string that is a copy of it with + all lower case alphabetic characters converted to uppercase. Casing + is :simple or :full for simple or full case conversion, + respectively." + (declare (fixnum start)) + (if (eq casing :simple) + (cl:string-upcase string :start start :end end) + (string-upcase-full string :start start :end end))) + + +;; An example this differs from cl:string-downcase: +;; #\Latin_Capital_Letter_I_With_Dot_Above. +(defun string-downcase-full (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with + all uppercase alphabetic characters converted to lowercase using + full case conversion.." + (declare (fixnum start)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (s) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + (write-string string s :start offset :end start) + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (multiple-value-bind (code wide) + (lisp:codepoint string index) + (when wide (incf index)) + ;; Handle ASCII specially because this is called early in + ;; initialization, before unidata is available. + (cond ((< 64 code 91) + (write-char (code-char (incf code 32)) s)) + ((> code 127) + (write-string (lisp:unicode-full-case-lower code) s)) + (t + ;; Handle codes below 64 + (multiple-value-bind (hi lo) + (surrogates code) + (write-char hi s) + (when lo + (write-char lo s))))))) + (write-string string s :start end :end offset-slen)))))) + +(defun string-downcase (string &key (start 0) end (casing :full)) + _N"Given a string, returns a new string that is a copy of it with all + uppercase alphabetic characters converted to lowercase. Casing is + :simple or :full for simple or full case conversion, respectively." + + (declare (fixnum start)) + (if (eq casing :simple) + (cl:string-downcase string :start start :end end) + (string-downcase-full string :start start :end end))) + + +;;; +;;; This is a Lisp translation of the Scheme code from William +;;; D. Clinger that implements the word-breaking algorithm. This is +;;; used with permission. +;;; +;;; This version is modified from the original at +;;; http://www.ccs.neu.edu/home/will/R6RS/ to conform to CMUCL's +;;; implementation of the word break properties. +;;; +;;; +;;; Copyright statement and original comments: +;;; +;;;-------------------------------------------------------------------------------- + +;; Copyright 2006 William D Clinger. +;; +;; Permission to copy this software, in whole or in part, to use this +;; software for any lawful purpose, and to redistribute this software +;; is granted subject to the restriction that all copies made of this +;; software must include this copyright and permission notice in full. +;; +;; I also request that you send me a copy of any improvements that you +;; make to this software so that they may be incorporated within it to +;; the benefit of the Scheme community. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Word-breaking as defined by Unicode Standard Annex #29. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Implementation notes. +;; +;; The string-foldcase, string-downcase, and string-titlecase +;; procedures rely on the notion of a word, which is defined +;; by Unicode Standard Annex 29. +;; +;; The string-foldcase and string-downcase procedures rely on +;; word boundaries only when they encounter a Greek sigma, so +;; their performance should not be greatly affected by the +;; performance of the word-breaking algorithm. +;; +;; The string-titlecase procedure must find all word boundaries, +;; but it is typically used on short strings (titles). +;; +;; Hence the performance of the word-breaking algorithm should +;; not matter too much for this reference implementation. +;; Word-breaking is more generally useful, however, so I tried +;; to make this implementation reasonably efficient. +;; +;; Word boundaries are defined by 14 different rules in +;; Unicode Standard Annex #29, and by GraphemeBreakProperty.txt +;; and WordBreakProperty.txt. See also WordBreakTest.html. +;; +;; My original implementation of those specifications failed +;; 6 of the 494 tests in auxiliary/WordBreakTest.txt, but it +;; appeared to me that those tests were inconsistent with the +;; word-breaking rules in UAX #29. John Cowan forwarded my +;; bug report to the Unicode experts, and Mark Davis responded +;; on 29 May 2007: +;; +;; Thanks for following up on this. I think you have found a problem in the +;; formulation of word break, not the test. The intention was to break after a +;; Sep character, as is done in Sentence break. So my previous suggestion was +;; incorrect; instead, what we need is a new rule: +;; +;; *Break after paragraph separators.* +;; WB3a. Sep � +;; I'll make a propose to the UTC for this. +;; +;; Here is Will's translation of those rules (including WB3a) +;; into a finite state machine that searches forward within a +;; string, looking for the next position at which a word break +;; is allowed. The current state consists of an index i into +;; the string and a summary of the left context whose rightmost +;; character is at index i. The left context is usually +;; determined by the character at index i, but there are three +;; complications: +;; +;; Extend and Format characters are ignored unless they +;; follow a separator or the beginning of the text. +;; ALetter followed by MidLetter is treated specially. +;; Numeric followed by MidNum is treated specially. +;; +;; In the implementation below, the left context ending at i +;; is encoded by the following symbols: +;; +;; CR +;; Sep (excluding CR) +;; ALetter +;; MidLetter +;; ALetterMidLetter (ALetter followed by MidLetter) +;; Numeric +;; MidNum +;; NumericMidNum (Numeric followed by MidNum) +;; Katakana +;; ExtendNumLet +;; other (none of the above) +;; +;; Given a string s and an exact integer i (which need not be +;; a valid index into s), returns the index of the next character +;; that is not part of the word containing the character at i, +;; or the length of s if the word containing the character at i +;; extends through the end of s. If i is negative or a valid +;; index into s, then the returned value will be greater than i. +;; +;;;-------------------------------------------------------------------------------- + +(defun string-next-word-break (s i) + _N"Given a string, S, and a starting index, return the index of the + next character that is not part of the word containing the character + at the index, or the length of S if the word containing the + character extends to the end of S. If the index is negative or + valid index into S, the returned value will be strictly greater than + the index." + (let ((n (length s))) + (labels + ((char-word-break-category (c) + ;; Map our unicode word break property into what this + ;; algorithm wants. + (let ((cat (lisp::unicode-word-break c))) + (case cat + ((:lf :cr :newline) + :sep) + ((:extend :format) + :extend-or-format) + (otherwise cat)))) + (left-context (i) + ;; Given a valid index i into s, returns the left context + ;; at i. + (multiple-value-bind (c widep) + (lisp:codepoint s i n) + (let* ((back + ;; If we're at a regular character or a leading + ;; surrogate, decrementing by 1 gets us the to + ;; previous character. But for a trailing + ;; surrogate, we need to decrement by 2! + (if (eql widep -1) + 2 + 1)) + (cat (char-word-break-category c))) + (case cat + ((:sep) + (if (= c (char-code #\return)) :cr cat)) + ((:midletter :midnumlet) + (let ((i-1 (- i back))) + (if (and (<= 0 i-1) + (eq (left-context i-1) :aletter)) + :aletter-midletter + cat))) + ((:midnum :midnumlet) + (let ((i-1 (- i back))) + (if (and (<= 0 i-1) + (eq (left-context i-1) :numeric)) + :numeric-midnum + cat))) + ((:extendorformat) + (if (< 0 i) + (left-context (- i back)) + :other)) + (otherwise cat))))) + + (index-of-previous-non-ignored (j) + ;; Returns the index of the last non-Extend, non-Format + ;; character within (substring s 0 j). Should not be + ;; called unless such a character exists. + + (let* ((j1 (- j 1))) + (multiple-value-bind (c widep) + (lisp:codepoint s j1) + (when (eql widep -1) + ;; Back up one more if we're at the trailing + ;; surrogate. + (decf j1)) + (let ((cat (char-word-break-category c))) + (case cat + ((:extend-or-format) + (index-of-previous-non-ignored j1)) + (otherwise j1)))))) + + (lookup (j context) + ;; Given j and the context to the left of (not including) j, + ;; returns the index at the start of the next word + ;; (or before which a word break is permitted). + + (if (>= j n) + (case context + ((:aletter-midletter :numeric-midnum) + (let ((j (index-of-previous-non-ignored n))) + (if (< i j) j n))) + (otherwise n)) + (multiple-value-bind (c widep) + (lisp:codepoint s j) + (let* ((next-j + ;; The next character is either 1 or 2 code + ;; units away. For a leading surrogate, it's + ;; 2; Otherwise just 1. + (if (eql widep 1) + 2 + 1)) + (cat (char-word-break-category c))) + (case cat + ((:extend-or-format) + (case context + ((:cr :sep) j) + (otherwise (lookup (+ j next-j) context)))) + (otherwise + (case context + ((:cr) + (if (= c (char-code #\linefeed)) + ;; Rule WB3: Don't break CRLF, continue looking + (lookup (+ j next-j) cat) + j)) + ((:aletter) + (case cat + ((:aletter :numeric :extendnumlet) + ;; Rules WB5, WB9, ? + (lookup (+ j next-j) cat)) + ((:midletter :midnumlet) + ;; Rule WB6, need to keep looking + (lookup (+ j next-j) :aletter-midletter)) + (otherwise j))) + ((:aletter-midletter) + (case cat + ((:aletter) + ;; Rule WB7 + (lookup (+ j next-j) cat)) + (otherwise + ;; Rule WB6 and WB7 were extended, but the + ;; region didn't end with :aletter. So + ;; backup and break at that point. + (let ((j2 (index-of-previous-non-ignored j))) + (if (< i j2) j2 j))))) + ((:numeric) + (case cat + ((:numeric :aletter :extendnumlet) + ;; Rules WB8, WB10, ? + (lookup (+ j next-j) cat)) + ((:midnum :midnumlet) + ;; Rules WB11, need to keep looking + (lookup (+ j next-j) :numeric-midnum)) + (otherwise j))) + ((:numeric-midnum) + (case cat + ((:numeric) + ;; Rule WB11, keep looking + (lookup (+ j next-j) cat)) + (otherwise + ;; Rule WB11, WB12 were extended, but the + ;; region didn't end with :numeric, so + ;; backup and break at that point. + (let ((j2 (index-of-previous-non-ignored j))) + (if (< i j2) j2 j))))) + ((:midletter :midnum :midnumlet) + ;; Rule WB14 + j) + ((:katakana) + (case cat + ((:katakana :extendnumlet) + ;; Rule WB13, WB13a + (lookup (+ j next-j) cat)) + (otherwise j))) + ((:extendnumlet) + (case cat + ((:extendnumlet :aletter :numeric :katakana) + ;; Rule WB13a, WB13b + (lookup (+ j next-j) cat)) + (otherwise j))) + ((:regional_indicator) + (case cat + ((:regional_indicator) + ;; Rule WB13c + (lookup (+ j next-j) cat)) + (otherwise j))) + (otherwise j))))))))) + (declare (notinline lookup left-context)) + (cond ((< i 0) + ;; Rule WB1 + 0) + ((<= n i) + ;; Rule WB2 + n) + (t + (multiple-value-bind (c widep) + (lisp:codepoint s i) + (declare (ignore c)) + (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) + +(defun string-capitalize-unicode (string &key (start 0) end (casing :simple)) + "Capitalize String using the Unicode word-break algorithm to find + the words in String. The beginning is capitalized depending on the + value of Casing" + (declare (type (member :simple :full :title) casing)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (result) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + + (write-string string result :start 0 :end start) + (let ((upper (ecase casing + (:simple + #'(lambda (ch) + (multiple-value-bind (hi lo) + (lisp::surrogates (lisp::unicode-upper ch)) + (write-char hi result) + (when lo (write-char lo result))))) + (:full + #'(lambda (ch) + (write-string (lisp::unicode-full-case-upper ch) result))) + (:title + #'(lambda (ch) + (write-string (lisp::unicode-full-case-title ch) result)))))) + (do ((start start next) + (next (string-next-word-break string start) + (string-next-word-break string next))) + ((or (= start next) + (>= start end))) + ;; Convert the first character of the word to upper + ;; case, and then make the rest of the word lowercase. + (funcall upper (lisp:codepoint string start)) + (write-string (string-downcase string :start (1+ start) + :end next + :casing casing) + result + :start (1+ start) + :end next))) + (write-string string result :start end :end offset-slen)))))) + +(defun string-capitalize-full (string &key (start 0) end (casing :full)) + "Capitalize String using the Common Lisp word-break algorithm to find + the words in String. The beginning is capitalized depending on the + value of Casing" + (declare (fixnum start) + (type (member :simple :full :title) casing)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (with-output-to-string (s) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset))) + (declare (fixnum offset-slen)) + (write-string string s :start offset :end start) + (flet ((alphanump (m) + (or (< 47 m 58) (< 64 m 91) (< 96 m 123) + #+(and unicode (not unicode-bootstrap)) + (and (> m 127) + (<= lisp::+unicode-category-letter+ + (lisp::unicode-category m) + (+ lisp::+unicode-category-letter+ #x0F))))) + (upper (ch) + (ecase casing + (:simple + #'(lambda (ch) + (multiple-value-bind (hi lo) + (lisp::surrogates (lisp::unicode-upper ch)) + (write-char hi s) + (when lo (write-char lo s))))) + (:full + #'(lambda (ch) + (write-string (lisp::unicode-full-case-upper ch) s))) + (:title + #'(lambda (ch) + (write-string (lisp::unicode-full-case-title ch) s)))))) + (do ((index start (1+ index)) + (newword t)) + ((= index (the fixnum end))) + (declare (fixnum index)) + (multiple-value-bind (code wide) + (lisp:codepoint string index) + (when wide (incf index)) + (cond ((not (alphanump code)) + (multiple-value-bind (hi lo) + (surrogates code) + (write-char hi s) + (when lo (write-char lo s))) + (setq newword t)) + (newword + ;; Char is first case-modifiable after non-case-modifiable + (funcall upper code) + (setq newword ())) + (t + ;; char is case-modifiable, but not first + (write-string (lisp:unicode-full-case-lower code) s)))))) + (write-string string s :start end :end offset-slen)))))) + +(defun string-capitalize (string &key (start 0) end + (casing :title) + (unicode-word-break t)) + _N"Given a string, returns a copy of the string with the first + character of each ``word'' converted to upper-case, and remaining + chars in the word converted to lower case. Casing is :simple, :full + or :title for simple, full or title case conversion, respectively. If + Unicode-Word-Break is non-Nil, then the Unicode word-breaking + algorithm is used to determine the word boundaries. Otherwise, A + ``word'' is defined to be a string of case-modifiable characters + delimited by non-case-modifiable chars. " + + (declare (fixnum start) + (type (member :simple :full :title) casing)) + (if unicode-word-break + (string-capitalize-unicode string :start start :end end :casing casing) + (if (eq casing :simple) + (cl:string-capitalize string :start start :end end) + (string-capitalize-full string :start start :end end :casing casing)))) diff --git a/src/code/unidata.lisp b/src/code/unidata.lisp index 55e3a28..3518100 100644 --- a/src/code/unidata.lisp +++ b/src/code/unidata.lisp @@ -18,6 +18,15 @@ (export '(string-to-nfd string-to-nfkc string-to-nfkd string-to-nfc unicode-complete unicode-complete-name + unicode-full-case-lower + unicode-full-case-upper + unicode-full-case-title + unicode-category + +unicode-category-lower+ + +unicode-category-other+ + +unicode-category-graphic+ + +unicode-category-upper+ + +unicode-category-title+ load-all-unicode-data)) (defvar *unidata-path* #p"ext-formats:unidata.bin") diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 5229915..052b4c1 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -851,13 +851,11 @@ (sequence stringable) simple-string (flushable)) (defknown (string-upcase string-downcase) - (stringable &key (:start index) (:end sequence-end) #+unicode (:casing case-conversion-type)) + (stringable &key (:start index) (:end sequence-end)) simple-string (flushable)) (defknown (string-capitalize) - (stringable &key (:start index) (:end sequence-end) - #+unicode (:casing case-conversion-type) - #+unicode (:unicode-word-break boolean)) + (stringable &key (:start index) (:end sequence-end)) simple-string (flushable)) (defknown (nstring-upcase nstring-downcase nstring-capitalize) diff --git a/src/tools/worldbuild.lisp b/src/tools/worldbuild.lisp index 9d0dbb6..4b5f364 100644 --- a/src/tools/worldbuild.lisp +++ b/src/tools/worldbuild.lisp @@ -186,6 +186,8 @@ ,@(when (c:backend-featurep :mp) '("target:code/multi-proc")) "target:code/intl-tramp" + ,@(when (c::backend-featurep :unicode) + '("target:code/unicode")) )) (setf *genesis-core-name* "target:lisp/kernel.core") diff --git a/src/tools/worldcom.lisp b/src/tools/worldcom.lisp index f8ac65a..150d33c 100644 --- a/src/tools/worldcom.lisp +++ b/src/tools/worldcom.lisp @@ -324,6 +324,8 @@ (comf "target:code/intl-tramp") (comf "target:code/intl") +(when (c:backend-featurep :unicode) + (comf "target:code/unicode")) ); let *byte-compile-top-level* ); with-compiler-log-file commit 9d66b2585eb33ff8106511da512b4772a3887aab Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri May 24 19:18:49 2013 -0700 Fix typo. diff --git a/src/code/multi-proc.lisp b/src/code/multi-proc.lisp index e478a95..4e2b1bc 100644 --- a/src/code/multi-proc.lisp +++ b/src/code/multi-proc.lisp @@ -1977,6 +1977,6 @@ (setf (lock-process ,lock) nil))))))) (defun process-join (process) - (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) - (lambda () (not (mp:process-alive-p thread)))) + (mp:process-wait (format nil "Waiting for thread ~A to complete" process) + (lambda () (not (mp:process-alive-p process)))) (values-list (process-%return-values process))) ----------------------------------------------------------------------- Summary of changes: src/code/exports.lisp | 36 ++- src/code/multi-proc.lisp | 4 +- src/code/string.lisp | 495 +----------------------------------- src/code/unicode.lisp | 519 ++++++++++++++++++++++++++++++++++++++ src/code/unidata.lisp | 9 + src/compiler/fndb.lisp | 6 +- src/general-info/release-20e.txt | 5 + src/tools/worldbuild.lisp | 2 + src/tools/worldcom.lisp | 2 + 9 files changed, 589 insertions(+), 489 deletions(-) create mode 100644 src/code/unicode.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-07-1-gf36a31a
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 f36a31aaf95b60e2cc210648d951b41d3112a73a (commit) from bb56dbb6572939222d731530c3045b4a87ee7f51 (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 f36a31aaf95b60e2cc210648d951b41d3112a73a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jul 5 06:56:29 2013 -0700 Make NOT-MORE-CONTAGIOUS support member and union types. This change allow cmucl to fold identity operations as in (defun foo (x) (declare (float x)) (* x 1)) Previously, cmucl wouldn't change (* x 1) to just x. because the declaration of x is represented internally as a union type. diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 7888eba..c12251c 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3141,45 +3141,58 @@ ;;; (defun not-more-contagious (x y) (declare (type continuation x y)) - (let ((type1 (continuation-type x)) - (type2 (continuation-type y))) - (if (and (numeric-type-p type1) (numeric-type-p type2)) - (let ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (format1 (numeric-type-format type1)) - (format2 (numeric-type-format type2)) - (complexp1 (numeric-type-complexp type1)) - (complexp2 (numeric-type-complexp type2))) - (cond ((or (null complexp1) (null class1)) Nil) - ((member class1 '(integer rational)) 'T) - ((and (eq class1 'float) (null complexp2)) Nil) - ((and (eq class1 'float) (null class2)) Nil) - ((and (eq class1 'float) (eq class2 'float)) - (and (ecase complexp2 - (:real (eq complexp1 :real)) - (:complex 'T)) - (ecase format2 - ((nil short-float single-float) - (member format1 '(short-float single-float))) - #-double-double - ((double-float long-float) 'T) - #+double-double - (double-float - (member format1 '(short-float single-float - double-float))) - #+long-float - (long-float 'T) - #+double-double - (double-double-float 't)))) - ((and (eq class1 'float) (member class2 '(integer rational))) - Nil) - (t - (error (intl:gettext "Unexpected types: ~s ~s~%") type1 type2))))))) + (let ((x-type (continuation-type x)) + (y-type (continuation-type y))) + (flet + ((not-more-contagious-1 (t1 t2) + (if (and (numeric-type-p t1) (numeric-type-p t2)) + (let ((class1 (numeric-type-class t1)) + (class2 (numeric-type-class t2)) + (format1 (numeric-type-format t1)) + (format2 (numeric-type-format t2)) + (complexp1 (numeric-type-complexp t1)) + (complexp2 (numeric-type-complexp t2))) + (cond ((or (null complexp1) (null class1)) Nil) + ((member class1 '(integer rational)) 'T) + ((and (eq class1 'float) (null complexp2)) Nil) + ((and (eq class1 'float) (null class2)) Nil) + ((and (eq class1 'float) (eq class2 'float)) + (and (ecase complexp2 + (:real (eq complexp1 :real)) + (:complex 'T)) + (ecase format2 + ((nil short-float single-float) + (member format1 '(short-float single-float))) + #-double-double + ((double-float long-float) 'T) + #+double-double + (double-float + (member format1 '(short-float single-float + double-float))) + #+long-float + (long-float 'T) + #+double-double + (double-double-float 't)))) + ((and (eq class1 'float) (member class2 '(integer rational))) + Nil) + (t + (error (intl:gettext "Unexpected types: ~s ~s~%") t1 t2)))))) + (maybe-convert-to-numeric (type) + (if (member-type-p type) + (convert-member-type type) + type))) + (dolist (x (prepare-arg-for-derive-type x-type)) + (dolist (y (prepare-arg-for-derive-type y-type)) + (unless (not-more-contagious-1 + (maybe-convert-to-numeric x) + (maybe-convert-to-numeric y)) + (return-from not-more-contagious nil)))) + t))) ;;; Fold (- x 0). ;;; ;;; If y is not constant, not zerop, or is contagious, or a negative -;;; float -0.0 then give up because (- -0.0 -0.0) is 0.0, not -0.0. +;;; float -0.0 then give up because (- -0.0 0.0) is 0.0, not -0.0. ;;; (deftransform - ((x y) (t (constant-argument number)) * :when :both) "fold zero arg" ----------------------------------------------------------------------- Summary of changes: src/compiler/srctran.lisp | 83 ++++++++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 35 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0