dev-lisp/clozurecl: fix bug with the ~e format

Upstream patch http://trac.clozure.com/ccl/changeset/16639
Bug: http://trac.clozure.com/ccl/ticket/563, http://trac.clozure.com/ccl/ticket/1186

Package-Manager: portage-2.2.25

2 files changed, 222 insertions, 0 deletions

diff --git a/dev-lisp/clozurecl/clozurecl-1.11-r1.ebuild b/dev-lisp/clozurecl/clozurecl-1.11-r1.ebuild
new file mode 100644
index 000000000000..5a39a3a71920
--- /dev/null
+++ b/dev-lisp/clozurecl/clozurecl-1.11-r1.ebuild
@@ -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
+}
diff --git a/dev-lisp/clozurecl/files/ccl-format.patch b/dev-lisp/clozurecl/files/ccl-format.patch
new file mode 100644
index 000000000000..c2df37c2b870
--- /dev/null
+++ b/dev-lisp/clozurecl/files/ccl-format.patch
@@ -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