!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: binfloat.gs,v 1.16 2008-01-09 22:50:08 stever Exp $
!
! Superclass Hierarchy:
!   BinaryFloat, Number, Magnitude, Object.
!
!=========================================================================

! create all the float classes

! the class BinaryFloat is created in floatclasses.gs

removeallmethods BinaryFloat
removeallclassmethods BinaryFloat

category: 'For Documentation Installation only'
classmethod: BinaryFloat
installDocumentation

| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details:
'BinaryFloat is an abstract class.  Various subclasses provide different
 implementations of Binary floating point.  Each subclass is expected
 to conform to IEEE Standard 754.'.
doc documentClassWith: txt .

txt := (GsDocText new) details:
'Float status flags, exception handlers, and non-default rounding modes are
 maintained only for a single GemStone Smalltalk execution and are cleared
 when a new execution begins.'.
doc documentClassCategory: #'Exception Handling' with: txt.

self description: doc.
%

category: 'Truncation and Rounding'
method: BinaryFloat
integerPart

"Returns an integer representing the receiver truncated toward zero."

^ self truncated
%

category: 'Truncation and Rounding'
method: BinaryFloat
fractionPart

"Returns the fraction remaining after the receiver is truncated toward zero."

^ self - self truncated asFloat
%

category: 'Converting'
method: BinaryFloat
asScaledDecimal: scale

"Returns a ScaledDecimal that represents the receiver.  If the receiver is
 a NaN or Infinity, returns the receiver.  The argument scale should be a
 non-negative SmallInteger."

| myKind |

