Skip to content

Commit

Permalink
dev-lisp/clozurecl: fix bug with the ~e format
Browse files Browse the repository at this point in the history
  • Loading branch information
Andrey Grozin authored and ulm committed Nov 22, 2015
1 parent cd4d4fc commit dc9d07b
Show file tree
Hide file tree
Showing 2 changed files with 222 additions and 0 deletions.
94 changes: 94 additions & 0 deletions dev-lisp/clozurecl/clozurecl-1.11-r1.ebuild
Original file line number Diff line number Diff line change
@@ -0,0 +1,94 @@
# Copyright 1999-2015 Gentoo Foundation
# Distributed under the terms of the GNU General Public License v2
# $Id$

EAPI=6

inherit eutils multilib toolchain-funcs

MY_PN=ccl
MY_P=${MY_PN}-${PV}

DESCRIPTION="Common Lisp implementation, derived from Digitool's MCL product"
HOMEPAGE="http://ccl.clozure.com/"
SRC_URI="
x86? ( ftp://ftp.clozure.com/pub/release/${PV}/${MY_P}-linuxx86.tar.gz )
amd64? ( ftp://ftp.clozure.com/pub/release/${PV}/${MY_P}-linuxx86.tar.gz )
doc? ( http://ccl.clozure.com/docs/ccl.html )"
# ppc? ( ftp://ftp.clozure.com/pub/release/${PV}/${MY_P}-linuxppc.tar.gz )
# ppc64? ( ftp://ftp.clozure.com/pub/release/${PV}/${MY_P}-linuxppc.tar.gz )"

LICENSE="LLGPL-2.1"
SLOT="0"
# KEYWORDS="~amd64 ~ppc ~ppc64 ~x86"
KEYWORDS="~amd64 ~x86"
IUSE="doc"

RDEPEND=">=dev-lisp/asdf-2.33-r3:="
DEPEND="${RDEPEND}
!dev-lisp/openmcl"

S="${WORKDIR}"/${MY_PN}
PATCHES=( "${FILESDIR}"/ccl-format.patch )
ENVD="${T}"/50ccl

src_configure() {
if use x86; then
CCL_RUNTIME=lx86cl; CCL_HEADERS=x86-headers; CCL_KERNEL=linuxx8632
elif use amd64; then
CCL_RUNTIME=lx86cl64; CCL_HEADERS=x86-headers64; CCL_KERNEL=linuxx8664
elif use ppc; then
CCL_RUNTIME=ppccl; CCL_HEADERS=headers; CCL_KERNEL=linuxppc
elif use ppc64; then
CCL_RUNTIME=ppccl64; CCL_HEADERS=headers64; CCL_KERNEL=linuxppc64
fi
}

src_prepare() {
default
cp /usr/share/common-lisp/source/asdf/build/asdf.lisp tools/ || die
}

src_compile() {
emake -C lisp-kernel/${CCL_KERNEL} clean
emake -C lisp-kernel/${CCL_KERNEL} all CC="$(tc-getCC)"

unset CCL_DEFAULT_DIRECTORY
./${CCL_RUNTIME} -n -b -Q -e '(ccl:rebuild-ccl :full t)' -e '(ccl:quit)' || die "Compilation failed"

# remove non-owner write permissions on the full-image
chmod go-w ${CCL_RUNTIME}{,.image} || die

esvn_clean
}

src_install() {
local install_dir=/usr/$(get_libdir)/${PN}

exeinto ${install_dir}
# install executable
doexe ${CCL_RUNTIME}
# install core image
cp ${CCL_RUNTIME}.image "${D}"/${install_dir} || die
# install optional libraries
dodir ${install_dir}/tools
cp tools/*fsl "${D}"/${install_dir}/tools || die

# until we figure out which source files are necessary for runtime
# optional features and which aren't, we install all sources
find . -type f -name '*fsl' -delete || die
rm -f lisp-kernel/${CCL_KERNEL}/*.o || die
cp -a compiler level-0 level-1 lib library \
lisp-kernel scripts tools xdump contrib \
"${D}"/${install_dir} || die
cp -a ${CCL_HEADERS} "${D}"/${install_dir} || die

make_wrapper ccl "${install_dir}/${CCL_RUNTIME}"

echo "CCL_DEFAULT_DIRECTORY=${install_dir}" > "${ENVD}"
doenvd "${ENVD}"

dodoc doc/release-notes.txt
use doc && dodoc "${DISTDIR}"/ccl.html
use doc && dodoc -r examples
}
128 changes: 128 additions & 0 deletions dev-lisp/clozurecl/files/ccl-format.patch
Original file line number Diff line number Diff line change
@@ -0,0 +1,128 @@
diff -r -U1 ccl.orig/lib/format.lisp ccl/lib/format.lisp
--- ccl.orig/lib/format.lisp 2015-11-07 02:10:10.000000000 +0600
+++ ccl/lib/format.lisp 2015-11-20 22:51:51.736191995 +0600
@@ -1296,5 +1296,2 @@

-
-
-
;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
@@ -1305,41 +1302,74 @@

-
-(defconstant long-log10-of-2 0.30103d0)
-
-#|
-(defun scale-exponent (x)
- (if (floatp x )
- (scale-expt-aux (abs x) 0.0d0 1.0d0 1.0d1 1.0d-1 long-log10-of-2)
- (report-bad-arg x 'float)))
-
-#|this is the slisp code that was in the place of the error call above.
- before floatp was put in place of shortfloatp.
- ;(scale-expt-aux x (%sp-l-float 0) (%sp-l-float 1) %long-float-ten
- ; %long-float-one-tenth long-log10-of-2)))
-|#
-
-; this dies with floating point overflow (?) if fed least-positive-double-float
-
-(defun scale-expt-aux (x zero one ten one-tenth log10-of-2)
- (let ((exponent (nth-value 1 (decode-float x))))
- (if (= x zero)
- (values zero 1)
- (let* ((e (round (* exponent log10-of-2)))
- (x (if (minusp e) ;For the end ranges.
- (* x ten (expt ten (- -1 e)))
- (/ x ten (expt ten (1- e))))))
- (do ((d ten (* d ten))
- (y x (/ x d))
- (e e (1+ e)))
- ((< y one)
- (do ((m ten (* m ten))
- (z y (* z m))
- (e e (1- e)))
- ((>= z one-tenth) (values x e)))))))))
-|#
-
-(defun scale-exponent (n)
- (let ((exp (nth-value 1 (decode-float n))))
- (values (round (* exp long-log10-of-2)))))
-
+(defconstant single-float-min-e
+ (nth-value 1 (decode-float least-positive-single-float)))
+(defconstant double-float-min-e
+ (nth-value 1 (decode-float least-positive-double-float)))
+
+;;; Adapted from CMUCL.
+
+;; This is a modified version of the scale computation from Burger and
+;; Dybvig's paper "Printing floating-point quickly and accurately."
+;; We only want the exponent, so most things not needed for the
+;; computation of the exponent have been removed. We also implemented
+;; the floating-point log approximation given in Burger and Dybvig.
+;; This is very noticeably faster for large and small numbers. It is
+;; slower for intermediate sized numbers.
+(defun accurate-scale-exponent (v)
+ (declare (type float v))
+ (if (zerop v)
+ 1
+ (let ((float-radix 2) ; b
+ (float-digits (float-digits v)) ; p
+ (min-e
+ (etypecase v
+ (single-float single-float-min-e)
+ (double-float double-float-min-e))))
+ (multiple-value-bind (f e)
+ (integer-decode-float v)
+ (let ( ;; FIXME: these even tests assume normal IEEE rounding
+ ;; mode. I wonder if we should cater for non-normal?
+ (high-ok (evenp f)))
+ ;; We only want the exponent here.
+ (labels ((flog (x)
+ (declare (type (float (0.0)) x))
+ (let ((xd (etypecase x
+ (single-float
+ (float x 1d0))
+ (double-float
+ x))))
+ (ceiling (- (the (double-float -400d0 400d0)
+ (log xd 10d0))
+ 1d-10))))
+ (fixup (r s m+ k)
+ (if (if high-ok
+ (>= (+ r m+) s)
+ (> (+ r m+) s))
+ (+ k 1)
+ k))
+ (scale (r s m+)
+ (let* ((est (flog v))
+ (scale (the integer (10-to-e (abs est)))))
+ (if (>= est 0)
+ (fixup r (* s scale) m+ est)
+ (fixup (* r scale) s (* m+ scale) est)))))
+ (let (r s m+)
+ (if (>= e 0)
+ (let* ((be (expt float-radix e))
+ (be1 (* be float-radix)))
+ (if (/= f (expt float-radix (1- float-digits)))
+ (setf r (* f be 2)
+ s 2
+ m+ be)
+ (setf r (* f be1 2)
+ s (* float-radix 2)
+ m+ be1)))
+ (if (or (= e min-e)
+ (/= f (expt float-radix (1- float-digits))))
+ (setf r (* f 2)
+ s (* (expt float-radix (- e)) 2)
+ m+ 1)
+ (setf r (* f float-radix 2)
+ s (* (expt float-radix (- 1 e)) 2)
+ m+ float-radix)))
+ (scale r s m+))))))))

@@ -1922,3 +1952,3 @@
(format-error "incompatible values for k and d")))
- (when (not exp) (setq exp (scale-exponent number)))
+ (when (not exp) (setq exp (accurate-scale-exponent (abs number))))
AGAIN

0 comments on commit dc9d07b

Please sign in to comment.