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

[Git][cmucl/cmucl][issue-435-add-core-math-compile-code] Undo changes to lisp_cosh and lisp_expm1
by Raymond Toy (＠rtoy) 25 Feb '26

25 Feb '26

Raymond Toy pushed to branch issue-435-add-core-math-compile-code at cmucl / cmucl Commits: 993d1907 by Raymond Toy at 2026-02-24T18:42:57-08:00 Undo changes to lisp_cosh and lisp_expm1 Accidentally let some stuff in. - - - - - 1 changed file: - src/lisp/irrat.c Changes: ===================================== src/lisp/irrat.c ===================================== @@ -163,8 +163,6 @@ double lisp_cosh(double x) { #ifdef FEATURE_CORE_MATH - MAYBE_SIGNAL_OVERFLOW(fabs(x)) - return cr_cosh(x); #else return __ieee754_cosh(x); @@ -308,10 +306,6 @@ double lisp_expm1(double x) { #ifdef FEATURE_CORE_MATH - if (isinf(x) == 1) { - return fdlibm_setexception(x, FDLIBM_OVERFLOW); - } - return cr_expm1(x); #else return fdlibm_expm1(x); View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/993d19072a51e7a2186a25a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/993d19072a51e7a2186a25a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-435-add-core-math-compile-code] 2 commits: Merge branch 'issue-435-add-core-math-compile-code' into 'master'
by Raymond Toy (＠rtoy) 25 Feb '26

25 Feb '26

Raymond Toy pushed to branch issue-435-add-core-math-compile-code at cmucl / cmucl Commits: e1f841fb by Raymond Toy at 2026-02-24T18:15:35-08:00 Merge branch 'issue-435-add-core-math-compile-code' into 'master' Forgot to add log1pf.c See merge request cmucl/cmucl!355 - - - - - f2f15905 by Raymond Toy at 2026-02-24T18:35:58-08:00 Address #435: Compile single-float core-math routines Update config files and Makefiles to include the single-float core-math routines. Add interfaces to the routines in irrat.c. This verifies that we have included everything and it compiles. The lisp interface hasn't been updated, so none of these get called. - - - - - 3 changed files: - src/lisp/Config.x86_common - src/lisp/GNUmakefile - src/lisp/irrat.c Changes: ===================================== src/lisp/Config.x86_common ===================================== @@ -65,6 +65,34 @@ CORE64_SRCS=\ $(CORE_MATH_64)/log1p/log1p.c \ $(CORE_MATH_64)/expm1/expm1.c \ $(CORE_MATH_64)/sincos/sincos.c + +CORE_MATH_32=core-math/src/binary32 +CORE32_SRCS=\ + $(CORE_MATH_32)/sin/sinf.c \ + $(CORE_MATH_32)/cos/cosf.c \ + $(CORE_MATH_32)/tan/tanf.c \ + $(CORE_MATH_32)/atan2/atan2f.c \ + $(CORE_MATH_32)/asin/asinf.c \ + $(CORE_MATH_32)/acos/acosf.c \ + $(CORE_MATH_32)/atan/atanf.c \ + $(CORE_MATH_32)/sinh/sinhf.c \ + $(CORE_MATH_32)/cosh/coshf.c \ + $(CORE_MATH_32)/tanh/tanhf.c \ + $(CORE_MATH_32)/asinh/asinhf.c \ + $(CORE_MATH_32)/acosh/acoshf.c \ + $(CORE_MATH_32)/atanh/atanhf.c \ + $(CORE_MATH_32)/exp/expf.c \ + $(CORE_MATH_32)/log/logf.c \ + $(CORE_MATH_32)/log10/log10f.c \ + $(CORE_MATH_32)/log2/log2f.c \ + $(CORE_MATH_32)/pow/powf.c \ + $(CORE_MATH_32)/hypot/hypotf.c \ + $(CORE_MATH_32)/log1p/log1pf.c \ + $(CORE_MATH_32)/expm1/expm1f.c \ + $(CORE_MATH_32)/sincos/sincosf.c + +CORE_MATH_SRCS = $(CORE64_SRCS) $(CORE32_SRCS) + endif ifeq ($(filter 2% 3%, $(shell $(CC) -dumpversion)),) ===================================== src/lisp/GNUmakefile ===================================== @@ -36,7 +36,7 @@ SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ dynbind.c breakpoint.c regnames.c backtrace.c save.c purify.c \ runprog.c time.c case-mapping.c exec-init.c \ irrat.c \ - ${CORE64_SRCS} \ + ${CORE_MATH_SRCS} \ ${FDLIBM} ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC} ===================================== src/lisp/irrat.c ===================================== @@ -32,6 +32,28 @@ extern double cr_hypot(double, double); extern double cr_log1p(double); extern double cr_expm1(double); extern void cr_sincos(double, double *, double *); + +extern float cr_sinf(float); +extern float cr_cosf(float); +extern float cr_tanf(float); +extern float cr_atanf(float); +extern float cr_atan2f(float, float); +extern float cr_asinf(float); +extern float cr_acosf(float); +extern float cr_sinhf(float); +extern float cr_coshf(float); +extern float cr_tanhf(float); +extern float cr_asinhf(float); +extern float cr_acoshf(float); +extern float cr_atanhf(float); +extern float cr_expf(float); +extern float cr_logf(float); +extern float cr_log10f(float); +extern float cr_powf(float, float); +extern float cr_hypotf(float, float); +extern float cr_log1pf(float); +extern float cr_expm1f(float); +extern void cr_sincosf(float, float *, float *); #endif @@ -141,6 +163,8 @@ double lisp_cosh(double x) { #ifdef FEATURE_CORE_MATH + MAYBE_SIGNAL_OVERFLOW(fabs(x)) + return cr_cosh(x); #else return __ieee754_cosh(x); @@ -284,6 +308,10 @@ double lisp_expm1(double x) { #ifdef FEATURE_CORE_MATH + if (isinf(x) == 1) { + return fdlibm_setexception(x, FDLIBM_OVERFLOW); + } + return cr_expm1(x); #else return fdlibm_expm1(x); @@ -297,7 +325,7 @@ lisp_scalbn(double x, int n) } void -lisp_sincos (double x, double *s, double *c) +lisp_sincos(double x, double *s, double *c) { #ifdef FEATURE_CORE_MATH cr_sincos(x, s, c); @@ -307,3 +335,236 @@ lisp_sincos (double x, double *s, double *c) cmucl_sincos(x, s, c); #endif } + +/* + * The single-float versions of the special functions. When core-math + * is set, we use the single-float core-math functions. Otherwise, we + * use the double-float versions from fdlibm, with appropriate + * coercions. + */ +float +lisp_sinf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_sinf(x); +#else + return (float) fdlibm_sin((double) x); +#endif +} + +float +lisp_cosf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_cosf(x); +#else + return (float) fdlibm_cos((double) x); +#endif +} + +float +lisp_tanf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_tanf(x); +#else + return (float) fdlibm_tan((double) x); +#endif +} + +float +lisp_atanf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_atanf(x); +#else + return (float) fdlibm_atan((double) x); +#endif +} + +float +lisp_atan2f(float y, float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_atan2f(y, x); +#else + return (float) __ieee754_atan2((double) y, (double) x); +#endif +} + +float +lisp_asinf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_asinf(x); +#else + return (float) __ieee754_asin((double) x); +#endif +} + +float +lisp_acosf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_acosf(x); +#else + return (float) __ieee754_acos((double) x); +#endif +} + +float +lisp_sinhf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_sinhf(x); +#else + return (float) __ieee754_sinh((double) x); +#endif +} + +float +lisp_coshf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_coshf(x); +#else + return (float) __ieee754_cosh((double) x); +#endif +} + +float +lisp_tanhf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_tanhf(x); +#else + return (float) fdlibm_tanh((double) x); +#endif +} + +float +lisp_asinhf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_asinhf(x); +#else + return (float) fdlibm_asinh((double) x); +#endif +} + +float +lisp_acoshf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_acoshf(x); +#else + return (float) __ieee754_acosh((double) x); +#endif +} + +float +lisp_atanhf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_atanhf(x); +#else + return (float) __ieee754_atanh((double) x); +#endif +} + +float +lisp_expf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_expf(x); +#else + return (float) __ieee754_exp((double) x); +#endif +} + +float +lisp_logf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_logf(x); +#else + return (float) __ieee754_log((double) x); +#endif +} + +float +lisp_log10f(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_log10f(x); +#else + return (float) __ieee754_log10((double) x); +#endif +} + +float +lisp_powf(float x, float y) +{ +#ifdef FEATURE_CORE_MATH + /* + * cr_pow when compiled with older versions of gcc or clang can + * cause failures in the ansi-tests [#469]. Ubuntu 25.10 and Fedora 41 + * (gcc only) are known to have compilers that work well enough + * that the ansi-tests pass. + */ + return cr_powf(x, y); +#else + /* + * cr_pow seems causes ansi-tests to fail in test WRITE.1 among + * others. Somewhere an invalid operation is occurring. Thus + * just use fdlibm for now until we can figure out what's causing + * the failure. + */ + return (float) __ieee754_pow((double) x, (double) y); +#endif +} + +float +lisp_hypotf(float x, float y) +{ +#ifdef FEATURE_CORE_MATH + return cr_hypotf(x, y); +#else + return (float) __ieee754_hypot((double) x, (double) y); +#endif +} + +float +lisp_log1pf(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_log1pf(x); +#else + return (float) fdlibm_log1p((double) x); +#endif +} + +float +lisp_expm1f(float x) +{ +#ifdef FEATURE_CORE_MATH + return cr_expm1f(x); +#else + return (float) fdlibm_expm1((double) x); +#endif +} + +void +lisp_sincosf(float x, float *s, float *c) +{ +#ifdef FEATURE_CORE_MATH + cr_sincosf(x, s, c); +#else + extern void cmucl_sincos(double, double*, double*); + double ds, dc; + + cmucl_sincos((double) x, &ds, &dc); + *s = (float) ds; + *c = (float) dc; +#endif +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/1b1e639bf08e9e6c9b4555… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/1b1e639bf08e9e6c9b4555… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Forgot to add log1pf.c
by Raymond Toy (＠rtoy) 25 Feb '26

25 Feb '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1b1e639b by Raymond Toy at 2026-02-24T18:09:31-08:00 Forgot to add log1pf.c - - - - - e1f841fb by Raymond Toy at 2026-02-24T18:15:35-08:00 Merge branch 'issue-435-add-core-math-compile-code' into 'master' Forgot to add log1pf.c See merge request cmucl/cmucl!355 - - - - - 1 changed file: - + src/lisp/core-math/src/binary32/log1p/log1pf.c Changes: ===================================== src/lisp/core-math/src/binary32/log1p/log1pf.c ===================================== @@ -0,0 +1,141 @@ +/* Correctly-rounded biased argument natural logarithm function for binary32 value. + +Copyright (c) 2023-2025 Alexei Sibidanov. + +This file is part of the CORE-MATH project +(https://core-math.gitlabpages.inria.fr/). + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. +*/ + +#include <stdint.h> +#include <errno.h> + +// Warning: clang also defines __GNUC__ +#if defined(__GNUC__) && !defined(__clang__) +#pragma GCC diagnostic ignored "-Wunknown-pragmas" +#endif + +#pragma STDC FENV_ACCESS ON + +typedef union {float f; uint32_t u;} b32u32_u; +typedef union {double f; uint64_t u;} b64u64_u; + +static __attribute__((noinline)) float as_special(float x){ + b32u32_u t = {.f = x}; + if(t.u==0xbf800000u){// +0.0 +#ifdef CORE_MATH_SUPPORT_ERRNO + errno = ERANGE; +#endif + return -1.0f/0.0f; // to raise FE_DIVBYZERO + } + if(t.u == 0x7f800000u) return x; // +inf + uint32_t ax = t.u<<1; + if(ax > 0xff000000u) return x + x; // nan +#ifdef CORE_MATH_SUPPORT_ERRNO + errno = EDOM; +#endif + return 0.0f/0.0f; // to raise FE_INVALID +} + +float cr_log1pf(float x) { + static const double x0[] = { + 0x1.f81f82p-1, 0x1.e9131acp-1, 0x1.dae6077p-1, 0x1.cd85689p-1, 0x1.c0e0704p-1, 0x1.b4e81b5p-1, + 0x1.a98ef6p-1, 0x1.9ec8e95p-1, 0x1.948b0fdp-1, 0x1.8acb90fp-1, 0x1.8181818p-1, 0x1.78a4c81p-1, + 0x1.702e05cp-1, 0x1.6816817p-1, 0x1.605816p-1, 0x1.58ed231p-1, 0x1.51d07ebp-1, 0x1.4afd6ap-1, + 0x1.446f865p-1, 0x1.3e22cbdp-1, 0x1.3813814p-1, 0x1.323e34ap-1, 0x1.2c9fb4ep-1, 0x1.27350b9p-1, + 0x1.21fb781p-1, 0x1.1cf06aep-1, 0x1.1811812p-1, 0x1.135c811p-1, 0x1.0ecf56cp-1, 0x1.0a6810ap-1, + 0x1.0624dd3p-1, 0x1.0204081p-1}; + static const double lixb[] = { + 0x1.fc0a8909b4218p-7, 0x1.77458f51aac89p-5, 0x1.341d793afb997p-4, 0x1.a926d3a5ebd2ap-4, + 0x1.0d77e7a8a823dp-3, 0x1.44d2b6c557102p-3, 0x1.7ab89040accecp-3, 0x1.af3c94ecab3d6p-3, + 0x1.e27076d54e6c9p-3, 0x1.0a324e3888ad5p-2, 0x1.22941fc0c7357p-2, 0x1.3a64c56ae3fdbp-2, + 0x1.51aad874af21fp-2, 0x1.686c81d300eap-2, 0x1.7eaf83c7fa9b5p-2, 0x1.947941aa610ecp-2, + 0x1.a9cec9a3f023bp-2, 0x1.beb4d9ea4156ep-2, 0x1.d32fe7f35e5c7p-2, 0x1.e7442617b817ap-2, + 0x1.faf588dd5ed1p-2, 0x1.0723e5c635c39p-1, 0x1.109f39d53c99p-1, 0x1.19ee6b38a4668p-1, + 0x1.23130d7f93c3bp-1, 0x1.2c0e9ec9b0b85p-1, 0x1.34e289cb35eccp-1, 0x1.3d9026ad3d3f3p-1, + 0x1.4618bc1eadbbbp-1, 0x1.4e7d8127dd8a9p-1, 0x1.56bf9d5967092p-1, 0x1.5ee02a926936ep-1}; + static const double lix[] = { + 0x1.fc0a890fc03e4p-7, 0x1.77458f532dcfcp-5, 0x1.341d793bbd1d1p-4, 0x1.a926d3a6ad563p-4, + 0x1.0d77e7a908e59p-3, 0x1.44d2b6c5b7d1ep-3, 0x1.7ab890410d909p-3, 0x1.af3c94ed0bff3p-3, + 0x1.e27076d5af2e6p-3, 0x1.0a324e38b90e3p-2, 0x1.22941fc0f7966p-2, 0x1.3a64c56b145eap-2, + 0x1.51aad874df82dp-2, 0x1.686c81d3314afp-2, 0x1.7eaf83c82afc3p-2, 0x1.947941aa916fbp-2, + 0x1.a9cec9a42084ap-2, 0x1.beb4d9ea71b7cp-2, 0x1.d32fe7f38ebd5p-2, 0x1.e7442617e8788p-2, + 0x1.faf588dd8f31fp-2, 0x1.0723e5c64df4p-1, 0x1.109f39d554c97p-1, 0x1.19ee6b38bc96fp-1, + 0x1.23130d7fabf43p-1, 0x1.2c0e9ec9c8e8cp-1, 0x1.34e289cb4e1d3p-1, 0x1.3d9026ad556fbp-1, + 0x1.4618bc1ec5ec2p-1, 0x1.4e7d8127f5bb1p-1, 0x1.56bf9d597f399p-1, 0x1.5ee02a9281675p-1}; + static const double b[] = + {0x1p+0, -0x1p-1, 0x1.5555555556f6bp-2, -0x1.00000000029b9p-2, + 0x1.9999988d176e4p-3, -0x1.55555418889a7p-3, 0x1.24adeca50e2bcp-3, -0x1.001ba33bf57cfp-3}; + + double z = x; + b32u32_u t = {.f = x}; + uint32_t ux = t.u, ax = ux&(~0u>>1); + if(__builtin_expect(ax<0x3c880000u, 1)){ // |x| < 0x1.1p-6 + if(__builtin_expect(ax<0x33000000u, 0)){ // |x| < 0x1p-25 + if(!ax) return x; + float res = __builtin_fmaf(x,-x,x); +#ifdef CORE_MATH_SUPPORT_ERRNO + /* log1p(x) underflows exactly when |res| < 2^-126 + and for x=-0x1.fffffcp-127 and rounding downwards */ + if (__builtin_fabsf (res) < 0x1p-126f || + (x == -0x1.fffffcp-127f && res == -0x1p-126f)) + errno = ERANGE; // underflow +#endif + return res; + } + double z2 = z*z, z4 = z2*z2; + double f = z2*((b[1] + z*b[2]) + z2*(b[3] + z*b[4]) + z4*((b[5] + z*b[6]) + z2*b[7])); + b64u64_u r = {.f = z + f}; + if(__builtin_expect((r.u&0xfffffffll) == 0, 0)) r.f += 0x1p14*(f + (z - r.f)); + return r.f; + } else { + if(__builtin_expect(ux>=0xbf800000u||ax>=0x7f800000u, 0)) return as_special(x); + b64u64_u tp = {.f = z + 1}; + int e = tp.u>>52; + uint64_t m52 = tp.u&(~(uint64_t)0>>12); + unsigned j = (tp.u >> (52-5))&31; + e -= 0x3ff; + b64u64_u xd = {.u = m52 | ((uint64_t)0x3ff<<52)}; + z = xd.f*x0[j] - 1; + static const double c[] = + {-0x1.3902c33434e7fp-43, 0x1.ffffffe1cbed5p-1, -0x1.ffffff7d1b014p-2, 0x1.5564e0ed3613ap-2, -0x1.0012232a00d4ap-2}; + const double ln2 = 0x1.62e42fefa39efp-1; + double z2 = z*z, r = (ln2*e + lixb[j]) + z*((c[1] + z*c[2]) + z2*(c[3] + z*c[4])); + float ub = r, lb = r + 2.2e-11; + if(__builtin_expect(ub != lb, 0)){ + double z4 = z2*z2, f = z*((b[0] + z*b[1]) + z2*(b[2] + z*b[3]) + z4*((b[4] + z*b[5]) + z2*(b[6] + z*b[7]))); + const double ln2l = 0x1.7f7d1cf79abcap-20, ln2h = 0x1.62e4p-1; + double Lh = ln2h * e, Ll = ln2l * e, rl = f + Ll + lix[j]; + b64u64_u tr = {.f = rl + Lh}; + if(__builtin_expect((tr.u&0xfffffffll) == 0 , 0)){ + if(x==-0x1.247ab0p-6) return -0x1.271f0ep-6f - 0x1p-31f; + if(x==-0x1.3a415ep-5) return -0x1.407112p-5f + 0x1p-30f; + if(x== 0x1.fb035ap-2) return 0x1.9bddc2p-2f + 0x1p-27f; + tr.f += 64*(rl + (Lh - tr.f)); + } else if(rl+(Lh-tr.f)==0.0){ + if(x== 0x1.b7fd86p-4) return 0x1.a1ece2p-4f + 0x1p-29f; + if(x==-0x1.3a415ep-5) return -0x1.407112p-5f + 0x1p-30f; + if(x== 0x1.43c7e2p-6) return 0x1.409f80p-6f + 0x1p-31f; + } + ub = tr.f; + } + return ub; + } +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c430d75d10ac4715177157… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c430d75d10ac4715177157… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-435-add-core-math-compile-code
by Raymond Toy (＠rtoy) 25 Feb '26

25 Feb '26

Raymond Toy pushed new branch issue-435-add-core-math-compile-code at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-435-add-core-math-c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Address #435: Add single-float core-math routines
by Raymond Toy (＠rtoy) 25 Feb '26

25 Feb '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d09876ca by Raymond Toy at 2026-02-24T16:05:24-08:00 Address #435: Add single-float core-math routines - - - - - c430d75d by Raymond Toy at 2026-02-24T16:05:24-08:00 Merge branch 'issue-435-add-core-math-code-only' into 'master' Address #435: Add single-float core-math routines See merge request cmucl/cmucl!354 - - - - - 26 changed files: - + src/lisp/core-math/src/binary32/acos/acosf.c - + src/lisp/core-math/src/binary32/acosh/acoshf.c - + src/lisp/core-math/src/binary32/asin/asinf.c - + src/lisp/core-math/src/binary32/asinh/asinhf.c - + src/lisp/core-math/src/binary32/atan/atanf.c - + src/lisp/core-math/src/binary32/atan2/atan2f.c - + src/lisp/core-math/src/binary32/atanh/atanhf.c - + src/lisp/core-math/src/binary32/cos/cosf.c - + src/lisp/core-math/src/binary32/cosh/coshf.c - + src/lisp/core-math/src/binary32/exp/expf.c - + src/lisp/core-math/src/binary32/exp2m1/Makefile - + src/lisp/core-math/src/binary32/exp2m1/check_special.c - + src/lisp/core-math/src/binary32/exp2m1/exp2m1f.c - + src/lisp/core-math/src/binary32/exp2m1/exp2m1f.wc - + src/lisp/core-math/src/binary32/exp2m1/exp2m1f_mpfr.c - + src/lisp/core-math/src/binary32/expm1/expm1f.c - + src/lisp/core-math/src/binary32/hypot/hypotf.c - + src/lisp/core-math/src/binary32/log/logf.c - + src/lisp/core-math/src/binary32/log10/log10f.c - + src/lisp/core-math/src/binary32/log2/log2f.c - + src/lisp/core-math/src/binary32/pow/powf.c - + src/lisp/core-math/src/binary32/sin/sinf.c - + src/lisp/core-math/src/binary32/sincos/sincosf.c - + src/lisp/core-math/src/binary32/sinh/sinhf.c - + src/lisp/core-math/src/binary32/tan/tanf.c - + src/lisp/core-math/src/binary32/tanh/tanhf.c The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3434a96310bce31753072e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3434a96310bce31753072e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-435-add-core-math-code-only
by Raymond Toy (＠rtoy) 25 Feb '26

25 Feb '26

Raymond Toy pushed new branch issue-435-add-core-math-code-only at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-435-add-core-math-c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] ETYPECASE.15 is passing now
by Raymond Toy (＠rtoy) 24 Feb '26

