--- a/Float.st	Thu Aug 19 02:17:59 1999 +0200
+++ b/Float.st	Thu Aug 19 03:20:08 1999 +0200
@@ -758,6 +758,77 @@
 %}
 !
 
+asTrueFraction
+    "Answer a fraction that EXACTLY represents self,
+     a double precision IEEE floating point number.
+     Floats are stored in the same form on all platforms.
+     (Does not handle gradual underflow or NANs.)
+     By David N. Smith with significant performance
+     improvements by Luciano Esteban Notarfrancesco.
+     (Version of 11April97)"
+
+    |shifty sign expPart exp fraction fractionPart result zeroBitsCount|
+
+    self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction'].
+    self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction'].
+
+    "Extract the bits of an IEEE double float "
+    UninterpretedBytes isBigEndian ifTrue:[
+"/        shifty := ((self basicAt: 1) bitShift: 32) + (self basicAt: 2).
+        shifty := LargeInteger basicNew numberOfDigits:8.
+        1 to:8 do:[:i | shifty digitAt:(9-i) put:(self basicAt:i)].
+    ] ifFalse:[
+        shifty := LargeInteger basicNew numberOfDigits:8.
+        1 to:8 do:[:i | shifty digitAt:i put:(self basicAt:i)].
+    ].
+
+    " Extract the sign and the biased exponent "
+    sign := (shifty bitShift: -63) = 0 ifTrue: [1] ifFalse: [-1].
+    expPart := (shifty bitShift: -52) bitAnd: 16r7FF.
+
+    " Extract fractional part; answer 0 if this is a true 0.0 value "
+    fractionPart := shifty bitAnd:  16r000FFFFFFFFFFFFF.
+    ( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0  ].
+
+    " Replace omitted leading 1 in fraction "
+    fraction := fractionPart bitOr: 16r0010000000000000.
+
+    "Unbias exponent: 16r3FF is bias; 52 is fraction width"
+    exp := 16r3FF + 52 - expPart.
+
+    " Form the result. When exp>52, the exponent is adjusted by
+      the number of trailing zero bits in the fraction to minimize
+      the (huge) time otherwise spent in #gcd:. "
+    exp negative ifTrue: [
+        result := sign * fraction bitShift: exp negated 
+    ] ifFalse:[
+        zeroBitsCount := fraction lowBit - 1.
+        exp := exp - zeroBitsCount.
+        exp <= 0 ifTrue: [
+            zeroBitsCount := zeroBitsCount + exp.
+            "exp := 0."   " Not needed; exp not refernced again "
+            result := sign * fraction bitShift:zeroBitsCount negated 
+        ] ifFalse: [
+            result := Fraction
+                    numerator: (sign * fraction bitShift: zeroBitsCount negated)
+                    denominator: (1 bitShift:exp) 
+        ] 
+    ].
+
+    "Low cost validation omitted after extensive testing"
+    "(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']."
+
+    ^ result 
+
+    "
+     0.3 asTrueFraction  
+     1.25 asTrueFraction
+     0.25 asTrueFraction  
+     -0.25 asTrueFraction  
+     3e37 asTrueFraction 
+    "
+!
+
 coerce:aNumber
     "return aNumber converted into receivers type"
 
@@ -1925,6 +1996,6 @@
 !Float class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/Float.st,v 1.100 1999-08-12 08:58:27 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/Float.st,v 1.101 1999-08-19 01:19:32 cg Exp $'
 ! !
 Float initialize!

--- a/LPReal.st	Thu Aug 19 02:17:59 1999 +0200
+++ b/LPReal.st	Thu Aug 19 03:20:08 1999 +0200
@@ -247,21 +247,25 @@
 
     ].
 
-    "/ NOTICE: this must be redefined in float
-    "/ subclasses to handle the smallinteger range;
-    "/ i.e. this may only be invoked for reals
-    "/ which are NOT within the smallInt range.
-    "/ otherwise, endless recursion is the consequence.
+    self abs < 2e16 ifTrue:[
+        "/ NOTICE: this must be redefined in float
+        "/ subclasses to handle the smallinteger range;
+        "/ i.e. this may only be invoked for reals
+        "/ which are NOT within the smallInt range.
+        "/ otherwise, endless recursion is the consequence.
 
-    max := SmallInteger maxVal // 2 + 1.
-    maxF := max asFloat.
+        max := SmallInteger maxVal // 2 + 1.
+        maxF := max asFloat.
 
-    ^ (self quo:maxF) * max + (self rem:maxF) truncated
+        ^ (self quo:maxF) * max + (self rem:maxF) truncated
+    ].
+    ^ self asTrueFraction
 
     "
