cmucl-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- 1 participants
- 3032 discussions

[git] CMU Common Lisp branch master updated. snapshot-2013-11-1-g373bc97
by rtoy@common-lisp.net 08 Apr '15
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 373bc974935a33ff1515d0d1cce2af8f7d910c04 (commit)
from e99b2b29bf65f7a2a678e9d7199085bf4aabd81a (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 373bc974935a33ff1515d0d1cce2af8f7d910c04
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Wed Nov 6 19:20:01 2013 -0800
Recognize -h and -? options to print out a usage message.
diff --git a/bin/create-target.sh b/bin/create-target.sh
index 21b38a6..84c00c8 100755
--- a/bin/create-target.sh
+++ b/bin/create-target.sh
@@ -18,6 +18,19 @@ usage() {
##--
prgm_name=`basename $0` bld_dir=$1 lisp_variant=$2 motif_variant=$3
+
+while getopts "h?" arg
+do
+ case $arg in
+ h) usage ;;
+ \?) usage ;;
+ esac
+done
+
+bld_dir=$1
+lisp_variant=$2
+motif_variant=$3
+
exec 2>&1
[ -n "$bld_dir" ] || usage
-----------------------------------------------------------------------
Summary of changes:
bin/create-target.sh | 13 +++++++++++++
1 file changed, 13 insertions(+)
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch master updated. begin-x87-removal-21-gecd7d26
by rtoy@common-lisp.net 08 Apr '15
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 ecd7d26d363b65a174ab04a1c2a802fe8ca96ddc (commit)
from 5abd66f6073fabd08af8e0155f74cd338a28d280 (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 ecd7d26d363b65a174ab04a1c2a802fe8ca96ddc
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Tue Apr 29 22:44:04 2014 -0700
Oops. Only compile float-sse2 on x86 machines!
diff --git a/src/tools/comcom.lisp b/src/tools/comcom.lisp
index b75a588..9ad7973 100644
--- a/src/tools/comcom.lisp
+++ b/src/tools/comcom.lisp
@@ -173,8 +173,9 @@
(when *load-stuff*
(load (vmdir "target:assembly/support")))
(comf (vmdir "target:compiler/move"))
-(comf (vmdir "target:compiler/float-sse2")
- :byte-compile *byte-compile*)
+(when (c:target-featurep :x86)
+ (comf (vmdir "target:compiler/float-sse2")
+ :byte-compile *byte-compile*))
(comf (vmdir "target:compiler/sap") :byte-compile *byte-compile*)
(when (c:target-featurep :x86)
(comf (vmdir "target:compiler/sse2-sap")
-----------------------------------------------------------------------
Summary of changes:
src/tools/comcom.lisp | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-42-g386d97b
by rtoy@common-lisp.net 08 Apr '15
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 386d97b2222de3cb7d175013d6509722c10b3846 (commit)
via 058a45ff915dbe4ed7f08a24226b074e00c63d14 (commit)
from e0b1f9f8b2142397cbf4ea76dd3ba862862baa49 (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 386d97b2222de3cb7d175013d6509722c10b3846
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Aug 1 19:44:29 2014 -0700
Import pow (ieee754_pow) from fdlibm, as is.
diff --git a/src/lisp/e_pow.c b/src/lisp/e_pow.c
new file mode 100644
index 0000000..5683bf5
--- /dev/null
+++ b/src/lisp/e_pow.c
@@ -0,0 +1,309 @@
+
+#ifndef lint
+static char sccsid[] = "@(#)e_pow.c 1.5 04/04/22 SMI";
+#endif
+
+/*
+ * ====================================================
+ * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved.
+ *
+ * Permission to use, copy, modify, and distribute this
+ * software is freely granted, provided that this notice
+ * is preserved.
+ * ====================================================
+ */
+
+/* __ieee754_pow(x,y) return x**y
+ *
+ * n
+ * Method: Let x = 2 * (1+f)
+ * 1. Compute and return log2(x) in two pieces:
+ * log2(x) = w1 + w2,
+ * where w1 has 53-24 = 29 bit trailing zeros.
+ * 2. Perform y*log2(x) = n+y' by simulating muti-precision
+ * arithmetic, where |y'|<=0.5.
+ * 3. Return x**y = 2**n*exp(y'*log2)
+ *
+ * Special cases:
+ * 1. (anything) ** 0 is 1
+ * 2. (anything) ** 1 is itself
+ * 3. (anything) ** NAN is NAN
+ * 4. NAN ** (anything except 0) is NAN
+ * 5. +-(|x| > 1) ** +INF is +INF
+ * 6. +-(|x| > 1) ** -INF is +0
+ * 7. +-(|x| < 1) ** +INF is +0
+ * 8. +-(|x| < 1) ** -INF is +INF
+ * 9. +-1 ** +-INF is NAN
+ * 10. +0 ** (+anything except 0, NAN) is +0
+ * 11. -0 ** (+anything except 0, NAN, odd integer) is +0
+ * 12. +0 ** (-anything except 0, NAN) is +INF
+ * 13. -0 ** (-anything except 0, NAN, odd integer) is +INF
+ * 14. -0 ** (odd integer) = -( +0 ** (odd integer) )
+ * 15. +INF ** (+anything except 0,NAN) is +INF
+ * 16. +INF ** (-anything except 0,NAN) is +0
+ * 17. -INF ** (anything) = -0 ** (-anything)
+ * 18. (-anything) ** (integer) is (-1)**(integer)*(+anything**integer)
+ * 19. (-anything except 0 and inf) ** (non-integer) is NAN
+ *
+ * Accuracy:
+ * pow(x,y) returns x**y nearly rounded. In particular
+ * pow(integer,integer)
+ * always returns the correct integer provided it is
+ * representable.
+ *
+ * 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
+#else
+static double
+#endif
+bp[] = {1.0, 1.5,},
+dp_h[] = { 0.0, 5.84962487220764160156e-01,}, /* 0x3FE2B803, 0x40000000 */
+dp_l[] = { 0.0, 1.35003920212974897128e-08,}, /* 0x3E4CFDEB, 0x43CFD006 */
+zero = 0.0,
+one = 1.0,
+two = 2.0,
+two53 = 9007199254740992.0, /* 0x43400000, 0x00000000 */
+huge = 1.0e300,
+tiny = 1.0e-300,
+ /* poly coefs for (3/2)*(log(x)-2s-2/3*s**3 */
+L1 = 5.99999999999994648725e-01, /* 0x3FE33333, 0x33333303 */
+L2 = 4.28571428578550184252e-01, /* 0x3FDB6DB6, 0xDB6FABFF */
+L3 = 3.33333329818377432918e-01, /* 0x3FD55555, 0x518F264D */
+L4 = 2.72728123808534006489e-01, /* 0x3FD17460, 0xA91D4101 */
+L5 = 2.30660745775561754067e-01, /* 0x3FCD864A, 0x93C9DB65 */
+L6 = 2.06975017800338417784e-01, /* 0x3FCA7E28, 0x4A454EEF */
+P1 = 1.66666666666666019037e-01, /* 0x3FC55555, 0x5555553E */
+P2 = -2.77777777770155933842e-03, /* 0xBF66C16C, 0x16BEBD93 */
+P3 = 6.61375632143793436117e-05, /* 0x3F11566A, 0xAF25DE2C */
+P4 = -1.65339022054652515390e-06, /* 0xBEBBBD41, 0xC5D26BF1 */
+P5 = 4.13813679705723846039e-08, /* 0x3E663769, 0x72BEA4D0 */
+lg2 = 6.93147180559945286227e-01, /* 0x3FE62E42, 0xFEFA39EF */
+lg2_h = 6.93147182464599609375e-01, /* 0x3FE62E43, 0x00000000 */
+lg2_l = -1.90465429995776804525e-09, /* 0xBE205C61, 0x0CA86C39 */
+ovt = 8.0085662595372944372e-0017, /* -(1024-log2(ovfl+.5ulp)) */
+cp = 9.61796693925975554329e-01, /* 0x3FEEC709, 0xDC3A03FD =2/(3ln2) */
+cp_h = 9.61796700954437255859e-01, /* 0x3FEEC709, 0xE0000000 =(float)cp */
+cp_l = -7.02846165095275826516e-09, /* 0xBE3E2FE0, 0x145B01F5 =tail of cp_h*/
+ivln2 = 1.44269504088896338700e+00, /* 0x3FF71547, 0x652B82FE =1/ln2 */
+ivln2_h = 1.44269502162933349609e+00, /* 0x3FF71547, 0x60000000 =24b 1/ln2*/
+ivln2_l = 1.92596299112661746887e-08; /* 0x3E54AE0B, 0xF85DDF44 =1/ln2 tail*/
+
+#ifdef __STDC__
+ double __ieee754_pow(double x, double y)
+#else
+ double __ieee754_pow(x,y)
+ double x, y;
+#endif
+{
+ double z,ax,z_h,z_l,p_h,p_l;
+ double y1,t1,t2,r,s,t,u,v,w;
+ int i0,i1,i,j,k,yisint,n;
+ int hx,hy,ix,iy;
+ unsigned lx,ly;
+
+ i0 = ((*(int*)&one)>>29)^1; i1=1-i0;
+ hx = __HI(x); lx = __LO(x);
+ hy = __HI(y); ly = __LO(y);
+ ix = hx&0x7fffffff; iy = hy&0x7fffffff;
+
+ /* y==zero: x**0 = 1 */
+ if((iy|ly)==0) return one;
+
+ /* +-NaN return x+y */
+ if(ix > 0x7ff00000 || ((ix==0x7ff00000)&&(lx!=0)) ||
+ iy > 0x7ff00000 || ((iy==0x7ff00000)&&(ly!=0)))
+ return x+y;
+
+ /* determine if y is an odd int when x < 0
+ * yisint = 0 ... y is not an integer
+ * yisint = 1 ... y is an odd int
+ * yisint = 2 ... y is an even int
+ */
+ yisint = 0;
+ if(hx<0) {
+ if(iy>=0x43400000) yisint = 2; /* even integer y */
+ else if(iy>=0x3ff00000) {
+ k = (iy>>20)-0x3ff; /* exponent */
+ if(k>20) {
+ j = ly>>(52-k);
+ if((j<<(52-k))==ly) yisint = 2-(j&1);
+ } else if(ly==0) {
+ j = iy>>(20-k);
+ if((j<<(20-k))==iy) yisint = 2-(j&1);
+ }
+ }
+ }
+
+ /* special value of y */
+ if(ly==0) {
+ if (iy==0x7ff00000) { /* y is +-inf */
+ if(((ix-0x3ff00000)|lx)==0)
+ return y - y; /* inf**+-1 is NaN */
+ else if (ix >= 0x3ff00000)/* (|x|>1)**+-inf = inf,0 */
+ return (hy>=0)? y: zero;
+ else /* (|x|<1)**-,+inf = inf,0 */
+ return (hy<0)?-y: zero;
+ }
+ if(iy==0x3ff00000) { /* y is +-1 */
+ if(hy<0) return one/x; else return x;
+ }
+ if(hy==0x40000000) return x*x; /* y is 2 */
+ if(hy==0x3fe00000) { /* y is 0.5 */
+ if(hx>=0) /* x >= +0 */
+ return sqrt(x);
+ }
+ }
+
+ ax = fabs(x);
+ /* special value of x */
+ if(lx==0) {
+ if(ix==0x7ff00000||ix==0||ix==0x3ff00000){
+ z = ax; /*x is +-0,+-inf,+-1*/
+ if(hy<0) z = one/z; /* z = (1/|x|) */
+ if(hx<0) {
+ if(((ix-0x3ff00000)|yisint)==0) {
+ z = (z-z)/(z-z); /* (-1)**non-int is NaN */
+ } else if(yisint==1)
+ z = -z; /* (x<0)**odd = -(|x|**odd) */
+ }
+ return z;
+ }
+ }
+
+ n = (hx>>31)+1;
+
+ /* (x<0)**(non-int) is NaN */
+ if((n|yisint)==0) return (x-x)/(x-x);
+
+ s = one; /* s (sign of result -ve**odd) = -1 else = 1 */
+ if((n|(yisint-1))==0) s = -one;/* (-ve)**(odd int) */
+
+ /* |y| is huge */
+ if(iy>0x41e00000) { /* if |y| > 2**31 */
+ if(iy>0x43f00000){ /* if |y| > 2**64, must o/uflow */
+ if(ix<=0x3fefffff) return (hy<0)? huge*huge:tiny*tiny;
+ if(ix>=0x3ff00000) return (hy>0)? huge*huge:tiny*tiny;
+ }
+ /* over/underflow if x is not close to one */
+ if(ix<0x3fefffff) return (hy<0)? s*huge*huge:s*tiny*tiny;
+ if(ix>0x3ff00000) return (hy>0)? s*huge*huge:s*tiny*tiny;
+ /* now |1-x| is tiny <= 2**-20, suffice to compute
+ log(x) by x-x^2/2+x^3/3-x^4/4 */
+ t = ax-one; /* t has 20 trailing zeros */
+ w = (t*t)*(0.5-t*(0.3333333333333333333333-t*0.25));
+ u = ivln2_h*t; /* ivln2_h has 21 sig. bits */
+ v = t*ivln2_l-w*ivln2;
+ t1 = u+v;
+ __LO(t1) = 0;
+ t2 = v-(t1-u);
+ } else {
+ double ss,s2,s_h,s_l,t_h,t_l;
+ n = 0;
+ /* take care subnormal number */
+ if(ix<0x00100000)
+ {ax *= two53; n -= 53; ix = __HI(ax); }
+ n += ((ix)>>20)-0x3ff;
+ j = ix&0x000fffff;
+ /* determine interval */
+ ix = j|0x3ff00000; /* normalize ix */
+ if(j<=0x3988E) k=0; /* |x|<sqrt(3/2) */
+ else if(j<0xBB67A) k=1; /* |x|<sqrt(3) */
+ else {k=0;n+=1;ix -= 0x00100000;}
+ __HI(ax) = ix;
+
+ /* compute ss = s_h+s_l = (x-1)/(x+1) or (x-1.5)/(x+1.5) */
+ u = ax-bp[k]; /* bp[0]=1.0, bp[1]=1.5 */
+ v = one/(ax+bp[k]);
+ ss = u*v;
+ s_h = ss;
+ __LO(s_h) = 0;
+ /* t_h=ax+bp[k] High */
+ t_h = zero;
+ __HI(t_h)=((ix>>1)|0x20000000)+0x00080000+(k<<18);
+ t_l = ax - (t_h-bp[k]);
+ s_l = v*((u-s_h*t_h)-s_h*t_l);
+ /* compute log(ax) */
+ s2 = ss*ss;
+ r = s2*s2*(L1+s2*(L2+s2*(L3+s2*(L4+s2*(L5+s2*L6)))));
+ r += s_l*(s_h+ss);
+ s2 = s_h*s_h;
+ t_h = 3.0+s2+r;
+ __LO(t_h) = 0;
+ t_l = r-((t_h-3.0)-s2);
+ /* u+v = ss*(1+...) */
+ u = s_h*t_h;
+ v = s_l*t_h+t_l*ss;
+ /* 2/(3log2)*(ss+...) */
+ p_h = u+v;
+ __LO(p_h) = 0;
+ p_l = v-(p_h-u);
+ z_h = cp_h*p_h; /* cp_h+cp_l = 2/(3*log2) */
+ z_l = cp_l*p_h+p_l*cp+dp_l[k];
+ /* log2(ax) = (ss+..)*2/(3*log2) = n + dp_h + z_h + z_l */
+ t = (double)n;
+ t1 = (((z_h+z_l)+dp_h[k])+t);
+ __LO(t1) = 0;
+ t2 = z_l-(((t1-t)-dp_h[k])-z_h);
+ }
+
+ /* split up y into y1+y2 and compute (y1+y2)*(t1+t2) */
+ y1 = y;
+ __LO(y1) = 0;
+ p_l = (y-y1)*t1+y*t2;
+ p_h = y1*t1;
+ z = p_l+p_h;
+ j = __HI(z);
+ i = __LO(z);
+ if (j>=0x40900000) { /* z >= 1024 */
+ if(((j-0x40900000)|i)!=0) /* if z > 1024 */
+ return s*huge*huge; /* overflow */
+ else {
+ if(p_l+ovt>z-p_h) return s*huge*huge; /* overflow */
+ }
+ } else if((j&0x7fffffff)>=0x4090cc00 ) { /* z <= -1075 */
+ if(((j-0xc090cc00)|i)!=0) /* z < -1075 */
+ return s*tiny*tiny; /* underflow */
+ else {
+ if(p_l<=z-p_h) return s*tiny*tiny; /* underflow */
+ }
+ }
+ /*
+ * compute 2**(p_h+p_l)
+ */
+ i = j&0x7fffffff;
+ k = (i>>20)-0x3ff;
+ n = 0;
+ if(i>0x3fe00000) { /* if |z| > 0.5, set n = [z+0.5] */
+ n = j+(0x00100000>>(k+1));
+ k = ((n&0x7fffffff)>>20)-0x3ff; /* new k for n */
+ t = zero;
+ __HI(t) = (n&~(0x000fffff>>k));
+ n = ((n&0x000fffff)|0x00100000)>>(20-k);
+ if(j<0) n = -n;
+ p_h -= t;
+ }
+ t = p_l+p_h;
+ __LO(t) = 0;
+ u = t*lg2_h;
+ v = (p_l-(t-p_h))*lg2+t*lg2_l;
+ z = u+v;
+ w = v-(z-u);
+ t = z*z;
+ t1 = z - t*(P1+t*(P2+t*(P3+t*(P4+t*P5))));
+ r = (z*t1)/(t1-two)-(w+z*w);
+ z = one-(r-z);
+ j = __HI(z);
+ j += (n<<20);
+ if((j>>20)<=0) z = scalbn(z,n); /* subnormal output */
+ else __HI(z) += (n<<20);
+ return s*z;
+}
commit 058a45ff915dbe4ed7f08a24226b074e00c63d14
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Aug 1 19:41:02 2014 -0700
Use fdlibm versions of log1p and expm1.
diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index 2a88c9f..1a942fe 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -88,8 +88,8 @@
(def-math-rtn "sqrt" 1)
(def-math-rtn "hypot" 2)
-(def-math-rtn "log1p" 1)
-(def-math-rtn "expm1" 1)
+(def-math-rtn ("fdlibm_log1p" %log1p) 1)
+(def-math-rtn ("fdlibm_expm1" %expm1) 1)
;; These are needed for use by byte-compiled files. But don't use
;; these with sse2 since we don't support using the x87 instructions
-----------------------------------------------------------------------
Summary of changes:
src/code/irrat.lisp | 4 +-
src/lisp/e_pow.c | 309 +++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 311 insertions(+), 2 deletions(-)
create mode 100644 src/lisp/e_pow.c
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch rtoy-simp-dd-trig created. snapshot-2013-12-a-25-g712df0b
by rtoy@common-lisp.net 08 Apr '15
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, rtoy-simp-dd-trig has been created
at 712df0bc4e655226bc5c9ed91aa9c875b4a5eb0d (commit)
- Log -----------------------------------------------------------------
commit 712df0bc4e655226bc5c9ed91aa9c875b4a5eb0d
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Dec 20 16:47:21 2013 -0800
Add tests for dd-%sincos.
diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp
index 911b623..b46c904 100644
--- a/src/tests/trig.lisp
+++ b/src/tests/trig.lisp
@@ -388,3 +388,46 @@
-4.080663888418042385451434945255951177650840227682488471558860153w-1
1.888w-33)))
+(define-test dd-sincos.signed-zeroes
+ "Test sincos at 0d0, -0d0"
+ (:tag :sincos :signed-zeroes :double-double)
+ (assert-equal '(0w0 1w0)
+ (multiple-value-list (kernel::dd-%sincos 0w0)))
+ (assert-equal '(-0w0 1w0)
+ (multiple-value-list (kernel::dd-%sincos -0w0))))
+
+;; Test sincos at a bunch of random points and compare the result from
+;; sin and cos. If they differ, save the result in a list to be
+;; returned.
+(defun dd-sincos-test (limit n)
+ (let (results)
+ (dotimes (k n)
+ (let* ((x (random limit))
+ (s-exp (sin x))
+ (c-exp (cos x)))
+ (multiple-value-bind (s c)
+ (kernel::dd-%sincos x)
+ (unless (and (eql s s-exp)
+ (eql c c-exp))
+ (push (list x
+ (list s s-exp)
+ (list c c-exp))
+ results)))))
+ results))
+
+(define-test dd-sincos.consistent
+ "Test sincos is consistent with sin and cos"
+ (:tag :sincos :double-double)
+ ;; Small values
+ (assert-eql nil
+ (dd-sincos-test (/ kernel:dd-pi 4) 1000))
+ ;; Medium
+ (assert-eql nil
+ (dd-sincos-test 16w0 1000))
+ ;; Large
+ (assert-eql nil
+ (dd-sincos-test (scale-float 1w0 120) 1000))
+ ;; Very large
+ (assert-eql nil
+ (dd-sincos-test (scale-float 1w0 1023) 1000)))
+
commit bf84dbc8c5bd5478fd36b55f99e119cfff11ca6d
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Dec 20 16:47:07 2013 -0800
Add dd-%sincos and use it as needed instead of calling sin and cos
separately.
diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp
index 6661f2b..381d678 100644
--- a/src/code/irrat-dd.lisp
+++ b/src/code/irrat-dd.lisp
@@ -1191,6 +1191,29 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
(dd-%%tan reduced)
(- (/ (dd-%%tan reduced))))))))
+(defun dd-%sincos (x)
+ (declare (double-double-float x))
+ (cond ((< (abs x) (/ pi 4))
+ (values (dd-%%sin x)
+ (dd-%%cos x)))
+ (t
+ ;; Argument reduction needed
+ (multiple-value-bind (n reduced)
+ (reduce-arg x)
+ (case (logand n 3)
+ (0
+ (values (dd-%%sin reduced)
+ (dd-%%cos reduced)))
+ (1
+ (values (dd-%%cos reduced)
+ (- (dd-%%sin reduced))))
+ (2
+ (values (- (dd-%%sin reduced))
+ (- (dd-%%cos reduced))))
+ (3
+ (values (- (dd-%%cos reduced))
+ (dd-%%sin reduced))))))))
+
;;; dd-%log2
;;; Base 2 logarithm.
diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index 4ccf80a..078e56f 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -1298,7 +1298,9 @@
(coerce s '(dispatch-type theta)))))
#+double-double
((double-double-float)
- (complex (cos theta) (sin theta))))))
+ (multiple-value-bind (s c)
+ (dd-%sincos theta)
+ (complex c s))))))
(defun asin (number)
"Return the arc sine of NUMBER."
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index d123d18..34acdeb 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -748,8 +748,9 @@
#+double-double
(deftransform cis ((z) (double-double-float) *)
- ;; Cis.
- '(complex (cos z) (sin z)))
+ `(multiple-value-bind (s c)
+ (kernel::dd-%sincos x)
+ (complex c s)))
;;; The argument range is limited on the x86 FP trig. functions. A
commit 2e3e48d466c67a09ea7aeb23106fdc50143be3b5
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Dec 20 16:07:12 2013 -0800
Add tests for double-double trig functions.
diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp
index 58d10b6..911b623 100644
--- a/src/tests/trig.lisp
+++ b/src/tests/trig.lisp
@@ -215,3 +215,176 @@
(assert-eql nil
(sincos-test (scale-float 1d0 1023) 1000)))
+;; Compute the relative error between actual and expected if expected
+;; is not zero. Otherwise, return absolute error between actual and
+;; expected. If the error is less than the threshold, return T.
+;; Otherwise return the actual (relative or absolute) error.
+(defun rel-or-abs-error (actual expected &optional (threshold double-float-epsilon))
+ (let ((err (if (zerop expected)
+ (abs (- actual expected))
+ (/ (abs (- actual expected))
+ (abs expected)))))
+ (if (<= err threshold)
+ t
+ err)))
+
+(define-test dd-sin.signed-zeroes
+ "Test sin for 0w0 and -0w0"
+ (:tag :sin :double-double :signed-zeroes)
+ (assert-eql 0w0 (sin 0w0))
+ (assert-equal -0w0 (sin -0w0)))
+
+(define-test dd-sin.no-reduction
+ "Test sin for small args without reduction"
+ (:tag :sin :double-double)
+ (assert-eq t (rel-or-abs-error
+ (sin .5w0)
+ 4.794255386042030002732879352155713880818033679406006751886166131w-1
+ 1w-32))
+ (assert-eq t (rel-or-abs-error
+ (sin -0.5w0)
+ -4.794255386042030002732879352155713880818033679406006751886166131w-1
+ 1w-32)))
+
+(define-test dd-sin.pi/2
+ "Test for arg near pi/2"
+ (:tag :sin :double-double)
+ (assert-eq t (rel-or-abs-error
+ (sin (/ kernel:dd-pi 2))
+ 1w0
+ 1w-50)))
+
+;; The reference value were computed using maxima. Here's how to
+;; compute the reference value. Set fpprec:64 to tell maxima to use
+;; 64 digits of precision. For 7/4*pi, do (integer-decode-float (* 7/4
+;; kernel:dd-pi)) to get the exact rational representation of the
+;; desired double-double-float. Then bfloat(sin(<rational>)).
+(define-test dd-sin.arg-reduction
+ "Test for sin with arg reduction"
+ (:tag :sin :double-double)
+ ;; Test for argument reduction with n mod 4 = 0
+ (assert-eq t (rel-or-abs-error
+ (sin (* 7/4 kernel:dd-pi))
+ -7.07106781186547524400844362104849691328261037289050238659653433w-1
+ 0w0))
+ ;; Test for argument reduction with n mod 4 = 1
+ (assert-eq t (rel-or-abs-error
+ (sin (* 9/4 kernel:dd-pi))
+ 7.07106781186547524400844362104858161816423215627023442400880643w-1
+ 0w0))
+ ;; Test for argument reduction with n mod 4 = 2
+ (assert-eq t (rel-or-abs-error
+ (sin (* 11/4 kernel:dd-pi))
+ 7.071067811865475244008443621048998682901731241858306822215522497w-1
+ 8.716w-33))
+ ;; Test for argument reduction with n mod 4 = 3
+ (assert-eq t (rel-or-abs-error
+ (sin (* 13/4 kernel:dd-pi))
+ -7.071067811865475244008443621048777109664479707052746581685893187w-1
+ 8.716w-33))
+ ;; Test for argument reduction, big value
+ (assert-eq t (rel-or-abs-error
+ (sin (scale-float 1w0 120))
+ 3.778201093607520226555484700569229919605866976512306642257987199w-1
+ 8.156w-33)))
+
+(define-test dd-cos.signed-zeroes
+ "Test cos for 0w0 and -0w0"
+ (:tag :cos :double-double :signed-zeroes)
+ (assert-eql 1w0 (cos 0w0))
+ (assert-equal 1w0 (cos -0w0)))
+
+(define-test dd-cos.no-reduction
+ "Test cos for small args without reduction"
+ (:tag :cos :double-double)
+ (assert-eq t (rel-or-abs-error
+ (cos .5w0)
+ 8.775825618903727161162815826038296519916451971097440529976108683w-1
+ 0w0))
+ (assert-eq t (rel-or-abs-error
+ (cos -0.5w0)
+ 8.775825618903727161162815826038296519916451971097440529976108683w-1
+ 0w0)))
+
+(define-test dd-cos.pi/2
+ "Test for arg near pi/2"
+ (:tag :cos :double-double)
+ (assert-eq t (rel-or-abs-error
+ (cos (/ kernel:dd-pi 2))
+ -1.497384904859169777320797133937725094986669701841027904483071358w-33
+ 0w0)))
+
+(define-test dd-cos.arg-reduction
+ "Test for cos with arg reduction"
+ (:tag :cos :double-double)
+ ;; Test for argument reduction with n mod 4 = 0
+ (assert-eq t (rel-or-abs-error
+ (cos (* 7/4 kernel:dd-pi))
+ 7.07106781186547524400844362104849691328261037289050238659653433w-1
+ 0w0))
+ ;; Test for argument reduction with n mod 4 = 1
+ (assert-eq t (rel-or-abs-error
+ (cos (* 9/4 kernel:dd-pi))
+ 7.07106781186547524400844362104858161816423215627023442400880643w-1
+ 3.487w-32))
+ ;; Test for argument reduction with n mod 4 = 2
+ (assert-eq t (rel-or-abs-error
+ (cos (* 11/4 kernel:dd-pi))
+ -7.071067811865475244008443621048998682901731241858306822215522497w-1
+ 1.482w-31))
+ ;; Test for argument reduction with n mod 4 = 3
+ (assert-eq t (rel-or-abs-error
+ (cos (* 13/4 kernel:dd-pi))
+ -7.071067811865475244008443621048777109664479707052746581685893187w-1
+ 7.845w-32))
+ ;; Test for argument reduction, big value
+ (assert-eq t (rel-or-abs-error
+ (cos (scale-float 1w0 120))
+ -9.258790228548378673038617641074149467308332099286564602360493726w-1
+ 0w0)))
+
+(define-test dd-tan.signed-zeroes
+ "Test tan for 0w0 and -0w0"
+ (:tag :tan :double-double :signed-zeroes)
+ (assert-eql 0w0 (tan 0w0))
+ (assert-equal -0w0 (tan -0w0)))
+
+(define-test dd-tan.no-reduction
+ "Test tan for small args without reduction"
+ (:tag :tan :double-double)
+ (assert-eq t (rel-or-abs-error
+ (tan .5w0)
+ 5.463024898437905132551794657802853832975517201797912461640913859w-1
+ 0w0))
+ (assert-eq t (rel-or-abs-error
+ (tan -0.5w0)
+ -5.463024898437905132551794657802853832975517201797912461640913859w-1
+ 0w0)))
+
+(define-test dd-tan.pi/2
+ "Test for arg near pi/2"
+ (:tag :tan :double-double)
+ (assert-eq t (rel-or-abs-error
+ (tan (/ kernel:dd-pi 2))
+ -6.67830961000672557834948096545679895621313886078988606234681001w32
+ 0w0)))
+
+(define-test dd-tan.arg-reduction
+ "Test for tan with arg reduction"
+ (:tag :tan :double-double)
+ ;; Test for argument reduction with n even
+ (assert-eq t (rel-or-abs-error
+ (tan (* 7/4 kernel:dd-pi))
+ -1.000000000000000000000000000000001844257310064121018312678894979w0
+ 6.467w-33))
+ ;; Test for argument reduction with n odd
+ (assert-eq t (rel-or-abs-error
+ (tan (* 9/4 kernel:dd-pi))
+ 1.000000000000000000000000000000025802415787810837455445433037983w0
+ 5.773w-33))
+ ;; Test for argument reduction, big value
+ (assert-eq t (rel-or-abs-error
+ (tan (scale-float 1w0 120))
+ -4.080663888418042385451434945255951177650840227682488471558860153w-1
+ 1.888w-33)))
+
commit 949acab5719c22e51a45a936271b46b04edaa8ac
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Dec 20 16:06:40 2013 -0800
For dd-%%sin, return x if x is small enough. (Makes sin(-0w0) be
-0w0).
diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp
index 170bc06..6661f2b 100644
--- a/src/code/irrat-dd.lisp
+++ b/src/code/irrat-dd.lisp
@@ -1000,8 +1000,11 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
(declare (type (double-double-float -1w0 1w0) x)
(optimize (speed 2) (space 0)
(inhibit-warnings 3)))
- (let ((x2 (* x x)))
- (+ x (* x (* x2 (poly-eval x2 sincof))))))
+ (if (< (abs (double-double-hi x))
+ (scale-float 1d0 -52))
+ x
+ (let ((x2 (* x x)))
+ (+ x (* x (* x2 (poly-eval x2 sincof)))))))
;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2))
;; Theoretical peak relative error = 2.1e-37,
commit 6f25e2e894bdf13c00a29651031ad0bbedb50f0e
Merge: 408aa78 82d0a77
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Dec 20 12:39:48 2013 -0800
Merge branch 'master' into rtoy-simp-dd-trig
commit 408aa78aa3947f2c8f8a5b2a03429d5c05e93fbe
Merge: 00bd409 01a3f47
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Fri Dec 20 07:44:09 2013 -0800
Merge branch 'master' into rtoy-simp-dd-trig
commit 00bd409b8d9de4f5f6223bf4d017e6f1c0826e48
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Thu Dec 12 18:48:41 2013 -0800
Simplify dd-%%sin, dd-%%cos, and dd-%%tan.
These routines did argument reduction, but since we use
__kernel_rem_pio2 to do accurate argument reduction, the argument
reduction in these routines is a waste of time. This greatly
simplifies the routines to just the polynomial (or rational)
approximations.
diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp
index 4c57165..170bc06 100644
--- a/src/code/irrat-dd.lisp
+++ b/src/code/irrat-dd.lisp
@@ -995,6 +995,14 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
-1.666666666666666666666666666666666647199w-1
)))
+;; Compute sin(x) for |x| < pi/4 (approx).
+(defun dd-%%sin (x)
+ (declare (type (double-double-float -1w0 1w0) x)
+ (optimize (speed 2) (space 0)
+ (inhibit-warnings 3)))
+ (let ((x2 (* x x)))
+ (+ x (* x (* x2 (poly-eval x2 sincof))))))
+
;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2))
;; Theoretical peak relative error = 2.1e-37,
;; relative peak error spread = 1.4e-8
@@ -1016,101 +1024,17 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
4.166666666666666666666666666666459301466w-2
)))
-(defconstant dp1
- (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106))
-
-(defconstant dp2
- (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106)))
-
-(defconstant dp3
- (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106)))
-
-(defconstant dp4
- (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106)))
-
-(defun dd-%%sin (x)
- (declare (type double-double-float x)
- (optimize (speed 2) (space 0)
- (inhibit-warnings 3)))
- (when (minusp x)
- (return-from dd-%%sin (- (the double-double-float (dd-%%sin (- x))))))
- ;; y = integer part of x/(pi/4).
- (let* ((y (float (floor (/ x dd-pi/4)) 1w0))
- (z (scale-float y -4)))
- (declare (type double-double-float y z))
- (setf z (float (floor z) 1w0)) ; integer part of y/8
- (setf z (- y (scale-float z 4))) ; y - 16*(y/16)
-
- (let ((j (truncate z))
- (sign 1))
- (declare (type (integer -1 1) sign))
- (unless (zerop (logand j 1))
- (incf j)
- (incf y))
- (setf j (logand j 7))
-
- (when (> j 3)
- (setf sign (- sign))
- (decf j 4))
-
- ;; Extended precision modular arithmetic
- (setf z (- (- (- x (* y dp1))
- (* y dp2))
- (* y dp3)))
- (let ((zz (* z z)))
- (if (or (= j 1)
- (= j 2))
- (setf y (+ (- 1 (scale-float zz -1))
- (* zz zz (poly-eval zz coscof))))
- (setf y (+ z (* z (* zz (poly-eval zz sincof))))))
- (if (< sign 0)
- (- y)
- y)))))
-
+;; Compue cos(x) for |x| < pi/4 (approx)
(defun dd-%%cos (x)
- (declare (type double-double-float x)
+ (declare (type (double-double-float -1w0 1w0) x)
(optimize (speed 2) (space 0)
(inhibit-warnings 3)))
- (when (minusp x)
- (return-from dd-%%cos (dd-%%cos (- x))))
- ;; y = integer part of x/(pi/4).
- (let* ((y (float (floor (/ x dd-pi/4)) 1w0))
- (z (scale-float y -4)))
- (declare (type double-double-float y z))
- (setf z (float (floor z) 1w0)) ; integer part of y/8
- (setf z (- y (scale-float z 4))) ; y - 16*(y/16)
-
- (let ((i (truncate z))
- (j 0)
- (sign 1))
- (declare (type (integer 0 7) j)
- (type (integer -1 1) sign))
- (unless (zerop (logand i 1))
- (incf i)
- (incf y))
- (setf j (logand i 7))
-
- (when (> j 3)
- (setf sign (- sign))
- (decf j 4))
- (when (> j 1)
- (setf sign (- sign)))
-
- ;; Extended precision modular arithmetic. This is basically
- ;; computing x - y*(pi/4) accurately so that |z| < pi/4.
- (setf z (- (- (- x (* y dp1))
- (* y dp2))
- (* y dp3)))
- (let ((zz (* z z)))
- (if (or (= j 1)
- (= j 2))
- (setf y (+ z (* z (* zz (poly-eval zz sincof)))))
- (setf y (+ (- 1 (scale-float zz -1))
- (* zz (poly-eval zz coscof) zz))))
- (if (< sign 0)
- (- y)
- y)))))
+ (let ((x2 (* x x)))
+ (+ (- 1 (scale-float x2 -1))
+ (* x2 (poly-eval x2 coscof) x2))))
+;; Compute tan(x) or cot(x) for |x| < pi/4 (approx). If cotflag is
+;; non-nil, cot(x) is returned. Otherwise, return tan(x).
(let ((P (make-array 6 :element-type 'double-double-float
:initial-contents
'(
@@ -1132,50 +1056,18 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
-4.152206921457208101480801635640958361612w10
8.650244186622719093893836740197250197602w10
))))
- (defun dd-tancot (xx cotflag)
- (declare (type double-double-float xx)
- (optimize (speed 2) (space 0)))
- (let ((x 0w0)
- (sign 1))
- (declare (type double-double-float x)
- (type (integer -1 1) sign))
- (cond ((minusp xx)
- (setf x (- xx))
- (setf sign -1))
- (t
- (setf x xx)))
- (let* ((y (float (floor (/ x dd-pi/4)) 1w0))
- (z (scale-float y -4))
- (j 0))
- (declare (type double-double-float y z)
- (type fixnum j))
- (setf z (float (floor z) 1w0))
- (setf z (- y (scale-float z 4)))
-
- (setf j (truncate z))
-
- (unless (zerop (logand j 1))
- (incf j)
- (incf y))
-
- (setf z (- (- (- x (* y dp1))
- (* y dp2))
- (* y dp3)))
- (let ((zz (* z z)))
- (if (> zz 1w-40)
- (setf y (+ z
- (* z (* zz (/ (poly-eval zz p)
- (poly-eval-1 zz q))))))
- (setf y z))
- (if (not (zerop (logand j 2)))
- (if cotflag
- (setf y (- y))
- (setf y (/ -1 y)))
- (if cotflag
- (setf y (/ y))))
- (if (< sign 0)
- (- y)
- y))))))
+ (defun dd-tancot (x cotflag)
+ (declare (type (double-double-float -1w0 1w0) x)
+ (optimize (speed 2) (space 0) (inhibit-warnings 3)))
+ (let* ((xx (* x x))
+ (y (if (> xx 1w-40)
+ (+ x
+ (* x (* xx (/ (poly-eval xx p)
+ (poly-eval-1 xx q)))))
+ x)))
+ (if cotflag
+ (/ y)
+ y))))
(defun dd-%%tan (x)
(declare (type double-double-float x))
@@ -1254,9 +1146,7 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
dd-%sin))
(defun dd-%sin (x)
(declare (double-double-float x))
- (cond ((minusp (float-sign x))
- (- (dd-%sin (- x))))
- ((< (abs x) (/ pi 4))
+ (cond ((< (abs x) (/ pi 4))
(dd-%%sin x))
(t
;; Argument reduction needed
@@ -1272,9 +1162,7 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
dd-%cos))
(defun dd-%cos (x)
(declare (double-double-float x))
- (cond ((minusp x)
- (dd-%cos (- x)))
- ((< (abs x) (/ pi 4))
+ (cond ((< (abs x) (/ pi 4))
(dd-%%cos x))
(t
;; Argument reduction needed
@@ -1290,9 +1178,7 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010
dd-%tan))
(defun dd-%tan (x)
(declare (double-double-float x))
- (cond ((minusp (float-sign x))
- (- (dd-%tan (- x))))
- ((< (abs x) (/ pi 4))
+ (cond ((< (abs x) (/ pi 4))
(dd-%%tan x))
(t
;; Argument reduction needed
-----------------------------------------------------------------------
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-11-gd669c12
by rtoy@common-lisp.net 08 Apr '15
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 d669c129619ad3952fcabb263e307e3d48b12969 (commit)
from 06300c812a5dfeecc9afd43d45608356f7c80dd6 (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 d669c129619ad3952fcabb263e307e3d48b12969
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Sun Dec 8 09:26:24 2013 -0800
Update for ppc/darwin 10.5 and gcc 4.8.
o Remove -no-cpp-precomp, which isn't recognized by gcc 4.8.
o Add -static-libgcc so lisp doesn't need to have a compatible version
of libgcc on the target system.
o e_rem_pio2.c doesn't have aliasing issues, so remove the compiler
flags.
diff --git a/src/lisp/Config.ppc_darwin b/src/lisp/Config.ppc_darwin
index e999827..0902b89 100644
--- a/src/lisp/Config.ppc_darwin
+++ b/src/lisp/Config.ppc_darwin
@@ -11,12 +11,12 @@ CPPFLAGS = -I. -I$(PATH1)
# think gcc 4 is wrong. However, to work around this, we use /**/ to
# concatenate tokens which reguires the -traditional flag.
-# Build for OSX 10.2.8 or later. (Is this what we want?)
+# Build for OSX 10.4 or later. (Is this what we want?)
OSX_VERSION=-mmacosx-version-min=10.4
CC = gcc
LD = ld
NM = $(PATH1)/darwin-nm
-CPP = cpp -no-cpp-precomp
+CPP = cpp
DEPEND_FLAGS = -MM
ifdef FEATURE_LINKAGE_TABLE
@@ -34,8 +34,8 @@ ifdef FEATURE_UNICODE
UNICODE = -DUNICODE
endif
-CFLAGS = $(OSX_VERSION) -g -O3 -no-cpp-precomp -DDARWIN -Dppc $(LINKAGE) $(GENCGC) $(UNICODE)
-ASFLAGS = $(OSX_VERSION) -traditional -g -O3 -no-cpp-precomp -DDARWIN -Dppc $(LINKAGE) $(GENCGC)
+CFLAGS = $(OSX_VERSION) -g -O3 -DDARWIN -Dppc $(LINKAGE) $(GENCGC) $(UNICODE)
+ASFLAGS = $(OSX_VERSION) -traditional -g -O3 -DDARWIN -Dppc $(LINKAGE) $(GENCGC)
UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
ASSEM_SRC = ppc-assem.S linux-stubs.S
@@ -52,10 +52,15 @@ endif
# that the segaddr for CMUCLRO should be the READ_ONLY_SPACE_START.
# The seg1addr should be somewhere above our spaces. This is where
# the C runtime code goes, I think.
-
+#
# OS_LINK_FLAGS = -g -dynamic -Wl,-sectcreate,CMUCLRO,core,/dev/null -Wl,-segaddr,CMUCLRO,0x01000000 -Wl,-seg1addr,0x1a000000
-OS_LINK_FLAGS = $(OSX_VERSION)
+
+# gcc 4.8, (used on zombie) needs -static-libgcc so that the gcc
+# library is staticly linked into lisp so that the user doesn't need a
+# matching version of libgcc.
+OS_LINK_FLAGS = $(OSX_VERSION) -static-libgcc
OS_LIBS = -lSystem -lc -lm
+
#all: adjustlisp
#adjustlisp: lisp darwin-lispadjuster
# ./darwin-lispadjuster lisp
@@ -64,6 +69,7 @@ OS_LIBS = -lSystem -lc -lm
#darwin-lispadjuster: darwin-lispadjuster.c
-# This has aliasing problems, so turn off aliasing.
+# According to Config.x86_common, this no longer has aliasing
+# problems, so we don't need any additional compilation options.
e_rem_pio2.o : e_rem_pio2.c
- $(CC) -c -fno-strict-aliasing -ffloat-store $(CFLAGS) $<
+ $(CC) -c $(CFLAGS) $<
-----------------------------------------------------------------------
Summary of changes:
src/lisp/Config.ppc_darwin | 22 ++++++++++++++--------
1 file changed, 14 insertions(+), 8 deletions(-)
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch rtoy-lisp-trig updated. snapshot-2013-12-a-6-g7069ef9
by rtoy@common-lisp.net 08 Apr '15
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, rtoy-lisp-trig has been updated
via 7069ef9dfa3770d7b3e00aac297ae7dcb22b8c20 (commit)
from 7190b61cf97c8320d6a218c430471c0fb0bf518e (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 7069ef9dfa3770d7b3e00aac297ae7dcb22b8c20
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Sat Dec 14 21:38:18 2013 -0800
Small cleanups.
* Remove unneeded package specifier for %ieee754-rem-pi/2
* Add some comments for %tan.
diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index c23321d..6a025a1 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -543,7 +543,7 @@
(t
;; Argument reduction needed
(multiple-value-bind (n y0 y1)
- (kernel::%ieee754-rem-pi/2 x)
+ (%ieee754-rem-pi/2 x)
(case (logand n 3)
(0
(kernel-sin y0 y1 1))
@@ -568,7 +568,7 @@
(t
;; Argument reduction needed
(multiple-value-bind (n y0 y1)
- (kernel::%ieee754-rem-pi/2 x)
+ (%ieee754-rem-pi/2 x)
(ecase (logand n 3)
(0
(kernel-cos y0 y1))
@@ -584,16 +584,19 @@
(optimize (speed 3)))
(let ((ix (logand #x7fffffff (kernel:double-float-high-bits x))))
(cond ((<= ix #x3fe921fb)
+ ;; |x| < pi/4
(kernel-tan x 0d0 1))
((>= ix #x7ff00000)
+ ;; tan(Inf or Nan) is NaN
(- x x))
(t
(multiple-value-bind (n y0 y1)
- (kernel::%ieee754-rem-pi/2 x)
+ (%ieee754-rem-pi/2 x)
(let ((flag (- 1 (ash (logand n 1) 1))))
;; flag = 1 if n even, -1 if n odd
(kernel-tan y0 y1 flag)))))))
+;; Compute sin and cos of x, simultaneously.
(defun %sincos (x)
(declare (double-float x)
(optimize (speed 3)))
@@ -617,7 +620,6 @@
(3
(values (- (kernel-cos y0 y1))
(kernel-sin y0 y1 1))))))))
-
(declaim (ext:end-block))
-----------------------------------------------------------------------
Summary of changes:
src/code/irrat.lisp | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-30-g5f031f1
by rtoy@common-lisp.net 08 Apr '15
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 5f031f16b552b5798732191e4e5d0a04607373bf (commit)
from 06179e0c45b51011eae88bfc711d7bec00769c89 (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 5f031f16b552b5798732191e4e5d0a04607373bf
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Thu Jul 31 15:57:55 2014 -0700
Update to 3.1.3.
diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp
index cce093d..750a886 100644
--- a/src/contrib/asdf/asdf.lisp
+++ b/src/contrib/asdf/asdf.lisp
@@ -1,5 +1,5 @@
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
-;;; This is ASDF 3.1.2: Another System Definition Facility.
+;;; This is ASDF 3.1.3: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel(a)common-lisp.net>.
@@ -402,7 +402,7 @@ or when loading the package is optional."
(imported)
(t (push name intern)))))))
(labels ((sort-names (names)
- (sort names #'string<))
+ (sort (copy-list names) #'string<))
(table-keys (table)
(loop :for k :being :the :hash-keys :of table :collect k))
(when-relevant (key value)
@@ -845,8 +845,8 @@ UNINTERN -- Remove symbols here from PACKAGE."
(uiop/package:define-package :uiop/common-lisp
(:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
- (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
- (:reexport :common-lisp)
+ (:use :uiop/package)
+ (:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
(:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp (:shadow #:user-homedir-pathname)
@@ -855,7 +855,7 @@ UNINTERN -- Remove symbols here from PACKAGE."
#:logical-pathname #:translate-logical-pathname
#:make-broadcast-stream #:file-namestring)
#+genera (:shadowing-import-from :scl #:boolean)
- #+genera (:export #:boolean #:ensure-directories-exist)
+ #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
#+mcl (:shadow #:user-homedir-pathname))
(in-package :uiop/common-lisp)
@@ -935,9 +935,20 @@ UNINTERN -- Remove symbols here from PACKAGE."
#+genera
(eval-when (:load-toplevel :compile-toplevel :execute)
+ (unless (fboundp 'lambda)
+ (defmacro lambda (&whole form &rest bvl-decls-and-body)
+ (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
+ `#',(cons 'lisp::lambda (cdr form))))
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
- (fs:create-directories-recursively (pathname path)))))
+ (fs:create-directories-recursively (pathname path))))
+ (unless (fboundp 'read-sequence)
+ (defun read-sequence (sequence stream &key (start 0) end)
+ (scl:send stream :string-in nil sequence start end)))
+ (unless (fboundp 'write-sequence)
+ (defun write-sequence (sequence stream &key (start 0) end)
+ (scl:send stream :string-out sequence start end)
+ sequence)))
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
(read-from-string
@@ -1213,7 +1224,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters
(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
- (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
+ (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
#-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
@@ -1390,7 +1401,7 @@ and EVAL that in a (FUNCTION ...) context."
(etypecase fun
(function fun)
((or boolean keyword character number pathname) (constantly fun))
- (hash-table (lambda (x) (gethash x fun)))
+ (hash-table #'(lambda (x) (gethash x fun)))
(symbol (fdefinition fun))
(cons (if (eq 'lambda (car fun))
(eval fun)
@@ -1750,10 +1761,13 @@ then returning the non-empty string value of the variable"
(defun operating-system ()
"The operating system of the current host"
(first-feature
- '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
+ '(:cygwin
+ (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
(:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
(:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
- (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
+ (:solaris :solaris :sunos)
+ (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
+ :unix
:genera)))
(defun architecture ()
@@ -2552,7 +2566,7 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA
"if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
(let ((sub (when maybe-subpath (pathname maybe-subpath)))
- (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
+ (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
(or (and base (subpathp sub base)) sub)))
(defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
@@ -3297,13 +3311,14 @@ in an atomic way if the implementation allows."
directory-pathname (unix:get-unix-error-msg errno))))
#+cormanlisp (win32:delete-directory directory-pathname)
#+ecl (si:rmdir directory-pathname)
+ #+genera (fs:delete-directory directory-pathname)
#+lispworks (lw:delete-directory directory-pathname)
#+mkcl (mkcl:rmdir directory-pathname)
#+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
`(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
#+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
- #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
(error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
(defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
@@ -3337,7 +3352,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
(error "~S was asked to delete ~S but the directory does not exist"
'delete-filesystem-tree directory-pathname))
(:ignore nil)))
- #-(or allegro cmu clozure sbcl scl)
+ #-(or allegro cmu clozure genera sbcl scl)
((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
;; except on implementations where we can prevent DIRECTORY from following symlinks;
;; instead spawn a standard external program to do the dirty work.
@@ -3347,7 +3362,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
#+allegro (symbol-call :excl.osi :delete-directory-and-files
directory-pathname :if-does-not-exist if-does-not-exist)
#+clozure (ccl:delete-directory directory-pathname)
- #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
+ #+genera (fs:delete-directory directory-pathname :confirm nil)
#+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
'(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
@@ -3995,7 +4010,9 @@ Upon success, the KEEP form is evaluated and the file is is deleted unless it ev
(beforef (gensym "BEFORE"))
(afterf (gensym "AFTER")))
`(flet (,@(when before
- `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
+ `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
+ ,@(when after `((declare (ignorable ,pathname))))
+ ,@before)))
,@(when after
(assert pathnamep)
`((,afterf (,pathname) ,@after))))
@@ -4120,7 +4137,7 @@ This is designed to abstract away the implementation specific quit forms."
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
#+gcl (system:quit code)
- #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
+ #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
#+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code)
@@ -4144,8 +4161,8 @@ This is designed to abstract away the implementation specific quit forms."
(declare (ignorable stream count condition))
#+abcl
(loop :for i :from 0
- :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
- (safe-format! stream "~&~D: ~A~%" i frame))
+ :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
+ (safe-format! stream "~&~D: ~A~%" i frame))
#+allegro
(let ((*terminal-io* stream)
(*standard-output* stream)
@@ -4169,20 +4186,20 @@ This is designed to abstract away the implementation specific quit forms."
(debug:backtrace (or count most-positive-fixnum) stream))
#+(or ecl mkcl)
(let* ((top (si:ihs-top))
- (repeats (if count (min top count) top))
- (backtrace (loop :for ihs :from 0 :below top
+ (repeats (if count (min top count) top))
+ (backtrace (loop :for ihs :from 0 :below top
:collect (list (si::ihs-fun ihs)
(si::ihs-env ihs)))))
(loop :for i :from 0 :below repeats
- :for frame :in (nreverse backtrace) :do
- (safe-format! stream "~&~D: ~S~%" i frame)))
+ :for frame :in (nreverse backtrace) :do
+ (safe-format! stream "~&~D: ~S~%" i frame)))
#+gcl
(let ((*debug-io* stream))
(ignore-errors
(with-safe-io-syntax ()
- (if condition
- (conditions::condition-backtrace condition)
- (system::simple-backtrace)))))
+ (if condition
+ (conditions::condition-backtrace condition)
+ (system::simple-backtrace)))))
#+lispworks
(let ((dbg::*debugger-stack*
(dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
@@ -4196,8 +4213,8 @@ This is designed to abstract away the implementation specific quit forms."
stream)
#+xcl
(loop :for i :from 0 :below (or count most-positive-fixnum)
- :for frame :in (extensions:backtrace-as-list) :do
- (safe-format! stream "~&~D: ~S~%" i frame)))
+ :for frame :in (extensions:backtrace-as-list) :do
+ (safe-format! stream "~&~D: ~S~%" i frame)))
(defun print-backtrace (&rest keys &key stream count condition)
"Print a backtrace"
@@ -4297,14 +4314,14 @@ if we are not called from a directly executable image."
;; SBCL and Allegro already separate user arguments from implementation arguments.
#-(or sbcl allegro)
(unless (eq *image-dumped-p* :executable)
- ;; LispWorks command-line processing isn't transparent to the user
- ;; unless you create a standalone executable; in that case,
- ;; we rely on cl-launch or some other script to set the arguments for us.
- #+lispworks (return *command-line-arguments*)
- ;; On other implementations, on non-standalone executables,
- ;; we trust cl-launch or whichever script starts the program
- ;; to use -- as a delimiter between implementation arguments and user arguments.
- #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
+ ;; LispWorks command-line processing isn't transparent to the user
+ ;; unless you create a standalone executable; in that case,
+ ;; we rely on cl-launch or some other script to set the arguments for us.
+ #+lispworks (return *command-line-arguments*)
+ ;; On other implementations, on non-standalone executables,
+ ;; we trust cl-launch or whichever script starts the program
+ ;; to use -- as a delimiter between implementation arguments and user arguments.
+ #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
(rest arguments)))
(defun argv0 ()
@@ -4339,7 +4356,7 @@ immediately to the surrounding restore process if allowed to continue.
Then, comes the restore process itself:
First, call each function in the RESTORE-HOOK,
-in the order they were registered with REGISTER-RESTORE-HOOK.
+in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
Second, evaluate the prelude, which is often Lisp text that is read,
as per EVAL-INPUT.
Third, call the ENTRY-POINT function, if any is specified, with no argument.
@@ -4384,7 +4401,7 @@ of the function will be returned rather than interpreted as a boolean designatin
(dump-hook *image-dump-hook*)
#+clozure prepend-symbols #+clozure (purify t)
#+sbcl compression
- #+(and sbcl windows) application-type)
+ #+(and sbcl os-windows) application-type)
"Dump an image of the current Lisp environment at pathname FILENAME, with various options.
First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
@@ -4458,7 +4475,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(when compression (list :compression compression))
;;--- only save runtime-options for standalone executables
(when executable (list :toplevel #'restore-image :save-runtime-options t))
- #+(and sbcl windows) ;; passing :application-type :gui will disable the console window.
+ #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
;; the default is :console - only works with SBCL 1.1.15 or later.
(when application-type (list :application-type application-type)))))
#-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
@@ -5295,7 +5312,7 @@ It returns a process-info plist with possible keys:
#+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
(%wait-process-result
(apply '%run-program (%normalize-system-command command) :wait t keys))
- #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl)
+ #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
(let ((%command (%redirected-system-command command input output error-output directory)))
#+(and lispworks os-windows)
(system:call-system %command :current-directory directory :wait t)
@@ -5312,6 +5329,8 @@ It returns a process-info plist with possible keys:
(*error-output* *stderr*))
(ext:system %command))
#+gcl (system:system %command)
+ #+genera (error "~S not supported on Genera, cannot run ~S"
+ '%system %command)
#+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
#+mkcl (mkcl:system %command)
#+xcl (system:%run-shell-command %command))))
@@ -6342,7 +6361,7 @@ this function tries to locate the Windows FOLDER for one of
"Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
be applied to the results to yield a configuration form. Current
values of TAG include :source-registry and :output-translations."
- (let ((files (sort (ignore-errors
+ (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
(remove-if
'hidden-pathname-p
(directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
@@ -6568,7 +6587,8 @@ directive.")
:uiop/run-program :uiop/lisp-build
:uiop/configuration :uiop/backward-driver))
-#+mkcl (provide :uiop)
+;; Provide both lowercase and uppercase, to satisfy more people.
+(provide "uiop") (provide "UIOP")
;;;; -------------------------------------------------------------------------
;;;; Handle upgrade as forward- and backward-compatibly as possible
;; See https://bugs.launchpad.net/asdf/+bug/485687
@@ -6638,7 +6658,7 @@ previously-loaded version of ASDF."
;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
- (asdf-version "3.1.2")
+ (asdf-version "3.1.3")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
@@ -6650,26 +6670,26 @@ previously-loaded version of ASDF."
(when-upgrading ()
(let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
- ;; NB: it's too late to do anything about functions in UIOP!
- ;; If you introduce some critically incompatibility there, you must change name.
+ ;; NB: it's too late to do anything about functions in UIOP!
+ ;; If you introduce some critically incompatibility there, you must change name.
'(#:component-relative-pathname #:component-parent-pathname ;; component
#:source-file-type
#:find-system #:system-source-file #:system-relative-pathname ;; system
- #:find-component ;; find-component
- #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
- #:component-depends-on #:operation-done-p #:component-depends-on
- #:traverse ;; backward-interface
+ #:find-component ;; find-component
+ #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
+ #:component-depends-on #:operation-done-p #:component-depends-on
+ #:traverse ;; backward-interface
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan
- #:operate ;; operate
- #:parse-component-form ;; defsystem
- #:apply-output-translations ;; output-translations
- #:process-output-translations-directive
- #:inherit-source-registry #:process-source-registry ;; source-registry
- #:process-source-registry-directive
- #:trivial-system-p)) ;; bundle
- (redefined-classes
+ #:operate ;; operate
+ #:parse-component-form ;; defsystem
+ #:apply-output-translations ;; output-translations
+ #:process-output-translations-directive
+ #:inherit-source-registry #:process-source-registry ;; source-registry
+ #:process-source-registry-directive
+ #:trivial-system-p)) ;; bundle
+ (redefined-classes
;; redefining the classes causes interim circularities
- ;; with the old ASDF during upgrade, and many implementations bork
+ ;; with the old ASDF during upgrade, and many implementations bork
'((#:compile-concatenated-source-op (#:operation) ()))))
(loop :for name :in redefined-functions
:for sym = (find-symbol* name :asdf nil) :do
@@ -6677,12 +6697,12 @@ previously-loaded version of ASDF."
;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
#-clisp (fmakunbound sym)))
(labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
- (find-symbol* s p nil)))
- (asyms (l) (mapcar #'asym l)))
+ (find-symbol* s p nil)))
+ (asyms (l) (mapcar #'asym l)))
(loop* :for (name superclasses slots) :in redefined-classes
- :for sym = (find-symbol* name :asdf nil)
- :when (and sym (find-class sym))
- :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
+ :for sym = (find-symbol* name :asdf nil)
+ :when (and sym (find-class sym))
+ :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
;;; Self-upgrade functions
@@ -7143,8 +7163,9 @@ in which the system specification (.asd file) is located."
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
- #:do-asdf-cache #:normalize-namestring
- #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
+ #:do-asdf-cache #:normalize-namestring
+ #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
+ #:clear-configuration-and-retry #:retry))
(in-package :asdf/cache)
;;; This stamp cache is useful for:
@@ -7180,8 +7201,17 @@ in which the system specification (.asd file) is located."
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-cache* (not override))
(funcall fun)
- (let ((*asdf-cache* (make-hash-table :test 'equal)))
- (funcall fun)))))
+ (loop
+ (restart-case
+ (let ((*asdf-cache* (make-hash-table :test 'equal)))
+ (return (funcall fun)))
+ (retry ()
+ :report (lambda (s)
+ (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
+ (clear-configuration-and-retry ()
+ :report (lambda (s)
+ (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
+ (clear-configuration)))))))
(defmacro with-asdf-cache ((&key key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
@@ -7308,8 +7338,8 @@ of which is a system object.")
(defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered.
(loop :for name :being :the :hash-keys :of *defined-systems*
- :unless (equal name "asdf")
- :do (clear-defined-system name)))
+ :unless (equal name "asdf")
+ :do (clear-defined-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
@@ -7562,82 +7592,73 @@ but not loaded in memory"
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one.
-FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
-PATHNAME when not null is a path from where to load the system,
+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
+PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
- (with-asdf-cache (:key `(locate-system ,name))
- (let* ((name (coerce-name name))
- (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
- (previous (cdr in-memory))
- (previous (and (typep previous 'system) previous))
- (previous-time (car in-memory))
- (found (search-for-system-definition name))
- (found-system (and (typep found 'system) found))
- (pathname (ensure-pathname
- (or (and (typep found '(or pathname string)) (pathname found))
- (and found-system (system-source-file found-system))
- (and previous (system-source-file previous)))
- :want-absolute t :resolve-symlinks *resolve-symlinks*))
- (foundp (and (or found-system pathname previous) t)))
- (check-type found (or null pathname system))
- (unless (check-not-old-asdf-system name pathname)
- (cond
- (previous (setf found nil pathname nil))
- (t
- (setf found (sysdef-preloaded-system-search "asdf"))
- (assert (typep found 'system))
- (setf found-system found pathname nil))))
- (values foundp found-system pathname previous previous-time))))
+ (let* ((name (coerce-name name))
+ (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+ (previous (cdr in-memory))
+ (previous (and (typep previous 'system) previous))
+ (previous-time (car in-memory))
+ (found (search-for-system-definition name))
+ (found-system (and (typep found 'system) found))
+ (pathname (ensure-pathname
+ (or (and (typep found '(or pathname string)) (pathname found))
+ (and found-system (system-source-file found-system))
+ (and previous (system-source-file previous)))
+ :want-absolute t :resolve-symlinks *resolve-symlinks*))
+ (foundp (and (or found-system pathname previous) t)))
+ (check-type found (or null pathname system))
+ (unless (check-not-old-asdf-system name pathname)
+ (cond
+ (previous (setf found nil pathname nil))
+ (t
+ (setf found (sysdef-preloaded-system-search "asdf"))
+ (assert (typep found 'system))
+ (setf found-system found pathname nil))))
+ (values foundp found-system pathname previous previous-time)))
(defmethod find-system ((name string) &optional (error-p t))
(with-asdf-cache (:key `(find-system ,name))
(let ((primary-name (primary-system-name name)))
(unless (equal name primary-name)
(find-system primary-name nil)))
- (loop
- (restart-case
- (multiple-value-bind (foundp found-system pathname previous previous-time)
- (locate-system name)
- (when (and found-system (eq found-system previous)
- (or (first (gethash `(find-system ,name) *asdf-cache*))
- (and *immutable-systems* (gethash name *immutable-systems*))))
- (return found-system))
- (assert (eq foundp (and (or found-system pathname previous) t)))
- (let ((previous-pathname (and previous (system-source-file previous)))
- (system (or previous found-system)))
- (when (and found-system (not previous))
- (register-system found-system))
- (when (and system pathname)
- (setf (system-source-file system) pathname))
- (when (and pathname
- (let ((stamp (get-file-stamp pathname)))
- (and stamp
- (not (and previous
- (or (pathname-equal pathname previous-pathname)
- (and pathname previous-pathname
- (pathname-equal
- (physicalize-pathname pathname)
- (physicalize-pathname previous-pathname))))
- (stamp<= stamp previous-time))))))
- ;; only load when it's a pathname that is different or has newer content, and not an old asdf
- (load-asd pathname :name name)))
- (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
- (return
- (cond
- (in-memory
- (when pathname
- (setf (car in-memory) (get-file-stamp pathname)))
- (cdr in-memory))
- (error-p
- (error 'missing-component :requires name))))))
- (reinitialize-source-registry-and-retry ()
- :report (lambda (s)
- (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
- (unset-asdf-cache-entry `(locate-system ,name))
- (initialize-source-registry)))))))
-
+ (or (and *immutable-systems* (gethash name *immutable-systems*)
+ (cdr (system-registered-p name)))
+ (multiple-value-bind (foundp found-system pathname previous previous-time)
+ (locate-system name)
+ (assert (eq foundp (and (or found-system pathname previous) t)))
+ (let ((previous-pathname (and previous (system-source-file previous)))
+ (system (or previous found-system)))
+ (when (and found-system (not previous))
+ (register-system found-system))
+ (when (and system pathname)
+ (setf (system-source-file system) pathname))
+ (when (and pathname
+ (let ((stamp (get-file-stamp pathname)))
+ (and stamp
+ (not (and previous
+ (or (pathname-equal pathname previous-pathname)
+ (and pathname previous-pathname
+ (pathname-equal
+ (physicalize-pathname pathname)
+ (physicalize-pathname previous-pathname))))
+ (stamp<= stamp previous-time))))))
+ ;; only load when it's a pathname that is different or has newer content, and not an old asdf
+ (load-asd pathname :name name)))
+ (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
+ (cond
+ (in-memory
+ (when pathname
+ (setf (car in-memory) (get-file-stamp pathname)))
+ (cdr in-memory))
+ (error-p
+ (error 'missing-component :requires name))
+ (t ;; not found: don't keep negative cache, see lp#1335323
+ (unset-asdf-cache-entry `(locate-system ,name))
+ (return-from find-system nil)))))))))
;;;; -------------------------------------------------------------------------
;;;; Finding components
@@ -7747,10 +7768,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(and (typep c 'missing-dependency)
(eq (missing-required-by c) component)
(equal (missing-requires c) name))))
- (unless (component-parent component)
- (let ((name (coerce-name name)))
- (unset-asdf-cache-entry `(find-system ,name))
- (unset-asdf-cache-entry `(locate-system ,name))))))))
+ (unless (component-parent component)
+ (let ((name (coerce-name name)))
+ (unset-asdf-cache-entry `(find-system ,name))
+ (unset-asdf-cache-entry `(locate-system ,name))))))))
(defun resolve-dependency-spec (component dep-spec)
@@ -9048,7 +9069,8 @@ The default operation may change in the future if we implement a
component-directed strategy for how to load or compile systems.")
(defmethod component-depends-on ((o prepare-op) (s system))
- `((,*load-system-operation* ,@(component-sideway-dependencies s))))
+ (loop :for (o . cs) :in (call-next-method)
+ :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs)))
(defclass build-op (non-propagating-operation) ()
(:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
@@ -9059,7 +9081,8 @@ as a symbol or as a string later read as a symbol (after loading the defsystem-d
if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
that will load the system in the current image, and its typically LOAD-OP."))
(defmethod component-depends-on ((o build-op) (c component))
- `((,(or (component-build-operation c) *load-system-operation*) ,c)))
+ `((,(or (component-build-operation c) *load-system-operation*) ,c)
+ ,@(call-next-method)))
(defun make (system &rest keys)
"The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
@@ -9163,8 +9186,8 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(defun restart-upgraded-asdf ()
;; If we're in the middle of something, restart it.
(when *asdf-cache*
- (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
- :when (eq x 'find-system) :collect y)))
+ (let ((l (loop :for k :being :the hash-keys :of *asdf-cache*
+ :when (eq (first k) 'find-system) :collect (second k))))
(clrhash *asdf-cache*)
(dolist (s l) (find-system s nil)))))
(register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
@@ -10683,7 +10706,7 @@ To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
Please report to ASDF-DEVEL if this works for you.")))
-;;; Backward compatibility with pre-3.1.1 names
+;;; Backward compatibility with pre-3.1.2 names
(defclass fasl-op (selfward-operation)
((selfward-operation :initform 'compile-bundle-op :allocation :class)))
(defclass load-fasl-op (selfward-operation)
@@ -10976,7 +10999,7 @@ Please use UIOP:RUN-PROGRAM instead."
(in-package :asdf/package-inferred-system)
(with-upgradability ()
- (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))
+ (defparameter *defpackage-forms* '(defpackage define-package))
(defun initial-package-inferred-systems-table ()
(let ((h (make-hash-table :test 'equal)))
@@ -11222,11 +11245,13 @@ otherwise return a default system name computed from PACKAGE-NAME."
#:package-inferred-system-missing-package-error
#:operation-definition-warning #:operation-definition-error
- #:try-recompiling
+ #:try-recompiling ; restarts
#:retry
- #:accept ; restarts
+ #:accept
#:coerce-entry-to-directory
#:remove-entry-from-registry
+ #:clear-configuration-and-retry
+
#:*encoding-detection-hook*
#:*encoding-external-format-hook*
@@ -11262,14 +11287,15 @@ otherwise return a default system name computed from PACKAGE-NAME."
#:user-source-registry
#:system-source-registry
#:user-source-registry-directory
- #:system-source-registry-directory))
+ #:system-source-registry-directory
+ ))
;;;; ---------------------------------------------------------------------------
;;;; ASDF-USER, where the action happens.
(uiop/package:define-package :asdf/user
(:nicknames :asdf-user)
- ;; NB: releases before 3.1.1 this :use'd only uiop/package instead of uiop below.
+ ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below.
;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.
;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package
-----------------------------------------------------------------------
Summary of changes:
src/contrib/asdf/asdf.lisp | 324 ++++++++++++++++++++++++--------------------
1 file changed, 175 insertions(+), 149 deletions(-)
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp annotated tag snapshot-2014-02 created. snapshot-2014-02
by rtoy@common-lisp.net 08 Apr '15
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-02 has been created
at 4f494840e0d6c784941f252f77f041ed864da0ce (tag)
tagging c96b5d32cec8300cccfcbcfc25211621a145f527 (commit)
replaces snapshot-2014-01
tagged by Raymond Toy
on Mon Feb 3 17:40:45 2014 -0800
- Log -----------------------------------------------------------------
Snapshot 2014-02
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.13 (Darwin)
iEYEABECAAYFAlLwRScACgkQJ5IjUmgZO7ILmwCdGStocYPOWFLgNsvATjOvexD4
lSAAn3KVtsgyKWevH4l+OfHXAHjuOQx5
=jqBT
-----END PGP SIGNATURE-----
Raymond Toy (12):
Use truename of *load-pathname*.
Use the correct syntax to match Power Mac for uname -m.
In trac.65, make comparison test an assertion test to show failures
In the summary, print out all test failures and errors.
Fix complex multiply vop.
Update.
Copy src/pcl/simple-streams/rt/simple-streams-tests.lisp to
Convert to using lisp-unit. Disable the two inet tests since the echo
Remove the zero checking of the heap.
Allow stack-tn's to be accessed in the float arith vops.
Simplify the macros that generate the basic float operations.
Update from commit logs.
-----------------------------------------------------------------------
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-42-g894af6c
by rtoy@common-lisp.net 08 Apr '15
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 894af6c4aaa3b83f3c13d2e59735c33f79abdc20 (commit)
via 15d3bbe341280c08855d07dc6664c0fd17b27636 (commit)
via e5bfd82b999468624a09dad92189843f08eac5b2 (commit)
from f849f4dba02f2b41d78ffe21d43be5b184aa7cdf (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 894af6c4aaa3b83f3c13d2e59735c33f79abdc20
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Mon Dec 23 10:40:03 2013 -0800
Add tests for the branch cut for atanh. Not clear that this is
correct because atanh(-2) appears to be wrong.
diff --git a/tests/trig.lisp b/tests/trig.lisp
index 9565ef5..05437e5 100644
--- a/tests/trig.lisp
+++ b/tests/trig.lisp
@@ -725,3 +725,66 @@
(get-signs (acosh-def #c(0.25d0 -1d-20)))
(assert-true (check-signs #'acosh #c(0.25d0 -0d0) tr ti))
(assert-true (check-signs #'acosh #c(0.25w0 -0w0) tr ti))))
+
+;; atanh(z) = 1/2*(log(1+z) - log(1-z))
+;;
+;; The branch cut is on the real axis for |x| > 1. For x < -1, it is
+;; continuous with Quadrant III. For x > 1, it is continuous with
+;; quadrant I.
+;;
+;; NOTE: The rules above are what is given by the CLHS. However,
+;; consider the value of atanh(-2) and atanh(-2-0.0*i)
+;;
+;; atanh(-2) = 1/2*(log(1-2) - log(1+2))
+;; = 1/2*(log(-1) - log(3))
+;; = 1/2*(i*pi - log(3))
+;; = -1/2*log(3) + i*pi/2
+;;
+;; atanh(-2-0*i) = 1/2*(log(1+(-2-0*i)) - log(1-(-2-0*i)))
+;; = 1/2*(log(-1-0*i) - log(3-0*i))
+;; = 1/2*(-i*pi - log(3))
+;; = -1/2*log(3) - i*pi/2
+;;
+;; atanh(-2+0*i) = 1/2*(log(1+(-2+0*i)) - log(1-(-2+0*i)))
+;; = 1/2*(log(-1+0*i) - log(3-0*i))
+;; = 1/2*(i*pi - log(3))
+;; = -1/2*log(3) + i*pi/2
+;;
+;; Thus, atanh(-2) is continuous with Quadrant II, NOT continuous with
+;; Quadrant III!
+;;
+;; What do we do?
+(defun atanh-def (z)
+ (r*z 1/2
+ (- (log (1+z z))
+ (log (1-z z)))))
+
+(define-test branch-cut.atanh
+ (:tag :atanh :branch-cuts)
+ ;; Test for x < -1, which is continuous with Quadrant III. Use the
+ ;; the value at #c(-2d0 -1d-20) as the reference.
+ (multiple-value-bind (tr ti)
+ (get-signs (atanh-def #c(-2d0 -1d-20)))
+ (assert-true (check-signs #'atanh -2d0 tr ti))
+ (assert-true (check-signs #'atanh -2w0 tr ti))
+ (assert-true (check-signs #'atanh #c(-2d0 -0d0) tr ti))
+ (assert-true (check-signs #'atanh #c(-2w0 -0w0) tr ti)))
+ ;; Test the other side of the branch cut for x < -1.
+ (multiple-value-bind (tr ti)
+ (get-signs (atanh-def #c(-2d0 +1d-20)))
+ (assert-true (check-signs #'atanh #c(-2d0 0d0) tr ti))
+ (assert-true (check-signs #'atanh #c(-2w0 0w0) tr ti)))
+
+ ;; Test for x > 1, which is continuous with Quadrant I, using the
+ ;; value at #c(+2d0 1d-10) as the reference
+ (multiple-value-bind (tr ti)
+ (get-signs (atanh-def #c(2d0 1d-20)))
+ (assert-true (check-signs #'atanh 2d0 tr ti))
+ (assert-true (check-signs #'atanh 2w0 tr ti))
+ (assert-true (check-signs #'atanh #c(2d0 0) tr ti))
+ (assert-true (check-signs #'atanh #c(2w0 0) tr ti)))
+ ;; Test the other side of the branch cut for x > 1.
+ (multiple-value-bind (tr ti)
+ (get-signs (atanh-def #c(2d0 -1d-20)))
+ (assert-true (check-signs #'atanh #c(2d0 -0d0) tr ti))
+ (assert-true (check-signs #'atanh #c(2w0 -0w0) tr ti))))
commit 15d3bbe341280c08855d07dc6664c0fd17b27636
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Mon Dec 23 08:36:22 2013 -0800
Add tests for the branch cuts for asinh and acosh, and some fixes.
o Add function R-Z to compute r - z carefully. (For definition of
acos)
o Add function R*Z to compute r*z carefully, For acos and acosh.
o Add tests for asinh and acosh.
diff --git a/tests/trig.lisp b/tests/trig.lisp
index 011aeaf..9565ef5 100644
--- a/tests/trig.lisp
+++ b/tests/trig.lisp
@@ -468,6 +468,13 @@
(complex (- 1 (realpart z)) (- (imagpart z)))
(- 1 z)))
+(defun z-1 (z)
+ (if (complexp z)
+ (complex (- (realpart z) 1)
+ (imagpart z))
+ (- z 1)))
+
+
;; Carefully compute 1+z. For z = x + i*y, we want 1+x + i*y, which
;; only really matters when y is a signed zero.
(defun 1+z (z)
@@ -475,12 +482,24 @@
(complex (+ 1 (realpart z)) (imagpart z))
(+ 1 z)))
+(defun r-z (r z)
+ (if (complexp z)
+ (complex (- r (realpart z))
+ (- (imagpart z)))
+ (- r z)))
+
;; Carefully compute i*z = i*(x+i*y) = -y + i*x.
(defun i*z (z)
(if (complexp z)
(complex (- (imagpart z)) (realpart z))
(complex 0 z)))
+;; Carefully compute r*z, where r is a real value and z is complex.
+(defun r*z (r z)
+ (if (complexp z)
+ (complex (* r (realpart z)) (* r (imagpart z)))
+ (* r z)))
+
;; asin(x) = -i*log(i*x + sqrt(1-x^2))
;;
;; The branch cut is the real axis |x| > 1. For x < -1, it is
@@ -529,10 +548,10 @@
;; continous with Quadrant II; for x > 1, Quadrant IV.
(defun acos-def (z)
(if (typep z 'kernel:double-double-float)
- (- (/ kernel:dd-pi 2)
- (asin-def z))
- (- (/ pi 2)
- (asin-def z))))
+ (r-z (/ kernel:dd-pi 2)
+ (asin-def z))
+ (r-z (/ pi 2)
+ (asin-def z))))
(define-test branch-cut.acos
(:tag :acos :branch-cuts)
@@ -601,7 +620,7 @@
(let* ((iz (i*z z))
(w (- (log (1+z iz))
(log (1-z iz)))))
- (* -1/2 (i*z w))))
+ (r*z -1/2 (i*z w))))
(define-test branch-cut.atan
(:tag :atan :branch-cuts)
@@ -628,3 +647,81 @@
(get-signs (atan-def #c(1d-20 2d0)))
(assert-true (check-signs #'atan #c(0d0 2d0) tr ti))
(assert-true (check-signs #'atan #c(0d0 2w0) tr ti))))
+
+;; asinh(z) = log(z + sqrt(1+z^2))
+;;
+;; The branch cut is the imaginary axis with |y| > 1. For y > 1, asinh
+;; is continuous with Quadrant I. For y < -1, it is continuous with
+;; Quadrant III.
+
+(defun asinh-def (z)
+ (log (+ z (sqrt (1+z (* z z))))))
+
+(define-test branch-cut.asinh
+ (:tag :asinh :branch-cuts)
+ ;; Test for y < -1, which is continuous with Quadrant I. Use the
+ ;; value at #c(1d-20 -2d0) as the reference.
+ (multiple-value-bind (tr ti)
+ (get-signs (asinh-def #c(1d-20 -2d0)))
+ (assert-true (check-signs #'asinh #c(0d0 -2d0) tr ti))
+ (assert-true (check-signs #'asinh #c(0w0 -2w0) tr ti)))
+ ;; Test the other side of the branch cut for y < -1.
+ (multiple-value-bind (tr ti)
+ (get-signs (asinh-def #c(-1d-20 -2d0)))
+ (assert-true (check-signs #'asinh #c(-0d0 -2d0) tr ti))
+ (assert-true (check-signs #'asinh #c(-0w0 -2w0) tr ti)))
+
+ ;; Test for y > 1, which is continuous with Quadrant III, using the
+ ;; value at #c(-1d-20 +2d0) as the reference
+ (multiple-value-bind (tr ti)
+ (get-signs (asinh-def #c(-1d-20 2d0)))
+ (assert-true (check-signs #'asinh #c(-0d0 2d0) tr ti))
+ (assert-true (check-signs #'asinh #c(-0w0 2w0) tr ti)))
+ ;; Test the other side of the branch cut for x > 1.
+ (multiple-value-bind (tr ti)
+ (get-signs (asinh-def #c(1d-20 2d0)))
+ (assert-true (check-signs #'asinh #c(0d0 2d0) tr ti))
+ (assert-true (check-signs #'asinh #c(0d0 2w0) tr ti))))
+
+;; acosh(z) = 2*log(sqrt((z+1)/2) + sqrt((z-1)/2))
+;;
+;; The branch cut is along the real axis with x < 1. For x < 0, it is
+;; continuous with Quadrant II. For 0< x < 1, it is continuous with
+;; Quadrant I.
+
+(defun acosh-def (z)
+ (r*z 2
+ (log (+ (sqrt (r*z 1/2 (1+z z)))
+ (sqrt (r*z 1/2 (z-1 z)))))))
+
+
+(define-test branch-cut.acosh
+ (:tag :acosh :branch-cuts)
+ ;; Test for x < 0, which is continuous with Quadrant II. Use the
+ ;; value at #c(-2d0 1d-20) as a reference.
+ (multiple-value-bind (tr ti)
+ (get-signs (acosh-def #c(-2d0 1d-20)))
+ (assert-true (check-signs #'acosh -2d0 tr ti))
+ ;;(assert-true (check-signs #'acosh -2w0 tr ti))
+ (assert-true (check-signs #'acosh #c(-2d0 0) tr ti))
+ ;;(assert-true (check-signs #'acosh #c(-2w0 0) tr ti))
+ )
+ ;; Test the other side of the branch cut for x < -1.
+ (multiple-value-bind (tr ti)
+ (get-signs (acosh-def #c(-2d0 -1d-20)))
+ (assert-true (check-signs #'acosh #c(-2d0 -0d0) tr ti))
+ ;;(assert-true (check-signs #'acosh #c(-2w0 -0w0) tr ti))
+ )
+
+ ;; Test for 0 < x < 1, which is continuous with Quadrant I, using the
+ ;; value at #c(0.25d0 1d-10) as the reference.
+ (multiple-value-bind (tr ti)
+ (get-signs (acosh-def #c(0.25d0 1d-20)))
+ (assert-true (check-signs #'acosh #c(0.25d0 0) tr ti))
+ (assert-true (check-signs #'acosh #c(0.25w0 0) tr ti))
+ )
+ ;; Test the other side of the branch cut for 0 < x < 1.
+ (multiple-value-bind (tr ti)
+ (get-signs (acosh-def #c(0.25d0 -1d-20)))
+ (assert-true (check-signs #'acosh #c(0.25d0 -0d0) tr ti))
+ (assert-true (check-signs #'acosh #c(0.25w0 -0w0) tr ti))))
commit e5bfd82b999468624a09dad92189843f08eac5b2
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Mon Dec 23 00:16:43 2013 -0800
Float printer tests from reading the logs for print.lisp.
diff --git a/tests/printer.lisp b/tests/printer.lisp
new file mode 100644
index 0000000..b511f0b
--- /dev/null
+++ b/tests/printer.lisp
@@ -0,0 +1,113 @@
+(defpackage :printer-tests
+ (:use :cl :lisp-unit))
+
+(in-package "PRINTER-TESTS")
+
+(define-test format.float.1
+ (assert-equal ".0000"
+ (format nil "~5F" 1d-10))
+ (assert-equal "0.000"
+ (format nil "~,3F" 0.000001)))
+
+(define-test format.float.2
+ (assert-equal " 0.990E+00" (format nil "~11,3,2,0,'*,,'EE" .99))
+ (assert-equal " 0.999E+00" (format nil "~11,3,2,0,'*,,'EE" .999))
+ (assert-equal " 0.100E+01" (format nil "~11,3,2,0,'*,,'EE" .9999))
+ (assert-equal " 0.999E-04" (format nil "~11,3,2,0,'*,,'EE" .0000999))
+ (assert-equal " 0.100E-03" (format nil "~11,3,2,0,'*,,'EE" .00009999))
+ (assert-equal " 9.999E-05" (format nil "~11,3,2,,'*,,'EE" .00009999))
+ (assert-equal " 1.000E-04" (format nil "~11,3,2,,'*,,'EE" .000099999)))
+
+(define-test format.float.3
+ (assert-equal ".00123d+6" (format nil "~9,,,-2E" 1.2345689d3))
+ (assert-equal "-.0012d+6" (format nil "~9,,,-2E" -1.2345689d3))
+ (assert-equal ".00123d+0" (format nil "~9,,,-2E" 1.2345689d-3))
+ (assert-equal "-.0012d+0" (format nil "~9,,,-2E" -1.2345689d-3)))
+
+(define-test format.float.4
+ (assert-equal "0.314e-01" (format nil "~9,3,2,0,'%G" 0.0314159))
+ (assert-equal "+.003e+03" (format nil "~9,3,2,-2,'%@e" 3.14159))
+ (assert-equal " 31.42" (format nil "~6,2,1,'*F" 3.14159))
+ (assert-equal " 3141590." (format nil "~9,0,6f" 3.14159))
+
+ (assert-equal ".00000003d+8" (format nil "~9,4,,-7E" pi))
+ (assert-equal ".000003d+6" (format nil "~9,4,,-5E" pi))
+ (assert-equal "3141600.d-6" (format nil "~5,4,,7E" pi))
+ (assert-equal " 314.16d-2" (format nil "~11,4,,3E" pi))
+ (assert-equal " 31416.d-4" (format nil "~11,4,,5E" pi))
+ (assert-equal " 0.3142d+1" (format nil "~11,4,,0E" pi))
+ (assert-equal ".03142d+2" (format nil "~9,,,-1E" pi))
+ (assert-equal "0.003141592653589793d+3" (format nil "~,,,-2E" pi))
+ (assert-equal "31.41592653589793d-1" (format nil "~,,,2E" pi))
+ (assert-equal "3.141592653589793d+0" (format nil "~E" pi))
+ (assert-equal ".03142d+2" (format nil "~9,5,,-1E" pi))
+ (assert-equal " 0.03142d+2" (format nil "~11,5,,-1E" pi))
+ (assert-equal "3.141592653589793 " (format nil "~G" pi))
+ (assert-equal "3.1416 " (format nil "~9,5G" pi))
+ (assert-equal "| 3141593.d-06|" (format nil "|~13,6,2,7E|" pi))
+ (assert-equal "0.314d+01" (format nil "~9,3,2,0,'%E" pi))
+ (assert-equal " 3141593." (format nil "~9,0,6f" pi))
+ (assert-equal " 31.42" (format nil "~6,2,1,'*F" pi))
+ (assert-equal "******" (format nil "~6,2,1,'*F" (* 100 pi)))
+ (assert-equal "+.003d+03" (format nil "~9,3,2,-2,'%@E" pi))
+ (assert-equal "+0.003d+03" (format nil "~10,3,2,-2,'%@E" pi))
+ (assert-equal "=====+0.003d+03" (format nil "~15,3,2,-2,'%,'=@E" pi))
+ (assert-equal "0.003d+03" (format nil "~9,3,2,-2,'%E" pi))
+ (assert-equal "%%%%%%%%" (format nil "~8,3,2,-2,'%@E" pi))
+
+ (assert-equal "1. " (format nil "~g" 1e0))
+
+ (assert-equal "0.0e+0" (format nil "~e" 0))
+ (assert-equal "0.0d+0" (format nil "~e" 0d0))
+ (assert-equal "0.0d+0000" (format nil "~9,,4e" 0d0))
+ (assert-equal "1.2345678901234567d+4" (format nil "~E" 1.234567890123456789d4))
+
+ (assert-equal "1.32922799578492d+36" (format nil "~20E" (expt 2d0 120)))
+ (assert-equal " 1.32922800d+36" (format nil "~21,8E" (expt 2d0 120)))
+
+ (assert-equal ".0012345679" (format nil "~11f" 1.23456789123456789d-3)))
+
+(define-test format.float.5
+ ;; From CLHS 22.3.11
+ (flet ((test-f (x)
+ (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F"
+ x x x x x x)))
+ (assert-equal " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" (test-f 3.14159))
+ (assert-equal " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" (test-f -3.14159))
+ (assert-equal "100.00|******|100.00| 100.0|100.00|100.0" (test-f 100.0))
+ (assert-equal "1234.00|******|??????|1234.0|1234.00|1234.0" (test-f 1234.0))
+ (assert-equal " 0.01| 0.06| 0.01| 0.006|0.01|0.006" (test-f 0.006))))
+
+(define-test format.float.6
+ (flet ((test-e (x)
+ (format nil
+ "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~
+ ~9,3,2,-2,'%@E|~9,2E"
+ x x x x)))
+
+ (assert-equal " 3.14e+0| 31.42$-01|+.003e+03| 3.14e+0" (test-e 3.14159))
+ (assert-equal " -3.14e+0|-31.42$-01|-.003e+03| -3.14e+0" (test-e -3.14159))
+ (assert-equal " 1.10e+3| 11.00$+02|+.001e+06| 1.10e+3" (test-e 1100.0))
+ (assert-equal " 1.10d+3| 11.00$+02|+.001d+06| 1.10d+3" (test-e 1100.0d0))
+ (assert-equal "*********| 11.00$+12|+.001e+16| 1.10e+13" (test-e 1.1e13))
+ (assert-equal "*********|??????????|%%%%%%%%%|1.10d+120" (test-e 1.1d120))))
+
+(define-test format.float.7
+ (flet ((test-scale (k)
+ (format nil "~&Scale factor ~2D: |~13,6,2,VE|"
+ (- k 5) (- k 5) 3.14159)))
+
+ (assert-equal "Scale factor -5: | 0.000003e+06|" (test-scale 0))
+ (assert-equal "Scale factor -4: | 0.000031e+05|" (test-scale 1))
+ (assert-equal "Scale factor -3: | 0.000314e+04|" (test-scale 2))
+ (assert-equal "Scale factor -2: | 0.003142e+03|" (test-scale 3))
+ (assert-equal "Scale factor -1: | 0.031416e+02|" (test-scale 4))
+ (assert-equal "Scale factor 0: | 0.314159e+01|" (test-scale 5))
+ (assert-equal "Scale factor 1: | 3.141590e+00|" (test-scale 6))
+ (assert-equal "Scale factor 2: | 31.41590e-01|" (test-scale 7))
+ (assert-equal "Scale factor 3: | 314.1590e-02|" (test-scale 8))
+ (assert-equal "Scale factor 4: | 3141.590e-03|" (test-scale 9))
+ (assert-equal "Scale factor 5: | 31415.90e-04|" (test-scale 10))
+ (assert-equal "Scale factor 6: | 314159.0e-05|" (test-scale 11))
+ (assert-equal "Scale factor 7: | 3141590.e-06|" (test-scale 12))))
+
-----------------------------------------------------------------------
Summary of changes:
tests/printer.lisp | 113 ++++++++++++++++++++++++++++++++++
tests/trig.lisp | 170 ++++++++++++++++++++++++++++++++++++++++++++++++++--
2 files changed, 278 insertions(+), 5 deletions(-)
create mode 100644 tests/printer.lisp
hooks/post-receive
--
CMU Common Lisp
1
0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-10-g8a5b49e
by rtoy@common-lisp.net 08 Apr '15
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 8a5b49ec0af3c4cad29a26e8dc3f9cee029fd67d (commit)
from 513c3b23e97cf7e1af4da202053bedf96e70cc44 (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 8a5b49ec0af3c4cad29a26e8dc3f9cee029fd67d
Author: Raymond Toy <toy.raymond(a)gmail.com>
Date: Sat Mar 1 08:31:17 2014 -0800
Update from recent changes.
diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot
index 8ae0b93..f2b0c22 100644
--- a/src/i18n/locale/cmucl.pot
+++ b/src/i18n/locale/cmucl.pot
@@ -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
-----------------------------------------------------------------------
Summary of changes:
src/i18n/locale/cmucl.pot | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
hooks/post-receive
--
CMU Common Lisp
1
0