24 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: a72ebe85 by Raymond Toy at 2026-02-24T07:12:44-08:00 ETYPECASE.15 is passing now For some reason ETYPECASE.15 is passing, so use the ansi-test branch cmucl-expected-failures instead of cmucl-expected-failures-etypecase.15. - - - - - 1 changed file: - bin/run-ansi-tests.sh Changes: ===================================== bin/run-ansi-tests.sh ===================================== @@ -36,7 +36,7 @@ shift $((OPTIND - 1)) # Use branch cmucl-expected-failures in general since this branch # generally has the list of expected failures. This is the branch to # use on cmucl master in general. -BRANCH=cmucl-expected-failures-etypecase.15 +BRANCH=cmucl-expected-failures set -x if [ -d ../ansi-test ]; then View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a72ebe85432251c61a8cc9f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a72ebe85432251c61a8cc9f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] 3 commits: Revert changes that added extra blank lines at the end
by Raymond Toy (＠rtoy) 24 Feb '26

24 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: 538acc32 by Raymond Toy at 2026-02-23T19:18:53-05:00 Revert changes that added extra blank lines at the end - - - - - fd6d177f by Raymond Toy at 2026-02-23T19:19:14-05:00 Full remove old version of parse-hex-float. We use ext:parse-hex-float now. - - - - - 02e0f002 by Raymond Toy at 2026-02-23T18:27:46-08:00 Update release notes and cmucl.pot [skip-ci] - - - - - 4 changed files: - src/code/extensions.lisp - src/general-info/release-22a.md - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/extensions.lisp ===================================== @@ -724,7 +724,3 @@ ;; contents. Is there a better way? (when ,dirname (delete-directory ,dirname :recursive t)))))) - - - - ===================================== src/general-info/release-22a.md ===================================== @@ -57,6 +57,7 @@ public domain. * #460: Unit tests were not being recognized as failing on CI. * #463: `double-double-float` is missing comparison operations between `double-double-float` and `double-float` + * #474: Add functions to print and parse C-style hex floats. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6060,6 +6060,38 @@ msgid "" " afterward." msgstr "" +#: src/code/ext-code.lisp +msgid "" +"Prints a single or double float in bit-perfect C-style hex.\n" +" If AT-P is true, prepends '+' for non-negative finite values." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Convert FLOAT to C-style hex string and write it to STREAM.\n" +" Infinities are printed as \"-inf\" and \"inf\". NaN is printed as\n" +" \"nan\"." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Formatter for ~/ext:format-hex-float/. \n" +" Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Reads a C-style hex float number from STREAM. A single-float or\n" +" double-float number is returned. A HEX-PARSE-ERROR is signaled for\n" +" an invalid format." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Parse a C-style hex float number from OBJ which is either a string or a " +"stream." +msgstr "" + #: src/code/commandline.lisp msgid "A list of all the command line arguments after --" msgstr "" ===================================== tests/float.lisp ===================================== @@ -579,27 +579,6 @@ (assert-equal -2w300 (* -2w300 1w0))) - - -;; Rudimentary code to read C %a formatted numbers that look like -;; "-0x1.c4dba4ba1ee79p-620". We assume STRING is exactly in this -;; format. No error-checking is done. -#+nil -(defun ext:parse-hex-float (string) - (let* ((sign (if (char= (aref string 0) #\-) - -1 - 1)) - (dot-posn (position #\. string)) - (p-posn (position #\p string)) - (lead (parse-integer string :start (1- dot-posn) :end dot-posn)) - (frac (parse-integer string :start (1+ dot-posn) :end p-posn :radix 16)) - (exp (parse-integer string :start (1+ p-posn)))) - (* sign - (scale-float (float (+ (ash lead 52) - frac) - 1d0) - (- exp 52))))) - ;; Relative error in terms of bits of accuracy. This is the ;; definition used by Baudin and Smith. A result of 53 means the two ;; numbers have identical bits. For complex numbers, we use the min View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68e2a5c280e67ce1b4457e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68e2a5c280e67ce1b4457e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] 3 commits: Refactoring and renaming for final API
by Raymond Toy (＠rtoy) 24 Feb '26