myKind := self kind.
myKind == #normal ifFalse:[
  ((myKind == #infinity _or:[ myKind == #signalingNaN ]) 
    _or:[ myKind == #quietNaN])  ifTrue:[
      BinaryFloat _raiseInvalidOperationException .
      ^ self.
    ].
  ].
^ self asFraction asScaledDecimal: scale.
%

! edited to fix 36173
category: 'Converting'
method: BinaryFloat
asFraction

"Returns a Fraction that represents the receiver.  If the receiver is a NaN,
 or Infinity, returns the receiver."

| knd |

"If an infinite or quiet NaN, returns self"
knd := self _getKind .
knd > 2 ifTrue:[ | myKind |
  myKind := self kind .
  myKind == #zero ifTrue:[ ^ 0 ].
  ((myKind == #infinity) _or: [ myKind == #quietNaN ]) ifTrue: [ ^self ].

     "If a signaling NaN, raises a floating point exception & returns self"
  (myKind == #signalingNaN) ifTrue: [ 
    BinaryFloat _raiseInvalidOperationException.
    ^self _makeQuietNaN 
  ].
  self error:'logic error'. "should not reach here"
].
" we have either normal or subnormal "
^ self _mathPrim: 12  "_asFraction" .
%

! deleted _idxCompareLessThan: v2.0

! deleted _idxCompareLessThanOrEqual: v2.0

! deleted _idxCompareGreaterThan: v2.0

! deleted _idxCompareGreaterThanOrEqual: v2.0

! deleted _idxCompareEqualTo: v2.0

! deleted _idxCompareNotEqualTo: v2.0

category: 'Indexing Support'
method: BinaryFloat
_isNaN

"(Subclass responsibility.)  Returns whether the receiver is quiet NaN or
 a signaling NaN.  This method is only to be used by the indexing subsystem."

BinaryFloat subclassResponsibility: #_isNaN
%

category: 'Formatting'
method: BinaryFloat
asStringUsingFormat: anArray

"(Subclass responsibility.)  Returns a String corresponding to the receiver,
 using the format specified by anArray."

BinaryFloat subclassResponsibility: #asStringUsingFormat:
%

category: 'Formatting'
method: BinaryFloat
asString

"(Subclass responsibility.)  Returns a String corresponding to the value of the
 receiver.  Where applicable, returns one of the following Strings:
 'PlusInfinity', 'MinusInfinity', 'PlusQuietNaN', 'MinusQuietNaN',
 'PlusSignalingNaN', or 'MinusSignalingNaN'."

BinaryFloat subclassResponsibility: #asString
%

category: 'Accessing'
method: BinaryFloat
denominator

"Returns the denominator of a Fraction representing the receiver."

| myKind |
myKind := self kind .
myKind == #normal ifFalse:[
     "If an infinite or quiet NaN, returns self"
  ((myKind == #infinity) _or: [ myKind == #quietNaN ])
     ifTrue: [ ^self ].
  
     "If a signaling NaN, raise a floating point exception & returns self"
  (myKind == #signalingNaN)
     ifTrue: [ self class _raiseInvalidOperationException.
               ^self _makeQuietNaN ].
  ].

^ (self asFraction) denominator
%

category: 'Accessing'
method: BinaryFloat
numerator

"Returns the numerator of a Fraction representing the receiver."

| myKind |

   "If an infinite or quiet NaN, returns self"
myKind := self kind.
myKind == #normal ifFalse:[
  ((myKind == #infinity) _or: [ myKind == #quietNaN ])
     ifTrue: [ ^self ].

     "If a signaling NaN, raise a floating point exception & returns self"
  (myKind == #signalingNaN)
     ifTrue: [ self class _raiseInvalidOperationException.
               ^self _makeQuietNaN ].
  ].

^ (self asFraction) numerator
%

! fix bug 12083
category: 'Instance Creation'
classmethod: BinaryFloat
fromString: aString

"Returns an instance of Float, constructed from aString.  The String must
 contain only Characters representing the object to be created, although
 leading and trailing blanks are permitted."

^ Float fromString: aString
%

category: 'Instance Creation'
classmethod: BinaryFloat
fromStream: aStream

"Generates a BinaryFloat from aStream.  Generates an error if an attempt is
 made to read beyond the end of the stream.

 The Stream must contain a legal BinaryFloat, as defined by the following BNF
 construction:

 BinaryFloat = ( Integer '.' Digit {Digit} [ E Integer ] ) |
         ( Integer E Integer )
 Integer = [ ('+' | '-') ] Digit {Digit}
 Point = ( '.' | ',' ) depending on Locale
 E = ( 'E' | 'e')

 Note that the syntax does not allow certain valid BinaryFloats (such as
 PlusInfinity and MinusInfinity) to be read."

| ch s getDigits getChar getSign |

self _checkReadStream: aStream forClass: CharacterCollection.

ch := aStream next.
[ ch isEquivalent: $ ]
whileTrue:
  [ ch := aStream next ].
aStream position: (aStream position - 1).
s := aStream contents class new.

getDigits := [ (aStream atEnd _or: [ aStream peek isDigit not])
               ifTrue:
                 [ self _errIncorrectFormat: aStream ].
               [ aStream atEnd not _and: [ aStream peek isDigit ] ]
               whileTrue:
                 [ s add: aStream next ].
             ].

getChar := [ :c |
             (aStream peek isEquivalent: c)
             ifTrue:
               [ s add: aStream next ]
           ].

getSign := [ (getChar value: $-) == nil
              ifTrue:
                [ getChar value: $+ ].
           ].

getSign value.
getDigits value.

(getChar value: (Locale decimalPoint at: 1)) ~~ nil
ifTrue:
  [ getDigits value ].

((getChar value: $e) ~~ nil)
ifTrue:
  [ getSign value.
    getDigits value.
  ].

^ self fromString: s
%

category: 'Accessing'
method: BinaryFloat
at: anIndex put: aValue

"Disallowed.  You may not change the value of a Float."

self shouldNotImplement: #at:put:
%

category: 'Accessing'
method: BinaryFloat
size: anInteger

"Disallowed.  You may not change the size of a Float."

self shouldNotImplement: #size:
%

category: 'Comparing'
method: BinaryFloat
>= aMagnitude

"Returns true if the receiver is greater than or equal to aMagnitude;
 returns false otherwise."

"Reimplemented from Magnitude to handle NaNs correctly."

^ aMagnitude <= self
%

category: 'Arithmetic'
method: BinaryFloat
rem: aNumber

"Returns the integer remainder defined in terms of quo: (division of the
 receiver by aNumber, with truncation toward zero)."

  "x rem: y | x=infinity or y=0 are invalid floating point
   operations and returns quiet NaNs"

(aNumber = 0.0) "0.0/0.0 is also invalid"
   ifTrue: [ ^ (aNumber asFloat) / (aNumber asFloat)].

(self _getKind == 3 "infinity" ) "infinity/infinity is also invalid"
   ifTrue: [ ^ self / self ].
^ super rem: aNumber
%

category: 'Testing'
method: BinaryFloat
even

"(R) Returns true if the receiver is an even integer, false otherwise."

 self fractionPart = 0.0 ifFalse:[ ^ false ] .
 ^ (self / 2.0) = 0.0
%

category: 'Testing'
method: BinaryFloat
odd

"(R) Returns true if the receiver is an odd integer, false otherwise."

 self fractionPart = 0.0 ifFalse:[ ^ false ] .
 ^ (self / 2.0) ~= 0.0
%

category: 'Arithmetic'
classmethod: BinaryFloat
pi

"Returns the value of pi, accurate to twenty decimal places."

^ 3.14159265358979323846
%

category: 'Exception Handling'
classmethod: BinaryFloat
_raiseInvalidOperationException

"This method sets the invalid operation exception of the floating point
 processor."

MinusSignalingNaN + 3.0E0 .
^self
%

category: 'Exception Handling'
classmethod: BinaryFloat
clearException: aString

"Clears the raised exception type defined by aString ('divideByZero',
 'inexactResult', 'invalidOperation', 'overflow', 'underflow').  If aString is
 not one of these exception types, an error is generated.  Raised exceptions
 are set by GemStone during floating point operations, and must be explicitly
 cleared with this method."

|state kind offset|
kind := self _exceptionKind: aString.
state := self status.
offset := self _exceptionList size + kind .

state size < offset ifTrue:[ ^ self "not implemented" ].

state at: offset put: $0 .
self status: state.
%

category: 'Exception Handling'
classmethod: BinaryFloat
clearAllExceptions

"Clear all raised exceptions."

self _exceptionList do: [:each | self clearException: each]
%

category: 'Exception Handling'
classmethod: BinaryFloat
raisedExceptions

"Returns a list of all raised exceptions."

|result|

result := Array new.
self _exceptionList do: [:each|
  (self raisedException: each) ifTrue: [
    result add: each]].
^result
%

category: 'Exception Handling'
classmethod: BinaryFloat
_setException: anException to: aBool

"Turn on (or off) a floating point exception.  Returns the previous state."

|state kind offset |
kind := self _exceptionKind: anException.
state := self status.
offset := self _exceptionList size * 2 + kind .

state size < offset ifTrue:[ ^ false "exception not implemented" ].

state at: offset put: (aBool ifTrue: [$1] ifFalse: [$0]).

self status: state
%

category: 'Exception Handling'
classmethod: BinaryFloat
_exceptionFor: aString

"Returns exception installed on given string, else nil."

|this desired|

this := Exception _staticExceptions.
desired := ErrorSymbols at: #numErrFltException.

[this == nil] whileFalse: [
  (this category == GemStoneError _and: [
      this number == desired _and: [
      this subtype = aString]]) ifTrue: [ ^this ].
  this := this next].
^nil
%

category: 'Exception Handling'
classmethod: BinaryFloat
on: aString do: aBlock

"The argument aString defines the exception type ('divideByZero',
 'inexactResult', 'invalidOperation', 'overflow', 'underflow').  If aString is
 not one of these, an error is generated.

 The three-argument block aBlock is evaluated when the specified exception
 occurs.  The three arguments to aBlock are:

 1.  The category of the exception (always GemStoneError)
 2.  The number of the exception (always rtErrFltException)
 3.  an Array containing arguments to the exception, to wit:
    1.  The type of exception (a Symbol, such as #divideByZero),
    2.  The selector of the offending operation,
    3.  The default result that would be returned,
    4.  The first operand to the operation,
    5.  The second operand to the operation, if any.

 The value that the block returns becomes the result of the floating point
 operation.

 Note that underflow and overflow pass an unusual result to the
 trap handler if the exception is enabled --  In particular, the
 correct result is biased by a factor of 10 to the 22500 power to
 bring it into the representable range of a Float.

 If you do not want to field the exception specified by aString,
 leave aBlock nil.  If aBlock is neither a block nor nil,
 an error is generated.  Returns the receiver."

| oldException |

"Remove old exception, if any"
oldException := self _exceptionFor: aString.
oldException ~~ nil ifTrue: [ Exception removeStaticException: oldException].

aBlock ~~nil ifTrue: [
    aBlock numberArgs ~= 3 ifTrue: [
      ^aBlock _error: #rtErrBadBlockArgCount args: #[aBlock numberArgs, 3].
      ].
    self _setException: aString to: true.
    self _installException: aBlock on: aString.
  ]
  ifFalse: [
    self _setException: aString to: false.
  ]
%

category: 'Exception Handling'
classmethod: BinaryFloat
_installException: aBlock on: aString

"Install given block as a static exception."

  Exception installStaticException:
	[:theException :cat :num :args |
            (args at: 1) = theException subtype ifFalse: [
              theException resignal: cat number: num args: args].
            aBlock value: cat value: num value: args]
	category: GemStoneError
	number: (ErrorSymbols at: #numErrFltException)
        subtype: aString
%

category: 'Exception Handling'
classmethod: BinaryFloat
operationException: aString

"Returns true if the specified exception has occurred in the current operation.
 Otherwise, returns false.  The argument aString defines the exception type
 ('divideByZero', 'inexactResult', 'invalidOperation', 'overflow',
 'underflow').  If aString is not one of these, an error is generated."

|status kind|

status := Float status.
kind := Float _exceptionKind: aString.

status size < kind ifTrue:[ ^ false "exception not implemented" ].

^(status at: kind) == $1
%

category: 'Exception Handling'
classmethod: BinaryFloat
operationExceptions

"Returns a list of all exceptions raised by the last floating point operation."

|result|

result := Array new.
self _exceptionList do: [:each|
  (self operationException: each) ifTrue: [
    result add: each]].
^result
%

category: 'Exception Handling'
classmethod: BinaryFloat
_exceptionList

"Returns the list of available exceptions, in order."

^ #(#divideByZero #invalidOperation #overflow #underflow #inexactResult ).
%

category: 'Exception Handling'
classmethod: BinaryFloat
_exceptionKind: aString

"Use a String indicating a type of exception (i.e., 'divideByZero',
 'inexactResult', 'invalidOperation', 'overflow', or 'underflow'.
 Returns an offset to be used analyzing a Float status string."

|list|

list := self _exceptionList.
1 to: list size do: [:i | (list at: i) = aString ifTrue: [^i]].
^ aString _error: #numErrArgNotFltException
%

category: 'Exception Handling'
classmethod: BinaryFloat
raisedException: aString

"Returns true if the specified exception has occurred since the last
 clearException operation.  Otherwise, returns false.  The argument aString
 defines the exception type ('divideByZero', 'inexactResult',
 'invalidOperation', 'overflow', 'underflow').  If aString is not one of these,
 an error is generated.

 The occurrence of a floating point exception that is not trapped by
 on:do: causes that exception to be raised."

|status kind offset |

status := Float status.
kind := Float _exceptionKind: aString.
offset := self _exceptionList size + kind .

status size < offset
  ifTrue:[ ^ false "exception not implemented" ] .

^ (status at: offset ) == $1
%

category: 'Exception Handling'
classmethod: BinaryFloat
status

"Returns an empty Array in this release."

"Returns a six-element Array.  The first element of the Array is a String
 representing the status of the floating point processor, including the
 operation exceptions, raised exceptions, rounding mode, and the enabled traps.
 The next five elements of the Array are the blocks associated with each of the
 enabled traps, in this order: divideByZero, inexactResult, invalidOperation,
 overflow, underflow.

 Any method that modifies the trap handlers should first save the status
 using this method.  After the method has modified the trap handlers, it
 should use status: to restore the status."

<primitive: 122>
^ self _primitiveFailed: #floatStatus
%

category: 'Exception Handling'
classmethod: BinaryFloat
status: aString

"Has no effect in this release."

"Restores the status of the floating point processor to the previously saved
 status represented by aString.  The argument aString is the first element of
 the Array that Float|status returns."

<primitive: 129>
aString _validateClasses: #[String].
aString _error: #numErrArgNotFltStatus
%

category: 'Exception Handling'
classmethod: BinaryFloat
trapEnabled: aString

"Returns true if a trap handler has been defined for the specified exception
 Otherwise, returns false."

 |status kind offset |

 status := Float status.
 kind := Float _exceptionKind: aString.
 offset := self _exceptionList size * 2 + kind .

 status size < offset ifTrue:[ ^ false "trap handler not implemented" ].

 ^(status at: offset) == $1
%

category: 'Exception Handling'
classmethod: BinaryFloat
enabledExceptions

"Returns a list of all raised exceptions."

|result|

result := Array new.
self _exceptionList do: [:each|
  (self trapEnabled: each) ifTrue: [
    result add: each]].
^result
%

! deleted raisedToInteger:

category: 'Arithmetic'
method: BinaryFloat
negated

"Returns a Number that is the negation of the receiver."

"reimplemented for efficiency"

^ (0.0 - self)
%

category: 'Arithmetic'
method: BinaryFloat
abs

"Returns a Number that is the absolute value of the receiver."

"reimplemented for efficiency"

(self < 0.0) ifTrue: [ ^ self negated ].

^ self
%

category: 'Testing'
method: BinaryFloat
negative

"Returns true if the receiver is less than zero, false if the receiver is zero
 or greater."

^ self < 0.0
%

category: 'Testing'
method: BinaryFloat
positive

"Returns true if the receiver is greater than or equal to zero, false if the
 receiver is less than zero."

^ self >= 0.0
%

category: 'Testing'
method: BinaryFloat
strictlyPositive

"Returns true if the receiver is greater than zero and false if it is less than
 or equal to zero."

^ self > 0.0
%

category: 'Truncation and Rounding'
classmethod: BinaryFloat
roundingMode

"Returns the current rounding mode ('nearestEven', 'towardMinusInfinity',
 'towardPlusInfinity', 'towardZero').

 Returns 'unknown' if access to rounding mode is not implemented for
 the receiver."

|state mode|

state := Float status.
state size < 16 ifTrue:[ ^ #unknown ] .
mode := state at: 16.
mode == $E ifTrue: [ ^ #nearestEven].
mode == $N ifTrue: [ ^ #towardMinusInfinity].
mode == $P ifTrue: [ ^ #towardPlusInfinity].
mode == $Z ifTrue: [ ^ #towardZero].
^ #unknown "should never occur!"
%

category: 'Truncation and Rounding'
classmethod: BinaryFloat
roundingMode: aString

"The argument aString defines the rounding mode ('nearestEven',
 'towardMinusInfinity', 'towardPlusInfinity', 'towardZero').  If aString is not
 one of these, an error is generated."

|status newChar|
newChar := nil.
aString = #nearestEven
  ifTrue: [newChar := $E]
  ifFalse: [
    aString = #towardMinusInfinity
      ifTrue: [newChar := $N]
      ifFalse: [
        aString = #towardPlusInfinity
          ifTrue: [newChar := $P]
	  ifFalse: [
            aString = #towardZero
              ifTrue: [newChar := $Z]
            ]
        ]
    ].
newChar == nil ifTrue: [^ aString _error: #numErrArgNotRoundingMode].
status := Float status.
status size < 16 ifTrue:[ ^ self "mode not implemented" ] .
status at: 16 put: newChar.
Float status: status.
%

category: 'Arithmetic'
method: BinaryFloat
factorial

"Returns the factorial of the integer part of the receiver.  Returns 1 if the
 receiver is less than or equal to 1."

| x result |
result := 1.0E0  .
x := result .
self asInteger timesRepeat:[ result := result * x.  x := x + 1.0E0 ] .
^ result .
%

category: 'Storing and Loading'
classmethod: BinaryFloat
loadFrom: passiveObj

"Reads from passiveObj the passive form of an object.  Converts the object to
 its active form by loading the information into a new instance of the receiver.
 Returns the new instance."

BinaryFloat subclassResponsibility: #loadFrom:
%

! fixed 36540
category: 'Storing and Loading'
method: BinaryFloat
writeTo: passiveObj

"Converts the receiver to its passive form and writes that information on
 passiveObj."

passiveObj writeClass: self class;
      nextPutAll: self asStringLocaleC ;
      space
%

