[armedbear-cvs] r11569 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Mon Jan 19 09:36:19 UTC 2009
Author: ehuelsmann
Date: Mon Jan 19 09:36:06 2009
New Revision: 11569
Log:
Eliminate float-serializing ambiguities: if you need a float/double, store one
(instead of reading it from a string).
Modified:
trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java Mon Jan 19 09:36:06 2009
@@ -33,6 +33,8 @@
package org.armedbear.lisp;
+import java.math.BigInteger;
+
public final class FloatFunctions extends Lisp
{
// ### set-floating-point-modes &key traps => <no values>
@@ -142,6 +144,27 @@
}
};
+ // ### %float-bits float => integer
+ private static final Primitive _FLOAT_BITS =
+ new Primitive("%float-bits", "integer")
+ {
+ @Override
+ public LispObject execute(LispObject arg) throws ConditionThrowable
+ {
+ if (arg instanceof SingleFloat) {
+ int bits = Float.floatToIntBits(((SingleFloat)arg).value);
+ BigInteger big = BigInteger.valueOf(bits >> 1);
+ return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
+ }
+ if (arg instanceof DoubleFloat) {
+ long bits = Double.doubleToLongBits(((DoubleFloat)arg).value);
+ BigInteger big = BigInteger.valueOf(bits >> 1);
+ return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO));
+ }
+ return type_error(arg, Symbol.FLOAT);
+ }
+ };
+
// ### rational
private static final Primitive RATIONAL =
new Primitive("rational", "number")
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Jan 19 09:36:06 2009
@@ -129,6 +129,11 @@
(declare (optimize speed))
(pool-get (list 3 n)))
+(defknown pool-float (single-float) (integer 1 65535))
+(defun pool-float (n)
+ (declare (optimize speed))
+ (pool-get (list 4 (%float-bits n))))
+
(defknown pool-long (integer) (integer 1 65535))
(defun pool-long (n)
(declare (optimize speed))
@@ -152,6 +157,29 @@
(setf *pool-count* (+ index 2)))
index))
+(defknown pool-double (double-float) (integer 1 65535))
+(defun pool-double (n)
+ (declare (optimize speed))
+ (let* ((n (%float-bits n))
+ (entry (list 6
+ (logand (ash n -32) #xffffffff)
+ (logand n #xffffffff)))
+ (ht *pool-entries*)
+ (index (gethash1 entry ht)))
+ (declare (type hash-table ht))
+ (unless index
+ (setf index *pool-count*)
+ (push entry *pool*)
+ (setf (gethash entry ht) index)
+ ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte
+ ;; constants take up two entries in the constant_pool table of the class
+ ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the
+ ;; item in the constant_pool table at index n, then the next usable item in
+ ;; the pool is located at index n+2. The constant_pool index n+1 must be
+ ;; valid but is considered unusable." So:
+ (setf *pool-count* (+ index 2)))
+ index))
+
(defknown u2 (fixnum) cons)
(defun u2 (n)
(declare (optimize speed))
@@ -199,6 +227,10 @@
(defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
(defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum")
(defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;")
+(defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat")
+(defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;")
+(defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat")
+(defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;")
(defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter")
(defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;")
(defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;")
@@ -1553,14 +1585,14 @@
(declare (optimize speed))
(declare (type (unsigned-byte 16) n))
(declare (type stream stream))
- (write-8-bits (ash n -8) stream)
+ (write-8-bits (logand (ash n -8) #xFF) stream)
(write-8-bits (logand n #xFF) stream))
(defknown write-u4 (integer stream) t)
(defun write-u4 (n stream)
(declare (optimize speed))
(declare (type (unsigned-byte 32) n))
- (write-u2 (ash n -16) stream)
+ (write-u2 (logand (ash n -16) #xFFFF) stream)
(write-u2 (logand n #xFFFF) stream))
(declaim (ftype (function (t t) t) write-s4))
@@ -1630,15 +1662,15 @@
(case tag
(1 ; UTF8
(write-utf8 (third entry) stream))
- (3 ; int
- (write-s4 (second entry) stream))
- ((5 6)
+ ((3 4) ; int
+ (write-u4 (second entry) stream))
+ ((5 6) ; long double
(write-u4 (second entry) stream)
(write-u4 (third entry) stream))
- ((9 10 11 12)
+ ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType
(write-u2 (second entry) stream)
(write-u2 (third entry) stream))
- ((7 8)
+ ((7 8) ; class string
(write-u2 (second entry) stream))
(t
(error "write-constant-pool-entry unhandled tag ~D~%" tag)))))
@@ -2014,6 +2046,36 @@
(setf *static-code* *code*))))
(setf (gethash n ht) g)))
+(defknown declare-float (single-float) string)
+(defun declare-float (s)
+ (declare-with-hashtable
+ s *declared-floats* ht g
+ (let* ((*code* *static-code*))
+ (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym))))
+ (declare-field g +lisp-single-float+)
+ (emit 'new +lisp-single-float-class+)
+ (emit 'dup)
+ (emit 'ldc (pool-float s))
+ (emit-invokespecial-init +lisp-single-float-class+ '("F"))
+ (emit 'putstatic *this-class* g +lisp-single-float+)
+ (setf *static-code* *code*))
+ (setf (gethash s ht) g)))
+
+(defknown declare-double (double-float) string)
+(defun declare-double (d)
+ (declare-with-hashtable
+ d *declared-doubles* ht g
+ (let ((*code* *static-code*))
+ (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym))))
+ (declare-field g +lisp-double-float+)
+ (emit 'new +lisp-double-float-class+)
+ (emit 'dup)
+ (emit 'ldc2_w (pool-double d))
+ (emit-invokespecial-init +lisp-double-float-class+ '("D"))
+ (emit 'putstatic *this-class* g +lisp-double-float+)
+ (setf *static-code* *code*))
+ (setf (gethash d ht) g)))
+
(defknown declare-character (t) string)
(defun declare-character (c)
(let ((g (symbol-name (gensym)))
@@ -2201,6 +2263,12 @@
((integerp form)
;; A bignum.
(emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+))
+ ((typep form 'single-float)
+ (emit 'getstatic *this-class*
+ (declare-float form) +lisp-single-float+))
+ ((typep form 'double-float)
+ (emit 'getstatic *this-class*
+ (declare-double form) +lisp-double-float+))
((numberp form)
;; A number, but not a fixnum.
(emit 'getstatic *this-class*
Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Mon Jan 19 09:36:06 2009
@@ -85,6 +85,8 @@
(defvar *declared-functions* nil)
(defvar *declared-strings* nil)
(defvar *declared-integers* nil)
+(defvar *declared-floats* nil)
+(defvar *declared-doubles* nil)
(defstruct (class-file (:constructor %make-class-file))
pathname ; pathname of output file
@@ -101,7 +103,9 @@
(symbols (make-hash-table :test 'eq))
(functions (make-hash-table :test 'equal))
(strings (make-hash-table :test 'eq))
- (integers (make-hash-table :test 'eql)))
+ (integers (make-hash-table :test 'eql))
+ (floats (make-hash-table :test 'eql))
+ (doubles (make-hash-table :test 'eql)))
(defun class-name-from-filespec (filespec)
(let* ((name (pathname-name filespec)))
@@ -131,7 +135,9 @@
(*declared-symbols* (class-file-symbols ,var))
(*declared-functions* (class-file-functions ,var))
(*declared-strings* (class-file-strings ,var))
- (*declared-integers* (class-file-integers ,var)))
+ (*declared-integers* (class-file-integers ,var))
+ (*declared-floats* (class-file-floats ,var))
+ (*declared-doubles* (class-file-doubles ,var)))
(progn , at body)
(setf (class-file-pool ,var) *pool*
(class-file-pool-count ,var) *pool-count*
@@ -141,7 +147,9 @@
(class-file-symbols ,var) *declared-symbols*
(class-file-functions ,var) *declared-functions*
(class-file-strings ,var) *declared-strings*
- (class-file-integers ,var) *declared-integers*))))
+ (class-file-integers ,var) *declared-integers*
+ (class-file-floats ,var) *declared-floats*
+ (class-file-doubles ,var) *declared-doubles*))))
(defstruct compiland
name
More information about the armedbear-cvs
mailing list