24 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: 029170e8 by Raymond Toy at 2026-02-23T19:11:09-05:00 Refactoring and renaming for final API Merged the separate single and double hex printer into FLOAT-TO-HEX-STRING. Added WRITE-HEX-FLOAT that writes a float to the given stream, like WRITE-STRING, except for hex floats. FORMAT-HEX-FLOAT simplified to use FLOAT-TO-HEX-STRING. PARSE-HEX-FLOAT converts a hex float number from either a string or a stream. - - - - - 03794011 by Raymond Toy at 2026-02-23T19:14:14-05:00 Update exports for new API - - - - - 68e2a5c2 by Raymond Toy at 2026-02-23T19:14:33-05:00 Update tests to use the new names. - - - - - 3 changed files: - src/code/exports.lisp - src/code/ext-code.lisp - tests/extensions.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1370,7 +1370,8 @@ "REMOVE-PACKAGE-LOCAL-NICKNAME" "PACKAGE-LOCALLY-NICKNAMED-BY-LIST") ;; Printing and parsing of C-style hex floats - (:export "PRINT-HEX-FLOAT" + (:export "FLOAT-TO-HEX-STRING" + "WRITE-HEX-FLOAT" "FORMAT-HEX-FLOAT" "HEX-PARSE-ERROR" "PARSE-HEX-FLOAT")) ===================================== src/code/ext-code.lisp ===================================== @@ -21,100 +21,69 @@ (intl:textdomain "cmucl") -;;; C-style hex float printer and parser -(defun print-hex-single-float (val) - "Prints a single-float in C-style hex format." - (cond ((float-nan-p val) - "nan") - ((float-infinity-p val) - (if (plusp val) "inf" "-inf")) - ((zerop val) - (if (eql val -0.0f0) - "-0x0.0p+0f" "0x0.0p+0f")) - (t - (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val))) - (sign (ldb (byte 1 31) bits)) - (exp-bits (ldb (byte 8 23) bits)) - (mantissa (ldb (byte 23 0) bits)) - ;; Print lower-case hex digits. - (*print-case* :downcase)) - (if (zerop exp-bits) - ;; Subnormal: Leading digit 0, exponent fixed at -126 - (format nil "~A0x0.~6,'0Xp-126f" - (if (= sign 1) "-" "") - (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits) - ;; Normalized: Leading digit 1, exponent bias 127 - (format nil "~A0x1.~6,'0Xp~Af" - (if (= sign 1) "-" "") - (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits) - (- exp-bits 127))))))) - -(defun print-hex-double-float (val) - "Prints a double-float in C-style hex format." - (cond ((float-nan-p val) - "nan") - ((float-infinity-p val) - (if (plusp val) "inf" "-inf")) - ((zerop val) - (if (eql val -0.0d0) - "-0x0.0p+0" "0x0.0p+0")) - (t - (multiple-value-bind (hi-bits lo-bits) - (kernel:double-float-bits val) - (let* ((hi (ldb (byte 32 0) hi-bits)) - (lo (ldb (byte 32 0) lo-bits)) - (sign (ldb (byte 1 31) hi)) - (exp-bits (ldb (byte 11 20) hi)) - ;; Combine 20 bits from high word and 32 bits from low word - (mantissa (logior (ash (ldb (byte 20 0) hi) 32) - lo)) - ;; Print lower-case hex digits. - (*print-case* :downcase)) - (if (zerop exp-bits) - ;; Subnormal: Leading digit 0, exponent fixed at -1022 - (format nil "~A0x0.~13,'0Xp-1022" - (if (= sign 1) "-" "") - mantissa) - ;; Normalized: Leading digit 1, exponent bias 1023 - (format nil "~A0x1.~13,'0Xp~A" - (if (= sign 1) "-" "") - mantissa ; 52 bits fits 13 hex digits perfectly - (- exp-bits 1023)))))))) +;;;; C-style hex float printer and parser -;;; PRINT-HEX-FLOAT -- Public +;;; FLOAT-TO-HEX-STRING -- Public ;;; ;;; Return a string representing a single and double-floats in C-style ;;; hex format. -(defun print-hex-float (float) - "Convert FLOAT to C-style hex string. Infinities are printed as \"-inf\" - and \"inf\". NaN is printed as \"nan\"." +(defun float-to-hex-string (val &optional at-p) + "Prints a single or double float in bit-perfect C-style hex. + If AT-P is true, prepends '+' for non-negative finite values." + (cond ((ext:float-nan-p val) "nan") + ((ext:float-infinity-p val) + (if (plusp val) (if at-p "+inf" "inf") "-inf")) + (t + (multiple-value-bind (sign exp-bits mantissa bias precision suffix) + (typecase val + (single-float + (let ((bits (ldb (byte 32 0) (kernel:single-float-bits val)))) + (values (ldb (byte 1 31) bits) + (ldb (byte 8 23) bits) + (ash (ldb (byte 23 0) bits) 1) ; Align 23 to 6 hex digits + 127 6 "f"))) + (double-float + (multiple-value-bind (hi lo) (kernel:double-float-bits val) + (values (ldb (byte 1 31) hi) + (ldb (byte 11 20) hi) + (logior (ash (ldb (byte 20 0) hi) 32) (ldb (byte 32 0) lo)) + 1023 13 ""))) + (t (error "Unsupported float type: ~S" (type-of val)))) + + (let ((sign-str (cond ((= sign 1) "-") + (at-p "+") + (t "")))) + (if (and (zerop exp-bits) (zerop mantissa)) + (format nil "~A0x0.0p+0~A" sign-str suffix) + (format nil "~A0x~A.~V,'0Xp~A~A" + sign-str + (if (zerop exp-bits) "0" "1") + precision + mantissa + (if (zerop exp-bits) (1+ (- bias)) (- exp-bits bias)) + suffix))))))) + +;;; WRITE-HEX-FLOAT -- Public +;;; +;;; Writes a float number in C-style hex format to the given stream. +(defun write-hex-float (float &optional (stream *standard-output*)) + "Convert FLOAT to C-style hex string and write it to STREAM. + Infinities are printed as \"-inf\" and \"inf\". NaN is printed as + \"nan\"." (declare (float float)) - (etypecase float - (single-float (print-hex-single-float float)) - (double-float (print-hex-double-float float)))) + (write-string (float-to-hex-string float) + stream)) ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ (defun format-hex-float (stream arg colon-p at-sign-p &optional width) "Formatter for ~/ext:format-hex-float/. - @ forces sign (+/-). Colon modifier is ignored as per request." + Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored." (declare (ignore width colon-p)) - (let ((str (if (typep arg 'single-float) - (print-hex-single-float arg) - (print-hex-double-float arg)))) - ;; Prepend '+' if @ is used and number isn't negative or special - (when (and at-sign-p - (not (ext:float-nan-p arg)) - (not (ext:float-infinity-p arg)) - (not (char= (char str 0) #\-))) - (write-char #\+ stream)) - (write-string str stream))) + (write-string (float-to-hex-string arg at-sign-p) + stream)) -;;; PARSE-HEX-FLOAT -- Public -;;; -;;; Parse a C-style float hex strings. Always returns a double-float. -;;; Error-checking is enabled for malformed strings. (define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) @@ -122,68 +91,14 @@ (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) -#+nil -(defun parse-hex-float (str) - "Parses hex floats using scale-float for the exponent. Strictly hex-literal only." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) - (string-downcase str))) - (len (length str))) - (when (zerop len) - (error 'hex-parse-error :text str :message "Empty string")) - - (let* ((ends-with-f (and (> len 1) - (char= (char str (1- len)) #\f))) - (effective-len (if ends-with-f - (1- len) len)) - (prototype (if ends-with-f - 1.0f0 1.0d0)) - (has-sign (or (char= (char str 0) #\-) - (char= (char str 0) #\+))) - (sign (if (and has-sign - (char= (char str 0) #\-)) - -1 1)) - (start (if has-sign 1 0))) - - (unless (and (<= (+ start 2) effective-len) - (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - - (let ((p-pos (position #\p str :start start :end effective-len))) - (unless p-pos - (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos)) - ;; Leading hex: digits before the dot - (leading-str (subseq str sig-start (or dot-pos p-pos))) - ;; Trailing hex: digits after the dot - (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) "")) - (has-digits (or (plusp (length leading-str)) - (plusp (length trailing-str))))) - - (unless has-digits - (error 'hex-parse-error :text str :message "No hex digits in significand")) - - (handler-case - (let* ((leading-int (if (string= leading-str "") 0 - (parse-integer leading-str :radix 16))) - (trailing-len (length trailing-str)) - (trailing-int (if (string= trailing-str "") 0 - (parse-integer trailing-str :radix 16))) - ;; Calculate the significand as a float: leading + (trailing / 16^len) - (significand (float (+ leading-int - (/ trailing-int (expt 16 trailing-len))) - prototype)) - ;; The exponent after 'p' - (raw-exponent (parse-integer str :start exp-start :end effective-len))) - ;; Use scale-float to apply the binary exponent efficiently - (* sign (scale-float significand raw-exponent))) - (error (c) - (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) - +;;; PARSE-HEX-FLOAT-FROM-STREAM -- Public +;;; +;;; Parse a C-style float hex string from a stream. Invalid formats +;;; signal an error. A single-float or double-float may be returned. (defun parse-hex-float-from-stream (stream) - "Reads hex float from stream using double-float accumulation and a 6-character exponent buffer." + "Reads a C-style hex float number from STREAM. A single-float or + double-float number is returned. A HEX-PARSE-ERROR is signaled for + an invalid format." (let* ((sign 1.0d0) (char (peek-char t stream))) ; Skip whitespace @@ -251,6 +166,15 @@ (float result 1.0f0) result))))))) -(defun parse-hex-float (str) - (with-input-from-string (s str) - (parse-hex-float-from-stream s))) +;;; PARSE-HEX-FLOAT -- Public +;;; +;;; Parse a C-style hex float number from either a string or a stream. +(defun parse-hex-float (obj) + "Parse a C-style hex float number from OBJ which is either a string or a stream." + (declare (type (or string stream) obj)) + (etypecase obj + (string + (with-input-from-string (s obj) + (parse-hex-float-from-stream s))) + (stream + (parse-hex-float-from-stream obj)))) ===================================== tests/extensions.lisp ===================================== @@ -21,34 +21,45 @@ (:tag :precision) ;; Double Precision (-1022 Cliff) - (assert-equal #x0010000000000000 (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) - (assert-equal #x000fffffffffffff (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) - (assert-equal #x001f0195cb356b8f (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) + (assert-equal #x0010000000000000 + (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) + (assert-equal #x000fffffffffffff + (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) + (assert-equal #x001f0195cb356b8f + (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) ;; Single Precision (-126 Cliff) - (assert-equal #x00800000 (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) - (assert-equal #x00400000 (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) - (assert-equal #x7f7fffff (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) + (assert-equal #x00800000 + (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) + (assert-equal #x00400000 + (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) + (assert-equal #x7f7fffff + (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) (define-test test-negative-zero (:tag :edge-cases) - (assert-equal #x8000000000000000 (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) - (assert-equal #x80000000 (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) - (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float))) + (assert-equal #x8000000000000000 + (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) + (assert-equal #x80000000 + (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) + (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") + 'single-float))) (define-test test-subnormal-boundaries (:tag :edge) ;; Test smallest single-float subnormal (let* ((val (kernel:make-single-float 1)) - (str (ext::print-hex-single-float val)) + (str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed))) + (assert-equal (get-single-bits val) (get-single-bits parsed) + val str parsed)) ;; Test smallest double-float subnormal (let* ((val (kernel:make-double-float 0 1)) - (str (ext::print-hex-double-float val)) + (str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed)))) + (assert-equal (get-double-bits val) (get-double-bits parsed) + val str parsed))) (define-test test-double-roundtrip (:tag :stress) @@ -58,9 +69,11 @@ (lo (random #x100000000)) (val (kernel:make-double-float hi lo))) (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) - (let* ((str (ext::print-hex-double-float val)) + (let* ((str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed))))))) + (assert-equal (get-double-bits val) + (get-double-bits parsed) + val str parsed)))))) (define-test test-single-roundtrip (:tag :stress) @@ -69,6 +82,8 @@ (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw)) (val (kernel:make-single-float bits))) (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) - (let* ((str (concatenate 'string (ext::print-hex-single-float val) "f")) + (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f")) (parsed (ext:parse-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed))))))) + (assert-equal (get-single-bits val) + (get-single-bits parsed) + val str parsed)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/71da2451e58a3fb02bc9a3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/71da2451e58a3fb02bc9a3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] 4 commits: Some minor indentation formatting
by Raymond Toy (＠rtoy) 23 Feb '26

23 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: ab9e4523 by Raymond Toy at 2026-02-23T07:47:51-08:00 Some minor indentation formatting Makes things a little easier to read. - - - - - 950d0c30 by Raymond Toy at 2026-02-23T08:54:02-08:00 Add parse-hex-float-from-stream As an experiment, we added code to parse hex floats from a stream. And implemented parse-hex-float via parse-hex-float-from-stream. Tests pass. Also updated print-hex-single-float to append an "f" on the output. - - - - - 5e8ecebb by Raymond Toy at 2026-02-23T09:08:54-08:00 Fix format-hex-float to work with printers - - - - - 71da2451 by Raymond Toy at 2026-02-23T09:14:12-08:00 Add some tests for subnormal boundaries - - - - - 2 changed files: - src/code/ext-code.lisp - tests/extensions.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -23,39 +23,53 @@ ;;; C-style hex float printer and parser (defun print-hex-single-float (val) - "Prints a single-float in bit-perfect C-style hex using raw bits." - (cond ((float-nan-p val) "nan") - ((float-infinity-p val) (if (plusp val) "inf" "-inf")) - ((zerop val) (if (eql val -0.0f0) "-0x0.0p+0" "0x0.0p+0")) + "Prints a single-float in C-style hex format." + (cond ((float-nan-p val) + "nan") + ((float-infinity-p val) + (if (plusp val) "inf" "-inf")) + ((zerop val) + (if (eql val -0.0f0) + "-0x0.0p+0f" "0x0.0p+0f")) (t (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val))) (sign (ldb (byte 1 31) bits)) (exp-bits (ldb (byte 8 23) bits)) - (mantissa (ldb (byte 23 0) bits))) + (mantissa (ldb (byte 23 0) bits)) + ;; Print lower-case hex digits. + (*print-case* :downcase)) (if (zerop exp-bits) ;; Subnormal: Leading digit 0, exponent fixed at -126 - (format nil "~A0x0.~6,'0Xp-126" + (format nil "~A0x0.~6,'0Xp-126f" (if (= sign 1) "-" "") (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits) ;; Normalized: Leading digit 1, exponent bias 127 - (format nil "~A0x1.~6,'0Xp~A" + (format nil "~A0x1.~6,'0Xp~Af" (if (= sign 1) "-" "") (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits) (- exp-bits 127))))))) (defun print-hex-double-float (val) - "Prints a double-float in bit-perfect C-style hex using raw bits." - (cond ((float-nan-p val) "nan") - ((float-infinity-p val) (if (plusp val) "inf" "-inf")) - ((zerop val) (if (eql val -0.0d0) "-0x0.0p+0" "0x0.0p+0")) + "Prints a double-float in C-style hex format." + (cond ((float-nan-p val) + "nan") + ((float-infinity-p val) + (if (plusp val) "inf" "-inf")) + ((zerop val) + (if (eql val -0.0d0) + "-0x0.0p+0" "0x0.0p+0")) (t - (multiple-value-bind (hi-bits lo-bits) (kernel:double-float-bits val) + (multiple-value-bind (hi-bits lo-bits) + (kernel:double-float-bits val) (let* ((hi (ldb (byte 32 0) hi-bits)) (lo (ldb (byte 32 0) lo-bits)) (sign (ldb (byte 1 31) hi)) (exp-bits (ldb (byte 11 20) hi)) ;; Combine 20 bits from high word and 32 bits from low word - (mantissa (logior (ash (ldb (byte 20 0) hi) 32) lo))) + (mantissa (logior (ash (ldb (byte 20 0) hi) 32) + lo)) + ;; Print lower-case hex digits. + (*print-case* :downcase)) (if (zerop exp-bits) ;; Subnormal: Leading digit 0, exponent fixed at -1022 (format nil "~A0x0.~13,'0Xp-1022" @@ -82,38 +96,52 @@ ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ -(defun format-hex-float (stream val &optional colon-p at-p &rest params) - "Format ~/ directive supporting @ (sign) modifier for single/double floats." - (declare (ignore colon-p params)) - (write-string - (typecase val - (single-float (print-hex-single-float val at-p)) - (double-float (print-hex-double-float val at-p)) - (t (format nil "~A" val))) - stream)) +(defun format-hex-float (stream arg colon-p at-sign-p &optional width) + "Formatter for ~/ext:format-hex-float/. + @ forces sign (+/-). Colon modifier is ignored as per request." + (declare (ignore width colon-p)) + (let ((str (if (typep arg 'single-float) + (print-hex-single-float arg) + (print-hex-double-float arg)))) + ;; Prepend '+' if @ is used and number isn't negative or special + (when (and at-sign-p + (not (ext:float-nan-p arg)) + (not (ext:float-infinity-p arg)) + (not (char= (char str 0) #\-))) + (write-char #\+ stream)) + (write-string str stream))) ;;; PARSE-HEX-FLOAT -- Public ;;; ;;; Parse a C-style float hex strings. Always returns a double-float. ;;; Error-checking is enabled for malformed strings. -(define-condition hex-parse-error (error) +(define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) (:report (lambda (c s) (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) +#+nil (defun parse-hex-float (str) "Parses hex floats using scale-float for the exponent. Strictly hex-literal only." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) + (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) + (string-downcase str))) (len (length str))) - (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) + (when (zerop len) + (error 'hex-parse-error :text str :message "Empty string")) - (let* ((ends-with-f (and (> len 1) (char= (char str (1- len)) #\f))) - (effective-len (if ends-with-f (1- len) len)) - (prototype (if ends-with-f 1.0f0 1.0d0)) - (has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) - (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) + (let* ((ends-with-f (and (> len 1) + (char= (char str (1- len)) #\f))) + (effective-len (if ends-with-f + (1- len) len)) + (prototype (if ends-with-f + 1.0f0 1.0d0)) + (has-sign (or (char= (char str 0) #\-) + (char= (char str 0) #\+))) + (sign (if (and has-sign + (char= (char str 0) #\-)) + -1 1)) (start (if has-sign 1 0))) (unless (and (<= (+ start 2) effective-len) @@ -121,7 +149,8 @@ (error 'hex-parse-error :text str :message "Missing '0x' prefix")) (let ((p-pos (position #\p str :start start :end effective-len))) - (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) + (unless p-pos + (error 'hex-parse-error :text str :message "Missing exponent 'p'")) (let* ((sig-start (+ start 2)) (dot-pos (position #\. str :start sig-start :end p-pos)) @@ -130,7 +159,8 @@ (leading-str (subseq str sig-start (or dot-pos p-pos))) ;; Trailing hex: digits after the dot (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) "")) - (has-digits (or (plusp (length leading-str)) (plusp (length trailing-str))))) + (has-digits (or (plusp (length leading-str)) + (plusp (length trailing-str))))) (unless has-digits (error 'hex-parse-error :text str :message "No hex digits in significand")) @@ -149,4 +179,78 @@ (raw-exponent (parse-integer str :start exp-start :end effective-len))) ;; Use scale-float to apply the binary exponent efficiently (* sign (scale-float significand raw-exponent))) - (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) + (error (c) + (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) + +(defun parse-hex-float-from-stream (stream) + "Reads hex float from stream using double-float accumulation and a 6-character exponent buffer." + (let* ((sign 1.0d0) + (char (peek-char t stream))) ; Skip whitespace + + ;; 1. Handle Sign + (when (member char '(#\+ #\-)) + (when (char= (read-char stream) #\-) (setf sign -1.0d0)) + (setf char (peek-char nil stream))) + + ;; 2. Verify '0x' Prefix + (unless (and (char-equal (read-char stream) #\0) + (char-equal (read-char stream) #\x)) + (error 'hex-parse-error :text "Stream" :message "Missing '0x' prefix")) + + ;; 3. Read Significand + (let ((val 0.0d0) + (digits-read 0)) + ;; Integer part loop + (loop for c = (peek-char nil stream nil nil) + for digit = (and c (digit-char-p c 16)) + while digit + do (read-char stream) + (setf val (+ (* val 16.0d0) digit)) + (incf digits-read)) + + ;; Fractional part loop + (when (eql (peek-char nil stream nil nil) #\.) + (read-char stream) ; Consume #\. + (loop with weight = (/ 1.0d0 16.0d0) + for c = (peek-char nil stream nil nil) + for digit = (and c (digit-char-p c 16)) + while digit + do (read-char stream) + (setf val (+ val (* digit weight))) + (setf weight (/ weight 16.0d0)) + (incf digits-read))) + + (unless (plusp digits-read) + (error 'hex-parse-error :text "Stream" :message "No hex digits in significand")) + + ;; 4. Handle Exponent 'p' + (let ((p-char (read-char stream nil))) + (unless (and p-char (char-equal p-char #\p)) + (error 'hex-parse-error :text "Stream" :message "Missing exponent 'p'")) + + ;; Size 6 handles sign + 3-4 digits + buffer + (let ((exp-str (make-array 6 :element-type 'character + :fill-pointer 0 + :adjustable t))) + (loop for c = (peek-char nil stream nil nil) + while (and c (find c "+-0123456789")) + do (vector-push-extend (read-char stream) exp-str)) + + (when (zerop (length exp-str)) + (error 'hex-parse-error :text "Stream" :message "Invalid or missing exponent")) + + (let* ((raw-exp (parse-integer exp-str)) + (suffix (peek-char nil stream nil #\Space)) + (is-single (char-equal suffix #\f)) + ;; Final Construction + (result (* sign (scale-float val raw-exp)))) + + (when is-single (read-char stream)) ; Consume 'f' + + (if is-single + (float result 1.0f0) + result))))))) + +(defun parse-hex-float (str) + (with-input-from-string (s str) + (parse-hex-float-from-stream s))) ===================================== tests/extensions.lisp ===================================== @@ -37,6 +37,19 @@ (assert-equal #x80000000 (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float))) +(define-test test-subnormal-boundaries + (:tag :edge) + ;; Test smallest single-float subnormal + (let* ((val (kernel:make-single-float 1)) + (str (ext::print-hex-single-float val)) + (parsed (ext:parse-hex-float str))) + (assert-equal (get-single-bits val) (get-single-bits parsed))) + ;; Test smallest double-float subnormal + (let* ((val (kernel:make-double-float 0 1)) + (str (ext::print-hex-double-float val)) + (parsed (ext:parse-hex-float str))) + (assert-equal (get-double-bits val) (get-double-bits parsed)))) + (define-test test-double-roundtrip (:tag :stress) (loop repeat 10000 do View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b32b761d8abf7d62fb04c3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b32b761d8abf7d62fb04c3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0