/[cmucl]/src/bootfiles/19c/boot-2006-06-1.lisp
ViewVC logotype

Contents of /src/bootfiles/19c/boot-2006-06-1.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Jun 30 18:41:21 2006 UTC (7 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2007-01, snapshot-2007-02, release-19e, release-19d, GIT-CONVERSION, unicode-utf16-sync-2008-12, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, RELEASE_20b, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, release-19d-base, release-19e-pre1, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, label-2009-03-25, cross-sol-x86-2010-12-20, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, sse2-merge-with-2008-11, sse2-merge-with-2008-10, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, cross-sparc-branch-base, release-19e-base, intl-branch-base, unicode-utf16-base, portable-clx-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-07, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +47 -0 lines
This large checkin merges the double-double float support to HEAD.
The merge is from the tag "double-double-irrat-end".  The
double-double branch is now obsolete.

The code should build without double-double support (tested on sparc)
as well as build with double-double support (tested also on sparc).
1 ;;;; Bootstrap file for doing a full build from a cross-compile for
2 ;;;; double-double-float support. This needs to be done using the
3 ;;;; build from the cross-compile for double-double-float. See
4 ;;;; boot-2006-06-1-cross-dd-sparc.lisp for more info.
5 (in-package :cl-user)
6 (pushnew :double-double *features*)
7 (setf lisp::*enable-package-locked-errors* nil)
8
9 ;;; This is a hack. I need make-double-double-float,
10 ;;; double-double-hi, double-double-lo, and %double-double-float to
11 ;;; work. For some reason, the cross-compile makes these known
12 ;;; functions be infinite loops, but if we compile them here and setf
13 ;;; fdefinition we get workingness.
14 (defun %foo (x y)
15 (declare (double-float x y))
16 (kernel:%make-double-double-float x y))
17 (compile '%foo)
18
19
20
21 (defun foo-hi (x)
22 (declare (type kernel:double-double-float x))
23 (kernel:double-double-hi x))
24 (compile 'foo-hi)
25 (defun foo-lo (x)
26 (declare (type kernel:double-double-float x))
27 (kernel:double-double-lo x))
28 (compile 'foo-lo)
29 (defun %coerce-foo (x)
30 (if (typep x 'kernel:double-double-float)
31 x
32 (kernel:make-double-double-float (float x 1d0) 0d0)))
33 (compile '%foo)
34
35 (setf (fdefinition 'kernel::%make-double-double-float) #'%foo)
36 (setf (fdefinition 'kernel::double-double-hi) #'foo-hi)
37 (setf (fdefinition 'kernel::double-double-lo) #'foo-lo)
38 (setf (fdefinition 'kernel::%double-double-float) #'%coerce-foo)
39
40 (in-package "KERNEL")
41 (defun make-double-double-float (hi lo)
42 ;; Make sure the parts make sense for a double-double
43 (if (or (float-infinity-p hi) (float-nan-p hi))
44 (%make-double-double-float hi lo)
45 (multiple-value-bind (s e)
46 (c::two-sum hi lo)
47 (%make-double-double-float s e))))

  ViewVC Help
Powered by ViewVC 1.1.5