Permalink
Fetching contributors…
Cannot retrieve contributors at this time
14828 lines (12338 sloc) 443 KB
Object subclass: #MsgParmSpec
instanceVariableNames: 'parmName parmProtocols parmAliasingAttribute '
classVariableNames: ''
poolDictionaries: ''
category: ''!
Object subclass: #MsgReturnSpec
instanceVariableNames: 'returnValueProtocols returnValueAliasingAttribute '
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCase subclass: #TestCaseProtocol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseProtocol subclass: #TestCaseHelper
instanceVariableNames: 'testCase '
classVariableNames: ' '
poolDictionaries: ''
category: ''!
TestCaseHelper class instanceVariableNames: 'testSelectors '!
TestCaseHelper subclass: #CollectionStreamHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #GettableStreamHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #WriteStreamHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #SequencedReadableCollectionHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #SequencedStreamHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #CollectionHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #SequencedCollectionHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #ReadableStringHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #SequencedContractibleCollectionHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #PuttableStreamHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #AbstractDictionaryHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseProtocol subclass: #MainTestCase
instanceVariableNames: 'messages helpers '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ExceptionSetANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #IdentityDictionaryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ExceptionClassANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #SelectorANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ArrayFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ObjectClassANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #NilANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #FloatANSITest
instanceVariableNames: 'smallInt2 largeNegInt2000000000 largePosInt2000000000 float2 fractionHalf sclDec2s3 numList '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ReadWriteStreamFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ScaledDecimalANSITest
instanceVariableNames: 'smallInt2 largeNegInt2000000000 largePosInt2000000000 float2 fractionHalf sclDec2s3 numList '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #NotificationANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #CharacterANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ZeroDivideANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #TranscriptANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #MessageNotUnderstoodANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #SequencedStreamTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #BagFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ErrorClassANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #WarningClassANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #OrderedCollectionFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #DurationANSITest
instanceVariableNames: 'off0123 smallInt2 largeNegInt2000000000 largePosInt2000000000 float2 fractionHalf numList '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ZeroDivideFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #IntervalFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ReadStreamFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ByteArrayFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ExceptionANSITest
instanceVariableNames: 'unchanged changed value '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #MonadicBlockANSITest
instanceVariableNames: 'blk1args '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #DurationFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #SortedCollectionFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #DateAndTimeANSITest
instanceVariableNames: 'd19970426t8 '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ReadWriteStreamANSITest
instanceVariableNames: 'readWriteStream '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #DateAndTimeFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #FractionFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ErrorANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #StringFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ReadFileStreamANSITest
instanceVariableNames: 'readFileStream '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #FailedMessageANSITest
instanceVariableNames: 'failedMsg '
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #ObjectHelper
instanceVariableNames: 'object '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #IntegerANSITest
instanceVariableNames: 'smallInt2 largeNegInt2000000000 largePosInt2000000000 float2 fractionHalf sclDec2s3 numList '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #FileStreamFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #WarningANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #IdentityDictionaryFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #FractionANSITest
instanceVariableNames: 'smallInt2 largeNegInt2000000000 largePosInt2000000000 float2 fractionHalf sclDec2s3 numList '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #MessageNotUnderstoodSelectorANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #NiladicBlockANSITest
instanceVariableNames: 'blk0args canonicalObject '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #NotificationClassANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #ObjectANSITest
instanceVariableNames: 'object '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #SetFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #ExtensibleCollectionHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #DyadicValuableANSITest
instanceVariableNames: 'blk2args '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #WriteStreamFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedStreamTest subclass: #WriteStreamANSITest
instanceVariableNames: 'writeStream '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #WriteFileStreamANSITest
instanceVariableNames: 'writeFileStream '
classVariableNames: ''
poolDictionaries: ''
category: ''!
Object subclass: #ProtocolANYSpec
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
ProtocolANYSpec subclass: #ProtocolSpec
instanceVariableNames: 'name conformsTo description messageSpecifications '
classVariableNames: 'DefaultConvTable FixNum OperatorTable Protocols UnaryConvTable UndefinedConformsToNames ClassProtocols '
poolDictionaries: ''
category: ''!
MsgReturnSpec subclass: #MsgReturnRuleSpec
instanceVariableNames: 'ruleSourceCode ruleBlock '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #FloatCharacterizationANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #CharacterFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedStreamTest subclass: #ReadStreamANSITest
instanceVariableNames: 'readStream '
classVariableNames: ''
poolDictionaries: ''
category: ''!
Object subclass: #ProtocolMsgSpec
instanceVariableNames: 'selector parameterSpecifications returnValueSpecifications specSections '
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #DictionaryFactoryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #BooleanANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
MainTestCase subclass: #CollectionTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
CollectionTest subclass: #SequencedReadableCollectionTest
instanceVariableNames: 'canonicalObjects'
classVariableNames: ''
poolDictionaries: ''
category: ''!
CollectionTest subclass: #IntervalANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedReadableCollectionTest subclass: #StringANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
CollectionTest subclass: #DictionaryANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
CollectionTest subclass: #SetANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedReadableCollectionTest subclass: #SymbolANSITest
instanceVariableNames: 'smalltalkSymbol '
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedReadableCollectionTest subclass: #OrderedCollectionANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
CollectionTest subclass: #BagANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedReadableCollectionTest subclass: #ByteArrayANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedReadableCollectionTest subclass: #SortedCollectionANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
SequencedReadableCollectionTest subclass: #ArrayANSITest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
TestCaseHelper subclass: #ReadStreamHelper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: ''!
!ReadStreamHelper methodsFor: nil!
testXupToX
self canonicalObject reset.
self value: [self canonicalObject upTo: $ ]
should: [:r | r = 'this' & self canonicalObject next = $i]
conformTo: self protocol selector: #upTo:.
self value: [self canonicalObject upTo: $X]
should: [:r | r = 's a string' & self canonicalObject atEnd]
conformTo: self protocol selector: #upTo:.
self value: [self canonicalObject upTo: $a]
should: [:r | r isEmpty]
conformTo: self protocol selector: #upTo:.!
object: anObject!
testXnextX
self canonicalObject reset.
self value: [self canonicalObject next: 3]
should: [:r | r asArray = 'thi' asArray]
conformTo: self protocol selector: #'next:'.
self value: [self canonicalObject next: 0]
should: [:r | r isEmpty]
conformTo: self protocol selector: #'next:'.
"Errors: amount < 0."
self value: [self canonicalObject next: -1]
shouldRaise: Error.!
canonicalObject
^testCase canonicalObject!
protocol
^#'ReadStream'! !
!ReadStreamHelper class methodsFor: nil!
initialize
"ReadStreamHelper initialize"
super initialize! !
!CollectionTest methodsFor: nil!
conformanceOfPutElementOnXatAllXputX: aString
"Do Nothing, Has no conformance issue"!
conformanceOfPutElementOnXatXputX: aString
"Do Nothing, Has no conformance issue"!
returnTypeHasLimitedElementTypes
^false!
conformanceOfPutElementOnXatAllPutX: aString
"Do Nothing, Has no conformance issue"! !
!CollectionTest class methodsFor: nil!
helperClassesDo: aBlock
super helperClassesDo: aBlock.
aBlock value: CollectionHelper! !
!SequencedReadableCollectionTest methodsFor: nil!
canonicalObjects
| helper |
canonicalObjects isNil ifFalse: [ ^canonicalObjects ].
helper := helpers detect: [ :each | each class == SequencedReadableCollectionHelper ].
canonicalObjects := helper canonicalObjects.
^canonicalObjects!
!BooleanANSITest methodsFor: nil!
testXandX
" <boolean>#and: "
#'Fundamental'.
self value: [ true and: [true] ] should: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ true and: [nil isNil] ] should: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ true and: [false] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ true and: [nil notNil] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ true and: [nil selector] ]
shouldRaise: MessageNotUnderstood.
self value: [ false and: [true] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ false and: [nil isNil] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ false and: [false] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.
self value: [ false and: [nil notNil] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.
"No error:"
self value: [ false and: [nil selector] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'and:'.!
testXnot
" <boolean>#not "
#'Fundamental'.
self value: [true not] should: [:r | r = false]
conformTo: #'boolean' selector: #'not'.
self value: [false not] should: [:r | r = true]
conformTo: #'boolean' selector: #'not'.!
testXxorX
" <boolean>#xor: "
#'Fundamental'.
self value: [true xor: true] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'xor:'.
self value: [true xor: false] should: [:r | r]
conformTo: #'boolean' selector: #'xor:'.
self value: [false xor: true] should: [:r | r]
conformTo: #'boolean' selector: #'xor:'.
self value: [false xor: false] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'xor:'.!
protocol
^#boolean!
canonicalObject
^true!
testXifFalseXifTrueX
" <boolean>#ifFalse:ifTrue: "
#'Fundamental'.
self value: [ false
ifFalse: [0]
ifTrue: [nil selector] ]
should: [:r | r = 0]
conformTo: #'boolean' selector: #'ifFalse:ifTrue:'.
self value: [ true
ifFalse: [nil selector]
ifTrue: [1] ]
should: [:r | r = 1]
conformTo: #'boolean' selector: #'ifFalse:ifTrue:'.!
testXandOp
" <boolean>#& "
#'Fundamental'.
self value: [true & true] should: [:r | r]
conformTo: #'boolean' selector: #'&'.
self value: [true & false] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'&'.
self value: [false & true] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'&'.
self value: [false & false] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'&'.!
testXorX
" <boolean>#or: "
#'Fundamental'.
self value: [ true or: [true] ] should: [:r | r]
conformTo: #'boolean' selector: #'or:'.
self value: [ true or: [false] ] should: [:r | r]
conformTo: #'boolean' selector: #'or:'.
"No error:"
self value: [ true or: [nil selector] ] should: [:r | r]
conformTo: #'boolean' selector: #'or:'.
self value: [ false or: [true] ] should: [:r | r]
conformTo: #'boolean' selector: #'or:'.
self value: [ false or: [nil isNil] ] should: [:r | r]
conformTo: #'boolean' selector: #'or:'.
self value: [ false or: [false] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'or:'.
self value: [ false or: [nil notNil] ] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'or:'.
self value: [ false or: [nil selector] ]
shouldRaise: MessageNotUnderstood.!
testXifTrueX
" <boolean>#ifTrue: "
#'Fundamental'.
self value: [ true ifTrue: [1] ] should: [:r | r = 1]
conformTo: #'boolean' selector: #'ifTrue:'.
self value: [ false ifTrue: [1] ] should: [:r | true "unspecified"]
conformTo: #'boolean' selector: #'ifTrue:'.!
testXifFalseX
" <boolean>#ifFalse: "
#'Fundamental'.
self value: [ false ifFalse: [0] ] should: [:r | r = 0]
conformTo: #'boolean' selector: #'ifFalse:'.
self value: [ true ifFalse: [0] ] should: [:r | true "unspecified"]
conformTo: #'boolean' selector: #'ifFalse:'.!
testXprintString
" <boolean>#printString "
#'Fundamental'.
self value: [true printString] should: [:r | r = 'true']
conformTo: #'boolean' selector: #'printString'.
self value: [false printString] should: [:r | r = 'false']
conformTo: #'boolean' selector: #'printString'.!
testXeqvX
" <boolean>#eqv: "
#'Fundamental'.
self value: [true eqv: true] should: [:r | r]
conformTo: #'boolean' selector: #'eqv:'.
self value: [true eqv: false] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'eqv:'.
self value: [false eqv: true] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'eqv:'.
self value: [false eqv: false] should: [:r | r]
conformTo: #'boolean' selector: #'eqv:'.!
testXorOp
" <boolean>#| "
#'Fundamental'.
self value: [true | true] should: [:r | r]
conformTo: #'boolean' selector: #'|'.
self value: [true | false] should: [:r | r]
conformTo: #'boolean' selector: #'|'.
self value: [false | true] should: [:r | r]
conformTo: #'boolean' selector: #'|'.
self value: [false | false] shouldnt: [:r | r]
conformTo: #'boolean' selector: #'|'.!
testXifTrueXifFalseX
" <boolean>#ifTrue:ifFalse: "
#'Fundamental'.
self value: [ true
ifTrue: [ 1 ]
ifFalse: [ nil selector ] ]
should: [:r | r = 1]
conformTo: #'boolean' selector: #'ifTrue:ifFalse:'.
self value: [ false
ifTrue: [ nil selector ]
ifFalse: [ 0 ] ]
should: [:r | r = 0]
conformTo: #'boolean' selector: #'ifTrue:ifFalse:'.! !
!DictionaryFactoryANSITest methodsFor: nil!
protocol
^#'Dictionary factory'!
testXwithAllX
" <Dictionary factory>#withAll: "
#'Collection'.!
testXnewX
" <Dictionary factory>#new: "
#'Collection'.!
canonicalObject
^Dictionary!
testXnew
" <Dictionary factory>#new "
#'Collection'.! !
!ProtocolMsgSpec methodsFor: nil!
hasReturnValue
"Answer true if receiver has return value specifications, else false."
^ returnValueSpecifications notNil!
isConformingReturn: returnObject
"Answer true if the result, returnObject, of sending the receiver conforms to the specified return value, else false."
| returnClass |
#todo."??? is no return value an error or compliant ???"
self hasReturnValue ifFalse: [^ true].
self isReturnValueSpecByRule ifTrue: [^ false].
returnClass := returnObject class.
self specForEachReturnValueList
do: [:returnSpec | (returnSpec isConformingReturnClass: returnClass)
ifTrue: [^ true]].
^ false!
specForEachReturnValueList
"Answer the specification for each message return value list of the receiver."
returnValueSpecifications isNil ifTrue: [^ self class defaultReturnValueSpecificationCollection].
^ returnValueSpecifications!
specSections
"Answer the specification sections of the receiver.
Note: specSections must be a <Dictionary> of <symbol> keys and <readableString> values. Keys are: #'Synopsis' #'DefinedIn' #'Definition' #'RefinedIn' #'Refinement' #'Errors'."
specSections isNil ifTrue: [^ self protocolManager defaultSpecSectionsCollection].
^ specSections!
messageSelector
"Answer the selector of the receiver."
^ selector!
messageDefinition
"Answer the definition of the receiver, or an empty string."
#todo."??? should this be the proto is component of or Definition: sec proto ???"
specSections isNil ifTrue: [^ String new].
^ specSections at: #'Definition' ifAbsent: [String new]!
messageSynopsis
"Answer the synopsis of the receiver, or an empty string."
#todo."??? should this be the proto is component of or Definition: sec proto ???"
specSections isNil ifTrue: [^ String new].
^ specSections at: #'Synopsis' ifAbsent: [String new]!
hasParms
"Answer true if receiver has parameter specifications, else false."
^ parameterSpecifications notNil!
isConformingReturn: returnObject opRECEIVER: receiver conformTo: protocolName selector: msgSelector
"Answer true if the result, returnObject, of sending the receiver conforms to the protocol in which it is used, or any protocol that conforms to that protocol, else false."
#todo."??? Figure out how to do this test ???"
^ self isConformingReturn: returnObject!
allReferredToProtocolNames
"Answer a list of protocol names referred to by the receiver."
| referredToNames protocolName |
referredToNames := Set new.
protocolName := self definedInProtocolName.
protocolName notNil ifTrue: [referredToNames add: protocolName].
protocolName := self refinedInProtocolName.
protocolName isNil ifFalse: [referredToNames add: protocolName].
self specForEachParmList do: [:msgSpecParm | referredToNames addAll: msgSpecParm parmProtocolNames].
self specForEachReturnValueList
do: [:msgSpecReturn | (msgSpecReturn isKindOf: self protocolManager protocolMsgReturnValueRuleSpec)
ifFalse: [referredToNames addAll: msgSpecReturn returnValueProtocolNames]].
^ referredToNames!
messagePattern
"Answer the message pattern of the receiver."
| aStream colonCnt parmNames |
parmNames := (self specForEachParmList collect: [:msgParmSpec | msgParmSpec parmName]) asArray.
(selector includes: $:)
ifFalse:
[parmNames size = 0 ifTrue: [^ selector asString].
parmNames size = 1 ifTrue: [^ selector asString , ' ' , (parmNames at: 1)].
self error: 'Mis-matched parms & selector.'].
aStream := WriteStream on: (String new: 200).
colonCnt := 0.
selector
do: [:char | char = $:
ifTrue:
[colonCnt := colonCnt + 1.
aStream nextPutAll: ': '.
aStream nextPutAll: (parmNames at: colonCnt).
colonCnt = parmNames size ifFalse: [aStream space]]
ifFalse: [aStream nextPut: char]].
^ aStream contents!
printOn: targetStream
"Append to targetStream a text representation of the receiver as a developer would want to see it (inspector, etc)."
#todo."??? fix ???"
targetStream nextPutAll: self class name;
nextPut: $(;
nextPutAll: self messageSelector;
nextPut: $(.
self specForEachParmList do: [:parmSpec | targetStream nextPutAll: parmSpec parmName]
separatedBy: [targetStream space].
targetStream nextPutAll: ') '.
" self specForEachReturnValueList
do: [ :returnSpec | targetStream nextPutAll: returnSpec parmName ]
separatedBy: [targetStream space].
"
targetStream nextPut: $)!
definedInProtocolName
"Answer the protocol name in which the receiver is defined, or nil."
#todo."??? should this be the proto is component of or Definition: sec proto ???"
specSections isNil ifTrue: [^ nil].
^ specSections at: #'DefinedIn' ifAbsent: []!
setSelector: selectorIn specSections: specSectionsIn specForEachParmList: parmSpecsIn specForEachReturnValueList: returnValueSpecsIn
"Private -
Note: Assumes all parms have been checked for validity."
selector := selectorIn.
specSections := specSectionsIn.
parameterSpecifications := parmSpecsIn.
returnValueSpecifications := returnValueSpecsIn!
specForEachParmList
"Answer the specification for each message parameter list of the receiver."
parameterSpecifications isNil ifTrue: [^ self class defaultParameterSpecificationCollection].
^ parameterSpecifications!
isReturnValueSpecByRule
"Answer true if the receiver return value protocol is detirmined by a rule, else false."
returnValueSpecifications isNil ifTrue: [
^false.
].
^returnValueSpecifications any isKindOf: (self protocolManager protocolMsgReturnValueRuleSpec)!
isConformingReturn: returnObject ruleReceiver: receiver operand: operand
"Answer true if the result, returnObject, of sending the receiver conforms to the specified return value, else false."
#todo."??? is no return value an error or compliant ???"
self hasReturnValue ifFalse: [^ true].
self isReturnValueSpecByRule ifFalse: [^ false].
^ self specForEachReturnValueList asArray first
isConformingReturnClass: returnObject class
ruleReceiver: receiver
operand: operand!
fileOutOnSIFFiler: programFiler protocol: protocolName
"File out the receiver definition and its message definitions on ANSI SIF filer, programFiler."
| parmString returnIsRuleSw returnOrRule tmpStream |
#todo. "??? Add annotations ???"
parmString := '#()'.
self hasParms
ifTrue:
[tmpStream := WriteStream on: (String new: 200).
tmpStream nextPutAll: '#( '.
self specForEachParmList do: [:msgParmSpec | msgParmSpec storeSIFOn: tmpStream]
separatedBy: [tmpStream space].
tmpStream nextPutAll: ' )'.
parmString := tmpStream contents].
returnIsRuleSw := false.
returnOrRule := '#()'.
self hasReturnValue
ifTrue: [self isReturnValueSpecByRule
ifTrue:
[returnIsRuleSw := true.
returnOrRule := self specForEachReturnValueList asArray first returnValueRuleBlockSource]
ifFalse:
[tmpStream := WriteStream on: (String new: 200).
tmpStream nextPutAll: '#( '.
self specForEachReturnValueList do: [:msgReturnSpec | msgReturnSpec storeSIFOn: tmpStream]
separatedBy: [tmpStream space].
tmpStream nextPutAll: ' )'.
returnOrRule := tmpStream contents]].
programFiler
fileOutProtocol: protocolName
message: self messagePattern
synopsis: self messageSynopsis
definedIn: self definedInProtocolName
definition: self messageDefinition
refinedIn: self refinedInProtocolName
refinement: self messageRefinement
parameters: parmString
returnIsRule: returnIsRuleSw
returnValuesOrRule: returnOrRule
errors: self messageErrors
annotations: Dictionary new!
hash
"Answer the hash value for the receiver."
#todo."I'm not sure this tests effectively for the same elements?????"
^ self messageSelector hash!
refinedInProtocolName
"Answer the protocol name in which the receiver is refined, or nil."
#todo."??? should this be the proto is component of or Refinement: sec proto ???"
specSections isNil ifTrue: [^ nil].
^ specSections at: #'RefinedIn' ifAbsent: []!
messageErrors
"Answer the errors of the receiver, or an empty string."
#todo."??? should this be the proto is component of or Definition: sec proto ???"
specSections isNil ifTrue: [^ String new].
^ specSections at: #'Errors' ifAbsent: [String new]!
<= comperand
"Answer whether the receiver's message selector is less than or equal to comperand's message selector.
Note: This is to allow protocol message selectors to be sorted with the default sort block."
(comperand isKindOf: self protocolManager protocolMsgSpec)
ifFalse: [self error: 'Comperand not a ProtocolSpec.'].
^ self messageSelector <= comperand messageSelector!
= comperand
"Answer whether the receiver is considered equal (contains same elements) to comperand. They are equal if both are instances of the same class and have the same message selector."
#todo."I'm not sure this tests effectively for the same elements?????"
^ (comperand isKindOf: self protocolManager protocolMsgSpec)
and: [self messageSelector == comperand messageSelector]!
messageRefinement
"Answer the refinement of the receiver, or an empty string."
#todo."??? should this be the proto is component of or Definition: sec proto ???"
specSections isNil ifTrue: [^ String new].
^ specSections at: #'Refinement' ifAbsent: [String new]!
isConformingReturn: returnObject ruleReceiver: receiver
"Answer true if the result, returnObject, of sending the receiver conforms to the specified return value, else false."
#todo."??? is no return value an error or compliant ???"
self hasReturnValue ifFalse: [^ true].
self isReturnValueSpecByRule ifFalse: [^ false].
^ self specForEachReturnValueList asArray first isConformingReturnClass: returnObject class ruleReceiver: receiver! !
!ProtocolMsgSpec class methodsFor: nil!
newSelector: selector specSections: specSections specsForEachParm: parmSpecs specsForEachReturnValue: retValSpecs
"Answer a new protocol message specification with selector, selector, specSections, specSections, a list of specifications for each parameter, parmSpecs, and a list of specifications for each return value, retValSpecs.
Note: specSections must be a <Dictionary> of <symbol> keys and <readableString> values, parmSpecs must be a <collection> of <protocolMessageParmSpec>s, retValSpecs, a <collection> of <protocolMessageReturnSpec>s."
^ self
privateNewSelector: selector
specSectionsOrNil: specSections
specForEachParmOrListOrNil: parmSpecs
specForEachReturnValueOrListOrNil: retValSpecs!
privateMessagePatternParmListOrNil: parmSpecsIn selector: selectorIn
"Private - Answer the message pattern of the receiver."
| aStream colonCnt parmNames parmSpecsTmp |
parmSpecsIn isNil
ifTrue: [parmSpecsTmp := Set new]
ifFalse: [parmSpecsTmp := parmSpecsIn].
parmNames := (parmSpecsTmp collect: [:msgParmSpec | msgParmSpec parmName]) asArray.
(selectorIn includes: $:)
ifFalse:
[parmNames size = 0 ifTrue: [^ selectorIn asString].
parmNames size = 1 ifTrue: [^ selectorIn asString , ' ' , (parmNames at: 1)].
self error: 'Mis-matched parms & selectorIn.'].
aStream := WriteStream on: (String new: 200).
colonCnt := 0.
selectorIn do: [:char |
char = $:
ifTrue:
[colonCnt := colonCnt + 1.
aStream nextPutAll: ': '.
aStream nextPutAll: (parmNames at: colonCnt).
colonCnt = parmNames size ifFalse: [aStream space]]
ifFalse: [aStream nextPut: char]].
^ aStream contents!
privateValidReturnValueOrListOrNil: retValSpecsIn ifError: errorBlock
"Private -"
| retValSpecsTmp |
retValSpecsIn isNil ifTrue: [^ nil].
(retValSpecsIn isKindOf: self protocolManager protocolMsgReturnValueSpec)
ifTrue:
[retValSpecsTmp := self defaultReturnValueSpecificationCollection.
retValSpecsTmp add: retValSpecsIn.
^ retValSpecsTmp].
(retValSpecsIn isKindOf: Collection)
ifFalse: [^ errorBlock value].
retValSpecsIn isEmpty ifTrue: [^ nil].
retValSpecsTmp := self defaultReturnValueSpecificationCollection.
retValSpecsIn
do:
[:rvSpec |
(rvSpec isKindOf: self protocolManager protocolMsgReturnValueSpec)
ifFalse: [^ errorBlock value].
retValSpecsTmp add: rvSpec].
^ retValSpecsTmp!
privateValidParmOrListOrNil: parmSpecsIn selector: selectorIn ifError: errorBlock
"Private -"
| parmSpecsTmp colonCnt |
(parmSpecsIn isKindOf: self protocolManager protocolMsgParmSpec)
ifTrue: [self privateMessagePatternParmListOrNil: (Set with: parmSpecsIn)
selector: selectorIn]
ifFalse: [self privateMessagePatternParmListOrNil: parmSpecsIn selector: selectorIn].
parmSpecsIn isNil ifTrue: [^ nil].
(parmSpecsIn isKindOf: self protocolManager protocolMsgParmSpec)
ifTrue:
[parmSpecsTmp := self defaultParameterSpecificationCollection.
parmSpecsTmp add: parmSpecsIn.
^ parmSpecsTmp].
(parmSpecsIn isKindOf: Collection)
ifFalse: [^ errorBlock value].
parmSpecsIn isEmpty ifTrue: [^ nil].
colonCnt := (selectorIn select: [:char | char = $:]) size.
colonCnt > 0
ifTrue: [colonCnt = parmSpecsIn size ifFalse: [self error: 'Protocol msg. spec. number of parms do not match selector.']]
ifFalse: [parmSpecsIn size = 0 | (parmSpecsIn size = 1) ifFalse: [self error: 'Protocol msg. spec. number of parms do not match selector.']].
parmSpecsTmp := self defaultParameterSpecificationCollection.
parmSpecsIn
do:
[:parmSpec |
(parmSpec isKindOf: self protocolManager protocolMsgParmSpec)
ifFalse: [^ errorBlock value].
parmSpecsTmp add: parmSpec].
^ parmSpecsTmp!
privateNewSelector: selectorIn specSectionsOrNil: specSectionsIn specForEachParmOrListOrNil: parmSpecsIn specForEachReturnValueOrListOrNil: retValSpecsIn
"Private -"
| newProtocolMsgSpec specSectionsTmp parmSpecsTmp retValSpecsTmp |
(selectorIn isKindOf: Symbol)
ifFalse: [self error: 'Protocol msg. spec. selector not a Symbol.'].
specSectionsTmp := self privateValidSpecSectionsOrNil: specSectionsIn ifError: [^ self error: 'Protocol msg. spec. spec. sections not a Dictionary.'].
parmSpecsTmp := self
privateValidParmOrListOrNil: parmSpecsIn
selector: selectorIn
ifError: [^ self error: 'Protocol msg. spec. parm not a Collection of ProtocolMsgSpec or nil.'].
retValSpecsTmp := self privateValidReturnValueOrListOrNil: retValSpecsIn ifError: [^ self error: 'Protocol ret. val. spec. not a Collection of MsgReturnSpec or nil.'].
newProtocolMsgSpec := super basicNew.
newProtocolMsgSpec
setSelector: selectorIn
specSections: specSectionsTmp
specForEachParmList: parmSpecsTmp
specForEachReturnValueList: retValSpecsTmp.
^ newProtocolMsgSpec!
new
"Raise an exception as this is an inappropriate message."
^ self shouldNotImplement!
privateValidSpecSectionsOrNil: specSectionsIn ifError: errorBlock
"Private -"
specSectionsIn isNil ifTrue: [^ nil].
(specSectionsIn isKindOf: Dictionary)
ifFalse: [^ errorBlock value].
specSectionsIn isEmpty ifTrue: [^ nil].
^ specSectionsIn!
defaultParameterSpecificationCollection
"Private - Answer a <Set>, the default parameter specification collection object."
^ Set new!
defaultReturnValueSpecificationCollection
"Private - Answer a <Set>, the default return value specification collection object."
^ Set new! !
!ReadStreamANSITest methodsFor: nil!
protocol
^#'ReadStream'!
setUp
super setUp.
readStream := ReadStream on: 'this is a string'!
canonicalObject
^readStream! !
!ReadStreamANSITest class methodsFor: nil!
helperClassesDo: aBlock
super helperClassesDo: aBlock.
aBlock value: GettableStreamHelper.
aBlock value: CollectionStreamHelper.
aBlock value: ReadStreamHelper.! !
!CharacterFactoryANSITest methodsFor: nil!
testXcr
" <Character factory>#cr "
#'Fundamental'.
self value: [Character cr]
should: [:r | true "implementation defined "]
conformTo: #'Character factory' selector: #'cr'.!
testXspace
" <Character factory>#space "
#'Fundamental'.
self value: [Character space]
should: [:r | true "implementation defined "]
conformTo: #'Character factory' selector: #'space'.!
protocol
^#'Character factory'!
testXlf
" <Character factory>#lf "
#'Fundamental'.
self value: [Character lf]
should: [:r | true "implementation defined "]
conformTo: #'Character factory' selector: #'lf'.!
testXtab
" <Character factory>#tab "
#'Fundamental'.
self value: [Character tab]
should: [:r | true "implementation defined "]
conformTo: #'Character factory' selector: #'tab'.!
canonicalObject
^Character!
testXcodePointX
" <Character factory>#codePoint: "
#'Fundamental'.
self value: [Character codePoint: ($a codePoint)] should: [:r | r = $a]
conformTo: #'Character factory' selector: #'codePoint:'.
self value: [Character codePoint: 3000000] shouldRaise: Error.! !
!ArrayANSITest methodsFor: nil!
emptyCollection
^self canonicalObject class new!
canonicalElement
^self canonicalObject at: 2!
canonicalObject
^#(1 2 3 4) copy!
protocol
^#Array! !
!ArrayANSITest class methodsFor: nil!
helperClassesDo: aBlock
super helperClassesDo: aBlock.
aBlock value: SequencedCollectionHelper.
aBlock value: SequencedReadableCollectionHelper! !
!FloatCharacterizationANSITest methodsFor: nil!
testXe
" <floatCharacterization>#e "
#'Numeric'.!
testXfminDenormalized
" <floatCharacterization>#fminDenormalized "
#'Numeric'.!
testXfmax
" <floatCharacterization>#fmax "
#'Numeric'.!
testXprecision
" <floatCharacterization>#precision "
#'Numeric'.!
testXepsilon
" <floatCharacterization>#epsilon "
#'Numeric'.!
testXpi
" <floatCharacterization>#pi "
#'Numeric'.!
protocol
^#'floatCharacterization'!
canonicalObject
^Float!
testXemin
" <floatCharacterization>#emin "
#'Numeric'.!
testXfminNormalized
" <floatCharacterization>#fminNormalized "
#'Numeric'.!
testXfmin
" <floatCharacterization>#fmin "
#'Numeric'.!
testXemax
" <floatCharacterization>#emax "
#'Numeric'.!
testXdenormalized
" <floatCharacterization>#denormalized "
#'Numeric'.!
testXradix
" <floatCharacterization>#radix "
#'Numeric'.! !
!MsgReturnRuleSpec methodsFor: nil!
returnProtocolName: receiver
^self ruleBlock value: receiver!
returnValueRuleBlockSource: blockSource
"Set the rule block source code that when evaluated with appropiate values answers the protocol message return value conforms-to protocol name."
ruleBlock := nil.
ruleSourceCode := blockSource.
(ruleSourceCode includes: $^) ifFalse: [^self].
ruleSourceCode := ruleSourceCode select: [:c | c ~~ $^]!
printOn: targetStream
"Append to targetStream a text representation of the receiver as a developer would want to see it (inspector, etc)."
targetStream nextPutAll: self class name;
nextPut: $(;
nextPutAll: self returnValueRuleBlockSource;
nextPut: $)!
returnValueAliasingAttribute
"Signal an error as the receiver specifies no behavior."
self error: 'Protocol msg. return value rule specifies no aliasing attribute.'!
newRetValRuleSourceCode: ruleBlockSource
"Private - ."
ruleBlock := nil.
ruleSourceCode := ruleBlockSource.
(ruleSourceCode includes: $^) ifFalse: [^self].
ruleSourceCode := ruleSourceCode select: [:c | c ~~ $^]!
isConformingReturnClass: returnClass ruleReceiver: receiver operand: operand
"Answer true if the class, returnClass, of the result of sending a message conforms to the receiver, else false."
| returnProtocolName |
#todo. "??? bug does not allow return in block ???"
returnProtocolName := self ruleBlock value: receiver value: operand.
^returnClass conformsToProtocolNamed: returnProtocolName.!
returnValueProtocolNames
"Signal an error as the receiver specifies no behavior."
self error: 'Protocol msg. return value rule specifies no protocol.'!
isConformingReturnClass: returnClass ruleReceiver: receiver
"Answer true if the class, returnClass, of the result of sending a message conforms to the receiver, else false."
| returnProtocolName |
#todo. "??? bug does not allow return in block ???"
returnProtocolName := self ruleBlock value: receiver.
^returnClass conformsToProtocolNamed: returnProtocolName.!
ruleBlock
ruleBlock isNil ifTrue: [ruleBlock := Compiler evaluate: ruleSourceCode].
^ruleBlock!
returnValueRuleBlockSource
"Answer the rule block source code that when evaluated with appropiate values answers the protocol message return value conforms-to protocol name."
^ ruleSourceCode! !
!MsgReturnRuleSpec class methodsFor: nil!
newRetValRuleSourceCode: ruleBlockSource
"Answer a new return value specification representing a protocol message's return value conforms-to protocol determined by evaluating the rule, ruleBlockSource, with appropiate values."
^ self privateNewRetValRuleSourceCode: ruleBlockSource!
privateNewRetValRuleSourceCode: ruleBlockSource
"Private - ."
(ruleBlockSource isKindOf: String)
ifFalse: [self error: 'Protocol msg. return value rule block source not a String.'].
^ self basicNew newRetValRuleSourceCode: ruleBlockSource;
yourself! !
!ProtocolANYSpec methodsFor: nil!
conformsToMessageSelectors
"Answer all of selectors which make up all protocols to which the receiver conforms."
| tmpList |
tmpList := self protocolManager defaultMessageSpecificationCollection.
self allConformsToProtocolNames do: [:aProtocollName | tmpList addAll: (self protocolManager protocolNamed: aProtocollName) messageSelectors].
^ tmpList!
removeSelector: unused
"Signal an error as the receiver specifies no behavior."
self error: 'Protocol <' , self protocolName , '> specifies no behavior.'!
removeSelector: unused1 ifAbsent: unused2
"Signal an error as the receiver specifies no behavior."
self error: 'Protocol <' , self protocolName , '> specifies no behavior.'!
wrkAllConformsToMessageSelectorsTo: aDict visited: visitedProtocols
self messageSelectors do: [:aMessageSelector |
(aDict includesKey: aMessageSelector)
ifFalse: [aDict at: aMessageSelector put: self protocolName]].
visitedProtocols add: self protocolName.
self conformsToProtocolNames do: [:aProtoName |
(visitedProtocols includes: aProtoName)
ifFalse: [(self protocolManager protocolNamed: aProtoName)
wrkAllConformsToMessageSelectorsTo: aDict
visited: visitedProtocols]]!
messageSelectors
"Answer an empty list of of selectors which make up the receiver's protocol."
^ self protocolManager defaultMessageSpecificationCollection!
protocolName
"Answer the name of the receiver."
^ self protocolManager protocolANYName!
renameToProtocolName: unused
"Signal an error as the receiver can not be renamed."
self error: 'Protocol <' , self protocolName , '> can not be renamed.'!
removeAllSelectors: unused
"Signal an error as the receiver specifies no behavior."
self error: 'Protocol <' , self protocolName , '> specifies no behavior.'!
allConformsToProtocolNames
"Answer the names of all protocols to which the receiver conforms including super protocols."
| tmpList |
tmpList := self conformsToProtocolNames.
self conformsToProtocolNames do: [:aProtocollName | tmpList addAll: (self protocolManager protocolNamed: aProtocollName) allConformsToProtocolNames].
^ tmpList!
fileOutOnSIFFiler: programFiler
"Do nothing as the receiver is created by protocol initialization."
^ self!
messageOrNilAtSelector: selector
"Answer nil <ANY> protocol by definition can't have any messages."
"2000/06/23 Harmon, R. Added to fix bug when TestCaseANSI >>
#assertSend: is sent with a selector not defined in the
target protocol or any of its inherited protocols."
^nil!
printOn: targetStream
"Append to targetStream a text representation of the receiver as a developer would want to see it (inspector, etc)."
targetStream nextPut: $<;
nextPutAll: self protocolName;
nextPut: $>;
nextPut: $(.
self messageSelectors do: [:selector | targetStream nextPutAll: selector]
separatedBy: [targetStream nextPutAll: ', '].
targetStream nextPut: $)!
allMessageSelectors
"Answer all of selectors which make up the receiver's protocol and all protocols to which the receiver conforms."
| tmpList |
tmpList := self messageSelectors.
self allConformsToProtocolNames do: [:aProtocollName | tmpList addAll: (self protocolManager protocolNamed: aProtocollName) messageSelectors].
^ tmpList!
conformingBehaviors
"Answer all classes in class then metaclass hierarchy order (i.e. superclasses first) as all conform to the receiver.
Note: Return value is a <OrderedCollection> of class or metaclass objects."
| answer |
answer := OrderedCollection new: 10.
Smalltalk allClasses do: [:class |
answer addLast: class.
answer addLast: class class].
^ answer!
messages
"Answer an empty list of of message specifications of the receiver."
^ self protocolManager defaultMessageSpecificationCollection!
hash
"Answer the hash value for the receiver."
^ self protocolName hash!
selectorsInBehavior: classOrMetaclass
"Answer an empty list of selectors ofcorresponding messages as all classes and metaclasses conform to the receiver but it specifies no behavior."
^ Set new!
<= comperand
"Answer whether the receiver is less than or equal to comperand.
Note: This is to allow protocols to be sorted with the default sort block."
(comperand isKindOf: self protocolManager protocol)
| (comperand isKindOf: self protocolManager protocolANY) ifFalse: [self error: 'Comperand not a ProtocolSpec.'].
^ self protocolName asLowercase <= comperand protocolName asLowercase!
conformsToProtocolNames
"Answer an empty list of protocol names to which the receiver conforms."
^ self protocolManager defaultConformsToCollection!
= comperand
"Answer whether the receiver is considered equal (contains same elements) to comperand."
^ (comperand isKindOf: self protocolManager protocol)
and: [self protocolName == comperand protocolName]!
protocolDescription
"Answer a description of the receiver."
^ 'A protocol to which all other protocols conform.' copy!
displayOn: targetStream
"Append the receiver to targetStream in a format that a user would want to see."
targetStream nextPut: $<;
nextPutAll: self protocolName;
nextPut: $>!
addUndefinedProtocolNames
^ self!
includesSelector: unused
"Answer false as the receiver specifies no behavior."
^ false! !
!ProtocolANYSpec class methodsFor: nil!
new
"Raise an exception as this is an inappropriate message."
^ self shouldNotImplement!
privateNewProtocolANY
"Private -"
| newProtocol |
newProtocol := self basicNew.
^ newProtocol! !
!WriteFileStreamANSITest methodsFor: nil!
testXflush
" <puttableStream>#flush "
#'File Stream'.!
testXnextPutX
" <puttableStream>#nextPut: "
#'File Stream'.!
testXisEmpty
" <sequencedStream>#isEmpty "
#'File Stream'.!
protocol
^#'writeFileStream'!
testXtab
" <puttableStream>#tab "
#'File Stream'.!
setUp
super setUp.
" This method will create a file named 'ansiTestFile.junk' in the current directory
if it does not already exist. "
"writeFileStream := FileStream write: 'ansiTestFile.junk'"!
testXspace
" <puttableStream>#space "
#'File Stream'.!
testXsetToEnd
" <sequencedStream>#setToEnd "
#'File Stream'.!
testXpositionX
" <sequencedStream>#position: "
#'File Stream'.!
testXisBinary
" <FileStream>#isBinary "
#'File Stream'.!
tearDown
"writeFileStream close"!
testXcontents
" <FileStream>#contents "
#'File Stream'.!
testXreset
" <sequencedStream>#reset "
#'File Stream'.!
testXisText
" <FileStream>#isText "
#'File Stream'.!
testXclose
" <sequencedStream>#close "
#'File Stream'.!
testXexternalType
" <FileStream>#externalType "
#'File Stream'.!
testXcr
" <puttableStream>#cr "
#'File Stream'.!
testXnextPutAllX
" <puttableStream>#nextPutAll: "
#'File Stream'.!
canonicalObject
^writeFileStream!
testXposition
" <sequencedStream>#position "
#'File Stream'.! !
!WriteStreamANSITest methodsFor: nil!
protocol
^#'WriteStream'!
setUp
super setUp.
writeStream := WriteStream with: 'this is a string' copy!
canonicalObject
^writeStream! !
!WriteStreamANSITest class methodsFor: nil!
helperClassesDo: aBlock
super helperClassesDo: aBlock.
aBlock value: PuttableStreamHelper.
aBlock value: CollectionStreamHelper.
aBlock value: WriteStreamHelper.! !
!WriteStreamFactoryANSITest methodsFor: nil!
protocol
^#'WriteStream factory'!
canonicalObject
^WriteStream!
testXwithX
self value: [self canonicalObject with: 'this is a string']
should: [:r | r position = ('this is a string' size)
& r contents = 'this is a string']
conformTo: self protocol selector: #'with:'.! !
!DyadicValuableANSITest methodsFor: nil!
testXvalueWithArgumentsX
" <valuable>#valueWithArguments: "
#'Valuable'.
self value: [blk2args valueWithArguments: #(1 2)]
should: [:r | r = #(1 2)]
conformTo: #'valuable' selector: #'valueWithArguments:'.!
testXargumentCount
" <dyadicValuable>#argumentCount "
#'Valuable'.
self value: [blk2args argumentCount] should: [:r | r = 2]
conformTo: #'dyadicValuable' selector: #'argumentCount'.!
protocol
^#'dyadicValuable'!
setUp
super setUp.
blk2args := [ :arg1 :arg2 | Array with: arg1 with: arg2 ].!
testXvalueXvalueX
" <dyadicValuable>#value:value: "
#'Valuable'.
self value: [blk2args value: 1 value: 2] should: [:r | r = #(1 2)]
conformTo: #'dyadicValuable' selector: #'value:value:'.!
canonicalObject
^blk2args! !
!ExtensibleCollectionHelper methodsFor: nil!
testXaddAllX
" <extensibleCollection>#addAll: "
| extensibleCollection addCollection compareCollection |
#'Collection'.
extensibleCollection := self object.
self
value: [extensibleCollection addAll: #(666 777)]
should: [:result | (extensibleCollection includes: 777) and: [extensibleCollection includes: 666]]
conformTo: #extensibleCollection
selector: #addAll:.
addCollection := OrderedCollection with: 555 with: 444.
extensibleCollection := self object.
compareCollection := self object.
self should: [(addCollection do: [:each | extensibleCollection add: each]) = (compareCollection addAll: addCollection)]!
testXremoveX
" <extensibleCollection>#remove: "
| extensibleCollection sampleValue |
#'Collection'.
extensibleCollection := self object.
extensibleCollection do: [ :each | sampleValue := each].
self
value: [ extensibleCollection remove: sampleValue ]
should: [:result | (extensibleCollection includes: sampleValue) not ]
conformTo: #extensibleCollection
selector: #remove:!
testXaddX
" <extensibleCollection>#add: "
| extensibleCollection |
#'Collection'.
extensibleCollection := self object.
self
value: [ extensibleCollection add: 777 ]
should: [:result | extensibleCollection includes: 777]
conformTo: #extensibleCollection
selector: #add:!
testXremoveAllX
" <extensibleCollection>#removeAll: "
| extensibleCollection removeAll |
#'Collection'.
extensibleCollection := self object.
removeAll := self object.
self
value: [ extensibleCollection removeAll: removeAll]
should: [:result | extensibleCollection isEmpty ]
conformTo: #extensibleCollection
selector: #removeAll:!
object: anObject!
testXremoveXifAbsentX
" <extensibleCollection>#remove:ifAbsent: "
| extensibleCollection sampleValue |
#'Collection'.
extensibleCollection := self object.
extensibleCollection do: [ :each | sampleValue := each].
self
value: [ extensibleCollection remove: sampleValue ifAbsent: [#foo]]
should: [:result | result = sampleValue ]
conformTo: #extensibleCollection
selector: #remove:ifAbsent:.
self
value: [ extensibleCollection remove: sampleValue ifAbsent: [#foo]]
should: [:result | result = #foo ]
conformTo: #extensibleCollection
selector: #remove:ifAbsent:!
object
^testCase canonicalObject! !
!SetFactoryANSITest methodsFor: nil!
testXwithX
" <Set factory>#with: "
#'Collection'.!
testXwithXwithX
" <Set factory>#with:with: "
#'Collection'.!
testXnew
" <Set factory>#new "
#'Collection'.!
protocol
^#'Set factory'!
testXnewX
" <Set factory>#new: "
#'Collection'.!
testXwithAllX
" <Set factory>#withAll: "
#'Collection'.!
canonicalObject
^Set!
testXwithXwithXwithX
" <Set factory>#with:with:with: "
#'Collection'.!
testXwithXwithXwithXwithX
" <Set factory>#with:with:with:with: "
#'Collection'.! !
!ObjectANSITest methodsFor: nil!
protocol
^#Object!
setUp
super setUp.
object := Object new.!
canonicalObject
^object! !
!NotificationClassANSITest methodsFor: nil!
testXsignalX
" <exceptionSignaler>#signal: "
#'Exception'.!
testXallSubclasses
" <classDescription>#allSubclasses "
#'Exception'.!
testXname
" <classDescription>#name "
#'Exception'.!
testXsuperclass
" <classDescription>#superclass "
#'Exception'.!
protocol
^#'Notification class'!
testXconcatenateOp
" <exceptionSelector>#, "
#'Exception'.!
testXallSuperclasses
" <classDescription>#allSuperclasses "
#'Exception'.!
testXnew
" <Notification class>#new "
#'Exception'.
self value: [Notification new]
should: [:r | true "??? r = Notification signal ???"]
conformTo: #'Notification class' selector: #'new'.!
testXsignal
" <Exception class>#signal "
#'Exception'.!
canonicalObject
^Notification!
testXhandlesX
" <Exception class>#handles: "
#'Exception'.!
testXsubclasses
" <classDescription>#subclasses "
#'Exception'.! !
!NiladicBlockANSITest methodsFor: nil!
setUp
super setUp.
blk0args := [ Array new ].
canonicalObject := [3+4]!
testXonXdoX
" <niladicBlock>#on:do: "
#'Valuable'.
self value: [ [#( 1 2 ) size] on: Error do: [ :error | error return: -1] ]
should: [:r | r = 2]
conformTo: #'niladicBlock' selector: #'on:do:'.
self value: [[Error signal. 0] on: Error do: [:error | error return: -1]]
should: [:r | r = -1]
conformTo: #'niladicBlock' selector: #'on:do:'.!
testXwhileTrueX
" <niladicValuable>#whileTrue: "
| sum |
#'Valuable'.
sum := 0.
self value: [ [sum < 4 ] whileTrue: [sum := sum + 1] ]
should: [:r | sum = 4]
conformTo: #'niladicValuable' selector: #'whileTrue:'.
sum := 0.
self value: [ [sum < 0 ] whileTrue: [sum := sum + 1] ]
should: [:r | sum = 0]
conformTo: #'niladicValuable' selector: #'whileTrue:'.!
testXensureX
" <niladicBlock>#ensure: "
| flag tmp |
#'Valuable'.
flag := 0.
self value: [ [#( 1 2 ) size] ensure: [flag := 1] ]
should: [:r | r = 2 & flag = 1]
conformTo: #'niladicBlock' selector: #'ensure:'.
#'todo'."I don't think this is a good test."
flag := 0.
[tmp := [#( 1 2 ) siz] ensure: [ flag := 1 ].
] on: MessageNotUnderstood do: [ :mnu | mnu return ].
self value: [tmp] should: [:r | flag = 1]
conformTo: #'niladicBlock' selector: #'ensure:'.
self value: [ [#( 1 2 ) siz] ensure: [ flag := 1 ] ]
shouldRaise: MessageNotUnderstood.
#'todo'."or this ."
flag := 0.
[tmp := [Error signal] ensure: [ flag := 1 ].
] on: Error do: [ :error | error return ].
self value: [ tmp ] should: [:r | flag = 1]
conformTo: #'niladicBlock' selector: #'ensure:'.
self value: [ [Error signal] ensure: [ flag := 1 ] ]
shouldRaise: Error.
#'testAnom'. "??? I think the ensure block should not be evaluated as per:
Activation of an exception handler from within the receiver is not in and of itself an abnormal termination. However, if the exception handler for an exception that is not resumable results in termination of the receiver or if its handler block contains a return statement that results in abnormal termination of the receiver, then terminationBlock will be evaluated after evaluation of the exception handler.
flag := 0.
[tmp := [Notification signal] ensure: [ flag := 1 ].
] on: Notification do: [ :notification | notification resume ].
self value: [ tmp ] should: [:r | flag = 0]
conformTo: #'niladicBlock' selector: #'ensure:'.
???"
self value: [ [Notification signal] ensure: [] ]
shouldRaise: Notification.!
protocol
^#'niladicBlock'!
testXargumentCount
" <niladicValuable>#argumentCount "
#'Valuable'.
self value: [blk0args argumentCount] should: [:r | r = 0]
conformTo: #'niladicValuable' selector: #'argumentCount'.!
testXwhileTrue
" <niladicValuable>#whileTrue "
| sum |
#'Valuable'.
sum := 0.
self value: [ [(sum := sum + 1) < 4 ] whileTrue ]
should: [:r | sum = 4]
conformTo: #'niladicValuable' selector: #'whileTrue'.!
testXvalueWithArgumentsX
" <valuable>#valueWithArguments: "
#'Valuable'.
self value: [blk0args valueWithArguments: #()] should: [:r | r = #()]
conformTo: #'valuable' selector: #'valueWithArguments:'.!
testXwhileFalse
" <niladicValuable>#whileFalse "
| sum |
#'Valuable'.
sum := 0.
self value: [ [(sum := sum + 1) >= 3] whileFalse]
should: [:r | sum = 3]
conformTo: #'niladicValuable' selector: #'whileFalse'.!
testXvalue
" <niladicValuable>#value "
#'Valuable'.
self value: [blk0args value] should: [:r | r = #()]
conformTo: #'niladicValuable' selector: #'value'.!
canonicalObject
^canonicalObject!
testXifCurtailedX
" <niladicBlock>#ifCurtailed: "
| flag tmp |
#'Valuable'.
self value: [ [flag := 0] ifCurtailed: [flag := 1] ]
should: [:r | r = 0 & flag = 0]
conformTo: #'niladicBlock' selector: #'ifCurtailed:'.
[tmp := [Notification signal. 0] ifCurtailed: [flag := 1].
] on: Notification do: [ :notification | notification resume ].
self value: [ tmp ] should: [:r | r = 0 & flag = 0]
conformTo: #'niladicBlock' selector: #'ifCurtailed:'.!
testXwhileFalseX
" <niladicValuable>#whileFalse: "
| element aReadStream |
#'Valuable'.
aReadStream := ReadStream on: (Array with: 1 with: 2 with: 3).
self value: [[aReadStream atEnd] whileFalse: [
element := aReadStream next]]
should: [:r | element = 3]
conformTo: #'niladicValuable' selector: #'whileFalse:'.
element := 0.
self value: [ [element = 0] whileFalse: [element := 1] ]
should: [:r | element = 0]
conformTo: #'niladicValuable' selector: #'whileFalse:'.! !
!MessageNotUnderstoodSelectorANSITest methodsFor: nil!
testXhandlesX
" <MessageNotUnderstoodSelector>#handles: "
#'Exception'.
self value: [ [ MessageNotUnderstood signal
] on: MessageNotUnderstood do: [ :mnu |
mnu return: (MessageNotUnderstood handles: mnu) ] ]
should: [:r | r]
conformTo: #'MessageNotUnderstoodSelector' selector: #'handles:'.
" ??? should! "
self value: [ [ MessageNotUnderstood signal
] on: MessageNotUnderstood do: [ :mnu |
mnu return: (Error handles: mnu) ] ]
should: [:r | r]
conformTo: #'MessageNotUnderstoodSelector' selector: #'handles:'.!
testXconcatenateOp
" <exceptionSelector>#, "
#'Exception'.!
canonicalObject
^MessageNotUnderstood!
protocol
^#MessageNotUnderstoodSelector! !
!FractionANSITest methodsFor: nil!
testXasScaledDecimalX
" <number>#asScaledDecimal: "
#'Numeric'.
self value: [(1/2) asScaledDecimal: 2]
should: [:r | r = 0.5s2 & (r scale = 2)]
conformTo: #'number' selector: #'asScaledDecimal:'.
self value: [(-1/2) asScaledDecimal: 2]
should: [:r | r = -0.5s2 & (r scale = 2)]
conformTo: #'number' selector: #'asScaledDecimal:'.!
testXtoXbyXdoX
" <number>#to:by:do: "
#'Numeric'.!
testXasInteger
" <number>#asInteger "
#'Numeric'.
self value: [(1/3) asInteger] should: [:r | r = 0]
conformTo: #'number' selector: #'asInteger'.
self value: [(1/2) asInteger] should: [:r | r = 1]
conformTo: #'number' selector: #'asInteger'.
self value: [(-1/2) asInteger] should: [:r | r = -1]
conformTo: #'number' selector: #'asInteger'.!
testXdenominator
" <Fraction>#denominator "
#'Numeric'.!
testXmaxX
" <magnitude>#max: "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and operand are not comparable."
self value: [(1/2) max: 3] should: [:r | r = 3]
conformTo: #'magnitude' selector: #'max:'.
self value: [(-9000000000/2) max: -2000000000]
should: [:r | r = -2000000000]
conformTo: #'magnitude' selector: #'max:'.
self value: [(1/2) max: 2000000003] should: [:r | r = 2000000003]
conformTo: #'magnitude' selector: #'max:'.
self value: [(1/2) max: 3.0] should: [:r | r = 3.0]
conformTo: #'magnitude' selector: #'max:'.
self value: [(1/2) max: (5/2)] should: [:r | r = (5/2)]
conformTo: #'magnitude' selector: #'max:'.
self value: [(1/2) max: 3.0s3] should: [:r | r = 3.0s3]
conformTo: #'magnitude' selector: #'max:'.
"Num max: Num -> Num"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx) max: (numList at: ndx)]
should: [:r | r = (numList at: ndx)]
conformTo: #'magnitude' selector: #'max:'
].!
testXnotEqualityOp
" <Object>#~= "
#'Numeric'.
" The value of receiver ~= comparand is true if and only if the value of
comparand ~= receiver would also be true.
"
self value: [fractionHalf ~= (2/3)]
should: [:r | r] conformTo: #'Object' selector: #'~='.
self value: [smallInt2 ~= (6/2)]
should: [:r | r] conformTo: #'Object' selector: #'~='.
self value: [fractionHalf ~= fractionHalf]
shouldnt: [:r | r] conformTo: #'Object' selector: #'~='.
self value: [smallInt2 ~= (4/2)]
shouldnt: [:r | r] conformTo: #'Object' selector: #'~='.!
testXbetweenXandX
" <magnitude>#between:and: "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and min or max are not comparable"
self value: [(1/2) between: 0 and: 3]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/ -2) between: -2000000003 and: 0]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 0 and: 2000000003]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 0.0 and: 3.0]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: (1/4) and: (5/2)]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 0.0s3 and: 3.0s3]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: -2000000001 and: 2000000003]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 0.0 and: 3.0s3]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
"Num between: Num and: Num -> true"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx)
between: (numList at: ndx)
and: (numList at: ndx)]
should: [:r | r] conformTo: #'magnitude' selector: #'between:and:'
].
self value: [(1/2) between: 3 and: 4]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: -2000000003 and: -2000000005]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 2000000003 and: 2000000005]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 3.0 and: 5.0]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: (5/2) and: (7/2)]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
self value: [(1/2) between: 3.0s3 and: 5.0s3]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.
"??? min not min but max and vice versa -> false ???"
self value: [(1/2) between: 3 and: 1]
shouldnt: [:r | r] conformTo: #'magnitude' selector: #'between:and:'.!
testXabs
" <number>#abs (Return Values: <RECEIVER>) "
| rcvr |
#'Numeric'.
rcvr := 1/2.
self value: [rcvr abs] should: [:r | r = (1/2)]
conformTo: #'number' selector: #'abs' opRECEIVER: rcvr.
rcvr := -1/2.
self value: [rcvr abs] should: [:r | r = (1/2)]
conformTo: #'number' selector: #'abs' opRECEIVER: rcvr.!
testXraisedToIntegerX
" <number>#raisedToInteger: (Return Values: <RECEIVER>)"
| rcvr |
#'Numeric'.
rcvr := 51/10.
self value: [rcvr raisedToInteger: 0] should: [:r | r = 1]
conformTo: #'number' selector: #'raisedToInteger:' opRECEIVER: rcvr.
self value: [rcvr raisedToInteger: 1] should: [:r | r = rcvr]
conformTo: #'number' selector: #'raisedToInteger:'
opRECEIVER: rcvr.
self value: [rcvr raisedToInteger: 2] should: [:r | r = (2601/100)]
conformTo: #'number' selector: #'raisedToInteger:'
opRECEIVER: rcvr.
self value: [rcvr negated raisedToInteger: 2]
should: [:r | r = (2601/100)]
conformTo: #'number' selector: #'raisedToInteger:'
opRECEIVER: rcvr.
self value: [rcvr raisedToInteger: -2] should: [:r | r = ( 100/2601)]
conformTo: #'number' selector: #'raisedToInteger:'
opRECEIVER: rcvr.
"It is erroneous if the operand does not conform
to the protocol <integer>."
self value: [rcvr raisedToInteger: (51/10)]
shouldRaise: Error.!
testXasFraction
" <number>#asFraction "
#'Numeric'.
self value: [(1/2) asFraction] should: [:r | r = (1/2)]
conformTo: #'number' selector: #'asFraction'.
self value: [(-1/2) asFraction] should: [:r | r = (-1/2)]
conformTo: #'number' selector: #'asFraction'.!
testXisKindOfX
" <Object>#isKindOf: "
#'Numeric'.
" The return value is unspecified if the receiver is a class object or candidateClass is not a class object.
"
#todo. "Fix find a test for unspecified rule above ???"
self value: [fractionHalf isKindOf: Fraction]
should: [:r | r] conformTo: #'Object' selector: #'isKindOf:'.
"Metaclass tests:"
self value: [fractionHalf class isKindOf: (Fraction class)]
should: [:r | r] conformTo: #'Object' selector: #'isKindOf:'.
"Inherit tests:"
self value: [fractionHalf class isKindOf: (Number class)]
should: [:r | r] conformTo: #'Object' selector: #'isKindOf:'.
self value: [fractionHalf isKindOf: Symbol]
shouldnt: [:r | r] conformTo: #'Object' selector: #'isKindOf:'.!
testXtruncated
" <number>#truncated "
#'Numeric'.
self value: [(1/3) truncated] should: [:r | r = 0]
conformTo: #'number' selector: #'truncated'.
self value: [(3/2) truncated] should: [:r | r = 1]
conformTo: #'number' selector: #'truncated'.
self value: [(-1/2) truncated] should: [:r | r = 0]
conformTo: #'number' selector: #'truncated'.!
testXroundToX
" <number>#roundTo: (returnRule - :receiver :operand) "
| retVals frac |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
frac := (51/10).
retVals := #(6 0 0 6.0 5 6.000s3).
1 to: numList size do: [ :ndx |
self value: [frac roundTo: (numList at: ndx)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'roundTo:'
ruleReceiver: frac operand: (numList at: ndx)
].
self should: [(0.0 roundTo: fractionHalf) = 0.0]!
testXasFloat
" <number>#asFloat "
#'Numeric'.
self value: [(1/2) asFloat] should: [:r | r = 0.5]
conformTo: #'number' selector: #'asFloat'.
self value: [(-1/2) asFloat] should: [:r | r = -0.5]
conformTo: #'number' selector: #'asFloat'.!
testXremX
" <number>#rem: "
| retVals ndx num2 frac |
#'Numeric'.
"Within the limits of representation, the following invariant should hold:
(receiver quo: operand)*operand + (receiver rem: operand) = receiver"
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
numList := #( 5 5.0 5.0s3 ).
frac := (53/2).
retVals := Array with: (3/2) with: 1.5 with: (3/2).
ndx := 0.
numList do: [ :num |
ndx := ndx + 1.
self value: [frac rem: num]
should: [:r | r = (retVals at: ndx)
& ((frac quo: num) * num + (frac rem: num)
= frac)]
conformTo: #'number' selector: #'rem:'
].
numList := numList collect: [ :num | num negated ].
ndx := 0.
numList do: [ :num |
ndx := ndx + 1.
self value: [frac rem: num]
should: [:r | r = (retVals at: ndx)
& ((frac quo: num) * num + (frac rem: num)
= frac)]
conformTo: #'number' selector: #'rem:'
].
frac := (-53/2).
numList := #( 5 5.0 5.0s3 ).
retVals := retVals collect: [ :num | num negated ].
ndx := 0.
numList do: [ :num |
ndx := ndx + 1.
self should: [(frac rem: num) = (retVals at: ndx)
& ((frac quo: num) * num + (frac rem: num)
= frac)]
].
ndx := 0.
numList do: [ :num |
ndx := ndx + 1.
self should: [(frac rem: num) = (retVals at: ndx)
& ((frac quo: num) * num + (frac rem: num)
= frac)]
].
frac := (53/2).
num2 := (5/2).
self value: [frac rem: num2]
should: [:r | r = (3/2)
& ((frac quo: num2) * num2 + (frac rem: num2)
= frac)]
conformTo: #'number' selector: #'rem:'.
frac := (20000000003/2).
numList := #( -2000000000 2000000000 ).
numList do: [ :num |
self value: [frac rem: num]
should: [:r | r = (3/2)
& ((frac quo: num) * num + (frac rem: num)
= frac)]
conformTo: #'number' selector: #'rem:'
].
"If either the receiver or operand are of type <Float> and the operand has a value of zero, the result is implementation defined. The implementation may signal the ZeroDivide exception or provide a continuation value "
self value: [fractionHalf rem: 0.0] shouldRaise: ZeroDivide.
self value: [fractionHalf rem: 0] shouldRaise: ZeroDivide.!
testXnotIdentityOp
" <Object>#~~ "
#'Numeric'.
" The value of receiver ~~ comparand is true if and only if the value of comparand ~~ receiver would also be true.
"
self should: [fractionHalf ~~ (2/3) and: [(2/3) ~~ fractionHalf]].
self value: [fractionHalf ~~ (2/3)]
should: [:r | r] conformTo: #'Object' selector: #'~~'.
self value: [smallInt2 ~~ (6/2)]
should: [:r | r] conformTo: #'Object' selector: #'~~'.
self value: [fractionHalf ~~ fractionHalf]
shouldnt: [:r | r] conformTo: #'Object' selector: #'~~'.
self value: [smallInt2 ~~ (4/2)]
shouldnt: [:r | r] conformTo: #'Object' selector: #'~~'.!
testXtoXbyX
" <number>#to:by: "
#'Numeric'.!
testXequalityOp
" <number>#= "
#'Numeric'.
" receiver = comparand =>
receiver hash = comparand hash
"
self value: [fractionHalf = fractionHalf]
should: [:r | r & (fractionHalf hash = fractionHalf hash) ]
conformTo: #'number' selector: #'='.
self value: [ fractionHalf = (5/2) ]
shouldnt: [ :r | r | (fractionHalf hash = (5/2) hash) ]
conformTo: #'number' selector: #'='.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
self value: [ fractionHalf = 2 ]
should: [ :r | r ifTrue: [ fractionHalf hash = 2 hash ]
ifFalse: [ fractionHalf hash ~= 2 hash ] ]
conformTo: #'number' selector: #'='.
self value: [ fractionHalf = -2000000000 ]
should: [ :r | r ifTrue: [ fractionHalf hash = -2000000000 hash ]
ifFalse: [ fractionHalf hash ~= -2000000000 hash ] ]
conformTo: #'number' selector: #'='.
self value: [ fractionHalf = 2000000000 ]
should: [ :r | r ifTrue: [ fractionHalf hash = 2000000000 hash ]
ifFalse: [ fractionHalf hash ~= 2000000000 hash ] ]
conformTo: #'number' selector: #'='.
self value: [ fractionHalf = 0.5 ]
should: [ :r | r ifTrue: [ fractionHalf hash = 0.5 hash ]
ifFalse: [ fractionHalf hash ~= 0.5 hash ] ]
conformTo: #'number' selector: #'='.
self value: [ fractionHalf = 0.5s3 ]
should: [ :r | r ifTrue: [ fractionHalf hash = 0.5s3 hash ]
ifFalse: [ fractionHalf hash ~= 0.5s3 hash ] ]
conformTo: #'number' selector: #'='.!
testXstrictlyPositive
" <number>#strictlyPositive "
#'Numeric'.
self value: [(1/2) strictlyPositive] should: [:r | r]
conformTo: #'number' selector: #'strictlyPositive'.
self value: [(-1/2) strictlyPositive] shouldnt: [:r | r]
conformTo: #'number' selector: #'strictlyPositive'.!
testXidentityOp
" <Object>#== "
#'Numeric'.
" The value of receiver == comparand is true if and only if the value of comparand == receiver would also be true. If the value of receiver == comparand is true then the receiver and comparand must have equivalent identity hash values. Or more formally:
receiver == comparand =>
receiver identityHash = comparand identityHash
"
self value: [fractionHalf == fractionHalf]
should: [:r | r] conformTo: #'Object' selector: #'=='.
self value: [smallInt2 == (4/2)]
should: [:r | r] conformTo: #'Object' selector: #'=='.
self value: [fractionHalf == (2/3)]
shouldnt: [:r | r] conformTo: #'Object' selector: #'=='.
self value: [smallInt2 == (6/2)]
shouldnt: [:r | r] conformTo: #'Object' selector: #'=='.!
testXnegated
" <number>#negated (Return Values: <RECEIVER>) "
| rcvr |
#'Numeric'.
rcvr := 3/2.
self value: [rcvr negated] should: [:r | r = (-3/2)]
conformTo: #'number' selector: #'negated' opRECEIVER: rcvr.
rcvr := -3/2.
self value: [rcvr negated] should: [:r | r = (3/2)]
conformTo: #'number' selector: #'negated' opRECEIVER: rcvr.!
testXisMemberOfX
" <Object>#isMemberOf: "
#'Numeric'.
" The return value is unspecified if the receiver is a class object or candidateClass is not a class object.
"
#todo. "Fix find a test for unspecified rule above ???"
self value: [fractionHalf isMemberOf: Fraction]
should: [:r | r] conformTo: #'Object' selector: #'isMemberOf:'.
"Metaclass tests:"
self value: [fractionHalf class isMemberOf: (Fraction class)]
should: [:r | r] conformTo: #'Object' selector: #'isMemberOf:'.
"Fail inherit tests:"
self value: [fractionHalf class isMemberOf: (Number class)]
shouldnt: [:r | r] conformTo: #'Object' selector: #'isMemberOf:'.
self value: [fractionHalf isMemberOf: Float]
shouldnt: [:r | r] conformTo: #'Object' selector: #'isMemberOf:'.!
testXsquared
" <number>#squared (Return Values: <RECEIVER>)"
| rcvr |
#'Numeric'.
rcvr := 51/10.
self value: [rcvr squared] should: [:r | r = (2601/100)]
conformTo: #'number' selector: #'squared' opRECEIVER: rcvr.
rcvr := -51/10.
self value: [rcvr squared] should: [:r | r = (2601/100)]
conformTo: #'number' selector: #'squared' opRECEIVER: rcvr.!
testXremainderIntegerDivideOp
" <number>#\\ (returnRule - :receiver :operand) "
"The remainder has the same sign as operand.
Within the limits of representation, the following invariant should hold:
(receiver // operand) * operand + (receiver \\ operand) = receiver
"
| retVals recList ndx |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
recList := #( 26 -26000000006 26000000006 26.0 0 26.0s3 ) copy.
recList at: 5 put: (53/2).
retVals := #( 0 1 0 0.5 1 0 ) copy.
retVals at: 1 put: (1/2).
retVals at: 3 put: (1/2).
retVals at: 6 put: (1/2).
ndx := 0.
recList do: [ :rec |
ndx := ndx + 1.
self value: [rec \\ (3/2)]
should: [:r | r = (retVals at: ndx)
& ((rec // (3/2)) * (3/2) + (rec \\ (3/2)) = rec)]
conformTo: #'number' selector: #'\\'
ruleReceiver: rec operand: (3/2).
].
"The remainder has the same sign as operand."
retVals := #(-1 0 -1 -1.0 0 -1.000s3 ) copy.
retVals at: 2 put: (-1/2).
retVals at: 5 put: (-1/2).
ndx := 0.
recList do: [ :rec |
ndx := ndx + 1.
self value: [rec \\ (-3/2)]
should: [:r | r = (retVals at: ndx)
& ((rec // (-3/2)) * (-3/2) + (rec \\ (-3/2)) = rec)]
conformTo: #'number' selector: #'\\'
ruleReceiver: rec operand: (-3/2).
].
self should: [(53/2) \\ (3/2) = 1
& (((53/2) // (3/2)) * (3/2) + ((53/2) \\ (3/2)) = (53/2))].
self should: [(53/2) \\ (-3/2) = (-1/2)
& (((53/2) // (-3/2)) * (-3/2) + ((53/2) \\ (-3/2)) = (53/2))].
self should: [0 \\ fractionHalf = 0].
"If the operand is zero, the ZeroDivide must be signaled."
self value: [fractionHalf \\ 0] shouldRaise: ZeroDivide.!
testXraisedToX
" <number>#raisedTo: "
| numVals retVals |
#'Numeric'.
numVals := #(2 2.0 0 2.0s3 ) copy.
numVals at: 3 put: (1/2).
retVals := #(0 0.25 0.7071067811865475 0.25 ) copy.
retVals at: 1 put: (1/4).
1 to: numVals size do: [ :ndx |
self value: [fractionHalf raisedTo: (numVals at: ndx)]
should: [:r | r closeTo: (retVals at: ndx)]
conformTo: #'number' selector: #'raisedTo:'.
].
retVals := #(4 4.0 1.414213562373095 4.0 ).
1 to: numVals size do: [ :ndx |
self value: [fractionHalf raisedTo: ((numVals at: ndx) negated)]
should: [:r | r closeTo: (retVals at: ndx)]
conformTo: #'number' selector: #'raisedTo:'
].
self value: [fractionHalf raisedTo: 0.0] should: [:r | r = 1]
conformTo: #'number' selector: #'raisedTo:'.
self value: [0.0 raisedTo: fractionHalf] should: [:r | r = 0.0]
conformTo: #'number' selector: #'raisedTo:'.
self value: [fractionHalf raisedTo: 1.0] should: [:r | r = fractionHalf]
conformTo: #'number' selector: #'raisedTo:'.
"It is erroneous if the receiver equals zero
and the operand is less than or equal to zero,"
self value: [0.0 raisedTo: (fractionHalf negated)]
shouldRaise: Error.
" or if the receiver is less than zero."
self value: [fractionHalf negated raisedTo: 2.0]
shouldRaise: Error.!
testXceiling
" <number>#ceiling "
#'Numeric'.
self value: [(1/3) ceiling] should: [:r | r = 1]
conformTo: #'number' selector: #'ceiling'.
self value: [(1/2) ceiling] should: [:r | r = 1]
conformTo: #'number' selector: #'ceiling'.
self value: [(-1/2) ceiling] should: [:r | r = 0]
conformTo: #'number' selector: #'ceiling'.!
testXreciprocal
" <number>#reciprocal (returnRule - :receiver) "
#'Numeric'.
self value: [fractionHalf reciprocal] should: [:r | r = 2]
conformTo: #'number' selector: #'reciprocal'
ruleReceiver: fractionHalf!
testXaddOp
" <number>#+ (returnRule - :receiver :operand) "
| retVals |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := Array new: 6.
retVals at: 1 put: (5/2).
retVals at: 2 put: (-3999999999/2).
retVals at: 3 put: (4000000001/2).
retVals at: 4 put: 2.5.
retVals at: 5 put: 1.
retVals at: 6 put: (5/2).
1 to: numList size do: [ :ndx |
self value: [fractionHalf + (numList at: ndx)]
should: [:r | r closeTo: (retVals at: ndx)]
conformTo: #'number' selector: #'+'
ruleReceiver: fractionHalf operand: (numList at: ndx)
].!
testXidentityHash
" <Object>#identityHash "
#'Numeric'.
self value: [fractionHalf identityHash]
should: [:r | r = fractionHalf identityHash]
conformTo: #'Object' selector: #'identityHash'.
self value: [smallInt2 identityHash]
should: [:r | r = (4/2) identityHash]
conformTo: #'Object' selector: #'identityHash'.
self value: [fractionHalf identityHash]
shouldnt: [:r | r = (2/3) identityHash]
conformTo: #'Object' selector: #'identityHash'.
self value: [smallInt2 identityHash]
shouldnt: [:r | r = (6/2) identityHash]
conformTo: #'Object' selector: #'identityHash'.!
testXintegerDivideOp
" <number>#// "
| retVals |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
"The sign of the result is positive if the receiver and operand
have the same sign, and negative if the signs are different."
retVals := #(666666666 -1 0 666666666 2666666666 666666666 ).
1 to: numList size do: [ :ndx |
self value: [(4000000000/3) // (numList at: ndx)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'//'.
].
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := #( -666666667 0 -1 -666666667 -2666666667 -666666667 ).
1 to: numList size do: [ :ndx |
self value: [(4000000000/3) // ((numList at: ndx) negated)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'//'
].
self should: [(256/5) // (50/5) = 5].
self should: [(126/5) // 5 = 5].
self should: [(125000000001/5) // 5000000000 = 5].
self should: [(-125000000001/5) // -5000000000 = 5].
self should: [(131/5) // 5.1 = 5].
self should: [(131/5) // 5.1s1 = 5].
self value: [0 // fractionHalf] should: [:r | r = 0]
conformTo: #'number' selector: #'//'.
"If the operand has a value of zero the ZeroDivide exception is signaled."
self value: [fractionHalf // 0] shouldRaise: ZeroDivide.!
testXpositive
" <number>#positive "
#'Numeric'.
self value: [(1/2) positive] should: [:r | r]
conformTo: #'number' selector: #'positive'.
self value: [(-1/2) positive] shouldnt: [:r | r]
conformTo: #'number' selector: #'positive'.!
testXgreaterThanOrEqualToOp
" <magnitude>#>= "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and operand are not comparable."
"Small >= Big -> false"
#( 2 2000000000 2.0 2.0s3 ) do: [ :tstNum |
self value: [(1/3) >= tstNum] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'>='
].
self value: [(-9000000005/3) >= -2000000000] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'>='.
self value: [(1/4) >= (1/2)] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'>='.
"Num >= Num -> true"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx) >= (numList at: ndx)]
should: [:r | r ] conformTo: #'magnitude' selector: #'>='
].
"Big >= Small -> true"
#( 2 2.0 2.0s3 ) do: [ :tstNum |
self value: [(11/2) >= tstNum] should: [:r | r]
conformTo: #'magnitude' selector: #'>='
].
self value: [(9000000005/3) >= 2000000000] should: [:r | r]
conformTo: #'magnitude' selector: #'>='.
self value: [(-1000000005/3) >= -2000000000] should: [:r | r]
conformTo: #'magnitude' selector: #'>='.
self value: [(11/2) >= (1/2)] should: [:r | r]
conformTo: #'magnitude' selector: #'>='.!
testXtoX
" <number>#to: "
| start middleNdx stop2 |
#'Numeric'.
start := (1/2).
numList := #( 2 2.0 0 2.0s3 ) copy.
numList at: 3 put: (3/2).
numList do: [ :stop |
self value: [start to: stop]
should: [:r | (r size = 2)
". . . the last element in the sequence . . . is . . .[:]
receiver + ((stop - receiver) // 1)"
& (r last = (start + ((stop - start) // 1)))
"The elements conform to the receiver's protocol."
& (r allSatisfy: [ :elem |
elem class conformsToProtocolNamed: #'Fraction'])
]
conformTo: #'number' selector: #'to:'
].
start := (3/2).
stop2 := (4000000001/2).
middleNdx := 1000000000. "Check conformance of first, middle and last."
self value: [start to: stop2]
should: [:r | (r size = 2000000000)
". . . the last element in the sequence . . . is . . .[:]
receiver + ((stop - receiver) // 1)"
& (r last = (start + ((stop2 - start) // 1)))
"The elements conform to the receiver's protocol."
& ((Array with: (r at: 1)
with: (r at: middleNdx)
with: (r at: 3)
) allSatisfy: [ :elem |
elem class conformsToProtocolNamed: #'Fraction'])
]
conformTo: #'number' selector: #'to:'.
start := (-4000000001/2).
stop2 := (-3/2).
middleNdx := 1000000000. "Check conformance of first, middle and last."
self value: [start to: stop2]
should: [:r | (r size = 2000000000)
". . . the last element in the sequence . . . is . . .[:]
receiver + ((stop - receiver) // 1)"
& (r last = (start + ((stop2 - start) // 1)))
"The elements conform to the receiver's protocol."
& ((Array with: (r at: 1)
with: (r at: middleNdx)
with: (r at: 3)
) allSatisfy: [ :elem |
elem class conformsToProtocolNamed: #'Fraction'])
]
conformTo: #'number' selector: #'to:'.
"The interval answered will be empty if the receiver is greater than stop."
self value: [(1/2) to: (-1/2)]
should: [:r | (r isEmpty)] conformTo: #'number' selector: #'to:'!
canonicalObject
^1/3!
testXasFloatE
" <number>#asFloatE "
#'Numeric'.
self value: [(1/2) asFloatE] should: [:r | r = 0.5]
conformTo: #'number' selector: #'asFloatE'.
self value: [(-1/2) asFloatE] should: [:r | r = -0.5]
conformTo: #'number' selector: #'asFloatE'.!
testXgreaterThanOp
" <number>#> "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and operand are not comparable."
"Small > Big -> false"
#( 2 2000000000 2.0 2.0s3 ) do: [ :tstNum |
self value: [(1/3) > tstNum] shouldnt: [:r | r]
conformTo: #'number' selector: #'>'
].
self value: [(-9000000005/3) > -2000000000] shouldnt: [:r | r]
conformTo: #'number' selector: #'>'.
self value: [(1/4) > (1/2)] shouldnt: [:r | r]
conformTo: #'number' selector: #'>'.
"Num > Num -> false"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx) > (numList at: ndx)]
shouldnt: [:r | r ] conformTo: #'number' selector: #'>'
].
"Big > Small -> true"
#( 2 2.0 2.0s3 ) do: [ :tstNum |
self value: [(11/2) > tstNum] should: [:r | r]
conformTo: #'number' selector: #'>'
].
self value: [(9000000005/3) > 2000000000] should: [:r | r]
conformTo: #'number' selector: #'>'.
self value: [(-1000000005/3) > -2000000000] should: [:r | r]
conformTo: #'number' selector: #'>'.
self value: [(11/2) > (1/2)] should: [:r | r]
conformTo: #'number' selector: #'>'.!
testXdivideOp
" <number>#/ (returnRule - :receiver :operand) "
| retVals |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := Array new: 6.
retVals at: 1 put: (1/4).
retVals at: 2 put: (-1/4000000000).
retVals at: 3 put: (1/4000000000).
retVals at: 4 put: 0.25.
retVals at: 5 put: 1.
retVals at: 6 put: (1/4).
1 to: numList size do: [ :ndx |
self value: [fractionHalf / (numList at: ndx)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'/'
ruleReceiver: fractionHalf operand: (numList at: ndx)
].
self value: [0 / fractionHalf] should: [:r | r = 0]
conformTo: #'number' selector: #'/'
ruleReceiver: fractionHalf operand: 0.
"The implementation must signal the ZeroDivide exception."
self value: [fractionHalf / 0] shouldRaise: ZeroDivide.!
testXprintString
" <Fraction>#printString "
#'Numeric'.
self value: [(1/2) printString] should: [:r | r = '1/2']
conformTo: #'Fraction' selector: #'printString'.
self value: [(1/ -2) printString] should: [:r | r = '-1/2']
conformTo: #'Fraction' selector: #'printString'.
self value: [(3/33) printString] should: [:r | r = '1/11']
conformTo: #'Fraction' selector: #'printString'.!
testXfloor
" <number>#floor "
#'Numeric'.
self value: [(1/3) floor] should: [:r | r = 0]
conformTo: #'number' selector: #'floor'.
self value: [(1/2) floor] should: [:r | r = 0]
conformTo: #'number' selector: #'floor'.
self value: [(3/2) floor] should: [:r | r = 1]
conformTo: #'number' selector: #'floor'.
self value: [(-1/2) floor] should: [:r | r = -1]
conformTo: #'number' selector: #'floor'.!
testXtoXdoX
" <number>#to:do: "
#'Numeric'.!
setUp
super setUp.
smallInt2 := 2.
largeNegInt2000000000 := -2000000000.
largePosInt2000000000 := 2000000000.
float2 := 2.0d0.
fractionHalf := 1/2.
sclDec2s3 := 2.0s3.
numList := Array new: 6.
numList at: 1 put: smallInt2.
numList at: 2 put: largeNegInt2000000000.
numList at: 3 put: largePosInt2000000000.
numList at: 4 put: float2.
numList at: 5 put: fractionHalf.
numList at: 6 put: sclDec2s3.!
testXsign
" <number>#sign "
#'Numeric'.
self value: [(1/2) sign] should: [:r | r = 1]
conformTo: #'number' selector: #'sign'.
self value: [(-1/2) sign] should: [:r | r = -1]
conformTo: #'number' selector: #'sign'.!
testXminX
" <magnitude>#min: "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and operand are not comparable."
self value: [(1/2) min: 0] should: [:r | r = 0]
conformTo: #'magnitude' selector: #'min:'.
self value: [(-2000000000/2) min: -2000000000]
should: [:r | r = -2000000000]
conformTo: #'magnitude' selector: #'min:'.
self value: [(9000000000/2) min: 2000000003]
should: [:r | r = 2000000003]
conformTo: #'magnitude' selector: #'min:'.
self value: [(1/2) min: 0.0] should: [:r | r = 0.0]
conformTo: #'magnitude' selector: #'min:'.
self value: [(1/2) min: (1/4)] should: [:r | r = (1/4)]
conformTo: #'magnitude' selector: #'min:'.
self value: [(1/2) min: 0.1s3] should: [:r | r = 0.1s3]
conformTo: #'magnitude' selector: #'min:'.
"Num min: Num -> Num"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx) min: (numList at: ndx)]
should: [:r | r = (numList at: ndx)]
conformTo: #'magnitude' selector: #'min:'
].!
testXrounded
" <number>#rounded "
#'Numeric'.
self value: [(1/3) rounded] should: [:r | r = 0]
conformTo: #'number' selector: #'rounded'.
self value: [(1/2) rounded] should: [:r | r = 1]
conformTo: #'number' selector: #'rounded'.
self value: [(-1/2) rounded] should: [:r | r = -1]
conformTo: #'number' selector: #'rounded'.!
testXtruncateToX
" <number>#truncateTo: (returnRule - :receiver :operand) "
| retVals frac |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
frac := (51/10).
retVals := #(4 0 0 4.0 5 4).
1 to: numList size do: [ :ndx |
self value: [frac truncateTo: (numList at: ndx)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'truncateTo:'
ruleReceiver: frac operand: (numList at: ndx)
].
self should: [(0.0 truncateTo: fractionHalf) = 0.0].!
testXfractionPart
" <number>#fractionPart (Return Values: <RECEIVER>)"
| rcvr |
#'Numeric'.
"Within the limits of representation, the following invariants should hold:
receiver integerPart + receiver fractionPart = receiver
receiver \\1 = receiver fractionPart (RAH - erroneous, add #'abs')
"
rcvr := (3/2).
self value: [rcvr fractionPart]
should: [:r | r = (1/2) & (rcvr integerPart + rcvr fractionPart = rcvr)
& (rcvr \\ 1 = rcvr fractionPart abs)]
conformTo: #'number' selector: #'fractionPart' opRECEIVER: rcvr.
rcvr := (-3/2).
self value: [rcvr fractionPart]
should: [:r | r = (-1/2) & (rcvr integerPart + rcvr fractionPart = rcvr)
& (rcvr \\ 1 = rcvr fractionPart abs)]
conformTo: #'number' selector: #'fractionPart' opRECEIVER: rcvr.!
testXnegative
" <number>#negative "
#'Numeric'.
self value: [(-1/2) negative] should: [:r | r]
conformTo: #'number' selector: #'negative'.
self value: [(1/2) negative] shouldnt: [:r | r]
conformTo: #'number' selector: #'negative'.!
testXsubtractOp
" <number>#- (returnRule - :receiver :operand) "
| retVals |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := Array new: 6.
retVals at: 1 put: (-3/2).
retVals at: 2 put: (4000000001/2).
retVals at: 3 put: (-3999999999/2).
retVals at: 4 put: -1.5.
retVals at: 5 put: 0.
retVals at: 6 put: (-3/2).
1 to: numList size do: [ :ndx |
self value: [fractionHalf - (numList at: ndx)]
should: [:r | r closeTo: (retVals at: ndx)]
conformTo: #'number' selector: #'-'
ruleReceiver: fractionHalf operand: (numList at: ndx)
].!
testXcopy
" <Object>#copy (Return Values: <RECEIVER>) "
#'Numeric'.
" Return a new object that must be as similar as possible to the receiver in its initial state and behavior. Any operation that changes the state of the new object should not as a side-effect change the state or behavior of the receiver. Similarly, any change to the receiver should not as a side-effect change the new object.
If the receiver is an identity object, return the receiver.
"
#todo. "??? add change-side-effect test ???"
self value: [fractionHalf copy]
should: [:r | (r = fractionHalf) ]
conformTo: #'Object' selector: #'copy' opRECEIVER: fractionHalf.!
testXhash
" <Object>#hash "
#'Numeric'.
" Any two objects that are considered equivalent using the #= message must have the same hash value. More formally:
receiver = comparand =>
receiver hash = comparand hash
"
#'testAnom'. "??? <Object> test of equivalence seems to confilict
with <Number> convert then test.
self shouldnt: [smallInt2 = float2].
self shouldnt: [smallInt2 hash = float2 hash].
???"
self value: [fractionHalf hash]
should: [:r | r = fractionHalf hash]
conformTo: #'Object' selector: #'hash'.
self value: [fractionHalf hash]
shouldnt: [:r | r = (2/3) hash] conformTo: #'Object' selector: #'hash'.!
protocol
^#'Fraction'!
testXasFloatD
" <number>#asFloatD "
#'Numeric'.
self value: [(1/2) asFloatD] should: [:r | r = 0.5]
conformTo: #'number' selector: #'asFloatD'.
self value: [(-1/2) asFloatD] should: [:r | r = -0.5]
conformTo: #'number' selector: #'asFloatD'.!
testXlessThanOrEqualToOp
" <magnitude>#<= "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and operand are not comparable."
"Small <= Big -> true"
#( 2 2000000000 2.0 2.0s3 ) do: [ :tstNum |
self value: [(1/3) <= tstNum] should: [:r | r]
conformTo: #'magnitude' selector: #'<='
].
self value: [(-9000000005/3) <= -2000000000] should: [:r | r]
conformTo: #'magnitude' selector: #'<='.
self value: [(1/4) <= (1/2)] should: [:r | r]
conformTo: #'magnitude' selector: #'<='.
"Num <= Num -> false"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx) <= (numList at: ndx)]
should: [:r | r ] conformTo: #'magnitude' selector: #'<='
].
"Big <= Small -> false"
#( 2 2.0 2.0s3 ) do: [ :tstNum |
self value: [(11/2) <= tstNum] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'<='
].
self value: [(9000000005/3) <= 2000000000] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'<='.
self value: [(-1000000005/3) <= -2000000000] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'<='.
self value: [(11/2) <= (1/2)] shouldnt: [:r | r]
conformTo: #'magnitude' selector: #'<='.!
testXintegerPart
" <number>#integerPart (returnRule - :receiver) "
| rcvr |
#'Numeric'.
rcvr := (1/2).
self value: [rcvr integerPart] should: [:result | result = 0]
conformTo: #'number' selector: #'integerPart' ruleReceiver: rcvr.
rcvr := (3/2).
self value: [rcvr integerPart] should: [:result | result = 1]
conformTo: #'number' selector: #'integerPart' ruleReceiver: rcvr.
rcvr := (-3/2).
self value: [rcvr integerPart] should: [:result | result = -1]
conformTo: #'number' selector: #'integerPart' ruleReceiver: rcvr.!
testXquoX
" <number>#quo: "
| retVals |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := #( 666666666 0 0 666666666 2666666666 666666666 ).
1 to: numList size do: [ :ndx |
self value: [(4000000000/3) quo: (numList at: ndx)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'quo:'.
].
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := #( -666666666 0 0 -666666666 -2666666666 -666666666 ).
1 to: numList size do: [ :ndx |
self value: [(4000000000/3) quo: ((numList at: ndx) negated)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'quo:'
].
self should: [((256/5) quo: (50/5)) = 5].
self should: [((126/5) quo: 5) = 5].
self should: [((125000000001/5) quo: 5000000000) = 5].
self should: [((-125000000001/5) quo: -5000000000) = 5].
self should: [((131/5) quo: 5.1) = 5].
self should: [((131/5) quo: 5.1s1) = 5].
self value: [0 quo: fractionHalf] should: [:r | r = 0]
conformTo: #'number' selector: #'quo:'.
"If the operand has a value of zero the ZeroDivide exception is signaled."
self value: [fractionHalf quo: 0] shouldRaise: ZeroDivide.!
testXasFloatQ
" <number>#asFloatQ "
#'Numeric'.
self value: [(1/2) asFloatQ] should: [:r | r = 0.5]
conformTo: #'number' selector: #'asFloatQ'.
self value: [(-1/2) asFloatQ] should: [:r | r = -0.5]
conformTo: #'number' selector: #'asFloatQ'.!
testXmultiplyOp
" <number>#* (returnRule - :receiver :operand) "
| retVals |
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
retVals := #(1 -1000000000 1000000000 1.0 0 1) copy.
retVals at: 5 put: (1/4).
1 to: numList size do: [ :ndx |
self value: [fractionHalf * (numList at: ndx)]
should: [:r | r = (retVals at: ndx)]
conformTo: #'number' selector: #'*'
ruleReceiver: fractionHalf operand: (numList at: ndx)
].!
testXnumerator
" <Fraction>#numerator "
#'Numeric'.!
testXlessThanOp
" <number>#< "
#'Numeric'.
" #( 2 -2000000000 2000000000 2.0 1/2 2.0s3 )."
#'todo'."It is erroneous if the receiver and operand are not comparable."
"Small < Big -> true"
#( 2 2000000000 2.0 2.0s3 ) do: [ :tstNum |
self value: [(1/3) < tstNum] should: [:r | r]
conformTo: #'number' selector: #'<'
].
self value: [(-9000000005/3) < -2000000000] should: [:r | r]
conformTo: #'number' selector: #'<'.
self value: [(1/4) < (1/2)] should: [:r | r]
conformTo: #'number' selector: #'<'.
"Num < Num -> false"
1 to: numList size do: [ :ndx |
self value: [(numList at: ndx) < (numList at: ndx)]
shouldnt: [:r | r ] conformTo: #'number' selector: #'<'
].
"Big < Small -> false"
#( 2 2.0 2.0s3 ) do: [ :tstNum |
self value: [(11/2) < tstNum] shouldnt: [:r | r]
conformTo: #'number' selector: #'<'
].
self value: [(9000000005/3) < 2000000000] shouldnt: [:r | r]
conformTo: #'number' selector: #'<'.
self value: [(-1000000005/3) < -2000000000] shouldnt: [:r | r]
conformTo: #'number' selector: #'<'.
self value: [(11/2) < (1/2)] shouldnt: [:r | r]
conformTo: #'number' selector: #'<'.!
testXsqrt
" <number>#sqrt "
self value: [(2601/100) sqrt] should: [:r | r closeTo: 5.1]
conformTo: #'number' selector: #'sqrt'.
self value: [(1/4) sqrt] should: [:r | r = 0.5]
conformTo: #'number' selector: #'sqrt'! !
!IdentityDictionaryFactoryANSITest methodsFor: nil!
protocol
^#'IdentityDictionary factory'!
testXwithAllX
" <IdentityDictionary factory>#withAll: "
#'Collection'.!
testXnewX
" <IdentityDictionary factory>#new: "
#'Collection'.!
canonicalObject
^IdentityDictionary!
testXnew
" <IdentityDictionary factory>#new "
#'Collection'.! !
!WarningANSITest methodsFor: nil!
testXresignalAsX
" <signaledException>#resignalAs: "
#'Exception'.!
testXretryUsingX
" <signaledException>#retryUsing: "
#'Exception'.!
testXmessageText
" <exceptionDescription>#messageText "