-     12345.0 asInteger
-     1e15 asInteger
-     1e33 asInteger
+     12345.0 asInteger     
+     1e15 asInteger        
+     1e33 asInteger asFloat
+     1e303 asInteger asFloat
     "
 
     "Modified: 12.2.1997 / 16:45:07 / cg"
@@ -493,5 +497,5 @@
 !LimitedPrecisionReal class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/Attic/LPReal.st,v 1.31 1999-07-26 09:10:36 stefan Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/Attic/LPReal.st,v 1.32 1999-08-19 01:20:08 cg Exp $'
 ! !

--- a/LimitedPrecisionReal.st	Thu Aug 19 02:17:59 1999 +0200
+++ b/LimitedPrecisionReal.st	Thu Aug 19 03:20:08 1999 +0200
@@ -247,21 +247,25 @@
 
     ].
 
-    "/ NOTICE: this must be redefined in float
-    "/ subclasses to handle the smallinteger range;
-    "/ i.e. this may only be invoked for reals
-    "/ which are NOT within the smallInt range.
-    "/ otherwise, endless recursion is the consequence.
+    self abs < 2e16 ifTrue:[
+        "/ NOTICE: this must be redefined in float
+        "/ subclasses to handle the smallinteger range;
+        "/ i.e. this may only be invoked for reals
+        "/ which are NOT within the smallInt range.
+        "/ otherwise, endless recursion is the consequence.
 
-    max := SmallInteger maxVal // 2 + 1.
-    maxF := max asFloat.
+        max := SmallInteger maxVal // 2 + 1.
+        maxF := max asFloat.
 
-    ^ (self quo:maxF) * max + (self rem:maxF) truncated
+        ^ (self quo:maxF) * max + (self rem:maxF) truncated
+    ].
+    ^ self asTrueFraction
 
     "
-     12345.0 asInteger
-     1e15 asInteger
-     1e33 asInteger
+     12345.0 asInteger     
+     1e15 asInteger        
+     1e33 asInteger asFloat
+     1e303 asInteger asFloat
     "
 
     "Modified: 12.2.1997 / 16:45:07 / cg"
@@ -493,5 +497,5 @@
 !LimitedPrecisionReal class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/LimitedPrecisionReal.st,v 1.31 1999-07-26 09:10:36 stefan Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/LimitedPrecisionReal.st,v 1.32 1999-08-19 01:20:08 cg Exp $'
 ! !

--- a/SFloat.st	Thu Aug 19 02:17:59 1999 +0200
+++ b/SFloat.st	Thu Aug 19 03:20:08 1999 +0200
@@ -481,6 +481,12 @@
     ^ self
 !
 
+asTrueFraction
+    "return a fraction with same value as the receiver"
+
+    ^ self asFloat asTrueFraction
+!
+
 generality
     "return the generality value - see ArithmeticValue>>retry:coercing:"
 
@@ -958,5 +964,5 @@
 !ShortFloat class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/Attic/SFloat.st,v 1.51 1999-08-12 08:58:36 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/Attic/SFloat.st,v 1.52 1999-08-19 01:19:54 cg Exp $'
 ! !

--- a/ShortFloat.st	Thu Aug 19 02:17:59 1999 +0200
+++ b/ShortFloat.st	Thu Aug 19 03:20:08 1999 +0200
@@ -481,6 +481,12 @@
     ^ self
 !
 
+asTrueFraction
+    "return a fraction with same value as the receiver"
+
+    ^ self asFloat asTrueFraction
+!
+
 generality
     "return the generality value - see ArithmeticValue>>retry:coercing:"
 
@@ -958,5 +964,5 @@
 !ShortFloat class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/ShortFloat.st,v 1.51 1999-08-12 08:58:36 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/ShortFloat.st,v 1.52 1999-08-19 01:19:54 cg Exp $'
 ! !