Marcel Taeumel uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-jar.436.mcz
==================== Summary ====================
Name: KernelTests-jar.436
Author: jar
Time: 20 June 2022, 6:16:50.946618 pm
UUID: e028fc29-0d67-2840-b4cf-be8269e69fc3
Ancestors: KernelTests-ct.435
Add semaphore and mutex tests for #suspend vs #suspendAndUnblock semantics
=============== Diff against KernelTests-ct.435 ===============
Item was removed:
- SystemOrganization addCategory: #'KernelTests-Classes'!
- SystemOrganization addCategory: #'KernelTests-Methods'!
- SystemOrganization addCategory: #'KernelTests-Numbers'!
- SystemOrganization addCategory: #'KernelTests-Objects'!
- SystemOrganization addCategory: #'KernelTests-Processes'!
- SystemOrganization addCategory: #'KernelTests-WriteBarrier'!
- SystemOrganization addCategory: #'KernelTests-Models'!
Item was removed:
- ClassTestCase subclass: #AbstractProcessTest
- instanceVariableNames: 'semaphore'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
Item was removed:
- ----- Method: AbstractProcessTest class>>isAbstract (in category 'testing') -----
- isAbstract
-
- ^ self name = #AbstractProcessTest!
Item was removed:
- ----- Method: AbstractProcessTest>>classToBeTested (in category 'support') -----
- classToBeTested
-
- ^ self environment classNamed: #Process!
Item was removed:
- ----- Method: AbstractProcessTest>>genuineProcess (in category 'support') -----
- genuineProcess
- "Usually, we don't want to expose this from the class under test but we need it in the test context."
-
- ^ Processor instVarNamed: 'genuineProcess'!
Item was removed:
- ----- Method: AbstractProcessTest>>setUp (in category 'running') -----
- setUp
-
- super setUp.
- semaphore := Semaphore new.!
Item was removed:
- ----- Method: AbstractProcessTest>>tearDown (in category 'running') -----
- tearDown
- "Release all processes still waiting at the semaphore or in the active priority queue."
-
- Processor yield.
- [semaphore isEmpty] whileFalse: [semaphore signal].
-
- super tearDown.!
Item was removed:
- TestCase subclass: #AllocationTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
Item was removed:
- ----- Method: AllocationTest>>setMaximumOldSpaceTo:around: (in category 'support') -----
- setMaximumOldSpaceTo: bytes around: aBlock
- "Attempt to evaluate aBlock with a limit of the requested maximum
- size of old space, restoring the extant limit after the evaluation."
-
- | extantLimit |
- extantLimit := Smalltalk vmParameterAt: 67.
- Smalltalk vmParameterAt: 67 put: (Smalltalk vmParameterAt: 1) + bytes asInteger.
- ^aBlock ensure: [Smalltalk vmParameterAt: 67 put: extantLimit]!
Item was removed:
- ----- Method: AllocationTest>>setMaximumOldSpaceToAtLeast:around: (in category 'support') -----
- setMaximumOldSpaceToAtLeast: bytes around: aBlock
- "Attempt to evaluate aBlock with a limit of at least the requested maximum
- size (in bytes) of old space, restoring the extant limit after the evaluation."
-
- | extantLimit |
- extantLimit := Smalltalk vmParameterAt: 67.
- extantLimit >= bytes ifTrue:
- [^aBlock value].
- Smalltalk vmParameterAt: 67 put: (Smalltalk vmParameterAt: 1) + bytes asInteger.
- ^aBlock ensure: [Smalltalk vmParameterAt: 67 put: extantLimit]!
Item was removed:
- ----- Method: AllocationTest>>testOneGigAllocation (in category 'tests') -----
- testOneGigAllocation
- self setMaximumOldSpaceToAtLeast: 1024 * 1024 * 1024 * (Smalltalk wordSize = 8
- ifTrue: [4]
- ifFalse: [1.5])
- around:
- [| sz array failed |
- failed := false.
- sz := 1024*1024*1024 / Smalltalk wordSize.
- array := [Array new: sz]
- on: OutOfMemory
- do: [:ex| failed := true].
- self assert: (failed or: [array isArray and: [array size = sz]])]!
Item was removed:
- ----- Method: AllocationTest>>testOneMegAllocation (in category 'tests') -----
- testOneMegAllocation
- "Documentating a weird bug in the allocator"
- | sz array failed |
- failed := false.
- sz := 1024*1024.
- array := [Array new: sz] on: OutOfMemory do:[:ex| failed := true].
- self assert: (failed or:[array size = sz]).
- !
Item was removed:
- ----- Method: AllocationTest>>testOutOfMemorySignal (in category 'tests') -----
- testOutOfMemorySignal
- "Ensure that OutOfMemory is signaled eventually. Restrain the available memory first to not stress the machine too much."
-
- self setMaximumOldSpaceToAtLeast: 1024 * 1024 * 1024 * (Smalltalk wordSize = 8
- ifTrue: [4]
- ifFalse: [1.5])
- around:
- [| sz |
- sz := 512*1024*1024. "work around the 1GB alloc bug" "what 1Gb allocation bug? eem"
- self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory].!
Item was removed:
- ----- Method: AllocationTest>>testOutOfMemorySignalExtreme (in category 'tests') -----
- testOutOfMemorySignalExtreme
- "Try to allocate more memory than permitted by the -memory vm argument, and check whether the expected error is signaled. Note that current (2017) Spur VMs fail in #new: and #basicNew: with #'bad argument' if given other than a non-negative SmallInteger."
- Smalltalk heapMemoryLimit ifNotNil:
- [ : bytes |
- self
- should: [ Array new: (bytes // Smalltalk wordSize) + 100 ]
- raise: OutOfMemory, Error
- withExceptionDo:
- [:ex|
- ex class == Error ifTrue:
- [self assert: [ex messageText includesSubstring: 'basicNew: with invalid argument' ]]]]!
Item was removed:
- TestCase subclass: #BasicBehaviorClassMetaclassTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
-
- !BasicBehaviorClassMetaclassTest commentStamp: '<historical>' prior: 0!
- This class contains some tests regarding the classes
- Behavior
- ClassDescription
- Class
- Metaclass
- ---
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testBehaviorClassClassDescriptionMetaclassHierarchy (in category 'tests') -----
- testBehaviorClassClassDescriptionMetaclassHierarchy
- "self run: #testBehaviorClassClassDescriptionMetaclassHierarchy"
-
- self assert: Class superclass == ClassDescription.
- self assert: Metaclass superclass == ClassDescription.
-
- self assert: ClassDescription superclass == Behavior.
- self assert: Behavior superclass = Object.
-
- self assert: Class class class == Metaclass.
- self assert: Metaclass class class == Metaclass.
- self assert: ClassDescription class class == Metaclass.
- self assert: Behavior class class == Metaclass.
-
-
-
-
-
-
-
-
-
-
-
-
-
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testClassDescriptionAllSubInstances (in category 'tests') -----
- testClassDescriptionAllSubInstances
- "self run: #testClassDescriptionAllSubInstances"
-
- | cdNo clsNo metaclsNo |
- cdNo := ClassDescription allSubInstances size.
- clsNo := Class allSubInstances size .
- metaclsNo := Metaclass allSubInstances size.
-
- "When traits are present, discount all traits if necessary"
- Smalltalk at: #Trait ifPresent:[:aClass|
- (aClass inheritsFrom: ClassDescription)
- ifTrue:[cdNo := cdNo - aClass instanceCount]].
- Smalltalk at: #ClassTrait ifPresent:[:aClass|
- (aClass inheritsFrom: ClassDescription)
- ifTrue:[cdNo := cdNo - aClass instanceCount]].
-
- self assert: cdNo = (clsNo + metaclsNo).!
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclass (in category 'tests') -----
- testMetaclass
- "self run: #testMetaclass"
-
- self assert: OrderedCollection class class == Metaclass.
- self assert: Dictionary class class == Metaclass.
- self assert: Object class class == Metaclass.
-
-
-
-
-
-
-
-
-
-
-
-
-
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassName (in category 'tests') -----
- testMetaclassName
- "self run: #testMetaclassName"
-
- self assert: Dictionary class name = 'Dictionary class'.
- self assert: OrderedCollection class name = 'OrderedCollection class'.
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassNumberOfInstances (in category 'tests') -----
- testMetaclassNumberOfInstances
- "self run: #testMetaclassNumberOfInstances"
-
- self assert: Dictionary class allInstances size = 1.
- self assert: OrderedCollection class allInstances size = 1.!
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassPointOfCircularity (in category 'tests') -----
- testMetaclassPointOfCircularity
- "self run: #testMetaclassPointOfCircularity"
-
- self assert: Metaclass class instanceCount = 1.
- self assert: Metaclass class someInstance == Metaclass.
-
-
-
-
-
-
-
-
-
-
-
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclass (in category 'tests') -----
- testMetaclassSuperclass
- "self run: #testMetaclassSuperclass"
-
- self assert: Dictionary class superclass == HashedCollection class.
- self assert: OrderedCollection class superclass == SequenceableCollection class.
-
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclassHierarchy (in category 'tests') -----
- testMetaclassSuperclassHierarchy
- "self run: #testMetaclassSuperclassHierarchy"
-
- | s |
- self assert: SequenceableCollection class instanceCount = 1.
- self assert: Collection class instanceCount = 1.
- self assert: Object class instanceCount = 1.
- self assert: ProtoObject class instanceCount = 1.
-
- s := OrderedCollection new.
- s add: SequenceableCollection class.
- s add: Collection class.
- s add: Object class.
- s add: ProtoObject class.
-
- s add: Class.
- s add: ClassDescription.
- s add: Behavior.
- s add: Object.
- s add: ProtoObject.
-
- self assert: OrderedCollection class allSuperclasses = s.
-
-
-
-
-
-
- !
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testObjectAllSubclasses (in category 'tests') -----
- testObjectAllSubclasses
- "self run: #testObjectAllSubclasses"
-
- | n2 |
- n2 := Object allSubclasses size.
- self assert: n2 = (Object allSubclasses
- select: [:cls | cls class class == Metaclass
- or: [cls class == Metaclass]]) size!
Item was removed:
- ----- Method: BasicBehaviorClassMetaclassTest>>testSuperclass (in category 'tests') -----
- testSuperclass
- "self run: #testSuperclass"
-
- | s |
- self assert: Dictionary superclass == HashedCollection.
- self assert: OrderedCollection superclass == SequenceableCollection.
-
- s := OrderedCollection new.
- s add: SequenceableCollection.
- s add: Collection.
- s add: Object.
- s add: ProtoObject.
-
- self assert: OrderedCollection allSuperclasses = s.
-
-
- !
Item was removed:
- TestCase subclass: #BehaviorTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
Item was removed:
- ----- Method: BehaviorTest>>sampleMessageWithFirstArgument:andInterleavedCommentBeforeSecondArgument: (in category 'tests') -----
- sampleMessageWithFirstArgument: firstArgument "This is a comment intended to explain arg1"
- andInterleavedCommentBeforeSecondArgument: secondArgument
-
- "This method is here to test a few utilities like formalParametersAt:"
-
- | thisIsAnUnusedTemp |
- thisIsAnUnusedTemp := self.
- ^thisIsAnUnusedTemp!
Item was removed:
- ----- Method: BehaviorTest>>testAllSelectors (in category 'tests') -----
- testAllSelectors
-
- self assert: ProtoObject allSelectors = ProtoObject selectors asIdentitySet.
- self assert: Object allSelectors = (Object selectors union: ProtoObject selectors) asIdentitySet.!
Item was removed:
- ----- Method: BehaviorTest>>testAllSelectorsBelow (in category 'tests') -----
- testAllSelectorsBelow
-
- self assert: (Object allSelectorsBelow: ProtoObject) = Object selectors asIdentitySet.
- self assert: (Object allSelectorsBelow: nil) = (Object selectors union: ProtoObject selectors) asIdentitySet!
Item was removed:
- ----- Method: BehaviorTest>>testBehaviorSubclasses (in category 'tests') -----
- testBehaviorSubclasses
- "self run: #testBehaviorSubclasses"
-
- | b b2 |
- b := Behavior new.
- b superclass: OrderedCollection.
- b methodDictionary: MethodDictionary new.
-
- b2 := Behavior new.
- b2 superclass: b.
- b2 methodDictionary: MethodDictionary new.
-
- self assert: (b subclasses includes: b2).
- self deny: (b subclasses includes: b).
-
- self assert: (b withAllSubclasses includes: b).
-
- self assert: (b allSubclasses includes: b2).!
Item was removed:
- ----- Method: BehaviorTest>>testBehaviornewnewShouldNotCrash (in category 'tests') -----
- testBehaviornewnewShouldNotCrash
-
- Behavior new new.
- "still not working correctly but at least does not crash the image"
- !
Item was removed:
- ----- Method: BehaviorTest>>testBinding (in category 'tests') -----
- testBinding
- self assert: Object binding value = Object.
- self assert: Object binding key = #Object.
-
- self assert: Object class binding value = Object class.
-
- "returns nil for Metaclasses... like Encoder>>#associationFor:"
-
- self assert: Object class binding key = nil.!
Item was removed:
- ----- Method: BehaviorTest>>testChange (in category 'tests') -----
- testChange
- "self debug: #testChange"
-
- | behavior model |
- behavior := Behavior new.
- behavior superclass: Model.
- behavior setFormat: Model format.
- model := Model new.
- model primitiveChangeClassTo: behavior new.
- Utilities
- useAuthorInitials: self className
- during: [ behavior compile: 'thisIsATest ^ 2' ].
- self assert: model thisIsATest = 2.
- self should: [Model new thisIsATest] raise: MessageNotUnderstood.
-
-
- !
Item was removed:
- ----- Method: BehaviorTest>>testFormalParameterNames (in category 'tests') -----
- testFormalParameterNames
- | method |
- method := #sampleMessageWithFirstArgument:andInterleavedCommentBeforeSecondArgument:.
- self assert: (self class formalParametersAt: method) size = 2.
- self assert: (self class formalParametersAt: method) asArray = #('firstArgument' 'secondArgument').
- CurrentReadOnlySourceFiles cacheDuring: [
- Object selectorsDo: [:e |
- self assert: (Object formalParametersAt: e) size = e numArgs]].!
Item was removed:
- ----- Method: BehaviorTest>>testWhichMethodsStoreInto (in category 'tests') -----
- testWhichMethodsStoreInto
- ClassForBehaviorTest withAllSubclassesDo: [:eachTestClass |
- {eachTestClass. eachTestClass class} do: [:eachTestClassOrMetaclass |
-
- eachTestClassOrMetaclass allInstVarNames do: [:iv |
- self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: iv)
- collect: [:eachMethod | eachMethod selector]) sorted
- = (eachTestClassOrMetaclass whichSelectorsStoreInto: iv) sorted.
- self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: iv)
- allSatisfy: [:eachMethod | eachMethod methodClass = eachTestClassOrMetaclass]) ].
-
- eachTestClassOrMetaclass allClassVarNames do: [:cv |
- self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: cv)
- collect: [:eachMethod | eachMethod selector]) sorted
- = (eachTestClassOrMetaclass whichSelectorsStoreInto: cv) sorted.
- self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: cv)
- allSatisfy: [:eachMethod | eachMethod methodClass = eachTestClassOrMetaclass]) ]]]!
Item was removed:
- ----- Method: BehaviorTest>>testWhichSelectorStoreInto (in category 'tests') -----
- testWhichSelectorStoreInto
- self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'iv1') sorted = #(#initialize #iv1: #reset ).
- self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'iv2') sorted = #(#iv2: #reset ).
- self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'CV1') sorted = #(#initialize).
- self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'CV2') sorted = #().
-
- self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'iv1') sorted = #(#resetIV1 ).
- self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'iv2') sorted = #(#iv2: ).
- self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'CV1') sorted = #().
- self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'CV2') sorted = #().
-
- self assert: (ClassForBehaviorTest class whichSelectorsStoreInto: 'CV1') sorted = #(#initialize).
- self assert: (ClassForBehaviorTest class whichSelectorsStoreInto: 'CV2') sorted = #(#initialize).
- self assert: (ClassForBehaviorTest class whichSelectorsStoreInto: 'civ1') sorted = #(#civ1).
-
- self assert: (SubClassForBehaviorTest class whichSelectorsStoreInto: 'CV1') sorted = #().
- self assert: (SubClassForBehaviorTest class whichSelectorsStoreInto: 'CV2') sorted = #().
- self assert: (SubClassForBehaviorTest class whichSelectorsStoreInto: 'civ1') sorted = #(#install).!
Item was removed:
- TestCase subclass: #BlockClosureTest
- instanceVariableNames: 'aBlockClosure homeOfABlockClosure'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !BlockClosureTest commentStamp: 'eem 3/30/2017 17:45' prior: 0!
- I am an SUnit Test of BlockClosure and some of Context's simulation machinery'. See also MethodContextTest.
-
- My fixtures are:
- aBlockClosure - just some trivial block, i.e., [100@100 corner: 200@200].
- homeOfABlockClosure - the home context of the block
-
- NOTES ABOUT AUTOMATING USER INPUTS
-
- When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program.
-
- BlockClosure helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like:
-
- [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false)
-
- There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers.
-
- Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available.
-
- Examples:
-
- So you don't need any introduction here -- this one works like usual.
- [self inform: 'hello'. #done] value.
-
- Now let's suppress all inform: messages.
- [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages.
-
- Here we can just suppress a single inform: message.
- [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there')
-
- Here you see how you can suppress a list of messages.
- [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there')
-
- Enough about inform:, let's look at confirm:. As you see this one works as expected.
- [self confirm: 'You like Squeak?'] value
-
- Let's supply answers to one of the questions -- check out the return value.
- [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}]
- valueSupplyingAnswer: #('You like Smalltalk?' true)
-
- Here we supply answers using only substrings of the questions (for simplicity).
- [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}]
- valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) )
-
- This time let's answer all questions exactly the same way.
- [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}]
- valueSupplyingAnswer: true
-
- And, of course, we can answer FillInTheBlank questions in the same manner.
- [FillInTheBlank request: 'What day is it?']
- valueSupplyingAnswer: 'the first day of the rest of your life'
-
- We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer.
- [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName]
- valueSupplyingAnswer: #default
-
- Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image).
- [FillInTheBlank request: 'What day is it?']
- valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }
-
- [Comment taken from BlockClosureTest last written by jrp 10/17/2004 12:22]!
Item was removed:
- ----- Method: BlockClosureTest class>>onceMethod (in category 'support methods') -----
- onceMethod
- ^[Object new] once!
Item was removed:
- ----- Method: BlockClosureTest>>return: (in category 'private') -----
- return: something
-
- ^ something!
Item was removed:
- ----- Method: BlockClosureTest>>setUp (in category 'running') -----
- setUp
- super setUp.
- aBlockClosure := [100@100 corner: 200@200].
- homeOfABlockClosure := thisContext!
Item was removed:
- ----- Method: BlockClosureTest>>testCull (in category 'tests - evaluating') -----
- testCull
- self assert: nil equals: ([ ] cull: 1).
- self assert: nil equals: ([ :x | ] cull: 1).
- self assert: 1 equals: ([ :x | x ] cull: 1).
- self should: [ [ :x :y | ] cull: 1 ] raise: Error.
- self should: [ [ :x :y :z | ] cull: 1 ] raise: Error.
- self should: [ [ :x :y :z :a | ] cull: 1 ] raise: Error.
- self should: [ [ :x :y :z :a :b | ] cull: 1 ] raise: Error.
- self assert: ([ 0 ] cull: 1) = 0.
- self assert: ([ :x | x ] cull: 1) = 1 !
Item was removed:
- ----- Method: BlockClosureTest>>testCullCull (in category 'tests - evaluating') -----
- testCullCull
- self assert: nil equals: ([ ] cull: 1 cull: 2).
-
- self assert: nil equals: ([ :x | ] cull: 1 cull: 2).
- self assert: 1 equals: ([ :x | x ] cull: 1 cull: 2).
-
- self assert: nil equals: ([ :x :y | ] cull: 1 cull: 2).
- self assert: 1 equals: ([ :x :y | x ] cull: 1 cull: 2).
- self assert: 2 equals: ([ :x :y | y ] cull: 1 cull: 2).
-
- self should: [ [ :x :y :z | ] cull: 1 cull: 2 ] raise: Error.
- self should: [ [ :x :y :z :a | ] cull: 1 cull: 2 ] raise: Error.
- self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 ] raise: Error.
- self assert: ([ 0 ] cull: 1 cull: 2) = 0.
- self assert: ([ :x | x ] cull: 1 cull: 2) = 1.
- self assert: ([ :x :y | y ] cull: 1 cull: 2) = 2. !
Item was removed:
- ----- Method: BlockClosureTest>>testCullCullCull (in category 'tests - evaluating') -----
- testCullCullCull
- self assert: nil equals: ([ ] cull: 1 cull: 2 cull: 3).
-
- self assert: nil equals: ([ :x | ] cull: 1 cull: 2 cull: 3).
- self assert: 1 equals: ([ :x | x ] cull: 1 cull: 2 cull: 3).
-
- self assert: nil equals: ([ :x :y | ] cull: 1 cull: 2 cull: 3).
- self assert: 1 equals: ([ :x :y | x ] cull: 1 cull: 2 cull: 3).
- self assert: 2 equals: ([ :x :y | y ] cull: 1 cull: 2 cull: 3).
-
- self assert: nil equals: ([ :x :y :z | ] cull: 1 cull: 2 cull: 3).
- self assert: 1 equals: ([ :x :y :z | x ] cull: 1 cull: 2 cull: 3).
- self assert: 2 equals: ([ :x :y :z | y ] cull: 1 cull: 2 cull: 3).
- self assert: 3 equals: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3).
-
- self should: [ [ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 ] raise: Error.
- self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 cull: 3 ] raise: Error.
- self assert: ([ 0 ] cull: 1 cull: 2 cull: 3) = 0.
- self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3) = 1.
- self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3) = 2.
- self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3) = 3. !
Item was removed:
- ----- Method: BlockClosureTest>>testCullCullCullCull (in category 'tests - evaluating') -----
- testCullCullCullCull
- self assert: nil equals: ([ ] cull: 1 cull: 2 cull: 3 cull: 4).
-
- self assert: nil equals: ([ :x | ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 1 equals: ([ :x | x ] cull: 1 cull: 2 cull: 3 cull: 4).
-
- self assert: nil equals: ([ :x :y | ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 1 equals: ([ :x :y | x ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 2 equals: ([ :x :y | y ] cull: 1 cull: 2 cull: 3 cull: 4).
-
- self assert: nil equals: ([ :x :y :z | ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 1 equals: ([ :x :y :z | x ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 2 equals: ([ :x :y :z | y ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 3 equals: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3 cull: 4).
-
- self assert: nil equals: ([ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 1 equals: ([ :x :y :z :a | x ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 2 equals: ([ :x :y :z :a | y ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 3 equals: ([ :x :y :z :a | z ] cull: 1 cull: 2 cull: 3 cull: 4).
- self assert: 4 equals: ([ :x :y :z :a | a ] cull: 1 cull: 2 cull: 3 cull: 4).
-
- self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error.
- self assert: ([ 0 ] cull: 1 cull: 2 cull: 3 cull: 4) = 0.
- self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3 cull: 4) = 1.
- self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3 cull: 4) = 2.
- self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3 cull: 4) = 3.
- self assert: ([ :x :y :z :a | a ] cull: 1 cull: 2 cull: 3 cull: 4) = 4.!
Item was removed:
- ----- Method: BlockClosureTest>>testDecompile (in category 'tests - printing') -----
- testDecompile
- self assert: ([3 + 4] decompile printString = '{[3 + 4]}')!
Item was removed:
- ----- Method: BlockClosureTest>>testEmptyBlocksAnswerNil (in category 'tests - evaluating') -----
- testEmptyBlocksAnswerNil
- "In the olden days ([:a :b|] value: #first value: #last) == #last..."
- {[]. [:a|]. [:a :b|]. [:a :b :c|]} do:
- [:block|
- self assert: (block cull: 1 cull: 2 cull: 3) equals: nil]!
Item was removed:
- ----- Method: BlockClosureTest>>testMoreThanOnce (in category 'tests - evaluating') -----
- testMoreThanOnce
- "Make sure that we can use once more than once"
- | moreThanOnce |
- moreThanOnce := (1 to: 3) collect: [:e | [String new] once -> [Array new] once].
- self assert: (moreThanOnce allSatisfy: [:each | each key isString]).
- self assert: (moreThanOnce allSatisfy: [:each | each value isArray]).
- self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
- self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).!
Item was removed:
- ----- Method: BlockClosureTest>>testMoreThanOnceForEqualBlocks (in category 'tests - evaluating') -----
- testMoreThanOnceForEqualBlocks
- "Make sure that we can use once more than once"
- | moreThanOnce |
- moreThanOnce := (1 to: 3) collect: [:e | [Object new] once -> [Object new] once].
- self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
- self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).
- self assert: (moreThanOnce noneSatisfy: [:each | each key == each value]).!
Item was removed:
- ----- Method: BlockClosureTest>>testNew (in category 'tests') -----
- testNew
- self should: [Context new: 5] raise: Error.
- [Context new: 5]
- on: Error do: [:e|
- self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new:'].
-
- self should: [Context new] raise: Error.
- [Context new]
- on: Error do: [:e|
- self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new']!
Item was removed:
- ----- Method: BlockClosureTest>>testNoArguments (in category 'tests') -----
- testNoArguments
- [10
- timesRepeat: [:arg | 1 + 2]]
- ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.'].
- [10
- timesRepeat: [:arg1 :arg2 | 1 + 2]]
- ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.']!
Item was removed:
- ----- Method: BlockClosureTest>>testOnce (in category 'tests - evaluating') -----
- testOnce
- | objs result |
- objs := (1 to: 10) collect: [:ign| [Object new] once].
- self assert: (objs allSatisfy: [:obj| obj == objs first]).
- result := self class onceMethod.
- 1 to: 10 do:
- [:ign|
- self assert: result == self class onceMethod]!
Item was removed:
- ----- Method: BlockClosureTest>>testOneArgument (in category 'tests') -----
- testOneArgument
- | c |
- c := OrderedCollection new.
- c add: 'hello'.
- [c
- do: [1 + 2]]
- ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.'].
- [c
- do: [:arg1 :arg2 | 1 + 2]]
- ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.']!
Item was removed:
- ----- Method: BlockClosureTest>>testRunSimulated (in category 'tests') -----
- testRunSimulated
- self assert: Rectangle equals:
- (Context runSimulated: aBlockClosure asContext) class.
- self assert: 42 equals:
- (Context runSimulated: [self return: 42]).
- self
- should: [Context runSimulated: [self halt]]
- raise: Halt.!
Item was removed:
- ----- Method: BlockClosureTest>>testRunSimulatedContextAtEachStep (in category 'tests') -----
- testRunSimulatedContextAtEachStep
-
- | context |
- context := aBlockClosure asContext.
- self assert: Rectangle equals: (thisContext
- runSimulated: context
- contextAtEachStep: [:ctxt | self assert:
- [ctxt == context or: [ctxt hasSender: context]]]) class.!
Item was removed:
- ----- Method: BlockClosureTest>>testSetUp (in category 'tests') -----
- testSetUp
- "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
- self deny: aBlockClosure isContext.
- self assert: aBlockClosure isClosure.
- self assert: aBlockClosure home = homeOfABlockClosure.
- self assert: aBlockClosure receiver = self.
- self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
- ifTrue: [aBlockClosure method isCompiledBlock]
- ifFalse: [aBlockClosure method isCompiledMethod])!
Item was removed:
- ----- Method: BlockClosureTest>>testSourceString (in category 'tests - printing') -----
- testSourceString
- self assert: [] sourceString equals: '[]'.
- self assert: (#((#'[' #':arg' #| nil #']') (#'[' #':arg' #| #']')) includes: (Scanner new scanTokens: [:arg|] sourceString)).
- self assert: (Scanner new scanTokens: [ : stream | self printSourceOn: stream ] sourceString)
- equals: #(#'[' #':stream' #| #self #printSourceOn: #stream #']')!
Item was removed:
- ----- Method: BlockClosureTest>>testSupplyAnswerOfFillInTheBlank (in category 'tests - supply answer') -----
- testSupplyAnswerOfFillInTheBlank
-
- UIManager subclassesDo: [:managerClass |
- self should: ['blue' = ([managerClass new request: 'Your favorite color?']
- valueSupplyingAnswer: #('Your favorite color?' 'blue'))]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer (in category 'tests - supply answer') -----
- testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer
-
- UIManager subclassesDo: [:managerClass |
- self should: ['red' = ([managerClass new request: 'Your favorite color?' initialAnswer: 'red']
- valueSupplyingAnswer: #('Your favorite color?' #default))]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSupplyAnswerUsingOnlySubstringOfQuestion (in category 'tests - supply answer') -----
- testSupplyAnswerUsingOnlySubstringOfQuestion
-
- UIManager subclassesDo: [:managerClass |
- self should: [false = ([managerClass new confirm: 'You like Smalltalk?']
- valueSupplyingAnswer: #('like' false))]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSupplyAnswerUsingRegexMatchOfQuestion (in category 'tests - supply answer') -----
- testSupplyAnswerUsingRegexMatchOfQuestion
-
- (String includesSelector: #matchesRegex:) ifFalse: [^ self].
-
- UIManager subclassesDo: [:managerClass |
- self should: [true = ([managerClass new confirm: 'You like Smalltalk?']
- valueSupplyingAnswer: #('.*Smalltalk\?' true))]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSupplySpecificAnswerToQuestion (in category 'tests - supply answer') -----
- testSupplySpecificAnswerToQuestion
-
- UIManager subclassesDo: [:managerClass |
- self should: [false = ([managerClass new confirm: 'You like Smalltalk?']
- valueSupplyingAnswer: #('You like Smalltalk?' false))]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSupplySpecificAnswerToSelection (in category 'tests - supply answer') -----
- testSupplySpecificAnswerToSelection
-
- | windowTitle |
- windowTitle := 'What is your favorite letter?'.
- UIManager subclassesDo: [:managerClass |
- self should: [#b = ([managerClass new chooseFrom: #(a b c) values: #(a b c) title: windowTitle]
- valueSupplyingAnswer: {windowTitle . #b})]].
-
- UIManager subclassesDo: [:managerClass |
- self should: [#b = ([managerClass new chooseFrom: #(a b c) values: #(a b c) title: windowTitle]
- valueSupplyingAnswer: {windowTitle . 2})]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSuppressInform (in category 'tests - supply answer') -----
- testSuppressInform
-
- UIManager subclassesDo: [:managerClass | | manager |
- manager := managerClass new.
- self should: [[manager inform: 'Should not see this message or this test failed!!']
- valueSuppressingAllMessages]]!
Item was removed:
- ----- Method: BlockClosureTest>>testSuppressInformUsingStringMatchOptions (in category 'tests - supply answer') -----
- testSuppressInformUsingStringMatchOptions
-
- UIManager subclassesDo: [:managerClass | | manager |
- manager := managerClass new.
- #("message" "pattern"
- 'Should not see this message or this test failed!!' 'Should not see this message or this test failed!!'
- 'Should not see this message or this test failed!!' 'not see this message'
- 'Should not see this message or this test failed!!' '*message*failed#')
- pairsDo: [:message :pattern |
- self assert: ([manager inform: message] valueSuppressingMessages: {pattern})]]!
Item was removed:
- ----- Method: BlockClosureTest>>testTallyInstructions (in category 'tests') -----
- testTallyInstructions
- self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
- ifTrue: [14]
- ifFalse: [15])
- equals: (Context tallyInstructions: aBlockClosure asContext) size!
Item was removed:
- ----- Method: BlockClosureTest>>testValue (in category 'tests - evaluating') -----
- testValue
-
- "#value"
- self
- assert: nil equals: [ ] value;
- assert: 1 equals: [ 1 ] value;
- should: [ [ :a | ] value ] raise: Error.
-
- "#value:"
- self
- assert: nil equals: ([ :a | ] value: 1);
- assert: 1 equals: ([ :a | a ] value: 1);
- should: [ [ ] value: 1 ] raise: Error;
- should: [ [ :a :b | ] value: 1 ] raise: Error!
Item was removed:
- ----- Method: BlockClosureTest>>testValueValue (in category 'tests - evaluating') -----
- testValueValue
-
- self
- assert: nil equals: ([ :a :b | ] value: 1 value: 2);
- assert: 1 equals: ([ :a :b | a ] value: 1 value: 2);
- assert: 2 equals: ([ :a :b | b ] value: 1 value: 2);
- should: [ [ ] value: 1 value: 2 ] raise: Error;
- should: [ [ :a | ] value: 1 value: 2 ] raise: Error;
- should: [ [ :a :b :c | ] value: 1 value: 2 ] raise: Error!
Item was removed:
- ----- Method: BlockClosureTest>>testValueValueValue (in category 'tests - evaluating') -----
- testValueValueValue
-
- self
- assert: nil equals: ([ :a :b :c | ] value: 1 value: 2 value: 3);
- assert: 1 equals: ([ :a :b :c | a ] value: 1 value: 2 value: 3);
- assert: 2 equals: ([ :a :b :c | b ] value: 1 value: 2 value: 3);
- assert: 3 equals: ([ :a :b :c | c ] value: 1 value: 2 value: 3);
- should: [ [ ] value: 1 value: 2 value: 3 ] raise: Error;
- should: [ [ :a | ] value: 1 value: 2 value: 3 ] raise: Error;
- should: [ [ :a :b | ] value: 1 value: 2 value: 3 ] raise: Error;
- should: [ [ :a :b :c :d | ] value: 1 value: 2 value: 3 ] raise: Error!
Item was removed:
- ----- Method: BlockClosureTest>>testValueValueValueValue (in category 'tests - evaluating') -----
- testValueValueValueValue
-
- self
- assert: nil equals: ([ :a :b :c :d | ] value: 1 value: 2 value: 3 value: 4);
- assert: 1 equals: ([ :a :b :c :d | a ] value: 1 value: 2 value: 3 value: 4);
- assert: 2 equals: ([ :a :b :c :d | b ] value: 1 value: 2 value: 3 value: 4);
- assert: 3 equals: ([ :a :b :c :d | c ] value: 1 value: 2 value: 3 value: 4);
- assert: 4 equals: ([ :a :b :c :d | d ] value: 1 value: 2 value: 3 value: 4);
- should: [ [ ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
- should: [ [ :a | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
- should: [ [ :a :b | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
- should: [ [ :a :b :c | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
- should: [ [ :a :b :c :d :e | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error!
Item was removed:
- ----- Method: BlockClosureTest>>testValueValueValueValueValue (in category 'tests - evaluating') -----
- testValueValueValueValueValue
-
- self
- assert: nil equals: ([ :a :b :c :d :e | ] value: 1 value: 2 value: 3 value: 4 value: 5);
- assert: 1 equals: ([ :a :b :c :d :e | a ] value: 1 value: 2 value: 3 value: 4 value: 5);
- assert: 2 equals: ([ :a :b :c :d :e | b ] value: 1 value: 2 value: 3 value: 4 value: 5);
- assert: 3 equals: ([ :a :b :c :d :e | c ] value: 1 value: 2 value: 3 value: 4 value: 5);
- assert: 4 equals: ([ :a :b :c :d :e | d ] value: 1 value: 2 value: 3 value: 4 value: 5);
- assert: 5 equals: ([ :a :b :c :d :e | e ] value: 1 value: 2 value: 3 value: 4 value: 5);
- should: [ [ ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
- should: [ [ :a | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
- should: [ [ :a :b | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
- should: [ [ :a :b :c | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
- should: [ [ :a :b :c :d | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
- should: [ [ :a :b :c :d :e :f | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error!
Item was removed:
- ----- Method: BlockClosureTest>>testValueWithPossibleArgs (in category 'tests - evaluating') -----
- testValueWithPossibleArgs
- | block blockWithArg blockWith2Arg |
-
- block := [1].
- blockWithArg := [:arg | arg].
- blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}].
-
- self assert: (block valueWithPossibleArgs: #()) = 1.
- self assert: (block valueWithPossibleArgs: #(1)) = 1.
-
- self assert: (blockWithArg valueWithPossibleArgs: #()) = nil.
- self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1.
- self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1.
-
- self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}.
- self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}.
- self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2).
- self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2)!
Item was removed:
- ----- Method: BlockClosureTest>>testValueWithPossibleArgument (in category 'tests - evaluating') -----
- testValueWithPossibleArgument
- | block blockWithArg blockWith2Arg |
-
- block := [1].
- blockWithArg := [:arg | arg].
- blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}].
-
- self assert: (block valueWithPossibleArgument: 1) = 1.
-
- self assert: (blockWithArg valueWithPossibleArgument: 1) = 1.
-
- self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}!
Item was removed:
- ClassTestCase subclass: #BooleanTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
-
- !BooleanTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category
- !
Item was removed:
- ----- Method: BooleanTest>>testBooleanInitializedInstance (in category 'tests') -----
- testBooleanInitializedInstance
-
- self assert: (Boolean initializedInstance = nil).!
Item was removed:
- ----- Method: BooleanTest>>testBooleanNew (in category 'tests') -----
- testBooleanNew
-
- self shouldRaiseError: [Boolean new].
- self shouldRaiseError: [True new].
- self shouldRaiseError: [False new].!
Item was removed:
- ----- Method: BooleanTest>>testNew (in category 'tests') -----
- testNew
-
- self shouldRaiseError: [Boolean new].!
Item was removed:
- TestCase subclass: #CategorizerTest
- instanceVariableNames: 'categorizer'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
Item was removed:
- ----- Method: CategorizerTest>>setUp (in category 'running') -----
- setUp
- categorizer := Categorizer defaultList: #(a b c d e).
- categorizer classifyAll: #(a b c) under: 'abc'.
- categorizer addCategory: 'unreal'.!
Item was removed:
- ----- Method: CategorizerTest>>testClassifyNewElementNewCategory (in category 'tests') -----
- testClassifyNewElementNewCategory
- categorizer classify: #f under: #nice.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- (''unreal'')
- (''nice'' f)
- '!
Item was removed:
- ----- Method: CategorizerTest>>testClassifyNewElementOldCategory (in category 'tests') -----
- testClassifyNewElementOldCategory
- categorizer classify: #f under: #unreal.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- (''unreal'' f)
- '!
Item was removed:
- ----- Method: CategorizerTest>>testClassifyOldElementNewCategory (in category 'tests') -----
- testClassifyOldElementNewCategory
- categorizer classify: #e under: #nice.
- self assert: categorizer printString =
- '(''as yet unclassified'' d)
- (''abc'' a b c)
- (''unreal'')
- (''nice'' e)
- '!
Item was removed:
- ----- Method: CategorizerTest>>testClassifyOldElementOldCategory (in category 'tests') -----
- testClassifyOldElementOldCategory
- categorizer classify: #e under: #unreal.
- self assert: categorizer printString =
- '(''as yet unclassified'' d)
- (''abc'' a b c)
- (''unreal'' e)
- '!
Item was removed:
- ----- Method: CategorizerTest>>testDefaultCategoryIsTransient (in category 'tests') -----
- testDefaultCategoryIsTransient
- "Test that category 'as yet unclassified' disapears when all it's elements are removed'"
- categorizer classifyAll: #(d e) under: #abc.
- self assert: categorizer printString =
- '(''abc'' a b c d e)
- (''unreal'')
- '!
Item was removed:
- ----- Method: CategorizerTest>>testNoSpecialCategories (in category 'tests') -----
- testNoSpecialCategories
-
- SystemNavigation allClasses do: [:class |
- {class. class class} do: [:classOrMetaClass |
- self
- assert: (classOrMetaClass organization categories includes: Categorizer allCategory) not
- description: ('{1} must not have the all-category in its organization.' format: {class name}).
- self
- assert: (classOrMetaClass organization isEmpty or: [
- (classOrMetaClass organization categories includes: Categorizer nullCategory) not])
- description: ('{1} must not have the null-category in its organization.' format: {class name}).]].!
Item was removed:
- ----- Method: CategorizerTest>>testNullCategory (in category 'tests') -----
- testNullCategory
- "Test that category 'as yet unclassified' disapears when all it's elements are removed'"
- | aCategorizer |
- aCategorizer := Categorizer defaultList: #().
- self assert: aCategorizer printString =
- '(''as yet unclassified'')
- '.
- self assert: aCategorizer categories = #('no messages').
- aCategorizer classify: #a under: #b.
- self assert: aCategorizer printString =
- '(''b'' a)
- '.
- self assert: aCategorizer categories = #(b).!
Item was removed:
- ----- Method: CategorizerTest>>testRemoveEmptyCategory (in category 'tests') -----
- testRemoveEmptyCategory
- categorizer removeCategory: #unreal.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- '!
Item was removed:
- ----- Method: CategorizerTest>>testRemoveExistingElement (in category 'tests') -----
- testRemoveExistingElement
- categorizer removeElement: #a.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' b c)
- (''unreal'')
- '!
Item was removed:
- ----- Method: CategorizerTest>>testRemoveNonEmptyCategory (in category 'tests') -----
- testRemoveNonEmptyCategory
- self should: [categorizer removeCategory: #abc] raise: Error.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- (''unreal'')
- '!
Item was removed:
- ----- Method: CategorizerTest>>testRemoveNonExistingCategory (in category 'tests') -----
- testRemoveNonExistingCategory
- categorizer removeCategory: #nice.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- (''unreal'')
- '!
Item was removed:
- ----- Method: CategorizerTest>>testRemoveNonExistingElement (in category 'tests') -----
- testRemoveNonExistingElement
- categorizer removeElement: #f.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- (''unreal'')
- '!
Item was removed:
- ----- Method: CategorizerTest>>testRemoveThenRename (in category 'tests') -----
- testRemoveThenRename
- categorizer removeCategory: #unreal.
- categorizer renameCategory: #abc toBe: #unreal.
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''unreal'' a b c)
- '!
Item was removed:
- ----- Method: CategorizerTest>>testUnchanged (in category 'tests') -----
- testUnchanged
- self assert: categorizer printString =
- '(''as yet unclassified'' d e)
- (''abc'' a b c)
- (''unreal'')
- '!
Item was removed:
- ClassTestCase subclass: #ClassBuilderTest
- instanceVariableNames: 'baseClass subClass baseClass2 subSubClass'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
Item was removed:
- ----- Method: ClassBuilderTest>>baseClassName (in category 'utilities') -----
- baseClassName
- ^#DummyClassBuilderFormatTestSuperClass!
Item was removed:
- ----- Method: ClassBuilderTest>>categoryNameForTemporaryClasses (in category 'utilities') -----
- categoryNameForTemporaryClasses
- "Answer the category where to classify temporarily created classes"
-
- ^'Dummy-Tests-ClassBuilder'!
Item was removed:
- ----- Method: ClassBuilderTest>>cleanup (in category 'utilities') -----
- cleanup
- subSubClass ifNotNil:[subSubClass removeFromSystem].
- subClass ifNotNil:[subClass removeFromSystem].
- baseClass ifNotNil:[baseClass removeFromSystem].
- baseClass2 ifNotNil: [baseClass2 removeFromSystem].
- (Smalltalk organization listAtCategoryNamed: self categoryNameForTemporaryClasses) isEmpty
- ifTrue: [Smalltalk organization removeCategory: self categoryNameForTemporaryClasses]!
Item was removed:
- ----- Method: ClassBuilderTest>>makeByteVariableSubclassOf: (in category 'utilities') -----
- makeByteVariableSubclassOf: aClass
- ^ aClass variableByteSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeDoubleByteVariableSubclassOf: (in category 'utilities') -----
- makeDoubleByteVariableSubclassOf: aClass
- ^ aClass variableDoubleByteSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeDoubleWordVariableSubclassOf: (in category 'utilities') -----
- makeDoubleWordVariableSubclassOf: aClass
- ^ aClass variableDoubleWordSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeIVarsSubclassOf: (in category 'utilities') -----
- makeIVarsSubclassOf: aClass
- ^ aClass subclass: self subClassName
- instanceVariableNames: 'var3 var4'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeNormalSubclassOf: (in category 'utilities') -----
- makeNormalSubclassOf: aClass
- ^ aClass subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeVariableSubclassOf: (in category 'utilities') -----
- makeVariableSubclassOf: aClass
- ^ aClass variableSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeWeakSubclassOf: (in category 'utilities') -----
- makeWeakSubclassOf: aClass
- ^ aClass weakSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>makeWordVariableSubclassOf: (in category 'utilities') -----
- makeWordVariableSubclassOf: aClass
- ^ aClass variableWordSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses!
Item was removed:
- ----- Method: ClassBuilderTest>>performTest (in category 'private') -----
- performTest
-
- Utilities
- useAuthorInitials: self className
- during: [ super performTest ]!
Item was removed:
- ----- Method: ClassBuilderTest>>subClassName (in category 'utilities') -----
- subClassName
- ^#DummyClassBuilderFormatTestSubClass!
Item was removed:
- ----- Method: ClassBuilderTest>>subSubClassName (in category 'utilities') -----
- subSubClassName
- ^#DummyClassBuilderFormatTestSubSubClass!
Item was removed:
- ----- Method: ClassBuilderTest>>tearDown (in category 'running') -----
- tearDown
-
- self cleanup.
- baseClass := nil.
- subClass := nil.
- baseClass2 := nil.
- subSubClass := nil!
Item was removed:
- ----- Method: ClassBuilderTest>>testByteVariableSubclass (in category 'tests - format') -----
- testByteVariableSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object variableByteSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
-
- subClass := self makeNormalSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self assert: (subClass isBytes).
- self deny: (subClass isWords).
- self deny: (subClass isShorts).
- self deny: (subClass isLongs).
- subClass removeFromSystem.
-
- "pointer classes"
- self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
- self should:[self makeVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWeakSubclassOf: baseClass] raise: Error.
-
- "bit classes"
- subClass := self makeByteVariableSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self assert: (subClass isBytes).
- self deny: (subClass isWords).
- self deny: (subClass isShorts).
- self deny: (subClass isLongs).
- subClass removeFromSystem.
-
- self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error.
-
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testChangeToVariableSubclass (in category 'tests - format') -----
- testChangeToVariableSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- baseClass := Object variableSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
-
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testCompiledMethodSubclass (in category 'tests - format') -----
- testCompiledMethodSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- [self deny: (Smalltalk includesKey: self subClassName).
- baseClass := CompiledMethod
- variableByteSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- self deny: baseClass isPointers.
- self assert: baseClass isVariable.
- self deny: baseClass isWeak.
- self assert: baseClass isBytes.
- self assert: baseClass isCompiledMethodClass.
- self deny: baseClass isWords.
- self deny: baseClass isShorts.
- self deny: baseClass isLongs.
- "Now move it to be a sibling; test it maintains its CompiledMethod-ness"
- baseClass := ByteArray
- variableByteSubclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- self deny: baseClass isPointers.
- self assert: baseClass isVariable.
- self deny: baseClass isWeak.
- self assert: baseClass isBytes.
- self assert: baseClass isCompiledMethodClass.
- self deny: baseClass isWords.
- self deny: baseClass isShorts.
- self deny: baseClass isLongs]
- ensure: [self cleanup]!
Item was removed:
- ----- Method: ClassBuilderTest>>testDoubleByteVariableSubclass (in category 'tests - format') -----
- testDoubleByteVariableSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object variableDoubleByteSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- subClass := self makeNormalSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isShorts).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- self deny: (subClass isWords).
- self deny: (subClass isLongs).
- subClass removeFromSystem.
-
- "pointer classes"
- self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
- self should:[self makeVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWeakSubclassOf: baseClass] raise: Error.
-
- "bit classes"
- self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error.
- subClass := self makeDoubleByteVariableSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isShorts).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- self deny: (subClass isWords).
- self deny: (subClass isLongs).
- subClass removeFromSystem.
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testDoubleWordVariableSubclass (in category 'tests - format') -----
- testDoubleWordVariableSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object variableDoubleWordSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- subClass := self makeNormalSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isLongs).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- self deny: (subClass isShorts).
- self deny: (subClass isWords).
- subClass removeFromSystem.
-
- "pointer classes"
- self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
- self should:[self makeVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWeakSubclassOf: baseClass] raise: Error.
-
- "bit classes"
- self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
- subClass := self makeDoubleWordVariableSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isLongs).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- self deny: (subClass isShorts).
- self deny: (subClass isWords).
- subClass removeFromSystem.
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testDuplicateClassVariableError (in category 'tests - reshape') -----
- testDuplicateClassVariableError
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: 'TestVar'
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
-
- self should:[
- subClass := baseClass subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: 'TestVar'
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses
- ] raise: DuplicateVariableError.
-
- [subClass := baseClass subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: 'TestVar'
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses
- ] on: DuplicateVariableError do:[:ex|
- self assert: ex superclass == baseClass.
- self assert: ex variable = 'TestVar'.
- ex resume.
- ].
-
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
-
- self should:[
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: 'TestVar'
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- ] raise: DuplicateVariableError.
-
- [baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: 'TestVar'
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- ] on: DuplicateVariableError do:[:ex|
- self assert: ex superclass == baseClass.
- self assert: ex variable = 'TestVar'.
- ex resume.
- ].!
Item was removed:
- ----- Method: ClassBuilderTest>>testDuplicateInstanceVariableError (in category 'tests - reshape') -----
- testDuplicateInstanceVariableError
- | didRaise |
- "Define 'var' in a superclass."
- baseClass := Object
- subclass: self baseClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- "Ensure trying to define a subclass with same var errors."
- didRaise := false.
- [baseClass subclass: self subClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses ]
- on: DuplicateVariableError do:
- [ : err |
- didRaise := true.
- self assert: err superclass == baseClass.
- self assert: err variable = 'var' ].
- self assert: didRaise.
- "Prepare for next test: Remove 'var' from superclass."
- baseClass := Object
- subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- "Define a subclass without 'var'..."
- subClass := baseClass
- subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- "... but with a subclass of THAT, with 'var' defined."
- subSubClass := subClass subclass: self subSubClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- "... as well as a different base class with 'var' already defined..."
- baseClass2 := Object
- subclass: (self baseClassName,'2') asSymbol
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- "...and now try to move the middle subClass, whose subclass (a.k.a., subSubClass) defines 'var', to the new baseClass which also defines 'var'."
- didRaise := false.
- [baseClass2 subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses ]
- on: DuplicateVariableError do:
- [ : err |
- didRaise := true.
- self assert: err superclass == baseClass2.
- self assert: err variable = 'var' ].
- self assert: didRaise!
Item was removed:
- ----- Method: ClassBuilderTest>>testMoveVarFromSubToSuperclass (in category 'tests - reshape') -----
- testMoveVarFromSubToSuperclass
- | baseInst subInst |
-
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
-
- subClass := baseClass subclass: self subClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- subClass compile: 'subGet ^var'.
- subClass compile: 'subSet: v var := v'.
-
- self assert:[baseClass instSize = 0].
- self assert:[subClass instSize = 1].
-
- baseInst := baseClass new.
- subInst := subClass new.
- subInst instVarAt: 1 put: 123.
-
- self assert: (subInst instVarAt: 1) = 123.
- self assert: (subInst subGet) = 123.
-
- [baseClass := Object subclass: self baseClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- ] on: DuplicateVariableError do:[:ex| ex resume].
- baseClass compile: 'superGet ^var'.
- baseClass compile: 'superSet: v var := v'.
-
- self assert:[baseClass instSize = 1].
- self assert:[subClass instSize = 2].
-
- "the assumption here is that an existing value is propagated up"
- self assert: (baseInst instVarAt: 1) = nil.
- self assert: (subInst instVarAt: 1) = 123.
- self assert: (subInst instVarAt: 2) = 123.
-
- "the assumption below is that the subclass binds to the local scope not
- the outer one, which is in line with common name space approaches."
- subInst superSet: 666.
- subInst subSet: 321.
-
- self assert: (subInst instVarAt: 1) = 666.
- self assert: (subInst instVarAt: 2) = 321.
- self assert: (subInst superGet) = 666.
- self assert: (subInst subGet) = 321.
-
- subClass := baseClass subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
-
- self assert:[baseClass instSize = 1].
- self assert:[subClass instSize = 1].
-
- "the assumption here is that the current (subclass) value is propagated up"
- self assert: (subInst instVarAt: 1) = 321.
- self assert: (subInst subGet) = 321.
- !
Item was removed:
- ----- Method: ClassBuilderTest>>testMoveVarFromSuperToSubclass (in category 'tests - reshape') -----
- testMoveVarFromSuperToSubclass
- | baseInst subInst |
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- baseClass compile: 'superGet ^var'.
- baseClass compile: 'superSet: v var := v'.
-
- subClass := baseClass subclass: self subClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- subClass compile: 'subGet ^var'.
- subClass compile: 'subSet: v var := v'.
-
- self assert:[baseClass instSize = 1].
- self assert:[subClass instSize = 1].
-
- baseInst := baseClass new.
- subInst := subClass new.
- baseInst instVarAt: 1 put: 42.
- subInst instVarAt: 1 put: 123.
-
- self assert: (baseInst instVarAt: 1) = 42.
- self assert: (subInst instVarAt: 1) = 123.
- self assert: (subInst subGet) = 123.
-
- [subClass := baseClass subclass: self subClassName
- instanceVariableNames: 'var'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses
- ] on: DuplicateVariableError do:[:ex| ex resume].
-
- self assert:[baseClass instSize = 1].
- self assert:[subClass instSize = 2].
-
- self assert: (baseInst instVarAt: 1) = 42.
-
- "the assumption below is that for duplicate variables the values get duplicated too.
- this isn't strictly necessary; what we really need is that the old var doesn't get
- nuked but it has some advantages when moving vars up the hierarchy"
- self assert: (subInst instVarAt: 1) = 123.
- self assert: (subInst instVarAt: 2) = 123.
- self assert: (subInst superGet) = 123.
- self assert: (subInst subGet) = 123.
-
- "the assumption below is that the subclass binds to the local scope not
- the outer one, which is in line with common name space approaches."
- subInst superSet: 666.
- subInst subSet: 321.
-
- self assert: (subInst instVarAt: 1) = 666.
- self assert: (subInst instVarAt: 2) = 321.
- self assert: (subInst superGet) = 666.
- self assert: (subInst subGet) = 321.
-
- baseClass removeSelector: #superGet.
- baseClass removeSelector: #superSet:.
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
-
- self assert:[baseClass instSize = 0].
- self assert:[subClass instSize = 1].
-
- self assert: (subInst instVarAt: 1) = 321.
- self assert: (subInst subGet) = 321.
- !
Item was removed:
- ----- Method: ClassBuilderTest>>testNewUniclass (in category 'tests - uniclass') -----
- testNewUniclass
-
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- "Note that you have to denote a new base class to be capable of spawning uni classes. See Object class >> #isUniClass for more information."
- baseClass class
- compile: ('isUniClass\ ^ self ~~ {1}' withCRs format: {self baseClassName})
- classified: 'instance creation'.
-
- subClass := baseClass newSubclass.
-
- self
- assert: subClass isUniClass;
- assert: subClass environment ~~ baseClass environment;
- assert: subClass category = Object categoryForUniclasses;
- assert: (baseClass organization categoryOfElement: subClass name) isNil.
-
- self deny: subClass isObsolete.
- subClass removeFromSystem.
- self assert: subClass isObsolete.!
Item was removed:
- ----- Method: ClassBuilderTest>>testSubclass (in category 'tests - format') -----
- testSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- subClass := self makeNormalSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self deny: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- "pointer classes"
- subClass := self makeIVarsSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self deny: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeVariableSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert:(subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeWeakSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert:(subClass isVariable).
- self assert:(subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- "bit classes"
- subClass := self makeByteVariableSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self assert: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeWordVariableSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testSubclassWithInstanceVariables (in category 'tests - format') -----
- testSubclassWithInstanceVariables
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object subclass: self baseClassName
- instanceVariableNames: 'var1 var2'
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- subClass := self makeNormalSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self deny: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- "pointer classes"
- subClass := self makeIVarsSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self deny: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeVariableSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeWeakSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- "bit classes"
- self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testVariableSubclass (in category 'tests - format') -----
- testVariableSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object variableSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- "pointer classes"
- subClass := self makeNormalSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeIVarsSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeVariableSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeWeakSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- "bit classes"
- self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testWeakSubclass (in category 'tests - format') -----
- testWeakSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object weakSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- "pointer classes"
- subClass := self makeNormalSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeIVarsSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeVariableSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- subClass := self makeWeakSubclassOf: baseClass.
- self assert: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWeak).
- self deny: (subClass isBytes).
- subClass removeFromSystem.
-
- "bit classes"
- self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
- ] ensure:[self cleanup].!
Item was removed:
- ----- Method: ClassBuilderTest>>testWordVariableSubclass (in category 'tests - format') -----
- testWordVariableSubclass
- "Ensure that the invariants for superclass/subclass format are preserved"
- baseClass := Object variableWordSubclass: self baseClassName
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- [
- subClass := self makeNormalSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWords).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- self deny: (subClass isShorts).
- self deny: (subClass isLongs).
- subClass removeFromSystem.
-
- "pointer classes"
- self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
- self should:[self makeVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeWeakSubclassOf: baseClass] raise: Error.
-
- "bit classes"
- self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error.
- self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error.
- subClass := self makeWordVariableSubclassOf: baseClass.
- self deny: (subClass isPointers).
- self assert: (subClass isVariable).
- self assert: (subClass isWords).
- self deny: (subClass isWeak).
- self deny: (subClass isBytes).
- self deny: (subClass isShorts).
- self deny: (subClass isLongs).
- subClass removeFromSystem.
- ] ensure:[self cleanup].!
Item was removed:
- ClassTestCase subclass: #ClassDescriptionTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
-
- !ClassDescriptionTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class ClassDescription. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: ClassDescriptionTest>>testOrganization (in category 'tests') -----
- testOrganization
-
- | aClassOrganizer |
- aClassOrganizer := ClassDescription organization.
- self assert: (aClassOrganizer isKindOf: ClassOrganizer).!
Item was removed:
- Object subclass: #ClassForBehaviorTest
- instanceVariableNames: 'iv1 iv2'
- classVariableNames: 'CV1 CV2'
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
- ClassForBehaviorTest class
- instanceVariableNames: 'civ1'!
- ClassForBehaviorTest class
- instanceVariableNames: 'civ1'!
Item was removed:
- ----- Method: ClassForBehaviorTest class>>civ1 (in category 'accessing') -----
- civ1
- ^civ1 ifNil: [civ1 := false]!
Item was removed:
- ----- Method: ClassForBehaviorTest class>>initialize (in category 'class initialization') -----
- initialize
- CV1 := 1.
- CV2 := 2!
Item was removed:
- ----- Method: ClassForBehaviorTest>>initialize (in category 'accessing') -----
- initialize
- iv1 := CV1 ifNil: [CV1 := 1]!
Item was removed:
- ----- Method: ClassForBehaviorTest>>iv1 (in category 'accessing') -----
- iv1
- ^iv1!
Item was removed:
- ----- Method: ClassForBehaviorTest>>iv1: (in category 'accessing') -----
- iv1: anyObject
- iv1 := anyObject!
Item was removed:
- ----- Method: ClassForBehaviorTest>>iv2 (in category 'accessing') -----
- iv2
- ^iv2!
Item was removed:
- ----- Method: ClassForBehaviorTest>>iv2: (in category 'accessing') -----
- iv2: anyObject
- iv2 := anyObject!
Item was removed:
- ----- Method: ClassForBehaviorTest>>reset (in category 'accessing') -----
- reset
- iv1 := iv2 := nil!
Item was removed:
- TestCase subclass: #ClassTest
- instanceVariableNames: 'className renamedName'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
Item was removed:
- ----- Method: ClassTest>>categoryNameForTemporaryClasses (in category 'setup') -----
- categoryNameForTemporaryClasses
- "Answer the category where to classify temporarily created classes"
-
- ^'Dummy-Tests-Class'!
Item was removed:
- ----- Method: ClassTest>>deleteClass (in category 'setup') -----
- deleteClass
- | cl |
- cl := Smalltalk at: className ifAbsent: [^self].
- cl removeFromChanges; removeFromSystemUnlogged
- !
Item was removed:
- ----- Method: ClassTest>>deleteRenamedClass (in category 'setup') -----
- deleteRenamedClass
- | cl |
- cl := Smalltalk at: renamedName ifAbsent: [^self].
- cl removeFromChanges; removeFromSystemUnlogged
- !
Item was removed:
- ----- Method: ClassTest>>performTest (in category 'private') -----
- performTest
-
- Utilities
- useAuthorInitials: self className
- during: [ super performTest ]!
Item was removed:
- ----- Method: ClassTest>>setUp (in category 'setup') -----
- setUp
- className := #TUTU.
- renamedName := #RenamedTUTU.
- self deleteClass.
- self deleteRenamedClass.
- Object subclass: className
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self categoryNameForTemporaryClasses.
- #('foo' 'bar self foo' 'baz self bar') do:
- [:s| (Smalltalk at: className) compileSilently: s]!
Item was removed:
- ----- Method: ClassTest>>tearDown (in category 'setup') -----
- tearDown
- self deleteClass.
- self deleteRenamedClass.
- (Smalltalk organization listAtCategoryNamed: self categoryNameForTemporaryClasses) isEmpty
- ifTrue: [Smalltalk organization removeCategory: self categoryNameForTemporaryClasses]!
Item was removed:
- ----- Method: ClassTest>>testAddInstVarName (in category 'tests') -----
- testAddInstVarName
- "self run: #testAddInstVarName"
-
-
- | tutu |
- tutu := Smalltalk at: className.
- tutu addInstVarName: 'x'.
- self assert: (tutu instVarNames = #('x')).
- tutu addInstVarName: 'y'.
- self assert: (tutu instVarNames = #('x' 'y')).
- tutu selectorsAndMethodsDo:
- [:s :m|
- self assert: m methodClassAssociation == (Smalltalk bindingOf: className)]
-
- !
Item was removed:
- ----- Method: ClassTest>>testChangeClassOf (in category 'tests') -----
- testChangeClassOf
- "Exercise primitiveChangeClass (primitive 115) for a common use case. This should pass
- for any Squeak image format (but failed for image format 68002 prior to VM fix)"
-
- self shouldnt: [Exception new primitiveChangeClassTo: Error new] raise: Error!
Item was removed:
- ----- Method: ClassTest>>testCompileAll (in category 'tests - compiling') -----
- testCompileAll
- "We expect this to succeed."
- ClassTest compileAll.!
Item was removed:
- ----- Method: ClassTest>>testRenaming (in category 'tests') -----
- testRenaming
- "self debug: #testRenaming"
- "self run: #testRenaming"
-
- | oldName newMetaclassName class |
- oldName := className.
- newMetaclassName := (renamedName, #' class') asSymbol.
- class := Smalltalk at: oldName.
- class class compile: 'dummyMeth'.
- class rename: renamedName.
- self assert: class name = renamedName.
- self assert: (ChangeSet current changedClassNames includes: renamedName).
- self assert: (ChangeSet current changedClassNames includes: newMetaclassName).
- !
Item was removed:
- TestCase subclass: #ClassVarScopeTest
- instanceVariableNames: 'parent child grandchild foo environment'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
-
- !ClassVarScopeTest commentStamp: 'nice 7/28/2013 16:05' prior: 0!
- Test that a class variable defined in a superclass takes precedence over a global variable of same name.
-
- In #setUp:
-
- Three classes are defined: parent, child and grandchild.
- A class variable is defined in child.
- A global with the same name is defined in Smalltalk globals.
- Methods are defined in all classes getting and setting this class or global variable.
-
- Test whether methods referencing the variable with that name
- access the correct variable.!
Item was removed:
- ----- Method: ClassVarScopeTest>>createClass:superClass:classVariableNames: (in category 'private') -----
- createClass: aSymbol superClass: superClass classVariableNames: aString
-
- ^SystemChangeNotifier uniqueInstance doSilently: [
- ClassBuilder new
- name: aSymbol
- inEnvironment: environment
- subclassOf: superClass
- type: #normal
- instanceVariableNames: ''
- classVariableNames: aString
- poolDictionaries: ''
- category: 'Test' ]!
Item was removed:
- ----- Method: ClassVarScopeTest>>performTest (in category 'private') -----
- performTest
-
- Utilities
- useAuthorInitials: self className
- during: [ super performTest ]!
Item was removed:
- ----- Method: ClassVarScopeTest>>setUp (in category 'running') -----
- setUp
-
- environment := Environment withName: 'test'.
- environment importSelf.
- parent := self createClass: #ClassVarScopeParent superClass: nil classVariableNames: ''.
- child := self createClass: #ClassVarScopeChild superClass: parent classVariableNames: 'ClassVarScopeFoo'.
- grandchild := self createClass: #ClassVarScopeGrandchild superClass: child classVariableNames: ''.
- foo := environment at: #ClassVarScopeFoo put: Object basicNew.
-
- parent compileSilently: self sourceOfParentGetFoo.
- parent compileSilently: self sourceOfParentSetFoo.
-
- parent class compileSilently: self sourceOfParentGetFoo.
- parent class compileSilently: self sourceOfParentSetFoo.
-
- child compileSilently: self sourceOfChildGetFoo.
- child compileSilently: self sourceOfChildSetFoo.
-
- child class compileSilently: self sourceOfChildGetFoo.
- child class compileSilently: self sourceOfChildSetFoo.
-
- grandchild compileSilently: self sourceOfGrandchildGetFoo.
- grandchild compileSilently: self sourceOfGrandchildSetFoo.
-
- grandchild class compileSilently: self sourceOfGrandchildGetFoo.
- grandchild class compileSilently: self sourceOfGrandchildSetFoo!
Item was removed:
- ----- Method: ClassVarScopeTest>>sourceOfChildGetFoo (in category 'query') -----
- sourceOfChildGetFoo
- ^'childGetFoo
- ^ClassVarScopeFoo'!
Item was removed:
- ----- Method: ClassVarScopeTest>>sourceOfChildSetFoo (in category 'query') -----
- sourceOfChildSetFoo
- ^'childSetFoo: anObject
- ClassVarScopeFoo := anObject'!
Item was removed:
- ----- Method: ClassVarScopeTest>>sourceOfGrandchildGetFoo (in category 'query') -----
- sourceOfGrandchildGetFoo
- ^'grandchildGetFoo
- ^ClassVarScopeFoo'!
Item was removed:
- ----- Method: ClassVarScopeTest>>sourceOfGrandchildSetFoo (in category 'query') -----
- sourceOfGrandchildSetFoo
- ^'grandchildSetFoo: anObject
- ClassVarScopeFoo := anObject'!
Item was removed:
- ----- Method: ClassVarScopeTest>>sourceOfParentGetFoo (in category 'query') -----
- sourceOfParentGetFoo
- ^'parentGetFoo
- ^ClassVarScopeFoo'!
Item was removed:
- ----- Method: ClassVarScopeTest>>sourceOfParentSetFoo (in category 'query') -----
- sourceOfParentSetFoo
- ^'parentSetFoo: anObject
- ClassVarScopeFoo := anObject'!
Item was removed:
- ----- Method: ClassVarScopeTest>>tearDown (in category 'running') -----
- tearDown
-
- | classes |
- classes := { grandchild. child. parent }.
- grandchild := child := parent := nil.
- classes do: [ :each |
- each
- removeFromChanges;
- removeFromSystemUnlogged ].
- environment removeKey: #ClassVarScopeFoo ifAbsent: []!
Item was removed:
- ----- Method: ClassVarScopeTest>>testDefinedClassMethodInChild (in category 'tests') -----
- testDefinedClassMethodInChild
- self assert: child childGetFoo == nil.
- child childSetFoo: #bar.
- self assert: child childGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testDefinedClassMethodInGrandchild (in category 'tests') -----
- testDefinedClassMethodInGrandchild
- self assert: grandchild grandchildGetFoo == nil.
- grandchild grandchildSetFoo: #bar.
- self assert: grandchild grandchildGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testDefinedClassMethodInParent (in category 'tests') -----
- testDefinedClassMethodInParent
- self assert: parent parentGetFoo == foo.
- parent parentSetFoo: #bar.
- self assert: parent parentGetFoo = #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testDefinedInstanceMethodInChild (in category 'tests') -----
- testDefinedInstanceMethodInChild
- self assert: child basicNew childGetFoo == nil.
- child basicNew childSetFoo: #bar.
- self assert: child basicNew childGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testDefinedInstanceMethodInGrandchild (in category 'tests') -----
- testDefinedInstanceMethodInGrandchild
- self assert: grandchild basicNew grandchildGetFoo == nil.
- grandchild basicNew grandchildSetFoo: #bar.
- self assert: grandchild basicNew grandchildGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testDefinedInstanceMethodInParent (in category 'tests') -----
- testDefinedInstanceMethodInParent
- self assert: parent basicNew parentGetFoo == foo.
- parent basicNew parentSetFoo: #bar.
- self assert: parent basicNew parentGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testInheritedClassMethodInChild (in category 'tests') -----
- testInheritedClassMethodInChild
- self assert: child parentGetFoo == foo.
- child parentSetFoo: #bar.
- self assert: child parentGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testInheritedClassMethodInGrandchild (in category 'tests') -----
- testInheritedClassMethodInGrandchild
- self assert: grandchild childGetFoo == nil.
- grandchild childSetFoo: #bar.
- self assert: grandchild childGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testInheritedInstanceMethodInChild (in category 'tests') -----
- testInheritedInstanceMethodInChild
- self assert: child basicNew parentGetFoo == foo.
- child basicNew parentSetFoo: #bar.
- self assert: child basicNew parentGetFoo == #bar!
Item was removed:
- ----- Method: ClassVarScopeTest>>testInheritedInstanceMethodInGrandchild (in category 'tests') -----
- testInheritedInstanceMethodInGrandchild
- self assert: grandchild basicNew childGetFoo == nil.
- grandchild basicNew childSetFoo: #bar.
- self assert: grandchild basicNew childGetFoo == #bar!
Item was removed:
- LongTestCase subclass: #CompiledMethodComparisonTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: CompiledMethodComparisonTest>>testHash (in category 'tests') -----
- testHash
- <timeout: 120>
-
- | ai |
- ai := CompiledMethod allInstances.
- "We assume here that if two CompiledMethods are equal then they have the same size and header."
- (ai groupBy: [ :method | { method size. method header } ]) values
- replace: [ :each | each asArray ];
- do: [ :methods |
- 1 to: methods size do: [ :i |
- | firstMethod |
- firstMethod := methods at: i.
- i to: methods size do: [ :j |
- | secondMethod |
- secondMethod := methods at: j.
- firstMethod = secondMethod ifTrue: [
- self assert: firstMethod hash equals: secondMethod hash ] ] ] ]
- displayingProgress: 'Testing hashes'.
- self assert: (ai collect: [ :cm | cm hash ] as: Set) size * 2 >= ai asSet size!
Item was removed:
- ClassTestCase subclass: #CompiledMethodTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !CompiledMethodTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class CompiledMethod. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: CompiledMethodTest>>a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: (in category 'tests - performing') -----
- a1: a1 a2: a2 a3: a3 a4: a4 a5: a5 a6: a6 a7: a7 a8: a8 a9: a9 a10: a10 a11: a11 a12: a12 a13: a13 a14: a14 a15: a15
- "I'm a method with the maximum size of arguments that can be executed via normal send but crash on perform :)"
-
- ^ a1 + a2 - a2!
Item was removed:
- ----- Method: CompiledMethodTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- Smalltalk isRunningCog ifTrue: [ ^super expectedFailures ].
- ^#(
- "Not supported by the interpreter VM. See method comments for details"
- testPerformInSuperclassCanExecutelongMethodWithTemps
- )!
Item was removed:
- ----- Method: CompiledMethodTest>>performTest (in category 'private') -----
- performTest
-
- Utilities
- useAuthorInitials: self className
- during: [ super performTest ]!
Item was removed:
- ----- Method: CompiledMethodTest>>returnPlusOne: (in category 'examples') -----
- returnPlusOne: anInteger
- ^anInteger + 1. !
Item was removed:
- ----- Method: CompiledMethodTest>>returnTrue (in category 'examples') -----
- returnTrue
- ^true !
Item was removed:
- ----- Method: CompiledMethodTest>>testClosureCompiled (in category 'tests - closures') -----
- testClosureCompiled
- self
- assert: (self class >> #withClosure) isClosureCompiled;
- assert: (self class >> #withClosureNoNLR) isClosureCompiled!
Item was removed:
- ----- Method: CompiledMethodTest>>testClosureNLRs (in category 'tests - closures') -----
- testClosureNLRs
- self
- assert:
- ((self class >> #withClosure) embeddedBlockClosures at: 1)
- hasMethodReturn;
- assert:
- ((self class >> #withClosureNoNLR) embeddedBlockClosures at: 1)
- hasMethodReturn not!
Item was removed:
- ----- Method: CompiledMethodTest>>testClosureSize (in category 'tests - closures') -----
- testClosureSize
- | compiledMethod expectedSize |
- compiledMethod := (self class >> #withClosure).
- expectedSize := compiledMethod bytecodeSetName
- caseOf: {
- ['SistaV1'] -> [3].
- ['V3PlusClosures'] -> [2]}.
- self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.
- compiledMethod := (self class >> #withClosureNoNLR).
- expectedSize := compiledMethod bytecodeSetName
- caseOf: {
- ['SistaV1'] -> [3].
- ['V3PlusClosures'] -> [2]}.
- self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.!
Item was removed:
- ----- Method: CompiledMethodTest>>testCopy (in category 'tests - copying') -----
- testCopy
- <pragma: #pragma>
- | method copy |
- method := thisContext method.
- self assert: method pragmas notEmpty.
- copy := method copy.
- self assert: (method equivalentTo: copy).
- self assert: method = copy.
- self assert: method ~~ copy.
- method pragmas do:
- [:p|
- self assert: p method == method].
- copy pragmas do:
- [:p|
- self assert: p method == copy]!
Item was removed:
- ----- Method: CompiledMethodTest>>testCopyWithTrailerBytes (in category 'tests - copying') -----
- testCopyWithTrailerBytes
- <pragma: #pragma>
- | method copy |
- method := thisContext method.
- self assert: method pragmas notEmpty.
- copy := method copyWithTempNames: #('m' 'c').
- self assert: (method equivalentTo: copy).
- self deny: method = copy. "copyWithTempNames: changes the length of a method so these are no longer equal."
- self assert: method symbolic = copy symbolic. "but their bytecode should be the same"
- self assert: method ~~ copy.
- method pragmas do:
- [:p|
- self assert: p method == method].
- copy pragmas do:
- [:p|
- self assert: p method == copy]!
Item was removed:
- ----- Method: CompiledMethodTest>>testDecompile (in category 'tests - decompiling') -----
- testDecompile
- "self debug: #testDecompileTree"
- | method cls stream |
-
- Smalltalk removeClassNamed: #TUTU.
-
- cls := Object subclass: #TUTU
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'.
- cls compileSilently: 'foo ^ 10'.
- method := cls >> #foo.
- Smalltalk removeClassNamed: #TUTU.
- stream := String new writeStream.
- method decompile printOn: stream.
- self assert: stream contents = 'foo
- ^ 10'
-
-
- !
Item was removed:
- ----- Method: CompiledMethodTest>>testHasClosure (in category 'tests - closures') -----
- testHasClosure
- self
- assert: (self class >> #withClosure) containsBlockClosures;
- assert: (self class >> #withClosureNoNLR) containsBlockClosures;
- assert: (self class >> #withoutClosure) containsBlockClosures not!
Item was removed:
- ----- Method: CompiledMethodTest>>testIsInstalled (in category 'tests - testing') -----
- testIsInstalled
- | method cls |
-
- method := (self class)>>#returnTrue.
- self assert: method isInstalled.
-
- "now make an orphaned method by just deleting the class."
-
- Smalltalk removeClassNamed: #TUTU.
-
- cls := Object subclass: #TUTU
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'.
- cls compile: 'foo ^ 10'.
- method := cls >> #foo.
- Smalltalk removeClassNamed: #TUTU.
-
- self deny: method isInstalled. !
Item was removed:
- ----- Method: CompiledMethodTest>>testIsQuick (in category 'tests - testing') -----
- testIsQuick
- | method |
-
- method := self class compiledMethodAt: #returnTrue.
- self assert: (method isQuick).
-
- method := self class compiledMethodAt: #returnPlusOne:.
- self deny: (method isQuick).
-
- !
Item was removed:
- ----- Method: CompiledMethodTest>>testMethodClass (in category 'tests - accessing') -----
- testMethodClass
- | method cls binding |
- method := self class >> #returnTrue.
- self assert: #returnTrue equals: method selector.
- "now make an orphaned method by just deleting the class.
- old: #unknown
- pre-environment semantics: return Obsolete class
- environment semantics: return binding's value, which will be nil"
- (Smalltalk classNamed: #TUTU) ifNotNil:
- [Smalltalk removeClassNamed: #TUTU].
- cls := Object
- subclass: #TUTU
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'.
- cls compile: 'foo ^ 10'.
- method := cls >> #foo.
- binding := cls binding.
- self assert: binding value equals: (Smalltalk classNamed: #TUTU) description: 'binding before class removal'.
- self assert: (Smalltalk classNamed: #TUTU) equals: method methodClass description: 'methodClass before class removal'.
- Smalltalk removeClassNamed: #TUTU.
- self assert: binding value equals: method methodClass description: 'methodClass after class removal'.!
Item was removed:
- ----- Method: CompiledMethodTest>>testNew (in category 'tests') -----
- testNew
-
- self shouldRaiseError: [self classToBeTested new].!
Item was removed:
- ----- Method: CompiledMethodTest>>testPerformCanExecutelongMethodWithTemps (in category 'tests - performing') -----
- testPerformCanExecutelongMethodWithTemps
- "self debug: #testPerformCanExecutelongMethodWithTemps"
- "the perform: primitive reuses the context of the method calling it. The primitive adds performed selector arguments to the context variables list. So this means that you can execute some methods but not performed them if the calling methods defined too many temps "
-
- | temp1 temp2 temp3 |
- temp1 := 33.
- temp2 := 666.
- temp3 := 42.
- self assert: (self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) = 1.
- self assert: (self class>>#testPerformCanExecutelongMethodWithTemps) frameSize = CompiledMethod smallFrameSize.
- self assert: (self class>>#a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15:) frameSize = CompiledMethod fullFrameSize.!
Item was removed:
- ----- Method: CompiledMethodTest>>testPerformInSuperclassCanExecutelongMethodWithTemps (in category 'tests - performing') -----
- testPerformInSuperclassCanExecutelongMethodWithTemps
- "This test documents a limitation of the standard Squeak VM that has
- been addressed in the Cog family of VMs. The test will pass on Cog, but
- is expected to fail on an interpreter VM. The test fails on an interpreter VM
- because the perform: primitive reuses the context of the method calling it.
- The primitive adds performed selector arguments to the context variables
- list. So this means that you can execute some methods but not performed
- them if the calling methods defined too many temps."
-
- "self debug: #testPerformInSuperclassCanExecutelongMethodWithTemps"
-
- | temp1 temp2 temp3 |
- temp1 := 33.
- temp2 := 666.
- temp3 := 42.
- self assert: (self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) inSuperclass: self class) = 1!
Item was removed:
- ----- Method: CompiledMethodTest>>testSearchForClass (in category 'tests - accessing') -----
- testSearchForClass
- | method cls |
-
- method := (self class)>>#returnTrue.
- self assert: (method searchForClass = self class).
-
- "now make an orphaned method. we want to get nil as the class"
-
- Smalltalk removeClassNamed: #TUTU.
-
- cls := Object subclass: #TUTU
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'.
- cls compile: 'foo ^ 10'.
- method := cls >> #foo.
- Smalltalk removeClassNamed: #TUTU.
-
- self assert: method searchForClass = nil.
- !
Item was removed:
- ----- Method: CompiledMethodTest>>testSearchForSelector (in category 'tests - accessing') -----
- testSearchForSelector
- | method cls |
-
- method := (self class)>>#returnTrue.
- self assert: (method searchForSelector = #returnTrue).
-
- "now make an orphaned method. we want to get nil as the selector"
-
- Smalltalk removeClassNamed: #TUTU.
-
- cls := Object subclass: #TUTU
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'.
- cls compile: 'foo ^ 10'.
- method := cls >> #foo.
- Smalltalk removeClassNamed: #TUTU.
-
- self assert: method searchForSelector = nil.
- !
Item was removed:
- ----- Method: CompiledMethodTest>>testSelector (in category 'tests - accessing') -----
- testSelector
- | method cls |
-
- method := (self class)>>#returnTrue.
- self assert: (method selector = #returnTrue).
-
- "now make an orphaned method. new semantics: return corrent name"
-
- Smalltalk removeClassNamed: #TUTU.
-
- cls := Object subclass: #TUTU
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'.
- cls compile: 'foo ^ 10'.
- method := cls >> #foo.
- Smalltalk removeClassNamed: #TUTU.
-
- self assert: method selector = #foo.
- !
Item was removed:
- ----- Method: CompiledMethodTest>>testValueWithReceiverArguments (in category 'tests - evaluating') -----
- testValueWithReceiverArguments
-
- | method value |
-
- method := self class compiledMethodAt: #returnTrue.
-
- value := method valueWithReceiver: nil arguments: #().
- self assert: (value = true).
-
- method := self class compiledMethodAt: #returnPlusOne:.
- value := method valueWithReceiver: nil arguments: #(1).
- self assert: (value = 2). !
Item was removed:
- ----- Method: CompiledMethodTest>>withClosure (in category 'examples') -----
- withClosure
- [ ^ 23 ] value!
Item was removed:
- ----- Method: CompiledMethodTest>>withClosureNoNLR (in category 'examples') -----
- withClosureNoNLR
- ^ [ 23 ] value!
Item was removed:
- ----- Method: CompiledMethodTest>>withoutClosure (in category 'examples') -----
- withoutClosure
- ^ 23 + 42!
Item was removed:
- TestCase subclass: #CompiledMethodTrailerTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testEmbeddingSourceCode (in category 'tests') -----
- testEmbeddingSourceCode
-
- | trailer newTrailer code |
-
- trailer := CompiledMethodTrailer new.
-
- code := 'foo'.
- trailer sourceCode: code.
- newTrailer := trailer testEncoding.
-
- self assert: (trailer kind == #EmbeddedSourceQCompress ).
- self assert: (newTrailer sourceCode = code).
-
- "the last bytecode index must be at 0"
- self assert: (newTrailer endPC = 0).
-
- code := 'testEmbeddingSourceCode
-
- | trailer newTrailer code |
-
- trailer := CompiledMethodTrailer new.
-
- trailer sourceCode: code.
- newTrailer := trailer testEncoding.
-
- self assert: (newTrailer sourceCode = code).'.
-
- trailer sourceCode: code.
- self assert: (trailer kind == #EmbeddedSourceZip ).
- newTrailer := trailer testEncoding.
-
- self assert: (newTrailer sourceCode = code).
- "the last bytecode index must be at 0"
- self assert: (newTrailer endPC = 0).
- !
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testEmbeddingTempNames (in category 'tests') -----
- testEmbeddingTempNames
-
- | trailer newTrailer code |
-
- trailer := CompiledMethodTrailer new.
-
- code := 'foo'.
- trailer tempNames: code.
- newTrailer := trailer testEncoding.
-
- self assert: (trailer kind == #TempsNamesQCompress ).
- self assert: (newTrailer tempNames = code).
- "the last bytecode index must be at 0"
- self assert: (newTrailer endPC = 0).
-
-
- code := 'testEmbeddingSourceCode
-
- | trailer newTrailer code |
-
- trailer := CompiledMethodTrailer new.
-
- trailer sourceCode: code.
- newTrailer := trailer testEncoding.
-
- self assert: (newTrailer sourceCode = code).'.
-
- trailer tempNames: code.
- self assert: (trailer kind == #TempsNamesZip ).
- newTrailer := trailer testEncoding.
-
- self assert: (newTrailer tempNames = code).
- "the last bytecode index must be at 0"
- self assert: (newTrailer endPC = 0).
- !
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testEncodingNoTrailer (in category 'tests') -----
- testEncodingNoTrailer
-
- | trailer |
-
- trailer := CompiledMethodTrailer new.
-
- "by default it should be a no-trailer"
- self assert: (trailer kind == #NoTrailer ).
- self assert: (trailer size = 1).
-
- trailer := trailer testEncoding.
-
- self assert: (trailer kind == #NoTrailer ).
- self assert: (trailer size = 1).
- "the last bytecode index must be at 0"
- self assert: (trailer endPC = 0).
- !
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testEncodingSourcePointer (in category 'tests') -----
- testEncodingSourcePointer
-
- | trailer |
-
- trailer := CompiledMethodTrailer new.
-
- CompiledMethod allInstancesDo: [:method | | ptr |
- trailer method: method.
- self assert: ( (ptr := method sourcePointer) == trailer sourcePointer).
- "the last bytecode index must be at 0"
- ptr ~= 0 ifTrue: [
- self assert: (method endPC = trailer endPC) ].
- ].!
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testEncodingVarLengthSourcePointer (in category 'tests') -----
- testEncodingVarLengthSourcePointer
-
- | trailer newTrailer |
-
- trailer := CompiledMethodTrailer new.
-
- trailer sourcePointer: 1.
- newTrailer := trailer testEncoding.
-
- self assert: (newTrailer sourcePointer = 1).
-
- trailer sourcePointer: 16r100000000000000.
- newTrailer := trailer testEncoding.
- self assert: (newTrailer sourcePointer = 16r100000000000000).
- "the last bytecode index must be at 0"
- self assert: (newTrailer endPC = 0).
- !
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testEncodingZeroSourcePointer (in category 'tests') -----
- testEncodingZeroSourcePointer
-
- | trailer |
-
- trailer := CompiledMethodTrailer new.
-
- self assert:
- (trailer sourcePointer: 0) testEncoding sourcePointer = 0
- !
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testSourceByIdentifierEncoding (in category 'tests') -----
- testSourceByIdentifierEncoding
-
- | trailer id |
-
- trailer := CompiledMethodTrailer new.
-
- id := UUID new asString.
- trailer sourceIdentifier: id.
-
- self assert: (trailer kind == #SourceByStringIdentifier ).
-
- trailer := trailer testEncoding.
-
- self assert: (trailer kind == #SourceByStringIdentifier ).
- self assert: (trailer sourceIdentifier = id).
- "the last bytecode index must be at 0"
- self assert: (trailer endPC = 0).
- !
Item was removed:
- ----- Method: CompiledMethodTrailerTest>>testSourceBySelectorEncoding (in category 'tests') -----
- testSourceBySelectorEncoding
-
- | trailer |
-
- trailer := CompiledMethodTrailer new.
-
- trailer setSourceBySelector.
-
- self assert: (trailer kind == #SourceBySelector ).
- self assert: (trailer size = 1).
-
- trailer := trailer testEncoding.
-
- self assert: (trailer kind == #SourceBySelector ).
- self assert: (trailer size = 1).
- "the last bytecode index must be at 0"
- self assert: (trailer endPC = 0).
- !
Item was removed:
- TestCase subclass: #ComplexTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: ComplexTest>>testAbs (in category 'tests') -----
- testAbs
- "self run: #testAbs"
- "self debug: #testAbs"
-
- | c |
- c := (6 - 6 i).
- self assert: c abs = 72 sqrt.
- !
Item was removed:
- ----- Method: ComplexTest>>testAdding (in category 'tests') -----
- testAdding
- "self run: #testAdding"
-
- | c |
- c := (5 - 6 i) + (-5 + 8 i). "Complex with Complex"
- self assert: (c = (0 + 2 i)).!
Item was removed:
- ----- Method: ComplexTest>>testArCosh (in category 'tests') -----
- testArCosh
- | c |
- c := (2.5 + 0 i).
- self assert: (c arCosh real closeTo: c real arCosh).
- self assert: (c arCosh imaginary closeTo: 0).
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: (c arCosh cosh real closeTo: c real).
- self assert: (c arCosh cosh imaginary closeTo: c imaginary).
- self deny: c arCosh real negative]]!
Item was removed:
- ----- Method: ComplexTest>>testArSinh (in category 'tests') -----
- testArSinh
- | c |
- c := (2.5 + 0 i).
- self assert: (c arSinh real closeTo: c real arSinh).
- self assert: (c arSinh imaginary closeTo: 0).
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: (c arSinh sinh real closeTo: c real).
- self assert: (c arSinh sinh imaginary closeTo: c imaginary)]]!
Item was removed:
- ----- Method: ComplexTest>>testArTanh (in category 'tests') -----
- testArTanh
- | c |
- c := (0.5 + 0 i).
- self assert: (c arTanh real closeTo: c real arTanh).
- self assert: (c arTanh imaginary closeTo: 0).
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: (c arTanh tanh real closeTo: c real).
- self assert: (c arTanh tanh imaginary closeTo: c imaginary)]]!
Item was removed:
- ----- Method: ComplexTest>>testArcCos (in category 'tests') -----
- testArcCos
- | c |
- c := (0.5 + 0 i).
- self assert: (c arcCos real closeTo: c real arcCos).
- self assert: (c arcCos imaginary closeTo: 0).
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: (c arcCos cos real closeTo: c real).
- self assert: (c arcCos cos imaginary closeTo: c imaginary)]]!
Item was removed:
- ----- Method: ComplexTest>>testArcCosPlusArcSin (in category 'tests') -----
- testArcCosPlusArcSin
- | c |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: ((c arcCos + c arcSin) real closeTo: Float halfPi).
- self assert: ((c arcCos + c arcSin) imaginary closeTo: 0.0)]]!
Item was removed:
- ----- Method: ComplexTest>>testArcSin (in category 'tests') -----
- testArcSin
- | c |
- c := (0.5 + 0 i).
- self assert: (c arcSin real closeTo: c real arcSin).
- self assert: (c arcSin imaginary closeTo: 0).
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: (c arcSin sin real closeTo: c real).
- self assert: (c arcSin sin imaginary closeTo: c imaginary)]]!
Item was removed:
- ----- Method: ComplexTest>>testArcTan (in category 'tests') -----
- testArcTan
- | c |
- c := (0.5 + 0 i).
- self assert: (c arcTan real closeTo: c real arcTan).
- self assert: (c arcTan imaginary closeTo: 0).
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: (c arcTan tan real closeTo: c real).
- self assert: (c arcTan tan imaginary closeTo: c imaginary)]]!
Item was removed:
- ----- Method: ComplexTest>>testArg (in category 'tests') -----
- testArg
- "self run: #testArg"
- "self debug: #testArg"
-
- | c |
- c := (0 + 5 i) .
- self assert: c arg = (Float pi/ 2).
- !
Item was removed:
- ----- Method: ComplexTest>>testBug1 (in category 'tests - bugs') -----
- testBug1
-
- self assert: (0.5 * (2+0i) ln) exp = (0.5 * 2 ln) exp.!
Item was removed:
- ----- Method: ComplexTest>>testComplexCollection (in category 'tests') -----
- testComplexCollection
- "self run: #testComplexCollection"
- "self debug: #testComplexCollection"
-
- | array array2 |
- array := Array with: 1 + 2i with: 3 + 4i with: 5 + 6i.
- array2 := 2 * array.
- array with: array2 do: [:one :two | self assert: (2 * one) = two ] !
Item was removed:
- ----- Method: ComplexTest>>testConjugated (in category 'tests') -----
- testConjugated
-
- | c cc |
- c := (5 - 6 i).
- cc := c conjugated.
- self assert: cc real = c real.
- self assert: cc imaginary = c imaginary negated.!
Item was removed:
- ----- Method: ComplexTest>>testConversion (in category 'tests') -----
- testConversion
- "self run: #testConversion"
- "self debug: #testConversion"
-
- self assert: ((1 + 2i) + 1) = (2 + 2 i).
- self assert: (1 + (1 + 2i)) = (2 + 2 i).
- self assert: ((1 + 2i) + 1.0) = (2.0 + 2 i).
- self assert: (1.0 + (1 + 2i)) = (2.0 + 2 i).
- self assert: ((1 + 2i) + (2/3)) = ((5/3) + 2 i ).
- self assert: ((2/3) + (1 + 2i)) = ((5/3) + 2 i )!
Item was removed:
- ----- Method: ComplexTest>>testCos (in category 'tests') -----
- testCos
- | c c2 |
- c := (2 + 0 i).
- self assert: (c cos real closeTo: c real cos).
- self assert: (c cos imaginary closeTo: 0).
- c := (2 + 3 i).
- c2 := c i exp + c i negated exp / 2.
- self assert: (c cos real closeTo: c2 real).
- self assert: (c cos imaginary closeTo: c2 imaginary).!
Item was removed:
- ----- Method: ComplexTest>>testCos2PlusSin2 (in category 'tests') -----
- testCos2PlusSin2
- | c |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: ((c cos squared + c sin squared) real closeTo: 1).
- self assert: ((c cos squared + c sin squared) imaginary closeTo: 0.0)]]!
Item was removed:
- ----- Method: ComplexTest>>testCosh (in category 'tests') -----
- testCosh
- | c c2 |
- c := (2 + 0 i).
- self assert: (c cosh real closeTo: c real cosh).
- self assert: (c cosh imaginary closeTo: 0).
- c := (2 + 3 i).
- c2 := c exp + c negated exp / 2.
- self assert: (c cosh real closeTo: c2 real).
- self assert: (c cosh imaginary closeTo: c2 imaginary).
- c2 := c i cos.
- self assert: (c cosh real closeTo: c2 real).
- self assert: (c cosh imaginary closeTo: c2 imaginary).!
Item was removed:
- ----- Method: ComplexTest>>testCosh2MinusSinh2 (in category 'tests') -----
- testCosh2MinusSinh2
- | c |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
- #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
- c := real + imag i.
- self assert: ((c cosh squared - c sinh squared) real closeTo: 1).
- self assert: ((c cosh squared - c sinh squared) imaginary closeTo: 0.0)]]!
Item was removed:
- ----- Method: ComplexTest>>testCreation (in category 'tests') -----
- testCreation
- "self run: #testCreation"
-
- | c |
- c := 5 i.
- self assert: (c real = 0).
- self assert: (c imaginary = 5).
-
- c := 6 + 7 i.
- self assert: (c real = 6).
- self assert: ( c imaginary = 7).
-
- c := 5.6 - 8 i.
- self assert: (c real = 5.6).
- self assert: (c imaginary = -8).
-
- c := Complex real: 10 imaginary: 5.
- self assert: (c real = 10).
- self assert: (c imaginary = 5).
-
- c := Complex abs: 5 arg: (Float pi/2).
- self assert: (c real rounded = 0).
- self assert: (c imaginary = 5).
- !
Item was removed:
- ----- Method: ComplexTest>>testDivision1 (in category 'tests') -----
- testDivision1
- "self run: #testDivision1"
- "self debug: #testDivision1"
-
- | c1 c2 quotient |
- c1 := 2.0e252 + 3.0e70 i.
- c2 := c1.
- quotient := c1 / c2.
-
- "This used to fail when / was not protected against floating point overflow in intermediate computations
- but it should now work correctly if divideSecureBy: is correctly used as fallback case"
- self assert: (quotient - 1) isZero
-
- !
Item was removed:
- ----- Method: ComplexTest>>testEquality (in category 'tests') -----
- testEquality
- "self run: #testEquality"
- "self debug: #testEquality"
-
- self assert: 0i = 0.
- self assert: (2 - 5i) = ((1 -4 i) + (1 - 1i)).
- self assert: 0i isZero.
- self deny: (1 + 3 i) = 1.
- self deny: (1 + 3 i) = (1 + 2i).
-
- "Some more stuff"
- self deny: (1 i) = nil.
- self deny: nil = (1 i).
-
- self deny: (1 i) = #(1 2 3).
- self deny: #(1 2 3) = (1 i).
-
- self deny: (1 i) = 0.
- self deny: 0 = (1 i).
-
- self assert: (1 + 0 i) = 1.
- self assert: 1 = (1+ 0 i).
-
- self assert: (1 + 0 i) = 1.0.
- self assert: 1.0 = (1+ 0 i).
-
- self assert: (1/2 + 0 i) = (1/2).
- self assert: (1/2) = (1/2+ 0 i).!
Item was removed:
- ----- Method: ComplexTest>>testLn (in category 'tests') -----
- testLn
- self assert: (Float e + 0 i) ln = Float e ln "See Bug 1815 on Mantis"!
Item was removed:
- ----- Method: ComplexTest>>testMultiplyByI (in category 'tests') -----
- testMultiplyByI
-
- | c |
- c := (5 - 6 i).
- self assert: (c * 1i = c i)!
Item was removed:
- ----- Method: ComplexTest>>testMultiplyDoesNotOverflow (in category 'tests') -----
- testMultiplyDoesNotOverflow
-
- | c1 c2 product smallProduct scale |
- c1 := (1 + 1 i) sqrt * Float fmax sqrt.
- product := c1 squared.
- self assert: product real isFinite.
- self assert: product imaginary isFinite.
- self assert: (product real - Float fmax) / Float fmax ulp < 3.
- self assert: (product imaginary - Float fmax) / Float fmax ulp < 3.
-
- "a more tricky case"
- c1 := 1.0 + 0.25 i.
- c2 := 1.125+ 0.5 i.
- smallProduct := c1 * c2.
- "check that we will not overflow in precondition"
- self assert: smallProduct real abs <= 1.
- self assert: smallProduct imaginary abs <= 1.
- "now retry with a large scale"
- scale := Float fmax.
- product := c1 * scale * c2.
- self assert: product real isFinite.
- self assert: product imaginary isFinite.
- self assert: (scale * smallProduct real - product real) / (scale * smallProduct real) ulp < 3.
- self assert: (scale * smallProduct imaginary - product imaginary) / (scale * smallProduct imaginary) ulp < 3.!
Item was removed:
- ----- Method: ComplexTest>>testNegated (in category 'tests') -----
- testNegated
- "self run: #testNegated"
- "self debug: #testNegated"
-
- | c |
- c := (2 + 5 i) .
- self assert: c negated = (-2 - 5i).
- !
Item was removed:
- ----- Method: ComplexTest>>testRaisedTo (in category 'tests') -----
- testRaisedTo
-
- | c c3 |
- c := (5 - 6 i).
- c3 := (c raisedTo: 0.2) raisedTo: 5.
- self assert: (c3 real closeTo: c real).
- self assert: (c3 imaginary closeTo: c imaginary).!
Item was removed:
- ----- Method: ComplexTest>>testRaisedToInteger (in category 'tests') -----
- testRaisedToInteger
-
- | c c3 |
- c := (5 - 6 i).
- c3 := (c * c * c).
- self assert: (c3 = (c raisedToInteger: 3)).
- self assert: (c3 reciprocal = (c raisedToInteger: -3)).!
Item was removed:
- ----- Method: ComplexTest>>testReciprocal (in category 'tests') -----
- testReciprocal
- "self run: #testReciprocal"
- "self debug: #testReciprocal"
-
- | c |
- c := (2 + 5 i).
- self assert: c reciprocal = ((2/29) - (5/29)i).
- !
Item was removed:
- ----- Method: ComplexTest>>testReciprocalDoesNotOverflow (in category 'tests') -----
- testReciprocalDoesNotOverflow
- "Note: intermediate overflow might cause the answer to be zero in careless implementation"
-
- | c scale cScaled cScaledInv expected |
- c := (1 + 1i).
- scale := Float fmax.
- cScaled := c * scale.
- cScaledInv := cScaled reciprocal.
- expected := c reciprocal real / scale + (c reciprocal imaginary / scale) i.
- self assert: (expected real- cScaledInv real) abs / expected real ulp < 3.
- self assert: (expected imaginary - cScaledInv imaginary) abs / expected imaginary ulp < 3.!
Item was removed:
- ----- Method: ComplexTest>>testReciprocalError (in category 'tests') -----
- testReciprocalError
- "self run: #testReciprocalError"
- "self debug: #testReciprocalError"
-
- | c |
- c := (0 i).
- self should: [c reciprocal] raise: ZeroDivide
- !
Item was removed:
- ----- Method: ComplexTest>>testSecureDivision1 (in category 'tests') -----
- testSecureDivision1
- "self run: #testSecureDivision1"
- "self debug: #testSecureDivision1"
-
- | c1 c2 quotient |
- c1 := 2.0e252 + 3.0e70 i.
- c2 := c1.
- quotient := c1 divideSecureBy: c2.
- self assert: (quotient - 1) isZero.
- !
Item was removed:
- ----- Method: ComplexTest>>testSecureDivision2 (in category 'tests') -----
- testSecureDivision2
- "self run: #testSecureDivision2"
- "self debug: #testSecureDivision2"
-
- | c1 c2 quotient |
- c1 := 2.0e252 + 3.0e70 i.
- c2 := c1.
- quotient := c1 divideFastAndSecureBy: c2.
- self assert: (quotient - 1) isZero.
- !
Item was removed:
- ----- Method: ComplexTest>>testSecureDivisionDoesNotOverflow (in category 'tests') -----
- testSecureDivisionDoesNotOverflow
-
- | c1 c2 scale |
- "Note: this test used to fail with legacy version of divideSecureBy:"
- c1 := (2 + 1i).
- c2 := (1 + 1i).
- scale := Float fmax.
- self testSecureDivisionOf: c1 by: c2 scaledBy: scale.
- "And this one fails with incomplete correction of above method"
- c1 := (1/2 + 1i) / (5 << 48).
- c2 := (1 + 1i).
- scale := Float fminDenormalized.
- self testSecureDivisionOf: c1 by: c2 scaledBy: scale!
Item was removed:
- ----- Method: ComplexTest>>testSecureDivisionOf:by:scaledBy: (in category 'tests') -----
- testSecureDivisionOf: c1 by: c2 scaledBy: scale
- "Note: this test used to fail with legacy version of divideSecureBy:"
-
- | quo expected |
- quo := c1 / c2.
- expected := quo real / scale + (quo imaginary / scale) i.
- "check in precondition that the scaled division c1/(c2*scale) would not oevrflow"
- self assert: expected real isFinite.
- self assert: expected imaginary isFinite.
- "now retry with scaling"
- quo := c1 divideSecureBy: (c2 * scale).
- self assert: quo real isFinite.
- self assert: quo imaginary isFinite.
- self assert: (expected real - quo real) abs / (expected real ulp) < 3.
- self assert: (expected imaginary - quo imaginary) abs / (expected imaginary ulp) < 3.!
Item was removed:
- ----- Method: ComplexTest>>testSin (in category 'tests') -----
- testSin
- | c c2 |
- c := (2 + 0 i).
- self assert: (c sin real closeTo: c real sin).
- self assert: (c sin imaginary closeTo: 0).
- c := 2 + 3 i.
- c2 := c i exp - c i negated exp / 2 i.
- self assert: (c sin real closeTo: c2 real).
- self assert: (c sin imaginary closeTo: c2 imaginary).!
Item was removed:
- ----- Method: ComplexTest>>testSinh (in category 'tests') -----
- testSinh
- | c c2 |
- c := (2 + 0 i).
- self assert: (c sinh real closeTo: c real sinh).
- self assert: (c sinh imaginary closeTo: 0).
- c := 2 + 3 i.
- c := c cosh squared - c sinh squared.
- self assert: (c real closeTo: 1).
- self assert: (c imaginary closeTo: 0).
- c2 := c exp - c negated exp / 2.
- self assert: (c sinh real closeTo: c2 real).
- self assert: (c sinh imaginary closeTo: c2 imaginary).
- c2 := c i sin i negated.
- self assert: (c sinh real closeTo: c2 real).
- self assert: (c sinh imaginary closeTo: c2 imaginary).!
Item was removed:
- ----- Method: ComplexTest>>testSqrt (in category 'tests') -----
- testSqrt
- -3 to: 3 do: [:re | -2 to: 2 do: [:im |
- | c s t |
- c := re asFloat + im asFloat i.
- s := c sqrt.
- t := s squared.
- self assert: (t real - c real) abs / 4 < c abs asFloat ulp.
- self assert: (t imaginary - c imaginary) abs / 4 < c abs asFloat ulp.
- self assert: s imaginary signBit = c imaginary signBit]]!
Item was removed:
- ----- Method: ComplexTest>>testSquared (in category 'tests') -----
- testSquared
- "self run: #testSquared"
- "self debug: #testSquared"
-
- | c c2 |
- c := (6 - 6 i).
- c2 := (c squared).
- self assert: c2 imaginary = -72.
- self assert: c2 real = 0.!
Item was removed:
- ----- Method: ComplexTest>>testTan (in category 'tests') -----
- testTan
- | c c2 |
- c := (2 + 0 i).
- self assert: (c tan real closeTo: c real tan).
- self assert: (c tan imaginary closeTo: 0).
- c := 2 + 3 i.
- c2 := c sin / c cos.
- self assert: (c2 real closeTo: c tan real).
- self assert: (c2 imaginary closeTo: c tan imaginary).!
Item was removed:
- ----- Method: ComplexTest>>testTanh (in category 'tests') -----
- testTanh
- | c c2 |
- c := (2 + 0 i).
- self assert: (c tanh real closeTo: c real tanh).
- self assert: (c tanh imaginary closeTo: 0).
- c := 2 + 3 i.
- c2 := c sinh / c cosh.
- self assert: (c2 real closeTo: c tanh real).
- self assert: (c2 imaginary closeTo: c tanh imaginary).!
Item was removed:
- TestCase subclass: #ContextTest
- instanceVariableNames: 'aCompiledMethod aReceiver aSender aContext'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !ContextTest commentStamp: 'ct 1/27/2020 13:03' prior: 0!
- I am an SUnit Test of Context. See also BlockClosureTest.
- See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. To see how blocks are implemented in this version of Squeak see http://www.mirandabanda.org/cogblog/2008/06/07/closures-part-i/ and http://www.mirandabanda.org/cogblog/2008/07/22/closures-part-ii-the-bytecod…. (The Squeak V3 byte codes are not quite the same as Smalltalk-80, and the SistaV1 byetcodes are quite different.)
- My fixtures are:
- aReceiver - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
- aSender - just some arbitrary object, thisContext
- aCompiledMethod - just some arbitrary method, "Rectangle rightCenter".
- aContext - just some arbitray context ...
-
- !
Item was removed:
- ----- Method: ContextTest>>privRestartTest (in category 'private') -----
- privRestartTest
- "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out"
- |a firstTimeThrough |
- firstTimeThrough := true.
- a := 10.
-
- self assert: 30 equals: [|b|
- self assert: 10 = a .
- self assert: nil == b.
- b := a + 20.
- firstTimeThrough ifTrue: [
- firstTimeThrough := false.
- thisContext restart.].
- b] value
- !
Item was removed:
- ----- Method: ContextTest>>setUp (in category 'running') -----
- setUp
- super setUp.
- aCompiledMethod := Rectangle methodDict at: #rightCenter.
- aReceiver := 100@100 corner: 200@200.
- aSender := thisContext.
- aContext := Context sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). !
Item was removed:
- ----- Method: ContextTest>>testActivateReturnValue (in category 'tests') -----
- testActivateReturnValue
- self assert: (aSender activateReturn: aContext value: #()) isContext.
- self assert: ((aSender activateReturn: aContext value: #()) receiver = aContext).!
Item was removed:
- ----- Method: ContextTest>>testCopyStack (in category 'tests') -----
- testCopyStack
- self assert: aContext copyStack printString = aContext printString.!
Item was removed:
- ----- Method: ContextTest>>testCopyTo (in category 'tests') -----
- testCopyTo
-
- | context depth targetSender |
- context := thisContext.
- depth := 1.
- targetSender := context.
- [ (targetSender := targetSender sender) isNil ] whileFalse: [
- | original copy |
- original := context.
- copy := context copyTo: targetSender.
- 1 to: depth do: [ :index |
- index = 1 ifFalse: [
- "Since we're copying thisContext, the pc and stackPtr may be different for the current frame."
- self
- assert: original pc equals: copy pc;
- assert: original stackPtr equals: copy stackPtr ].
- self
- deny: original == copy;
- assert: original method equals: copy method;
- assert: original closure equals: copy closure;
- assert: original receiver equals: copy receiver.
- original := original sender.
- copy := copy sender ].
- self
- assert: copy isNil;
- assert: original == targetSender.
- depth := depth + 1 ]!
Item was removed:
- ----- Method: ContextTest>>testFindContextSuchThat (in category 'tests') -----
- testFindContextSuchThat
- self assert: (aContext findContextSuchThat: [:each| true]) printString = aContext printString.
- self assert: (aContext hasContext: aContext). !
Item was removed:
- ----- Method: ContextTest>>testMessageNotUnderstood (in category 'tests') -----
- testMessageNotUnderstood
-
- "A simulation error (recursive message not understood) occurs that cannot be handled by the simulated code"
- self
- should:
- [Context runSimulated:
- [[TestEmptyClass new foo]
- on: Error do: [:ex | ex]]]
- raise: Error.
-
- "The simulator sends #doesNotUnderstand: to the receiver even if the lookup class has no superclass."
- self assert:
- [Context runSimulated:
- [self
- executeShould: [ProtoObject new foo]
- inScopeOf: MessageNotUnderstood]].
- self assert:
- [Context runSimulated:
- [self
- executeShould: [Compiler evaluate: 'super foo' for: Object new]
- inScopeOf: MessageNotUnderstood]].!
Item was removed:
- ----- Method: ContextTest>>testMethodContext (in category 'tests') -----
- testMethodContext
- self assert: aContext home notNil.
- self assert: aContext receiver notNil.
- self assert: aContext method isCompiledMethod.!
Item was removed:
- ----- Method: ContextTest>>testMethodIsBottomContext (in category 'tests') -----
- testMethodIsBottomContext
- self assert: aContext bottomContext = aSender.
- self assert: aContext secondFromBottom = aContext.!
Item was removed:
- ----- Method: ContextTest>>testObjectsAsMethod (in category 'tests') -----
- testObjectsAsMethod
-
- | result error |
- SystemChangeNotifier uniqueInstance doSilently: [
- self class addSelector: #foo withMethod: (TestObjectForMethod new xxxMethod: thisContext homeMethod)].
-
- result := Context runSimulated: [[self foo] on: Error do: [:ex | error := ex]].
- error ifNotNil: [self fail: error].
-
- SystemChangeNotifier uniqueInstance doSilently: [
- [self assert: self foo equals: result]
- ensure: [self class removeSelector: #foo]].!
Item was removed:
- ----- Method: ContextTest>>testPrimitive100 (in category 'tests') -----
- testPrimitive100
-
- {
- {#isNil. {}. Object}. "valid 0-arg message"
- {#=. {true}. UndefinedObject}. "valid unary message"
- {#ifNil:ifNotNil:. {[2]. [:x | x]}. Object}. "valid binary message"
- {{}. #=. {true}. SequenceableCollection}. "mirror primitive"
- {#isNil}. "missing arguments"
- {#isNil. 'not an array'}. "invalid arguments"
- {#isNil. {}}. "missing lookupClass"
- {#isNil. {'excess arg'}. Object}. "too many arguments"
- {#=. {}. UndefinedObject}. "missing argument"
- {#isNil. {}. Boolean}. "lookupClass not in inheritance chain"
- } do: [:args |
- self
- assert: (nil tryPrimitive: 100 withArgs: args)
- equals: (Context runSimulated: [nil tryPrimitive: 100 withArgs: args])].!
Item was removed:
- ----- Method: ContextTest>>testPrimitive83 (in category 'tests') -----
- testPrimitive83
-
- {
- {#isNil}. "valid 0-arg message"
- {#=. true}. "valid unary message"
- {#ifNil:ifNotNil:. [2]. [:x | x]}. "valid binary message"
- {#isNil. 'excess arg'}. "too many arguments"
- {#=}. "missing argument"
- } do: [:args |
- self
- assert: (nil tryPrimitive: 83 withArgs: args)
- equals: (Context runSimulated: [nil tryPrimitive: 83 withArgs: args])].!
Item was removed:
- ----- Method: ContextTest>>testPrimitive84 (in category 'tests') -----
- testPrimitive84
-
- {
- {#isNil. {}}. "valid 0-arg message"
- {#=. {true}}. "valid unary message"
- {#ifNil:ifNotNil:. {[2]. [:x | x]}}. "valid binary message"
- {#isNil}. "missing arguments"
- {#isNil. 'not an array'}. "invalid arguments"
- {#isNil. {'excess arg'}}. "too many arguments"
- {#=. {}}. "missing argument"
- } do: [:args |
- self
- assert: (nil tryPrimitive: 84 withArgs: args)
- equals: (Context runSimulated: [nil tryPrimitive: 84 withArgs: args])].!
Item was removed:
- ----- Method: ContextTest>>testRestart (in category 'tests') -----
- testRestart
- self should: [self privRestartTest] notTakeMoreThan: 0.1 second!
Item was removed:
- ----- Method: ContextTest>>testReturn (in category 'tests') -----
- testReturn
- "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
- aContext := Context sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #().
- self assert: (aContext return: 5) = 5!
Item was removed:
- ----- Method: ContextTest>>testSetUp (in category 'tests') -----
- testSetUp
- "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
- self assert: aContext isContext.
- self deny: aContext isExecutingBlock.
- self deny: aContext isClosure.
- self deny: aContext isDead.
- "self assert: aMethodContext home = aReceiver."
- "self assert: aMethodContext blockHome = aReceiver."
- self assert: aContext receiver = aReceiver.
- self assert: aContext method isCompiledMethod.
- self assert: aContext method = aCompiledMethod.
- self assert: aContext methodNode selector = #rightCenter.
- self assert: (aContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
- self assert: aContext client printString = 'ContextTest>>#testSetUp'.
- !
Item was removed:
- TestCase subclass: #DelayTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
Item was removed:
- ----- Method: DelayTest>>testBounds (in category 'tests - limits') -----
- testBounds
- "self run: #testBounds"
-
- self should: [Delay forMilliseconds: -1] raise: Error.
-
- "We expect these to succeed."
- Delay forMilliseconds: SmallInteger maxVal + 1.
- (Delay forMilliseconds: Float pi) wait. "Wait 3ms"
- !
Item was removed:
- ----- Method: DelayTest>>testMultiProcessWaitOnSameDelay (in category 'tests - limits') -----
- testMultiProcessWaitOnSameDelay
- "Ensure that waiting on the same delay from multiple processes raises an error"
- | delay p1 p2 wasRun |
- delay := Delay forSeconds: 1.
- wasRun := false.
- p1 := [delay wait] forkAt: Processor activePriority+1.
- p2 := [
- self should:[delay wait] raise: Error.
- wasRun := true.
- ] forkAt: Processor activePriority+1.
- p1 terminate.
- p2 terminate.
- self assert: wasRun.
-
- !
Item was removed:
- ----- Method: DelayTest>>testMultiSchedule (in category 'tests - limits') -----
- testMultiSchedule
- "Ensure that scheduling the same delay twice raises an error"
- | delay |
- delay := Delay forSeconds: 1.
- delay schedule.
- self should:[delay schedule] raise: Error.
- !
Item was removed:
- ClassTestCase subclass: #DependentsArrayTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
-
- !DependentsArrayTest commentStamp: '<historical>' prior: 0!
- This class is to test the special implementation of DependentsArray.
-
- DependentsArray size will not count nil elements (the ones reclaimed by garbage collector).
- Consequently, any message implemented with a construction like (1 to: self size do: [:i | ]) and sent to the dependents of any object might not behave as supposed to.!
Item was removed:
- ----- Method: DependentsArrayTest>>testAddingTwice (in category 'tests') -----
- testAddingTwice
-
- | test dep2 deps |
- test := Object new.
- dep2 := String with: $z with: $u with: $t.
-
- test addDependent: String new.
- test addDependent: dep2.
-
- Smalltalk garbageCollect. "this will make first dependent vanish, replaced by nil"
-
- test addDependent: dep2.
-
- deps := test dependents.
- self should: [deps asIdentitySet size = deps size] description: 'No object should be added twice in dependents'!
Item was removed:
- ----- Method: DependentsArrayTest>>testCanDiscardEdits (in category 'tests') -----
- testCanDiscardEdits
- "self debug: #testCanDiscardEdits."
-
- | anObject aView |
- anObject := Object new.
- "A Project may always discard edits."
- aView := Project new.
- anObject addDependent: Object new. "this entry should be garbage collected"
- anObject addDependent: aView.
-
- Smalltalk garbageCollect. "force garbage collection"
-
- self
- should: [anObject dependents size = 1]
- description: 'first dependent of anObject should have been collected, second should not'.
-
- self
- shouldnt: [anObject canDiscardEdits]
- description: 'anObject cannot discard edits because aView is a dependent of anObject and aView has unaccepted edits'.!
Item was removed:
- ----- Method: DependentsArrayTest>>testSize (in category 'tests') -----
- testSize
-
- self
- assert: (DependentsArray with: nil) size = 0;
- assert: (DependentsArray with: nil with: 1 with: nil) size = 1;
- assert: (DependentsArray with: 1 with: 3) size = 2;
- assert: (DependentsArray with: nil with: nil with: nil) size = 0!
Item was removed:
- ClassTestCase subclass: #ExtendedNumberParserTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testFractionPartWithoutIntegerPart (in category 'tests') -----
- testFractionPartWithoutIntegerPart
- "The integer part before the decimal is optional"
-
- self assert: (ExtendedNumberParser parse: '.5') = (1/2).
- self assert: (ExtendedNumberParser parse: '.5') isFloat.
-
- self assert: (ExtendedNumberParser parse: '.3e2') = 30.
- self assert: (ExtendedNumberParser parse: '.3e2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '-.4e2') = -40.
- self assert: (ExtendedNumberParser parse: '-.4e2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '+.5e2') = 50.
- self assert: (ExtendedNumberParser parse: '+.5e2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '+.6e+2') = 60.
- self assert: (ExtendedNumberParser parse: '+.6e+2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '-.7e+2') = -70.
- self assert: (ExtendedNumberParser parse: '-.7e+2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '+2r.1e-2') = (1/8).
- self assert: (ExtendedNumberParser parse: '+2r.1e-2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '-4r.1e-2') = (-1/64).
- self assert: (ExtendedNumberParser parse: '-4r.1e-2') isFloat.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testIntegerPartWithoutFraction (in category 'tests') -----
- testIntegerPartWithoutFraction
- "The fraction part after the decimal is optional"
-
- self assert: (ExtendedNumberParser parse: '1.') = 1.
- self assert: (ExtendedNumberParser parse: '1.') isFloat.
-
- self assert: (ExtendedNumberParser parse: '3.e2') = 300.
- self assert: (ExtendedNumberParser parse: '3.e2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '-4.e2') = -400.
- self assert: (ExtendedNumberParser parse: '-4.e2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '+5.e2') = 500.
- self assert: (ExtendedNumberParser parse: '+5.e2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '+6.e+2') = 600.
- self assert: (ExtendedNumberParser parse: '+6.e+2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '-7.e+2') = -700.
- self assert: (ExtendedNumberParser parse: '-7.e+2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '+2r1.e-2') = (1/4).
- self assert: (ExtendedNumberParser parse: '+2r1.e-2') isFloat.
-
- self assert: (ExtendedNumberParser parse: '-4r1.e-2') = (-1/16).
- self assert: (ExtendedNumberParser parse: '-4r1.e-2') isFloat.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testInvalidExponent (in category 'tests') -----
- testInvalidExponent
- "The leading number is returned, the invalid part is ignored"
-
- self assert: (ExtendedNumberParser parse: '1e') = 1.
- self assert: (ExtendedNumberParser parse: '1eZ') = 1.
- self assert: (ExtendedNumberParser parse: '+1eW') = 1.
- self assert: (ExtendedNumberParser parse: '-1eX') = -1.
-
- self assert: (ExtendedNumberParser parse: '2e-') = 2.
- self assert: (ExtendedNumberParser parse: '2e--1') = 2.
- self assert: (ExtendedNumberParser parse: '2e-+1') = 2.
- self assert: (ExtendedNumberParser parse: '2e-Z') = 2.
- self assert: (ExtendedNumberParser parse: '+2e-W') = 2.
- self assert: (ExtendedNumberParser parse: '-2e-X') = -2.
-
- self assert: (ExtendedNumberParser parse: '3e+') = 3.
- self assert: (ExtendedNumberParser parse: '3e+-') = 3.
- self assert: (ExtendedNumberParser parse: '3e+-1') = 3.
- self assert: (ExtendedNumberParser parse: '+3e+W') = 3.
- self assert: (ExtendedNumberParser parse: '-3e+Z') = -3.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testInvalidRadix (in category 'tests') -----
- testInvalidRadix
- "The leading number is returned, the invalid part is ignored"
-
- self assert: (ExtendedNumberParser parse: '1r') = 1.
- self assert: (ExtendedNumberParser parse: '+1r') = 1.
- self assert: (ExtendedNumberParser parse: '-1r') = -1.
- self assert: (ExtendedNumberParser parse: '-1r+') = -1.
- self assert: (ExtendedNumberParser parse: '-1r-') = -1.
-
- self assert: (ExtendedNumberParser parse: '-2r.') = -2.
- self assert: (ExtendedNumberParser parse: '-2r-.') = -2.
- self assert: (ExtendedNumberParser parse: '+2r-.') = 2.
-
- self assert: (ExtendedNumberParser parse: '+2r3.') = 2.
- self assert: (ExtendedNumberParser parse: '+2r.3') = 2.
- self assert: (ExtendedNumberParser parse: '+2r-.3') = 2.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testInvalidScale (in category 'tests') -----
- testInvalidScale
- "The leading number is returned, the invalid part is ignored"
-
- self assert: (ExtendedNumberParser parse: '1s') = 1.
- self assert: (ExtendedNumberParser parse: '1sZ') = 1.
- self assert: (ExtendedNumberParser parse: '+1sW') = 1.
- self assert: (ExtendedNumberParser parse: '-1sX') = -1.
-
- self assert: (ExtendedNumberParser parse: '2s-') = 2.
- self assert: (ExtendedNumberParser parse: '2s--1') = 2.
- self assert: (ExtendedNumberParser parse: '2s-+1') = 2.
- self assert: (ExtendedNumberParser parse: '2s-1') = 2.
- self assert: (ExtendedNumberParser parse: '+2s-2') = 2.
- self assert: (ExtendedNumberParser parse: '-2s-3') = -2.
-
- self assert: (ExtendedNumberParser parse: '3s+') = 3.
- self assert: (ExtendedNumberParser parse: '3s+-') = 3.
- self assert: (ExtendedNumberParser parse: '3s+-1') = 3.
- self assert: (ExtendedNumberParser parse: '+3s+2') = 3.
- self assert: (ExtendedNumberParser parse: '-3s+3') = -3.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testPositive (in category 'tests') -----
- testPositive
- "A leading + sign is allowed"
-
- self assert: (ExtendedNumberParser parse: '+1') = 1.
- self assert: (ExtendedNumberParser parse: '+22') = 22.
- self assert: (ExtendedNumberParser parse: '+2r11') = 3.
- self assert: (ExtendedNumberParser parse: '+2r+101') = 5.
- self assert: (ExtendedNumberParser parse: '+2r-101') = -5.
- self assert: (ExtendedNumberParser parse: '-2r+101') = -5.
-
- self assert: (ExtendedNumberParser parse: '+1.') isFloat.
- self assert: (ExtendedNumberParser parse: '+1.') = 1.
- self assert: (ExtendedNumberParser parse: '+21.') = 21.
- self assert: (ExtendedNumberParser parse: '+3r21.') = 7.
- self assert: (ExtendedNumberParser parse: '+3r+201.') = 19.
- self assert: (ExtendedNumberParser parse: '+3r-201.') = -19.
- self assert: (ExtendedNumberParser parse: '-3r+201.') = -19.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testPositiveExponent (in category 'tests') -----
- testPositiveExponent
- "A leading + sign is allowed in exponent"
-
- self assert: (ExtendedNumberParser parse: '1e+2') = 100.
- self assert: (ExtendedNumberParser parse: '1e+2') isInteger.
- self assert: (ExtendedNumberParser parse: '-1e+2') = -100.
-
- self assert: (ExtendedNumberParser parse: '1.e+2') = 100.
- self assert: (ExtendedNumberParser parse: '1.e+2') isFloat.
- self assert: (ExtendedNumberParser parse: '-1.0e+2') = -100.!
Item was removed:
- ----- Method: ExtendedNumberParserTest>>testUppercaseExponent (in category 'tests') -----
- testUppercaseExponent
- "An uppercase exponent is allowed"
-
- self assert: 0.01 equals: (ExtendedNumberParser parse: '1.00E-2').
- self assert: 305.0 equals: (ExtendedNumberParser parse: '3.05D+2').!
Item was removed:
- ClassTestCase subclass: #FalseTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
-
- !FalseTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class False. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category
- !
Item was removed:
- ----- Method: FalseTest>>testAND (in category 'tests') -----
- testAND
-
- self assert: (false & true) = false.
- self assert: (false & false) = false.!
Item was removed:
- ----- Method: FalseTest>>testAnd (in category 'tests') -----
- testAnd
-
- self assert: (false and: ['alternativeBlock']) = false.!
Item was removed:
- ----- Method: FalseTest>>testAsBit (in category 'tests') -----
- testAsBit
-
- self assert: (false asBit = 0).!
Item was removed:
- ----- Method: FalseTest>>testIfFalse (in category 'tests') -----
- testIfFalse
-
- self assert: ((false ifFalse: ['alternativeBlock']) = 'alternativeBlock'). !
Item was removed:
- ----- Method: FalseTest>>testIfFalseIfTrue (in category 'tests') -----
- testIfFalseIfTrue
-
- self assert: (false ifFalse: ['falseAlternativeBlock']
- ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. !
Item was removed:
- ----- Method: FalseTest>>testIfTrue (in category 'tests') -----
- testIfTrue
-
- self assert: (false ifTrue: ['alternativeBlock']) = nil. !
Item was removed:
- ----- Method: FalseTest>>testIfTrueIfFalse (in category 'tests') -----
- testIfTrueIfFalse
-
- self assert: (false ifTrue: ['trueAlternativeBlock']
- ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. !
Item was removed:
- ----- Method: FalseTest>>testInMemory (in category 'tests') -----
- testInMemory
-
- self assert: (false isInMemory = true).!
Item was removed:
- ----- Method: FalseTest>>testNew (in category 'tests') -----
- testNew
-
- self shouldRaiseError: [False new].!
Item was removed:
- ----- Method: FalseTest>>testNot (in category 'tests') -----
- testNot
-
- self assert: (false not = true).!
Item was removed:
- ----- Method: FalseTest>>testOR (in category 'tests') -----
- testOR
-
- self assert: (false | true) = true.
- self assert: (false | false) = false.!
Item was removed:
- ----- Method: FalseTest>>testOr (in category 'tests') -----
- testOr
-
- self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.!
Item was removed:
- ----- Method: FalseTest>>testPrintOn (in category 'tests') -----
- testPrintOn
-
- self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. !
Item was removed:
- ----- Method: FalseTest>>testXor (in category 'tests') -----
- testXor
- self assert: (false xor: true) = true.
- self assert: (false xor: false) = false.
- self assert: (false xor: [true]) = true.
- self assert: (false xor: [false]) = false.
- "Verify that boolean with non-boolean raise errors."
- self should: [false xor: [1]] raise: Error.
- self should: [false xor: 1] raise: Error.!
Item was removed:
- ClassTestCase subclass: #FloatTest
- instanceVariableNames: 'exactInteger float greaterInexactInt smallerInexactInt greaterFloat smallerFloat boxedFloat greaterBoxedFloat smallerBoxedFloat'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
-
- !FloatTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0!
- I provide a test suite for Float values. Examine my tests to see how Floats should behave, and see how to use them.!
Item was removed:
- ----- Method: FloatTest class>>testClassConstantsPasses (in category 'utilities') -----
- testClassConstantsPasses
- "Answer if testClassConstants passes. This can be used in e.g. the Kernel Package prolog
- to test if Float initialize needs to be run."
- [self new testClassConstants]
- on: TestResult failure
- do: [:ex| ^false].
- ^true!
Item was removed:
- ----- Method: FloatTest>>assert:equals:withinUlp: (in category 'asserting') -----
- assert: expected equals: actual withinUlp: maxUlp
- self assert: (expected - actual) abs <= (maxUlp * expected asFloat ulp)!
Item was removed:
- ----- Method: FloatTest>>assertIsNegativeZero: (in category 'asserting') -----
- assertIsNegativeZero: aFloat
- "Assert that aFloat is Float negativeZero"
- self assert: aFloat = 0.0.
- self assert: aFloat signBit = 1!
Item was removed:
- ----- Method: FloatTest>>assertIsPositiveZero: (in category 'asserting') -----
- assertIsPositiveZero: aFloat
- "Assert that aFloat is Float zero (the positive one)"
- self assert: aFloat = 0.0.
- self assert: aFloat signBit = 0!
Item was removed:
- ----- Method: FloatTest>>floatLiteralsIn: (in category 'private') -----
- floatLiteralsIn: method
- | floatLiterals |
- floatLiterals := OrderedCollection new.
- method allLiteralsDo:
- [:lit| lit isFloat ifTrue: [floatLiterals addLast: lit]].
- ^floatLiterals!
Item was removed:
- ----- Method: FloatTest>>methodContainsFloatLiteral: (in category 'private') -----
- methodContainsFloatLiteral: method
- method isQuick ifFalse:
- [method allLiteralsDo:
- [:lit| lit isFloat ifTrue: [^true]]].
- ^false!
Item was removed:
- ----- Method: FloatTest>>methodsMaybeContainingBrokenCompiledConstants (in category 'private') -----
- methodsMaybeContainingBrokenCompiledConstants
- "Answer a set of all methods in the system which contain float constants that differ from those obtaiuned by
- recompiling. These may indicate an old compiler issue, or indeed an issue with the current compiler. This is a
- variant of testCompiledConstants used for collecting the set of methods rather than testing that none exist."
- | identifiedPatients |
- identifiedPatients := IdentitySet new.
- CurrentReadOnlySourceFiles cacheDuring:
- [self systemNavigation allSelectorsAndMethodsDo:
- [:class :selector :method|
- (self methodContainsFloatLiteral: method) ifTrue:
- [| newMethodAndNode newLiterals oldLiterals |
- newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
- newLiterals := self floatLiteralsIn: newMethodAndNode method.
- oldLiterals := self floatLiteralsIn: method.
- "Convenience doit for recompiling broken methods:..."
- "class recompile: selector"
- newLiterals size = oldLiterals size
- ifFalse: [identifiedPatients add: method]
- ifTrue:
- [newLiterals with: oldLiterals do:
- [:new :old|
- (new asIEEE64BitWord = old asIEEE64BitWord
- or: [new isNaN and: old isNaN]) ifFalse:
- [identifiedPatients add: method]]]]]].
- ^identifiedPatients!
Item was removed:
- ----- Method: FloatTest>>setUp (in category 'running') -----
- setUp
- exactInteger := 1 << (Float precision + 2).
- float := exactInteger asFloat.
- greaterInexactInt := exactInteger + 1.
- smallerInexactInt := exactInteger - 1.
- greaterFloat := float successor.
- smallerFloat := float predecessor.
-
- boxedFloat := Float new: 2.
- boxedFloat basicAt: 1 put: (float basicAt: 1).
- boxedFloat basicAt: 2 put: (float basicAt: 2).
- greaterBoxedFloat := Float new: 2.
- greaterBoxedFloat basicAt: 1 put: (greaterFloat basicAt: 1).
- greaterBoxedFloat basicAt: 2 put: (greaterFloat basicAt: 2).
- smallerBoxedFloat := Float new: 2.
- smallerBoxedFloat basicAt: 1 put: (smallerFloat basicAt: 1).
- smallerBoxedFloat basicAt: 2 put: (smallerFloat basicAt: 2).!
Item was removed:
- ----- Method: FloatTest>>test32bitConversion (in category 'tests - IEEE 754') -----
- test32bitConversion
- "Except for NaN, we can convert a 32bits float to a 64bits float exactly.
- Thus we can convert the 64bits float to the original 32bits float pattern."
-
- #(16r0 "zero"
- 16r80000000 "negative zero"
- 16r1 "min unormalized"
- 16r12345 "a unnormalized"
- 16r801FEDCB "a negative unnormalized"
- 16r7FFFFF "largest unnormalized"
- 16r800000 "smallest normalized"
- 16r468ACDEF "a normalized float"
- 16rCABD1234 "a negative normalized float"
- 16r7F7FFFFF "largest finite float"
- 16r7F800000 "positive infinity"
- 16rFF800000 "negative infinity"
- )
- do: [:originalWord | self assert: (Float fromIEEE32Bit: originalWord) asIEEE32BitWord = originalWord]!
Item was removed:
- ----- Method: FloatTest>>test32bitGradualUnderflow (in category 'tests - IEEE 754') -----
- test32bitGradualUnderflow
- "method asIEEE32BitWord did not respect IEEE gradual underflow"
-
- | conv expected exponentPart |
-
- "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1
- 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign
- except when 2reeeeeeee isZero, which is a gradual underflow:
- 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-126) * sign
- and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise"
-
- "case 1: This example is the first gradual underflow case"
- conv := 2r0.11111111111111111111111e-126 asIEEE32BitWord.
-
- "expected float encoded as sign/exponent/mantissa (whithout leading 1 or 0)"
- exponentPart := 0.
- expected := exponentPart bitOr: 2r11111111111111111111111.
- self assert: expected = conv.
-
- "case 2: smallest number"
- conv := 2r0.00000000000000000000001e-126 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r1.
- self assert: expected = conv.
-
- "case 3: round to nearest even also in underflow cases... here round to upper"
- conv := 2r0.000000000000000000000011e-126 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r10.
- self assert: expected = conv.
-
- "case 4: round to nearest even also in underflow cases... here round to lower"
- conv := 2r0.000000000000000000000101e-126 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r10.
- self assert: expected = conv.
-
- "case 5: round to nearest even also in underflow cases... here round to upper"
- conv := 2r0.0000000000000000000001011e-126 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r11.
- self assert: expected = conv.
- !
Item was removed:
- ----- Method: FloatTest>>test32bitRoundingMode (in category 'tests - IEEE 754') -----
- test32bitRoundingMode
- "method asIEEE32BitWord did not respect IEEE default rounding mode"
-
- | conv expected exponentPart |
-
- "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1
- 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign
- except when 2reeeeeeee isZero, which is a gradual underflow:
- 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-127) * sign
- and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise"
-
- "This example has two extra bits in mantissa for testing rounding mode
- case 1: should obviously round to upper"
- conv := 2r1.0000000000000000000000111e25 asIEEE32BitWord.
-
- "expected float encoded as sign/exponent/mantissa (whithout leading 1)"
- exponentPart := 25+127 bitShift: 23. "127 is 2r01111111 or 16r7F"
- expected := exponentPart bitOr: 2r10.
- self assert: expected = conv.
-
- "case 2: exactly in the mid point of two 32 bit float: round toward nearest even (to upper)"
- conv := 2r1.0000000000000000000000110e25 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r10.
- self assert: expected = conv.
-
- "case 3: exactly in the mid point of two 32 bit float: round toward nearest even (to lower)"
- conv := 2r1.0000000000000000000000010e25 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r0.
- self assert: expected = conv.
-
- "case 4: obviously round to upper"
- conv := 2r1.0000000000000000000000011e25 asIEEE32BitWord.
- expected := exponentPart bitOr: 2r1.
- self assert: expected = conv.
- !
Item was removed:
- ----- Method: FloatTest>>testArCosh (in category 'tests - mathematical functions') -----
- testArCosh
- self assert: 1.0 arCosh = 0.0.
- self deny: Float infinity arCosh isFinite.
- self assert: (2.5 arCosh cosh closeTo: 2.5).!
Item was removed:
- ----- Method: FloatTest>>testArSinh (in category 'tests - mathematical functions') -----
- testArSinh
- self assertIsPositiveZero: 0.0 arSinh.
- self assertIsNegativeZero: Float negativeZero arSinh.
- self deny: Float infinity arSinh isFinite.
- self assert: (0.5 arSinh negated closeTo: 0.5 negated arSinh).
- self assert: (0.5 arSinh sinh closeTo: 0.5).
- self assert: (-2.5 arSinh sinh closeTo: -2.5).!
Item was removed:
- ----- Method: FloatTest>>testArTanh (in category 'tests - mathematical functions') -----
- testArTanh
- self assertIsPositiveZero: 0.0 arTanh.
- self assertIsNegativeZero: Float negativeZero arTanh.
- self deny: 1 arTanh isFinite.
- self assert: (0.5 arTanh negated closeTo: 0.5 negated arTanh).
- self assert: (0.5 arTanh tanh closeTo: 0.5).
- self assert: (-0.5 arTanh tanh closeTo: -0.5).!
Item was removed:
- ----- Method: FloatTest>>testArcTan (in category 'tests - mathematical functions') -----
- testArcTan
-
- self assert: ((100 arcTan: 100) closeTo: Float pi / 4).
- self assert: ((-100 arcTan: 100) closeTo: Float pi / -4).
- self assert: ((100 arcTan: -100) closeTo: Float pi * 3 / 4).
- self assert: ((-100 arcTan: -100) closeTo: Float pi * -3 / 4).
- self assert: ((0 arcTan: 100) closeTo: 0).
- self assert: ((0 arcTan: -100) closeTo: Float pi).
- self assert: ((100 arcTan: 0) closeTo: Float pi / 2).
- self assert: ((-100 arcTan: 0) closeTo: Float pi / -2).
-
- self assert: ((Float negativeZero arcTan: 100) closeTo: 0).
- self assert: ((Float negativeZero arcTan: -100) closeTo: Float pi * -1).
-
- self assert: (0 arcTan: 0) = 0.
- self assert: (Float negativeZero arcTan: 0) = 0.
- self assert: ((0 arcTan: Float negativeZero) closeTo: Float pi).
- self assert: ((Float negativeZero arcTan: Float negativeZero) closeTo: Float pi negated). !
Item was removed:
- ----- Method: FloatTest>>testCeiling (in category 'tests - conversion') -----
- testCeiling
- self assert: 1.0 ceiling = 1.
- self assert: 1.1 ceiling = 2.
- self assert: -2.0 ceiling = -2.
- self assert: -2.1 ceiling = -2.!
Item was removed:
- ----- Method: FloatTest>>testCharacterization (in category 'tests - characterization') -----
- testCharacterization
-
- "Test the largest finite representable floating point value"
- self assert: Float fmax successor = Float infinity.
- self assert: Float infinity predecessor = Float fmax.
- self assert: Float fmax negated predecessor = Float negativeInfinity.
- self assert: Float negativeInfinity successor = Float fmax negated.
-
- "Test the smallest positive representable floating point value"
- self assert: Float fmin predecessor = 0.0.
- self assert: 0.0 successor = Float fmin.
- self assert: Float fmin negated successor = 0.0.
- self assert: 0.0 predecessor = Float fmin negated.
-
- "Test the relative precision"
- self assert: Float one + Float epsilon > Float one.
- self assert: Float one + Float epsilon = Float one successor.
- self assert: Float one + (Float epsilon / Float radix) = Float one.
-
- "Test maximum and minimum exponent"
- self assert: Float fmax exponent = Float emax.
- self assert: Float fminNormalized exponent = Float emin.
- Float denormalized ifTrue: [
- self assert: Float fminDenormalized exponent = (Float emin + 1 - Float precision)].
-
- "Alternative tests for maximum and minimum"
- self assert: (Float radix - Float epsilon) * (Float radix raisedTo: Float emax) = Float fmax.
- self assert: Float epsilon * (Float radix raisedTo: Float emin) = Float fmin.
-
- "Test sucessors and predecessors"
- self assert: Float one predecessor successor = Float one.
- self assert: Float one successor predecessor = Float one.
- self assert: Float one negated predecessor successor = Float one negated.
- self assert: Float one negated successor predecessor = Float one negated.
- self assert: Float infinity successor = Float infinity.
- self assert: Float negativeInfinity predecessor = Float negativeInfinity.
- self assertIsNegativeZero: Float fmin negated successor.
- self assert: Float nan predecessor isNaN.
- self assert: Float nan successor isNaN.
-
- "SPECIFIC FOR IEEE 754 double precision - 64 bits"
- self assert: Float fmax hex = '7FEFFFFFFFFFFFFF'.
- self assert: Float fminDenormalized hex = '0000000000000001'.
- self assert: Float fminNormalized hex = '0010000000000000'.
- self assert: 0.0 hex = '0000000000000000'.
- self assert: Float negativeZero hex = '8000000000000000'.
- self assert: Float one hex = '3FF0000000000000'.
- self assert: Float infinity hex = '7FF0000000000000'.
- self assert: Float negativeInfinity hex = 'FFF0000000000000'.!
Item was removed:
- ----- Method: FloatTest>>testClassConstants (in category 'tests - characterization') -----
- testClassConstants
-
- "Test all the class constants that are floats to check that they are valid.
- Sometimes compiler bugs mean that the initialization method is incorrect, etc"
- | expectedVariables unexpectedVariables "these two are for determining if this test is correct, not its results"
- finiteVariables infiniteVariables nanVariables |
- finiteVariables := #(Pi Halfpi Twopi ThreePi RadiansPerDegree Ln2 Ln10 Sqrt2 E Epsilon MaxVal MaxValLn NegativeZero).
- infiniteVariables := #(Infinity NegativeInfinity).
- nanVariables := #(NaN).
- expectedVariables := Set new.
- unexpectedVariables := Set new.
- Float classPool keysAndValuesDo:
- [:name :value|
- value isFloat
- ifTrue:
- [(finiteVariables includes: name) ifTrue:
- [expectedVariables add: name.
- self assert: value isFinite.
- self deny: value isInfinite.
- self deny: value isNaN].
- (infiniteVariables includes: name) ifTrue:
- [expectedVariables add: name.
- self deny: value isFinite.
- self assert: value isInfinite.
- self deny: value isNaN].
- (nanVariables includes: name) ifTrue:
- [expectedVariables add: name.
- self deny: value isFinite.
- self deny: value isInfinite.
- self assert: value isNaN].
- (expectedVariables includes: name) ifFalse:
- [unexpectedVariables add: name]]
- ifFalse:
- [self deny: ((finiteVariables includes: name) or: [(infiniteVariables includes: name) or: [nanVariables includes: name]])]].
- "Now check that test itself is working as intended..."
- self assert: unexpectedVariables isEmpty.
- self assert: expectedVariables = (finiteVariables, infiniteVariables, nanVariables) asSet!
Item was removed:
- ----- Method: FloatTest>>testCloseTo (in category 'tests - compare') -----
- testCloseTo
- self deny: (Float nan closeTo: Float nan) description: 'NaN isn''t close to anything'.
- self deny: (Float nan closeTo: 1.0) description: 'NaN isn''t close to anything'.
- self deny: (1.0 closeTo: Float nan) description: 'NaN isn''t close to anything'.
-
- self deny: (-1.0 closeTo: 1.0).
- self deny: (1.0 closeTo: Float infinity).
- self assert: (Float infinity closeTo: Float infinity) description: 'since they are =, they also are closeTo:'.
-
- self assert: (1.0/3.0 closeTo: 1/3).
- self assert: (1.0e-8 closeTo: 0).
- self assert: (0 closeTo: 1.0e-8).
- self assert: (1+1.0e-8 closeTo: 1.0).
-
- self assert: (1000000001.0 closeTo: 1000000000.0).
- self deny: (1000000001 closeTo: 1000000000) description: 'exact representation are considered closeTo: only if equal'.!
Item was removed:
- ----- Method: FloatTest>>testCloseToFurthestCloseToNeasrest (in category 'tests - compare') -----
- testCloseToFurthestCloseToNeasrest
- | x nearest furthest |
- x := 1.0e-6.
- nearest := 1.0e-7.
- furthest := 0.0.
- self assert: (x - nearest) abs < (x - furthest) abs.
- self assert: (x closeTo: furthest) ==> (x closeTo: nearest)!
Item was removed:
- ----- Method: FloatTest>>testCloseToIsSymmetric (in category 'tests - compare') -----
- testCloseToIsSymmetric
- self assert: ((1<<2000) reciprocal closeTo: 1.0e-6) equals: (1.0e-6 closeTo: (1<<2000) reciprocal)!
Item was removed:
- ----- Method: FloatTest>>testComparison (in category 'tests - compare') -----
- testComparison
-
- "test equality when Float conversion loose bits"
- | a b c |
- a := 16r1FFFFFFFFFFFFF1.
- b := 16r1FFFFFFFFFFFFF3.
- c := a asFloat.
- self assert: ((a = c) & (b = c)) ==> (a = b).
-
- "Test equality when Float conversion exact"
- self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat.
- self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat asInteger.
-
- "Test inequality when Float conversion loose bits"
- self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1.
- self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1.0.
-
- self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1.
- self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1.0.
-
- "Test exact vs inexact arithmetic"
- (1 to: 100) do: [:i |
- i isPowerOfTwo
- ifTrue: [self assert: (1/i) = (1/i) asFloat]
- ifFalse: [self deny: (1/i) = (1/i) asFloat]].
-
- "Test overflow (compare to infinity)"
- a := (11 raisedTo: 400) / 2.
- b := (13 raisedTo: 400) / 2.
- c := a asFloat.
- self assert: ((a = c) & (b = c)) ==> (a = b).
-
- "every integer is smaller than infinity"
- self assert: a < Float infinity.
- self assert: a > Float negativeInfinity.
-
- "Test underflow"
- self deny: 1 / (11 raisedTo: 400) = 0.
- self deny: 1 / (11 raisedTo: 400) = 0.0.
-
- "Test hash code"
- self assert:
- ((Set new: 3) add: 3; add: 3.0; size) =
- ((Set new: 4) add: 3; add: 3.0; size).!
Item was removed:
- ----- Method: FloatTest>>testComparisonSmallFromBoxed (in category 'tests - compare') -----
- testComparisonSmallFromBoxed
- "Comparison should work the same, boxed or not"
-
- self assert: boxedFloat = float.
- self deny: boxedFloat ~= float.
- self deny: boxedFloat = smallerFloat.
- self assert: boxedFloat ~= greaterFloat.
-
- self assert: boxedFloat < greaterFloat.
- self assert: boxedFloat <= greaterFloat.
- self deny: boxedFloat > greaterFloat.
- self deny: boxedFloat >= greaterFloat.
-
- self deny: boxedFloat < smallerFloat.
- self deny: boxedFloat <= smallerFloat.
- self assert: boxedFloat > smallerFloat.
- self assert: boxedFloat >= smallerFloat.!
Item was removed:
- ----- Method: FloatTest>>testComparisonSmallWithBoxed (in category 'tests - compare') -----
- testComparisonSmallWithBoxed
- "Comparison should work the same, boxed or not"
-
- self assert: float = boxedFloat.
- self deny: float ~= boxedFloat.
- self deny: float = smallerBoxedFloat.
- self assert: float ~= greaterBoxedFloat.
-
- self assert: float < greaterBoxedFloat.
- self assert: float <= greaterBoxedFloat.
- self deny: float > greaterBoxedFloat.
- self deny: float >= greaterBoxedFloat.
-
- self deny: float < smallerBoxedFloat.
- self deny: float <= smallerBoxedFloat.
- self assert: float > smallerBoxedFloat.
- self assert: float >= smallerBoxedFloat.!
Item was removed:
- ----- Method: FloatTest>>testComparisonWhenPrimitiveFails (in category 'tests - compare') -----
- testComparisonWhenPrimitiveFails
- "This is related to http://bugs.squeak.org/view.php?id=7361"
-
- self deny: 0.5 < (1/4).
- self deny: 0.5 < (1/2).
- self assert: 0.5 < (3/4).
-
- self deny: 0.5 <= (1/4).
- self assert: 0.5 <= (1/2).
- self assert: 0.5 <= (3/4).
-
- self assert: 0.5 > (1/4).
- self deny: 0.5 > (1/2).
- self deny: 0.5 > (3/4).
-
- self assert: 0.5 >= (1/4).
- self assert: 0.5 >= (1/2).
- self deny: 0.5 >= (3/4).
-
- self deny: 0.5 = (1/4).
- self assert: 0.5 = (1/2).
- self deny: 0.5 = (3/4).
-
- self assert: 0.5 ~= (1/4).
- self deny: 0.5 ~= (1/2).
- self assert: 0.5 ~= (3/4).!
Item was removed:
- ----- Method: FloatTest>>testCompiledConstants (in category 'tests') -----
- testCompiledConstants
- "Test that any methods containing a floating point literal have been correctly compiled."
- CurrentReadOnlySourceFiles cacheDuring:
- [self systemNavigation allSelectorsAndMethodsDo:
- [:class :selector :method|
- (self methodContainsFloatLiteral: method) ifTrue:
- [| newMethodAndNode newLiterals oldLiterals |
- newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
- newLiterals := self floatLiteralsIn: newMethodAndNode method.
- oldLiterals := self floatLiteralsIn: method.
- "Convenience doit for recompiling broken methods:..."
- "class recompile: selector"
- self assert: newLiterals size = oldLiterals size.
- newLiterals with: oldLiterals do:
- [:new :old|
- self assert: (new asIEEE64BitWord = old asIEEE64BitWord
- or: [new isNaN and: old isNaN])]]]]!
Item was removed:
- ----- Method: FloatTest>>testContinuedFractions (in category 'tests - arithmetic') -----
- testContinuedFractions
- self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7).
- self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)!
Item was removed:
- ----- Method: FloatTest>>testCopy (in category 'tests') -----
- testCopy
- "Elementary tests"
- self assert: 2.0 copy = 2.0.
- self assert: -0.5 copy = -0.5.
-
- "Are exceptional Floats preserved by the copy ?"
- self assert: Float nan copy isNaN.
- self assert: Float infinity copy = Float infinity.
- self assert: Float negativeInfinity copy = Float negativeInfinity.
-
- "Is the sign of zero preserved by the copy ?"
- self assert: 0.0 copy hex = 0.0 hex.
- self assert: Float negativeZero copy hex = Float negativeZero hex.!
Item was removed:
- ----- Method: FloatTest>>testCopySign (in category 'tests - zero behavior') -----
- testCopySign
- self assert: (0.0 copySignTo: 1) = 1.
- self assert: (Float negativeZero copySignTo: 1) = -1.
- self assertIsNegativeZero: (-1 copySignTo: 0.0).
- self assertIsPositiveZero: (1 copySignTo: Float negativeZero).!
Item was removed:
- ----- Method: FloatTest>>testCosh (in category 'tests - mathematical functions') -----
- testCosh
- self assert: (0.0 cosh closeTo: 1).
- self deny: Float infinity cosh isFinite.
- self assert: (2.0 cosh squared - 2.0 sinh squared closeTo: 1).
- self assert: (2.0 cosh closeTo: 2.0 negated cosh).!
Item was removed:
- ----- Method: FloatTest>>testDegreeCos (in category 'tests - mathematical functions') -----
- testDegreeCos
- "Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic"
- self assert: (45.0 degreeCos squared - 0.5) abs <= Float epsilon.
- self assert: (60.0 degreeCos - 0.5) abs <= Float epsilon.
- self assert: (120.0 degreeCos + 0.5) abs <= Float epsilon.
- -360.0 to: 360.0 do: [:i |
- self assert: (i degreeCos closeTo: i degreesToRadians cos)].
-
- "Following tests use strict equality which is a requested property of degreeCos"
- -10.0 to: 10.0 do: [:k |
- self assert: (k*360 + 90) degreeCos = 0.
- self assert: (k*360 - 90) degreeCos = 0.
- self assert: (k*360 + 180) degreeCos + 1 = 0.
- self assert: (k*360) degreeCos - 1 = 0.].!
Item was removed:
- ----- Method: FloatTest>>testDegreeCosForExceptionalValues (in category 'tests - mathematical functions') -----
- testDegreeCosForExceptionalValues
- self assert: Float nan degreeCos isNaN.
- self assert: Float infinity degreeCos isNaN.
- self assert: Float negativeInfinity degreeCos isNaN.!
Item was removed:
- ----- Method: FloatTest>>testDegreeSin (in category 'tests - mathematical functions') -----
- testDegreeSin
- "Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic"
- self assert: (45.0 degreeSin squared - 0.5) abs <= Float epsilon.
- self assert: (30.0 degreeSin - 0.5) abs <= Float epsilon.
- self assert: (-30.0 degreeSin + 0.5) abs <= Float epsilon.
- -360.0 to: 360.0 do: [:i |
- self assert: (i degreeSin closeTo: i degreesToRadians sin)].
-
- "Following tests use strict equality which is a requested property of degreeSin"
- -10.0 to: 10.0 do: [:k |
- self assert: (k*360 + 90) degreeSin - 1 = 0.
- self assert: (k*360 - 90) degreeSin + 1= 0.
- self assert: (k*360 + 180) degreeSin = 0.
- self assert: (k*360) degreeSin = 0.].!
Item was removed:
- ----- Method: FloatTest>>testDegreeSinForExceptionalValues (in category 'tests - mathematical functions') -----
- testDegreeSinForExceptionalValues
- self assert: Float nan degreeSin isNaN.
- self assert: Float infinity degreeSin isNaN.
- self assert: Float negativeInfinity degreeSin isNaN.!
Item was removed:
- ----- Method: FloatTest>>testDivide (in category 'tests - arithmetic') -----
- testDivide
-
- self assert: 1.5 / 2.0 = 0.75.
-
- self assert: 2.0 / 1 = 2.0.
-
- self should: [ 2.0 / 0 ] raise: ZeroDivide.
- self should: [ 2.0 / 0.0 ] raise: ZeroDivide.
- self should: [ 1.2 / Float negativeZero ] raise: ZeroDivide.
- self should: [ 1.2 / (1.3 - 1.3) ] raise: ZeroDivide
- !
Item was removed:
- ----- Method: FloatTest>>testExactComparisonFromSmallInt (in category 'tests - compare') -----
- testExactComparisonFromSmallInt
- "Those tests works when using naive (integer asFloat = float) comparison.
- This is because the conversion asFloat are exact."
-
- {float. boxedFloat} do: [:f |
- self assert: exactInteger = f.
- self deny: exactInteger ~= f.
- self assert: exactInteger <= f.
- self deny: exactInteger < f.
- self assert: exactInteger >= f.
- self deny: exactInteger > f].
-
- {greaterFloat. greaterBoxedFloat} do: [:f |
- self deny: exactInteger = f.
- self assert: exactInteger ~= f.
- self assert: exactInteger <= f.
- self assert: exactInteger < f.
- self deny: exactInteger >= f.
- self deny: exactInteger > f].
-
- {smallerFloat. smallerBoxedFloat} do: [:f |
- self deny: exactInteger = f.
- self assert: exactInteger ~= f.
- self deny: exactInteger <= f.
- self deny: exactInteger < f.
- self assert: exactInteger >= f.
- self assert: exactInteger > f].!
Item was removed:
- ----- Method: FloatTest>>testExactComparisonWithSmallInt (in category 'tests - compare') -----
- testExactComparisonWithSmallInt
- "Those tests works when using naive (integer asFloat = float) comparison.
- This is because the conversion asFloat are exact."
-
- {float. boxedFloat} do: [:f |
- self assert: f = exactInteger.
- self deny: f ~= exactInteger.
- self assert: f <= exactInteger.
- self deny: f < exactInteger.
- self assert: f >= exactInteger.
- self deny: f > exactInteger].
-
- {greaterFloat. greaterBoxedFloat} do: [:f |
- self deny: f = exactInteger.
- self assert: f ~= exactInteger.
- self deny: f <= exactInteger.
- self deny: f < exactInteger.
- self assert: f >= exactInteger.
- self assert: f > exactInteger].
-
- {smallerFloat. smallerBoxedFloat} do: [:f |
- self deny: f = exactInteger.
- self assert: f ~= exactInteger.
- self assert: f <= exactInteger.
- self assert: f < exactInteger.
- self deny: f >= exactInteger.
- self deny: f > exactInteger].!
Item was removed:
- ----- Method: FloatTest>>testFloatRounded (in category 'tests - conversion') -----
- testFloatRounded
- "5000000000000001 asFloat has an exact representation (no round off error).
- It should round to nearest integer without loosing bits.
- This is a no regression test on http://bugs.squeak.org/view.php?id=7134"
-
- | x y int r |
-
- "This is a preamble asserting exactness of representation
- and quality of various conversions"
- int := 5000000000000001.
- x := int asFloat.
- y := (5 asFloat squared squared squared squared timesTwoPower: 15) + 1.
- self assert: x = y.
- self assert: x asTrueFraction = int.
-
- "this one should be true for any float
- in order to conform to ISO/IEC 10967-2"
- self assert: x rounded = x asTrueFraction rounded.
- self assert: x negated rounded = x negated asTrueFraction rounded.
-
- "a random test"
- r := Random new.
- 10000 timesRepeat: [
- x := r next * 1.9999e16 + 1.0e12 .
- self assert: x rounded = x asTrueFraction rounded.
- self assert: x negated rounded = x negated asTrueFraction rounded]!
Item was removed:
- ----- Method: FloatTest>>testFloatTruncated (in category 'tests - conversion') -----
- testFloatTruncated
- "(10 raisedTo: 16) asFloat has an exact representation (no round off error).
- It should convert back to integer without loosing bits.
- This is a no regression test on http://bugs.impara.de/view.php?id=3504"
-
- | x y int r |
- int := 10 raisedTo: 16.
- x := int asFloat.
- y := (5 raisedTo: 16) asFloat timesTwoPower: 16.
- self assert: x = y.
-
- self assert: x asInteger = int.
-
- "this one should be true for any float"
- self assert: x asInteger = x asTrueFraction asInteger.
-
- "a random test"
- r := Random new.
- 10000 timesRepeat: [
- x := r next * 1.9999e16 + 1.0e12 .
- self assert: x truncated = x asTrueFraction truncated].
-
- "test an edge case (see https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/376)"
- self assert: SmallInteger maxVal + 1 equals: (SmallInteger maxVal + 1) asFloat asInteger!
Item was removed:
- ----- Method: FloatTest>>testFloor (in category 'tests - conversion') -----
- testFloor
- self assert: 1.0 floor = 1.
- self assert: 1.1 floor = 1.
- self assert: -2.0 floor = -2.
- self assert: -2.1 floor = -3.!
Item was removed:
- ----- Method: FloatTest>>testFloorLog2 (in category 'tests - mathematical functions') -----
- testFloorLog2
- "Float internal representation of Float being in base 2, we expect (aFloat floorLog: 2) to be exact."
-
- | aBitLess aBitMore |
- aBitMore := 1 + Float epsilon.
- aBitLess := 1 - Float epsilon.
- Float emin + 1 to: Float emax - 1 do: [:exp |
- | exactPowerOfTwo |
- exactPowerOfTwo := 1.0 timesTwoPower: exp.
- self assert: (exactPowerOfTwo floorLog: 2) equals: exp.
- self assert: (exactPowerOfTwo * aBitMore floorLog: 2) equals: exp.
- self assert: (exactPowerOfTwo * aBitLess floorLog: 2) equals: exp - 1].!
Item was removed:
- ----- Method: FloatTest>>testFractionAsExactFloat (in category 'tests - conversion') -----
- testFractionAsExactFloat
- {
- 1/2.
- 1<<Float precision - 1 / (1 << 8).
- Float fminNormalized asFraction.
- Float fmin asFraction * 3.
- Float fmin asFraction.
- }
- do: [:f | self assert: f asExactFloat equals: f asFloat]!
Item was removed:
- ----- Method: FloatTest>>testFractionAsFloat (in category 'tests - conversion') -----
- testFractionAsFloat
- "use a random test"
-
- | r m frac err collec |
- r := Random new seed: 1234567.
- m := (2 raisedTo: 54) - 1.
- 200 timesRepeat: [
- frac := ((r nextInt: m) * (r nextInt: m) + 1) / ((r nextInt: m) * (r nextInt: m) + 1).
- err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
- self assert: err < (1/2)].
-
- collec := #(16r10000000000000 16r1FFFFFFFFFFFFF 1 2 16r20000000000000 16r20000000000001 16r3FFFFFFFFFFFFF 16r3FFFFFFFFFFFFE 16r3FFFFFFFFFFFFD).
- collec do: [:num |
- collec do: [:den |
- frac := Fraction numerator: num denominator: den.
- err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
- self assert: err <= (1/2)]].!
Item was removed:
- ----- Method: FloatTest>>testFractionAsFloat2 (in category 'tests - conversion') -----
- testFractionAsFloat2
- "test rounding to nearest even"
-
- self assert: ((1<<52)+0+(1/4)) asFloat asTrueFraction = ((1<<52)+0).
- self assert: ((1<<52)+0+(1/2)) asFloat asTrueFraction = ((1<<52)+0).
- self assert: ((1<<52)+0+(3/4)) asFloat asTrueFraction = ((1<<52)+1).
- self assert: ((1<<52)+1+(1/4)) asFloat asTrueFraction = ((1<<52)+1).
- self assert: ((1<<52)+1+(1/2)) asFloat asTrueFraction = ((1<<52)+2).
- self assert: ((1<<52)+1+(3/4)) asFloat asTrueFraction = ((1<<52)+2).!
Item was removed:
- ----- Method: FloatTest>>testFractionAsFloatWithUnderflow (in category 'tests - conversion') -----
- testFractionAsFloatWithUnderflow
- "test rounding to nearest even"
-
- | underflowPower |
- underflowPower := Float emin - Float precision.
- self assert: (2 raisedTo: underflowPower) asFloat = 0.0.
- self assert: (2 raisedTo: underflowPower) negated asFloat = 0.0.
- self assert: (2 raisedTo: underflowPower) negated asFloat signBit = 1 description: 'a negative underflow should return a negative zero'.!
Item was removed:
- ----- Method: FloatTest>>testFractionIsAnExactFloat (in category 'tests - conversion') -----
- testFractionIsAnExactFloat
- self assert: (1/2) isAnExactFloat.
- self assert: (1<<Float precision - 1 / (1 << 8)) isAnExactFloat.
- self assert: (Float fmin asFraction * 3) isAnExactFloat.
- self assert: Float fmin asFraction isAnExactFloat.
- self deny: (Float fmin asFraction / 2) isAnExactFloat.
- self deny: (Float fmin asFraction * 3 / 2) isAnExactFloat.
- self deny: (1 / 3) isAnExactFloat.
- self deny: (1<<Float precision + 1 / 2) isAnExactFloat.!
Item was removed:
- ----- Method: FloatTest>>testHugeIntegerCloseTo (in category 'tests - infinity behavior') -----
- testHugeIntegerCloseTo
- "This is a test for bug http://bugs.squeak.org/view.php?id=7368"
-
- "FloatTest new testHugeIntegerCloseTo"
-
- self deny: (1.0 closeTo: 200 factorial).
- self deny: (200 factorial closeTo: 1.0).
- self assert: (Float infinity closeTo: 200 factorial) = (200 factorial closeTo: Float infinity).!
Item was removed:
- ----- Method: FloatTest>>testInexactComparisonFromSmallInt (in category 'tests - compare') -----
- testInexactComparisonFromSmallInt
- "Those tests would fail if using naive (integer asFloat = float) comparison.
- This is because the conversion asFloat are inexact and loose bits."
-
- {float. boxedFloat} do: [:f |
- self deny: smallerInexactInt = f.
- self assert: greaterInexactInt ~= f.
-
- self assert: greaterInexactInt > f.
- self deny: greaterInexactInt <= f.
- self assert: smallerInexactInt < f.
- self deny: smallerInexactInt >= f].!
Item was removed:
- ----- Method: FloatTest>>testInexactComparisonOKFromSmallInt (in category 'tests - compare') -----
- testInexactComparisonOKFromSmallInt
- "asFloat conversion is monotonic:
- intA < intB ==> (intA asFloat <= intB asFloat).
- Thus those tests would work if using naive (integer asFloat op: float) comparison,
- even if asFloat conversion is inexact."
-
- {greaterFloat . greaterBoxedFloat} do: [:f |
- self deny: smallerInexactInt = f.
- self assert: smallerInexactInt ~= f.
-
- self assert: smallerInexactInt < f.
- self assert: smallerInexactInt <= f.
- self deny: smallerInexactInt > f.
- self deny: smallerInexactInt >= f].!
Item was removed:
- ----- Method: FloatTest>>testInexactComparisonOKWithSmallInt (in category 'tests - compare') -----
- testInexactComparisonOKWithSmallInt
- "asFloat conversion is monotonic:
- intA < intB ==> (intA asFloat <= intB asFloat).
- Thus those tests would work if using naive (integer asFloat op: float) comparison,
- even if asFloat conversion is inexact."
-
- {smallerFloat . smallerBoxedFloat} do: [:f |
- self deny: f = greaterInexactInt.
- self assert: f ~= greaterInexactInt.
-
- self assert: f < greaterInexactInt.
- self assert: f <= greaterInexactInt.
- self deny: f > greaterInexactInt.
- self deny: f >= greaterInexactInt].!
Item was removed:
- ----- Method: FloatTest>>testInexactComparisonWithSmallInt (in category 'tests - compare') -----
- testInexactComparisonWithSmallInt
- "Those tests would fail if using naive (integer asFloat = float) comparison.
- This is because the conversion asFloat are inexact and loose bits."
-
- {float. boxedFloat} do: [:f |
- self deny: f = greaterInexactInt.
- self assert: f ~= smallerInexactInt.
-
- self assert: f < greaterInexactInt.
- self deny: f >= greaterInexactInt.
- self assert: f > smallerInexactInt.
- self deny: f <= smallerInexactInt].!
Item was removed:
- ----- Method: FloatTest>>testInfinity1 (in category 'tests - infinity behavior') -----
- testInfinity1
- "FloatTest new testInfinity1"
-
- | i1 i2 |
-
- i1 := 10000 exp.
- i2 := 1000000000 exp.
- self assert: i1 isInfinite & i2 isInfinite & (i1 = i2).
- "All infinities are equal. (This is a very substantial difference to NaN's, which are never equal."
- !
Item was removed:
- ----- Method: FloatTest>>testInfinity2 (in category 'tests - infinity behavior') -----
- testInfinity2
- "FloatTest new testInfinity2"
-
- | i1 i2 |
- i1 := 10000 exp.
- i2 := 1000000000 exp.
- i2 := 0 - i2. " this is entirely ok. You can compute with infinite values."
-
- self assert: i1 isInfinite & i2 isInfinite & i1 positive & i2 negative.
- self deny: i1 = i2.
- "All infinities are signed. Negative infinity is not equal to Infinity"
- !
Item was removed:
- ----- Method: FloatTest>>testInfinity3 (in category 'tests - IEEE 754') -----
- testInfinity3
- self assert: (Float negativeInfinity asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
- '11111111100000000000000000000000'.
- self assert: (Float fromIEEE32Bit:
- (Integer readFrom: '11111111100000000000000000000000' readStream base: 2))
- = Float negativeInfinity!
Item was removed:
- ----- Method: FloatTest>>testInfinityCloseTo (in category 'tests - infinity behavior') -----
- testInfinityCloseTo
- "This is a test for bug http://bugs.squeak.org/view.php?id=6729:"
-
- "FloatTest new testInfinityCloseTo"
-
- self deny: (Float infinity closeTo: Float negativeInfinity).
- self deny: (Float negativeInfinity closeTo: Float infinity).!
Item was removed:
- ----- Method: FloatTest>>testIntegerAsFloat (in category 'tests - conversion') -----
- testIntegerAsFloat
- "assert IEEE 754 round to nearest even mode is honoured"
-
- self deny: 16r1FFFFFFFFFFFF0801 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 65 bits"
- self deny: 16r1FFFFFFFFFFFF0802 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 64 bits"
- self assert: 16r1FFFFFFFFFFF1F800 asFloat = 16r1FFFFFFFFFFF20000 asFloat. "nearest even is upper"
- self assert: 16r1FFFFFFFFFFFF0800 asFloat = 16r1FFFFFFFFFFFF0000 asFloat. "nearest even is lower"
- !
Item was removed:
- ----- Method: FloatTest>>testIsDenormal (in category 'tests - characterization') -----
- testIsDenormal
- self assert: Float fminNormalized predecessor isDenormal.
- self assert: Float fminDenormalized isDenormal.
- self assert: Float fminDenormalized negated isDenormal.
-
- self deny: Float fminNormalized isDenormal.
- self deny: 0.0 isDenormal.
- self deny: 1.0 isDenormal.
- self deny: Float fmax isDenormal.
- self deny: Float infinity isDenormal.
- self deny: Float negativeInfinity isDenormal.
- self deny: Float nan isDenormal.!
Item was removed:
- ----- Method: FloatTest>>testIsFinite (in category 'tests - characterization') -----
- testIsFinite
- self assert: Float fminDenormalized isFinite.
- self assert: 0.0 isFinite.
- self assert: Float pi negated isFinite.
- self assert: Float fmax isFinite.
-
- self deny: Float infinity isFinite.
- self deny: Float negativeInfinity isFinite.
- self deny: Float nan isFinite.!
Item was removed:
- ----- Method: FloatTest>>testIsPowerOfTwo (in category 'tests - characterization') -----
- testIsPowerOfTwo
-
- -1023 - 51 to: 1023 do: [ :each |
- | n |
- n := 1.0 timesTwoPower: each.
- self
- assert: n isPowerOfTwo;
- deny: n negated isPowerOfTwo ].
- { 0.0. 3.0. 0.3. Float nan. Float infinity } do: [ :each |
- self
- deny: each isPowerOfTwo;
- deny: each negated isPowerOfTwo ].
- !
Item was removed:
- ----- Method: FloatTest>>testIsZero (in category 'tests - zero behavior') -----
- testIsZero
- self assert: 0.0 isZero.
- self assert: Float negativeZero isZero.
- self deny: 0.1 isZero.!
Item was removed:
- ----- Method: FloatTest>>testLargeIntegerIsAnExactFloat (in category 'tests - conversion') -----
- testLargeIntegerIsAnExactFloat
- self assert: Float fmax asInteger isAnExactFloat.
- self deny: (Float fmax asInteger + (Float fmax ulp / 2) asInteger) isAnExactFloat.
- self deny: (Float fmax asInteger * 2) isAnExactFloat!
Item was removed:
- ----- Method: FloatTest>>testLargeNegativeIntegerAsFloat (in category 'tests - conversion') -----
- testLargeNegativeIntegerAsFloat
- "assert IEEE 754 round to nearest even mode is honoured"
-
- self assert: SmallInteger minVal asFloat negative.
- self assert: SmallInteger minVal isAnExactFloat description: 'this test requires this condition. If not met, change the test'.
- self assert: SmallInteger minVal equals: SmallInteger minVal asFloat. "this test requires integrity of negative SmallInteger asFloat"
- self assert: SmallInteger minVal asFloat - 1.0 equals: (SmallInteger minVal - 1) asFloat "same for LargeNegativeInteger"
- !
Item was removed:
- ----- Method: FloatTest>>testLiteralEqualityOfNan (in category 'tests - compare') -----
- testLiteralEqualityOfNan
- | nan |
- nan := Float nan.
- self assert: (nan literalEqual: nan)
- description: 'Float nan is not equal to itself, though it is literally equal'.!
Item was removed:
- ----- Method: FloatTest>>testLiteralEqualityOfZeroAndNegativeZero (in category 'tests - compare') -----
- testLiteralEqualityOfZeroAndNegativeZero
- self assert: 1
- equals: (Compiler evaluate: '1>2 ifTrue: [0.0] ifFalse: [-0.0]') signBit
- description: 'Float zero and negativeZero are not literally substituable'.!
Item was removed:
- ----- Method: FloatTest>>testLog2near1 (in category 'tests - mathematical functions') -----
- testLog2near1
- self assert: 1.0 predecessor ln / 2 ln equals: 1.0 predecessor log2 withinUlp: 2.
- self assert: 1.0 successor ln / 2 ln equals: 1.0 successor log2 withinUlp: 2!
Item was removed:
- ----- Method: FloatTest>>testMaxExactInteger (in category 'tests') -----
- testMaxExactInteger
- "
- FloatTest new testMaxExactInteger
- "
-
- self assert: Float maxExactInteger asFloat truncated = Float maxExactInteger.
- 0 to: 10000 do: [ :j |
- self assert: (Float maxExactInteger-j) asFloat truncated = (Float maxExactInteger-j) ].
- self deny: (Float maxExactInteger+1) asFloat truncated = (Float maxExactInteger+1)
- !
Item was removed:
- ----- Method: FloatTest>>testNaN1 (in category 'tests - NaN behavior') -----
- testNaN1
- "FloatTest new testNaN1"
-
- self assert: Float nan == Float nan.
- self deny: Float nan = Float nan.
- "a NaN is not equal to itself."
- !
Item was removed:
- ----- Method: FloatTest>>testNaN2 (in category 'tests - NaN behavior') -----
- testNaN2
- "Two NaN values are always considered to be different.
- On an little-endian machine (32 bit Intel), Float nan is 16rFFF80000 16r00000000.
- On a big-endian machine (PowerPC), Float nan is 16r7FF80000 16r00000000. Changing
- the bit pattern of the first word of a NaN produces another value that is still
- considered equal to NaN. This test should work on both little endian and big
- endian machines. However, it is not guaranteed to work on future 64 bit versions
- of Squeak, for which Float may have different internal representations."
-
- "FloatTest new testNaN2"
-
- | nan1 nan2 |
- nan1 := Float nan copy.
- nan2 := Float nan copy.
-
- "test two instances of NaN with the same bit pattern"
- self deny: nan1 = nan2.
- self deny: nan1 == nan2.
- self deny: nan1 = nan1.
- self assert: nan1 == nan1.
-
- "change the bit pattern of nan1"
- self assert: nan1 size = 2.
- self assert: (nan1 at: 2) = 0.
- nan1 at: 1 put: (nan1 at: 1) + 999.
- self assert: nan1 isNaN.
- self assert: nan2 isNaN.
- self deny: (nan1 at: 1) = (nan2 at: 1).
-
- "test two instances of NaN with different bit patterns"
- self deny: nan1 = nan2.
- self deny: nan1 == nan2.
- self deny: nan1 = nan1.
- self assert: nan1 == nan1
- !
Item was removed:
- ----- Method: FloatTest>>testNaN3 (in category 'tests - NaN behavior') -----
- testNaN3
- "FloatTest new testNaN3"
-
- | set item identitySet |
- set := Set new.
- set add: (item := Float nan).
- self deny: (set includes: item).
- identitySet := IdentitySet new.
- identitySet add: (item := Float nan).
- self assert: (identitySet includes: item).
- "as a NaN is not equal to itself, it can not be retrieved from a set"
- !
Item was removed:
- ----- Method: FloatTest>>testNaN4 (in category 'tests - NaN behavior') -----
- testNaN4
- "FloatTest new testNaN4"
-
- | dict |
- dict := Dictionary new.
- dict at: Float nan put: #NaN.
- self deny: (dict includes: Float nan).
- "as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key"
- !
Item was removed:
- ----- Method: FloatTest>>testNaN5 (in category 'tests - IEEE 754') -----
- testNaN5
- | nanstr |
-
- "check the NaN string representation conforms to IEEE 754"
- nanstr := Float nan asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2.
- self
- assert: (#($0 $1) includes: (nanstr at: 1));
- assert: (nanstr copyFrom: 2 to: 9) = '11111111';
- assert: (#($0 $1) includes: (nanstr at: 10)); "accept both quiet and signalled NaNs"
- assert: ((nanstr copyFrom: 11 to: 32) reject: [ :c | #($0 $1) includes: c ]) isEmpty.
-
- "check a correct quiet NaN is created from a string"
- self assert: (Float fromIEEE32Bit:
- (Integer readFrom: '01111111110000000000000000000000' readStream base: 2)) isNaN!
Item was removed:
- ----- Method: FloatTest>>testNaNCompare (in category 'tests - NaN behavior') -----
- testNaNCompare
- "IEEE 754 states that NaN cannot be ordered.
- As a consequence, every arithmetic comparison involving a NaN SHOULD return false.
- Except the is different test (~=).
- This test does verify this rule"
-
- | compareSelectors theNaN anotherNaN comparand brokenMethods warningMessage |
- compareSelectors := #(#< #<= #> #>= #=).
- theNaN := Float nan.
- anotherNaN := Float infinity - Float infinity.
- comparand := {1. 2.3. Float infinity. 2/3. 1.25s2. 2 raisedTo: 50}.
- comparand := comparand , (comparand collect: [:e | e negated]).
- comparand := comparand , {theNaN. anotherNaN}.
-
- "do a first pass to collect all broken methods"
- brokenMethods := Set new.
- comparand do: [:comp |
- compareSelectors do: [:op |
- (theNaN perform: op with: comp) ifTrue: [brokenMethods add: (theNaN class lookupSelector: op)].
- (comp perform: op with: theNaN) ifTrue: [brokenMethods add: (comp class lookupSelector: op)]].
- (theNaN ~= comp) ifFalse: [brokenMethods add: (theNaN class lookupSelector: #~=)].
- (comp ~= theNaN) ifFalse: [brokenMethods add: (comp class lookupSelector: #~=)]].
-
- "build a warning message to tell about all broken methods at once"
- warningMessage := String streamContents: [:s |
- s nextPutAll: 'According to IEEE 754 comparing with a NaN should always return false, except ~= that should return true.'; cr.
- s nextPutAll: 'All these methods failed to do so. They are either broken or call a broken one'.
- brokenMethods do: [:e | s cr; print: e methodClass; nextPutAll: '>>'; print: e selector]].
-
- "Redo the tests so as to eventually open a debugger on one of the failures"
- brokenMethods := Set new.
- comparand do: [:comp2 |
- compareSelectors do: [:op2 |
- self deny: (theNaN perform: op2 with: comp2) description: warningMessage.
- self deny: (comp2 perform: op2 with: theNaN) description: warningMessage].
- self assert: (theNaN ~= comp2) description: warningMessage.
- self assert: (comp2 ~= theNaN) description: warningMessage].!
Item was removed:
- ----- Method: FloatTest>>testNaNisLiteral (in category 'tests - NaN behavior') -----
- testNaNisLiteral
- self deny: Float nan isLiteral description: 'there is no literal representation of NaN'!
Item was removed:
- ----- Method: FloatTest>>testNegativeZeroAbs (in category 'tests - zero behavior') -----
- testNegativeZeroAbs
- self assert: Float negativeZero abs signBit = 0 description: 'the absolute value of a negative zero is zero'!
Item was removed:
- ----- Method: FloatTest>>testNegativeZeroSign (in category 'tests - zero behavior') -----
- testNegativeZeroSign
- self assert: Float negativeZero sign = 0.
- self assert: Float negativeZero signBit = 1 "That's how we can distinguish from positive zero"!
Item was removed:
- ----- Method: FloatTest>>testNthRoot (in category 'tests - mathematical functions') -----
- testNthRoot
- "
- FloatTest new testNthRoot
- "
- self should: [ -1.23 nthRoot: 4 ] raise: ArithmeticError!
Item was removed:
- ----- Method: FloatTest>>testPrintPaddedWithTo (in category 'tests - printing') -----
- testPrintPaddedWithTo
- "This bug was reported in http://lists.gforge.inria.fr/pipermail/pharo-users/2011-February/001569.html.
- The problem was caused by treating the format specifier as a number rather than
- as a string, such the the number may be a Float subject to floating point rounding
- errors. The solution to treat the format specifier as a string, and extract the integer
- fields before and after the decimal point in the string."
-
- self assert: [(1.0 printPaddedWith: $0 to: 2.2) = '01.00'].
- self assert: [(1.0 printPaddedWith: $X to: 2.2) = 'X1.0X'].
- self assert: [(1.0 printPaddedWith: $0 to: 2) = '01.0'].
- self assert: [(12345.6789 printPaddedWith: $0 to: 2) = '12345.6789'].
- self assert: [(12345.6789 printPaddedWith: $0 to: 2.2) = '12345.6789'].
- self assert: [(12.34 printPaddedWith: $0 to: 2.2) = '12.34'].
- self assert: [(12345.6789 printPaddedWith: $0 to: 2.2) = '12345.6789'].
- self assert: [(123.456 printPaddedWith: $X to: 4.4) = 'X123.456X'].
- self assert: [(1.0 printPaddedWith: $0 to: 2.1) = '01.0'].
- self assert: [(1.0 printPaddedWith: $0 to: 2.2) = '01.00'].
- self assert: [(1.0 printPaddedWith: $0 to: 2.3) = '01.000']. "previously failed due to float usage"
- self assert: [(1.0 printPaddedWith: $0 to: 2.4) = '01.0000']. "previously failed due to float usage"
- self assert: [(1.0 printPaddedWith: $0 to: 2.5) = '01.00000']
-
- !
Item was removed:
- ----- Method: FloatTest>>testRaisedTo (in category 'tests - mathematical functions') -----
- testRaisedTo
- "
- FloatTest new testRaisedTo
- "
- self should: [ -1.23 raisedTo: 1/4 ] raise: ArithmeticError!
Item was removed:
- ----- Method: FloatTest>>testReadFromManyDigits (in category 'tests - conversion') -----
- testReadFromManyDigits
- "A naive algorithm may interpret these representations as Infinity or NaN.
- This is http://bugs.squeak.org/view.php?id=6982"
-
- | s1 s2 |
- s1 := '1' , (String new: 321 withAll: $0) , '.0e-321'.
- s2 := '0.' , (String new: 320 withAll: $0) , '1e321'.
- self assert: (Number readFrom: s1) = 1.
- self assert: (Number readFrom: s2) = 1.!
Item was removed:
- ----- Method: FloatTest>>testReciprocal (in category 'tests - arithmetic') -----
- testReciprocal
-
- self
- assert: 1.0 reciprocal = 1.0;
- assert: 2.0 reciprocal = 0.5;
- assert: -1.0 reciprocal = -1.0;
- assert: -2.0 reciprocal = -0.5.
-
- self should: [ 0.0 reciprocal ] raise: ZeroDivide!
Item was removed:
- ----- Method: FloatTest>>testRounded (in category 'tests - conversion') -----
- testRounded
- self assert: 0.9 rounded = 1.
- self assert: 1.0 rounded = 1.
- self assert: 1.1 rounded = 1.
- self assert: -1.9 rounded = -2.
- self assert: -2.0 rounded = -2.
- self assert: -2.1 rounded = -2.
-
- "In case of tie, round to upper magnitude"
- self assert: 1.5 rounded = 2.
- self assert: -1.5 rounded = -2.!
Item was removed:
- ----- Method: FloatTest>>testSetOfFloat (in category 'tests') -----
- testSetOfFloat
- "Classical disagreement between hash and = did lead to a bug.
- This is a non regression test from http://bugs.squeak.org/view.php?id=3360"
-
- | size3 size4 |
- size3 := (Set new: 3) add: 3; add: 3.0; size.
- size4 := (Set new: 4) add: 3; add: 3.0; size.
- self assert: size3 = size4 description: 'The size of a Set should not depend on its capacity.'!
Item was removed:
- ----- Method: FloatTest>>testSign (in category 'tests') -----
- testSign
-
- "Set up"
- | negatives negz positives strictNegatives strictPositives zero |
- strictPositives := {2. 2.5. Float infinity}.
- strictNegatives := {-3. -3.25. Float negativeInfinity}.
- zero := 0.0.
- negz := Float negativeZero.
- positives := strictPositives copyWith: zero.
- negatives := strictNegatives copyWith: negz.
-
- "The sign of non zeros"
- strictPositives do: [:aPositive | self assert: aPositive sign = 1].
- strictNegatives do: [:aNegative | self assert: aNegative sign = -1].
-
- "The sign of zeros"
- self assert: zero sign = 0.
- self assert: negz sign = 0. "remark that negz can't be distinguished from zero and is thus considered positive..."
- self assert: negz signBit = 1. "but we can differentiate"
-
- "Test the copy sign functions"
- positives do: [:aPositiveSign |
- positives do: [:aPositive |
- self assert: (aPositive sign: aPositiveSign) = aPositive].
- negatives do: [:aNegative |
- self assert: (aNegative sign: aPositiveSign) = aNegative negated].
- (zero sign: aPositiveSign) signBit = 0.
- (negz sign: aPositiveSign) signBit = 0].
-
- negatives do: [:aNegativeSign |
- positives do: [:aPositive |
- self assert: (aPositive sign: aNegativeSign) = aPositive negated].
- negatives do: [:aNegative |
- self assert: (aNegative sign: aNegativeSign) = aNegative].
- (zero sign: aNegativeSign) signBit = 1.
- (negz sign: aNegativeSign) signBit = 1].!
Item was removed:
- ----- Method: FloatTest>>testSignificandAndExponent (in category 'tests - characterization') -----
- testSignificandAndExponent
- | denormals exceptionals normals |
-
- normals := {Float pi. Float pi * 100.0. Float pi/ -100.0. Float fmax. Float fminNormalized}.
- denormals := {0.0. Float negativeZero. Float fminNormalized predecessor. Float fmin negated}.
- exceptionals := {Float nan. Float infinity. Float negativeInfinity.}.
-
- normals , denormals , exceptionals do: [:aFloat |
- "Any Float can be decomposed into its significand and exponent, and the significand holds the sign"
- aFloat isNaN
- ifTrue: [self assert: (aFloat significand timesTwoPower: aFloat exponent) isNaN]
- ifFalse: [self
- assert: (aFloat significand timesTwoPower: aFloat exponent)
- equals: aFloat]].
-
- normals , denormals do: [:aFloat |
- "The significand magnitude is in interval [1.0,2.0( "
- aFloat = 0.0
- ifTrue: [self assert: aFloat significand equals: 0]
- ifFalse: [self
- assert: aFloat significand abs >= 1.0;
- assert: aFloat significand abs < 2.0]]!
Item was removed:
- ----- Method: FloatTest>>testSignificandAsInteger (in category 'tests - characterization') -----
- testSignificandAsInteger
- | mantissaBits denormalPowersOfTwo denormals exceptionals normalPowersOfTwo normals |
- "There are 52 bits used for representing the mantissa (plus an eventual leading 1, see below)"
- mantissaBits := Float precision - 1.
-
- normals := {Float pi. Float pi * 100.0. Float pi/ -100.0. Float fmax. Float fminNormalized}.
- denormals := {0.0. Float negativeZero. Float fminNormalized predecessor. Float fmin negated}.
- exceptionals := {Float nan. Float infinity. Float negativeInfinity.}.
- normalPowersOfTwo := (-10 to: 10) collect: [:i | 1.0 timesTwoPower: i].
- denormalPowersOfTwo := (Float emin - mantissaBits to: Float emin - 1) collect: [:i | 1.0 timesTwoPower: i].
-
- normals do: [:aNormalFloat |
- "Assume the mantissa is written in least 52 bits of hex format, with an implied 1 on position 53"
- self
- assert: (((Integer readFrom: aNormalFloat hex base: 16) bitAnd: 1<<mantissaBits-1) bitOr: 1<<mantissaBits)
- equals: aNormalFloat significandAsInteger].
-
- denormals , exceptionals do: [:aDenormalOrExceptionalFloat |
- "For every other Float, zero, denormal or exceptional, no implied leading one"
- self
- assert: ((Integer readFrom: aDenormalOrExceptionalFloat hex base: 16) bitAnd: 1<<mantissaBits-1)
- equals: aDenormalOrExceptionalFloat significandAsInteger].
-
- normalPowersOfTwo do: [:aNormalPowerOfTwoFloat |
- "The significand of a power of two is a power of two, with high bit of expected precision"
- self assert: aNormalPowerOfTwoFloat significandAsInteger isPowerOfTwo.
- self assert: aNormalPowerOfTwoFloat significandAsInteger highBit equals: Float precision.
- self assert: aNormalPowerOfTwoFloat successor significandAsInteger equals: aNormalPowerOfTwoFloat significandAsInteger + 1.
- "The last one is not true for fminNormalized"
- aNormalPowerOfTwoFloat = Float fminNormalized or: [
- self assert: aNormalPowerOfTwoFloat predecessor significandAsInteger equals: aNormalPowerOfTwoFloat significandAsInteger * 2 - 1]].
-
- denormalPowersOfTwo do: [:aDenormalPowerOfTwoFloat |
- "The significand of a denormal power of two is a power of two, just with less bits"
- self assert: aDenormalPowerOfTwoFloat significandAsInteger isPowerOfTwo.
- self assert: aDenormalPowerOfTwoFloat significandAsInteger highBit equals: Float precision + aDenormalPowerOfTwoFloat exponent - Float emin.
- aDenormalPowerOfTwoFloat successor = Float fminNormalized or: [
- self assert: aDenormalPowerOfTwoFloat successor significandAsInteger equals: aDenormalPowerOfTwoFloat significandAsInteger + 1].
- self assert: aDenormalPowerOfTwoFloat predecessor significandAsInteger equals: aDenormalPowerOfTwoFloat significandAsInteger - 1.].
-
- "Well known value for a few extremal cases"
- self assert: Float fmax significandAsInteger equals: 1 << Float precision - 1.
- self assert: Float fmin significandAsInteger equals: 1.
- self assert: 0.0 significandAsInteger equals: 0.
- self assert: Float infinity significandAsInteger equals: 0.
- self assert: Float nan significandAsInteger > 0!
Item was removed:
- ----- Method: FloatTest>>testSinh (in category 'tests - mathematical functions') -----
- testSinh
- self assertIsPositiveZero: 0.0 sinh.
- self assertIsNegativeZero: Float negativeZero sinh.
- self deny: Float infinity sinh isFinite.
- self assert: (2.0 cosh squared - 2.0 sinh squared closeTo: 1).
- self assert: (2.0 sinh negated closeTo: 2.0 negated sinh).!
Item was removed:
- ----- Method: FloatTest>>testSqrtFallback (in category 'tests - mathematical functions') -----
- testSqrtFallback
- | fallBackMethod |
- fallBackMethod := Float>>#sqrt.
- {Float fmin. Float fmin * 2.0. Float fmin * 63.0. Float fmax. Float fmax predecessor predecessor.
- 1.0. 2.0. 3.0. 4.0. 5.0}
- do: [:f |
- | s sm sp |
- "check against the primitives - if they are absent, it does not test anything..."
- s := fallBackMethod valueWithReceiver: f arguments: Array new.
- self assert: s equals: f sqrt.
-
- "in case we don't have the primitive, use exact arithmetic and a bit of logic"
- sm := s asTrueFraction - (s ulp asTrueFraction / 2).
- sp := s asTrueFraction + (s ulp asTrueFraction / 2).
-
- self assert: s asTrueFraction squared < f ==> [sp squared > f]
- description: '(s)^2 < (s+ulp/2)^2 <= f => s is more than ulp/2 away from the true square root of f'.
- self assert: s asTrueFraction squared > f ==> [sm squared < f]
- description: 'f <= (s-ulp/2)^2 < (s)^2 ==> s is more than ulp/2 away from the true square root of f'].
- self assertIsNegativeZero: (fallBackMethod valueWithReceiver: Float negativeZero arguments: Array new).
- self assertIsPositiveZero: (fallBackMethod valueWithReceiver: 0.0 arguments: Array new).
- self assert: (fallBackMethod valueWithReceiver: Float nan arguments: Array new) isNaN.
- self assert: (fallBackMethod valueWithReceiver: Float infinity arguments: Array new) equals: Float infinity.
- self should: [fallBackMethod valueWithReceiver: -2.0 arguments: Array new] raise: DomainError!
Item was removed:
- ----- Method: FloatTest>>testStoreBase16 (in category 'tests - printing') -----
- testStoreBase16
- "This bug was reported in mantis http://bugs.squeak.org/view.php?id=6695"
-
- self
- assert: (20.0 storeStringBase: 16) = '16r14.0'
- description: 'the radix prefix should not be omitted, except in base 10'!
Item was removed:
- ----- Method: FloatTest>>testStoreOn (in category 'tests') -----
- testStoreOn
- "If storeOn: prints exactly and the parser avoid cumulating round off Errors,
- then Float should be read back exactly.
- Note: there is no guarantee to restore the bit pattern of NaN though"
-
- self assert: (Compiler evaluate: Float halfPi storeString) = Float halfPi.
- self assert: (Compiler evaluate: Float halfPi negated storeString) = Float halfPi negated.
- self assert: (Compiler evaluate: Float infinity storeString) = Float infinity.
- self assert: (Compiler evaluate: Float negativeInfinity storeString) = Float negativeInfinity.
- self assert: (Compiler evaluate: Float nan storeString) isNaN.!
Item was removed:
- ----- Method: FloatTest>>testStringAsNumber (in category 'tests - conversion') -----
- testStringAsNumber
- "This covers parsing in Number>>readFrom:"
- | aFloat |
- aFloat := '10r-12.3456' asNumber.
- self assert: -12.3456 = aFloat.
- aFloat := '10r-12.3456e2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '10r-12.3456d2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '10r-12.3456q2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '-12.3456q2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '12.3456q2' asNumber.
- self assert: 1234.56 = aFloat.
- self
- should: [ 'invalid number' asNumber ]
- raise: NumberParserError!
Item was removed:
- ----- Method: FloatTest>>testTanh (in category 'tests - mathematical functions') -----
- testTanh
- self assertIsPositiveZero: 0.0 tanh.
- self assertIsNegativeZero: Float negativeZero tanh.
- self assert: (Float infinity tanh closeTo: 1).
- self assert: (2.0 cosh squared - 2.0 sinh squared closeTo: 1).
- self assert: (2.0 tanh negated closeTo: 2.0 negated tanh).!
Item was removed:
- ----- Method: FloatTest>>testTimesTwoPowerGradualUnderflow (in category 'tests - arithmetic') -----
- testTimesTwoPowerGradualUnderflow
- "Here is a vicious case where timesTwoPower is inexact because it underflows.
- And two consecutive inexact operations lead to a different result than a single one.
- Typically expressed as multiple of Float fmin in base 2,
- 2r1011*Float fmin shifted by -3 with round to nearest, tie to even mode:
- -> round(1.011) -> 1.0 = fmin
- But if first shifted by -2 then by -1:
- -> round(10.11) -> 11.0 = 3*fmin
- -> round(1.1) -> 10.0 = 2*fmin
- Or first shifted by -1 then by -2:
- -> round(101.1) -> 110.0 = 6*fmin
- -> round(1.1) -> 10.0 = 2*fmin
- A naive implementation that split the shift uncarefully might fail to handle such case correctly."
- | f |
- f := 2r1011 asFloat.
- "scan the whole range of possible exponents for this significand"
- Float fmin exponent + f exponent to: Float fmax exponent - f exponent
- do:
- [:exp |
- | g |
- g := f timesTwoPower: exp.
- self assert: (g timesTwoPower: Float fmin exponent - g exponent) = Float fmin].!
Item was removed:
- ----- Method: FloatTest>>testTimesTwoPowerOverflow (in category 'tests - arithmetic') -----
- testTimesTwoPowerOverflow
- self assert: (Float fminNormalized timesTwoPower: Float emax - Float emin) equals: (2.0 raisedTo: Float emax).
- self assert: (Float zero timesTwoPower: SmallInteger maxVal squared) equals: Float zero.
- !
Item was removed:
- ----- Method: FloatTest>>testTimesTwoPowerUnderflow (in category 'tests - arithmetic') -----
- testTimesTwoPowerUnderflow
- self assert: ((2.0 raisedTo: Float emax) timesTwoPower: Float emin - Float emax) equals: Float fminNormalized.
- self assert: (Float infinity timesTwoPower: SmallInteger minVal * SmallInteger maxVal) equals: Float infinity.
- !
Item was removed:
- ----- Method: FloatTest>>testTruncated (in category 'tests - conversion') -----
- testTruncated
- self assert: 1.0 truncated = 1.
- self assert: 1.1 truncated = 1.
- self assert: -2.0 truncated = -2.
- self assert: -2.1 truncated = -2.!
Item was removed:
- ----- Method: FloatTest>>testUlp (in category 'tests - characterization') -----
- testUlp
-
- {Float pi predecessor. Float pi. Float pi successor} do:
- [:f |
- self assert: (f * 2) ulp = (f ulp * 2).
- self assert: (f / 2) ulp = (f ulp / 2).
- self deny: f + f ulp = f.
- self deny: f - f ulp = f.
- "Tests below are valid as long as default rounding mode (to nearest even) is used"
- self assert: f significandAsInteger odd ==> (f ulp / 2.0 + f = f successor).
- self assert: f significandAsInteger even ==> (f ulp / 2.0 + f = f)].
-
- self assert: 0.0 ulp = Float fmin.
- self assert: 1.0 ulp = Float epsilon.
- self assert: Float nan ulp isNaN.
- self assert: Float infinity ulp = Float infinity.
- self assert: Float negativeInfinity ulp = Float infinity.
-
- self assert: ((0 to: Float precision - 1) allSatisfy: [:each | (Float fmin timesTwoPower: each) ulp = Float fmin]). !
Item was removed:
- ----- Method: FloatTest>>testZero1 (in category 'tests - zero behavior') -----
- testZero1
- "FloatTest new testZero1"
-
- self assert: Float negativeZero = 0 asFloat.
- self assert: (Float negativeZero at: 1) ~= (0 asFloat at: 1).
-
- "The negative zero has a bit representation that is different from the bit representation of the positive zero. Nevertheless, both values are defined to be equal."
- !
Item was removed:
- ----- Method: FloatTest>>testZero2 (in category 'tests - IEEE 754') -----
- testZero2
- self assert: (Float negativeZero asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
- '10000000000000000000000000000000'.
- self assert: (Float fromIEEE32Bit:
- (Integer readFrom: '10000000000000000000000000000000' readStream base: 2))
- = Float negativeZero!
Item was removed:
- ----- Method: FloatTest>>testZeroRaisedToNegativePower (in category 'tests - arithmetic') -----
- testZeroRaisedToNegativePower
- "this is a test related to http://bugs.squeak.org/view.php?id=6781"
-
- self should: [0.0 raisedTo: -1] raise: ZeroDivide.
- self should: [0.0 raisedTo: -1.0] raise: ZeroDivide.!
Item was removed:
- ClassTestCase subclass: #FractionTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: FractionTest>>assert:classAndValueEquals: (in category 'private') -----
- assert: a classAndValueEquals: b
- self assert: a class = b class.
- self assert: a = b!
Item was removed:
- ----- Method: FractionTest>>testCeiling (in category 'tests - conversions') -----
- testCeiling
- self assert: (3 / 2) ceiling = 2.
- self assert: (-3 / 2) ceiling = -1.!
Item was removed:
- ----- Method: FractionTest>>testDegreeCos (in category 'tests - mathematical functions') -----
- testDegreeCos
- "self run: #testDegreeCos"
-
- -361/3 to: 359/3 do: [:i |
- self assert: (i degreeCos closeTo: i degreesToRadians cos)].!
Item was removed:
- ----- Method: FractionTest>>testDegreeSin (in category 'tests - mathematical functions') -----
- testDegreeSin
- "self run: #testDegreeSin"
-
- -361/3 to: 359/3 do: [:i |
- self assert: (i degreeSin closeTo: i degreesToRadians sin)].!
Item was removed:
- ----- Method: FractionTest>>testExactRaisedTo (in category 'tests - mathematical functions') -----
- testExactRaisedTo
- "
- FractionTest new testExactRaisedTo
- "
- | f |
- self assert: (4/9 raisedTo: 1/2) classAndValueEquals: 2/3.
- self assert: (9/4 raisedTo: 1/2) classAndValueEquals: 3/2.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
- f := a / b.
- self assert: (f squared raisedTo: 1/2) classAndValueEquals: f.
- self assert: (f negated squared raisedTo: 1/2) classAndValueEquals: f.
- f := b / a.
- self assert: (f squared raisedTo: 1/2) classAndValueEquals: f.
- self assert: (f negated squared raisedTo: 1/2) classAndValueEquals: f ].
-
- self assert: (8/27 raisedTo: 1/3) classAndValueEquals: 2/3.
- self assert: (27/8 raisedTo: 1/3) classAndValueEquals: 3/2.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
- f := a / b.
- self assert: ((f raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f.
- self assert: ((f negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f negated.
- f := b / a.
- self assert: ((f raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f.
- self assert: ((f negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f negated ].
-
- self assert: (4/9 raisedTo: 3/2) classAndValueEquals: 8/27.
- self assert: (8/27 raisedTo: 2/3) classAndValueEquals: 4/9.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
- f := a / b.
- self assert: ((f raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
- self assert: ((f raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f.
- self assert: ((f negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
- self assert: ((f negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f.
- f := b / a.
- self assert: ((f raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
- self assert: ((f raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f.
- self assert: ((f negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
- self assert: ((f negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f ].
-
- self assert: (32/243 raisedTo: 3/5) classAndValueEquals: 8/27.
- self assert: (8/27 raisedTo: 5/3) classAndValueEquals: 32/243.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
- f := a / b.
- self assert: ((f raisedTo: 5) raisedTo: 3/5) classAndValueEquals: f*f*f.
- self assert: ((f raisedTo: 3) raisedTo: 5/3) classAndValueEquals: f*f*f*f*f.
- self assert: ((f negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (f*f*f) negated.
- self assert: ((f negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (f*f*f*f*f) negated.
-
- self assert: ((f raisedTo: -5) raisedTo: 3/5) classAndValueEquals: 1/(f*f*f).
- self assert: ((f raisedTo: -3) raisedTo: 5/3) classAndValueEquals: 1/(f*f*f*f*f).
- self assert: ((f negated raisedTo: -5) raisedTo: 3/5) classAndValueEquals: -1/(f*f*f).
- self assert: ((f negated raisedTo: -3) raisedTo: 5/3) classAndValueEquals: -1/(f*f*f*f*f).
- self assert: ((f raisedTo: 5) raisedTo: -3/5) classAndValueEquals: 1/(f*f*f).
- self assert: ((f raisedTo: 3) raisedTo: -5/3) classAndValueEquals: 1/(f*f*f*f*f).
- self assert: ((f negated raisedTo: 5) raisedTo: -3/5) classAndValueEquals: -1/(f*f*f).
- self assert: ((f negated raisedTo: 3) raisedTo: -5/3) classAndValueEquals: -1/(f*f*f*f*f).
-
- "No exact result => Float result"
- self assert: ((f raisedTo: 3) +1 raisedTo: 5/3) isFloat.
- self assert: ((f negated raisedTo: 3) -1 raisedTo: 5/3) isFloat.
-
- f := b / a.
- self assert: ((f raisedTo: 5) raisedTo: 3/5) classAndValueEquals: f*f*f.
- self assert: ((f raisedTo: 3) raisedTo: 5/3) classAndValueEquals: f*f*f*f*f.
- self assert: ((f negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (f*f*f) negated.
- self assert: ((f negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (f*f*f*f*f) negated.
-
- "No exact result => Float result"
- self assert: ((f raisedTo: 3) +1 raisedTo: 5/3) isFloat.
- self assert: ((f negated raisedTo: 3) -1 raisedTo: 5/3) isFloat ].!
Item was removed:
- ----- Method: FractionTest>>testExactSqrt (in category 'tests - mathematical functions') -----
- testExactSqrt
- "
- FractionTest new testExactSqrt
- "
- | f |
- self assert: (4/9) sqrt classAndValueEquals: 2/3.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :i :j |
- f := i / j.
- self assert: f squared sqrt classAndValueEquals: f.
- f := j / i.
- self assert: f squared sqrt classAndValueEquals: f ]!
Item was removed:
- ----- Method: FractionTest>>testFloor (in category 'tests - conversions') -----
- testFloor
- self assert: (3 / 2) floor = 1.
- self assert: (-3 / 2) floor = -2.!
Item was removed:
- ----- Method: FractionTest>>testFloorLog (in category 'tests - mathematical functions') -----
- testFloorLog
- self assert: (1/100 floorLog: 10) = -2.
- self assert: (((2 raisedTo: Float emax + 11)/3) floorLog: 10)
- = ((Float emax + 11)*2 log - 3 log) floor description: 'Fraction>>log should not overflow'.
- self assert: ((3/(2 raisedTo: Float precision - Float emin)) floorLog: 10)
- = ((Float emin - Float precision)*2 log + 3 log) floor description: 'Fraction>>log should not underflow'!
Item was removed:
- ----- Method: FractionTest>>testFloorLogExactness (in category 'tests - mathematical functions') -----
- testFloorLogExactness
-
- 1 + (Float fminDenormalized floorLog: 10) to: -1 do: [:n |
- self assert: ((10 raisedTo: n) floorLog: 10) = n].
-
- "Float version is not exact for at least 2 reasons:
- 1/(10 raisedTo: n) asFloat is not exact
- (aFloat log: radix) is not exact
-
- (1 + (Float fminDenormalized floorLog: 10) to: -1) count: [:n |
- ((10 raisedTo: n) asFloat floorLog: 10) ~= n]."
- !
Item was removed:
- ----- Method: FractionTest>>testFractionPrinting (in category 'tests - printing') -----
- testFractionPrinting
-
- self assert: (353/359) printString = '(353/359)'.
- self assert: ((2/3) printStringBase: 2) = '(10/11)'.
- self assert: ((2/3) storeStringBase: 2) = '(2r10/2r11)'.
- self assert: ((5/7) printStringBase: 3) = '(12/21)'.
- self assert: ((5/7) storeStringBase: 3) = '(3r12/3r21)'.
- self assert: ((11/13) printStringBase: 4) = '(23/31)'.
- self assert: ((11/13) storeStringBase: 4) = '(4r23/4r31)'.
- self assert: ((17/19) printStringBase: 5) = '(32/34)'.
- self assert: ((17/19) storeStringBase: 5) = '(5r32/5r34)'.
- self assert: ((23/29) printStringBase: 6) = '(35/45)'.
- self assert: ((23/29) storeStringBase: 6) = '(6r35/6r45)'.
- self assert: ((31/37) printStringBase: 7) = '(43/52)'.
- self assert: ((31/37) storeStringBase: 7) = '(7r43/7r52)'.
- self assert: ((41/43) printStringBase: 8) = '(51/53)'.
- self assert: ((41/43) storeStringBase: 8) = '(8r51/8r53)'.
- self assert: ((47/53) printStringBase: 9) = '(52/58)'.
- self assert: ((47/53) storeStringBase: 9) = '(9r52/9r58)'.
- self assert: ((59/61) printStringBase: 10) = '(59/61)'.
- self assert: ((59/61) storeStringBase: 10) = '(59/61)'.
- self assert: ((67/71) printStringBase: 11) = '(61/65)'.
- self assert: ((67/71) storeStringBase: 11) = '(11r61/11r65)'.
- self assert: ((73/79) printStringBase: 12) = '(61/67)'.
- self assert: ((73/79) storeStringBase: 12) = '(12r61/12r67)'.
- self assert: ((83/89) printStringBase: 13) = '(65/6B)'.
- self assert: ((83/89) storeStringBase: 13) = '(13r65/13r6B)'.
- self assert: ((97/101) printStringBase: 14) = '(6D/73)'.
- self assert: ((97/101) storeStringBase: 14) = '(14r6D/14r73)'.
- self assert: ((103/107) printStringBase: 15) = '(6D/72)'.
- self assert: ((103/107) storeStringBase: 15) = '(15r6D/15r72)'.
- self assert: ((109/113) printStringBase: 16) = '(6D/71)'.
- self assert: ((109/113) storeStringBase: 16) = '(16r6D/16r71)'.
- self assert: ((127/131) printStringBase: 17) = '(78/7C)'.
- self assert: ((127/131) storeStringBase: 17) = '(17r78/17r7C)'.
- self assert: ((137/139) printStringBase: 18) = '(7B/7D)'.
- self assert: ((137/139) storeStringBase: 18) = '(18r7B/18r7D)'.
- self assert: ((149/151) printStringBase: 19) = '(7G/7I)'.
- self assert: ((149/151) storeStringBase: 19) = '(19r7G/19r7I)'.
- self assert: ((157/163) printStringBase: 20) = '(7H/83)'.
- self assert: ((157/163) storeStringBase: 20) = '(20r7H/20r83)'.
- self assert: ((167/173) printStringBase: 21) = '(7K/85)'.
- self assert: ((167/173) storeStringBase: 21) = '(21r7K/21r85)'.
- self assert: ((179/181) printStringBase: 22) = '(83/85)'.
- self assert: ((179/181) storeStringBase: 22) = '(22r83/22r85)'.
- self assert: ((191/193) printStringBase: 23) = '(87/89)'.
- self assert: ((191/193) storeStringBase: 23) = '(23r87/23r89)'.
- self assert: ((197/199) printStringBase: 24) = '(85/87)'.
- self assert: ((197/199) storeStringBase: 24) = '(24r85/24r87)'.
- self assert: ((211/223) printStringBase: 25) = '(8B/8N)'.
- self assert: ((211/223) storeStringBase: 25) = '(25r8B/25r8N)'.
- self assert: ((227/229) printStringBase: 26) = '(8J/8L)'.
- self assert: ((227/229) storeStringBase: 26) = '(26r8J/26r8L)'.
- self assert: ((233/239) printStringBase: 27) = '(8H/8N)'.
- self assert: ((233/239) storeStringBase: 27) = '(27r8H/27r8N)'.
- self assert: ((241/251) printStringBase: 28) = '(8H/8R)'.
- self assert: ((241/251) storeStringBase: 28) = '(28r8H/28r8R)'.
- self assert: ((257/263) printStringBase: 29) = '(8P/92)'.
- self assert: ((257/263) storeStringBase: 29) = '(29r8P/29r92)'.
- self assert: ((269/271) printStringBase: 30) = '(8T/91)'.
- self assert: ((269/271) storeStringBase: 30) = '(30r8T/30r91)'.
- self assert: ((277/281) printStringBase: 31) = '(8T/92)'.
- self assert: ((277/281) storeStringBase: 31) = '(31r8T/31r92)'.
- self assert: ((283/293) printStringBase: 32) = '(8R/95)'.
- self assert: ((283/293) storeStringBase: 32) = '(32r8R/32r95)'.
- self assert: ((307/311) printStringBase: 33) = '(9A/9E)'.
- self assert: ((307/311) storeStringBase: 33) = '(33r9A/33r9E)'.
- self assert: ((313/317) printStringBase: 34) = '(97/9B)'.
- self assert: ((313/317) storeStringBase: 34) = '(34r97/34r9B)'.
- self assert: ((331/337) printStringBase: 35) = '(9G/9M)'.
- self assert: ((331/337) storeStringBase: 35) = '(35r9G/35r9M)'.
- self assert: ((347/349) printStringBase: 36) = '(9N/9P)'.
- self assert: ((347/349) storeStringBase: 36) = '(36r9N/36r9P)'.
-
- self assert: ((-2/3) printStringBase: 2) = '(-10/11)'.
- self assert: ((-2/3) storeStringBase: 2) = '(-2r10/2r11)'.
- self assert: ((5 / -7) printStringBase: 3) = '(-12/21)'.
- self assert: ((5 / -7) storeStringBase: 3) = '(-3r12/3r21)'.
- !
Item was removed:
- ----- Method: FractionTest>>testFractionReading (in category 'tests - printing') -----
- testFractionReading
- "Numerator literal syntax"
- self assert: (Fraction readFrom: '4') equals: 4.
- self assert: (Fraction readFrom: '45') equals: 45.
- self assert: (Fraction readFrom: '-45') equals: -45.
- self assert: (Fraction readFrom: '4e2') equals: 400.
- self assert: (Fraction readFrom: '33e-2') equals: 33/100.
- self assert: (Fraction readFrom: '4r123') equals: 1 * 4 + 2 * 4 + 3.
- self assert: (Fraction readFrom: '-4r123e5') equals: 1 * 4 + 2 * 4 + 3 * (4 raisedTo: 5) negated.
-
- "Numerator/Denominator literals syntax"
- self assert: (Fraction readFrom: '23/17') equals: 23/17.
- self assert: (Fraction readFrom: '-122/17') equals: -122/17.
- self assert: (Fraction readFrom: '-3r21e4/8r57e6') equals: (2 * 3 + 1 * (3 raisedTo: 4)) negated /(5 * 8 + 7 * (8 raisedTo: 6)).
-
- "Decimal integer part.fraction part literal syntax"
- self assert: (Fraction readFrom: '0.1') equals: 1/10.
- self assert: (Fraction readFrom: '0.071') equals: 71/1000.
- self assert: (Fraction readFrom: '-0.071e2') equals: -71/10.
- self assert: (Fraction readFrom: '0.07100e-2') equals: 71/100000.
-
- "Extended syntax"
- self assert: (Fraction readFrom: '+4') equals: 4.
- self assert: (Fraction readFrom: '.13') equals: 13/100.
- self assert: (Fraction readFrom: '30.e-2') equals: 3/10.
- self assert: (Fraction readFrom: '+30.e+4') equals: 300000.
-
- "Errors"
- self should: [(Fraction readFrom: '')] raise: Error.
- self should: [(Fraction readFrom: '.')] raise: Error.
- self should: [(Fraction readFrom: 'e3')] raise: Error.
- self should: [(Fraction readFrom: '+e2')] raise: Error.
- self should: [(Fraction readFrom: '-.e+2')] raise: Error.
- self should: [(Fraction readFrom: '/2')] raise: Error.!
Item was removed:
- ----- Method: FractionTest>>testFractionReadingBase (in category 'tests - printing') -----
- testFractionReadingBase
- {17/25. -132/271. 127. -1000} do: [:fraction |
- #(2 3 8 10 16) do: [:base |
- | printed |
- printed := (fraction printStringBase: base) copyWithoutAll: '()'.
- self assert: (Fraction readFrom: printed base: base) equals: fraction]].!
Item was removed:
- ----- Method: FractionTest>>testInexactRaisedTo (in category 'tests - mathematical functions') -----
- testInexactRaisedTo
- "
- FractionTest new testInexactRaisedTo
- "
- self assert: (((1 << 1024 + 1) / (1 << 1024 + 3)) raisedTo: 1/3) = 1.0.
- self assert: (((1 << 1024 + 1) / (1 << 1024 + 3)) negated raisedTo: 1/3) = -1.0!
Item was removed:
- ----- Method: FractionTest>>testInexactSqrt (in category 'tests - mathematical functions') -----
- testInexactSqrt
- "
- FractionTest new testInexactSqrt
- "
- self assert: ((1 << 1024 + 1) / (1 << 1024 + 3)) sqrt = 1.0!
Item was removed:
- ----- Method: FractionTest>>testIntegerWholeDivision (in category 'tests - arithmetic') -----
- testIntegerWholeDivision
-
- self assert: 4 / (2/3) classAndValueEquals: 6.
-
- self assert: 4 / (-2/3) classAndValueEquals: -6.
-
- self assert: -4 / (-2/3) classAndValueEquals: 6.
-
- self assert: -4 / (2/3) classAndValueEquals: -6.!
Item was removed:
- ----- Method: FractionTest>>testIntegerWholeMultiplication (in category 'tests - arithmetic') -----
- testIntegerWholeMultiplication
-
- self assert: 4 * (3/2) classAndValueEquals: 6.
-
- self assert: 4 * (-3/2) classAndValueEquals: -6.
-
- self assert: -4 * (-3/2) classAndValueEquals: 6.
-
- self assert: -4 * (3/2) classAndValueEquals: -6.!
Item was removed:
- ----- Method: FractionTest>>testLn (in category 'tests - mathematical functions') -----
- testLn
- self assert: ((1/100) ln closeTo: -2 * 10 ln).
- self assert: (((2 raisedTo: Float emax + 11)/3) ln closeTo: (Float emax + 11)*2 ln - 3 ln) description: 'Fraction>>ln should not overflow'.
- self assert: ((3/(2 raisedTo: Float precision - Float emin)) ln closeTo: (Float emin - Float precision)*2 ln + 3 ln) description: 'Fraction>>ln should not underflow'!
Item was removed:
- ----- Method: FractionTest>>testLog (in category 'tests - mathematical functions') -----
- testLog
- self assert: ((1/100) log closeTo: -2).
- self assert: (((2 raisedTo: Float emax + 11)/3) log closeTo: (Float emax + 11)*2 log - 3 log) description: 'Fraction>>log should not overflow'.
- self assert: ((3/(2 raisedTo: Float precision - Float emin)) log closeTo: (Float emin - Float precision)*2 log + 3 log) description: 'Fraction>>log should not underflow'!
Item was removed:
- ----- Method: FractionTest>>testNthRoot (in category 'tests - mathematical functions') -----
- testNthRoot
- self assert: ((-2 raisedTo: 35) / (3 raisedTo: 20) raisedTo: 1/5) equals: (-2 raisedTo: 7) / (3 raisedTo: 4).
- self assert: (1 / (1 << 2000) raisedTo: 1/100) equals: 1 / (1 << 20)!
Item was removed:
- ----- Method: FractionTest>>testRaisedToErrorConditions (in category 'tests - mathematical functions') -----
- testRaisedToErrorConditions
- "
- FractionTest new testRaisedToErrorConditions
- "
- self should: [ (-1/16) raisedTo: 1/4 ] raise: ArithmeticError.
- self should: [ ((1 << 1024 + 1) / (1 << 1024 + 3)) negated raisedTo: 1/4 ] raise: ArithmeticError!
Item was removed:
- ----- Method: FractionTest>>testReciprocal (in category 'tests - arithmetic') -----
- testReciprocal
-
- self
- assert: (1/2) reciprocal classAndValueEquals: 2;
- assert: (3/4) reciprocal equals: (4/3);
- assert: (-1/3) reciprocal classAndValueEquals: -3;
- assert: (-3/5) reciprocal equals: (-5/3)!
Item was removed:
- ----- Method: FractionTest>>testRounded (in category 'tests - conversions') -----
- testRounded
- self assert: (4 / 5) rounded = 1.
- self assert: (6 / 5) rounded = 1.
- self assert: (-4 / 5) rounded = -1.
- self assert: (-6 / 5) rounded = -1.
-
- "In case of tie, round to upper magnitude"
- self assert: (3 / 2) rounded = 2.
- self assert: (-3 / 2) rounded = -2.!
Item was removed:
- ----- Method: FractionTest>>testSqrtErrorConditions (in category 'tests - mathematical functions') -----
- testSqrtErrorConditions
- "
- FractionTest new testSqrtErrorConditions
- "
- self should: [ (-1/4) sqrt ] raise: DomainError.
- self should: [ ((1 << 1024 + 1) / (1 << 1024 + 3)) negated sqrt ] raise: DomainError!
Item was removed:
- ----- Method: FractionTest>>testThatFractionDenominatorIsPositive (in category 'tests - invariants') -----
- testThatFractionDenominatorIsPositive
- self assert: (-3 / 2) numerator negative description: 'a Fraction sign is allways carried by its numerator'.
- self assert: (-3 / 2) denominator positive description: 'a Fraction denominator is allways positive'.
-
- self assert: (3 / -2) numerator negative description: 'a Fraction sign is allways carried by its numerator'.
- self assert: (3 / -2) denominator positive description: 'a Fraction denominator is allways positive'.
-
- self assert: (-3 / -2) numerator positive description: 'two negative signs are simplified'.
- self assert: (-3 / -2) denominator positive description: 'a Fraction denominator is allways positive'.!
Item was removed:
- ----- Method: FractionTest>>testThatFractionIsReduced (in category 'tests - invariants') -----
- testThatFractionIsReduced
- self assert: (4 / 6) numerator equals: 2.
- self assert: (4 / 6) denominator equals: 3.
-
- self assert: (4 / 2) classAndValueEquals: 2.
-
- "Fraction class>>#numerator:denominator: does not automatically reduce the Fraction.
- Since it does not guaranty above invariant, it must be used with care."
- self assert: (Fraction numerator: 4 denominator: 6) numerator equals: 4.
- self assert: (Fraction numerator: 4 denominator: 6) denominator equals: 6.
- self assert: (Fraction numerator: 4 denominator: 6) reduced numerator equals: 2.
- self assert: (Fraction numerator: 4 denominator: 6) reduced denominator equals: 3.!
Item was removed:
- ----- Method: FractionTest>>testTruncated (in category 'tests - conversions') -----
- testTruncated
- self assert: (3 / 2) truncated = 1.
- self assert: (-3 / 2) truncated = -1.!
Item was removed:
- ----- Method: FractionTest>>testWholeDifference (in category 'tests - arithmetic') -----
- testWholeDifference
-
- self assert: (2/3) - (5/3) classAndValueEquals: -1.!
Item was removed:
- ----- Method: FractionTest>>testWholeDivision (in category 'tests - arithmetic') -----
- testWholeDivision
-
- self assert: (3/2) / (3/4) classAndValueEquals: 2.
-
- self assert: (3/2) / (-3/4) classAndValueEquals: -2.
-
- self assert: (-3/2) / (-3/4) classAndValueEquals: 2.
-
- self assert: (-3/2) / (3/4) classAndValueEquals: -2.!
Item was removed:
- ----- Method: FractionTest>>testWholeMultiplication (in category 'tests - arithmetic') -----
- testWholeMultiplication
-
- self assert: (3/2) * (4/3) classAndValueEquals: 2.
-
- self assert: (3/2) * (-4/3) classAndValueEquals: -2.
-
- self assert: (-3/2) * (-4/3) classAndValueEquals: 2.
-
- self assert: (-3/2) * (4/3) classAndValueEquals: -2.!
Item was removed:
- ----- Method: FractionTest>>testWholeSum (in category 'tests - arithmetic') -----
- testWholeSum
-
- self assert: (5/3) + (1/3) classAndValueEquals: 2.!
Item was removed:
- TestCase subclass: #InstVarRefLocatorTest
- instanceVariableNames: 'tt'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !InstVarRefLocatorTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class InstVarRefLocator. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: InstVarRefLocatorTest>>example1 (in category 'examples') -----
- example1
- | ff |
- (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']].
- ^ ff.!
Item was removed:
- ----- Method: InstVarRefLocatorTest>>example2 (in category 'examples') -----
- example2
- | ff|
- ff := 1.
- (1 < 2) ifTrue: [ff ifNotNil: [ff := 'hallo']].
- ^ ff.!
Item was removed:
- ----- Method: InstVarRefLocatorTest>>hasInstVarRef: (in category 'private') -----
- hasInstVarRef: aMethod
- "Answer whether the receiver references an instance variable."
-
- | scanner end printer |
-
- scanner := InstructionStream on: aMethod.
- printer := InstVarRefLocator new.
- end := scanner method endPC.
-
- [scanner pc <= end] whileTrue: [
- (printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
- ].
- ^false!
Item was removed:
- ----- Method: InstVarRefLocatorTest>>testExample1 (in category 'tests') -----
- testExample1
- | method |
-
- method := self class compiledMethodAt: #example1.
- self assert: (self hasInstVarRef: method).!
Item was removed:
- ----- Method: InstVarRefLocatorTest>>testExample2 (in category 'tests') -----
- testExample2
- | method |
-
- method := self class compiledMethodAt: #example2.
- self deny: (self hasInstVarRef: method).!
Item was removed:
- ----- Method: InstVarRefLocatorTest>>testInstructions (in category 'tests') -----
- testInstructions
- Object methodDict do: [:method | | scanner printer end |
- scanner := InstructionStream on: method.
- printer := InstVarRefLocator new.
- end := scanner method endPC.
-
- [scanner pc <= end] whileTrue: [
- printer interpretNextInstructionUsing: scanner.
- ].
- ].!
Item was removed:
- TestCase subclass: #InstructionClientTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !InstructionClientTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class InstructionClient. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: InstructionClientTest>>testInstructions (in category 'tests') -----
- testInstructions
- "just interpret all of methods of Object"
-
- | client |
- client := InstructionClient new.
- Object methodDict do: [:method |
- | scanner |
- scanner := (InstructionStream on: method).
- [scanner pc <= method endPC] whileTrue: [
- scanner interpretNextInstructionFor: client]].
- !
Item was removed:
- ClassTestCase subclass: #InstructionPrinterTest
- instanceVariableNames: 'tt'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !InstructionPrinterTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class InstructionPrinter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: InstructionPrinterTest>>example1 (in category 'examples') -----
- example1
- | ff|
- (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']].
- ^ ff.!
Item was removed:
- ----- Method: InstructionPrinterTest>>testInstructions (in category 'tests') -----
- testInstructions
- "just print all of methods of Object and see if no error accours"
-
- | printer |
- printer := InstructionPrinter.
- Object methodDict do: [:method |
- String streamContents: [:stream |
- (printer on: method) printInstructionsOn: stream]].
- !
Item was removed:
- TestCase subclass: #IntegerDigitLogicTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testAndSingleBitWithMinusOne (in category 'tests') -----
- testAndSingleBitWithMinusOne
- "And a single bit with -1 and test for same value"
- 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].!
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testLargeShift (in category 'tests') -----
- testLargeShift
- "A sanity check for LargeInteger bitShifts"
-
- | suite |
- suite := #( "some numbers on 64 bits or less"
- '101101011101001100110111110110011101101101000001110110011'
- '1101101001100010011001101110100000111011011010100011101100'
- '101101101011110011001100110011011101011001111000100011101000'
- '10101101101000101001111111111100101101011001011000100011100000'
- '1000101010101001111011101010111001011111110011110001000110000000'
- '1100101010101000010011101000110010111110110011110000000000000001' ).
- "65 bits or less"
- suite := suite , (suite collect: [:e | '1' , e reversed ]).
- "129 bits or less"
- suite := suite , (suite collect: [:e | e ,e ]).
- suite do: [:bits | | num ls rs |
- num := Integer readFrom: bits readStream base: 2.
- 0 to: bits size-1 do: [:shift |
- ls := (num bitShift: shift) printStringBase: 2.
- rs := (num bitShift: 0-shift) printStringBase: 2.
- self assert: ls = (bits , (String new: shift withAll: $0)).
- self assert: rs = (bits copyFrom: 1 to: bits size - shift).
- ]].!
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testMixedSignDigitLogic (in category 'tests') -----
- testMixedSignDigitLogic
- "Verify that mixed sign logic with large integers works."
- self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE!
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testNBitAndNNegatedEqualsN (in category 'tests') -----
- testNBitAndNNegatedEqualsN
- "Verify that (n bitAnd: n negated) = n for single bits"
- | n |
- 1 to: 100 do: [:i | n := 1 bitShift: i.
- self assert: (n bitAnd: n negated) = n]!
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testNNegatedEqualsNComplementedPlusOne (in category 'tests') -----
- testNNegatedEqualsNComplementedPlusOne
- "Verify that n negated = (n complemented + 1) for single bits"
- | n |
- 1 to: 100 do: [:i | n := 1 bitShift: i.
- self assert: n negated = ((n bitXor: -1) + 1)]!
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testShiftMinusOne1LeftThenRight (in category 'tests') -----
- testShiftMinusOne1LeftThenRight
- "Shift -1 left then right and test for 1"
- 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1].
- !
Item was removed:
- ----- Method: IntegerDigitLogicTest>>testShiftOneLeftThenRight (in category 'tests') -----
- testShiftOneLeftThenRight
- "Shift 1 bit left then right and test for 1"
- 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1].
- !
Item was removed:
- TestCase subclass: #IntegerTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: IntegerTest>>assert:classAndValueEquals: (in category 'private') -----
- assert: a classAndValueEquals: b
- self assert: a class = b class.
- self assert: a = b!
Item was removed:
- ----- Method: IntegerTest>>testBenchFib (in category 'tests - benchmarks') -----
- testBenchFib
-
- self assert: (0 benchFib = 1).
- self assert: (1 benchFib = 1).
- self assert: (2 benchFib = 3).
- !
Item was removed:
- ----- Method: IntegerTest>>testBigReceiverInexactNthRoot (in category 'tests - mathematical functions') -----
- testBigReceiverInexactNthRoot
- "
- IntegerTest new testBigReceiverInexactNthRoot
- "
-
- "Inexact 3rd root (not a whole cube number), so a Float must be answered.
- However, receiver is too big for Float arithmethic."
- | bigNum result |
- bigNum := (100 factorial raisedTo: 3) + 1. "Add 1 so it is not a whole cube"
- self assert: bigNum asFloat isInfinite. "Otherwise, we chose a bad sample"
- result := bigNum nthRoot: 3.
- self assert: result isFloat.
- self deny: result isInfinite.
- self assert: result = 100 factorial asFloat. "No other float is closer. See following line"
- self assert: 100 factorial asFloat = (100 factorial+1) asFloat!
Item was removed:
- ----- Method: IntegerTest>>testBigReceiverInexactSqrt (in category 'tests - mathematical functions') -----
- testBigReceiverInexactSqrt
- "
- IntegerTest new testBigReceiverInexactSqrt
- "
-
- "Inexact 3rd root (not a whole cube number), so a Float must be answered.
- However, receiver is too big for Float arithmethic."
- | bigNum result |
- bigNum := 100 factorial squared + 1. "Add 1 so it is not a whole square"
- self assert: bigNum asFloat isInfinite. "Otherwise, we chose a bad sample"
- result := bigNum sqrt.
- self assert: result isFloat.
- self deny: result isInfinite.
- self assert: result = 100 factorial asFloat. "No other float is closer. See following lines"
- self assert: (result successor asFraction squared - bigNum) abs >= (result asFraction squared - bigNum) abs.
- self assert: (result predecessor asFraction squared - bigNum) abs >= (result asFraction squared - bigNum) abs!
Item was removed:
- ----- Method: IntegerTest>>testBitAt (in category 'tests - bitLogic') -----
- testBitAt
- | trials bitSequence2 |
-
- self
- assert: ((1 to: 100) allSatisfy: [:i | (0 bitAt: i) = 0])
- description: 'all bits of zero are set to zero'.
-
- self
- assert: ((1 to: 100) allSatisfy: [:i | (-1 bitAt: i) = 1])
- description: 'In two complements, all bits of -1 are set to 1'.
-
-
- trials := #(
- '2r10010011'
- '2r11100100'
- '2r10000000'
- '2r0000101011011001'
- '2r1000101011011001'
- '2r0101010101011000'
- '2r0010011110110010'
- '2r0010011000000000'
- '2r00100111101100101000101011011001'
- '2r01110010011110110010100110101101'
- '2r10101011101011001010000010110110'
- '2r10101000000000000000000000000000'
- '2r0010101110101001110010100000101101100010011110110010100010101100'
- '2r1010101110101100101000001011011000100111101100101000101011011001'
- '2r1010101110101000000000000000000000000000000000000000000000000000').
- trials do: [:bitSequence | | aNumber |
- aNumber := Number readFrom: bitSequence.
- bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: (aNumber bitAt: i))].
- self assert: bitSequence2 = bitSequence].
-
- trials do: [:bitSequence | | bitInvert |
- bitInvert := -1 - (Number readFrom: bitSequence).
- bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: 1 - (bitInvert bitAt: i))].
- self assert: bitSequence2 = bitSequence description: '-1-x is similar to a bitInvert operation in two complement']!
Item was removed:
- ----- Method: IntegerTest>>testBitCount (in category 'tests - bitLogic') -----
- testBitCount
- self assert: 2r0 bitCount equals: 0.
- self assert: 2r1 bitCount equals: 1.
- self assert: 2r101 bitCount equals: 2.
- self assert: 2r1010000000000000000100000000000000000000000010000000000001001 bitCount equals: 6.
-
- 1 to: 100 do: [:i |
- self assert: (2r1 << i) bitCount equals: 1.
- self assert: (2r101 << i) bitCount equals: 2].
-
- self should: [-2 bitCount] raise: Error description: 'Negative integers have an infinite number of leading 1 in two complement representation'.!
Item was removed:
- ----- Method: IntegerTest>>testBitLogic (in category 'tests - bitLogic') -----
- testBitLogic
- "This little suite of tests is designed to verify correct operation of most
- of Squeak's bit manipulation code, including two's complement
- representation of negative values. It was written in a hurry and
- is probably lacking several important checks."
-
- "Shift 1 bit left then right and test for 1"
- "self run: #testBitLogic"
- | n |
- 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1].
-
- "Shift -1 left then right and test for 1"
- 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1].
-
- "And a single bit with -1 and test for same value"
- 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].
-
- "Verify that (n bitAnd: n negated) = n for single bits"
- 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: (n bitAnd: n negated) = n].
-
- "Verify that n negated = (n complemented + 1) for single bits"
- 1 to: 100 do: [:i |
- n := 1 bitShift: i.
- self assert: n negated = ((n bitXor: -1) + 1)].
-
- "Verify that (n + n complemented) = -1 for single bits"
- 1 to: 100 do: [:i |
- n := 1 bitShift: i.
- self assert: (n + (n bitXor: -1)) = -1].
-
- "Verify that n negated = (n complemented +1) for single bits"
- 1 to: 100 do: [:i |
- n := 1 bitShift: i.
- self assert: n negated = ((n bitXor: -1) + 1)].
-
- self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE.!
Item was removed:
- ----- Method: IntegerTest>>testBitReversal (in category 'tests - bitLogic') -----
- testBitReversal
- { 0. 1. SmallInteger maxVal-1. SmallInteger maxVal. SmallInteger maxVal+1. (2 raisedTo: 64)-1091. (2 raisedTo: 64)-1090. (2 raisedTo: 64)-1 } do:
- [ : fixture |
- | printedThenReversed reversedThenPrinted |
- printedThenReversed := (fixture printPaddedWith: $0 to: 64 base: 2) reversed.
- reversedThenPrinted := (fixture bitReverse: 64) printPaddedWith: $0 to: 64 base: 2.
- self assert: printedThenReversed = reversedThenPrinted ]!
Item was removed:
- ----- Method: IntegerTest>>testCreationFromBytes1 (in category 'tests - instance creation') -----
- testCreationFromBytes1
- "self run: #testCreationFromBytes1"
- "it is illegal for a LargeInteger to be less than SmallInteger maxVal."
- "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs SmallInteger maxVal as an instance of SmallInteger. "
-
- | maxSmallInt hexString
- builtInteger bytes |
- maxSmallInt := SmallInteger maxVal.
- hexString := maxSmallInt printStringHex.
- hexString size odd ifTrue:
- [hexString := '0', hexString].
- self assert: hexString size / 2 = maxSmallInt digitLength.
- bytes := ((1 to: hexString size by: 2) collect:
- [:i| Number readFrom: (hexString copyFrom: i to: i + 1) base: 16]) reversed.
- builtInteger := bytes size > 4
- ifTrue:
- [Integer
- byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)
- byte5: (bytes at: 5) byte6: (bytes at: 6) byte7: (bytes at: 7) byte8: (bytes at: 8)]
- ifFalse:
- [Integer
- byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)].
- self assert: builtInteger = maxSmallInt.
- self assert: builtInteger class = SmallInteger
- !
Item was removed:
- ----- Method: IntegerTest>>testCreationFromBytes2 (in category 'tests - instance creation') -----
- testCreationFromBytes2
- "self run: #testCreationFromBytes2"
-
- "it is illegal for a LargeInteger to be less than SmallInteger maxVal."
- "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger. "
- | maxSmallInt hexString builtInteger bytes |
- maxSmallInt := SmallInteger maxVal.
- hexString := (maxSmallInt + 1) printStringHex.
- hexString size odd ifTrue:
- [hexString := '0', hexString].
- self assert: hexString size / 2 = maxSmallInt digitLength.
- bytes := ((1 to: hexString size by: 2) collect:
- [:i| Number readFrom: (hexString copyFrom: i to: i + 1) base: 16]) reversed.
- builtInteger := bytes size > 4
- ifTrue:
- [Integer
- byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)
- byte5: (bytes at: 5) byte6: (bytes at: 6) byte7: (bytes at: 7) byte8: (bytes at: 8)]
- ifFalse:
- [Integer
- byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)].
- self assert: builtInteger = (maxSmallInt + 1).
- self deny: builtInteger class = SmallInteger
- !
Item was removed:
- ----- Method: IntegerTest>>testCreationFromBytes3 (in category 'tests - instance creation') -----
- testCreationFromBytes3
- "self run: #testCreationFromBytes3"
-
- "it is illegal for a LargeInteger to be less than SmallInteger maxVal."
- "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger. "
- | maxSmallInt hexString
- builtInteger bytes |
- maxSmallInt := SmallInteger maxVal.
- hexString := (maxSmallInt - 1) printStringHex.
- hexString size odd ifTrue:
- [hexString := '0', hexString].
- self assert: hexString size / 2 = maxSmallInt digitLength.
- bytes := ((1 to: hexString size by: 2) collect:
- [:i| Number readFrom: (hexString copyFrom: i to: i + 1) base: 16]) reversed.
- builtInteger := bytes size > 4
- ifTrue:
- [Integer
- byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)
- byte5: (bytes at: 5) byte6: (bytes at: 6) byte7: (bytes at: 7) byte8: (bytes at: 8)]
- ifFalse:
- [Integer
- byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)].
- self assert: builtInteger = (maxSmallInt - 1).
- self assert: builtInteger class = SmallInteger
- !
Item was removed:
- ----- Method: IntegerTest>>testCrossSumBase (in category 'tests - arithmetic') -----
- testCrossSumBase
- "self run: #testCrossSumBase"
-
- self assert: (
- ((-20 to: 20) collect: [:each | each crossSumBase: 10]) asArray =
- #(2 10 9 8 7 6 5 4 3 2 1 9 8 7 6 5 4 3 2 1 0 1 2 3 4 5 6 7 8 9 1 2 3 4 5 6 7 8 9 10 2)).
- self assert: (
- ((-20 to: 20) collect: [:each | each crossSumBase: 2]) asArray =
- #(2 3 2 2 1 4 3 3 2 3 2 2 1 3 2 2 1 2 1 1 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2)).
- self should: [10 crossSumBase: 1] raise: AssertionFailure!
Item was removed:
- ----- Method: IntegerTest>>testDegreeCos (in category 'tests - mathematical functions') -----
- testDegreeCos
- "self run: #testDegreeCos"
-
- "Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic"
- self assert: (45 degreeCos squared - (1/2)) abs <= Float epsilon.
- self assert: (60 degreeCos - (1/2)) abs <= Float epsilon.
- self assert: (120 degreeCos + (1/2)) abs <= Float epsilon.
- -360 to: 360 do: [:i |
- self assert: (i degreeCos closeTo: i degreesToRadians cos)].
-
- "Following tests use strict equality which is a requested property of degreeCos"
- -10 to: 10 do: [:k |
- self assert: (k*360 + 90) degreeCos = 0.
- self assert: (k*360 - 90) degreeCos = 0.
- self assert: (k*360 + 180) degreeCos + 1 = 0.
- self assert: (k*360) degreeCos - 1 = 0.].!
Item was removed:
- ----- Method: IntegerTest>>testDegreeSin (in category 'tests - mathematical functions') -----
- testDegreeSin
- "self run: #testDegreeSin"
-
- "Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic"
- self assert: (45 degreeSin squared - (1/2)) abs <= Float epsilon.
- self assert: (30 degreeSin - (1/2)) abs <= Float epsilon.
- self assert: (-30 degreeSin + (1/2)) abs <= Float epsilon.
- -360 to: 360 do: [:i |
- self assert: (i degreeSin closeTo: i degreesToRadians sin)].
-
- "Following tests use strict equality which is a requested property of degreeSin"
- -10 to: 10 do: [:k |
- self assert: (k*360 + 90) degreeSin - 1 = 0.
- self assert: (k*360 - 90) degreeSin + 1= 0.
- self assert: (k*360 + 180) degreeSin = 0.
- self assert: (k*360) degreeSin = 0].!
Item was removed:
- ----- Method: IntegerTest>>testDifferentBases (in category 'tests - instance creation') -----
- testDifferentBases
- "self run: #testDifferentBases"
- "| value |
- 2 to: 36 do: [:each|
- value := 0.
- 1 to: each-1 do: [:n| value := value + (n * (each raisedToInteger: n))].
- value := value negated.
- Transcript tab; show: 'self assert: (', value printString, ' printStringBase: ', each printString, ') = ''', (value printStringBase: each), '''.'; cr.
- Transcript tab; show: 'self assert: (', value printString, ' radix: ', each printString, ') = ''', (value radix: each), '''.'; cr.
- Transcript tab; show: 'self assert: ', value printString, ' printStringHex = ''', (value printStringBase: 16), '''.'; cr.
- Transcript tab; show: 'self assert: (', value printString, ' storeStringBase: ', each printString, ') = ''', (value storeStringBase: each), '''.'; cr.
- Transcript tab; show: 'self assert: ', value printString, ' storeStringHex = ''', (value storeStringBase: 16), '''.'; cr.
-
-
- ].
- "
-
- self assert: 2r10 = 2.
- self assert: 3r210 = 21.
- self assert: 4r3210 = 228.
- self assert: 5r43210 = 2930.
- self assert: 6r543210 = 44790.
- self assert: 7r6543210 = 800667.
- self assert: 8r76543210 = 16434824.
- self assert: 9r876543210 = 381367044.
- self assert: 10r9876543210 = 9876543210.
- self assert: 11rA9876543210 = 282458553905.
- self assert: 12rBA9876543210 = 8842413667692.
- self assert: 13rCBA9876543210 = 300771807240918.
- self assert: 14rDCBA9876543210 = 11046255305880158.
- self assert: 15rEDCBA9876543210 = 435659737878916215.
- self assert: 16rFEDCBA9876543210 = 18364758544493064720.
- self assert: 17rGFEDCBA9876543210 = 824008854613343261192.
- self assert: 18rHGFEDCBA9876543210 = 39210261334551566857170.
- self assert: 19rIHGFEDCBA9876543210 = 1972313422155189164466189.
- self assert: 20rJIHGFEDCBA9876543210 = 104567135734072022160664820.
- self assert: 21rKJIHGFEDCBA9876543210 = 5827980550840017565077671610.
- self assert: 22rLKJIHGFEDCBA9876543210 = 340653664490377789692799452102.
- self assert: 23rMLKJIHGFEDCBA9876543210 = 20837326537038308910317109288851.
- self assert: 24rNMLKJIHGFEDCBA9876543210 = 1331214537196502869015340298036888.
- self assert: 25rONMLKJIHGFEDCBA9876543210 = 88663644327703473714387251271141900.
- self assert: 26rPONMLKJIHGFEDCBA9876543210 = 6146269788878825859099399609538763450.
- self assert: 27rQPONMLKJIHGFEDCBA9876543210 = 442770531899482980347734468443677777577.
- self assert: 28rRQPONMLKJIHGFEDCBA9876543210 = 33100056003358651440264672384704297711484.
- self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 = 2564411043271974895869785066497940850811934.
- self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 = 205646315052919334126040428061831153388822830.
- self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 = 17050208381689099029767742314582582184093573615.
- self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 = 1459980823972598128486511383358617792788444579872.
- self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = 128983956064237823710866404905431464703849549412368.
- self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 11745843093701610854378775891116314824081102660800418.
- self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 1101553773143634726491620528194292510495517905608180485.
- self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 106300512100105327644605138221229898724869759421181854980.
-
- self assert: -2r10 = -2.
- self assert: -3r210 = -21.
- self assert: -4r3210 = -228.
- self assert: -5r43210 = -2930.
- self assert: -6r543210 = -44790.
- self assert: -7r6543210 = -800667.
- self assert: -8r76543210 = -16434824.
- self assert: -9r876543210 = -381367044.
- self assert: -10r9876543210 = -9876543210.
- self assert: -11rA9876543210 = -282458553905.
- self assert: -12rBA9876543210 = -8842413667692.
- self assert: -13rCBA9876543210 = -300771807240918.
- self assert: -14rDCBA9876543210 = -11046255305880158.
- self assert: -15rEDCBA9876543210 = -435659737878916215.
- self assert: -16rFEDCBA9876543210 = -18364758544493064720.
- self assert: -17rGFEDCBA9876543210 = -824008854613343261192.
- self assert: -18rHGFEDCBA9876543210 = -39210261334551566857170.
- self assert: -19rIHGFEDCBA9876543210 = -1972313422155189164466189.
- self assert: -20rJIHGFEDCBA9876543210 = -104567135734072022160664820.
- self assert: -21rKJIHGFEDCBA9876543210 = -5827980550840017565077671610.
- self assert: -22rLKJIHGFEDCBA9876543210 = -340653664490377789692799452102.
- self assert: -23rMLKJIHGFEDCBA9876543210 = -20837326537038308910317109288851.
- self assert: -24rNMLKJIHGFEDCBA9876543210 = -1331214537196502869015340298036888.
- self assert: -25rONMLKJIHGFEDCBA9876543210 = -88663644327703473714387251271141900.
- self assert: -26rPONMLKJIHGFEDCBA9876543210 = -6146269788878825859099399609538763450.
- self assert: -27rQPONMLKJIHGFEDCBA9876543210 = -442770531899482980347734468443677777577.
- self assert: -28rRQPONMLKJIHGFEDCBA9876543210 = -33100056003358651440264672384704297711484.
- self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 = -2564411043271974895869785066497940850811934.
- self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 = -205646315052919334126040428061831153388822830.
- self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 = -17050208381689099029767742314582582184093573615.
- self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 = -1459980823972598128486511383358617792788444579872.
- self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = -128983956064237823710866404905431464703849549412368.
- self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -11745843093701610854378775891116314824081102660800418.
- self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -1101553773143634726491620528194292510495517905608180485.
- self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -106300512100105327644605138221229898724869759421181854980.!
Item was removed:
- ----- Method: IntegerTest>>testEven (in category 'tests - basic') -----
- testEven
-
- self deny: (1073741825 even).
- self assert: (1073741824 even).
- !
Item was removed:
- ----- Method: IntegerTest>>testExactRaisedTo (in category 'tests - mathematical functions') -----
- testExactRaisedTo
- "
- IntegerTest new testExactRaisedTo
- "
- self assert: (4 raisedTo: 1/2) classAndValueEquals: 2.
- self assert: (9 raisedTo: 1/2) classAndValueEquals: 3.
- self assert: (9 raisedTo: -1/2) classAndValueEquals: 1/3.
- self assert: (-1 raisedTo: 1/3) classAndValueEquals: -1.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
- self assert: (i squared raisedTo: 1/2) classAndValueEquals: i.
- self assert: (i negated squared raisedTo: 1/2) classAndValueEquals: i ].
-
- self assert: (8 raisedTo: 1/3) classAndValueEquals: 2.
- self assert: (27 raisedTo: 1/3) classAndValueEquals: 3.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
- self assert: ((i raisedTo: 3) raisedTo: 1/3) classAndValueEquals: i.
- self assert: ((i negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: i negated ].
-
- self assert: (4 raisedTo: 3/2) classAndValueEquals: 8.
- self assert: (8 raisedTo: 2/3) classAndValueEquals: 4.
- self assert: (8 raisedTo: -2/3) classAndValueEquals: 1/4.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
- self assert: ((i raisedTo: 3) raisedTo: 2/3) classAndValueEquals: i*i.
- self assert: ((i raisedTo: 2) raisedTo: 3/2) classAndValueEquals: i*i*i.
- self assert: ((i negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: i*i.
- self assert: ((i negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: i*i*i ].
-
- self assert: (32 raisedTo: 3/5) classAndValueEquals: 8.
- self assert: (8 raisedTo: 5/3) classAndValueEquals: 32.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
- self assert: ((i raisedTo: 5) raisedTo: 3/5) classAndValueEquals: i*i*i.
- self assert: ((i raisedTo: 3) raisedTo: 5/3) classAndValueEquals: i*i*i*i*i.
- self assert: ((i negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (i*i*i) negated.
- self assert: ((i negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (i*i*i*i*i) negated.
-
- self assert: ((i raisedTo: -5) raisedTo: 3/5) classAndValueEquals: 1/(i*i*i).
- self assert: ((i raisedTo: -3) raisedTo: 5/3) classAndValueEquals: 1/(i*i*i*i*i).
- self assert: ((i negated raisedTo: -5) raisedTo: 3/5) classAndValueEquals: -1/(i*i*i).
- self assert: ((i negated raisedTo: -3) raisedTo: 5/3) classAndValueEquals: -1/(i*i*i*i*i).
-
- self assert: ((i raisedTo: 5) raisedTo: -3/5) classAndValueEquals: 1/(i*i*i).
- self assert: ((i raisedTo: 3) raisedTo: -5/3) classAndValueEquals: 1/(i*i*i*i*i).
- self assert: ((i negated raisedTo: 5) raisedTo: -3/5) classAndValueEquals: -1/(i*i*i).
- self assert: ((i negated raisedTo: 3) raisedTo: -5/3) classAndValueEquals: -1/(i*i*i*i*i).
-
- "No exact result => Float result"
- self assert: ((i raisedTo: 3) +1 raisedTo: 5/3) isFloat.
- self assert: ((i negated raisedTo: 3) -1 raisedTo: 5/3) isFloat ].!
Item was removed:
- ----- Method: IntegerTest>>testExactSqrt (in category 'tests - mathematical functions') -----
- testExactSqrt
- "
- IntegerTest new testExactSqrt
- "
- self assert: 4 sqrt classAndValueEquals: 2.
- self assert: 9 sqrt classAndValueEquals: 3.
- self assert: Float maxExactInteger squared sqrt classAndValueEquals: Float maxExactInteger.
- self assert: (Float maxExactInteger+1) squared sqrt classAndValueEquals: Float maxExactInteger+1.
- #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
- self assert: i squared sqrt classAndValueEquals: i ]!
Item was removed:
- ----- Method: IntegerTest>>testFloorLog (in category 'tests - mathematical functions') -----
- testFloorLog
- self assert: (100 floorLog: 10) = 2.
- self assert: (((2 raisedTo: Float emax + 3) floorLog: 10) = (2 log*(Float emax + 3)) floor) description: 'Integer>>floorLog: should not overflow'!
Item was removed:
- ----- Method: IntegerTest>>testFloorLogExactness (in category 'tests - mathematical functions') -----
- testFloorLogExactness
-
- 1 to: (Float fmax floorLog: 10) do: [:n |
- self assert: ((10 raisedTo: n) floorLog: 10) = n].
-
- "Float version is not exact for at least 2 reasons:
- (10 raisedTo: n) asFloat is not exact for n > 22
- (aFloat log: radix) is not exact
-
- (1 to: (Float fmax floorLog: 10)) count: [:n |
- ((10 raisedTo: n) asFloat floorLog: 10) ~= n]."!
Item was removed:
- ----- Method: IntegerTest>>testHighBit (in category 'tests - bitLogic') -----
- testHighBit
- | suite |
-
- suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}.
- suite := suite , (suite collect: [:e | e raisedTo: 20]).
-
- suite do: [:anInteger |
- | highBit shifted |
- highBit := 0.
- shifted := 1.
- [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1].
- self assert: anInteger highBit = highBit].!
Item was removed:
- ----- Method: IntegerTest>>testHighBitOfMagnitude (in category 'tests - bitLogic') -----
- testHighBitOfMagnitude
- | suite |
-
- suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}.
- suite := suite , (suite collect: [:e | e raisedTo: 20]).
-
- suite do: [:anInteger |
- | highBit shifted |
- highBit := 0.
- shifted := 1.
- [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1].
- self assert: anInteger highBitOfMagnitude = highBit.
- self assert: anInteger negated highBitOfMagnitude = highBit].!
Item was removed:
- ----- Method: IntegerTest>>testIntegerDivision (in category 'tests - arithmetic') -----
- testIntegerDivision
- | suite |
- suite := #( 1 2 5 1000 123456798 111222333444555 987654321098765432109876 ).
- suite := suite , (suite collect: [:e | e negated]).
- suite do: [:a |
- suite do: [:b |
- | q r |
- q := a // b.
- r := a \\ b.
- self assert: b * q + r = a.
- self assert: r abs < b abs.
- self assert: (r isZero or: [b negative = r negative])]].!
Item was removed:
- ----- Method: IntegerTest>>testIntegerPadding (in category 'tests - printing') -----
- testIntegerPadding
- "self run: #testIntegerPadding"
-
- self assert: (1 printStringBase: 10 length: 0 padded: false) = '1'.
- self assert: (1 printStringBase: 10 length: 1 padded: false) = '1'.
- self assert: (1 printStringBase: 10 length: 2 padded: false) = ' 1'.
- self assert: (1024 printStringBase: 10 length: 19 padded: false) = ' 1024'.
- self assert: (1024 printStringBase: 10 length: -1 padded: false) = '1024'.
- self assert: (1024 printStringBase: 10 length: 5 padded: false) = ' 1024'.
- self assert: (-1024 printStringBase: 10 length: 5 padded: false) = '-1024'.
- self assert: (-1024 printStringBase: 10 length: 19 padded: false) = ' -1024'.
-
- self assert: (1 printStringBase: 10 length: 0 padded: true) = '1'.
- self assert: (1 printStringBase: 10 length: 1 padded: true) = '1'.
- self assert: (1 printStringBase: 10 length: 2 padded: true) = '01'.
- self assert: (1024 printStringBase: 10 length: 19 padded: true) = '0000000000000001024'.
- self assert: (1024 printStringBase: 10 length: -1 padded: true) = '1024'.
- self assert: (1024 printStringBase: 10 length: 5 padded: true) = '01024'.
- self assert: (-1024 printStringBase: 10 length: 5 padded: true) = '-1024'.
- self assert: (-1024 printStringBase: 10 length: 19 padded: true) = '-000000000000001024'.
-
- self assert: (1 printStringBase: 16 length: 0 padded: false) = '1'.
- self assert: (1 printStringBase: 16 length: 1 padded: false) = '1'.
- self assert: (1 printStringBase: 16 length: 2 padded: false) = ' 1'.
- self assert: (2047 printStringBase: 16 length: 19 padded: false) = ' 7FF'.
- self assert: (2047 printStringBase: 16 length: -1 padded: false) = '7FF'.
- self assert: (2047 printStringBase: 16 length: 4 padded: false) = ' 7FF'.
- self assert: (-2047 printStringBase: 16 length: 4 padded: false) = '-7FF'.
- self assert: (-2047 printStringBase: 16 length: 19 padded: false) = ' -7FF'.
-
- self assert: (1 printStringBase: 16 length: 0 padded: true) = '1'.
- self assert: (1 printStringBase: 16 length: 1 padded: true) = '1'.
- self assert: (1 printStringBase: 16 length: 2 padded: true) = '01'.
- self assert: (2047 printStringBase: 16 length: 19 padded: true) = '00000000000000007FF'.
- self assert: (2047 printStringBase: 16 length: -1 padded: true) = '7FF'.
- self assert: (2047 printStringBase: 16 length: 4 padded: true) = '07FF'.
- self assert: (-2047 printStringBase: 16 length: 4 padded: true) = '-7FF'.
- self assert: (-2047 printStringBase: 16 length: 19 padded: true) = '-0000000000000007FF'.
-
- self assert: (1 storeStringBase: 10 length: 0 padded: false) = '1'.
- self assert: (1 storeStringBase: 10 length: 1 padded: false) = '1'.
- self assert: (1 storeStringBase: 10 length: 2 padded: false) = ' 1'.
- self assert: (1024 storeStringBase: 10 length: 19 padded: false) = ' 1024'.
- self assert: (1024 storeStringBase: 10 length: -1 padded: false) = '1024'.
- self assert: (1024 storeStringBase: 10 length: 5 padded: false) = ' 1024'.
- self assert: (-1024 storeStringBase: 10 length: 5 padded: false) = '-1024'.
- self assert: (-1024 storeStringBase: 10 length: 19 padded: false) = ' -1024'.
-
- self assert: (1 storeStringBase: 10 length: 0 padded: true) = '1'.
- self assert: (1 storeStringBase: 10 length: 1 padded: true) = '1'.
- self assert: (1 storeStringBase: 10 length: 2 padded: true) = '01'.
- self assert: (1024 storeStringBase: 10 length: 19 padded: true) = '0000000000000001024'.
- self assert: (1024 storeStringBase: 10 length: -1 padded: true) = '1024'.
- self assert: (1024 storeStringBase: 10 length: 5 padded: true) = '01024'.
- self assert: (-1024 storeStringBase: 10 length: 5 padded: true) = '-1024'.
- self assert: (-1024 storeStringBase: 10 length: 19 padded: true) = '-000000000000001024'.
-
- self assert: (1 storeStringBase: 16 length: 0 padded: false) = '16r1'.
- self assert: (1 storeStringBase: 16 length: 4 padded: false) = '16r1'.
- self assert: (1 storeStringBase: 16 length: 5 padded: false) = ' 16r1'.
- self assert: (2047 storeStringBase: 16 length: 19 padded: false) = ' 16r7FF'.
- self assert: (2047 storeStringBase: 16 length: -1 padded: false) = '16r7FF'.
- self assert: (2047 storeStringBase: 16 length: 7 padded: false) = ' 16r7FF'.
- self assert: (-2047 storeStringBase: 16 length: 7 padded: false) = '-16r7FF'.
- self assert: (-2047 storeStringBase: 16 length: 19 padded: false) = ' -16r7FF'.
-
- self assert: (1 storeStringBase: 16 length: 0 padded: true) = '16r1'.
- self assert: (1 storeStringBase: 16 length: 4 padded: true) = '16r1'.
- self assert: (1 storeStringBase: 16 length: 5 padded: true) = '16r01'.
- self assert: (2047 storeStringBase: 16 length: 19 padded: true) = '16r00000000000007FF'.
- self assert: (2047 storeStringBase: 16 length: -1 padded: true) = '16r7FF'.
- self assert: (2047 storeStringBase: 16 length: 7 padded: true) = '16r07FF'.
- self assert: (-2047 storeStringBase: 16 length: 7 padded: true) = '-16r7FF'.
- self assert: (-2047 storeStringBase: 16 length: 19 padded: true) = '-16r0000000000007FF'.
- !
Item was removed:
- ----- Method: IntegerTest>>testIntegerReadFrom (in category 'tests - instance creation') -----
- testIntegerReadFrom
- self assert: (Integer readFrom: '123' readStream base: 10) = 123.
- self assert: (Integer readFrom: '-123' readStream base: 10) = -123.
- self should: [Integer readFrom: 'abc' readStream base: 10] raise: Error.
- self should: [Integer readFrom: 'D12' readStream base: 10] raise: Error.
- self assert: (Integer readFrom: 'abc' readStream ifFail: [0]) = 0.
- self assert: (Integer readFrom: 'D12' readStream ifFail: [0]) = 0.
- self assert: (Integer readFrom: '1two3' readStream base: 10) = 1.
- !
Item was removed:
- ----- Method: IntegerTest>>testIsInteger (in category 'tests - basic') -----
- testIsInteger
-
- self assert: (0 isInteger).
- !
Item was removed:
- ----- Method: IntegerTest>>testIsPowerOfTwo (in category 'tests - basic') -----
- testIsPowerOfTwo
-
- | powersOfTwo nonPowersOfTwo |
- powersOfTwo := (0 to: 100) collect: [ :each |
- 2 raisedTo: each ].
- nonPowersOfTwo := (powersOfTwo collect: [ :each | each negated ]),
- #(0 3 -3 5 -5 6 -6 7 -7 9 -9 10 -10 100 -100 1000 -1000 12345678 -12345678 1234567890 -1234567890 12345678901234567890 -12345678901234567890).
- powersOfTwo do: [ :each |
- self assert: each isPowerOfTwo ].
- nonPowersOfTwo do: [ :each |
- self deny: each isPowerOfTwo ]!
Item was removed:
- ----- Method: IntegerTest>>testIsPrime (in category 'tests - basic') -----
- testIsPrime
-
- | i |
- "Not primes:"
- #(-1000000000000000 -100 -5 -3 -2 -1 0 1) do: [ :each |
- self deny: each isPrime ].
-
- "Check all non-negative integers up to one million."
- i := 0.
- Integer primesUpTo: 1000000 do: [ :prime |
- [ i < prime ] whileTrue: [
- self deny: i isPrime.
- i := i + 1 ].
- self assert: i isPrime.
- i := i + 1 ].
- [ i <= 1000000 ] whileTrue: [
- self deny: i isPrime.
- i := i + 1 ].
-
- "The following tests should return 'true'"
- #(17 78901 104729 15485863 2038074743) do: [ :each |
- self assert: each isPrime ].
-
- "The following tests should return 'false' (first 5 are Carmichael numbers)"
- #(561 2821 6601 10585 15841 256 29996224275831) do: [ :each |
- self deny: each isPrime ].
- !
Item was removed:
- ----- Method: IntegerTest>>testIsProbablyPrime (in category 'tests - basic') -----
- testIsProbablyPrime
-
- "Not primes:"
- #(-100 -5 -3 -2 -1 0 1) do: [ :each |
- self deny: each isProbablyPrime ].
-
- "The following tests should return 'true'"
- #(17 78901 104729 15485863 2038074743 29996224275833) do: [ :each |
- self assert: each isProbablyPrime ].
-
- "The following tests should return 'false' (first 5 are Carmichael integers)"
- #(561 2821 6601 10585 15841 256 29996224275831) do: [ :each |
- self deny: each isProbablyPrime ].!
Item was removed:
- ----- Method: IntegerTest>>testLargePrimesUpTo (in category 'tests - basic') -----
- testLargePrimesUpTo
-
- | nn |
- nn := (2 raisedTo: 17) - 1.
- self deny: (Integer primesUpTo: nn) last = nn.
- self assert: (Integer primesUpTo: nn + 1) last = nn.
-
-
- !
Item was removed:
- ----- Method: IntegerTest>>testLn (in category 'tests - mathematical functions') -----
- testLn
- self assert: (100 ln closeTo: 10 ln*2).
- self assert: ((2 raisedTo: Float emax + 3) ln closeTo: 2 ln*(Float emax + 3)) description: 'Integer>>ln should not overflow'!
Item was removed:
- ----- Method: IntegerTest>>testLog (in category 'tests - mathematical functions') -----
- testLog
- self assert: (100 log closeTo: 2).
- self assert: ((2 raisedTo: Float emax + 3) log closeTo: 2 log*(Float emax + 3)) description: 'Integer>>log should not overflow'!
Item was removed:
- ----- Method: IntegerTest>>testLowBit (in category 'tests - bitLogic') -----
- testLowBit
- | suite |
-
- suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}.
- suite := suite , (suite collect: [:e | e raisedTo: 20]).
-
- suite do: [:anInteger |
- | lowBit |
- lowBit := (anInteger respondsTo: #bitAt:)
- ifTrue: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAt: bitIndex) ~= 0] ifNone: [0]]
- ifFalse: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAnd: (1 bitShift: bitIndex-1)) ~= 0] ifNone: [0]].
- self assert: anInteger lowBit = lowBit.
- self assert: anInteger negated lowBit = lowBit].!
Item was removed:
- ----- Method: IntegerTest>>testMontgomeryMultiplication (in category 'tests - arithmetic') -----
- testMontgomeryMultiplication
- | a m mInv |
- m := 15485863.
- mInv := m montgomeryDigitBase - ((m bitAnd: m montgomeryDigitMax) reciprocalModulo: m montgomeryDigitBase).
- a := (m montgomeryDigitBase raisedTo: m montgomeryNumberOfDigits) \\ m.
- #(483933 3871465 8951195) do: [:s |
- (s montgomeryTimes: a modulo: m mInvModB: mInv) ifNotNil: [:s1 |
- | s2 sa ssa |
- self assert: s = s1.
- sa := s montgomeryTimes: (a * a \\ m) modulo: m mInvModB: mInv.
- self assert: sa = (s * a \\ m).
- ssa := sa montgomeryTimes: sa modulo: m mInvModB: mInv.
- self assert: ssa = (s * s * a \\ m).
- s2 := ssa montgomeryTimes: 1 modulo: m mInvModB: mInv.
- self assert: s2 = (s * s \\ m)]].!
Item was removed:
- ----- Method: IntegerTest>>testNegativeIntegerPrinting (in category 'tests - printing') -----
- testNegativeIntegerPrinting
- "self run: #testnegativeIntegerPrinting"
-
- self assert: (-2 printStringBase: 2) = '-10'.
- self assert: (-2 radix: 2) = '-10'.
- self assert: -2 printStringHex = '-2'.
- self assert: (-2 storeStringBase: 2) = '-2r10'.
- self assert: -2 storeStringHex = '-16r2'.
- self assert: (-21 printStringBase: 3) = '-210'.
- self assert: (-21 radix: 3) = '-210'.
- self assert: -21 printStringHex = '-15'.
- self assert: (-21 storeStringBase: 3) = '-3r210'.
- self assert: -21 storeStringHex = '-16r15'.
- self assert: (-228 printStringBase: 4) = '-3210'.
- self assert: (-228 radix: 4) = '-3210'.
- self assert: -228 printStringHex = '-E4'.
- self assert: (-228 storeStringBase: 4) = '-4r3210'.
- self assert: -228 storeStringHex = '-16rE4'.
- self assert: (-2930 printStringBase: 5) = '-43210'.
- self assert: (-2930 radix: 5) = '-43210'.
- self assert: -2930 printStringHex = '-B72'.
- self assert: (-2930 storeStringBase: 5) = '-5r43210'.
- self assert: -2930 storeStringHex = '-16rB72'.
- self assert: (-44790 printStringBase: 6) = '-543210'.
- self assert: (-44790 radix: 6) = '-543210'.
- self assert: -44790 printStringHex = '-AEF6'.
- self assert: (-44790 storeStringBase: 6) = '-6r543210'.
- self assert: -44790 storeStringHex = '-16rAEF6'.
- self assert: (-800667 printStringBase: 7) = '-6543210'.
- self assert: (-800667 radix: 7) = '-6543210'.
- self assert: -800667 printStringHex = '-C379B'.
- self assert: (-800667 storeStringBase: 7) = '-7r6543210'.
- self assert: -800667 storeStringHex = '-16rC379B'.
- self assert: (-16434824 printStringBase: 8) = '-76543210'.
- self assert: (-16434824 radix: 8) = '-76543210'.
- self assert: -16434824 printStringHex = '-FAC688'.
- self assert: (-16434824 storeStringBase: 8) = '-8r76543210'.
- self assert: -16434824 storeStringHex = '-16rFAC688'.
- self assert: (-381367044 printStringBase: 9) = '-876543210'.
- self assert: (-381367044 radix: 9) = '-876543210'.
- self assert: -381367044 printStringHex = '-16BB3304'.
- self assert: (-381367044 storeStringBase: 9) = '-9r876543210'.
- self assert: -381367044 storeStringHex = '-16r16BB3304'.
- self assert: (-9876543210 printStringBase: 10) = '-9876543210'.
- self assert: (-9876543210 radix: 10) = '-9876543210'.
- self assert: -9876543210 printStringHex = '-24CB016EA'.
- self assert: (-9876543210 storeStringBase: 10) = '-9876543210'.
- self assert: -9876543210 storeStringHex = '-16r24CB016EA'.
- self assert: (-282458553905 printStringBase: 11) = '-A9876543210'.
- self assert: (-282458553905 radix: 11) = '-A9876543210'.
- self assert: -282458553905 printStringHex = '-41C3D77E31'.
- self assert: (-282458553905 storeStringBase: 11) = '-11rA9876543210'.
- self assert: -282458553905 storeStringHex = '-16r41C3D77E31'.
- self assert: (-8842413667692 printStringBase: 12) = '-BA9876543210'.
- self assert: (-8842413667692 radix: 12) = '-BA9876543210'.
- self assert: -8842413667692 printStringHex = '-80AC8ECF56C'.
- self assert: (-8842413667692 storeStringBase: 12) = '-12rBA9876543210'.
- self assert: -8842413667692 storeStringHex = '-16r80AC8ECF56C'.
- self assert: (-300771807240918 printStringBase: 13) = '-CBA9876543210'.
- self assert: (-300771807240918 radix: 13) = '-CBA9876543210'.
- self assert: -300771807240918 printStringHex = '-1118CE4BAA2D6'.
- self assert: (-300771807240918 storeStringBase: 13) = '-13rCBA9876543210'.
- self assert: -300771807240918 storeStringHex = '-16r1118CE4BAA2D6'.
- self assert: (-11046255305880158 printStringBase: 14) = '-DCBA9876543210'.
- self assert: (-11046255305880158 radix: 14) = '-DCBA9876543210'.
- self assert: -11046255305880158 printStringHex = '-273E82BB9AF25E'.
- self assert: (-11046255305880158 storeStringBase: 14) = '-14rDCBA9876543210'.
- self assert: -11046255305880158 storeStringHex = '-16r273E82BB9AF25E'.
- self assert: (-435659737878916215 printStringBase: 15) = '-EDCBA9876543210'.
- self assert: (-435659737878916215 radix: 15) = '-EDCBA9876543210'.
- self assert: -435659737878916215 printStringHex = '-60BC6392F366C77'.
- self assert: (-435659737878916215 storeStringBase: 15) = '-15rEDCBA9876543210'.
- self assert: -435659737878916215 storeStringHex = '-16r60BC6392F366C77'.
- self assert: (-18364758544493064720 printStringBase: 16) = '-FEDCBA9876543210'.
- self assert: (-18364758544493064720 radix: 16) = '-FEDCBA9876543210'.
- self assert: -18364758544493064720 printStringHex = '-FEDCBA9876543210'.
- self assert: (-18364758544493064720 storeStringBase: 16) = '-16rFEDCBA9876543210'.
- self assert: -18364758544493064720 storeStringHex = '-16rFEDCBA9876543210'.
- self assert: (-824008854613343261192 printStringBase: 17) = '-GFEDCBA9876543210'.
- self assert: (-824008854613343261192 radix: 17) = '-GFEDCBA9876543210'.
- self assert: -824008854613343261192 printStringHex = '-2CAB6B877C1CD2D208'.
- self assert: (-824008854613343261192 storeStringBase: 17) = '-17rGFEDCBA9876543210'.
- self assert: -824008854613343261192 storeStringHex = '-16r2CAB6B877C1CD2D208'.
- self assert: (-39210261334551566857170 printStringBase: 18) = '-HGFEDCBA9876543210'.
- self assert: (-39210261334551566857170 radix: 18) = '-HGFEDCBA9876543210'.
- self assert: -39210261334551566857170 printStringHex = '-84D97AFCAE81415B3D2'.
- self assert: (-39210261334551566857170 storeStringBase: 18) = '-18rHGFEDCBA9876543210'.
- self assert: -39210261334551566857170 storeStringHex = '-16r84D97AFCAE81415B3D2'.
- self assert: (-1972313422155189164466189 printStringBase: 19) = '-IHGFEDCBA9876543210'.
- self assert: (-1972313422155189164466189 radix: 19) = '-IHGFEDCBA9876543210'.
- self assert: -1972313422155189164466189 printStringHex = '-1A1A75329C5C6FC00600D'.
- self assert: (-1972313422155189164466189 storeStringBase: 19) = '-19rIHGFEDCBA9876543210'.
- self assert: -1972313422155189164466189 storeStringHex = '-16r1A1A75329C5C6FC00600D'.
- self assert: (-104567135734072022160664820 printStringBase: 20) = '-JIHGFEDCBA9876543210'.
- self assert: (-104567135734072022160664820 radix: 20) = '-JIHGFEDCBA9876543210'.
- self assert: -104567135734072022160664820 printStringHex = '-567EF3C9636D242A8C68F4'.
- self assert: (-104567135734072022160664820 storeStringBase: 20) = '-20rJIHGFEDCBA9876543210'.
- self assert: -104567135734072022160664820 storeStringHex = '-16r567EF3C9636D242A8C68F4'.
- self assert: (-5827980550840017565077671610 printStringBase: 21) = '-KJIHGFEDCBA9876543210'.
- self assert: (-5827980550840017565077671610 radix: 21) = '-KJIHGFEDCBA9876543210'.
- self assert: -5827980550840017565077671610 printStringHex = '-12D4CAE2B8A09BCFDBE30EBA'.
- self assert: (-5827980550840017565077671610 storeStringBase: 21) = '-21rKJIHGFEDCBA9876543210'.
- self assert: -5827980550840017565077671610 storeStringHex = '-16r12D4CAE2B8A09BCFDBE30EBA'.
- self assert: (-340653664490377789692799452102 printStringBase: 22) = '-LKJIHGFEDCBA9876543210'.
- self assert: (-340653664490377789692799452102 radix: 22) = '-LKJIHGFEDCBA9876543210'.
- self assert: -340653664490377789692799452102 printStringHex = '-44CB61B5B47E1A5D8F88583C6'.
- self assert: (-340653664490377789692799452102 storeStringBase: 22) = '-22rLKJIHGFEDCBA9876543210'.
- self assert: -340653664490377789692799452102 storeStringHex = '-16r44CB61B5B47E1A5D8F88583C6'.
- self assert: (-20837326537038308910317109288851 printStringBase: 23) = '-MLKJIHGFEDCBA9876543210'.
- self assert: (-20837326537038308910317109288851 radix: 23) = '-MLKJIHGFEDCBA9876543210'.
- self assert: -20837326537038308910317109288851 printStringHex = '-1070108876456E0EF115B389F93'.
- self assert: (-20837326537038308910317109288851 storeStringBase: 23) = '-23rMLKJIHGFEDCBA9876543210'.
- self assert: -20837326537038308910317109288851 storeStringHex = '-16r1070108876456E0EF115B389F93'.
- self assert: (-1331214537196502869015340298036888 printStringBase: 24) = '-NMLKJIHGFEDCBA9876543210'.
- self assert: (-1331214537196502869015340298036888 radix: 24) = '-NMLKJIHGFEDCBA9876543210'.
- self assert: -1331214537196502869015340298036888 printStringHex = '-41A24A285154B026B6ED206C6698'.
- self assert: (-1331214537196502869015340298036888 storeStringBase: 24) = '-24rNMLKJIHGFEDCBA9876543210'.
- self assert: -1331214537196502869015340298036888 storeStringHex = '-16r41A24A285154B026B6ED206C6698'.
- self assert: (-88663644327703473714387251271141900 printStringBase: 25) = '-ONMLKJIHGFEDCBA9876543210'.
- self assert: (-88663644327703473714387251271141900 radix: 25) = '-ONMLKJIHGFEDCBA9876543210'.
- self assert: -88663644327703473714387251271141900 printStringHex = '-111374860A2C6CEBE5999630398A0C'.
- self assert: (-88663644327703473714387251271141900 storeStringBase: 25) = '-25rONMLKJIHGFEDCBA9876543210'.
- self assert: -88663644327703473714387251271141900 storeStringHex = '-16r111374860A2C6CEBE5999630398A0C'.
- self assert: (-6146269788878825859099399609538763450 printStringBase: 26) = '-PONMLKJIHGFEDCBA9876543210'.
- self assert: (-6146269788878825859099399609538763450 radix: 26) = '-PONMLKJIHGFEDCBA9876543210'.
- self assert: -6146269788878825859099399609538763450 printStringHex = '-49FBA7F30B0F48BD14E6A99BD8ADABA'.
- self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) = '-26rPONMLKJIHGFEDCBA9876543210'.
- self assert: -6146269788878825859099399609538763450 storeStringHex = '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
- self assert: (-442770531899482980347734468443677777577 printStringBase: 27) = '-QPONMLKJIHGFEDCBA9876543210'.
- self assert: (-442770531899482980347734468443677777577 radix: 27) = '-QPONMLKJIHGFEDCBA9876543210'.
- self assert: -442770531899482980347734468443677777577 printStringHex = '-14D1A80A997343640C1145A073731DEA9'.
- self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) = '-27rQPONMLKJIHGFEDCBA9876543210'.
- self assert: -442770531899482980347734468443677777577 storeStringHex = '-16r14D1A80A997343640C1145A073731DEA9'.
- self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) = '-RQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-33100056003358651440264672384704297711484 radix: 28) = '-RQPONMLKJIHGFEDCBA9876543210'.
- self assert: -33100056003358651440264672384704297711484 printStringHex = '-6145B6E6DACFA25D0E936F51D25932377C'.
- self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) = '-28rRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -33100056003358651440264672384704297711484 storeStringHex = '-16r6145B6E6DACFA25D0E936F51D25932377C'.
- self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-2564411043271974895869785066497940850811934 radix: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -2564411043271974895869785066497940850811934 printStringHex = '-1D702071CBA4A1597D4DD37E95EFAC79241E'.
- self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) = '-29rSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -2564411043271974895869785066497940850811934 storeStringHex = '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
- self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-205646315052919334126040428061831153388822830 radix: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -205646315052919334126040428061831153388822830 printStringHex = '-938B4343B54B550989989D02998718FFB212E'.
- self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) = '-30rTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -205646315052919334126040428061831153388822830 storeStringHex = '-16r938B4343B54B550989989D02998718FFB212E'.
- self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-17050208381689099029767742314582582184093573615 radix: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -17050208381689099029767742314582582184093573615 printStringHex = '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
- self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) = '-31rUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -17050208381689099029767742314582582184093573615 storeStringHex = '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
- self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -1459980823972598128486511383358617792788444579872 printStringHex = '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
- self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -1459980823972598128486511383358617792788444579872 storeStringHex = '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
- self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -128983956064237823710866404905431464703849549412368 printStringHex = '-584120A0328DE272AB055A8AA003CE4A559F223810'.
- self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -128983956064237823710866404905431464703849549412368 storeStringHex = '-16r584120A0328DE272AB055A8AA003CE4A559F223810'.
- self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -11745843093701610854378775891116314824081102660800418 printStringHex = '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
- self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex = '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
- self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex = '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
- self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex = '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
- self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex = '-455D441E55A37239AB4C303189576071AF5578FFCA80504'.
- self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex = '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.!
Item was removed:
- ----- Method: IntegerTest>>testNew (in category 'tests - instance creation') -----
- testNew
- self shouldRaiseError: [Integer new].!
Item was removed:
- ----- Method: IntegerTest>>testNthRoot (in category 'tests - mathematical functions') -----
- testNthRoot
- self assert: (1 << 2000 nthRoot: 100) equals: 1 << 20!
Item was removed:
- ----- Method: IntegerTest>>testNthRootErrorConditions (in category 'tests - mathematical functions') -----
- testNthRootErrorConditions
- "
- IntegerTest new testExactRaisedToErrorConditions
- "
-
- self should: [ -2 nthRoot: 1/4 ] raise: ArithmeticError.
- self should: [ -2 nthRoot: 1.24 ] raise: ArithmeticError.!
Item was removed:
- ----- Method: IntegerTest>>testNthRootExactness (in category 'tests - mathematical functions') -----
- testNthRootExactness
- | inexactRoots largeRaisedTo6 |
- largeRaisedTo6 := (2 to: 100) collect: [:k | (k raisedTo: 11) raisedTo: 6].
- inexactRoots := largeRaisedTo6 reject: [:e | (e nthRoot: 6) isInteger].
- self assert: inexactRoots isEmpty description: 'Failed to find the exact 6th root of these numbers'!
Item was removed:
- ----- Method: IntegerTest>>testNthRootExactnessForHugeValue (in category 'tests - mathematical functions') -----
- testNthRootExactnessForHugeValue
- self assert: ((10 raisedTo: 600) nthRoot: 300) classAndValueEquals: 100.
- self assert: ((10 raisedTo: 600) + 1 nthRoot: 300) classAndValueEquals: 100.0!
Item was removed:
- ----- Method: IntegerTest>>testNthRootImmuneToDoubleRounding (in category 'tests - mathematical functions') -----
- testNthRootImmuneToDoubleRounding
- "Use a specially crafted number for causing double rounding.
- Solution is 10...01.1 - verySmallQuantity.
- Where verySmallQuantity is approximately 1/53/(1<<53).
- If the verySmallQuantity is not taken into account, then solution is rounded to 10....010"
- | exponent crafted root highPrecisionRoot |
- exponent := 4.
- crafted := (1 << Float precision + 3 raisedTo: exponent) - 1.
- root := crafted nthRoot: exponent.
- highPrecisionRoot := (crafted << (exponent squared * Float precision * 4) nthRootRounded: exponent) / (1 << (exponent * Float precision * 4)).
- self assert: (root asFraction - highPrecisionRoot) abs < (root predecessor asFraction - highPrecisionRoot) abs.
-
- "Same with the other sign.
- Solution is 10...00.1 + verySmallQuantity."
- crafted := (1 << Float precision + 1 raisedTo: exponent) + 1.
- root := crafted nthRoot: exponent.
- highPrecisionRoot := (crafted << (exponent squared * Float precision * 4) nthRootRounded: exponent) / (1 << (exponent * Float precision * 4)).
- self assert: (root asFraction - highPrecisionRoot) abs < (root successor asFraction - highPrecisionRoot) abs.!
Item was removed:
- ----- Method: IntegerTest>>testNthRootRounded (in category 'tests - mathematical functions') -----
- testNthRootRounded
- <timeout: 5 "seconds">
- | d x |
- d := ((1 + 2 reciprocal - (1<<30) reciprocal) raisedTo: 1000) floor. "close to 1.5 by default"
- x := ((1 + 2 reciprocal + (1<<30) reciprocal) raisedTo: 1000) ceiling. "close to 1.5 by excess"
- self assert: (d nthRootTruncated: 1000) equals: 1.
- self assert: (x nthRootTruncated: 1000) equals: 1.
- self assert: (d nthRootRounded: 1000) equals: 1.
- self assert: (x nthRootRounded: 1000) equals: 2.!
Item was removed:
- ----- Method: IntegerTest>>testNthRootTruncated (in category 'tests - mathematical functions') -----
- testNthRootTruncated
- <timeout: 5 "seconds">
- | tooBigToBeAFloat large |
- tooBigToBeAFloat := 1 << 2000.
- self assert: (tooBigToBeAFloat nthRootTruncated: 100) equals: 1 << 20.
- self assert: (tooBigToBeAFloat + 1 nthRootTruncated: 100) equals: 1 << 20.
- self assert: (tooBigToBeAFloat - 1 nthRootTruncated: 100) equals: 1 << 20 - 1.
-
- large := -3 raisedTo: 255.
- self assert: (large nthRootTruncated: 17) equals: (-3 raisedTo: 15).
- self assert: (large + 11 nthRootTruncated: 17) equals: (-3 raisedTo: 15) + 1.
- self assert: (large - 11 nthRootTruncated: 17) equals: (-3 raisedTo: 15).
-
- 2 to: 10 do: [:thePower |
- 1 to: 10000 do: [:n |
- | theTruncatedRoot |
- theTruncatedRoot := n nthRootTruncated: thePower.
- self assert: (theTruncatedRoot raisedTo: thePower) <= n.
- self assert: (theTruncatedRoot + 1 raisedTo: thePower) > n]]!
Item was removed:
- ----- Method: IntegerTest>>testNumberOfDigits (in category 'tests - printing') -----
- testNumberOfDigits
-
- 2 to: 32 do: [:b |
- 1 to: 1000//b do: [:n |
- | bRaisedToN |
- bRaisedToN := b raisedTo: n.
- self assert: (bRaisedToN - 1 numberOfDigitsInBase: b) = n.
- self assert: (bRaisedToN numberOfDigitsInBase: b) = (n+1).
- self assert: (bRaisedToN + 1 numberOfDigitsInBase: b) = (n+1).
-
- self assert: (bRaisedToN negated + 1 numberOfDigitsInBase: b) = n.
- self assert: (bRaisedToN negated numberOfDigitsInBase: b) = (n+1).
- self assert: (bRaisedToN negated - 1 numberOfDigitsInBase: b) = (n+1).]].
- !
Item was removed:
- ----- Method: IntegerTest>>testPositiveIntegerPrinting (in category 'tests - printing') -----
- testPositiveIntegerPrinting
- "self run: #testPositiveIntegerPrinting"
-
- self assert: 0 printString = '0'.
- self assert: 0 printStringHex = '0'.
- self assert: 0 storeStringHex = '16r0'.
-
- self assert: (2 printStringBase: 2) = '10'.
- self assert: (2 radix: 2) = '10'.
- self assert: 2 printStringHex = '2'.
- self assert: (2 storeStringBase: 2) = '2r10'.
- self assert: 2 storeStringHex = '16r2'.
- self assert: (21 printStringBase: 3) = '210'.
- self assert: (21 radix: 3) = '210'.
- self assert: 21 printStringHex = '15'.
- self assert: (21 storeStringBase: 3) = '3r210'.
- self assert: 21 storeStringHex = '16r15'.
- self assert: (228 printStringBase: 4) = '3210'.
- self assert: (228 radix: 4) = '3210'.
- self assert: 228 printStringHex = 'E4'.
- self assert: (228 storeStringBase: 4) = '4r3210'.
- self assert: 228 storeStringHex = '16rE4'.
- self assert: (2930 printStringBase: 5) = '43210'.
- self assert: (2930 radix: 5) = '43210'.
- self assert: 2930 printStringHex = 'B72'.
- self assert: (2930 storeStringBase: 5) = '5r43210'.
- self assert: 2930 storeStringHex = '16rB72'.
- self assert: (44790 printStringBase: 6) = '543210'.
- self assert: (44790 radix: 6) = '543210'.
- self assert: 44790 printStringHex = 'AEF6'.
- self assert: (44790 storeStringBase: 6) = '6r543210'.
- self assert: 44790 storeStringHex = '16rAEF6'.
- self assert: (800667 printStringBase: 7) = '6543210'.
- self assert: (800667 radix: 7) = '6543210'.
- self assert: 800667 printStringHex = 'C379B'.
- self assert: (800667 storeStringBase: 7) = '7r6543210'.
- self assert: 800667 storeStringHex = '16rC379B'.
- self assert: (16434824 printStringBase: 8) = '76543210'.
- self assert: (16434824 radix: 8) = '76543210'.
- self assert: 16434824 printStringHex = 'FAC688'.
- self assert: (16434824 storeStringBase: 8) = '8r76543210'.
- self assert: 16434824 storeStringHex = '16rFAC688'.
- self assert: (381367044 printStringBase: 9) = '876543210'.
- self assert: (381367044 radix: 9) = '876543210'.
- self assert: 381367044 printStringHex = '16BB3304'.
- self assert: (381367044 storeStringBase: 9) = '9r876543210'.
- self assert: 381367044 storeStringHex = '16r16BB3304'.
- self assert: (9876543210 printStringBase: 10) = '9876543210'.
- self assert: (9876543210 radix: 10) = '9876543210'.
- self assert: 9876543210 printStringHex = '24CB016EA'.
- self assert: (9876543210 storeStringBase: 10) = '9876543210'.
- self assert: 9876543210 storeStringHex = '16r24CB016EA'.
- self assert: (282458553905 printStringBase: 11) = 'A9876543210'.
- self assert: (282458553905 radix: 11) = 'A9876543210'.
- self assert: 282458553905 printStringHex = '41C3D77E31'.
- self assert: (282458553905 storeStringBase: 11) = '11rA9876543210'.
- self assert: 282458553905 storeStringHex = '16r41C3D77E31'.
- self assert: (8842413667692 printStringBase: 12) = 'BA9876543210'.
- self assert: (8842413667692 radix: 12) = 'BA9876543210'.
- self assert: 8842413667692 printStringHex = '80AC8ECF56C'.
- self assert: (8842413667692 storeStringBase: 12) = '12rBA9876543210'.
- self assert: 8842413667692 storeStringHex = '16r80AC8ECF56C'.
- self assert: (300771807240918 printStringBase: 13) = 'CBA9876543210'.
- self assert: (300771807240918 radix: 13) = 'CBA9876543210'.
- self assert: 300771807240918 printStringHex = '1118CE4BAA2D6'.
- self assert: (300771807240918 storeStringBase: 13) = '13rCBA9876543210'.
- self assert: 300771807240918 storeStringHex = '16r1118CE4BAA2D6'.
- self assert: (11046255305880158 printStringBase: 14) = 'DCBA9876543210'.
- self assert: (11046255305880158 radix: 14) = 'DCBA9876543210'.
- self assert: 11046255305880158 printStringHex = '273E82BB9AF25E'.
- self assert: (11046255305880158 storeStringBase: 14) = '14rDCBA9876543210'.
- self assert: 11046255305880158 storeStringHex = '16r273E82BB9AF25E'.
- self assert: (435659737878916215 printStringBase: 15) = 'EDCBA9876543210'.
- self assert: (435659737878916215 radix: 15) = 'EDCBA9876543210'.
- self assert: 435659737878916215 printStringHex = '60BC6392F366C77'.
- self assert: (435659737878916215 storeStringBase: 15) = '15rEDCBA9876543210'.
- self assert: 435659737878916215 storeStringHex = '16r60BC6392F366C77'.
- self assert: (18364758544493064720 printStringBase: 16) = 'FEDCBA9876543210'.
- self assert: (18364758544493064720 radix: 16) = 'FEDCBA9876543210'.
- self assert: 18364758544493064720 printStringHex = 'FEDCBA9876543210'.
- self assert: (18364758544493064720 storeStringBase: 16) = '16rFEDCBA9876543210'.
- self assert: 18364758544493064720 storeStringHex = '16rFEDCBA9876543210'.
- self assert: (824008854613343261192 printStringBase: 17) = 'GFEDCBA9876543210'.
- self assert: (824008854613343261192 radix: 17) = 'GFEDCBA9876543210'.
- self assert: 824008854613343261192 printStringHex = '2CAB6B877C1CD2D208'.
- self assert: (824008854613343261192 storeStringBase: 17) = '17rGFEDCBA9876543210'.
- self assert: 824008854613343261192 storeStringHex = '16r2CAB6B877C1CD2D208'.
- self assert: (39210261334551566857170 printStringBase: 18) = 'HGFEDCBA9876543210'.
- self assert: (39210261334551566857170 radix: 18) = 'HGFEDCBA9876543210'.
- self assert: 39210261334551566857170 printStringHex = '84D97AFCAE81415B3D2'.
- self assert: (39210261334551566857170 storeStringBase: 18) = '18rHGFEDCBA9876543210'.
- self assert: 39210261334551566857170 storeStringHex = '16r84D97AFCAE81415B3D2'.
- self assert: (1972313422155189164466189 printStringBase: 19) = 'IHGFEDCBA9876543210'.
- self assert: (1972313422155189164466189 radix: 19) = 'IHGFEDCBA9876543210'.
- self assert: 1972313422155189164466189 printStringHex = '1A1A75329C5C6FC00600D'.
- self assert: (1972313422155189164466189 storeStringBase: 19) = '19rIHGFEDCBA9876543210'.
- self assert: 1972313422155189164466189 storeStringHex = '16r1A1A75329C5C6FC00600D'.
- self assert: (104567135734072022160664820 printStringBase: 20) = 'JIHGFEDCBA9876543210'.
- self assert: (104567135734072022160664820 radix: 20) = 'JIHGFEDCBA9876543210'.
- self assert: 104567135734072022160664820 printStringHex = '567EF3C9636D242A8C68F4'.
- self assert: (104567135734072022160664820 storeStringBase: 20) = '20rJIHGFEDCBA9876543210'.
- self assert: 104567135734072022160664820 storeStringHex = '16r567EF3C9636D242A8C68F4'.
- self assert: (5827980550840017565077671610 printStringBase: 21) = 'KJIHGFEDCBA9876543210'.
- self assert: (5827980550840017565077671610 radix: 21) = 'KJIHGFEDCBA9876543210'.
- self assert: 5827980550840017565077671610 printStringHex = '12D4CAE2B8A09BCFDBE30EBA'.
- self assert: (5827980550840017565077671610 storeStringBase: 21) = '21rKJIHGFEDCBA9876543210'.
- self assert: 5827980550840017565077671610 storeStringHex = '16r12D4CAE2B8A09BCFDBE30EBA'.
- self assert: (340653664490377789692799452102 printStringBase: 22) = 'LKJIHGFEDCBA9876543210'.
- self assert: (340653664490377789692799452102 radix: 22) = 'LKJIHGFEDCBA9876543210'.
- self assert: 340653664490377789692799452102 printStringHex = '44CB61B5B47E1A5D8F88583C6'.
- self assert: (340653664490377789692799452102 storeStringBase: 22) = '22rLKJIHGFEDCBA9876543210'.
- self assert: 340653664490377789692799452102 storeStringHex = '16r44CB61B5B47E1A5D8F88583C6'.
- self assert: (20837326537038308910317109288851 printStringBase: 23) = 'MLKJIHGFEDCBA9876543210'.
- self assert: (20837326537038308910317109288851 radix: 23) = 'MLKJIHGFEDCBA9876543210'.
- self assert: 20837326537038308910317109288851 printStringHex = '1070108876456E0EF115B389F93'.
- self assert: (20837326537038308910317109288851 storeStringBase: 23) = '23rMLKJIHGFEDCBA9876543210'.
- self assert: 20837326537038308910317109288851 storeStringHex = '16r1070108876456E0EF115B389F93'.
- self assert: (1331214537196502869015340298036888 printStringBase: 24) = 'NMLKJIHGFEDCBA9876543210'.
- self assert: (1331214537196502869015340298036888 radix: 24) = 'NMLKJIHGFEDCBA9876543210'.
- self assert: 1331214537196502869015340298036888 printStringHex = '41A24A285154B026B6ED206C6698'.
- self assert: (1331214537196502869015340298036888 storeStringBase: 24) = '24rNMLKJIHGFEDCBA9876543210'.
- self assert: 1331214537196502869015340298036888 storeStringHex = '16r41A24A285154B026B6ED206C6698'.
- self assert: (88663644327703473714387251271141900 printStringBase: 25) = 'ONMLKJIHGFEDCBA9876543210'.
- self assert: (88663644327703473714387251271141900 radix: 25) = 'ONMLKJIHGFEDCBA9876543210'.
- self assert: 88663644327703473714387251271141900 printStringHex = '111374860A2C6CEBE5999630398A0C'.
- self assert: (88663644327703473714387251271141900 storeStringBase: 25) = '25rONMLKJIHGFEDCBA9876543210'.
- self assert: 88663644327703473714387251271141900 storeStringHex = '16r111374860A2C6CEBE5999630398A0C'.
- self assert: (6146269788878825859099399609538763450 printStringBase: 26) = 'PONMLKJIHGFEDCBA9876543210'.
- self assert: (6146269788878825859099399609538763450 radix: 26) = 'PONMLKJIHGFEDCBA9876543210'.
- self assert: 6146269788878825859099399609538763450 printStringHex = '49FBA7F30B0F48BD14E6A99BD8ADABA'.
- self assert: (6146269788878825859099399609538763450 storeStringBase: 26) = '26rPONMLKJIHGFEDCBA9876543210'.
- self assert: 6146269788878825859099399609538763450 storeStringHex = '16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
- self assert: (442770531899482980347734468443677777577 printStringBase: 27) = 'QPONMLKJIHGFEDCBA9876543210'.
- self assert: (442770531899482980347734468443677777577 radix: 27) = 'QPONMLKJIHGFEDCBA9876543210'.
- self assert: 442770531899482980347734468443677777577 printStringHex = '14D1A80A997343640C1145A073731DEA9'.
- self assert: (442770531899482980347734468443677777577 storeStringBase: 27) = '27rQPONMLKJIHGFEDCBA9876543210'.
- self assert: 442770531899482980347734468443677777577 storeStringHex = '16r14D1A80A997343640C1145A073731DEA9'.
- self assert: (33100056003358651440264672384704297711484 printStringBase: 28) = 'RQPONMLKJIHGFEDCBA9876543210'.
- self assert: (33100056003358651440264672384704297711484 radix: 28) = 'RQPONMLKJIHGFEDCBA9876543210'.
- self assert: 33100056003358651440264672384704297711484 printStringHex = '6145B6E6DACFA25D0E936F51D25932377C'.
- self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) = '28rRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 33100056003358651440264672384704297711484 storeStringHex = '16r6145B6E6DACFA25D0E936F51D25932377C'.
- self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (2564411043271974895869785066497940850811934 radix: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 2564411043271974895869785066497940850811934 printStringHex = '1D702071CBA4A1597D4DD37E95EFAC79241E'.
- self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) = '29rSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 2564411043271974895869785066497940850811934 storeStringHex = '16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
- self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (205646315052919334126040428061831153388822830 radix: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 205646315052919334126040428061831153388822830 printStringHex = '938B4343B54B550989989D02998718FFB212E'.
- self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) = '30rTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 205646315052919334126040428061831153388822830 storeStringHex = '16r938B4343B54B550989989D02998718FFB212E'.
- self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (17050208381689099029767742314582582184093573615 radix: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 17050208381689099029767742314582582184093573615 printStringHex = '2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
- self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) = '31rUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 17050208381689099029767742314582582184093573615 storeStringHex = '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
- self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (1459980823972598128486511383358617792788444579872 radix: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 1459980823972598128486511383358617792788444579872 printStringHex = 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
- self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 1459980823972598128486511383358617792788444579872 storeStringHex = '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
- self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (128983956064237823710866404905431464703849549412368 radix: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 128983956064237823710866404905431464703849549412368 printStringHex = '584120A0328DE272AB055A8AA003CE4A559F223810'.
- self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 128983956064237823710866404905431464703849549412368 storeStringHex = '16r584120A0328DE272AB055A8AA003CE4A559F223810'.
- self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 11745843093701610854378775891116314824081102660800418 printStringHex = '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
- self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex = '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
- self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex = 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
- self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex = '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
- self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex = '455D441E55A37239AB4C303189576071AF5578FFCA80504'.
- self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
- self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex = '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.!
Item was removed:
- ----- Method: IntegerTest>>testPrimesUpTo (in category 'tests - basic') -----
- testPrimesUpTo
-
- | primes nn|
- primes := Integer primesUpTo: 100.
- self assert: primes = #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97).
-
- "upTo: semantics means 'non-inclusive'"
- primes := Integer primesUpTo: 5.
- self assert: primes = #(2 3).
-
- "this test is green for nn>25000, see #testLargePrimesUpTo"
- nn := 5.
- self deny: (Integer primesUpTo: nn) last = nn.
- self assert: (Integer primesUpTo: nn + 1) last = nn.!
Item was removed:
- ----- Method: IntegerTest>>testPrintOnBaseShowRadix (in category 'tests - printing') -----
- testPrintOnBaseShowRadix
- | s |
- s := '' writeStream.
- 123 printOn: s base: 10 showRadix: false.
- self assert: (s contents = '123').
-
- s := '' writeStream.
- 123 printOn: s base: 10 showRadix: true.
- self assert: (s contents = '10r123').
-
- s := '' writeStream.
- 123 printOn: s base: 8 showRadix: false.
- self assert: (s contents = '173').
-
- s := '' writeStream.
- 123 printOn: s base: 8 showRadix: true.
- self assert: (s contents = '8r173').!
Item was removed:
- ----- Method: IntegerTest>>testPrintStringBase (in category 'tests - printing') -----
- testPrintStringBase
-
- 2 to: 32 do: [:b |
- 1 to: 1000//b do: [:n |
- | bRaisedToN |
- bRaisedToN := b raisedTo: n.
- self assert: (bRaisedToN - 1 printStringBase: b) = (String new: n withAll: (Character digitValue: b-1)).
- self assert: (bRaisedToN printStringBase: b) = ('1' , (String new: n withAll: $0)).
-
- self assert: (bRaisedToN negated + 1 printStringBase: b) = ('-' , (String new: n withAll: (Character digitValue: b-1))).
- self assert: (bRaisedToN negated printStringBase: b) = ('-1' , (String new: n withAll: $0))]].
- !
Item was removed:
- ----- Method: IntegerTest>>testQuoRem (in category 'tests - arithmetic') -----
- testQuoRem
- | suite |
- suite := #( 1 2 5 1000 123456798 111222333444555 987654321098765432109876 ).
- suite := suite , (suite collect: [:e | e negated]).
- suite do: [:a |
- suite do: [:b |
- | q r |
- q := a quo: b.
- r := a rem: b.
- self assert: b * q + r = a.
- self assert: r abs < b abs.
- self assert: (r isZero or: [a negative = r negative])]].!
Item was removed:
- ----- Method: IntegerTest>>testRaisedToErrorConditions (in category 'tests - mathematical functions') -----
- testRaisedToErrorConditions
- "
- IntegerTest new testRaisedToErrorConditions
- "
-
- self should: [ -2 raisedTo: 1/4 ] raise: ArithmeticError.
- self should: [ -2 raisedTo: 1.24 ] raise: ArithmeticError.!
Item was removed:
- ----- Method: IntegerTest>>testRaisedToModulo (in category 'tests - arithmetic') -----
- testRaisedToModulo
- #(301 2047) do: [:m |
- 1 to: m - 1 by: (m // 30) do: [:x |
- 11 to: m - 1 by: (m // 40) do: [:y |
- self assert: (x raisedTo: y) \\ m = (x raisedTo: y modulo: m)]]].
- self assert: (8951195 raisedTo: 7742931 modulo: 15485863) = 15485862.!
Item was removed:
- ----- Method: IntegerTest>>testRange (in category 'tests - basic') -----
- testRange
- self assert: SmallInteger maxVal class equals: SmallInteger.
- self assert: (SmallInteger maxVal + 1) class equals: LargePositiveInteger.
- self assert: SmallInteger minVal class equals: SmallInteger.
- self assert: (SmallInteger minVal - 1) class equals: LargeNegativeInteger!
Item was removed:
- ----- Method: IntegerTest>>testReadFrom (in category 'tests - instance creation') -----
- testReadFrom
- "Ensure remaining characters in a stream are not lost when parsing an integer."
-
- #(
- ('12' 12 '')
- ('-350' -350 '')
- ('+27' 27 '')
- ('2r101 embedded radix are not allowed' 2 'r101 embedded radix are not allowed')
- ('25e3 exponent is ignored' 25 'e3 exponent is ignored')
- ('25s2 scale is ignored' 25 's2 scale is ignored')
- ('25. decimal separator is ignored' 25 '. decimal separator is ignored')
- ('25.30 fraction part is ignored' 25 '.30 fraction part is ignored')
- ('123r is not a radix specification' 123 'r is not a radix specification')
- ) do: [:each |
- [:string :numericValue :expectedRest |
- | readStream result rest |
- readStream := string readStream.
- result := Integer readFrom: readStream.
- rest := readStream upToEnd.
- self assert: result isInteger.
- self assert: result = numericValue.
- self assert: rest = expectedRest.
- ] valueWithArguments: each]!
Item was removed:
- ----- Method: IntegerTest>>testReciprocalModulo (in category 'tests - arithmetic') -----
- testReciprocalModulo
- 1 to: 512 do: [:a |
- a + 1 to: 512 do: [:b |
- | c |
- (a gcd: b) = 1
- ifTrue:
- [c := a reciprocalModulo: b.
- self assert: (a * c) \\ b = 1]
- ifFalse: [self should: [ a reciprocalModulo: b ] raise: Error]]].!
Item was removed:
- ----- Method: IntegerTest>>testRomanPrinting (in category 'tests - printing') -----
- testRomanPrinting
- self assert: 0 printStringRoman = ''. "No symbol for zero"
- self assert: 1 printStringRoman = 'I'.
- self assert: 2 printStringRoman = 'II'.
- self assert: 3 printStringRoman = 'III'.
- self assert: 4 printStringRoman = 'IV'.
- self assert: 5 printStringRoman = 'V'.
- self assert: 6 printStringRoman = 'VI'.
- self assert: 7 printStringRoman = 'VII'.
- self assert: 8 printStringRoman = 'VIII'.
- self assert: 9 printStringRoman = 'IX'.
- self assert: 10 printStringRoman = 'X'.
- self assert: 23 printStringRoman = 'XXIII'.
- self assert: 36 printStringRoman = 'XXXVI'.
- self assert: 49 printStringRoman = 'XLIX'.
- self assert: 62 printStringRoman = 'LXII'.
- self assert: 75 printStringRoman = 'LXXV'.
- self assert: 88 printStringRoman = 'LXXXVIII'.
- self assert: 99 printStringRoman = 'XCIX'.
- self assert: 100 printStringRoman = 'C'.
- self assert: 101 printStringRoman = 'CI'.
- self assert: 196 printStringRoman = 'CXCVI'.
- self assert: 197 printStringRoman = 'CXCVII'.
- self assert: 198 printStringRoman = 'CXCVIII'.
- self assert: 293 printStringRoman = 'CCXCIII'.
- self assert: 294 printStringRoman = 'CCXCIV'.
- self assert: 295 printStringRoman = 'CCXCV'.
- self assert: 390 printStringRoman = 'CCCXC'.
- self assert: 391 printStringRoman = 'CCCXCI'.
- self assert: 392 printStringRoman = 'CCCXCII'.
- self assert: 487 printStringRoman = 'CDLXXXVII'.
- self assert: 488 printStringRoman = 'CDLXXXVIII'.
- self assert: 489 printStringRoman = 'CDLXXXIX'.
- self assert: 584 printStringRoman = 'DLXXXIV'.
- self assert: 585 printStringRoman = 'DLXXXV'.
- self assert: 586 printStringRoman = 'DLXXXVI'.
- self assert: 681 printStringRoman = 'DCLXXXI'.
- self assert: 682 printStringRoman = 'DCLXXXII'.
- self assert: 683 printStringRoman = 'DCLXXXIII'.
- self assert: 778 printStringRoman = 'DCCLXXVIII'.
- self assert: 779 printStringRoman = 'DCCLXXIX'.
- self assert: 780 printStringRoman = 'DCCLXXX'.
- self assert: 875 printStringRoman = 'DCCCLXXV'.
- self assert: 876 printStringRoman = 'DCCCLXXVI'.
- self assert: 877 printStringRoman = 'DCCCLXXVII'.
- self assert: 972 printStringRoman = 'CMLXXII'.
- self assert: 973 printStringRoman = 'CMLXXIII'.
- self assert: 974 printStringRoman = 'CMLXXIV'.
- self assert: 1069 printStringRoman = 'MLXIX'.
- self assert: 1070 printStringRoman = 'MLXX'.
- self assert: 1071 printStringRoman = 'MLXXI'.
- self assert: 1166 printStringRoman = 'MCLXVI'.
- self assert: 1167 printStringRoman = 'MCLXVII'.
- self assert: 1168 printStringRoman = 'MCLXVIII'.
- self assert: 1263 printStringRoman = 'MCCLXIII'.
- self assert: 1264 printStringRoman = 'MCCLXIV'.
- self assert: 1265 printStringRoman = 'MCCLXV'.
- self assert: 1360 printStringRoman = 'MCCCLX'.
- self assert: 1361 printStringRoman = 'MCCCLXI'.
- self assert: 1362 printStringRoman = 'MCCCLXII'.
- self assert: 1457 printStringRoman = 'MCDLVII'.
- self assert: 1458 printStringRoman = 'MCDLVIII'.
- self assert: 1459 printStringRoman = 'MCDLIX'.
- self assert: 1554 printStringRoman = 'MDLIV'.
- self assert: 1555 printStringRoman = 'MDLV'.
- self assert: 1556 printStringRoman = 'MDLVI'.
- self assert: 1651 printStringRoman = 'MDCLI'.
- self assert: 1652 printStringRoman = 'MDCLII'.
- self assert: 1653 printStringRoman = 'MDCLIII'.
- self assert: 1748 printStringRoman = 'MDCCXLVIII'.
- self assert: 1749 printStringRoman = 'MDCCXLIX'.
- self assert: 1750 printStringRoman = 'MDCCL'.
- self assert: 1845 printStringRoman = 'MDCCCXLV'.
- self assert: 1846 printStringRoman = 'MDCCCXLVI'.
- self assert: 1847 printStringRoman = 'MDCCCXLVII'.
- self assert: 1942 printStringRoman = 'MCMXLII'.
- self assert: 1943 printStringRoman = 'MCMXLIII'.
- self assert: 1944 printStringRoman = 'MCMXLIV'.
- self assert: 2004 printStringRoman = 'MMIV'.
-
- self assert: -1 printStringRoman = '-I'.
- self assert: -2 printStringRoman = '-II'.
- self assert: -3 printStringRoman = '-III'.
- self assert: -4 printStringRoman = '-IV'.
- self assert: -5 printStringRoman = '-V'.
- self assert: -6 printStringRoman = '-VI'.
- self assert: -7 printStringRoman = '-VII'.
- self assert: -8 printStringRoman = '-VIII'.
- self assert: -9 printStringRoman = '-IX'.
- self assert: -10 printStringRoman = '-X'.
- !
Item was removed:
- ----- Method: IntegerTest>>testRoundDownTo (in category 'tests - truncation and round off') -----
- testRoundDownTo
-
- self
- assert: #( -40 -40 -40 -20 -20 -20 0 0 0 20 20 20 40 )
- equals: (#( -40 -30 -29 -20 -10 -9 0 9 10 20 29 30 40 )
- collect: [:num | num roundDownTo: 20]).!
Item was removed:
- ----- Method: IntegerTest>>testRoundTo (in category 'tests - truncation and round off') -----
- testRoundTo
-
- self
- assert: #( -40 -40 -20 -20 -20 0 0 0 20 20 20 40 40 )
- equals: (#( -40 -30 -29 -20 -10 -9 0 9 10 20 29 30 40 )
- collect: [:num | num roundTo: 20]).!
Item was removed:
- ----- Method: IntegerTest>>testRoundUpTo (in category 'tests - truncation and round off') -----
- testRoundUpTo
-
- self
- assert: #( -40 -20 -20 -20 0 0 0 20 20 20 40 40 40 )
- equals: (#( -40 -30 -29 -20 -10 -9 0 9 10 20 29 30 40 )
- collect: [:num | num roundUpTo: 20]).!
Item was removed:
- ----- Method: IntegerTest>>testSqrtErrorConditions (in category 'tests - mathematical functions') -----
- testSqrtErrorConditions
- "
- IntegerTest new testSqrtErrorConditions
- "
-
- self should: [ -1 sqrt ] raise: ArithmeticError!
Item was removed:
- ----- Method: IntegerTest>>testSqrtFloor (in category 'tests - mathematical functions') -----
- testSqrtFloor
-
- #(-1234567890123 -10 -5 -1) do: [ :each |
- self should: [ each sqrtFloor ] raise: Error ].
- #(
- 0 1 2 3 4 5 10 16 30 160479924 386234481 501619156 524723498 580855366 766098594 834165249 1020363860 1042083924 1049218924
- 1459774772895569 3050005981408238 4856589481837079 5650488387708463 7831037396100244) do: [ :each |
- self assert: each asFloat sqrt floor = each sqrtFloor ]
- !
Item was removed:
- ----- Method: IntegerTest>>testSqrtRem (in category 'tests - mathematical functions') -----
- testSqrtRem
-
- #(
- 0 1 2 3 4 5 10 16 30 160479924 386234481 501619156 524723498 580855366 766098594 834165249 1020363860 1042083924 1049218924
- 1459774772895569 3050005981408238 4856589481837079 5650488387708463 7831037396100244) do: [ :each |
- | sr |
- sr := each sqrtRem.
- self assert: sr first squared <= each.
- self assert: (sr first+1) squared > each.
- self assert: sr first squared + sr last = each]
- !
Item was removed:
- ----- Method: IntegerTest>>testTwoComplementBitLogicWithCarry (in category 'tests - bitLogic') -----
- testTwoComplementBitLogicWithCarry
- "This is non regression test for http://bugs.squeak.org/view.php?id=6874"
-
- "By property of two complement, following operation is:
- ...111110000 this is -16
- ...111101111 this is -16-1
- ...111100000 this is -32, the result of bitAnd: on two complement
-
- This test used to fail with n=31 39 47.... because of bug 6874"
-
- self assert: ((2 to: 80) allSatisfy: [:n | ((2 raisedTo: n) negated bitAnd: (2 raisedTo: n) negated - 1) = (2 raisedTo: n + 1) negated]).!
Item was removed:
- ----- Method: IntegerTest>>testTwoComplementRightShift (in category 'tests - bitLogic') -----
- testTwoComplementRightShift
- "self run: #testTwoComplementRightShift"
-
- | large small |
- small := 2 << 16.
- large := 2 << 32.
- self assert: ((small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1)
- == ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))).
-
- self assert: ((small bitShift: -1) ~= (small + 1 bitShift: -1)
- == ((large bitShift: -1) ~= (large + 1 bitShift: -1))).!
Item was removed:
- ClassTestCase subclass: #LargeNegativeIntegerTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testDenormalizedPrintString (in category 'tests') -----
- testDenormalizedPrintString
- "Check that an un-normalized instance behaves reasonably."
-
- | i i0 |
- i := LargeNegativeInteger new: 4.
- i basicAt: 2 put: 255.
- self assert: i size = 4.
- self assert: i printString = '-65280'. "-256*255"
- self assert: i normalize = -65280.
- self assert: (i normalize isMemberOf: SmallInteger).
-
- i0 := LargeNegativeInteger new: 0.
- self assert: i0 size = 0.
- self assert: i0 printString = '-0'.
- self assert: i0 normalize = 0.
- self assert: (i0 normalize isMemberOf: SmallInteger)!
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testDigitAt (in category 'tests') -----
- testDigitAt
-
- | lni |
- lni := -114605103402541699037609980192546360895434064385.
- 1 to: 20 do: [:i | | digit |
- digit := lni digitAt: i.
- self assert: i equals: digit]
- !
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testDigitAtPut (in category 'tests') -----
- testDigitAtPut
-
- | lni |
- lni := LargeNegativeInteger new: 20.
- 1 to: 20 do: [:i | lni digitAt: i put: i].
- self assert: -114605103402541699037609980192546360895434064385equals: lni
- !
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testDigitLength (in category 'tests') -----
- testDigitLength
-
- | lni |
- lni := -114605103402541699037609980192546360895434064385.
- self assert: 20 equals: lni digitLength
- !
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testEmptyTemplate (in category 'tests') -----
- testEmptyTemplate
- "Check that an uninitialized instance behaves reasonably."
-
- | i |
- i := LargeNegativeInteger new: 4.
- self assert: i size = 4.
- self assert: i printString = '-0'.
- self assert: i normalize = 0.
- self assert: (i normalize isMemberOf: SmallInteger)!
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testMinimumNegativeIntegerArithmetic (in category 'tests') -----
- testMinimumNegativeIntegerArithmetic
- "We are speaking of minimum integer in underlying hardware here.
- In 2-complement, abs(INT_MIN) = (INT-MAX+1) and thus overflows hardware register.
- Since some old VM forgot this edge case they may fail and it's better to be aware of it.
- http://code.google.com/p/cog/issues/detail?id=92
- http://bugs.squeak.org/view.php?id=7705
- We only test the cases of 32 and 64 bit signed integers."
-
- #(32 64) do: [:nBits |
- | largePositiveInt largeNegativeInt |
- largePositiveInt := (1 << (nBits - 1)).
- largeNegativeInt := largePositiveInt negated.
- self assert: (largeNegativeInt >> 3) equals: (largeNegativeInt bitInvert >> 3) bitInvert.
- self assert: (largeNegativeInt + 1) equals: (largePositiveInt - 1) negated.
- self assert: (largeNegativeInt - -1) equals: (largePositiveInt - 1) negated.
- self assert: (largeNegativeInt // -1) equals: largePositiveInt.
- self assert: (largeNegativeInt \\ -1) equals: 0.
- self assert: (largeNegativeInt rem: -1) equals: 0.
- self assert: (largeNegativeInt quo: -1) equals: largePositiveInt.
- self assert: (largeNegativeInt * -1) equals: largePositiveInt.
- self assert: (largeNegativeInt / -1) equals: largePositiveInt]!
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testReplaceFromToWithStartingAt (in category 'tests') -----
- testReplaceFromToWithStartingAt
-
- | lni20 lni7 |
- lni20 := LargeNegativeInteger new: 20.
- 1 to: 20 do: [:i | lni20 digitAt: i put: i].
- lni7 := LargeNegativeInteger new: 7.
- 1 to: 7 do: [:i | lni7 digitAt: i put: 11 - i].
- lni20 replaceFrom: 6 to: 10 with: lni7 startingAt: 2.
- "unmodified digits"
- (1 to: 5) , (11 to: 20) do: [:e | | digit |
- digit := lni20 digitAt: e.
- self assert: e equals: digit].
- "replaced digits"
- 6 to: 10 do: [:e | | digit replacementDigit |
- digit := lni20 digitAt: e.
- replacementDigit := lni7 digitAt: e - 4.
- self assert: replacementDigit equals: digit]
- !
Item was removed:
- ----- Method: LargeNegativeIntegerTest>>testSqrt (in category 'tests - mathematical functions') -----
- testSqrt
- self should: [(SmallInteger minVal - 1) sqrt] raise: DomainError!
Item was removed:
- ClassTestCase subclass: #LargePositiveIntegerTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>assert:classAndValueEquals: (in category 'asserting') -----
- assert: expected classAndValueEquals: actual
- self
- assert: expected equals: actual;
- assert: expected class equals: actual class.!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>assertSqrtCorrectlyRoundedForExponent: (in category 'asserting') -----
- assertSqrtCorrectlyRoundedForExponent: exp
- "Requires exp > Float precision, so that f ulp/2 is integer"
- {1.5. 1.25 squared. 2.0 predecessor} do: [:sf |
- | f xe xp xm |
-
- f := sf timesTwoPower: exp.
-
- "make two integers around the pivot"
- xe := f asInteger + (f ulp asInteger / 2).
- xm := xe squared - 1.
- xp := xe squared + 1.
- self assert: xe squared sqrt equals: xe.
- self assert: xe squared sqrt isInteger.
-
- "check rounding when result is near f squared"
- self assert: xm sqrt equals: f.
- self assert: xm sqrt isFloat.
- self assert: xp sqrt equals: f successor.
- self assert: xp sqrt isFloat.
-
- "same in the other direction"
- xe := f asInteger - (f ulp asInteger / 2).
- xm := xe squared - 1.
- xp := xe squared + 1.
- self assert: xe squared sqrt equals: xe.
- self assert: xe squared sqrt isInteger.
-
- "check rounding when result is near f squared"
- self assert: xm sqrt equals: f predecessor.
- self assert: xm sqrt isFloat.
- self assert: xp sqrt equals: f.
- self assert: xp sqrt isFloat].!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testBitShift (in category 'tests') -----
- testBitShift
-
- "Check bitShift from and back to SmallInts"
-
- 1 to: 257 do: [:i | self should: [((i bitShift: i) bitShift: 0-i) == i]].!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testDenormalizedPrintString (in category 'tests') -----
- testDenormalizedPrintString
- "Check that an un-normalized instance behaves reasonably."
-
- | i i0 |
- i := LargePositiveInteger new: 4.
- i basicAt: 2 put: 255.
- self assert: i size = 4.
- self assert: i printString = '65280'. "256*255"
- self assert: i normalize = 65280.
- self assert: (i normalize isMemberOf: SmallInteger).
-
- i0 := LargePositiveInteger new: 0.
- self assert: i0 size = 0.
- self assert: i0 printString = '0'.
- self assert: i0 normalize = 0.
- self assert: (i0 normalize isMemberOf: SmallInteger)!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testDigitAt (in category 'tests') -----
- testDigitAt
-
- | lpi |
- lpi := 114605103402541699037609980192546360895434064385.
- 1 to: 20 do: [:i | | digit |
- digit := lpi digitAt: i.
- self assert: i equals: digit]
- !
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testDigitAtPut (in category 'tests') -----
- testDigitAtPut
-
- | lpi |
- lpi := LargePositiveInteger new: 20.
- 1 to: 20 do: [:i | lpi digitAt: i put: i].
- self assert: 114605103402541699037609980192546360895434064385equals: lpi
- !
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testDigitDiv (in category 'tests') -----
- testDigitDiv
- | a b q r qr ap bp |
- ap := self x23kbits.
- bp := self x13kbits.
- self assert: (ap digitDivSplit: bp) = ((ap digitDiv: bp neg: false) collect: #normalize).
- #(#yourself #negated) do: [:opa |
- #(#yourself #negated) do: [:opb |
- a := ap perform: opa.
- b := bp perform: opb.
- qr := a digitDiv: b neg: opa ~~ opb.
- q := qr first normalize.
- r := qr last normalize.
- self assert: q * b + r = a.
- self assert: r abs < b abs.
- self assert: a positive ==> r positive.
- self assert: a negative ==> (r negative | r isZero)]]
- !
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testDigitLength (in category 'tests') -----
- testDigitLength
-
- | lpi |
- lpi := 114605103402541699037609980192546360895434064385.
- self assert: 20 equals: lpi digitLength
- !
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testEmptyTemplate (in category 'tests') -----
- testEmptyTemplate
-
- "Check that an uninitialized instance behaves reasonably."
-
- | i |
- i := LargePositiveInteger new: 4.
- self assert: i size = 4.
- self assert: i printString = '0'.
- self assert: i normalize = 0.
- self assert: (i normalize isMemberOf: SmallInteger)!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testFastMultiply (in category 'tests') -----
- testFastMultiply
- | a b ab ap bp |
- ap := self x92kbits.
- bp := self x106kbits.
- #(#yourself #negated) do: [:opa |
- #(#yourself #negated) do: [:opb |
- a := ap perform: opa.
- b := bp perform: opb.
- ab := a * b.
- self assert: (a multiplyByInteger: b) = ab.
- self assert: (a digitMultiply: b neg: a negative ~~ b negative) = ab.
- self assert: (a digitMul22: b) = ab.
- self assert: (a digitMul23: b) = ab.
- self assert: (a digitMul33: b) = ab]]!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testLargeSqrtFloor (in category 'tests') -----
- testLargeSqrtFloor
- "This test fails if a careless implementation naivly factors out the power of two (remove the trailing zeroes up to lowBit).
- This was the case in a previous Squeak 4.x implementation."
-
- | large root |
- large := (SmallInteger maxVal << 100 + 1) << 100.
- root := large sqrtFloor.
- self assert: root squared <= large.
- self assert: (root+1) squared > large.!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testMultDicAddSub (in category 'tests') -----
- testMultDicAddSub
- "self run: #testMultDicAddSub"
-
- | n f f1 |
- n := 100.
- f := 100 factorial.
- f1 := f*(n+1).
- n timesRepeat: [f1 := f1 - f].
- self assert: (f1 = f).
-
- n timesRepeat: [f1 := f1 + f].
- self assert: (f1 // f = (n+1)).
- self assert: (f1 negated = (Number readFrom: '-' , f1 printString)).!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testNormalize (in category 'tests') -----
- testNormalize
- "self run: #testNormalize"
- "Check normalization and conversion to/from SmallInts"
-
- self assert: ((SmallInteger maxVal + 1 - 1) == SmallInteger maxVal).
- self assert: (SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3).
- self should: ((SmallInteger minVal - 1 + 1) == SmallInteger minVal).
- self assert: (SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3).!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testReciprocalModulo (in category 'tests') -----
- testReciprocalModulo
- | large r |
- large := 1 bitShift: 48.
- r := Random seed: 46912151.
- 4691 timesRepeat:
- [| a b c t |
- a := (r nextInt: large) + 1.
- b := (r nextInt: large) + 1.
- a > b ifTrue: [t := a. a:= b. b := t].
- (a gcd: b) = 1
- ifTrue:
- [c := a reciprocalModulo: b.
- self assert: (a * c) \\ b = 1.]
- ifFalse: [self should: [ a reciprocalModulo: b ] raise: Error]].!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testReplaceFromToWithStartingAt (in category 'tests') -----
- testReplaceFromToWithStartingAt
-
- | lpi20 lpi7 |
- lpi20 := LargePositiveInteger new: 20.
- 1 to: 20 do: [:i | lpi20 digitAt: i put: i].
- lpi7 := LargePositiveInteger new: 7.
- 1 to: 7 do: [:i | lpi7 digitAt: i put: 11 - i].
- lpi20 replaceFrom: 6 to: 10 with: lpi7 startingAt: 2.
- "unmodified digits"
- (1 to: 5) , (11 to: 20) do: [:e | | digit |
- digit := lpi20 digitAt: e.
- self assert: e equals: digit].
- "replaced digits"
- 6 to: 10 do: [:e | | digit replacementDigit |
- digit := lpi20 digitAt: e.
- replacementDigit := lpi7 digitAt: e - 4.
- self assert: replacementDigit equals: digit]
- !
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testSqrt (in category 'tests - mathematical functions') -----
- testSqrt
- self assert: (SmallInteger maxVal + 1) sqrt equals: (SmallInteger maxVal + 1) asFloat sqrt.!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testSqrtCorrectlyRounded (in category 'tests - mathematical functions') -----
- testSqrtCorrectlyRounded
- self assertSqrtCorrectlyRoundedForExponent: Float precision * 2 - 1.
- self assertSqrtCorrectlyRoundedForExponent: Float precision * 2 + 1.
- self assertSqrtCorrectlyRoundedForExponent: Float precision * 2 + 3.
- self assertSqrtCorrectlyRoundedForExponent: Float precision * 3 // 2.
- self assertSqrtCorrectlyRoundedForExponent: Float emax* 2 // 3. "such that asFloat would overflow"
- self assertSqrtCorrectlyRoundedForExponent: Float emax.!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testSqrtNearExactTie (in category 'tests - mathematical functions') -----
- testSqrtNearExactTie
- | p q evenTie oddTie perfectSquare inexactSquare |
- "first construct square root results that lie exactly between 2 consecutive Float"
- p := Float precision.
- q := Float precision // 4.
- evenTie := 1 << q + 1 << q + 1 << (p - q - q) + 1.
- self assert: p + 1 = evenTie highBit.
- self assert: evenTie asFloat significandAsInteger even. "evenTie round down to even"
- self assert: evenTie asFloat ulp asFraction / 2 + evenTie asFloat asFraction = evenTie.
- oddTie := 1 << q + 1 << q + 1 << (p - q - q) + 2r11.
- self assert: p + 1 = oddTie highBit.
- self assert: oddTie asFloat significandAsInteger even. "oddTie round up to even"
- self assert: oddTie asFloat ulp asFraction / -2 + oddTie asFloat asFraction = oddTie.
-
- "then assert that we can retrieve the exact root"
- perfectSquare := evenTie squared.
- self assert: perfectSquare sqrt classAndValueEquals: evenTie.
-
- "now take an inexact square by excess : it falls above exact tie, and should round up"
- inexactSquare := evenTie squared + 1.
- self deny: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: evenTie asFloat successor.
- "same with one possibly exact square so that we take both paths"
- inexactSquare := evenTie squared + 3.
- self assert: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: evenTie asFloat successor.
- "same with less bits and a possibly exact square so that we explore yet another path"
- inexactSquare := evenTie squared + 3 // 4.
- self assert: inexactSquare * 4 equals: evenTie squared + 3.
- self assert: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: (evenTie asFloat successor / 2).
- "same with very very far bit to solve the tie"
- inexactSquare := evenTie squared << 100 + 2.
- self deny: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: (evenTie asFloat successor timesTwoPower: 50).
-
- "Redo the same with odd tie, just to be sure"
- perfectSquare := oddTie squared.
- self assert: perfectSquare sqrt classAndValueEquals: oddTie.
-
- "now take an inexact square by default : it falls below exact tie, and should round down"
- inexactSquare := oddTie squared - 1.
- self deny: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: oddTie asFloat predecessor.
- "same for not possibly exact case"
- inexactSquare := oddTie squared - 5.
- self assert: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: oddTie asFloat predecessor.
- "same with less bits"
- inexactSquare := oddTie squared - 9 // 4.
- self assert: inexactSquare * 4 equals: oddTie squared - 9.
- self assert: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: (oddTie asFloat predecessor / 2).
- "same with very very far bit to solve the tie"
- inexactSquare := oddTie squared << 100 - 2.
- self deny: inexactSquare mightBeASquare.
- self assert: inexactSquare sqrt classAndValueEquals: (oddTie asFloat predecessor timesTwoPower: 50).!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testSqrtRem (in category 'tests') -----
- testSqrtRem
- | x sr |
- x := self x92kbits.
- sr := x sqrtRem.
- self assert: sr first squared <= x.
- self assert: (sr first+1) squared > x.
- self assert: sr first squared + sr last = x.!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>testSquared (in category 'tests') -----
- testSquared
-
- | large ref |
- large := self x23kbits.
- ref := large * large.
- self assert: ref = large squared.
- self assert: ref = large squaredByHalf.
- self assert: ref = large squaredByThird.
- self assert: ref = large squaredByFourth.!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>x106kbits (in category 'accessing') -----
- x106kbits
- "Return a 106 kilo bits integer"
- ^(15 to: 55 by: 4)
- inject: 9876543210
- into: [:big :bits | big * big << bits + bits]!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>x13kbits (in category 'accessing') -----
- x13kbits
- "Return a 13 kilo bits integer"
- ^(15 to: 44 by: 4)
- inject: 9753102468
- into: [:big :bits | big * big << bits + bits]!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>x23kbits (in category 'accessing') -----
- x23kbits
- "Return a 23 kilo bits integer"
- ^(11 to: 44 by: 4)
- inject: 1234567890
- into: [:big :bits | big * big << bits + bits]!
Item was removed:
- ----- Method: LargePositiveIntegerTest>>x92kbits (in category 'accessing') -----
- x92kbits
- "Return a 92 kilo bits integer"
- ^(11 to: 51 by: 4)
- inject: 1357924680
- into: [:big :bits | big * big << bits + bits]!
Item was removed:
- TestCase subclass: #LiteralRefLocatorTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: LiteralRefLocatorTest>>testFindLiteralsInBytecode (in category 'tests') -----
- testFindLiteralsInBytecode
- "Create a method referencing integers, characters, special selectors and nil, true & false.
- Compile it and check that the objects are found."
- | source primary secondary binarySpecials integers characters |
- binarySpecials := Smalltalk specialSelectors select: [:s| s isSymbol and: [s isBinary]].
- "-65536 to 65535 in powers of two"
- integers := ((16 to: 1 by: -1) collect: [:power| (2 raisedTo: power) negated]),
- ((0 to: 16) collect: [:power| (2 raisedTo: power) - 1]).
- "some printable characters; alas none have code > 255"
- characters := (0 to: 65535)
- select: [:n| (n between: 132 and: 160) not "these have no glyph in typical fonts"
- and: [(Character value: n) shouldBePrintedAsLiteral]]
- thenCollect: [:n| Character value: n].
- [characters size > 32] whileTrue:
- [characters := (1 to: characters size by: 2) collect: [:i| characters at: i]].
-
- #(('' '') ('^[' ']')) do: "And the locators should work whether in a block or not"
- [:pFixes|
- source := ByteString streamContents:
- [:s| | binaries |
- binaries := binarySpecials readStream.
- s nextPutAll: 'exampleMethod'; crtab; nextPutAll: pFixes first.
- integers
- do: [:n| s print: n]
- separatedBy:
- [binaries atEnd ifTrue: [binaries reset].
- s space; nextPutAll: binaries next; space].
- s nextPut: $.; crtab.
- s nextPut: ${; space.
- characters
- do: [:c| s print: c]
- separatedBy: [s nextPut: $.; space].
- s space; nextPut: $}; nextPut: $.; crtab.
- s nextPutAll: 'true ifTrue: [^nil] ifFalse: [^false]'; nextPutAll: pFixes last].
- primary := CompiledCode classPool at: #PrimaryBytecodeSetEncoderClass.
- secondary := CompiledCode classPool at: #SecondaryBytecodeSetEncoderClass.
- { primary. secondary } do:
- [:encoderClass| | method |
- method := (Parser new
- encoderClass: encoderClass;
- parse: source class: self class)
- generate: CompiledMethodTrailer empty.
- binarySpecials, integers, characters, #(nil false true) do:
- [:literal | self assert: (method hasLiteral: literal)].
-
- "Now test for false positives..."
- integers, characters, #(nil false true) do:
- [:literal| | simpleSource simpleMethod |
- simpleSource := ByteString streamContents:
- [:s| s nextPutAll: 'exampleMethod'; crtab; nextPutAll: pFixes first; print: literal; nextPutAll: ' class'; nextPutAll: pFixes last].
- simpleMethod := (Parser new
- encoderClass: encoderClass;
- parse: simpleSource class: self class)
- generate: CompiledMethodTrailer empty.
- binarySpecials, integers, characters, #(nil false true) do: [:anyLiteral |
- anyLiteral == literal
- ifTrue: [self assert: (simpleMethod hasLiteral: anyLiteral)]
- ifFalse: [self deny: (simpleMethod hasLiteral: anyLiteral)]]]]]!
Item was removed:
- ----- Method: LiteralRefLocatorTest>>testThoroughFindLiteralsInBytecode (in category 'tests') -----
- testThoroughFindLiteralsInBytecode
- "Create a method referencing integers, characters, special selectors and nil, true & false.
- Compile it and check that the objects are found."
- | literals problem primary secondary |
- literals := #(-1 0 1 $0 $1 1.0 #[1 2 3 4] 'one' #one nil true false NaN).
- problem := Float bindingOf: #NaN.
- primary := CompiledCode classPool at: #PrimaryBytecodeSetEncoderClass.
- secondary := CompiledCode classPool at: #SecondaryBytecodeSetEncoderClass.
- { primary. secondary } do:
- [:encoderClass| | method |
- #(('' '') ('^[' ']')) do: "And the locators should work whether in a block or not"
- [:pFixes|
- "NaN's binding should still be found even though (Float bindingOf: #NaN) ~= (Float bindingOf: #NaN)"
- method := (Parser new
- encoderClass: encoderClass;
- parse: 'foo ', pFixes first, '^NaN', pFixes last class: Float)
- generate: CompiledMethodTrailer empty.
-
- "Check our problematic case first."
- self assert: (method hasLiteral: problem).
- "The selector of a method should never be found (unless it occurs as a literal or in a pragma)"
- self deny: (method hasLiteral: method selector).
-
- "All the literals should be found in a thorough search, but not otherwise"
- method := (Parser new
- encoderClass: encoderClass;
- parse: 'foo ', pFixes first, '^', literals storeString, pFixes last class: Float)
- generate: CompiledMethodTrailer empty.
- literals, {problem key} do:
- [:literal | self assert: (method hasLiteral: literal)]].
-
- "Likewise if in a pragma"
- method := (Parser new
- encoderClass: encoderClass;
- parse: 'foo <pragma: ', literals storeString, ' with: ', problem key storeString, '>' class: Float)
- generate: CompiledMethodTrailer empty.
- literals, {problem key} do:
- [:literal | self assert: (method hasLiteral: literal)]]!
Item was removed:
- TestCase subclass: #MessageSendTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: MessageSendTest>>testNumArgs (in category 'tests') -----
- testNumArgs
- self
- assert:
- (MessageSend
- receiver: Dictionary new
- selector: #at:put:) numArgs = 2 ;
- assert:
- (MessageSend
- receiver: 3
- selector: #sqrt) numArgs = 0!
Item was removed:
- TestCase subclass: #MessageTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: MessageTest>>testMessageEquality (in category 'tests') -----
- testMessageEquality
-
- self assert: (Message selector: #= argument: 1) equals: (Message selector: #= argument: 1).
- self assert: (Message selector: #= argument: 1) hash equals: (Message selector: #= argument: 1) hash.
- self deny: (Message selector: #= argument: 1) equals: (Message selector: #= argument: 1.0)!
Item was removed:
- TestCase subclass: #MethodPragmaTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: MethodPragmaTest>>assertPragma:givesKeyword:arguments: (in category 'utilities') -----
- assertPragma: aString givesKeyword: aSymbol arguments: anArray
- | pragma decompiled pragmaString index |
- pragma := self pragma: aString selector: #zork.
- self assert: aSymbol equals: pragma keyword.
- self assert: anArray equals: pragma arguments.
- decompiled := (self class>>#zork) decompile.
- self assert: (decompiled properties pragmas includes: pragma).
- pragmaString := pragma printString.
- "Pragma printString may contain a comment; if so, delete it"
- (index := pragmaString indexOfSubCollection: '> "in ') > 0 ifTrue:
- [pragmaString := pragmaString copyFrom: 1 to: index].
- self assert: (decompiled printString includesSubstring: pragmaString)!
Item was removed:
- ----- Method: MethodPragmaTest>>compile:selector: (in category 'utilities') -----
- compile: aString selector: aSelector
- self class
- compileSilently: aSelector , String lf , aString
- classified: self methodCategory.
- ^ self class >> aSelector.!
Item was removed:
- ----- Method: MethodPragmaTest>>methodCategory (in category 'utilities') -----
- methodCategory
- ^ #generated!
Item was removed:
- ----- Method: MethodPragmaTest>>pragma:selector: (in category 'utilities') -----
- pragma: aString selector: aSelector
- ^ (self compile: '<' , aString , '>' selector: aSelector)
- pragmas first.!
Item was removed:
- ----- Method: MethodPragmaTest>>pragma:selector:times: (in category 'utilities') -----
- pragma: aSymbol selector: aSelector times: anInteger
- ^ (self
- compile: (String streamContents: [ :stream |
- (1 to: anInteger) asArray shuffled do: [ :each |
- stream
- nextPut: $<; nextPutAll: aSymbol; space;
- print: each; nextPut: $>; cr ] ])
- selector: aSelector)
- pragmas.!
Item was removed:
- ----- Method: MethodPragmaTest>>tearDown (in category 'running') -----
- tearDown
- (self class organization listAtCategoryNamed: self methodCategory)
- do: [ :each | self class removeSelectorSilently: each ].
- self class organization removeCategory: self methodCategory.!
Item was removed:
- ----- Method: MethodPragmaTest>>testAllNamedFromTo (in category 'tests-finding') -----
- testAllNamedFromTo
- | pragmasCompiled pragmasDetected |
- pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
- pragmasDetected := Pragma allNamed: #foo: from: self class to: Object.
- self assert: pragmasDetected = pragmasCompiled.
-
- pragmasDetected := Pragma allNamed: #foo: from: Object to: Object.
- self assert: pragmasDetected isEmpty.!
Item was removed:
- ----- Method: MethodPragmaTest>>testAllNamedFromToSortedByArgument (in category 'tests-finding') -----
- testAllNamedFromToSortedByArgument
- | pragmasCompiled pragmasDetected |
- pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
- pragmasDetected := Pragma allNamed: #foo: from: self class to: Object sortedByArgument: 1.
- self assert: pragmasDetected = (pragmasCompiled
- sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])!
Item was removed:
- ----- Method: MethodPragmaTest>>testAllNamedFromToSortedUsing (in category 'tests-finding') -----
- testAllNamedFromToSortedUsing
- | pragmasCompiled pragmasDetected |
- pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
- pragmasDetected := Pragma
- allNamed: #foo: from: self class to: Object
- sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ].
- self assert: pragmasDetected = (pragmasCompiled
- sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).!
Item was removed:
- ----- Method: MethodPragmaTest>>testAllNamedIn (in category 'tests-finding') -----
- testAllNamedIn
- | pragmasCompiled pragmasDetected |
- pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
- pragmasDetected := Pragma allNamed: #foo: in: self class.
- self assert: pragmasDetected = pragmasCompiled.
-
- pragmasDetected := Pragma allNamed: #foo: in: Object.
- self assert: pragmasDetected isEmpty.!
Item was removed:
- ----- Method: MethodPragmaTest>>testAllNamedInSortedByArgument (in category 'tests-finding') -----
- testAllNamedInSortedByArgument
- | pragmasCompiled pragmasDetected |
- pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
- pragmasDetected := Pragma allNamed: #foo: in: self class sortedByArgument: 1.
- self assert: pragmasDetected = (pragmasCompiled
- sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])!
Item was removed:
- ----- Method: MethodPragmaTest>>testAllNamedInSortedUsing (in category 'tests-finding') -----
- testAllNamedInSortedUsing
- | pragmasCompiled pragmasDetected |
- pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
- pragmasDetected := Pragma
- allNamed: #foo: in: self class
- sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ].
- self assert: pragmasDetected = (pragmasCompiled
- sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).!
Item was removed:
- ----- Method: MethodPragmaTest>>testArguments (in category 'tests-pragma') -----
- testArguments
- | pragma |
- pragma := Pragma keyword: #foo: arguments: #( 123 ).
- self assert: pragma arguments = #( 123 ).!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileArray (in category 'tests-compiler') -----
- testCompileArray
- self assertPragma: 'foo: #()' givesKeyword: #foo: arguments: #( () ).
- self assertPragma: 'foo: #( foo )' givesKeyword: #foo: arguments: #( ( foo ) ).
- self assertPragma: 'foo: #( foo: )' givesKeyword: #foo: arguments: #( ( foo: ) ).
- self assertPragma: 'foo: #( 12 )' givesKeyword: #foo: arguments: #( ( 12 ) ).
- self assertPragma: 'foo: #( true )' givesKeyword: #foo: arguments: #( ( true ) ).
- !
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileBinary (in category 'tests-compiler') -----
- testCompileBinary
- self assertPragma: ' = 1' givesKeyword: #= arguments: #( 1 ).
- self assertPragma: ' , 3' givesKeyword: #, arguments: #( 3 ).
- self assertPragma: ' > 4' givesKeyword: #> arguments: #( 4 ).
- self assertPragma: ' < 5' givesKeyword: #< arguments: #( 5 ).
-
- self assertPragma: ' == 1' givesKeyword: #== arguments: #( 1 ).
- self assertPragma: ' <> 3' givesKeyword: #<> arguments: #( 3 ).
- self assertPragma: ' >< 4' givesKeyword: #>< arguments: #( 4 ).
- self assertPragma: ' ** 5' givesKeyword: #** arguments: #( 5 )!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileCharacter (in category 'tests-compiler') -----
- testCompileCharacter
- self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ).
- self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: { Character space }.!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileEmpty (in category 'tests-compiler') -----
- testCompileEmpty
- self assertPragma: 'foo' givesKeyword: #foo arguments: #().!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileFull (in category 'tests-compiler') -----
- testCompileFull
- self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ).
- self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileInvalid (in category 'tests-compiler') -----
- testCompileInvalid
- "Invalid pragmas should properly raise an error."
-
- self should: [ self compile: '<>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<1>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<#123>' selector: #zork ] raise: SyntaxErrorNotification.
-
- self should: [ self compile: '<foo bar>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<foo 1>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<foo bar zork>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<foo bar 1>' selector: #zork ] raise: SyntaxErrorNotification.
-
- self should: [ self compile: '<foo: bar:>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<foo: #bar: zork:>' selector: #zork ] raise: SyntaxErrorNotification.
-
- self should: [ self compile: '<<1>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<=2>' selector: #zork ] raise: SyntaxErrorNotification.
-
- self should: [ self compile: '< =1 = >' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '< =1 =2 >' selector: #zork ] raise: SyntaxErrorNotification.
-
- self should: [ self compile: '<foo: String>' selector: #zork ] raise: SyntaxErrorNotification.
- self should: [ self compile: '<foo: Pragma>' selector: #zork ] raise: SyntaxErrorNotification!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileNumber (in category 'tests-compiler') -----
- testCompileNumber
- self assertPragma: 'foo: 123' givesKeyword: #foo: arguments: #( 123 ).
- self assertPragma: 'foo: -123' givesKeyword: #foo: arguments: #( -123 ).
- self assertPragma: 'foo: 12.3' givesKeyword: #foo: arguments: #( 12.3 ).
- self assertPragma: 'foo: -12.3' givesKeyword: #foo: arguments: #( -12.3 ).!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileString (in category 'tests-compiler') -----
- testCompileString
- self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ).
- self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileSymbol (in category 'tests-compiler') -----
- testCompileSymbol
- self assertPragma: 'foo: #bar' givesKeyword: #foo: arguments: #( bar ).
- self assertPragma: 'foo: #bar:' givesKeyword: #foo: arguments: #( bar: ).
- self assertPragma: 'foo: #bar:zork:' givesKeyword: #foo: arguments: #( bar:zork: ).!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileTemps (in category 'tests-compiler') -----
- testCompileTemps
- "Pragmas should be placeable before and after temps."
-
- self
- shouldnt: [
- self assert: (self compile: '| temps | <foo>' selector: #zork)
- pragmas notEmpty ]
- raise: SyntaxErrorNotification.
- self
- shouldnt: [
- self assert: (self compile: '<foo> | temps |' selector: #zork)
- pragmas notEmpty ]
- raise: SyntaxErrorNotification.!
Item was removed:
- ----- Method: MethodPragmaTest>>testCompileValue (in category 'tests-compiler') -----
- testCompileValue
- self assertPragma: 'foo: true' givesKeyword: #foo: arguments: #( true ).
- self assertPragma: 'foo: false' givesKeyword: #foo: arguments: #( false ).
- self assertPragma: 'foo: nil' givesKeyword: #foo: arguments: #( nil )!
Item was removed:
- ----- Method: MethodPragmaTest>>testKeyword (in category 'tests-pragma') -----
- testKeyword
- | pragma |
- pragma := Pragma keyword: #foo: arguments: #( 123 ).
- self assert: pragma keyword = #foo:.!
Item was removed:
- ----- Method: MethodPragmaTest>>testMessage (in category 'tests-pragma') -----
- testMessage
- | pragma message |
- pragma := Pragma keyword: #foo: arguments: #( 123 ).
- message := pragma message.
-
- self assert: message selector = #foo:.
- self assert: message arguments = #( 123 ).!
Item was removed:
- ----- Method: MethodPragmaTest>>testMethod (in category 'tests-method') -----
- testMethod
- | pragma |
- pragma := self pragma: 'foo' selector: #bar.
- self assert: pragma method == (self class >> #bar).!
Item was removed:
- ----- Method: MethodPragmaTest>>testMethodClass (in category 'tests-method') -----
- testMethodClass
- | pragma |
- pragma := self pragma: 'foo' selector: #bar.
- self assert: pragma methodClass == self class.!
Item was removed:
- ----- Method: MethodPragmaTest>>testNoPragma (in category 'tests-compiled') -----
- testNoPragma
- | method |
- method := self compile: '' selector: #foo.
- self assert: method pragmas = #().!
Item was removed:
- ----- Method: MethodPragmaTest>>testPrimitiveIndexed1 (in category 'tests-primitives') -----
- testPrimitiveIndexed1
- "This test useses the #instVarAt: primitive."
-
- self compile: '<primitive: 74> ^ #inst' selector: #inst.
- self assert: self inst = #inst.!
Item was removed:
- ----- Method: MethodPragmaTest>>testPrimitiveIndexed2 (in category 'tests-primitives') -----
- testPrimitiveIndexed2
- "This test useses the #asOop primitive."
-
- self compile: '<primitive: 75> ^ #oop' selector: #oop.
- self assert: self oop = self asOop.!
Item was removed:
- ----- Method: MethodPragmaTest>>testPrimitiveNamed1 (in category 'tests-primitives') -----
- testPrimitiveNamed1
- "This test useses the #primitiveDirectoryLookup primitive."
-
- self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin''> ^ #lookup' selector: #lookup.
- self assert: self lookup = #lookup.
-
- !
Item was removed:
- ----- Method: MethodPragmaTest>>testPrimitiveNamed2 (in category 'tests-primitives') -----
- testPrimitiveNamed2
- "This test useses the #primPathNameDelimiter primitive."
-
- self compile: '<primitive: ''primitiveDirectoryDelimitor'' module: ''FilePlugin''> ^ #delim' selector: #delim.
- self assert: self delim = FileDirectory primPathNameDelimiter.
-
- !
Item was removed:
- ----- Method: MethodPragmaTest>>testReformat (in category 'tests-printing-reformating') -----
- testReformat
- self assert: (DisplayScreen class compiledMethodAt: #actualScreenDepth) getSource string = 'actualScreenDepth
- <primitive: ''primitiveScreenDepth''>
- ^ Display depth'.
-
- self assert: (DisplayScreen class compiledMethodAt: #actualScreenDepth) getSource string = 'actualScreenDepth
- <primitive: ''primitiveScreenDepth''>
- ^ Display depth'.
- !
Item was removed:
- ----- Method: MethodPragmaTest>>testSelector (in category 'tests-method') -----
- testSelector
- | pragma |
- pragma := self pragma: 'foo' selector: #bar.
- self assert: pragma selector == #bar.!
Item was removed:
- TestCase subclass: #MethodPropertiesTest
- instanceVariableNames: 'method'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: MethodPropertiesTest>>propertyDictionaryFor: (in category 'private') -----
- propertyDictionaryFor: aMethod
- ^ aMethod properties properties!
Item was removed:
- ----- Method: MethodPropertiesTest>>setUp (in category 'running') -----
- setUp
- method := Object >> #halt.!
Item was removed:
- ----- Method: MethodPropertiesTest>>tearDown (in category 'running') -----
- tearDown
- Object recompile: #halt from: Object.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testAllMethodsHaveMethodClass (in category 'tests') -----
- testAllMethodsHaveMethodClass
- Smalltalk garbageCollect.
- self assert: (CompiledMethod allInstances
- reject: [:cm | | lastLiteral |
- lastLiteral := cm literalAt: cm numLiterals.
- lastLiteral isVariableBinding
- and: [lastLiteral value isBehavior
- or: [lastLiteral value isTrait]]]) isEmpty
- description: 'CompiledMethods must have methodClass literal'!
Item was removed:
- ----- Method: MethodPropertiesTest>>testAt (in category 'tests') -----
- testAt
- self should: [ method properties at: #zork ] raise: Error.
- self assert: (self propertyDictionaryFor: method) isEmpty.
- method properties at: #zork put: 'hello'.
- self assert: (method properties at: #zork) = 'hello'.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testAtIfAbsent (in category 'tests') -----
- testAtIfAbsent
- self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hello'.
- self assert: (self propertyDictionaryFor: method) isEmpty.
- method properties at: #zork put: 'hi'.
- self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hi'.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testAtIfAbsentPut (in category 'tests') -----
- testAtIfAbsentPut
- self assert: (method properties at: #zork ifAbsentPut: [ 'hello' ]) = 'hello'.
- self assert: (method properties at: #zork ifAbsentPut: [ 'hi' ]) = 'hello'.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testAtPut (in category 'tests') -----
- testAtPut
- self assert: (method properties at: #zork put: 'hello') = 'hello'.
- self assert: (method properties at: #zork) = 'hello'.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testAtPutRepeatedly (in category 'tests') -----
- testAtPutRepeatedly
- self assert: (method properties at: #zork put: 'hello') = 'hello'.
- self assert: (method properties at: #zork put: 'hello') = 'hello'.
- self assert: (method properties at: #zork) = 'hello'.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testIncludesKey (in category 'tests') -----
- testIncludesKey
- self deny: (method properties includesKey: #zork).
- self assert: (self propertyDictionaryFor: method) isEmpty.
- method properties at: #zork put: 123.
- self assert: (method properties includesKey: #zork).!
Item was removed:
- ----- Method: MethodPropertiesTest>>testRemoveKey (in category 'tests') -----
- testRemoveKey
- method properties at: #zork put: 'hello'.
- self should: [ method properties removeKey: #halt ] raise: Error.
- self assert: (method properties removeKey: #zork) = 'hello'.
- self assert: (self propertyDictionaryFor: method) isEmpty.
- self should: [ method properties removeKey: #zork ] raise: Error.
- self assert: (self propertyDictionaryFor: method) isEmpty.!
Item was removed:
- ----- Method: MethodPropertiesTest>>testRemoveKeyifAbsent (in category 'tests') -----
- testRemoveKeyifAbsent
- method properties at: #zork put: 'hello'.
- self assert: (method properties removeKey: #halt ifAbsent: [ 'hi' ]) = 'hi'.
- self assert: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hello'.
- self assert: (self propertyDictionaryFor: method) isEmpty.
- self should: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hi'.
- self assert: (self propertyDictionaryFor: method) isEmpty.!
Item was removed:
- TestCase subclass: #ModelTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Models'!
Item was removed:
- ----- Method: ModelTest>>testCopyDependents (in category 'tests') -----
- testCopyDependents
-
- | bar foo |
- foo := Model new.
- foo addDependent: 42.
- self assert: {42} equals: foo dependents asArray.
-
- bar := foo copy.
- self assert: bar dependents isEmpty.!
Item was removed:
- TestCase subclass: #MonitorTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
Item was removed:
- ----- Method: MonitorTest>>testCheckOwnerProcess (in category 'tests') -----
- testCheckOwnerProcess
- self should: [Monitor new checkOwnerProcess]
- raise: Error.
-
- self shouldnt: [| m | m := Monitor new. m critical: [m checkOwnerProcess]]
- raise: Error.
-
- self should: [| s m |
- m := Monitor new.
- [m critical: [s := #in. Semaphore new wait]] fork.
- Processor yield.
- self assert: #in equals: s.
- m checkOwnerProcess]
- raise: Error!
Item was removed:
- ----- Method: MonitorTest>>testCriticalIfLocked (in category 'tests') -----
- testCriticalIfLocked
- | m s |
- m := Monitor new.
- self assert: #unlocked == (m critical: [#unlocked] ifLocked: [#locked]).
- [m critical: [s := #in. Semaphore new wait]] fork.
- Processor yield.
- self assert: #in equals: s.
- self assert: #locked equals: (m critical: [#unlocked] ifLocked: [#locked])!
Item was removed:
- ----- Method: MonitorTest>>testExample1 (in category 'tests') -----
- testExample1
-
- | producer1 producer2 monitor goal work counter goalReached finished |
- goal := (1 to: 1000) asOrderedCollection.
- work := OrderedCollection new.
- counter := 0.
- goalReached := false.
- finished := Semaphore new.
- monitor := Monitor new.
-
- producer1 := [
- [monitor critical:
- [monitor waitUntil: [counter \\5 = 0].
- goalReached or: [work add: (counter := counter + 1)].
- goalReached := counter >= goal size.
- monitor signal
- ].
- goalReached
- ]
- whileFalse.
- finished signal.
- ].
-
- producer2 := [
- [monitor critical:
- [monitor waitWhile: [counter \\5 = 0].
- goalReached or: [work add: (counter := counter + 1)].
- goalReached := counter >= goal size.
- monitor signal].
- goalReached
- ] whileFalse.
- finished signal
- ].
-
- producer1 forkAt: Processor userBackgroundPriority.
- producer2 forkAt: Processor userBackgroundPriority.
-
- finished wait; wait.
- self assert: goal = work!
Item was removed:
- ----- Method: MonitorTest>>testExample2 (in category 'tests') -----
- testExample2
- "Here is a second version that does not use a semaphore to inform the
- forking process about termination of both forked processes"
-
- | producer1 producer2 monitor goal work counter goalReached activeProducers|
- goal := (1 to: 1000) asOrderedCollection.
- work := OrderedCollection new.
- counter := 0.
- goalReached := false.
- activeProducers := 0.
- monitor := Monitor new.
-
- producer1 :=
- [ monitor critical: [activeProducers := activeProducers + 1].
- [monitor critical:
- [monitor waitUntil: [counter \\5 = 0].
- goalReached or: [work add: (counter := counter + 1)].
- " Transcript show: 'P1 '; show: counter printString; show: ' ';
- show: activeProducers printString; cr."
- goalReached := counter >= goal size.
- monitor signal
- ].
- goalReached
- ]
- whileFalse.
- monitor critical: [activeProducers := activeProducers - 1.
- monitor signal: #finish].
- ] .
-
- producer2 :=
- [monitor critical: [activeProducers := activeProducers + 1].
-
- [monitor critical:
- [monitor waitWhile: [counter \\5 = 0].
- goalReached or: [work add: (counter := counter + 1)].
- goalReached := counter >= goal size.
- monitor signal].
- goalReached ] whileFalse.
- monitor critical: [
- activeProducers := activeProducers - 1.
- monitor signal: #finish].
- ].
-
- producer1 forkAt: Processor userBackgroundPriority.
- producer2 forkAt: Processor userBackgroundPriority.
-
-
- monitor critical: [
- monitor waitUntil: [activeProducers = 0 & (goalReached)]
- for: #finish.
- ].
-
- self assert: goal = work
- !
Item was removed:
- ClassTestCase subclass: #MutexTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
-
- !MutexTest commentStamp: 'eem 7/26/2018 20:42' prior: 0!
- MutexTest provides SUnit tests for Mutex locks. c.f. SemaphoreTest.!
Item was removed:
- ----- Method: MutexTest>>criticalError (in category 'private') -----
- criticalError
- Processor activeProcess terminate!
Item was removed:
- ----- Method: MutexTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testUnwindMutexBlockedInCritical)!
Item was removed:
- ----- Method: MutexTest>>testCritical (in category 'tests') -----
- testCritical
- | lock |
- lock := Mutex new.
- [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority.
- self deny: lock isOwned!
Item was removed:
- ----- Method: MutexTest>>testCriticalIfError (in category 'tests') -----
- testCriticalIfError
- | lock |
- lock := Mutex new.
- [lock critical: [self criticalError ifError: []]] forkAt: Processor userInterruptPriority.
- self deny: lock isOwned!
Item was removed:
- ----- Method: MutexTest>>testMutexAfterCriticalWait (in category 'tests') -----
- testMutexAfterCriticalWait "self run: #testMutexAfterCriticalWait"
- "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
- leaves it with the mutex correctly released."
- | lock p |
- lock := Mutex new.
- p := [lock critical: []] newProcess.
- p priority: Processor activePriority - 1.
- lock critical: "We now own it; p can't enter properly"
- [p resume.
- "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
- [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
- self deny: lock isEmpty].
- "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
- p terminate.
- self deny: lock isOwned.
- self assert: lock isEmpty!
Item was removed:
- ----- Method: MutexTest>>testMutexCriticalBlockedInEnsure (in category 'tests') -----
- testMutexCriticalBlockedInEnsure "self run: #testMutexCriticalBlockedInEnsure"
- "This tests whether a mutex that is in the ensure: in critical: but has yet to evaluate the valueNoContextSwitch
- leaves it with the mutex unlocked."
- | lock proc |
- lock := Mutex new.
- proc := [lock critical: []] newProcess.
- proc priority: Processor activePriority - 1.
- "step until in critical:"
- [proc suspendedContext selector == #critical:] whileFalse: [proc step].
- "step until in ensure: (can't do this until in critical: cuz ensure: may be in newProcess etc...)"
- [proc suspendedContext selector == #ensure:] whileFalse: [proc step].
- "Now check that the lock is owned."
- self assert: lock isOwned.
- "Now that proc is at the right point, resume the process and immediately terminate it."
- proc resume; terminate.
- self deny: lock isOwned.
- self assert: lock isEmpty!
Item was removed:
- ----- Method: MutexTest>>testMutexInCriticalEnsureArgument (in category 'tests') -----
- testMutexInCriticalEnsureArgument "self run: #testMutexInCriticalEnsureArgument"
- "This tests whether a process that is in the ensure argument block in critical: but has yet to evaluate the primitiveExitCriticalSection
- leaves it with the mutex unlocked."
-
- | terminatee mutex |
- mutex := Mutex new.
- terminatee := [mutex critical: []] newProcess.
- self assert: terminatee isSuspended.
- terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #primitiveExitCriticalSection].
- self assert: terminatee isSuspended.
- terminatee terminate.
- self deny: mutex isOwned.
- self assert: mutex isEmpty!
Item was removed:
- ----- Method: MutexTest>>testMutexInCriticalWait (in category 'tests') -----
- testMutexInCriticalWait "self run: #testMutexInCriticalWait"
- "This tests whether a mutex that has got past the primitiveEnterCriticalSection in Mutex>>critical:
- leaves it unowned."
- | lock sock proc |
- lock := Mutex new.
- sock := Semaphore new.
- proc := [lock critical: [sock wait]] fork.
- Processor yield.
- self assert: proc suspendingList == sock.
- proc terminate.
- self deny: lock isOwned.
- self assert: lock isEmpty!
Item was removed:
- ----- Method: MutexTest>>testTerminationOfLowPriorityProcessDoesNotShutOutHighPriorityProcess (in category 'tests') -----
- testTerminationOfLowPriorityProcessDoesNotShutOutHighPriorityProcess
- | m p s |
- m := Mutex new.
- p := [m critical: [Semaphore new wait]] forkAt: Processor activePriority - 10.
- (Delay forMilliseconds: 100) wait. "Allow p to enter critical section, owning m"
- [m critical: [s := #in]] forkAt: Processor activePriority + 10.
- "r := { p suspendedContext pc. p suspendedContext copyStack }."
- p terminate.
- self deny: m isOwned.
- self assert: s == #in.
- "(m isOwned not and: [s == #in]) ifFalse:
- [Debugger openContext: r last label: 'p' contents: nil]"!
Item was removed:
- ----- Method: MutexTest>>testTerminationOfOneOfTwoLowPriorityProcesses (in category 'tests') -----
- testTerminationOfOneOfTwoLowPriorityProcesses
- | mutex p1 p2 entered1 entered2 |
- mutex := Mutex new.
- entered1 := entered2 := false.
- p1 := [mutex critical:[entered1 := true]]
- forkAt: Processor activePriority - 1.
- p2 := [mutex critical:[entered2 := true]]
- forkAt: Processor activePriority - 2.
- mutex critical:[(Delay forMilliseconds: 100) wait].
- p1 terminate.
- (Delay forMilliseconds: 100) wait.
- self deny: entered1.
- self assert: entered2!
Item was removed:
- ----- Method: MutexTest>>testUnwindMutexBlockedInCritical (in category 'tests') -----
- testUnwindMutexBlockedInCritical "self run: #testMutexBlockedInCritical"
- "This tests whether a mutex that is inside the primitiveEnterCriticalSection in Mutex>>critical:
- leaves it unchanged."
- | lock sock proc wait |
- lock := Mutex new.
- sock := Semaphore new.
- proc := [lock critical: [sock wait]] fork.
- wait := [[] ensure: [lock critical: []]] fork.
- Processor yield.
- self assert: proc suspendingList == sock.
- self assert: wait suspendingList == lock.
- self deny: lock isEmpty.
- self assert: lock isOwned.
- wait terminate.
- Processor yield.
- self assert: wait isTerminated.
- self assert: proc suspendingList == sock.
- self assert: wait suspendingList == nil.
- self assert: lock isEmpty.
- self assert: lock isOwned
- !
Item was removed:
- Object subclass: #NotImplementedTestData
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
Item was removed:
- ----- Method: NotImplementedTestData>>shouldBeImplementedMsg (in category 'accessing') -----
- shouldBeImplementedMsg
- ^ self shouldBeImplemented.!
Item was removed:
- ----- Method: NotImplementedTestData>>shouldNotImplementMsg (in category 'accessing') -----
- shouldNotImplementMsg
- ^ self shouldNotImplement.!
Item was removed:
- Object subclass: #NullMutex
- instanceVariableNames: 'semaphore owner'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
-
- !NullMutex commentStamp: 'fbs 5/17/2013 20:30' prior: 0!
- A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested.
-
- This Mutex DOES NOT mutually exclude anything. It just implements the same protocol.!
Item was removed:
- ----- Method: NullMutex>>critical: (in category 'mutual exclusion') -----
- critical: aBlock
- ^ aBlock value.!
Item was removed:
- TestCase subclass: #NumberParsingTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
-
- !NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35' prior: 0!
- Tests to verify parsing of numbers from streams and strings.
-
- Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.!
Item was removed:
- ----- Method: NumberParsingTest>>testFloatFromStreamAsNumber (in category 'tests - Float') -----
- testFloatFromStreamAsNumber
- "This covers parsing in Number>>readFrom:"
-
- | rs aFloat |
- rs := '10r-12.3456' readStream.
- aFloat := Number readFrom: rs.
- self assert: -12.3456 = aFloat.
- self assert: rs atEnd.
-
- rs := '10r-12.3456e2' readStream.
- aFloat := Number readFrom: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '10r-12.3456e2e2' readStream.
- aFloat := Number readFrom: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs upToEnd = 'e2'.
-
- rs := '10r-12.3456d2' readStream.
- aFloat := Number readFrom: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '10r-12.3456q2' readStream.
- aFloat := Number readFrom: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '-12.3456q2' readStream.
- aFloat := Number readFrom: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '12.3456q2' readStream.
- aFloat := Number readFrom: rs.
- self assert: 1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '12.3456z2' readStream.
- aFloat := Number readFrom: rs.
- self assert: 12.3456 = aFloat.
- self assert: rs upToEnd = 'z2'.
- !
Item was removed:
- ----- Method: NumberParsingTest>>testFloatFromStreamWithExponent (in category 'tests - Float') -----
- testFloatFromStreamWithExponent
- "This covers parsing in Number>>readFrom:"
-
- | rs aFloat |
- rs := '1.0e-14' readStream.
- aFloat := Number readFrom: rs.
- self assert: 1.0e-14 = aFloat.
- self assert: rs atEnd.
-
- rs := '1.0e-14 1' readStream.
- aFloat := Number readFrom: rs.
- self assert: 1.0e-14 = aFloat.
- self assert: rs upToEnd = ' 1'.
-
- rs := '1.0e-14eee' readStream.
- aFloat := Number readFrom: rs.
- self assert: 1.0e-14 = aFloat.
- self assert: rs upToEnd = 'eee'.
-
- rs := '1.0e14e10' readStream.
- aFloat := Number readFrom: rs.
- self assert: 1.0e14 = aFloat.
- self assert: rs upToEnd = 'e10'.
-
- rs := '1.0e+14e' readStream. "Plus sign is parseable too"
- aFloat := Number readFrom: rs.
- self assert: 1.0e14 = aFloat.
- self assert: rs upToEnd = 'e'.
-
- rs := '1.0e' readStream.
- aFloat := Number readFrom: rs.
- self assert: 1.0 = aFloat.
- self assert: rs upToEnd = 'e'.!
Item was removed:
- ----- Method: NumberParsingTest>>testFloatFromStringAsNumber (in category 'tests - Float') -----
- testFloatFromStringAsNumber
- "This covers parsing in Number>>readFrom:"
-
- | aFloat |
- aFloat := '10r-12.3456' asNumber.
- self assert: -12.3456 = aFloat.
- aFloat := '10r-12.3456e2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '10r-12.3456d2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '10r-12.3456q2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '-12.3456q2' asNumber.
- self assert: -1234.56 = aFloat.
- aFloat := '12.3456q2' asNumber.
- self assert: 1234.56 = aFloat.
- !
Item was removed:
- ----- Method: NumberParsingTest>>testFloatFromStringWithExponent (in category 'tests - Float') -----
- testFloatFromStringWithExponent
- "This covers parsing in Number>>readFrom:"
-
- | aFloat |
- aFloat := '1.0e-14' asNumber.
- self assert: 1.0e-14 = aFloat.
- aFloat := '1.0e-14 1' asNumber.
- self assert: 1.0e-14 = aFloat.
- aFloat := '1.0e-14e' asNumber.
- self assert: 1.0e-14 = aFloat.
- aFloat := '1.0e14e' asNumber.
- self assert: 1.0e14 = aFloat.
- aFloat := '1.0e+14e' asNumber. "Plus sign is parseable too"
- self assert: 1.0e14 = aFloat.
- !
Item was removed:
- ----- Method: NumberParsingTest>>testFloatReadWithImplicitLeadingZero (in category 'tests - Float') -----
- testFloatReadWithImplicitLeadingZero
- "Test support for implicit leading zeroes when reading numbers from Strings."
- self should: [-0.22 = '-.22' asNumber].
- self should: [0.22 = '.22' asNumber].
- !
Item was removed:
- ----- Method: NumberParsingTest>>testFloatReadWithRadix (in category 'tests - Float') -----
- testFloatReadWithRadix
- "This covers parsing in Number>>readFrom:
- Note: In most Smalltalk dialects, the radix notation is not used for numbers
- with exponents. In Squeak, a string with radix and exponent can be parsed,
- and the exponent is always treated as base 10 (not the base indicated in the
- radix prefix). I am not sure if this is a feature, a bug, or both, but the
- Squeak behavior is documented in this test. -dtl"
-
- | aNumber rs |
- aNumber := '2r1.0101e9' asNumber.
- self assert: 672.0 = aNumber.
- self assert: (Number readFrom: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)).
- rs := ReadStream on: '2r1.0101e9e9'.
- self assert: (Number readFrom: rs) = 672.0.
- self assert: rs upToEnd = 'e9'
- !
Item was removed:
- ----- Method: NumberParsingTest>>testFloatmin (in category 'tests - Float') -----
- testFloatmin
- "Note that these are originally tests cases for former bugs of libc dtoa from netlib.
- ref http://www.exploringbinary.com/gays-strtod-returns-zero-for-inputs-just-abo…
- ref http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/testsuite/gcc.dg/float-exact-1.c?v…
- They are also non regression for a bug of NumberParser related to incorrect position of last non zero digit.
- ref https://pharo.fogbugz.com/f/cases/12642/bug-in-NumberParser-when-reading-a-…"
- | halfMin moreThanHalfmin |
- halfMin := SqNumberParser parse: (Float fmin asTrueFraction / 2 printShowingDecimalPlaces: 1 - Float fmin exponent).
- self assert: halfMin equals: 0.0 description: 'nearest even of 0.5*Float fmin is zero'.
- moreThanHalfmin := SqNumberParser parse: (Float fmin asTrueFraction / 2 + (10 raisedTo: Float fmin exponent - 4) printShowingDecimalPlaces: 4 - Float fmin exponent).
- self assert: moreThanHalfmin equals: Float fmin description: 'nearest Float of a Fraction > 0.5*Float fmin is Float fmin'.!
Item was removed:
- ----- Method: NumberParsingTest>>testIntegerFromString (in category 'tests - Integer') -----
- testIntegerFromString
- "This covers parsing in Number>>readFrom:"
-
- #(
- ('123' 123)
- ('-123' -123)
- ('123.' 123.0)
- ('-123.' -123.0)
- ('123This is not to be read' 123)
- ('123s is a ScaledDecimal' 123s0)
- ('123sin is not a ScaledDecimal, s could be part of message sin' 123)
- ('123e could be confused with a Float' 123)) do: [ :each |
- [ :string :numericValue |
- | result |
- result := string asNumber.
- self assert: result = numericValue.
- self assert: result class = numericValue class] valueWithArguments: each ]
- !
Item was removed:
- ----- Method: NumberParsingTest>>testIntegerReadFrom (in category 'tests - Integer') -----
- testIntegerReadFrom
- "Ensure remaining characters in a stream are not lost when parsing an integer."
-
- #(
- ('13r96 has a radix specification' 123 ' has a radix specification')
- ('123r is not a radix specification here' 123 'r is not a radix specification here')
- ('-123e has no exponent' -123 'e has no exponent')
- ('-123.e has no exponent' -123.0 'e has no exponent')
- ('-123e2 has an exponent' -12300 ' has an exponent')
- ('123This is not to be read' 123 'This is not to be read')
- ('123s is a ScaledDecimal' 123s0 ' is a ScaledDecimal')
- ('-123.s is a ScaledDecimal' -123s0 ' is a ScaledDecimal')
- ('123sin is not a ScaledDecimal, s could be part of message sin' 123 'sin is not a ScaledDecimal, s could be part of message sin')
- ('123.sin is not a ScaledDecimal, s could be part of message sin' 123.0 'sin is not a ScaledDecimal, s could be part of message sin')
- ) do: [ :each |
- [ :string :numericValue :expectedRest |
- | readStream result rest |
- readStream := string readStream.
- result := Number readFrom: readStream.
- rest := readStream upToEnd.
- self assert: result = numericValue.
- self assert: result class = numericValue class.
- self assert: rest = expectedRest] valueWithArguments: each ]
- !
Item was removed:
- ----- Method: NumberParsingTest>>testIntegerReadWithRadix (in category 'tests - Integer') -----
- testIntegerReadWithRadix
- "This covers parsing in Number>>readFrom:
- Note: In most Smalltalk dialects, the radix notation is not used for numbers
- with exponents. In Squeak, a string with radix and exponent can be parsed,
- and the exponent is always treated as base 10 (not the base indicated in the
- radix prefix). I am not sure if this is a feature, a bug, or both, but the
- Squeak behavior is documented in this test. -dtl"
-
- | aNumber rs |
- aNumber := '2r1e26' asNumber.
- self assert: 67108864 = aNumber.
- self assert: (Number readFrom: '2r1e26') = (2 raisedTo: 26).
- rs := '2r1e26eee' readStream.
- self assert: (Number readFrom: rs) = 67108864.
- self assert: rs upToEnd = 'eee'
- !
Item was removed:
- ----- Method: NumberParsingTest>>testNegativeZero (in category 'tests - Integer') -----
- testNegativeZero
- "This test ensure that -0.0 will produce a negativeZero"
-
- | negativeZero |
- negativeZero := Number readFrom: '-0.0' readStream.
-
- "If it is a negative zero, it must behave like a negative zero... IEEE 754 tells how it should behave"
- self deny: (negativeZero at: 1) = 0 description: 'In IEEE 754, a negative zero has its sign bit set to 1'..
- self assert: negativeZero = 0 description: 'In IEEE 754, a negative zero cannot be distinguished from zero'.!
Item was removed:
- ----- Method: NumberParsingTest>>testScaledDecimalWithTrailingZeroes (in category 'tests - ScaledDecimal') -----
- testScaledDecimalWithTrailingZeroes
- "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169"
-
- self assert: (Number readFrom: '0.50s2') = (1/2).
- self assert: (Number readFrom: '0.500s3') = (1/2).
- self assert: (Number readFrom: '0.050s3') = (1/20).!
Item was removed:
- ClassTestCase subclass: #NumberTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
Item was removed:
- ----- Method: NumberTest>>testExactLog2 (in category 'tests') -----
- testExactLog2
- -10 to: 10 do: [:i | self assert: i equals: (2 raisedToInteger: i) log2].
- Float emin - Float precision + 1 to: Float emax do: [:i | self assert: i equals: (1.0 timesTwoPower: i) log2].!
Item was removed:
- ----- Method: NumberTest>>testFractionPart (in category 'tests') -----
- testFractionPart
-
- self
- assert: 2 fractionPart = 0;
- assert: (1/2) fractionPart = (1/2);
- assert: (4/3) fractionPart = (1/3);
- assert: 2.0 fractionPart = 0.0;
- assert: 0.5 fractionPart = 0.5;
- assert: 2.5 fractionPart = 0.5
- !
Item was removed:
- ----- Method: NumberTest>>testIntegerPart (in category 'tests') -----
- testIntegerPart
-
- self
- assert: 2 integerPart = 2;
- assert: (1/2) integerPart = 0;
- assert: (4/3) integerPart = 1;
- assert: 2.0 integerPart = 2.0;
- assert: 0.5 integerPart = 0.0;
- assert: 2.5 integerPart = 2.0
- !
Item was removed:
- ----- Method: NumberTest>>testLog2doesNotOverflow (in category 'tests') -----
- testLog2doesNotOverflow
- "Note: though this is not a strict identity, we can use strict Float equality here"
- self assert: 3000.0 equals: ((1 bitShift: 3000) - 1) log2.
- self assert: 1500.0 equals: (((1 bitShift: 3000) - 1) / (1 bitShift: 1500)) log2.!
Item was removed:
- ----- Method: NumberTest>>testLog2doesNotUnderflow (in category 'tests') -----
- testLog2doesNotUnderflow
- "Note: though this is not a strict identity, we can use strict Float equality here"
- self assert: -2000.0 equals: ((1 bitShift: 2000) - 1) reciprocal log2!
Item was removed:
- ----- Method: NumberTest>>testOne (in category 'tests') -----
- testOne
-
- self
- assert: Integer one = 1;
- assert: Float one = 1.0;
- assert: Fraction one = 1!
Item was removed:
- ----- Method: NumberTest>>testPrintShowingDecimalPlaces (in category 'tests') -----
- testPrintShowingDecimalPlaces
- self assert: (111.2 printShowingDecimalPlaces: 2) = '111.20'.
- self assert: (111.2 printShowingDecimalPlaces: 0) = '111'.
- self assert: (111 printShowingDecimalPlaces: 0) = '111'.
- self assert: (111111111111111 printShowingDecimalPlaces: 2) = '111111111111111.00'.
- self assert: (10 printShowingDecimalPlaces: 20) ='10.00000000000000000000'.
- self assert: (0.98 printShowingDecimalPlaces: 2) = '0.98'.
- self assert: (-0.98 printShowingDecimalPlaces: 2) = '-0.98'.
- self assert: (2.567 printShowingDecimalPlaces: 2) = '2.57'.
- self assert: (-2.567 printShowingDecimalPlaces: 2) = '-2.57'.
- self assert: (0.01 printShowingDecimalPlaces: 2) = '0.01'.
- self assert: (-0.001 printShowingDecimalPlaces: 2) = '-0.00'.!
Item was removed:
- ----- Method: NumberTest>>testPrintShowingDecimalPlaces2 (in category 'tests') -----
- testPrintShowingDecimalPlaces2
- "This tests problems related to Float>>rounded and Float>>roundTo::
- - Float>>#rounded is inexact
- - Float>>#roundTo: might overflow"
-
- "5000000000000001.0 asTrueFraction = 5000000000000001.
- 5000000000000001 highBit = 53.
- This number is represented exactly asFloat, it should print exactly"
- self assert: (5000000000000001.0 printShowingDecimalPlaces: 0) = '5000000000000001'.
-
- "50000000000001.25 asTrueFraction = (200000000000005/4).
- 200000000000005 highBit = 48, 4 isPowerOfTwo,
- So this number is also represented exactly as Float, it should print exactly.
- Beware: (50000000000001.25 / 0.01) rounded exhibit the same problem as above."
- self assert: (50000000000001.25 printShowingDecimalPlaces: 2) = '50000000000001.25'.
-
- "This number is close to maximum float value"
- self assert: '1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000' equals: (1.0e306 printShowingDecimalPlaces: 3).!
Item was removed:
- ----- Method: NumberTest>>testPrintShowingDecimalPlaces3 (in category 'tests') -----
- testPrintShowingDecimalPlaces3
- "This problem were reported at http://bugs.squeak.org/view.php?id=7028
- unfortunate inversion of left / right padding"
-
- self assert: (1.009 printShowingDecimalPlaces: 3) = '1.009'.
- self assert: (35.900 printShowingDecimalPlaces: 3) = '35.900'.
- self assert: (-0.097 printShowingDecimalPlaces: 3) = '-0.097'.!
Item was removed:
- ----- Method: NumberTest>>testRaisedTo (in category 'tests') -----
- testRaisedTo
- "this is a test related to http://bugs.squeak.org/view.php?id=6781"
-
- self should: [0 raisedTo: -1] raise: ZeroDivide.
- self should: [0 raisedTo: -1.0] raise: ZeroDivide.!
Item was removed:
- ----- Method: NumberTest>>testRaisedToInteger (in category 'tests') -----
- testRaisedToInteger
-
- self
- assert: (2 raisedToInteger: 0) = 1;
- assert: (2 raisedToInteger: 1) = 2;
- assert: (2 raisedToInteger: 4) = 16;
- assert: (0 raisedToInteger: 0) = 1;
- assert: (0 raisedToInteger: 2) = 0;
- assert: (2 raisedToInteger: -1) = (1/2);
- assert: (2 raisedToInteger: -4) = (1/16).
-
- self
- assert: (-3 raisedTo: 0) = 1;
- assert: (-3 raisedTo: 1) = -3;
- assert: (-3 raisedTo: 2) = 9;
- assert: (-3 raisedTo: 3) = -27;
- assert: (-3 raisedTo: -2) = (1/9);
- assert: (-3 raisedTo: -3) = (-1/27).
-
- self should: [ 0 raisedTo: -1 ] raise: ZeroDivide!
Item was removed:
- ----- Method: NumberTest>>testRaisedToIntegerWithFloats (in category 'tests') -----
- testRaisedToIntegerWithFloats
-
- self
- assert: (2.0 raisedToInteger: 0) = 1.0;
- assert: (2.0 raisedToInteger: 1) = 2.0;
- assert: (2.0 raisedToInteger: 4) = 16.0;
- assert: (0.0 raisedToInteger: 0) = 1.0;
- assert: (0.0 raisedToInteger: 2) = 0.0;
- assert: (2.0 raisedToInteger: -1) = 0.5;
- assert: (2.0 raisedToInteger: -4) = 0.0625.
-
- self
- assert: (-3.0 raisedTo: 0) = 1.0;
- assert: (-3.0 raisedTo: 1) = -3.0;
- assert: (-3.0 raisedTo: 2) = 9.0;
- assert: (-3.0 raisedTo: 3) = -27.0;
- assert: (-2.0 raisedTo: -2) = 0.25;
- assert: (-2.0 raisedTo: -3) = -0.125.
-
- self should: [ 0.0 raisedTo: -1 ] raise: ZeroDivide!
Item was removed:
- ----- Method: NumberTest>>testReadFrom (in category 'tests') -----
- testReadFrom
-
- self assert: 1.0e-14 = (Number readFrom: '1.0e-14').
- self assert: 2r1e26 = (Number readFrom: '2r1e26').!
Item was removed:
- ----- Method: NumberTest>>testReciprocal (in category 'tests') -----
- testReciprocal
-
- self
- assert: 1 reciprocal = 1;
- assert: 2 reciprocal = (1/2);
- assert: -1 reciprocal = -1;
- assert: -3 reciprocal = (-1/3).
-
- self should: [ 0 reciprocal ] raise: ZeroDivide!
Item was removed:
- ----- Method: NumberTest>>testRoundTo (in category 'tests - trunction and round off') -----
- testRoundTo
-
- {
- 1 . 1.0 . 1.0 .
- 1.0 . 1 . 1 .
- 1/3 . 1/4 . 1/4 .
- 0.9 . 1/3 . 1 .
- } groupsDo: [:receiver :argument :expected |
- self assert: expected equals: (receiver roundTo: argument)]!
Item was removed:
- ----- Method: NumberTest>>testZeroDivideHandler (in category 'tests') -----
- testZeroDivideHandler
- "Test for user-defined ZeroDivide behavior"
-
- [
- self assert: 1 / 0 = Float infinity.
- self assert: -1 / 0 = Float negativeInfinity.
- self assert: 1.0 / 0 = Float infinity.
- self assert: -1.0 / 0 = Float negativeInfinity.
- self assert: 1 / 0.0 = Float infinity.
- self assert: -1 / 0.0 = Float negativeInfinity.
- self assert: 1.0 / 0.0 = Float infinity.
- self assert: -1.0 / 0.0 = Float negativeInfinity.
- ] on: ZeroDivide
- do: [:ex | ex resume: ex dividend sign * Float infinity ]
- !
Item was removed:
- ClassTestCase subclass: #ObjectTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
Item was removed:
- ----- Method: ObjectTest>>a (in category 'private') -----
- a
- self b.!
Item was removed:
- ----- Method: ObjectTest>>a1 (in category 'private') -----
- a1
- self b1.!
Item was removed:
- ----- Method: ObjectTest>>b (in category 'private') -----
- b
- self haltIf: #testHaltIf.!
Item was removed:
- ----- Method: ObjectTest>>b1 (in category 'private') -----
- b1
- self haltIf: #testasdasdfHaltIf.!
Item was removed:
- ----- Method: ObjectTest>>testAssert (in category 'tests - debugging') -----
- testAssert
- Object assert: [true].
- Object assert: true.
- self should: [Object assert: [false]] raise: AssertionFailure.
- self should: [Object assert: false] raise: AssertionFailure.!
Item was removed:
- ----- Method: ObjectTest>>testBecome (in category 'tests') -----
- testBecome
- "self debug: #testBecome"
- "this test should that all the variables pointing to an object are pointing now to another one, and all
- object pointing to the other are pointing to the object"
-
- | pt1 pt2 pt3 |
- pt1 := 0@0.
- pt2 := pt1.
- pt3 := 100@100.
-
- pt1 become: pt3.
- self assert: pt2 = (100@100).
- self assert: pt3 = (0@0).
- self assert: pt1 = (100@100).!
Item was removed:
- ----- Method: ObjectTest>>testBecomeForward (in category 'tests') -----
- testBecomeForward
- "self debug: #testBecomeForward"
- "this test should that all the variables pointing to an object are pointing now to another one.
- Not that this inverse is not true. This kind of become is called oneWayBecome in VW"
-
- | pt1 pt2 pt3 |
- pt1 := 0@0.
- pt2 := pt1.
- pt3 := 100@100.
- pt1 becomeForward: pt3.
- self assert: pt2 = (100@100).
- self assert: pt3 == pt2.
- self assert: pt1 = (100@100)!
Item was removed:
- ----- Method: ObjectTest>>testCaseOf (in category 'tests') -----
- testCaseOf
-
- | a b c dict |
- a := Object new.
- b := Object new.
- c := Object new.
- dict := {
- [a] -> [b].
- [b] -> [c].
- [c] -> [a] }.
- self assert: b equals: (a caseOf: dict).
- self assert: c equals: (b caseOf: dict).
- self assert: a equals: (c caseOf: dict).
- self should: [nil caseOf: dict] raise: Error.!
Item was removed:
- ----- Method: ObjectTest>>testCaseOfInlined (in category 'tests') -----
- testCaseOfInlined
-
- | a b c |
- a := Object new.
- b := Object new.
- c := Object new.
- self assert: b equals: (a caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }).
- self assert: c equals: (b caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }).
- self assert: a equals: (c caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }).
- self should: [nil caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }] raise: Error.!
Item was removed:
- ----- Method: ObjectTest>>testCaseOfOtherwise (in category 'tests') -----
- testCaseOfOtherwise
-
- | a b c dict |
- a := Object new.
- b := Object new.
- c := Object new.
- dict := {
- [a] -> [b].
- [b] -> [c].
- [c] -> [a] }.
-
- self assert: b equals: (a caseOf: dict otherwise: [self fail]).
- self assert: c equals: (b caseOf: dict otherwise: [self fail]).
- self assert: a equals: (c caseOf: dict otherwise: [self fail]).
- self assert: 42 equals: (nil caseOf: dict otherwise: [42]).
- self assert: 42 equals: (6 caseOf: dict otherwise: [:x | x * 7]).!
Item was removed:
- ----- Method: ObjectTest>>testCaseOfOtherwiseInlined (in category 'tests') -----
- testCaseOfOtherwiseInlined
-
- | a b c |
- a := Object new.
- b := Object new.
- c := Object new.
- self assert: b equals: (a caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [self fail]).
- self assert: c equals: (b caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [self fail]).
- self assert: a equals: (c caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [self fail]).
- self assert: 42 equals: (nil caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [42]).
- self assert: 42 equals: (6 caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [:x | x * 7]).!
Item was removed:
- ----- Method: ObjectTest>>testCopyDependents (in category 'tests') -----
- testCopyDependents
-
- | bar foo |
- foo := Object new.
- foo addDependent: 42.
- self assert: {42} equals: foo dependents asArray.
-
- bar := foo copy.
- self assert: bar dependents isEmpty.!
Item was removed:
- ----- Method: ObjectTest>>testEvaluateWheneverChangeIn (in category 'tests - debugging') -----
- testEvaluateWheneverChangeIn
-
- | counter instance target |
- instance := Object new.
- counter := 0.
- target := #notExecuted.
- instance
- evaluate: [target := #executed]
- wheneverChangeIn: [counter].
- counter := counter + 1.
-
- instance name.
-
- self assert: #executed equals: target.!
Item was removed:
- ----- Method: ObjectTest>>testEvaluateWheneverChangeInTransparent (in category 'tests - debugging') -----
- testEvaluateWheneverChangeInTransparent
-
- | instance |
- instance := Object new.
- instance
- evaluate: []
- wheneverChangeIn: [].
- self assert: instance yourself == instance.!
Item was removed:
- ----- Method: ObjectTest>>testHaltIf (in category 'tests - testing') -----
- testHaltIf
-
- self should: [self haltIf: true] raise: Halt.
- self haltIf: false.
-
- self should: [self haltIf: [true]] raise: Halt.
- self haltIf: [false].
-
- self should: [self haltIf: #testHaltIf.] raise: Halt.
- self haltIf: #teadfasdfltIf.
-
- self should: [self a] raise: Halt.
- self a1.
-
- self should: [self haltIf: [:o | o class = self class]] raise: Halt.
- self haltIf: [:o | o class ~= self class].
- !
Item was removed:
- ----- Method: ObjectTest>>testIfNotNilDoDeprecation (in category 'tests') -----
- testIfNotNilDoDeprecation
-
- #(ifNotNilDo: #ifNil:ifNotNilDo: #ifNotNilDo:ifNil:) do: [ :selector |
- | senders |
- senders := self systemNavigation allCallsOn: selector.
- self
- assert: senders size = 1
- description: (String streamContents: [ :stream |
- | thisSelector |
- stream
- nextPutAll: 'Unexpected senders of ';
- print: selector;
- nextPutAll: ': '.
- thisSelector := thisContext method selector.
- (senders reject: [ :each |
- (each actualClass == self class
- and: [ each selector == thisSelector ]) ])
- do: [ :each |
- stream
- nextPutAll: each actualClass name;
- nextPutAll: ' >> ';
- print: each selector ]
- separatedBy: [ stream nextPutAll: ', ' ] ]) ]!
Item was removed:
- ----- Method: ObjectTest>>testNotNil (in category 'tests - testing') -----
- testNotNil
-
- self assert: Object new notNil!
Item was removed:
- ----- Method: ObjectTest>>testPerform (in category 'tests') -----
- testPerform
-
- | object |
- object := Object new.
- self assert: object equals: (object perform: #yourself).
- self deny: 1 equals: (object perform: #yourself).
- self assert: 4 equals: (2 perform: #squared).
- self deny: 3 equals: (2 perform: #squared)!
Item was removed:
- ----- Method: ObjectTest>>testPerformWith (in category 'tests') -----
- testPerformWith
-
- self assert: 7 equals: (3 perform: #+ with: 4)!
Item was removed:
- ----- Method: ObjectTest>>testPerformWithWith (in category 'tests') -----
- testPerformWithWith
-
- | receiver |
- receiver := [ :a :b | { a. b } ].
- self assert: #(1 2) equals: (receiver perform: #value:value: with: 1 with: 2)!
Item was removed:
- ----- Method: ObjectTest>>testPerformWithWithWith (in category 'tests') -----
- testPerformWithWithWith
-
- | receiver |
- receiver := [ :a :b :c | { a. b. c } ].
- self assert: #(1 2 3) equals: (receiver perform: #value:value:value: with: 1 with: 2 with: 3)!
Item was removed:
- ----- Method: ObjectTest>>testPerformWithWithWithWith (in category 'tests') -----
- testPerformWithWithWithWith
-
- | receiver |
- receiver := [ :a :b :c :d | { a. b. c. d } ].
- self assert: #(1 2 3 4) equals: (receiver perform: #value:value:value:value: with: 1 with: 2 with: 3 with: 4)!
Item was removed:
- ----- Method: ObjectTest>>testPerformWithWithWithWithWith (in category 'tests') -----
- testPerformWithWithWithWithWith
-
- | receiver |
- receiver := [ :a :b :c :d :e | { a. b. c. d. e } ].
- self assert: #(1 2 3 4 5) equals: (receiver perform: #value:value:value:value:value: with: 1 with: 2 with: 3 with: 4 with: 5)!
Item was removed:
- ----- Method: ObjectTest>>testPinning (in category 'tests') -----
- testPinning
- "Test pinning state changes for two objects. Iterate over all possible state transitions."
-
- | objects |
- objects := { Object new. Object new }.
- #((false false) (false true) (true false) (true true))
- combinations: 2
- atATimeDo: [ :transition |
- | fromState toState |
- fromState := transition first.
- toState := transition second.
- fromState with: objects do: [ :pinned :object |
- pinned
- ifTrue: [ object pin ]
- ifFalse: [ object unpin ].
- self assert: pinned equals: object isPinned ].
- objects withIndexDo: [ :object :index |
- | from to |
- from := fromState at: index.
- to := toState at: index.
- self assert: from equals: (to
- ifTrue: [ object pin ]
- ifFalse: [ object unpin ]).
- self assert: to equals: object isPinned ] ]!
Item was removed:
- ----- Method: ObjectTest>>testReadCarefullyFrom (in category 'tests') -----
- testReadCarefullyFrom
-
- self should: [Object readCarefullyFrom: nil] raise: Error.
- self should: [Object readCarefullyFrom: Object new] raise: Error.
- self assert: [(Object readCarefullyFrom: 'Object new') isKindOf: Object].
- self
- should: [self
- should: [Object newSubclass readCarefullyFrom: 'self assert: Object isNil']
- raise: AssertionFailure. "environment must be installed"]
- raise: Error. "because we return nil"
- self should: [(UndefinedObject readCarefullyFrom: 'Object new')] raise: Error.
- self should: [Object readCarefullyFrom: 'Object new:'] raise: Error.!
Item was removed:
- ----- Method: ObjectTest>>testReadFrom (in category 'tests') -----
- testReadFrom
-
- self should: [Object readFrom: nil] raise: Error.
- self should: [Object readFrom: Object new] raise: Error.
- self assert: [(Object readFrom: 'Object new') isKindOf: Object].
- self
- should: [self
- should: [Object newSubclass readFrom: 'self assert: Object isNil']
- raise: AssertionFailure. "environment must be installed"]
- raise: Error. "because we return nil"
- self should: [(UndefinedObject readFrom: 'Object new')] raise: Error.
- self should: [Object readFrom: 'Object new:'] raise: SyntaxErrorNotification.!
Item was removed:
- ----- Method: ObjectTest>>testShouldBeImplemented (in category 'tests') -----
- testShouldBeImplemented
- | testClass |
- testClass := NotImplementedTestData.
- self should: [testClass new shouldBeImplementedMsg] raise: NotImplemented.
- [testClass new shouldBeImplementedMsg] ifError: [:errDesc |
- self assert: (errDesc includesSubstring: testClass name) description: 'Error should include class name'.
- self assert: (errDesc includesSubstring: #shouldBeImplementedMsg asString) description: 'Error should include selector name'].!
Item was removed:
- ----- Method: ObjectTest>>testShouldNotImplement (in category 'tests') -----
- testShouldNotImplement
- | testClass |
- testClass := NotImplementedTestData.
- self should: [testClass new shouldNotImplementMsg] raise: NotImplemented.
- [testClass new shouldNotImplementMsg] ifError: [:errDesc |
- self assert: (errDesc includesSubstring: testClass name) description: 'Error should include class name'.
- self assert: (errDesc includesSubstring: #shouldNotImplementMsg asString) description: 'Error should include selector name'].!
Item was removed:
- ----- Method: Process>>suspendPrimitivelyOrFail (in category '*KernelTests-Processes') -----
- suspendPrimitivelyOrFail
- "Test support. Execute primitive 578, or fail."
-
- <primitive: 578>
- ^self primitiveFailed!
Item was removed:
- TestCase subclass: #ProcessSpecificTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
-
- !ProcessSpecificTest commentStamp: 'mvl 3/13/2007 13:52' prior: 0!
- A ProcessSpecificTest is a test case for process local and dynamic variables.
- !
Item was removed:
- ----- Method: ProcessSpecificTest>>checkDynamic: (in category 'private') -----
- checkDynamic: value
-
- self assert: value equals: TestDynamicVariable value.!
Item was removed:
- ----- Method: ProcessSpecificTest>>checkLocal: (in category 'private') -----
- checkLocal: value
-
- self assert: value equals: TestLocalVariable value.!
Item was removed:
- ----- Method: ProcessSpecificTest>>tearDown (in category 'running') -----
- tearDown
- "Make sure we don't pollute the running process' environment with the test variables"
-
- { TestLocalVariable. TestDynamicVariable } do: [ :each |
- Processor activeProcess environmentRemoveKey: each ifAbsent: [] ].
-
- TestDynamicVariable default: nil.!
Item was removed:
- ----- Method: ProcessSpecificTest>>testAssignmentToLocalVariableReturnsTheValue (in category 'tests') -----
- testAssignmentToLocalVariableReturnsTheValue
-
- self assert: 1 equals: (TestLocalVariable value: 1)!
Item was removed:
- ----- Method: ProcessSpecificTest>>testDynamicVariable (in category 'tests') -----
- testDynamicVariable
-
- | s1 s2 p1stopped p2stopped |
- s1 := Semaphore new.
- s2 := Semaphore new.
- p1stopped := p2stopped := false.
- [
- TestDynamicVariable value: 1 during:[
- self checkDynamic: 1.
- (Delay forMilliseconds: 30) wait.
- self checkDynamic: 1.
- TestDynamicVariable value: 3 during:[
- (Delay forMilliseconds: 30) wait.
- self checkDynamic: 3
- ].
- self checkDynamic: 1.
- ].
- self checkDynamic: nil.
- p1stopped := true.
- s1 signal.
- ] fork.
-
- [
- TestDynamicVariable value: 2 during:[
- self checkDynamic: 2.
- (Delay forMilliseconds: 30) wait.
- self checkDynamic: 2.
- ].
- self checkDynamic: nil.
- p2stopped := true.
- s2 signal.
- ] fork.
-
- "Set a maximum wait timeout so that the test case will complete
- even if the processes fail to signal us."
- s1 waitTimeoutSeconds: 2.
- s2 waitTimeoutSeconds: 2.
- self assert: p1stopped.
- self assert: p2stopped.!
Item was removed:
- ----- Method: ProcessSpecificTest>>testDynamicVariableDefault (in category 'tests') -----
- testDynamicVariableDefault
-
- "Just double-check our fixture."
- TestDynamicVariable default: #default.
- self assert: #default equals: TestDynamicVariable default.
-
- "Now check for default lookup out of any dynamic scope."
- self checkDynamic: #default..
-
- "Ignore default value by setting dynamic scope."
- TestDynamicVariable value: #dynamic during: [
- self checkDynamic: #dynamic].
-
- "Out of that scope, we should fall back to the default again."
- self checkDynamic: #default.
-
- "...even if that default value changes."
- TestDynamicVariable default: #anotherDefault.
- self checkDynamic: #anotherDefault.
- !
Item was removed:
- ----- Method: ProcessSpecificTest>>testLocalVariable (in category 'tests') -----
- testLocalVariable
-
- | s1 s2 p1stopped p2stopped |
- s1 := Semaphore new.
- s2 := Semaphore new.
- p1stopped := p2stopped := false.
- [
- self checkLocal: 0.
- TestLocalVariable value: 1.
- self checkLocal: 1.
- (Delay forMilliseconds: 30) wait.
- self checkLocal: 1.
- TestLocalVariable value: 2.
- self checkLocal: 2.
- p1stopped := true.
- s1 signal.
- ] fork.
-
- [
- (Delay forMilliseconds: 30) wait.
- self checkLocal: 0.
- TestLocalVariable value: 3.
- self checkLocal: 3.
- (Delay forMilliseconds: 30) wait.
- self checkLocal: 3.
- TestLocalVariable value: 4.
- self checkLocal: 4.
- p2stopped := true.
- s2 signal.
- ] fork.
-
- "Set a maximum wait timeout so that the test case will complete
- even if the processes fail to signal us."
- s1 waitTimeoutMSecs: 5000.
- s2 waitTimeoutMSecs: 5000.
- self assert: p1stopped.
- self assert: p2stopped.
- !
Item was removed:
- AbstractProcessTest subclass: #ProcessTerminateBug
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
Item was removed:
- ----- Method: ProcessTerminateBug>>testSchedulerTermination (in category 'tests') -----
- testSchedulerTermination
- | process sema gotHere sema2 |
- gotHere := false.
- sema := Semaphore new.
- sema2 := Semaphore new.
- process := [
- sema signal.
- sema2 wait.
- "will be suspended here"
- gotHere := true. "e.g., we must *never* get here"
- ] forkAt: Processor activeProcess priority.
- sema wait. "until process gets scheduled"
- process terminate.
- sema2 signal.
- Processor yield. "will give process a chance to continue and
- horribly screw up"
- self assert: gotHere not.
- !
Item was removed:
- ----- Method: ProcessTerminateBug>>testTerminationDuringUnwind (in category 'tests') -----
- testTerminationDuringUnwind
- "An illustration of the issue of process termination during unwind.
- This uses a well-behaved unwind block that we should allow to complete
- if at all possible."
- | unwindStarted unwindFinished p |
- unwindStarted := unwindFinished := false.
- p := [[] ensure:[
- unwindStarted := true.
- Processor yield.
- unwindFinished := true.
- ]] fork.
- self deny: unwindStarted.
- Processor yield.
- self assert: unwindStarted.
- self deny: unwindFinished.
- p terminate.
- self assert: unwindFinished.!
Item was removed:
- ----- Method: ProcessTerminateBug>>testUnwindFromActiveProcess (in category 'tests') -----
- testUnwindFromActiveProcess
- | sema process |
- sema := Semaphore forMutualExclusion.
- self assert:(sema isSignaled).
- process := [
- sema critical:[
- self deny: sema isSignaled.
- Processor activeProcess terminate.
- ]
- ] forkAt: Processor userInterruptPriority.
- self assert: sema isSignaled.!
Item was removed:
- ----- Method: ProcessTerminateBug>>testUnwindFromForeignProcess (in category 'tests') -----
- testUnwindFromForeignProcess
- | sema process |
- sema := Semaphore forMutualExclusion.
- self assert: sema isSignaled.
- process := [
- sema critical:[
- self deny: sema isSignaled.
- sema wait. "deadlock"
- ]
- ] forkAt: Processor userInterruptPriority.
- self deny: sema isSignaled.
- "This is for illustration only - the BlockCannotReturn cannot
- be handled here (it's truncated already)"
- self shouldnt: [process terminate] raise: BlockCannotReturn.
- self assert: sema isSignaled.
- !
Item was removed:
- AbstractProcessTest subclass: #ProcessTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
-
- !ProcessTest commentStamp: 'ul 8/16/2011 11:35' prior: 0!
- I hold test cases for generic Process-related behaviour.!
Item was removed:
- ----- Method: ProcessTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testTerminateTerminatingProcess testResumeTerminatingProcess)!
Item was removed:
- ----- Method: ProcessTest>>terminated (in category 'support') -----
- terminated
- "supports testProcessStateTests2"
-
- ^self suspend.
- !
Item was removed:
- ----- Method: ProcessTest>>testAtomicSuspend (in category 'tests') -----
- testAtomicSuspend
- "Test atomic suspend of foreign processes.
- Note: this test will fail when run with older VMs without primitive suspend 578."
-
- | list p |
- p := [semaphore wait] fork.
- Processor yield.
- list := p suspendPrimitivelyOrFail.
- self assert: list == nil.
- !
Item was removed:
- ----- Method: ProcessTest>>testComplete (in category 'tests') -----
- testComplete
-
- 1 to: 5 do: [:i | | process z expected result |
- process := [z := 1
- in: [:x | 2
- in: [:y |
- Processor activeProcess suspend.
- x + y]]] fork.
- Processor yield.
-
- expected := process suspendedContext stack at: i + 1.
- result := process
- complete: (process suspendedContext stack at: i)
- ifError: [:error | self fail].
-
- self assert: expected equals: result.
- self assert: expected equals: process suspendedContext.
-
- process runUntil: [:ctx | ctx isDead].
-
- self should: process isTerminated.
- self assert: 3 equals: z].!
Item was removed:
- ----- Method: ProcessTest>>testCompleteError (in category 'tests') -----
- testCompleteError
-
- 1 to: 5 do: [:i | | process z result error |
- process := [z := 1
- in: [:x | 0
- in: [:y |
- Processor activeProcess suspend.
- x / y]]] fork.
- Processor yield.
-
- result := process
- complete: (process suspendedContext stack at: i)
- ifError: [:ex | error := ex].
-
- self assert: (error isKindOf: ZeroDivide).
- self assert: process suspendedContext equals: result.
-
- process runUntil: [:ctx | ctx isDead].
-
- self should: process isTerminated.
- self assert: error equals: z].!
Item was removed:
- ----- Method: ProcessTest>>testEnvironmentAt (in category 'tests') -----
- testEnvironmentAt
- Processor activeProcess environmentAt: #processTests put: 42.
- self assert: (Processor activeProcess environmentAt: #processTests) = 42.
- self should: [Processor activeProcess environmentAt: #foobar] raise: Error!
Item was removed:
- ----- Method: ProcessTest>>testEnvironmentAtPut (in category 'tests') -----
- testEnvironmentAtPut
- self assert: (Processor activeProcess environmentAt: #processTests put: 42) = 42.!
Item was removed:
- ----- Method: ProcessTest>>testEnvironmentRemoveKey (in category 'tests') -----
- testEnvironmentRemoveKey
- Processor activeProcess environmentAt: #processTests put: 42.
- Processor activeProcess environmentRemoveKey: #processTests.
- self assert: (Processor activeProcess environmentAt: #processTests ifAbsent: []) isNil.
- self should: [Processor activeProcess environmentAt: #processTests] raise: Error!
Item was removed:
- ----- Method: ProcessTest>>testEvaluateOnBehalfOf (in category 'tests') -----
- testEvaluateOnBehalfOf
-
- | p1 p2 sem results |
- self genuineProcess == Processor activeProcess
- ifFalse: [self fail: 'Cannot debug this test'].
-
- sem := Semaphore new.
- p1 := [] newProcess.
- p1 environmentAt: #foo put: 1.
- p2 := [
- Processor activeProcess environmentAt: #foo put: 2.
- results := {
- Processor activeProcess environmentAt: #foo.
- self genuineProcess environmentAt: #foo.
- Processor activeProcess
- evaluate: [Processor activeProcess environmentAt: #foo]
- onBehalfOf: p1.
- Processor activeProcess
- evaluate: [self genuineProcess environmentAt: #foo]
- onBehalfOf: p1.
- Processor activeProcess environmentAt: #foo }.
- sem signal
- ] newProcess.
-
- p2 resume.
- sem wait.
-
- self assert: {2. 2. 1. 2. 2} equals: results.!
Item was removed:
- ----- Method: ProcessTest>>testPrioritySetBeforeSuspendedContext (in category 'tests') -----
- testPrioritySetBeforeSuspendedContext
- "Test whether priority is set before suspendedContext during process creation."
-
- "Setting priority after causes an endless stream of error windows when debugging e.g.
- [] newProcess
- when Process Browser is open with auto-update on.
-
- Once the suspendedContext is set, the new process is no longer considered terminated
- and Process Browser will try to place it in its list of processes but encounters a nil error
- when reading its priority because it has not been set yet."
-
- | p inside |
- inside := false.
- p := [inside := true. [] newProcess] newProcess.
- p runUntil: [:ctx | inside].
- p runUntil: [:ctx | ctx selectorToSendOrSelf = #suspendedContext:].
- "Now p is before assigning suspendedContext in Process class >> forContext:priority:
- tempAt: 3 is the local variable 'newProcess' representing the newly created process;
- verify whether the new process's priority has already been set."
- self assert: (p suspendedContext tempAt: 3) priority notNil!
Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulRunning (in category 'tests') -----
- testProcessFaithfulRunning
- "While simulating a process using #runUntilErrorOrReturnFrom:, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
-
- | process result |
- process := Process forBlock: [
- result := Processor activeProcess environmentAt: #foo].
- process environmentAt: #foo put: 42.
-
- process complete: process suspendedContext.
-
- self assert: 42 equals: result.!
Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulSimulation (in category 'tests') -----
- testProcessFaithfulSimulation
- "While simulating a process using the bytecode simulation machinery, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
-
- | process result |
- process := Process forBlock: [
- result := Processor activeProcess environmentAt: #foo].
- process environmentAt: #foo put: 42.
-
- process runUntil: [:context | context isDead].
-
- self assert: 42 equals: result.!
Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulTerminate (in category 'tests') -----
- testProcessFaithfulTerminate
-
- ^ self testProcessFaithfulTermination: #terminate!
Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulTerminateAggressively (in category 'tests') -----
- testProcessFaithfulTerminateAggressively
-
- ^ self testProcessFaithfulTermination: #terminateAggressively!
Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulTermination: (in category 'support') -----
- testProcessFaithfulTermination: terminator
- "When terminating a process, unwind blocks should be evaluated as if they were executed by the process being terminated."
-
- | process result |
- process := [
- [Processor activeProcess suspend]
- ensure: [result := Processor activeProcess environmentAt: #foo]]
- fork.
- Processor yield.
- process environmentAt: #foo put: 42.
-
- terminator value: process.
-
- self should: process isTerminated.
- self assert: 42 equals: result.!
Item was removed:
- ----- Method: ProcessTest>>testProcessStateTestDestroy (in category 'tests') -----
- testProcessStateTestDestroy
-
- ^ self testProcessStateTestTermination: #destroy!
Item was removed:
- ----- Method: ProcessTest>>testProcessStateTestTerminate (in category 'tests') -----
- testProcessStateTestTerminate
-
- ^ self testProcessStateTestTermination: #terminate!
Item was removed:
- ----- Method: ProcessTest>>testProcessStateTestTerminateAggressively (in category 'tests') -----
- testProcessStateTestTerminateAggressively
-
- ^ self testProcessStateTestTermination: #terminateAggressively!
Item was removed:
- ----- Method: ProcessTest>>testProcessStateTestTermination: (in category 'support') -----
- testProcessStateTestTermination: terminator
- "I test that a process is terminated when it reaches the last instruction
- of the bottom context for methods other than Process>>#terminate;
- this test would fail with the version of isTerminated before 3/11/2021."
-
- | bottomContext newProcess |
-
- newProcess := Process new.
- bottomContext := Context
- sender: nil
- receiver: newProcess
- method: (ProcessTest>>#terminated)
- arguments: {}.
- newProcess suspendedContext: ([] asContextWithSender: bottomContext).
- newProcess priority: Processor activePriority.
-
- self deny: newProcess isTerminated.
- terminator value: newProcess.
- self assert: newProcess isTerminated.
- !
Item was removed:
- ----- Method: ProcessTest>>testProcessStateTests (in category 'tests') -----
- testProcessStateTests
- self assert: Processor activeProcess isActiveProcess.
- self deny: Processor activeProcess isBlocked.
- self assert: Processor activeProcess isRunnable.
- self deny: Processor activeProcess isSuspended.
- self deny: Processor activeProcess isTerminated.
-
- "These processes are runnable but haven't got to the wait yet because the active process is running."
- self deny: ([semaphore wait] forkAt: Processor activePriority) isActiveProcess.
- self deny: ([semaphore wait] forkAt: Processor activePriority) isBlocked.
- self assert: ([semaphore wait] forkAt: Processor activePriority) isRunnable.
- self deny: ([semaphore wait] forkAt: Processor activePriority) isSuspended.
- self deny: ([semaphore wait] forkAt: Processor activePriority) isTerminated.
- self deny: ([semaphore wait] forkAt: Processor activePriority) suspendingList == semaphore.
-
- "These processes do get to run because, being higher priority they preempt the active process until they wait on the semaphore."
- self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isActiveProcess.
- self assert: ([semaphore wait] forkAt: Processor activePriority + 1) isBlocked.
- self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isRunnable.
- self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isSuspended.
- self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isTerminated.
- self assert: ([semaphore wait] forkAt: Processor activePriority + 1) suspendingList == semaphore.
-
- "These processes should be suspended, not terminated."
- self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isActiveProcess.
- self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isBlocked.
- self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isRunnable.
- self assert: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isSuspended.
- self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isTerminated.
- self assert: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) suspendingList isNil.
-
- "These processes should be terminated, not suspended."
- #(terminate terminateAggressively destroy) do: [:terminator |
- self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isActiveProcess.
- self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isBlocked.
- self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isRunnable.
- self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isSuspended.
- self assert: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isTerminated.
- self assert: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) suspendingList isNil].
-
- "These processes should be suspended."
- self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isActiveProcess.
- self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isBlocked.
- self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isRunnable.
- self assert: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isSuspended.
- self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isTerminated.
-
- "These processes should be terminated."
- #(terminate terminateAggressively destroy) do: [:terminator |
- self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isActiveProcess.
- self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isBlocked.
- self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isRunnable.
- self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isSuspended.
- self assert: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isTerminated].!
Item was removed:
- ----- Method: ProcessTest>>testProcessStateTests2 (in category 'tests') -----
- testProcessStateTests2
- "I test that a process is terminated when it reaches the last instruction
- of the bottom context for methods other than Process>>#terminate;
- this test would fail with the version of isTerminated before 3/11/2021."
-
- | bottomContext newProcess |
-
- newProcess := Process new.
- bottomContext := Context
- sender: nil
- receiver: newProcess
- method: (ProcessTest>>#terminated)
- arguments: {}.
- newProcess suspendedContext: ([] asContextWithSender: bottomContext).
- newProcess priority: Processor activePriority.
-
- self deny: newProcess isTerminated.
- newProcess terminate.
- self assert: newProcess isTerminated.
- !
Item was removed:
- ----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') -----
- testResumeTerminatingProcess
- "An attempt to resume a terminating process should probably raise an error;
- leave this test as an expected failure for the moment."
-
- | terminatee terminator resumed semaphore |
- semaphore := Semaphore new.
- terminatee := [semaphore critical:[]. resumed := true] fork.
- Processor yield.
- terminator := [terminatee terminate] newProcess.
- self assert: terminatee suspendingList == semaphore.
- self assert: terminator isSuspended.
- "run terminator and stop inside #terminate"
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
- self assert: terminator isSuspended.
- "resume the terminatee process and and check if the VM raises an error;
- an error is expected because terminatee's suspendedContext equals nil"
- self should: [terminatee resume] raise: Error.
- "now let the terminator finish terminating the terminatee process"
- terminator resume.
- Processor yield.
- self assert: resumed isNil.
- self assert: terminatee isTerminated.
- self assert: terminator isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testRevisedSuspendExpectations (in category 'tests') -----
- testRevisedSuspendExpectations
- "Test revised suspend expectations vs. pre-2022 VM's suspend"
-
- | s p list |
- s := Semaphore new.
- p := [s critical:[]] forkAt: Processor activePriority + 1.
- list := p suspend.
-
- Smalltalk processSuspensionUnblocks
- ifFalse: [
- self assert: p suspendingList equals: nil.
- self assert: list equals: nil.
- self deny: p suspendedContext selectorJustSentOrSelf equals: #wait
- ]
- ifTrue: [
- self assert: p suspendingList equals: nil.
- self assert: list equals: s.
- self assert: p suspendedContext selectorJustSentOrSelf equals: #wait
- ]!
Item was removed:
- ----- Method: ProcessTest>>testTerminateByHighestPriorityProcess (in category 'tests') -----
- testTerminateByHighestPriorityProcess
- "Test temination by a highest priority process."
-
- "Note: in case #terminate elevates the priority of the terminating
- process it has to make sure it doesn't exceed the highest priority.
- Workspace example:
- q := [Semaphore new wait] fork.
- p := [q terminate] forkAt: Processor highestPriority.
- q isTerminated
-
- We have to catch the 'Invalid priority' error via the 'error' variable
- because #shouldnt:raise: doesn't work between two processes."
-
- | p q error |
- p := [Semaphore new wait] fork.
- Processor yield.
- self assert: p isBlocked.
- error := false.
- q := [[p terminate] on: Error do: [error := true]] newProcess.
- q priority: Processor highestPriority.
- q resume.
- self deny: error.
- self assert: p isTerminated.
- self assert: q isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateEnsureAsStackTop (in category 'tests') -----
- testTerminateEnsureAsStackTop
- "Test #ensure unwind block is executed even when #ensure context is on stack's top."
-
- | p1 p2 p3 x1 x2 x3 |
- x1 := x2 := x3 := false.
-
- "p1 is at the beginning of the ensure block and the unwind block hasn't run yet"
- p1 := Process
- forBlock: [[] ensure: [x1 := x1 not]]
- runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) isNil]].
- p1 step. p1 step. "move the pc behind the send: valueNoContextSwitch instruction"
-
- "p2 has already set complete to true (tempAt: 2) but the unwind block hasn't run yet"
- p2 := Process
- forBlock: [[] ensure: [x2 := x2 not]]
- runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) notNil]].
-
- "p3 has already set complete to true AND the unwind block has already run;
- we have to verify the unwind block is not executed again during termination"
- p3 := Process
- forBlock: [[] ensure: [x3 := x3 not]]
- runUntil: [:ctx | ctx isUnwindContext and: [ctx willReturn]].
-
- "make sure all processes are running and only the p3's unwind block has finished"
- self deny: p1 isTerminated | p2 isTerminated | p3 isTerminated.
- self deny: x1 | x2.
- self assert: x3. "p3 has already run its unwind block; we test it won't run it again"
- "terminate all processes and verify all unwind blocks have finished correctly"
- p1 terminate. p2 terminate. p3 terminate.
- self assert: p1 isTerminated & p2 isTerminated & p3 isTerminated.
- self assert: x1 & x2 & x3!
Item was removed:
- ----- Method: ProcessTest>>testTerminateEnsureOnTopOfEnsure (in category 'tests') -----
- testTerminateEnsureOnTopOfEnsure
- "Test two ensure contexts on top of each other unwind correctly,
- that both their unwind blocks get executed."
-
- | beenHere beenHereToo bottom p top |
- beenHere := beenHereToo := false.
- bottom := Context contextEnsure: [beenHereToo := true].
- top := Context contextEnsure: [Processor activeProcess suspend. beenHere := true].
- top privSender: bottom.
- p := Process forContext: top priority: Processor activeProcess priority.
- p resume.
- Processor yield.
- self assert: p isSuspended.
- p terminate.
- self assert: beenHere & beenHereToo.
- self assert: p isTerminated
-
- !
Item was removed:
- ----- Method: ProcessTest>>testTerminateHandlingUnwindError (in category 'tests') -----
- testTerminateHandlingUnwindError
- "Test an error inside an unwind block is handled correctly."
-
- "Workspace example:
- [ [[Processor activeProcess terminate] ensure: [1/0]] on: ZeroDivide do: [] ] fork
-
- ZeroDivide error should get caught by the handler without opening the Debugger.
-
- To model this example as a test case we have to keep in mind that an error signal
- in one thread cannot be caught in a different thread: if process 'p' signals an error
- it won't be searching for a handler in the thread that sent 'p terminate' message.
- So we can't do something like:
- p := [ [ [Semaphore new wait] ensure: [1/0] ] on: ZeroDivide do: [] ] fork.
- Processor yield.
- self shouldnt: [p terminate] raise: Error
- Instead, in order to catch the situation the ZeroDivide error is not caught within 'p',
- we try to catch the UnhandledError raised in 'p' indicating the ZeroDivide has been
- missed. "
-
- | p error unwindBlock |
- unwindBlock := [[1/0] on: UnhandledError do: [error := true]].
- p := [ [ [Semaphore new wait] ensure: unwindBlock ] on: ZeroDivide do: [] ] fork.
- Processor yield.
- self assert: p isBlocked.
- error := false.
- p terminate.
- self deny: error.
- self assert: p isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateHighestPriorityProcess (in category 'tests') -----
- testTerminateHighestPriorityProcess
- "Test termination of a highest priority process."
-
- | p |
- p := [Semaphore new wait] forkAt: Processor highestPriority.
- Processor yield.
- self assert: p isBlocked.
- p terminate.
- self assert: p isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateInTerminate (in category 'tests') -----
- testTerminateInTerminate
- "Terminating a terminator process should unwind both the terminator and its terminatee process"
-
- | terminator terminatee unwound |
- unwound := false.
- terminatee := [[Processor activeProcess suspend] ensure: [unwound := true]] fork.
- Processor yield.
- terminator := [terminatee terminate] newProcess.
- self assert: terminatee isSuspended.
- self assert: terminator isSuspended.
- "run terminator and stop inside #terminate"
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
- self assert: terminator isSuspended.
- terminator terminate.
- self assert: terminator isTerminated.
- self assert: unwound!
Item was removed:
- ----- Method: ProcessTest>>testTerminateNestedUnwind (in category 'tests') -----
- testTerminateNestedUnwind
- "Test all nested unwind blocks are correctly unwound; all unwind blocks halfway through their execution should be completed or at least attempted to complete, not only the innermost one"
-
- | p x1 x2 x3 |
- x1 := x2 := x3 := false.
- p :=
- [
- [
- [ ] ensure: [ "halfway through completion when suspended"
- [ ] ensure: [ "halfway through completion when suspended"
- Processor activeProcess suspend.
- x1 := true].
- x2 := true]
- ] ensure: [ "not started yet when suspended"
- x3 := true]
- ] fork.
- Processor yield.
- p terminate.
-
- self assert: x1.
- self assert: x2.
- self assert: x3.!
Item was removed:
- ----- Method: ProcessTest>>testTerminateNestedUnwindAggressively (in category 'tests') -----
- testTerminateNestedUnwindAggressively
- "Test nested unwind blocks are correctly unwound; all unwind blocks halfway through their execution should not be attempted to complete."
-
- | p x1 x2 x3 |
- x1 := x2 := x3 := false.
- p :=
- [
- [
- [ ] ensure: [ "halfway through completion when suspended"
- [ ] ensure: [ "halfway through completion when suspended"
- Processor activeProcess suspend.
- x1 := true].
- x2 := true]
- ] ensure: [ "not started yet when suspended"
- x3 := true]
- ] fork.
- Processor yield.
- p terminateAggressively.
-
- self deny: x1.
- self deny: x2.
- self assert: x3.!
Item was removed:
- ----- Method: ProcessTest>>testTerminateNiledSuspendedContextProcess (in category 'tests') -----
- testTerminateNiledSuspendedContextProcess
- "Test a process with niled suspendedContext terminates correctly."
-
- | p |
- p := [] newProcess.
- self assert: p isSuspended.
- p suspendedContext: nil.
- p terminate.
- self assert: p isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateSingleEnsure (in category 'tests') -----
- testTerminateSingleEnsure
- "Test a stack consisting of a single ensure context unwinds correctly."
-
- | beenHere p singleton |
- beenHere := false.
- singleton := Context contextEnsure: [beenHere := true].
- p := Process forContext: singleton priority: Processor activeProcess priority.
- self assert: p isSuspended.
- self assert: p suspendedContext sender isNil.
- p terminate.
- self assert: beenHere.
- self assert: p isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') -----
- testTerminateTerminatingProcess
- "An attempt to terminate a terminating process should probably raise an error;
- leave this test as an expected failure for the moment."
-
- | terminatee terminator resumed semaphore |
- semaphore := Semaphore new.
- terminatee := [semaphore critical:[]. resumed := true] fork.
- Processor yield.
- terminator := [terminatee terminate] newProcess.
- self assert: terminatee suspendingList == semaphore.
- self assert: terminator isSuspended.
- "run terminator and stop inside #terminate"
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
- self assert: terminator isSuspended.
- "terminate the terminatee process again and let the termination finish;
- an error is expected because #terminate detected multiple termination"
- self should: [terminatee terminate] raise: Error.
- "now let the terminator finish terminating the terminatee process"
- terminator resume.
- Processor yield.
- self assert: resumed isNil.
- self assert: terminatee isTerminated.
- self assert: terminator isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateTerminatingProcessAfterUnwindStarted (in category 'tests') -----
- testTerminateTerminatingProcessAfterUnwindStarted
- "Terminating a terminatee process after the terminator process restarted the terminatee
- process should unwind the terminatee process and let the terminator process terminate."
-
- "Such a situation may occur e.g. when a terminating process encounters an error and
- opens a debugger (or calls another recovery machinery). In such case it's legitimate
- to terminate the terminating process again (by closing the debugger or as a termination
- by another recovery tool).
-
- Note: this is a different situation than in 'testTerminateTerminatingProcess' where
- the second termination is invoked 'too early' and may cause unpredictable outcome."
-
- | terminator terminatee unwound unwindBlock |
- unwound := false.
- unwindBlock := [Processor activeProcess suspend. unwound := true].
- terminatee := [[Semaphore new wait] ensure: unwindBlock] fork.
- Processor yield.
- terminator := [terminatee terminate] newProcess.
- self assert: terminatee isBlocked.
- self assert: terminator isSuspended.
- terminator resume.
- Processor yield.
- "terminator starts terminatee's unwind"
- Processor yield.
- "terminatee resumes and stops at unwindBlock's #suspend"
- self assert: terminatee isSuspended.
- terminatee terminate.
- self assert: terminatee isTerminated.
- self assert: unwound.
- Processor yield.
- self assert: terminator isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateTerminatingProcessInUnwindTo (in category 'tests') -----
- testTerminateTerminatingProcessInUnwindTo
- "Terminating a terminatee process after the terminator process restarted the terminatee
- process should unwind the terminatee process and let the terminator process terminate."
-
- | terminator terminatee unwound |
- unwound := false.
- terminatee := [[Semaphore new wait] ensure: [unwound := true]] fork.
- Processor yield.
- terminator := [terminatee terminate] newProcess.
- self assert: terminatee isBlocked.
- self assert: terminator isSuspended.
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #resume].
- "terminator steps until terminatee's unwind context is set"
- terminator suspendedContext nextInstruction. "skip terminatee resume instruction"
- terminator resume. "and run until parked at wait"
- terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #unwindTo:].
- "terminatee steps until at #unwindTo:"
- self assert: terminatee isSuspended.
- terminatee terminate.
- self assert: terminatee isTerminated.
- self assert: unwound.
- Processor yield.
- self assert: terminator isTerminated!
Item was removed:
- ----- Method: ProcessTest>>testTerminateWithDelayInUnwind (in category 'tests') -----
- testTerminateWithDelayInUnwind
- "Test the process that invoked the termination of another process waits
- for the other process to finish unwinding."
-
- "Insert delay into the unwind block to force rescheduling; alternatively,
- 'Processor yield' could be used instead of 'delay wait'."
-
- | delay p |
- delay := Delay forMilliseconds: 10.
- p := [[Processor activeProcess suspend] ensure: [delay wait]] fork.
- Processor yield.
- self assert: p isSuspended.
- p terminate.
- self assert: p isTerminated!
Item was removed:
- AbstractProcessTest subclass: #ProcessUnwindTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateActiveInNestedEnsure1 (in category 'tests') -----
- testTerminateActiveInNestedEnsure1
- "Terminate active process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [Processor activeProcess terminate] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateActiveInNestedEnsure2 (in category 'tests') -----
- testTerminateActiveInNestedEnsure2
- "Terminate active process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [ ] ensure: [
- Processor activeProcess terminate.
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateBlockedInNestedEnsure1 (in category 'tests') -----
- testTerminateBlockedInNestedEnsure1
- "Terminate blocked process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [semaphore wait] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is blocked and none of the unwind blocks has finished yet"
- self assert: p isBlocked.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateBlockedInNestedEnsure2 (in category 'tests') -----
- testTerminateBlockedInNestedEnsure2
- "Terminate blocked process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [ ] ensure: [
- semaphore wait.
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is blocked and none of the unwind blocks has finished yet"
- self assert: p isBlocked.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn1 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn1
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [Processor activeProcess suspend] ensure: [
- x1 := true. return value].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x3.
- self deny: x2 & x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn2 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn2
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [] ensure: [
- Processor activeProcess suspend.
- x1 := true. return value].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x3.
- self deny: x2 & x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn3 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn3
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [Processor activeProcess suspend] ensure: [
- x1 := true].
- x2 := true. return value]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn4 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn4
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [] ensure: [
- Processor activeProcess suspend.
- x1 := true].
- x2 := true. return value]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn5 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn5
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [Processor activeProcess suspend] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true. return value].
- x4 := true.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn6 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn6
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [] ensure: [
- Processor activeProcess suspend.
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true. return value].
- x4 := true.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn7 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn7
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [Processor activeProcess suspend] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true. return value.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn8 (in category 'tests') -----
- testTerminateInNestedEnsureWithReturn8
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [:return |
- [
- [ ] ensure: [
- [] ensure: [
- Processor activeProcess suspend.
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true. return value.
- ] valueWithExit
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateNestedEnsureWithReturn1 (in category 'tests') -----
- testTerminateNestedEnsureWithReturn1
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- "While testTerminateInNestedEnsureWithReturn1 to 8 start unwinding
- from inside a halfways through unwind block, this test (and the next) start
- the unwind from outside any ensure argument (aka unwind) block, testing
- the second half of the #unwindTo:safely: method."
-
- | p x1 x2 x3 x4 x5 |
- x1 := x2 := x3 := x4 := x5 := false.
- p :=
- [
- [:return |
- [ Processor activeProcess suspend.
- [ ] ensure: [
- [ ] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- return value.
- x3 := true].
- x4 := true.
- ] valueWithExit.
- x5 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4 | x5.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self deny: x1 & x2 & x3 & x4 & x5!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateNestedEnsureWithReturn2 (in category 'tests') -----
- testTerminateNestedEnsureWithReturn2
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 x5 |
- x1 := x2 := x3 := x4 := x5 := false.
- p :=
- [
- [:return |
- [
- [Processor activeProcess suspend] ensure: [
- [ ] ensure: [
- x1 := true].
- return value.
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] valueWithExit.
- x5 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4 | x5.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self deny: x1 & x2 & x3 & x4 & x5!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateRunnableInNestedEnsure1 (in category 'tests') -----
- testTerminateRunnableInNestedEnsure1
- "Terminate runnable process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [Processor yield] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is runnable and none of the unwind blocks has finished yet"
- self assert: p isRunnable.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateRunnableInNestedEnsure2 (in category 'tests') -----
- testTerminateRunnableInNestedEnsure2
- "Terminate runnable process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [ ] ensure: [
- Processor yield.
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is runnable and none of the unwind blocks has finished yet"
- self assert: p isRunnable.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateSuspendedInNestedEnsure1 (in category 'tests') -----
- testTerminateSuspendedInNestedEnsure1
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [Processor activeProcess suspend] ensure: [
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: ProcessUnwindTest>>testTerminateSuspendedInNestedEnsure2 (in category 'tests') -----
- testTerminateSuspendedInNestedEnsure2
- "Terminate suspended process.
- Test all nested unwind blocks are correctly executed;
- all unwind blocks halfway through their execution should be completed."
-
- | p x1 x2 x3 x4 |
- x1 := x2 := x3 := x4 := false.
- p :=
- [
- [
- [ ] ensure: [
- [ ] ensure: [
- Processor activeProcess suspend.
- x1 := true].
- x2 := true]
- ] ensure: [
- x3 := true].
- x4 := true.
- ] newProcess.
- p resume.
- Processor yield.
- "make sure p is suspended and none of the unwind blocks has finished yet"
- self assert: p isSuspended.
- self deny: x1 | x2 | x3 | x4.
- "now terminate the process and make sure all unwind blocks have finished"
- p terminate.
- self assert: p isTerminated.
- self assert: x1 & x2 & x3.
- self deny: x4.!
Item was removed:
- ----- Method: Promise>>unsynchronized (in category '*KernelTests-Processes') -----
- unsynchronized
- "This is useful for tests, because it's quite easy otherwise to deadlock your image. It is a DISASTER to use this in production code!!"
- mutex := NullMutex new.!
Item was removed:
- TestCase subclass: #PromiseTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
Item was removed:
- ----- Method: PromiseTest>>testAnErrorInOnRejectedRejectsPromise (in category 'tests - monad') -----
- testAnErrorInOnRejectedRejectsPromise
- "https://promisesaplus.com section 2.2.7.2"
- | p q error |
- p := Promise new.
- q := p ifRejected: [:e | (error := KeyNotFound new) signal].
- p rejectWith: 1.
- self assert: p isRejected description: 'Original Promise not rejected'.
- self assert: q isRejected description: 'Broken Promise not rejected'.
- self assert: p error = 1.
- self assert: q error == error.!
Item was removed:
- ----- Method: PromiseTest>>testAnErrorInThenRejectsPromise (in category 'tests - monad') -----
- testAnErrorInThenRejectsPromise
- "https://promisesaplus.com section 2.2.7.2"
- | p q error |
- p := Promise new.
- q := p then: [:v | (error := KeyNotFound new) signal].
- p resolveWith: 1.
- self deny: p isRejected description: 'Original Promise rejected'.
- self assert: q isRejected description: 'Broken Promise not rejected'.
- self assert: p value = 1.
- self assert: q error == error.!
Item was removed:
- ----- Method: PromiseTest>>testCanRejectPromise (in category 'tests - monad') -----
- testCanRejectPromise
- | p |
- p := Promise new.
- p rejectWith: Error new.!
Item was removed:
- ----- Method: PromiseTest>>testCannotRejectFulfilledPromise (in category 'tests - monad') -----
- testCannotRejectFulfilledPromise
- | p |
- p := Promise unit: 1.
- p rejectWith: Error new.
- self assert: p isResolved.
- self assert: 1 equals: p value.
- !
Item was removed:
- ----- Method: PromiseTest>>testCannotResolveaRejectedPromise (in category 'tests - monad') -----
- testCannotResolveaRejectedPromise
- | p e |
- p := Promise new.
- e := Error new.
- p rejectWith: e.
- p resolveWith: 1.
- self assert: p isRejected.
- self assert: p error == e.
- !
Item was removed:
- ----- Method: PromiseTest>>testChainedResolvers (in category 'tests') -----
- testChainedResolvers
- | promise1 promise2 result |
- promise1 := Promise new.
- promise2 := Promise new.
- promise1 whenResolved: [:bool | promise2 resolveWith: bool not].
- promise2 whenResolved: [:bool | result := bool].
- promise1 resolveWith: false.
- self should: [result].!
Item was removed:
- ----- Method: PromiseTest>>testCollapsesChainsOfPromises (in category 'tests - monad') -----
- testCollapsesChainsOfPromises
- "The monadic bind operator has signature (m a -> (a -> m b) -> m b): that is, in our setting,
- the block given to `then:` is expected to return a *Promise* of a value, not a value directly.
- It is convenient to accept non-promise values and automatically lift them into the monad,
- but we must also ensure we treat the case where a `then:`-block yields a Promise correctly."
- | p q r |
- p := Promise new.
- q := p then: [:v | Promise unit: v * 2].
- r := q then: [:v | Promise unit: v + 1].
- p resolveWith: 4.
- self assert: 4 * 2 equals: q value.
- self assert: (4 * 2 + 1) equals: r value.!
Item was removed:
- ----- Method: PromiseTest>>testFirstResolutionWins (in category 'tests - monad') -----
- testFirstResolutionWins
- | p |
- p := Promise new.
- p resolveWith: 1.
- p resolveWith: 2.
- self assert: p isResolved.
- self assert: p value == 1.
- !
Item was removed:
- ----- Method: PromiseTest>>testFulfillWithError (in category 'tests') -----
- testFulfillWithError
- | p |
- p := Promise new.
- p fulfillWith: [ 1 / 0 ] passErrors: false.
- self assert: p isRejected.
- self assert: ZeroDivide equals: p error class.!
Item was removed:
- ----- Method: PromiseTest>>testFulfillWithHaltAndResult (in category 'tests') -----
- testFulfillWithHaltAndResult
- | p |
- p := Promise new.
- [
- p fulfillWith: [ self halt. 3 + 4 ]
- ] on: Halt do: [:ex | ex resume].
- self assert: p isResolved.
- self assert: 7 equals: p value.!
Item was removed:
- ----- Method: PromiseTest>>testFulfillWithResult (in category 'tests') -----
- testFulfillWithResult
- | p |
- p := Promise new.
- p fulfillWith: [ 3 + 4 ].
- self assert: p isResolved.
- self assert: 7 equals: p value.!
Item was removed:
- ----- Method: PromiseTest>>testFutureRejectionInvisibleError (in category 'tests - future') -----
- testFutureRejectionInvisibleError
- | p |
- p := 1 future / 0.
- p whenRejected: []. "Installing a rejection handler is enough to cause the exception to be swallowed."
- self assert: (self waitUntil: [p isRejected] orCycleCount: 100).
- self assert: p isRejected.
- self assert: ZeroDivide equals: p error class.!
Item was removed:
- ----- Method: PromiseTest>>testFutureRejectionVisibleError (in category 'tests - future') -----
- testFutureRejectionVisibleError
- | p |
- p := 1 future / 0.
- [
- self assert: (self waitUntil: [p isRejected] orCycleCount: 100)
- ] on: ZeroDivide do: [:ex | "Fall through." ].
- self assert: p isRejected.
- self assert: ZeroDivide equals: p error class.!
Item was removed:
- ----- Method: PromiseTest>>testFutureResolution (in category 'tests - future') -----
- testFutureResolution
- | p |
- p := 3 future + 4.
- self assert: (self waitUntil: [p isResolved] orCycleCount: 100).
- self assert: p isResolved.
- self assert: 7 equals: p value.!
Item was removed:
- ----- Method: PromiseTest>>testMultipleResolvers (in category 'tests') -----
- testMultipleResolvers
- | promise sum |
- sum := 0.
- promise := Promise new.
- 5 timesRepeat: [
- promise whenResolved: [:val | sum := sum + val].
- ].
- promise resolveWith: 5.
- self should: [sum = 25].
- !
Item was removed:
- ----- Method: PromiseTest>>testNilErrBlockPropagation (in category 'tests - monad') -----
- testNilErrBlockPropagation
- "https://promisesaplus.com section 2.2.7.4"
- | p q |
- p := Promise new.
- q := p then: [:v | self error: 'Shouldn''t call resolvedBlock'] ifRejected: nil.
- p rejectWith: 1.
- self assert: p isRejected.
- self assert: q isRejected.
- self assert: p error equals: 1.
- self assert: q error equals: 1.!
Item was removed:
- ----- Method: PromiseTest>>testNilResolvedBlockPropagation (in category 'tests - monad') -----
- testNilResolvedBlockPropagation
- "https://promisesaplus.com section 2.2.7.3"
- | p q |
- p := Promise new.
- q := p then: nil ifRejected: [:e | self error: 'Shouldn''t call errBlock'].
- p resolveWith: 1.
- self assert: p isResolved.
- self assert: q isResolved.
- self assert: p value equals: 1.
- self assert: q value equals: 1.!
Item was removed:
- ----- Method: PromiseTest>>testRejectWithInvokesErrorHandlers (in category 'tests - monad') -----
- testRejectWithInvokesErrorHandlers
- | p error returnedError |
- returnedError := nil.
- error := KeyNotFound new.
- p := Promise ifRejected: [:e | returnedError := e].
- p rejectWith: error.
- self assert: returnedError notNil description: 'Error block did not run.'.
- self assert: error equals: returnedError description: 'Error not passed into block'.
- self assert: error equals: p error description: 'Promise didn''t store error'.!
Item was removed:
- ----- Method: PromiseTest>>testSingleResolver (in category 'tests') -----
- testSingleResolver
- | promise sum |
- sum := 0.
- promise := Promise new.
- promise whenResolved: [:val | sum := sum + val].
- promise resolveWith: 5.
- self assert: 5 equals: sum.
- !
Item was removed:
- ----- Method: PromiseTest>>testThenPermitsChainingOfPromises (in category 'tests - monad') -----
- testThenPermitsChainingOfPromises
- | p q r |
- p := Promise new.
- q := p then: [:v | v * 2].
- r := q then: [:v | v + 1].
- p resolveWith: 4.
- self assert: 4 * 2 equals: q value.
- self assert: (4 * 2 + 1) equals: r value.!
Item was removed:
- ----- Method: PromiseTest>>testThenReturnsaPromise (in category 'tests - monad') -----
- testThenReturnsaPromise
- | p |
- p := Promise new then: [:v | v * 2].
- self assert: Promise equals: p class.!
Item was removed:
- ----- Method: PromiseTest>>testTimeout (in category 'tests') -----
- testTimeout
- | promise |
- promise := Promise new.
- self shouldnt: [promise waitTimeoutMSecs: 1].
- self shouldnt: [promise isResolved].
- self shouldnt: [promise isRejected].
- promise resolveWith: 45.
- self should: [promise waitTimeoutMSecs: 1].
- self should: [promise isResolved].
- self shouldnt: [promise isRejected].!
Item was removed:
- ----- Method: PromiseTest>>testTimeoutRejected (in category 'tests') -----
- testTimeoutRejected
- | promise |
- promise := Promise new.
- self shouldnt: [promise waitTimeoutMSecs: 1].
- self shouldnt: [promise isResolved].
- self shouldnt: [promise isRejected].
- promise rejectWith: 45.
- self shouldnt: [promise waitTimeoutMSecs: 1].
- self shouldnt: [promise isResolved].
- self should: [promise isRejected].!
Item was removed:
- ----- Method: PromiseTest>>testUnitReturnsaPromise (in category 'tests - monad') -----
- testUnitReturnsaPromise
- | p |
- p := Promise unit: 1.
- self assert: Promise equals: p class.
- self assert: p isResolved.!
Item was removed:
- ----- Method: PromiseTest>>testWaitForRejection (in category 'tests - monad') -----
- testWaitForRejection
- | p |
- p := Promise new.
- [ (Delay forMilliseconds: 1) wait. p rejectWith: Error new ] fork.
- self should: [ p wait ] raise: BrokenPromise.!
Item was removed:
- ----- Method: PromiseTest>>testWaitForResolution (in category 'tests - monad') -----
- testWaitForResolution
- | p |
- p := Promise new.
- [ (Delay forMilliseconds: 1) wait. p resolveWith: #ok ] fork.
- self assert: [ p wait = #ok ]!
Item was removed:
- ----- Method: PromiseTest>>testWaitRejectionYieldsCorrectBrokenPromise (in category 'tests - monad') -----
- testWaitRejectionYieldsCorrectBrokenPromise
- | p |
- p := Promise new.
- [ (Delay forMilliseconds: 1) wait. p rejectWith: Error new ] fork.
- [ p wait ] on: BrokenPromise do: [ :bp | ^ self assert: [ bp promise == p ] ].
- self fail: 'Should not reach this point'!
Item was removed:
- ----- Method: PromiseTest>>testifRejectedDoesNotRunBlockIfPromiseResolves (in category 'tests - monad') -----
- testifRejectedDoesNotRunBlockIfPromiseResolves
- | p q error |
- error := nil.
- p := Promise new.
- q := p ifRejected: [:e | error := e].
- p resolveWith: 1.
- self deny: q isRejected.
- self assert: nil equals: error.!
Item was removed:
- ----- Method: PromiseTest>>testifRejectedRunsBlockIfPromiseFails (in category 'tests - monad') -----
- testifRejectedRunsBlockIfPromiseFails
- "https://promisesaplus.com section 2.2.7.1"
- | p q error |
- error := nil.
- p := Promise new.
- q := p ifRejected: [:e | error := e "N.B. returns a value, does not signal an Exception"].
- p rejectWith: KeyNotFound new.
- self assert: q isResolved.
- self assert: KeyNotFound equals: error class.
- self assert: q value == error.!
Item was removed:
- ----- Method: PromiseTest>>waitUntil:orCycleCount: (in category 'private') -----
- waitUntil: aBlock orCycleCount: anInteger
- "This is a gross hack that depends on running the tests in Morphic.
- We simply repeatedly do a cycle of the interaction loop, which happens
- to also be the way that the queue of pending futures gets serviced."
- | counter |
- counter := 0.
- [
- aBlock value ifTrue: [^ true].
- Project current world doOneSubCycle.
- counter := counter + 1.
- counter >= anInteger ifTrue: [^ false].
- ] repeat!
Item was removed:
- ClassTestCase subclass: #ProtoObjectTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
-
- !ProtoObjectTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class ProtoObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: ProtoObjectTest>>testFlag (in category 'tests - testing') -----
- testFlag
- "This should never throw an exception."
- ProtoObject new flag: #hallo.!
Item was removed:
- ----- Method: ProtoObjectTest>>testIfNil (in category 'tests - testing') -----
- testIfNil
-
- | object block |
- object := ProtoObject new.
- self shouldnt: [ object ifNil: [ self halt ]] raise: Halt.
- self assert: (object ifNil: [ nil ]) == object.
- "Now the same without inlining."
- block := [ self halt ].
- self shouldnt: [ object ifNil: block ] raise: Halt.
- block := [ nil ].
- self assert: (object ifNil: block) == object.
-
- !
Item was removed:
- ----- Method: ProtoObjectTest>>testIfNilIfNotNil (in category 'tests - testing') -----
- testIfNilIfNotNil
-
- | object returnValue block |
- object := ProtoObject new.
- returnValue := Object new.
- self should: [ object ifNil: [ self error ] ifNotNil: [ self halt ] ] raise: Halt.
- self should: [ object ifNil: [ self error ] ifNotNil: [ :o | self halt ] ] raise: Halt.
- self assert: (object ifNil: [ false ] ifNotNil: [ :o | o == object ]).
- self assert: (object ifNil: [ nil ] ifNotNil: [ returnValue ]) == returnValue.
- self assert: (object ifNil: [ nil ] ifNotNil: [ :o | returnValue ]) == returnValue.
- "Now the same without inlining."
- block := [ self halt ].
- self should: [ object ifNil: [ self error ] ifNotNil: block ] raise: Halt.
- block := [ :o | self halt ].
- self should: [ object ifNil: [ self error ] ifNotNil: block ] raise: Halt.
- block := [ :o | o == object ].
- self assert: (object ifNil: [ false ] ifNotNil: block).
- block := [ returnValue ].
- self assert: (object ifNil: [ nil ] ifNotNil: block) = returnValue.
- block := [ :o | returnValue ].
- self assert: (object ifNil: [ nil ] ifNotNil: block) = returnValue!
Item was removed:
- ----- Method: ProtoObjectTest>>testIfNotNil (in category 'tests - testing') -----
- testIfNotNil
-
- | object returnValue block |
- object := ProtoObject new.
- returnValue := Object new.
- self should: [ object ifNotNil: [ self halt ] ] raise: Halt.
- self should: [ object ifNotNil: [ :o | self halt ] ] raise: Halt.
- self assert: (object ifNotNil: [ :o | o == object ]).
- self assert: (object ifNotNil: [ returnValue ]) == returnValue.
- self assert: (object ifNotNil: [ :o | returnValue ]) == returnValue.
- "Now the same without inlining."
- block := [ self halt ].
- self should: [ object ifNotNil: block ] raise: Halt.
- block := [ :o | self halt ].
- self should: [ object ifNotNil: block ] raise: Halt.
- block := [ :o | o == object ].
- self assert: (object ifNotNil: block).
- block := [ returnValue ].
- self assert: (object ifNotNil: block) = returnValue.
- block := [ :o | returnValue ].
- self assert: (object ifNotNil: block) = returnValue!
Item was removed:
- ----- Method: ProtoObjectTest>>testIfNotNilIfNil (in category 'tests - testing') -----
- testIfNotNilIfNil
-
- | object returnValue block |
- object := ProtoObject new.
- returnValue := Object new.
- self should: [ object ifNotNil: [ self halt ] ifNil: [ self error ] ] raise: Halt.
- self should: [ object ifNotNil: [ :o | self halt ] ifNil: [ self error ] ] raise: Halt.
- self assert: (object ifNotNil: [ :o | o == object ] ifNil: [ false ]).
- self assert: (object ifNotNil: [ returnValue ] ifNil: [ false ]) == returnValue.
- self assert: (object ifNotNil: [ :o | returnValue ] ifNil: [ false ]) == returnValue.
- "Now the same without inlining."
- block := [ self halt ].
- self should: [ object ifNotNil: block ifNil: [ self error ] ] raise: Halt.
- block := [ :o | self halt ].
- self should: [ object ifNotNil: block ifNil: [ self error ] ] raise: Halt.
- block := [ :o | o == object ].
- self assert: (object ifNotNil: block ifNil: [ false ]).
- block := [ returnValue ].
- self assert: (object ifNotNil: block ifNil: [ false ]) == returnValue.
- block := [ :o | returnValue ].
- self assert: (object ifNotNil: block ifNil: [ false ]) == returnValue!
Item was removed:
- ----- Method: ProtoObjectTest>>testIsNil (in category 'tests - testing') -----
- testIsNil
-
- self deny: ProtoObject new isNil!
Item was removed:
- ClassTestCase subclass: #RandomTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
-
- !RandomTest commentStamp: 'ul 2/27/2015 12:36' prior: 0!
- I test the random number generator implemented by Random. Whenever its implementation changes, I'll have to be updated to match the new implementation.
- Instead of adding methods to Random to access the internal state, I use reflection (#instVarNamed:).!
Item was removed:
- ----- Method: RandomTest>>assertFirstValuesAre:finalStatesAre:withSeed: (in category 'helpers') -----
- assertFirstValuesAre: expectedValues finalStatesAre: expectedFinalStates withSeed: seed
- "Verify that the first generated numbers with the given seed are the same as in expectedValues. Also check that the state of the generator matches expectedFinalStates after the last number was generated."
-
- | random states |
- random := Random seed: seed.
- expectedValues do: [ :each |
- self assert: each equals: random nextValue ].
- states := random instVarNamed: #states.
- self
- assert: expectedFinalStates
- equals: states.
- self
- assert: expectedValues size \\ states size + 1
- equals: (random instVarNamed: #index)
- !
Item was removed:
- ----- Method: RandomTest>>assertInitialStateIs:withSeed: (in category 'helpers') -----
- assertInitialStateIs: expectedInitialState withSeed: seed
- "Verify that the initial values of the states variable match the given values for the given seed."
-
- | random |
- random := Random basicNew.
- random initializeStatesWith: seed.
- self
- assert: expectedInitialState
- equals: (random instVarNamed: #states)!
Item was removed:
- ----- Method: RandomTest>>testExpectedValuesAndFinalStates (in category 'tests') -----
- testExpectedValuesAndFinalStates
- "The numbers here were generated with a modified version of dcmt. http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/DC/dc.html ."
-
- self
- assertFirstValuesAre: #(791793822 321208675 533452018 916714539 223319369 1012473888 519521402 691227136 655932023 762631845 263546831 924338090 559722895 178321509 916222900 335844726 321863848 695515717 112692096 738657692 395570358 340088260 887167633 1009518587 243735024 275847384 769544812 100974653 906270421 342913954 97518663 1067659127 901766500 960849649 913009938 458031838 820147509 822604220 642364166 55274442 357680755 991571674 13914935 857799117 66453038 971120160 398083276 373288317 684827868 674731247)
- finalStatesAre: #(635250399 668117719 848992573 251038832 98606638 713392708 276649431 1832634 607491210 416789795 914892960 325580685 799306927 249385527 318375379 748373901 904063250 170318087)
- withSeed: 1.
- self
- assertFirstValuesAre: #(687305094 702568716 681618148 361497334 56139518 745675778 952599938 953942824 73974730 564274490 1060767469 886737457 1039805902 722013528 64171798 764123925 432128359 274234212 668956319 716744939 309797615 780783289 301460951 535739904 224961890 114117836 193753287 1031006106 336541050 154594855 533038119 881775175 158057306 77776036 493306911 605604566 1048063493 584525301 1022642202 864508130 413151089 57876224 191759976 1008496211 868455235 165567279 536395892 455845625 913969488 1031304391)
- finalStatesAre: #(1042729719 217432604 1069856876 162320335 202162581 218490242 297015026 68487684 898813855 71972347 874350418 438504195 940031925 17654607 153301097 316080480 107798001 361001990)
- withSeed: 16rFFFFFFFF.
- self
- assertFirstValuesAre: #(508754231 328289850 498391260 573176063 453719461 935895611 435707860 570185280 1062441194 1069509491 70217464 149146838 858549983 755358687 617299553 468867114 401402744 731268746 224918805 447062722 290392391 137004397 311801760 320322691 258212560 536704035 950550708 555923010 982471103 981495169 294632011 175884018 503667308 154136572 291636083 607893878 617073742 310910219 169050729 996306290 695080363 165230559 945376911 612064901 884146961 873827275 491094423 292583589 257673098 606271793)
- finalStatesAre: #(650871495 911703262 863344052 176605894 655312644 446078144 11879373 102580040 573515471 123917283 104253098 1042658978 222575135 487008331 309368251 253108077 333913878 249510222)
- withSeed: 36rSqueak!
Item was removed:
- ----- Method: RandomTest>>testInitialStates (in category 'tests') -----
- testInitialStates
- "The numbers here were generated with a modified version of dcmt. http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/DC/dc.html ."
-
- self
- assertInitialStateIs: #(1 738691430 491934885 961690497 64984499 171432612 446538473 482277108 305861910 321062125 1021787430 989754889 231135540 639897334 889001601 577497588 377121465 745575081)
- withSeed: 1.
- self
- assertInitialStateIs: #(1073741823 266459757 720566430 20126452 56152695 937338158 159797905 1043117473 406704525 811309125 915542797 222137334 82370074 761921770 934153467 57368396 980436236 43660082)
- withSeed: 16rFFFFFFFF.
- self
- assertInitialStateIs: #(664399324 1024531762 951500119 549828849 614037886 888424945 697907173 598650154 380912181 737669773 997432646 1017772356 307774789 986202438 417447953 558454367 229264988 682340290)
- withSeed: 36rSqueak.
-
- !
Item was removed:
- ----- Method: RandomTest>>testNext (in category 'tests') -----
- testNext
- "Generate some float values, and see if they are in the [0,1) interval. Also check that the smallest and the largest values are small/large enough."
-
- | random min max |
- min := Float infinity.
- max := Float negativeInfinity.
- random := Random seed: 112629.
- 100000 timesRepeat: [
- | next |
- next := random next.
- next < min ifTrue: [ min := next ].
- next > max ifTrue: [ max := next ].
- self assert: next >= 0.0 description: [ 'Generated value ', next asString, ' should be non-negative.' ].
- self assert: next < 1.0 description: [ 'Generated value ', next asString, ' should be less than 1.0.' ] ].
- self assert: max > 0.9999 description: 'The largest generated value should be greater than 0.9999.'.
- self assert: min < 0.0001 description: 'The smallest generated value should be less than 0.0001.'!
Item was removed:
- ----- Method: RandomTest>>testNextInt (in category 'tests') -----
- testNextInt
- "Generate many integer values from a small range, and see if they are distributed equally on that range. This is not an exact test, but it's good enough to find obvious errors in the generator."
-
- | random |
- random := Random seed: 1234567812345678.
- #(
- 2 100000
- 3 200000
- 10 300000
- 100 400000
- ) groupsDo: [ :bucketCount :runs |
- | buckets |
- buckets := Array new: bucketCount withAll: 0.
- runs timesRepeat: [
- | next |
- next := random nextInt: bucketCount.
- buckets at: next put: (buckets at: next) + 1 ].
- buckets do: [ :each |
- self assert: (each / (runs / bucketCount) between: 0.95 and: 1.05) ] ]!
Item was removed:
- ----- Method: RandomTest>>testNextIntLarge (in category 'tests') -----
- testNextIntLarge
- "Generate many 1281-bit integers and see if their bits are equally distributed. This is not an exact test, but it's good enough to find obvious errors in the generator."
-
- <timeout: 15>
- | random bits bitCounts maxValue runs |
- random := Random seed: 1234567812345678.
- bits := 1281.
- bitCounts := Array new: bits withAll: 0.
- maxValue := 1 << bits.
- runs := 20000.
- runs timesRepeat: [
- | value |
- value := (random nextInt: maxValue) - 1.
- 1 to: bits do: [ :bitIndex |
- bitCounts at: bitIndex put: (bitCounts at: bitIndex) + (value bitAt: bitIndex) ] ].
- bitCounts do: [ :each |
- self assert: ((each / (runs / 2)) between: 0.95 and: 1.05) ]
- !
Item was removed:
- ----- Method: RandomTest>>testRoll (in category 'tests') -----
- testRoll
-
- | random result |
- random := Random seed: 14482.
-
- "Roll the default die (d6)"
- 100 timesRepeat: [
- result := random roll: 'd'.
- self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
- self assert: result <= 6 description: [ 'Rolled value ', result asString, ' should be 6 or less.' ] ].
- 100 timesRepeat: [
- result := random roll: '1d'.
- self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
- self assert: result <= 6 description: [ 'Rolled value ', result asString, ' should be 6 or less.' ] ].
-
- "Roll a d20"
- 100 timesRepeat: [
- result := random roll: '1d20'.
- self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
- self assert: result <= 20 description: [ 'Rolled value ', result asString, ' should be 20 or less.' ] ].
-
- "Roll a d% (d100)"
- 1000 timesRepeat: [
- result := random roll: '1d%'.
- self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
- self assert: result <= 100 description: [ 'Rolled value ', result asString, ' should be 100 or less.' ] ].
- 1000 timesRepeat: [
- result := random roll: 'd%'.
- self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
- self assert: result <= 100 description: [ 'Rolled value ', result asString, ' should be 100 or less.' ] ].
-
- "Roll multiple dice"
- 100 timesRepeat: [
- result := random roll: '2d2'.
- self assert: result >= 2 description: [ 'Rolled value ', result asString, ' should be 2 or more.' ].
- self assert: result <= 4 description: [ 'Rolled value ', result asString, ' should be 4 or less.' ] ].
- 100 timesRepeat: [
- result := random roll: '1d2+1d2'.
- self assert: result >= 2 description: [ 'Rolled value ', result asString, ' should be 2 or more.' ].
- self assert: result <= 4 description: [ 'Rolled value ', result asString, ' should be 4 or less.' ] ].
-
- "Roll some d1s"
- result := random roll: '10d1'.
- self assert: result = 10 description: [ 'Rolled value ', result asString, 'should be 10.' ].
- result := random roll: '10d1-5d1'.
- self assert: result = 5 description: [ 'Rolled value ', result asString, 'should be 5.' ].
-
- "Roll a constant value"
- result := random roll: '5'.
- self assert: result = 5 description: [ 'Rolled value ', result asString, 'should be 5.' ].
- result := random roll: '5+3+2'.
- self assert: result = 10 description: [ 'Rolled value ', result asString, 'should be 10.' ].
-
- "Roll die and add constant value"
- result := random roll: '1d1+3'.
- self assert: result = 4 description: [ 'Rolled value ', result asString, 'should be 4.' ].!
Item was removed:
- ClassTestCase subclass: #ScaledDecimalTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
-
- !ScaledDecimalTest commentStamp: '<historical>' prior: 0!
- I provide a test suite for ScaledDecimal values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumber (in category 'tests') -----
- testAsNumber
- "Ensure no loss of precision"
-
- | sd |
- sd := '1.40s2' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 2.
- self assert: '1.40s2' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberNegatedWithoutDecimalPoint (in category 'tests') -----
- testAsNumberNegatedWithoutDecimalPoint
-
- | sd |
- sd := '-123s0' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 0.
- self assert: '-123s0' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberNegatedWithoutDecimalPoint2 (in category 'tests') -----
- testAsNumberNegatedWithoutDecimalPoint2
-
- | sd |
- sd := '-123s2' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 2.
- self assert: '-123.00s2' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberWithExtendedScale (in category 'tests') -----
- testAsNumberWithExtendedScale
-
- | sd |
- sd := '123s2' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 2.
- self assert: '123.00s2' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberWithRadix (in category 'tests') -----
- testAsNumberWithRadix
-
- | sd |
- sd := '10r-22.2s5' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 5.
- self assert: '-22.20000s5' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberWithSuperfluousDecimalPoint (in category 'tests') -----
- testAsNumberWithSuperfluousDecimalPoint
-
- | sd |
- sd := '123.s2' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 2.
- self assert: '123.00s2' = sd printString.
-
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberWithoutDecimalPoint (in category 'tests') -----
- testAsNumberWithoutDecimalPoint
-
- | sd |
- sd := '123s0' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 0.
- self assert: '123s0' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testAsNumberWithoutDecimalPoint2 (in category 'tests') -----
- testAsNumberWithoutDecimalPoint2
-
- | sd |
- sd := '123s2' asNumber.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 2.
- self assert: '123.00s2' = sd printString.
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testCoercion (in category 'tests') -----
- testCoercion
- #( #* #+ #- #/) do: [:op |
- self assert: (1.0s1 perform: op with: 2) class = ScaledDecimal.
- self assert: (1.0s1 perform: op with: 1/2) class = ScaledDecimal.
- self deny: (1.0s1 perform: op with: 1.0) class = ScaledDecimal.
-
- self assert: (1 perform: op with: 2.0s1) class = ScaledDecimal.
- self assert: (1/2 perform: op with: 2.0s1) class = ScaledDecimal.
- self deny: (1.0 perform: op with: 1.0s1) class = ScaledDecimal]!
Item was removed:
- ----- Method: ScaledDecimalTest>>testConvertFromFloat (in category 'tests') -----
- testConvertFromFloat
-
- | aFloat sd f2 diff |
- aFloat := 11/13 asFloat.
- sd := aFloat asScaledDecimal: 2.
- self assert: 2 = sd scale.
- self assert: '0.84s2' = sd printString.
- self assert: '-0.84s2' = sd negated printString.
- f2 := sd asFloat.
- diff := f2 - aFloat.
- self assert: diff abs < 1.0e-9. "actually, f = f2, but this is not a requirement"
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testConvertFromFraction (in category 'tests') -----
- testConvertFromFraction
- "Converting a Fractionwith asScaledDecimal use strictly necessary number of decimal places when possible."
-
- | defaultNumberOfDecimals |
- 0 to: 11 do: [:pow2 |
- 0 to: 11 do: [:pow5 |
- | fraction sd sd2 |
- fraction := 13 / (2 raisedTo: pow2) / (5 raisedTo: pow5).
- sd := fraction asScaledDecimal.
- self assert: sd scale = (pow2 max: pow5).
- sd2 := ScaledDecimal readFrom: sd printString.
- self assert: sd = sd2]].
-
- defaultNumberOfDecimals := (1/3) asScaledDecimal scale.
- #(6 7 9 11 12 13 14 17 18 19 21 22 23 24) do: [:den |
- | sd sd2 |
- sd := (1/den) asScaledDecimal.
- self assert: sd scale = defaultNumberOfDecimals.
- sd2 := ScaledDecimal readFrom: sd printString.
- self deny: sd = sd2
- ] !
Item was removed:
- ----- Method: ScaledDecimalTest>>testConvertFromFractionWithScale (in category 'tests') -----
- testConvertFromFractionWithScale
-
- | sd |
- sd := (13 / 11) asScaledDecimal: 6.
- self assert: ScaledDecimal == sd class.
- self assert: ('1.181818s6' = sd printString).
- self assert: 6 = sd scale.
- sd := (-13 / 11) asScaledDecimal: 6.
- self assert: ScaledDecimal == sd class.
- self assert: ('-1.181818s6' = sd printString).
- self assert: 6 = sd scale
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testConvertFromInteger (in category 'tests') -----
- testConvertFromInteger
- "Converting an Integer with asScaledDecimal use strictly necessary number of decimal places: 0."
-
- | sd |
- sd := 13 asScaledDecimal.
- self assert: 0 = sd scale.
- self assert: ('13s0' = sd printString).
- sd := -13 asScaledDecimal.
- self assert: 0 = sd scale.
- self assert: ('-13s0' = sd printString).
- sd := 130000000013 asScaledDecimal.
- self assert: 0 = sd scale.
- self assert: ('130000000013s0' = sd printString).
- sd := -130000000013 asScaledDecimal.
- self assert: 0 = sd scale.
- self assert: ('-130000000013s0' = sd printString)
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testConvertFromIntegerWithScale (in category 'tests') -----
- testConvertFromIntegerWithScale
- "Converting an Integer with asScaledDecimal: does now honour the scale passed as message argument."
-
- | sd |
- sd := 13 asScaledDecimal: 6.
- self assert: 6 = sd scale.
- self assert: ('13.000000s6' = sd printString).
- sd := -13 asScaledDecimal: 4.
- self assert: 4 = sd scale.
- self assert: ('-13.0000s4' = sd printString).
- sd := 130000000013 asScaledDecimal: 3.
- self assert: 3 = sd scale.
- self assert: ('130000000013.000s3' = sd printString).
- sd := -130000000013 asScaledDecimal: 1.
- self assert: 1 = sd scale.
- self assert: ('-130000000013.0s1' = sd printString)
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testExactNthRoot (in category 'tests') -----
- testExactNthRoot
- | eight thousandth tenth two |
- eight := 8.0s1.
- two := eight raisedTo: 1/3.
- self assert: two = 2.
- self assert: (two class = eight class and: [two scale = eight scale]).
- thousandth := 0.001s3.
- tenth := thousandth raisedTo: 1/3.
- self assert: tenth * 10 = 1.
- self assert: (tenth class = thousandth class and: [tenth scale = thousandth scale]).!
Item was removed:
- ----- Method: ScaledDecimalTest>>testExactSqrt (in category 'tests') -----
- testExactSqrt
- | four hundredth tenth two |
- four := 4.0s1.
- two := four sqrt.
- self assert: two = 2.
- self assert: (two class = four class and: [two scale = four scale]).
- hundredth := 0.01s2.
- tenth := hundredth sqrt.
- self assert: tenth * 10 = 1.
- self assert: (tenth class = hundredth class and: [tenth scale = hundredth scale]).!
Item was removed:
- ----- Method: ScaledDecimalTest>>testFloorLogExactness (in category 'tests - mathematical functions') -----
- testFloorLogExactness
- 1 + (Float fminDenormalized floorLog: 10) to: (Float fmax floorLog: 10) do: [:n |
- self assert: ((10 raisedTo: n) asScaledDecimal floorLog: 10) = n description: 'floorLog should be exact for ScaledDecimals'.]!
Item was removed:
- ----- Method: ScaledDecimalTest>>testInexactNthRoot (in category 'tests') -----
- testInexactNthRoot
- | tenth cubicRoot3 fifthRootTenth three |
- three := 3.0s1.
- cubicRoot3 := three raisedTo: 1/3.
- self assert: cubicRoot3 isFloat.
- self deny: cubicRoot3 squared = 3.
- tenth := 0.10s2.
- fifthRootTenth := tenth raisedTo: 1/5.
- self assert: fifthRootTenth isFloat.
- self deny: fifthRootTenth squared = tenth!
Item was removed:
- ----- Method: ScaledDecimalTest>>testInexactSqrt (in category 'tests') -----
- testInexactSqrt
- | tenth sqrt3 sqrtTenth three |
- three := 3.0s1.
- sqrt3 := three sqrt.
- self assert: sqrt3 isFloat.
- self deny: sqrt3 squared = 3.
- tenth := 0.10s2.
- sqrtTenth := tenth sqrt.
- self assert: sqrtTenth isFloat.
- self deny: sqrtTenth squared = tenth!
Item was removed:
- ----- Method: ScaledDecimalTest>>testIsLiteral (in category 'tests') -----
- testIsLiteral
- "This test is related to http://bugs.squeak.org/view.php?id=6796"
-
- self assert: 1.00s2 isLiteral description: 'every literal obviously isLiteral'.
-
- "Note that (1 / 3.00s2) is not a well behaved literal,
- because it does not re-evaluate to self...
- Every literal should be evaluated as self (see isSelfEvaluating).
- There is currently no way to print it as a literal.
- So i propose it shall not answer true."
- self deny: (1/3.00s2) isLiteral description: 'this number cannot represent itself as a literal'.!
Item was removed:
- ----- Method: ScaledDecimalTest>>testLiteral (in category 'tests') -----
- testLiteral
-
- | sd |
- sd := 1.40s2.
- self assert: ScaledDecimal == sd class.
- self assert: sd scale = 2.
- self assert: '1.40s2' = sd printString!
Item was removed:
- ----- Method: ScaledDecimalTest>>testLn (in category 'tests - mathematical functions') -----
- testLn
- self assert: (100.0s1 ln closeTo: 10 ln*2).
- self assert: ((2 raisedTo: Float emax + 3) asScaledDecimal ln closeTo: 2 ln*(Float emax + 3)) description: 'ScaledDecimal>>ln should not overflow'!
Item was removed:
- ----- Method: ScaledDecimalTest>>testLog (in category 'tests - mathematical functions') -----
- testLog
- self assert: ((10 raisedTo: 400) asScaledDecimal log closeTo: 400) description: 'log should be immune to intermediate Float overflow'.
- self assert: ((10 raisedTo: -400) asScaledDecimal log closeTo: -400) description: 'log should be immune to intermediate Float underflow'!
Item was removed:
- ----- Method: ScaledDecimalTest>>testOneRaisedToInteger (in category 'tests') -----
- testOneRaisedToInteger
- "One might be handled specially"
-
- self assert: (1.0s1 raisedToInteger: -1) scale = 1.
- self assert: (1.0s1 raisedToInteger: -1) = 1.
- self assert: (1.0s1 raisedToInteger: 0) scale = 1.
- self assert: (1.0s1 raisedToInteger: 0) = 1.
- self assert: (1.0s1 raisedToInteger: 1) scale = 1.
- self assert: (1.0s1 raisedToInteger: 1) = 1.
- self assert: (1.0s1 raisedToInteger: 2) scale = 1.
- self assert: (1.0s1 raisedToInteger: 2) = 1.!
Item was removed:
- ----- Method: ScaledDecimalTest>>testPrintString (in category 'tests') -----
- testPrintString
- "The printed representation of a ScaledDecimal is truncated, not rounded.
- Not sure if this is right, so this test describes the current Squeak implementation.
- If someone knows a reason that rounding would be preferable, then update
- this test."
-
- | sd |
- sd := (13 / 11) asScaledDecimal: 6.
- self assert: ('1.181818s6' = sd printString).
- sd := (13 / 11) asScaledDecimal: 5.
- self deny: ('1.18182s5' = sd printString).
- sd := (13 / 11) asScaledDecimal: 5.
- self assert: ('1.18181s5' = sd printString)
- !
Item was removed:
- ----- Method: ScaledDecimalTest>>testRaisedToInteger (in category 'tests') -----
- testRaisedToInteger
- "Raising to integer should preserve class and scale"
-
- self assert: (3.0s1 raisedToInteger: -1) scale = 1.
- self assert: (3.0s1 raisedToInteger: -1) = (1/3).
- self assert: (3.0s1 raisedToInteger: 0) scale = 1.
- self assert: (3.0s1 raisedToInteger: 0) = 1.
- self assert: (3.0s1 raisedToInteger: 1) scale = 1.
- self assert: (3.0s1 raisedToInteger: 1) = 3.
- self assert: (3.0s1 raisedToInteger: 2) scale = 1.
- self assert: (3.0s1 raisedToInteger: 2) = 9.!
Item was removed:
- ----- Method: ScaledDecimalTest>>testReadFrom (in category 'tests') -----
- testReadFrom
- "This is related to http://bugs.squeak.org/view.php?id=6779"
-
- self should: [(ScaledDecimal readFrom: '5.3') isKindOf: ScaledDecimal]
- description: 'Reading a ScaledDecimal should answer a ScaledDecimal'.
- self should: [((ScaledDecimal readFrom: '5.3') asScaledDecimal: 1) = (53/10 asScaledDecimal: 1)]
- description: 'ScaledDecimal readFrom: should not use Float intermediate because it would introduce round off errors'.!
Item was removed:
- ----- Method: ScaledDecimalTest>>testScaleExtension (in category 'tests') -----
- testScaleExtension
- "The scale is extended to the larger one in case of arithmetic operation"
-
- #( #* #+ #- #/) do: [:op |
- self assert: (2.5s1 perform: op with: 1.000s3) scale = 3.
- self assert: (3.5000s4 perform: op with: 1.0s1) scale = 4.]!
Item was removed:
- ----- Method: ScaledDecimalTest>>testStoreOn (in category 'tests') -----
- testStoreOn
- "this is http://bugs.squeak.org/view.php?id=4378"
-
- "Both results should be 1.
- ScaledDecimal representations are exact
- (though only scale digits or fractional part are printed)"
-
- self assert:
- (Compiler evaluate: (0.5s1 squared storeString)) * 4
- = (0.5s1 squared * 4).
-
-
- "However, exact literals should store literaly
- If not, they would break Decompiler."
-
- "BUG: i cannot write the test like this:
- self assert:
- 0.5s2 squared storeString = '0.25s2'
- BECAUSE compiler would consider 0.5s2 as = 0.5s1 and would reuse same slot..."
-
- self assert:
- 0.25s2 storeString = '0.25s2'!
Item was removed:
- ----- Method: ScaledDecimalTest>>testZeroRaisedToInteger (in category 'tests') -----
- testZeroRaisedToInteger
- "Zero might be handle specially"
-
- self should: [0.0s1 raisedToInteger: -1] raise: Error.
- self assert: (0.0s1 raisedToInteger: 0) = 1.
- self assert: (0.0s1 raisedToInteger: 0) scale = 1.
- self assert: (0.0s1 raisedToInteger: 1) = 0.
- self assert: (0.0s1 raisedToInteger: 1) scale = 1.
- self assert: (0.0s1 raisedToInteger: 2) = 0.
- self assert: (0.0s1 raisedToInteger: 2) scale = 1.!
Item was removed:
- ClassTestCase subclass: #SemaphoreTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
-
- !SemaphoreTest commentStamp: 'tlk 5/5/2006 13:32' prior: 0!
- A SemaphoreTest is sunit test for simple and multiEx semaphores
-
- Instance Variables none; does not have common test fixture accross all tests (because its testing differenct sorts of semaphores (could refactor into muliple testcases if there were more test conditions.
- !
Item was removed:
- ----- Method: SemaphoreTest>>criticalError (in category 'private') -----
- criticalError
- Processor activeProcess terminate!
Item was removed:
- ----- Method: SemaphoreTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testUnwindSemaInCriticalWait)!
Item was removed:
- ----- Method: SemaphoreTest>>testCritical (in category 'tests') -----
- testCritical
- | lock |
- lock := Semaphore forMutualExclusion.
- [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority.
- self assert: lock isSignaled!
Item was removed:
- ----- Method: SemaphoreTest>>testCriticalIfError (in category 'tests') -----
- testCriticalIfError
- | lock |
- lock := Semaphore forMutualExclusion.
- [lock critical: [self criticalError ifError:[]]] forkAt: Processor userInterruptPriority.
- self assert: lock isSignaled!
Item was removed:
- ----- Method: SemaphoreTest>>testSemaAfterCriticalWait (in category 'tests') -----
- testSemaAfterCriticalWait "self run: #testSemaAfterCriticalWait"
- "This tests whether a semaphore that has just left the wait in Semaphore>>critical:
- leaves it with signaling the associated semaphore."
- | s p |
- s := Semaphore new.
- p := [s critical:[]] forkAt: Processor activePriority-1.
- "wait until p entered the critical section"
- [p suspendingList == s] whileFalse:[(Delay forMilliseconds: 10) wait].
- "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
- but since we are running at higher priority than p it will not get to do
- anything."
- s signal.
- p terminate.
- self assert: 1 equals: s excessSignals!
Item was removed:
- ----- Method: SemaphoreTest>>testSemaAfterCriticalWaitSuspended (in category 'tests') -----
- testSemaAfterCriticalWaitSuspended "self run: #testSemaAfterCriticalWaitSuspended"
- "This tests whether a semaphore that has just left the wait in Semaphore>>critical: but
- has been suspended before termination, leaves it with signaling the associated semaphore."
- | s p |
- s := Semaphore new.
- p := [s critical:[]] forkAt: Processor activePriority-1.
- "wait until p entered the critical section"
- [p suspendingList == s] whileFalse:[(Delay forMilliseconds: 10) wait].
- "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
- but since we are running at higher priority than p it will not get to do
- anything."
- s signal.
- self assert: p suspendingList class == LinkedList.
- p suspend.
- self assert: p suspendingList == nil.
- p terminate.
- self assert: 1 equals: s excessSignals!
Item was removed:
- ----- Method: SemaphoreTest>>testSemaCriticalBlockedInEnsure (in category 'tests') -----
- testSemaCriticalBlockedInEnsure "self run: #testSemaCriticalBlockedInEnsure"
- "This tests whether a semaphore that is in ensure: but has yet to evaluate the valueNoContextSwitch
- leaves it with signaling the associated semaphore."
- | decompilation needSignalToEnterEnsure s p |
- "Distinguish between e.g.
- critical: t1 <criticalSection> ^[self wait. t1 value] ensure: [self signal]
- and
- critical: t1 <criticalSection> self wait. ^t1 ensure: [self signal]"
- decompilation := (Semaphore>>#critical:) decompileString.
- needSignalToEnterEnsure := (decompilation indexOfSubCollection: #wait) < (decompilation indexOf: $[).
- s := Semaphore new.
- needSignalToEnterEnsure ifTrue: [s signal].
- p := [s critical: []] newProcess.
- p priority: Processor activePriority - 1.
- "step until in critical:"
- [p suspendedContext selector == #critical:] whileFalse: [p step].
- "step until in ensure: (can't do this until in critical: cuz ensure: may be in newProcess etc...)"
- [p suspendedContext selector == #ensure:] whileFalse: [p step].
- "Now check that if we needed a signal to enter ensure: it has been consumed."
- self assert: 0 equals: s excessSignals.
- "Now that p is at the right point, resume the process and immediately terminate it."
- p resume; terminate.
- self assert: (needSignalToEnterEnsure ifTrue: [1] ifFalse: [0]) equals: s excessSignals!
Item was removed:
- ----- Method: SemaphoreTest>>testSemaInCriticalEnsureArgument (in category 'tests') -----
- testSemaInCriticalEnsureArgument "self run: #testSemaInCriticalEnsureArgument"
- "This tests whether a process that is in ensure argument block but has yet to evaluate the signal
- leaves it with signaling the associated semaphore."
-
- | terminatee sema |
- sema := Semaphore forMutualExclusion.
- terminatee := [sema critical: []] newProcess.
- self assert: terminatee isSuspended.
- terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #signal].
- self assert: terminatee isSuspended.
- terminatee terminate.
- self assert: terminatee isTerminated.
- self assert: sema excessSignals = 1 !
Item was removed:
- ----- Method: SemaphoreTest>>testSemaInCriticalWait (in category 'tests') -----
- testSemaInCriticalWait "self run: #testSemaInCriticalWait"
- "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
- leaves it without signaling the associated semaphore."
- | s p |
- s := Semaphore new.
- p := [s critical:[]] fork.
- Processor yield.
- self assert:(p suspendingList == s).
- p terminate.
- self assert: 0 equals: s excessSignals!
Item was removed:
- ----- Method: SemaphoreTest>>testUnwindSemaInCriticalWait (in category 'tests') -----
- testUnwindSemaInCriticalWait "self run: #testSemaInCriticalWait"
- "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
- leaves it without signaling the associated semaphore."
- | s p |
- s := Semaphore new.
- p := [[] ensure: [s critical:[]]] fork.
- Processor yield.
- self assert:(p suspendingList == s).
- p terminate.
- self assert: 0 equals: s excessSignals!
Item was removed:
- ----- Method: SemaphoreTest>>testWaitAndWaitTimeoutTogether (in category 'tests') -----
- testWaitAndWaitTimeoutTogether
- | semaphore value waitProcess waitTimeoutProcess |
- semaphore := Semaphore new.
-
- waitProcess := [semaphore wait. value := #wait] fork.
-
- waitTimeoutProcess := [semaphore waitTimeoutMSecs: 50. value := #waitTimeout] fork.
-
- "Wait for the timeout to happen"
- (Delay forMilliseconds: 100) wait.
-
- "The waitTimeoutProcess should already have timed out. This should release the waitProcess"
- semaphore signal.
-
- [waitProcess isTerminated and: [waitTimeoutProcess isTerminated]]
- whileFalse: [(Delay forMilliseconds: 100) wait].
-
- self assert: value = #wait.
- !
Item was removed:
- ----- Method: SemaphoreTest>>testWaitTimeoutMSecs (in category 'tests') -----
- testWaitTimeoutMSecs
- "Ensure that waitTimeoutMSecs behaves properly"
-
- "Ensure that a timed out waitTimeoutMSecs: returns true from the wait"
- self assert: (Semaphore new waitTimeoutMSecs: 50) == true.
-
- "Ensure that a signaled waitTimeoutMSecs: returns false from the wait"
- self assert: (Semaphore new signal waitTimeoutMSecs: 50) == false.
- !
Item was removed:
- ClassTestCase subclass: #SmallIntegerTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
-
- !SmallIntegerTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0!
- I provide a test suite for SmallInteger values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!
Item was removed:
- ----- Method: SmallIntegerTest>>testBasicNew (in category 'tests - Class Methods') -----
- testBasicNew
-
- self shouldRaiseError: [SmallInteger basicNew].!
Item was removed:
- ----- Method: SmallIntegerTest>>testDecimalDigitLength (in category 'tests - printing') -----
- testDecimalDigitLength
-
- | x length random |
- "Test edge cases"
- x := 1.
- length := 1.
- [ x <= SmallInteger maxVal ] whileTrue: [
- self
- assert: length equals: x decimalDigitLength;
- assert: (length - 1 max: 1) equals: (x - 1) decimalDigitLength.
- x := x * 10.
- length := length + 1 ].
- "A few values by hand"
- #(
- 0 1
- 4 1
- 12 2
- 123 3
- 1234 4
- 56789 5
- 657483 6
- 6571483 7
- 65174383 8
- 625744831 9
- 1000001111 10
- ), {
- SmallInteger maxVal. Smalltalk wordSize = 8 ifTrue: [ 19 ] ifFalse: [ 10 ]
- } groupsDo: [ :input :expectedOutput |
- self assert: expectedOutput equals: input decimalDigitLength ].
- "Pseudorandom tests."
- random := Random seed: 36rSqueak.
- 10000 timesRepeat: [
- x := SmallInteger maxVal atRandom: random.
- self assert: x asString size equals: x decimalDigitLength ]!
Item was removed:
- ----- Method: SmallIntegerTest>>testDivide (in category 'tests - arithmetic') -----
- testDivide
-
- self assert: 2 / 1 = 2.
- self assert: (3 / 2) isFraction.
- self assert: 4 / 2 = 2.
- self should: [ 1 / 0 ] raise: ZeroDivide.!
Item was removed:
- ----- Method: SmallIntegerTest>>testDivideMayOverflow (in category 'tests - arithmetic') -----
- testDivideMayOverflow
- "Dividing a SmallInteger by another Integer may answer a Large Integer.
- These cases have caused several VM bugs in the past, it's better to keep some assrtion around."
-
- self assert: (SmallInteger minVal / -1) isLarge.
- self assert: (SmallInteger minVal / -1) = (SmallInteger maxVal + 1).
-
- self assert: (SmallInteger minVal quo: -1) isLarge.
- self assert: (SmallInteger minVal quo: -1) = (SmallInteger maxVal + 1).
-
- self assert: (SmallInteger minVal // -1) isLarge.
- self assert: (SmallInteger minVal // -1) = (SmallInteger maxVal + 1).!
Item was removed:
- ----- Method: SmallIntegerTest>>testEven (in category 'tests - basic') -----
- testEven
-
- self assert: (SmallInteger minVal even).
- self deny: (SmallInteger maxVal even).
-
- self deny: ((SmallInteger minVal + 1) even).
- self assert: ((SmallInteger maxVal - 1) even).
-
- self deny: (1 even).
- self deny: (-1 even).
-
- self assert: (2 even).
- self assert: (-2 even).
-
- self assert: (0 even).!
Item was removed:
- ----- Method: SmallIntegerTest>>testMaxVal (in category 'tests - Class Methods') -----
- testMaxVal
-
- self assert: (SmallInteger maxVal = 16r3FFFFFFF or: [SmallInteger maxVal = 16rFFFFFFFFFFFFFFF]).!
Item was removed:
- ----- Method: SmallIntegerTest>>testMinVal (in category 'tests - Class Methods') -----
- testMinVal
-
- self assert: (SmallInteger minVal = -16r40000000 or: [SmallInteger minVal = -16r1000000000000000]).!
Item was removed:
- ----- Method: SmallIntegerTest>>testNew (in category 'tests - Class Methods') -----
- testNew
-
- self shouldRaiseError: [SmallInteger new].!
Item was removed:
- ----- Method: SmallIntegerTest>>testOdd (in category 'tests - basic') -----
- testOdd
-
- self deny: (SmallInteger minVal odd).
- self assert: (SmallInteger maxVal odd).
-
- self assert: ((SmallInteger minVal + 1) odd).
- self deny: ((SmallInteger maxVal - 1) odd).
-
- self assert: (1 odd).
- self assert: (-1 odd).
-
- self deny: (2 odd).
- self deny: (-2 odd).
-
- self deny: (0 odd).!
Item was removed:
- ----- Method: SmallIntegerTest>>testPrintPaddedWith (in category 'tests - printing') -----
- testPrintPaddedWith
-
- self assert: (123 printPaddedWith: $0 to: 10 base: 2) = '0001111011'.
- self assert: (123 printPaddedWith: $0 to: 10 base: 8) = '0000000173'.
- self assert: (123 printPaddedWith: $0 to: 10 base: 10) = '0000000123'.
- self assert: (123 printPaddedWith: $0 to: 10 base: 16) = '000000007B'.!
Item was removed:
- ----- Method: SmallIntegerTest>>testPrintString (in category 'tests - printing') -----
- testPrintString
-
- self assert: 1 printString = '1'.
- self assert: -1 printString = '-1'.
- self assert: SmallInteger minVal printString = (Smalltalk wordSize = 8 ifTrue: [ '-1152921504606846976'] ifFalse: ['-1073741824']).
- self assert: SmallInteger maxVal printString = (Smalltalk wordSize = 8 ifTrue: [ '1152921504606846975'] ifFalse: ['1073741823']).
- self assert: 12345 printString = '12345'.
- self assert: -54321 printString = '-54321'!
Item was removed:
- ClassTestCase subclass: #SqNumberParserTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Numbers'!
-
- !SqNumberParserTest commentStamp: 'nice 5/7/2006 17:54' prior: 0!
- Provide tests for new clas aimed at parsing numbers.
-
- It duplicates NumberParsingTest, with few more tests.!
Item was removed:
- ----- Method: SqNumberParserTest>>areLowercaseDigitsAllowed (in category 'utility') -----
- areLowercaseDigitsAllowed
- "Answer true if lowercase letter are allowed digits."
-
- ^(SqNumberParser parse: '16re' onError: [-1]) = 16rE!
Item was removed:
- ----- Method: SqNumberParserTest>>testBases (in category 'tests - fail') -----
- testBases
-
- self assert: (SqNumberParser parse: '16r20') equals: 32.
- self assert: (SqNumberParser parse: '2r10') equals: 2.
- self assert: ((SqNumberParser on: '10')
- nextIntegerBase: 2) equals: 2.
- self assert: ((SqNumberParser on: '10')
- defaultBase: 2;
- nextNumber) equals: 2.
- self assert: ((SqNumberParser on: '1000r10')
- defaultBase: 2;
- nextNumber) equals: 8.!
Item was removed:
- ----- Method: SqNumberParserTest>>testFail (in category 'tests - fail') -----
- testFail
- "Verify that the value of a failblock is returned."
- self assert: (SqNumberParser parse: 'blablabla' onError: [42]) equals: 42!
Item was removed:
- ----- Method: SqNumberParserTest>>testFloatFromStreamAsNumber (in category 'tests - Float') -----
- testFloatFromStreamAsNumber
- "This covers parsing in Number>>readFrom:"
-
- | rs aFloat |
- rs := '10r-12.3456' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: -12.3456 = aFloat.
- self assert: rs atEnd.
-
- rs := '10r-12.3456e2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '10r-12.3456e2e2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs upToEnd = 'e2'.
-
- rs := '10r-12.3456d2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '10r-12.3456q2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '-12.3456q2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: -1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '12.3456q2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 1234.56 = aFloat.
- self assert: rs atEnd.
-
- rs := '12.3456z2' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 12.3456 = aFloat.
- self assert: rs upToEnd = 'z2'.
- !
Item was removed:
- ----- Method: SqNumberParserTest>>testFloatFromStreamWithExponent (in category 'tests - Float') -----
- testFloatFromStreamWithExponent
- "This covers parsing in Number>>readFrom:"
-
- | rs aFloat |
- rs := '1.0e-14' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 1.0e-14 = aFloat.
- self assert: rs atEnd.
-
- rs := '1.0e-14 1' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 1.0e-14 = aFloat.
- self assert: rs upToEnd = ' 1'.
-
- rs := '1.0e-14eee' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 1.0e-14 = aFloat.
- self assert: rs upToEnd = 'eee'.
-
- rs := '1.0e14e10' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 1.0e14 = aFloat.
- self assert: rs upToEnd = 'e10'.
-
- rs := '1.0e+14e' readStream. "Plus sign is not parseable"
- aFloat := SqNumberParser parse: rs.
- self assert: 1.0 = aFloat.
- self assert: rs upToEnd = 'e+14e'.
-
- rs := '1.0e' readStream.
- aFloat := SqNumberParser parse: rs.
- self assert: 1.0 = aFloat.
- self assert: rs upToEnd = 'e'.!
Item was removed:
- ----- Method: SqNumberParserTest>>testFloatGradualUnderflow (in category 'tests - Float') -----
- testFloatGradualUnderflow
- "Gradual underflow are tricky.
- This is a non regression test for http://bugs.squeak.org/view.php?id=6976"
-
- | float trueFraction str |
-
- "as a preamble, use a base 16 representation to avoid round off error and check that number parsing is correct"
- trueFraction := 16r2D2593D58B4FC4 / (16 raisedTo: 256+13).
- "Parse the number in base 16 if possible - it is impossible if lowercase letter are allowed digits due to exponent letter ambiguity."
- float := self areLowercaseDigitsAllowed
- ifFalse: [SqNumberParser parse: '16r2.D2593D58B4FC4e-256']
- ifTrue: [trueFraction asFloat]..
- self assert: float asTrueFraction = trueFraction.
- self assert: float = trueFraction asFloat.
-
- "now print in base 10"
- str := (String new: 32) writeStream.
- float printOn: str base: 10.
-
- "verify if SqNumberParser can read it back"
- self assert: (SqNumberParser parse: str contents) = float. !
Item was removed:
- ----- Method: SqNumberParserTest>>testFloatPrintString (in category 'tests - Float') -----
- testFloatPrintString
- "self debug: #testFloatPrintString"
-
- | f r bases |
- f := Float basicNew: 2.
- r := Random new seed: 1234567.
- "printing a Float in base other than 10 is broken if lowercase digits are allowed"
- bases := self areLowercaseDigitsAllowed
- ifTrue: [#(10)]
- ifFalse: [#(2 8 10 16)].
- 100
- timesRepeat: [f basicAt: 1 put: (r nextInt: 16r100000000)- 1.
- f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
- bases
- do: [:base | | str |
- str := (String new: 64) writeStream.
- f negative ifTrue: [str nextPut: $-].
- str print: base; nextPut: $r.
- f abs printOn: str base: base.
- self assert: (SqNumberParser parse: str contents) = f]].
- "test big num near infinity"
- 10
- timesRepeat: [f basicAt: 1 put: 16r7FE00000 + ((r nextInt: 16r100000) - 1).
- f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
- bases
- do: [:base | | str |
- str := (String new: 64) writeStream.
- f negative ifTrue: [str nextPut: $-].
- str print: base; nextPut: $r.
- f abs printOn: str base: base.
- self assert: (SqNumberParser parse: str contents) = f]].
- "test infinitesimal (gradual underflow)"
- 10
- timesRepeat: [f basicAt: 1 put: 0 + ((r nextInt: 16r100000) - 1).
- f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
- bases
- do: [:base | | str |
- str := (String new: 64) writeStream.
- f negative ifTrue: [str nextPut: $-].
- str print: base; nextPut: $r.
- f abs printOn: str base: base.
- self assert: (SqNumberParser parse: str contents) = f]].!
Item was removed:
- ----- Method: SqNumberParserTest>>testFloatReadError (in category 'tests - Float') -----
- testFloatReadError
- "This covers parsing in Number>>readFrom:"
-
- | rs num |
- rs := '1e' readStream.
- num := SqNumberParser parse: rs.
- self assert: 1 = num.
- self assert: rs upToEnd = 'e'.
-
- rs := '1.' readStream.
- num := SqNumberParser parse: rs.
- self assert: 1 = num.
- self assert: num isInteger.
- self assert: rs upToEnd = '.'.
-
- rs := '' readStream.
- self should: [SqNumberParser parse: rs] raise: Error.
-
- rs := 'foo' readStream.
- self should: [SqNumberParser parse: rs] raise: Error.
-
- rs := 'radix' readStream.
- self should: [SqNumberParser parse: rs] raise: Error.
-
- rs := '.e0' readStream.
- self should: [SqNumberParser parse: rs] raise: Error.
-
- rs := '-.e0' readStream.
- self should: [SqNumberParser parse: rs] raise: Error.
-
- rs := '--1' readStream.
- self should: [SqNumberParser parse: rs] raise: Error.!
Item was removed:
- ----- Method: SqNumberParserTest>>testFloatReadWithRadix (in category 'tests - Float') -----
- testFloatReadWithRadix
- "This covers parsing in Number>>readFrom:
- Note: In most Smalltalk dialects, the radix notation is not used for numbers
- with exponents. In Squeak, a string with radix and exponent can be parsed,
- and the exponent is always treated as base 10 (not the base indicated in the
- radix prefix). I am not sure if this is a feature, a bug, or both, but the
- Squeak behavior is documented in this test. -dtl"
-
- | aNumber rs |
- aNumber := '2r1.0101e9' asNumber.
- self assert: 672.0 = aNumber.
- self assert: (SqNumberParser parse: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)).
- rs := ReadStream on: '2r1.0101e9e9'.
- self assert: (SqNumberParser parse: rs) = 672.0.
- self assert: rs upToEnd = 'e9'
- !
Item was removed:
- ----- Method: SqNumberParserTest>>testIntegerReadFrom (in category 'tests - Integer') -----
- testIntegerReadFrom
- "Ensure remaining characters in a stream are not lost when parsing an integer."
-
- | rs i s |
- rs := ReadStream on: '123.s could be confused with a ScaledDecimal'.
- i := SqNumberParser parse: rs.
- self assert: (i isInteger and: [ i = 123 ]).
- s := rs upToEnd.
- self assert: '.s could be confused with a ScaledDecimal' = s
- !
Item was removed:
- ----- Method: SqNumberParserTest>>testIntegerReadWithRadix (in category 'tests - Integer') -----
- testIntegerReadWithRadix
- "This covers parsing in Number>>readFrom:
- Note: In most Smalltalk dialects, the radix notation is not used for numbers
- with exponents. In Squeak, a string with radix and exponent can be parsed,
- and the exponent is always treated as base 10 (not the base indicated in the
- radix prefix). I am not sure if this is a feature, a bug, or both, but the
- Squeak behavior is documented in this test. -dtl"
-
- | aNumber rs |
- aNumber := '2r1e26' asNumber.
- self assert: 67108864 = aNumber.
- self assert: (SqNumberParser parse: '2r1e26') = (2 raisedTo: 26).
- rs := '2r1e26eee' readStream.
- self assert: (SqNumberParser parse: rs) = 67108864.
- self assert: rs upToEnd = 'eee'
- !
Item was removed:
- ----- Method: SqNumberParserTest>>testScaledDecimalWithImplicitScale (in category 'tests - ScaledDecimal') -----
- testScaledDecimalWithImplicitScale
- "Implicit scale is automatically adjusted to the number of fractional digits specified"
-
- #(
- ('123s' 123s0)
- ('0.5s' 0.5s1)
- ('1.60s' 1.60s2)
- ('23.070s' 23.070s3)
- ) do: [:each |
- [:string :scaledDecimal |
- | value |
- value := SqNumberParser parse: string readStream.
- self assert: value = scaledDecimal.
- self assert: value class = scaledDecimal class.
- self assert: value scale = scaledDecimal scale] valueWithArguments: each]!
Item was removed:
- ----- Method: SqNumberParserTest>>testScaledDecimalWithTrailingZeroes (in category 'tests - ScaledDecimal') -----
- testScaledDecimalWithTrailingZeroes
- "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169"
-
- self assert: (SqNumberParser parse: '0.50s2') = (1/2).
- self assert: (SqNumberParser parse: '0.500s3') = (1/2).
- self assert: (SqNumberParser parse: '0.050s3') = (1/20).!
Item was removed:
- ClassForBehaviorTest subclass: #SubClassForBehaviorTest
- instanceVariableNames: 'iv3'
- classVariableNames: 'CV3'
- poolDictionaries: ''
- category: 'KernelTests-Classes'!
Item was removed:
- ----- Method: SubClassForBehaviorTest class>>install (in category 'accessing') -----
- install
- civ1 := true!
Item was removed:
- ----- Method: SubClassForBehaviorTest>>iv2: (in category 'accessing') -----
- iv2: anyObject
- iv2 := anyObject printString!
Item was removed:
- ----- Method: SubClassForBehaviorTest>>resetIV1 (in category 'accessing') -----
- resetIV1
- iv1 := nil!
Item was removed:
- DynamicVariable subclass: #TestDynamicVariable
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
- TestDynamicVariable class
- instanceVariableNames: 'defaultValue'!
-
- !TestDynamicVariable commentStamp: 'mvl 3/13/2007 13:51' prior: 0!
- TestDynamicVariable is a test class using in ProcessSpecificTest.
-
- !
- TestDynamicVariable class
- instanceVariableNames: 'defaultValue'!
Item was removed:
- ----- Method: TestDynamicVariable class>>default (in category 'accessing') -----
- default
-
- ^ defaultValue!
Item was removed:
- ----- Method: TestDynamicVariable class>>default: (in category 'accessing') -----
- default: anObject
-
- defaultValue := anObject.!
Item was removed:
- nil subclass: #TestEmptyClass
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
-
- !TestEmptyClass commentStamp: 'ct 11/25/2021 11:49' prior: 0!
- I do not even understand #doesNotUnderstand:!! Sending any non-inlined message to me should crash the executor.!
Item was removed:
- ProcessLocalVariable subclass: #TestLocalVariable
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Processes'!
-
- !TestLocalVariable commentStamp: 'mvl 3/13/2007 13:52' prior: 0!
- TestLocalVariable is a test class using in ProcessSpecificTest.!
Item was removed:
- ----- Method: TestLocalVariable class>>default (in category 'as yet unclassified') -----
- default
- "My default value for a new process is 0."
-
- ^0!
Item was removed:
- ProtoObject subclass: #TestObjectForMethod
- instanceVariableNames: 'method'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Methods'!
Item was removed:
- ----- Method: TestObjectForMethod>>doesNotUnderstand: (in category 'dynamic forwarding') -----
- doesNotUnderstand: aMessage
-
- ^ aMessage sendTo: method!
Item was removed:
- ----- Method: TestObjectForMethod>>flushCache (in category 'compatibility') -----
- flushCache!
Item was removed:
- ----- Method: TestObjectForMethod>>methodClass: (in category 'compatibility') -----
- methodClass: aMethodClass!
Item was removed:
- ----- Method: TestObjectForMethod>>run:with:in: (in category 'evaluating') -----
- run: oldSelector with: arguments in: receiver
- ^ {oldSelector. arguments. receiver}!
Item was removed:
- ----- Method: TestObjectForMethod>>selector: (in category 'compatibility') -----
- selector: aSymbol!
Item was removed:
- ----- Method: TestObjectForMethod>>xxxMethod: (in category 'accessing') -----
- xxxMethod: aCompiledMethod
-
- method := aCompiledMethod!
Item was removed:
- ClassTestCase subclass: #TrueTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
Item was removed:
- ----- Method: TrueTest>>testAND (in category 'tests') -----
- testAND
-
- self assert: (true & true) = true.
- self assert: (true & false) = false.!
Item was removed:
- ----- Method: TrueTest>>testAnd (in category 'tests') -----
- testAnd
-
- self assert: (true and: ['alternativeBlock']) = 'alternativeBlock'.!
Item was removed:
- ----- Method: TrueTest>>testAsBit (in category 'tests') -----
- testAsBit
-
- self assert: (true asBit = 1).!
Item was removed:
- ----- Method: TrueTest>>testIfFalse (in category 'tests') -----
- testIfFalse
-
- self assert: (true ifFalse: ['alternativeBlock']) = nil. !
Item was removed:
- ----- Method: TrueTest>>testIfFalseIfTrue (in category 'tests') -----
- testIfFalseIfTrue
-
- self assert: (true ifFalse: ['falseAlternativeBlock']
- ifTrue: ['trueAlternativeBlock']) = 'trueAlternativeBlock'. !
Item was removed:
- ----- Method: TrueTest>>testIfTrue (in category 'tests') -----
- testIfTrue
-
- self assert: (true ifTrue: ['alternativeBlock']) = 'alternativeBlock'. !
Item was removed:
- ----- Method: TrueTest>>testIfTrueIfFalse (in category 'tests') -----
- testIfTrueIfFalse
-
- self assert: (true ifTrue: ['trueAlternativeBlock']
- ifFalse: ['falseAlternativeBlock']) = 'trueAlternativeBlock'. !
Item was removed:
- ----- Method: TrueTest>>testInMemory (in category 'tests') -----
- testInMemory
-
- self assert: (true isInMemory = true).!
Item was removed:
- ----- Method: TrueTest>>testNew (in category 'tests') -----
- testNew
-
- self should: [True new] raise: Error. !
Item was removed:
- ----- Method: TrueTest>>testNot (in category 'tests') -----
- testNot
-
- self assert: (true not = false).!
Item was removed:
- ----- Method: TrueTest>>testOR (in category 'tests') -----
- testOR
-
- self assert: (true | true) = true.
- self assert: (true | false) = true.!
Item was removed:
- ----- Method: TrueTest>>testOr (in category 'tests') -----
- testOr
-
- self assert: (true or: ['alternativeBlock']) = true.!
Item was removed:
- ----- Method: TrueTest>>testPrintOn (in category 'tests') -----
- testPrintOn
-
- self assert: (String streamContents: [:stream | true printOn: stream]) = 'true'. !
Item was removed:
- ----- Method: TrueTest>>testXor (in category 'tests') -----
- testXor
- self assert: (true xor: true) = false.
- self assert: (true xor: false) = true.
- self assert: (true xor: [true]) = false.
- self assert: (true xor: [false]) = true.
- "Verify that boolean with non-boolean raise errors."
- self should: [true xor: [1]] raise: Error.
- self should: [true xor: 1] raise: Error.!
Item was removed:
- ClassTestCase subclass: #UndefinedObjectTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
-
- !UndefinedObjectTest commentStamp: '<historical>' prior: 0!
- This is the unit test for the class UndefinedObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
- - http://www.c2.com/cgi/wiki?UnitTest
- - http://minnow.cc.gatech.edu/squeak/1547
- - the sunit class category!
Item was removed:
- ----- Method: UndefinedObjectTest>>testAllInstances (in category 'tests - Class Methods') -----
- testAllInstances
- self assert: UndefinedObject allInstances size = 1 description: 'There should be a single instance of UndefinedObject'.
- self assert: (UndefinedObject allInstances includes: nil) description: 'nil should be an instance of UndefinedObject'.!
Item was removed:
- ----- Method: UndefinedObjectTest>>testDeepCopy (in category 'tests - copying') -----
- testDeepCopy
-
- self assert: (nil deepCopy = nil).!
Item was removed:
- ----- Method: UndefinedObjectTest>>testHaltIfNil (in category 'tests - testing') -----
- testHaltIfNil
-
- self should: [ nil haltIfNil] raise: Halt.!
Item was removed:
- ----- Method: UndefinedObjectTest>>testIfNil (in category 'tests - testing') -----
- testIfNil
-
- | object block |
- object := Object new.
- self should: [ nil ifNil: [ self halt ] ] raise: Halt.
- self assert: (nil ifNil: [ object ]) == object.
- "Now the same without inlining."
- block := [ self halt ].
- self should: [ nil ifNil: block ] raise: Halt.
- block := [ object ].
- self assert: (nil ifNil: block) == object.
-
-
-
- !
Item was removed:
- ----- Method: UndefinedObjectTest>>testIfNilIfNotNil (in category 'tests - testing') -----
- testIfNilIfNotNil
-
- | object block |
- object := Object new.
- self should: [ nil ifNil: [self halt] ifNotNil: [ self error] ] raise: Halt.
- self should: [ nil ifNil: [ self halt ] ifNotNil: [ :o | self error ] ] raise: Halt.
- self assert: (nil ifNil: [ object ] ifNotNil: [ 1 ]) == object.
- self assert: (nil ifNil: [ object ] ifNotNil: [ :o | 1 ]) == object.
- "Now the same without inlining."
- block := [ self halt ].
- self should: [ nil ifNil: block ifNotNil: [ self error ] ] raise: Halt.
- self should: [ nil ifNil: block ifNotNil: [ :o | self error ] ] raise: Halt.
- block := [ object ].
- self assert: (nil ifNil: block ifNotNil: [ 1 ]) == object.
- self assert: (nil ifNil: block ifNotNil: [ :o | 1 ]) == object!
Item was removed:
- ----- Method: UndefinedObjectTest>>testIfNotNil (in category 'tests - testing') -----
- testIfNotNil
-
- | block |
- self shouldnt: [ nil ifNotNil: [ self halt ] ] raise: Halt.
- self shouldnt: [ nil ifNotNil: [ :object | self halt ] ] raise: Halt.
- self assert: (nil ifNotNil: [ 1 ]) == nil.
- self assert: (nil ifNotNil: [ :o | 1 ]) == nil.
- "Now the same without inlining."
- block := [ self halt ].
- self shouldnt: [ nil ifNotNil: block ] raise: Halt.
- block := [ :object | self halt ].
- self shouldnt: [ nil ifNotNil: block ] raise: Halt.
- block := [ 1 ].
- self assert: (nil ifNotNil: block) == nil.
- block := [ :o | 1 ].
- self assert: (nil ifNotNil: block) == nil.
-
-
- !
Item was removed:
- ----- Method: UndefinedObjectTest>>testIfNotNilIfNil (in category 'tests - testing') -----
- testIfNotNilIfNil
-
- | object block |
- object := Object new.
- self should: [ nil ifNotNil: [ self error ] ifNil: [ self halt ] ] raise: Halt.
- self should: [ nil ifNotNil: [ :o | self error] ifNil: [ self halt ] ] raise: Halt.
- self assert: (nil ifNotNil: [ 1 ] ifNil: [ object ]) == object.
- self assert: (nil ifNotNil: [ :o | 1 ] ifNil: [ object ]) == object.
- "Now the same without inlining."
- block := [ self error ].
- self should: [ nil ifNotNil: block ifNil: [ self halt ] ] raise: Halt.
- block := [ :o | self error].
- self should: [ nil ifNotNil: block ifNil: [ self halt ] ] raise: Halt.
- block := [ 1 ].
- self assert: (nil ifNotNil: block ifNil: [ object ]) == object.
- block := [ :o | 1 ].
- self assert: (nil ifNotNil: block ifNil: [ object ]) == object!
Item was removed:
- ----- Method: UndefinedObjectTest>>testInitializedInstance (in category 'tests - Class Methods') -----
- testInitializedInstance
-
- self assert: ( UndefinedObject initializedInstance class == UndefinedObject).!
Item was removed:
- ----- Method: UndefinedObjectTest>>testIsEmptyOrNil (in category 'tests - testing') -----
- testIsEmptyOrNil
-
- self assert: (nil isEmptyOrNil).!
Item was removed:
- ----- Method: UndefinedObjectTest>>testIsLiteral (in category 'tests - testing') -----
- testIsLiteral
-
- self assert: (nil isLiteral).!
Item was removed:
- ----- Method: UndefinedObjectTest>>testIsNil (in category 'tests - testing') -----
- testIsNil
-
- self assert: nil isNil!
Item was removed:
- ----- Method: UndefinedObjectTest>>testNew (in category 'tests - Class Methods') -----
- testNew
-
- self should: [ UndefinedObject new] raise: Error.!
Item was removed:
- ----- Method: UndefinedObjectTest>>testNotNil (in category 'tests - testing') -----
- testNotNil
-
- self deny: nil notNil!
Item was removed:
- ----- Method: UndefinedObjectTest>>testPrintOn (in category 'tests - printing') -----
- testPrintOn
-
- | string |
- string := String streamContents: [:stream | nil printOn: stream].
- self assert: (string = 'nil').!
Item was removed:
- ----- Method: UndefinedObjectTest>>testShallowCopy (in category 'tests - copying') -----
- testShallowCopy
-
- self assert: (nil shallowCopy = nil).!
Item was removed:
- ----- Method: UndefinedObjectTest>>testStoreOn (in category 'tests - printing') -----
- testStoreOn
-
- | string |
- string := String streamContents: [:stream | nil storeOn: stream].
- self assert: ((Compiler evaluate: string) = nil).!
Item was removed:
- ----- Method: UndefinedObjectTest>>testVeryDeepCopyWith (in category 'tests - copying') -----
- testVeryDeepCopyWith
-
- self assert: ((nil veryDeepCopyWith: nil) = nil).!
Item was removed:
- ClassTestCase subclass: #WeakMessageSendTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-Objects'!
Item was removed:
- ----- Method: WeakMessageSendTest>>testNoArguments (in category 'tests') -----
- testNoArguments
- "self run: #testNoArguments"
-
- | m |
- m := WeakMessageSend
- receiver: true
- selector: #yourself.
- self assert: (m value).
- !
Item was removed:
- ----- Method: WeakMessageSendTest>>testOneArgument (in category 'tests') -----
- testOneArgument
- "self run: #testOneArgument"
-
- | m |
- m := WeakMessageSend
- receiver: Array
- selector: #with:
- argument: 1.
- Smalltalk garbageCollectMost.
- self assert: (m value = { 1 })
- !
Item was removed:
- ----- Method: WeakMessageSendTest>>testOneArgumentWithGC (in category 'tests') -----
- testOneArgumentWithGC
-
- | m |
- m := WeakMessageSend
- receiver: Array
- selector: #with:
- arguments: { Object new }.
- Smalltalk garbageCollectMost.
- self assert: (m value isNil)!
Item was removed:
- ----- Method: WeakMessageSendTest>>testReceiverWithGC (in category 'tests') -----
- testReceiverWithGC
-
- | m |
- m := WeakMessageSend
- receiver: Object new
- selector: #isNil.
- Smalltalk garbageCollectMost.
- self assert: (m value isNil).!
Item was removed:
- ----- Method: WeakMessageSendTest>>testTwoArguments (in category 'tests') -----
- testTwoArguments
-
- | m |
- m := WeakMessageSend
- receiver: Array
- selector: #with:with:
- arguments: { 1 . 2 }.
- Smalltalk garbageCollectMost.
- self assert: (m value = { 1 . 2 }).
- !
Item was removed:
- Object subclass: #WriteBarrierAnotherStub
- instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-WriteBarrier'!
Item was removed:
- ----- Method: WriteBarrierAnotherStub>>var1 (in category 'accessing') -----
- var1
- ^ var1!
Item was removed:
- ----- Method: WriteBarrierAnotherStub>>var10 (in category 'accessing') -----
- var10
- ^ var10!
Item was removed:
- ----- Method: WriteBarrierAnotherStub>>var10: (in category 'accessing') -----
- var10: anObject
- var10 := anObject!
Item was removed:
- ----- Method: WriteBarrierAnotherStub>>var1: (in category 'accessing') -----
- var1: anObject
- var1 := anObject!
Item was removed:
- Object subclass: #WriteBarrierStub
- instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'KernelTests-WriteBarrier'!
Item was removed:
- ----- Method: WriteBarrierStub>>var1 (in category 'accessing') -----
- var1
- ^ var1!
Item was removed:
- ----- Method: WriteBarrierStub>>var10 (in category 'accessing') -----
- var10
- ^ var10!
Item was removed:
- ----- Method: WriteBarrierStub>>var10: (in category 'accessing') -----
- var10: anObject
- var10 := anObject!
Item was removed:
- ----- Method: WriteBarrierStub>>var1: (in category 'accessing') -----
- var1: anObject
- var1 := anObject!
Item was removed:
- TestCase subclass: #WriteBarrierTest
- instanceVariableNames: ''
- classVariableNames: 'ContextInstance'
- poolDictionaries: ''
- category: 'KernelTests-WriteBarrier'!
-
- !WriteBarrierTest commentStamp: '' prior: 0!
- My tests ensure the ReadOnly property of objects work properly.
-
- #testMutateIVObject is a good start to understand what is going on.
-
- The VM needs to be compiled with -DIMMUTABILTY= true for those tests to work.!
Item was removed:
- ----- Method: WriteBarrierTest class>>initialize (in category 'initialization') -----
- initialize
-
- ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()!
Item was removed:
- ----- Method: WriteBarrierTest>>alwaysReadOnlyObjects (in category 'guinea pigs') -----
- alwaysReadOnlyObjects
- "Immediates are always immutable"
- ^ { 1 }!
Item was removed:
- ----- Method: WriteBarrierTest>>alwaysWritableObjects (in category 'guinea pigs') -----
- alwaysWritableObjects
- "Objects that currently can't be immutable"
- ^ { ContextInstance .
- Processor .
- Processor activeProcess }!
Item was removed:
- ----- Method: WriteBarrierTest>>expectedFailures (in category 'expected failures') -----
- expectedFailures
- Smalltalk supportsReadOnlyObjects ifFalse:
- [^self class testSelectors].
- ^#( testMutateByteArrayUsingDoubleAtPut testMutateByteArrayUsingFloatAtPut ),
- (self mirrorPrimitives
- ifNil: [#(testBasicProxyReadOnly testBasicProxyWritable testSetIsReadOnlySuccessProxy)]
- ifNotNil: [#()])!
Item was removed:
- ----- Method: WriteBarrierTest>>maybeReadOnlyObjects (in category 'guinea pigs') -----
- maybeReadOnlyObjects
- "ByteObject, Variable object, fixed sized object"
- ^ { { 1 . 2 . 3 } asByteArray . { 1 . 2 . 3 } . (MessageSend receiver: 1 selector: #+ argument: 2) }!
Item was removed:
- ----- Method: WriteBarrierTest>>mirrorPrimitives (in category 'tests - helper') -----
- mirrorPrimitives
-
- ^Smalltalk classNamed: #MirrorPrimitives!
Item was removed:
- ----- Method: WriteBarrierTest>>testAttemptToMutateLiterals (in category 'tests - object') -----
- testAttemptToMutateLiterals
- | guineaPigs |
- guineaPigs := {#[1 2 3] . #(1 2 3) }.
- guineaPigs do:
- [ :guineaPig |
- self should: [guineaPig at: 1 put: 4]
- raise: ModificationForbidden].
-
- self should: [guineaPigs first become: guineaPigs second ]
- raise: ModificationForbidden.
-
- self should: [ByteString adoptInstance: guineaPigs first]
- raise: ModificationForbidden.
-
- self should: [WeakArray adoptInstance: guineaPigs last]
- raise: ModificationForbidden!
Item was removed:
- ----- Method: WriteBarrierTest>>testBasicProxyReadOnly (in category 'tests - proxy') -----
- testBasicProxyReadOnly
- self alwaysReadOnlyObjects do: [ :each |
- self assert: (self mirrorPrimitives isObjectReadOnly: each) equals: true ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testBasicProxyWritable (in category 'tests - proxy') -----
- testBasicProxyWritable
- self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
- self assert: (self mirrorPrimitives isObjectReadOnly: each) equals: false ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testBasicReadOnly (in category 'tests - object') -----
- testBasicReadOnly
- self alwaysReadOnlyObjects do: [ :each |
- self assert: each isReadOnlyObject equals: true ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testBasicWritable (in category 'tests - object') -----
- testBasicWritable
- self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
- self assert: each isReadOnlyObject equals: false ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testBecomeReadOnly (in category 'tests - object') -----
- testBecomeReadOnly
- | readOnlyArrays readOnlyByteArrays |
- readOnlyArrays := (1 to: 3) collect: [:n| (0 to: n) asArray beReadOnlyObject; yourself].
- "N.B. if the targets are read-only this fails, which is correct for elementsForwardIdentityTo: since copyHash is implicitly true;
- we need to write a test for a putative elementsForwardIdentityNoCopyHashTo:"
- readOnlyByteArrays := (1 to: 3) collect: [:n| (0 to: n) asByteArray" beReadOnlyObject; yourself"].
- self should: [readOnlyArrays elementsForwardIdentityTo: readOnlyByteArrays]
- raise: ModificationForbidden.
- [readOnlyArrays elementsForwardIdentityTo: readOnlyByteArrays]
- on: ModificationForbidden
- do: [:ex|
- false
- ifTrue: "This fails, but should succeed. I *think* it's to do with catching signals when resignalling"
- [(ex mirror detect: [:element| element isReadOnlyObject] ifNone: []) ifNotNil:
- [:readOnlyObj| readOnlyObj beWritableObject]]
- ifFalse:
- [ex mirror do: [:element| element beWritableObject]].
- ex retryModification].
- self assert: (readOnlyArrays allSatisfy: [:array| array class == ByteArray])!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateByteArrayUsingByteAtPut (in category 'tests - object') -----
- testMutateByteArrayUsingByteAtPut
- | guineaPig |
- guineaPig := ByteArray new: 5.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig byteAt: 1 put: 12 ]
- raise: ModificationForbidden.
-
- [ guineaPig byteAt: 1 put: 12 ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: 12.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig beReadOnlyObject.
- self
- should: [ guineaPig byteAt: 1 put: 13 ]
- raise: ModificationForbidden.
-
- [ guineaPig byteAt: 1 put: 13 ]
- on: ModificationForbidden
- do: [ :modification |
- modification object beWritableObject.
- modification retryModificationNoResume.
- modification object beReadOnlyObject.
- modification resume].
-
- self assert: guineaPig first equals: 13.
- self assert: guineaPig isReadOnlyObject!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateByteArrayUsingDoubleAtPut (in category 'tests - object') -----
- testMutateByteArrayUsingDoubleAtPut
- | guineaPig |
- guineaPig := ByteArray new: 8.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
- raise: ModificationForbidden.
-
- [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: (2 raisedTo: 65) asFloat.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig beReadOnlyObject.
- self
- should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 64) asFloat ]
- raise: ModificationForbidden.
-
- [ guineaPig doubleAt: 1 put: (2 raisedTo: 64) asFloat ]
- on: ModificationForbidden
- do: [ :modification |
- modification object beWritableObject.
- modification retryModificationNoResume.
- modification object beReadOnlyObject.
- modification resume].
-
- self assert: guineaPig first equals: (2 raisedTo: 64) asFloat.
- self assert: guineaPig isReadOnlyObject!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateByteArrayUsingFloatAtPut (in category 'tests - object') -----
- testMutateByteArrayUsingFloatAtPut
- | guineaPig |
- guineaPig := ByteArray new: 5.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig floatAt: 1 put: 1.0 ]
- raise: ModificationForbidden.
-
- [ guineaPig floatAt: 1 put: 1.0 ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: 1.0.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig floatAt: 1 put: 2.0 ]
- raise: ModificationForbidden.
-
- [ guineaPig floatAt: 1 put: 2.0 ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModificationNoResume.
- modification object beReadOnlyObject.
- modification resume].
-
- self assert: guineaPig first equals: 2.0.
- self assert: guineaPig isReadOnlyObject!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateByteStringyUsingAtPut (in category 'tests - object') -----
- testMutateByteStringyUsingAtPut
- | guineaPig |
- guineaPig := ByteString new: 5.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig at: 1 put: $h ]
- raise: ModificationForbidden.
-
- [ guineaPig at: 1 put: $h ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: $h.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig at: 1 put: $g ]
- raise: ModificationForbidden.
-
- [ guineaPig at: 1 put: $g ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModificationNoResume.
- modification object beReadOnlyObject.
- modification resume ].
-
- self assert: guineaPig first equals: $g.
- self assert: guineaPig isReadOnlyObject!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateByteStringyUsingByteAtPut (in category 'tests - object') -----
- testMutateByteStringyUsingByteAtPut
- | guineaPig |
- guineaPig := ByteString new: 5.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig byteAt: 1 put: 100 ]
- raise: ModificationForbidden.
-
- [ guineaPig byteAt: 1 put: 100 ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first asciiValue equals: 100!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateIVObject (in category 'tests - object') -----
- testMutateIVObject
- | guineaPig |
- guineaPig := MessageSend new.
- guineaPig beReadOnlyObject.
- [ guineaPig receiver: 1 ]
- on: ModificationForbidden
- do: [ :modification | "Surely a NoModification error" ].
- guineaPig
- beWritableObject;
- selector: #+;
- beReadOnlyObject.
- [ guineaPig arguments: #(2) ]
- on: ModificationForbidden
- do: [ :modification |"Surely a NoModification error" ].
- self assert: guineaPig receiver isNil.
- self assert: guineaPig arguments isNil.
- self assert: guineaPig selector == #+.!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectClass (in category 'tests - object') -----
- testMutateObjectClass
- | guineaPig |
- guineaPig := WriteBarrierStub new.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ]
- raise: ModificationForbidden.
-
- [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ]
- on: ModificationForbidden
- do: [ :modification |
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig class equals: WriteBarrierAnotherStub!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectClassViaAdoption (in category 'tests - object') -----
- testMutateObjectClassViaAdoption
- | guineaPig |
- guineaPig := WriteBarrierStub new.
- guineaPig beReadOnlyObject.
-
- self
- should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
- raise: ModificationForbidden.
-
- [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
- on: ModificationForbidden
- do: [ :modification |
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig class equals: WriteBarrierAnotherStub.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig beReadOnlyObject.
- self
- should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
- raise: ModificationForbidden.
-
- [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
- on: ModificationForbidden
- do: [ :modification |
- modification object beWritableObject.
- modification retryModificationNoResume.
- modification object beReadOnlyObject.
- modification resume].
-
- self assert: guineaPig class equals: WriteBarrierAnotherStub.
- self assert: guineaPig isReadOnlyObject!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectFirstInstVarWithManyVars (in category 'tests - object') -----
- testMutateObjectFirstInstVarWithManyVars
- | guineaPig failure |
- guineaPig := WriteBarrierStub new.
- guineaPig beReadOnlyObject.
- failure := [ guineaPig var1: #test ] on: ModificationForbidden do: [:err | err].
-
- self assert: failure fieldIndex equals: 1!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectInstVarShouldCatchRightFailure (in category 'tests - object') -----
- testMutateObjectInstVarShouldCatchRightFailure
- | guineaPig failure |
- guineaPig := MessageSend new.
- guineaPig beReadOnlyObject.
- failure := [ guineaPig receiver: #test ] on: ModificationForbidden do: [:err | err].
-
- self assert: failure object == guineaPig.
- self assert: failure newValue equals: #test.
- self assert: failure fieldIndex equals: 1.!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingAtPut (in category 'tests - object') -----
- testMutateObjectInstVarUsingAtPut
- | guineaPig |
- guineaPig := Array new: 5.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig at: 1 put: #test ]
- raise: ModificationForbidden.
-
- [ guineaPig at: 1 put: #test ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: #test.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig at: 1 put: #test ]
- raise: ModificationForbidden.
-
- [ guineaPig at: 1 put: #test ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModificationNoResume.
- modification object beReadOnlyObject.
- modification resume ].
-
- self assert: guineaPig first equals: #test.
- self assert: guineaPig isReadOnlyObject
- !
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingBasicAtPut (in category 'tests - object') -----
- testMutateObjectInstVarUsingBasicAtPut
- | guineaPig |
- guineaPig := Array new: 5.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig basicAt: 1 put: #test ]
- raise: ModificationForbidden.
-
- [ guineaPig basicAt: 1 put: #test ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: #test!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingInstVarAtPut (in category 'tests - object') -----
- testMutateObjectInstVarUsingInstVarAtPut
- | guineaPig |
- guineaPig := WriteBarrierStub new.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig instVarAt: 1 put: #test ]
- raise: ModificationForbidden.
-
- [ guineaPig instVarAt: 1 put: #test ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig var1 equals: #test!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateObjectLastInstVarWithManyVars (in category 'tests - object') -----
- testMutateObjectLastInstVarWithManyVars
- | guineaPig failure |
- guineaPig := WriteBarrierStub new.
- guineaPig beReadOnlyObject.
- failure := [ guineaPig var10: #test ] on: ModificationForbidden do: [:err | err].
-
- self assert: failure fieldIndex equals: 10!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateVariableObject (in category 'tests - object') -----
- testMutateVariableObject
- | guineaPigs |
- guineaPigs := {#[1 2 3] . #(1 2 3) }.
- guineaPigs do: [ :guineaPig |
- guineaPig beReadOnlyObject.
- [guineaPig at: 1 put: 4]
- on: ModificationForbidden
- do: [ "Surely a NoModification error" ].
- guineaPig
- beWritableObject;
- at: 2 put: 5;
- beReadOnlyObject.
- [guineaPig at: 3 put: 6]
- on: ModificationForbidden
- do: [ "Surely a NoModification error" ].
- self assert: guineaPig first = 1.
- self assert: guineaPig second = 5.
- self assert: guineaPig third = 3 ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateWideStringUsingAtPut (in category 'tests - object') -----
- testMutateWideStringUsingAtPut
- | guineaPig |
- guineaPig := 'hello' asWideString.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig at: 1 put: $q ]
- raise: ModificationForbidden.
-
- [ guineaPig at: 1 put: $q ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first equals: $q!
Item was removed:
- ----- Method: WriteBarrierTest>>testMutateWideStringUsingWordAtPut (in category 'tests - object') -----
- testMutateWideStringUsingWordAtPut
- | guineaPig |
- guineaPig := 'hello' asWideString.
- guineaPig beReadOnlyObject.
-
- self
- should: [ guineaPig wordAt: 1 put: 65536 ]
- raise: ModificationForbidden.
-
- [ guineaPig wordAt: 1 put: 65536 ]
- on: ModificationForbidden
- do: [:modification |
- self assert: modification fieldIndex equals: 1.
- modification object beWritableObject.
- modification retryModification ].
-
- self assert: guineaPig first asciiValue equals: 65536!
Item was removed:
- ----- Method: WriteBarrierTest>>testObject:initialState:tuples: (in category 'tests - helper') -----
- testObject: object initialState: initialState tuples: tuples
- self
- testObject: object
- initialState: initialState
- tuples: tuples
- setReadOnlyBlock: [ :value | object setIsReadOnlyObject: value ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testObject:initialState:tuples:setReadOnlyBlock: (in category 'tests - helper') -----
- testObject: object initialState: initialState tuples: tuples setReadOnlyBlock: setImmutabilityBlock
- self assert: object isReadOnlyObject equals: initialState.
- tuples do: [ :tuple |
- | stateToSet expectedResult expectedNewState |
- stateToSet := tuple first.
- expectedResult := tuple second.
- expectedNewState := tuple last.
- [self assert: (setImmutabilityBlock value: stateToSet) equals: expectedResult ]
- on: ((Smalltalk classNamed: #PrimitiveFailed) ifNil: [Error])
- do: [ self assert: (self alwaysReadOnlyObjects , self alwaysWritableObjects includes: object) ].
- self assert: object isReadOnlyObject equals: expectedNewState ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testProxyObject:initialState:tuples: (in category 'tests - helper') -----
- testProxyObject: object initialState: initialState tuples: tuples
- self
- testObject: object
- initialState: initialState
- tuples: tuples
- setReadOnlyBlock: [ :value |
- self mirrorPrimitives makeObject: object readOnly: value ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testRetryingInstVarModification (in category 'tests - object') -----
- testRetryingInstVarModification
- | guineaPig |
- guineaPig := MessageSend new.
- guineaPig beReadOnlyObject.
-
- [ guineaPig receiver: 1 ] on: ModificationForbidden do: [:err |
- guineaPig beWritableObject.
- err retryModification ].
-
- self assert: guineaPig receiver equals: 1!
Item was removed:
- ----- Method: WriteBarrierTest>>testRetryingPointInstVarModification (in category 'tests - object') -----
- testRetryingPointInstVarModification
- | guineaPig labRat |
- guineaPig := 1@2.
- labRat := guineaPig copy bitShiftPoint: 3.
- guineaPig beReadOnlyObject.
-
- [ guineaPig bitShiftPoint: 3 ]
- on: ModificationForbidden
- do: [:err |
- guineaPig beWritableObject.
- err retryModification ].
-
- self assert: guineaPig equals: labRat.
- self deny: guineaPig isReadOnlyObject.
-
- guineaPig bitShiftPoint: -3; beReadOnlyObject.
- self assert: guineaPig equals: 1@2.
-
- [ guineaPig bitShiftPoint: 3 ]
- on: ModificationForbidden
- do: [:err |
- guineaPig beWritableObject.
- err retryModificationNoResume.
- guineaPig beReadOnlyObject.
- err resume ].
-
- self assert: guineaPig equals: labRat.
- self assert: guineaPig isReadOnlyObject!
Item was removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailure (in category 'tests - object') -----
- testSetIsReadOnlyFailure
- self alwaysWritableObjects do: [ :each |
- self
- testObject: each
- initialState: false
- tuples: #( (true false false) (false false false) ) ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailureProxy (in category 'tests - proxy') -----
- testSetIsReadOnlyFailureProxy
- self alwaysWritableObjects do: [ :each |
- self
- testProxyObject: each
- initialState: false
- tuples: #( (true false false) (false false false) ) ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediate (in category 'tests - object') -----
- testSetIsReadOnlyImmediate
- self alwaysReadOnlyObjects do: [ :each |
- self
- testObject: each
- initialState: true
- tuples: #( (true true true) (false true true) ) ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediateProxy (in category 'tests - proxy') -----
- testSetIsReadOnlyImmediateProxy
- self alwaysReadOnlyObjects do: [ :each |
- self
- testProxyObject: each
- initialState: true
- tuples: #( (true true true) (false true true) ) ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccess (in category 'tests - object') -----
- testSetIsReadOnlySuccess
- self maybeReadOnlyObjects do: [ :each |
- self
- testObject: each
- initialState: false
- tuples: #( (true false true) (false true false) ) ]!
Item was removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccessProxy (in category 'tests - proxy') -----
- testSetIsReadOnlySuccessProxy
- self maybeReadOnlyObjects do: [ :each |
- self
- testProxyObject: each
- initialState: false
- tuples: #( (true false true) (false true false) ) ]!
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-jar.442.mcz
==================== Summary ====================
Name: KernelTests-jar.442
Author: jar
Time: 26 January 2023, 10:37:59.494205 pm
UUID: d69aa3b9-4497-6840-935d-1be1ea5f6b80
Ancestors: KernelTests-tpr.441
add setUp and tearDown methods to MonitorTest class to prevent tests from leaving unterminated (blocked on a semaphore) processes behind
=============== Diff against KernelTests-tpr.441 ===============
Item was changed:
TestCase subclass: #MonitorTest
+ instanceVariableNames: 'semaphore'
- instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: MonitorTest>>setUp (in category 'as yet unclassified') -----
+ setUp
+
+ super setUp.
+ semaphore := Semaphore new.!
Item was added:
+ ----- Method: MonitorTest>>tearDown (in category 'as yet unclassified') -----
+ tearDown
+ "Release all processes still waiting at the semaphore or in the active priority queue."
+
+ Processor yield.
+ [semaphore isEmpty] whileFalse: [semaphore signal].
+
+ super tearDown.!
Item was changed:
----- Method: MonitorTest>>testCheckOwnerProcess (in category 'tests') -----
testCheckOwnerProcess
self should: [Monitor new checkOwnerProcess]
raise: Error.
self shouldnt: [| m | m := Monitor new. m critical: [m checkOwnerProcess]]
raise: Error.
self should: [| s m |
m := Monitor new.
+ [m critical: [s := #in. semaphore wait]] fork.
- [m critical: [s := #in. Semaphore new wait]] fork.
Processor yield.
self assert: #in equals: s.
m checkOwnerProcess]
raise: Error!
Item was changed:
----- Method: MonitorTest>>testCriticalIfLocked (in category 'tests') -----
testCriticalIfLocked
| m s |
m := Monitor new.
self assert: #unlocked == (m critical: [#unlocked] ifLocked: [#locked]).
+ [m critical: [s := #in. semaphore wait]] fork.
- [m critical: [s := #in. Semaphore new wait]] fork.
Processor yield.
self assert: #in equals: s.
self assert: #locked equals: (m critical: [#unlocked] ifLocked: [#locked])!
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-jar.443.mcz
==================== Summary ====================
Name: KernelTests-jar.443
Author: jar
Time: 30 January 2023, 5:33:22.893677 pm
UUID: 4f815d5d-a166-d141-8fca-d9d0d57f0b93
Ancestors: KernelTests-tpr.441
Complement Kernel-jar.1498
=============== Diff against KernelTests-tpr.441 ===============
Item was removed:
- ----- Method: MutexTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testUnwindMutexBlockedInCritical)!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWait2 (in category 'tests') -----
+ testMutexAfterCriticalWait2
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [lock critical: [beenHere := true]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitCf (in category 'tests') -----
+ testMutexAfterCriticalWaitCf
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [lock critical: [beenHere := true]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty.
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate].
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitInEnsure (in category 'tests') -----
+ testMutexAfterCriticalWaitInEnsure
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p |
+ lock := Mutex new.
+ p := [[] ensure: [lock critical: []]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitInEnsure2 (in category 'tests') -----
+ testMutexAfterCriticalWaitInEnsure2
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [[] ensure: [lock critical: [beenHere := true]]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self assert: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitInEnsureCf (in category 'tests') -----
+ testMutexAfterCriticalWaitInEnsureCf
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [[] ensure: [lock critical: [beenHere := true]]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty.
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate].
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCritical (in category 'tests') -----
+ testMutexBlockedInCritical
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [lock critical: []] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCritical2 (in category 'tests') -----
+ testMutexBlockedInCritical2
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [lock critical: [beenHere := true]. beenHereToo := true] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ self deny: beenHere.
+ self deny: beenHereToo.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCriticalInEnsure (in category 'tests') -----
+ testMutexBlockedInCriticalInEnsure
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [[] ensure: [lock critical: []]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCriticalInEnsure2 (in category 'tests') -----
+ testMutexBlockedInCriticalInEnsure2
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [[] ensure: [lock critical: [beenHere := true]. beenHereToo := true]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ self deny: beenHere.
+ self assert: beenHereToo.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWait2 (in category 'tests') -----
+ testMutexInCriticalWait2
+ "This tests whether a process that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [lock critical: [sock wait. beenHere := true]. beenHereToo := true] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere.
+ self deny: beenHereToo!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWaitInEnsure (in category 'tests') -----
+ testMutexInCriticalWaitInEnsure
+ "This tests whether a process that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [[] ensure: [lock critical: [sock wait]]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWaitInEnsure2 (in category 'tests') -----
+ testMutexInCriticalWaitInEnsure2
+ "This tests whether a process that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [[] ensure: [lock critical: [sock wait. beenHere := true]. beenHereToo := true]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self assert: beenHere.
+ self assert: beenHereToo!
Item was removed:
- ----- Method: MutexTest>>testUnwindMutexBlockedInCritical (in category 'tests') -----
- testUnwindMutexBlockedInCritical "self run: #testMutexBlockedInCritical"
- "This tests whether a mutex that is inside the primitiveEnterCriticalSection in Mutex>>critical:
- leaves it unchanged."
- | lock sock proc wait |
- lock := Mutex new.
- sock := Semaphore new.
- proc := [lock critical: [sock wait]] fork.
- wait := [[] ensure: [lock critical: []]] fork.
- Processor yield.
- self assert: proc suspendingList == sock.
- self assert: wait suspendingList == lock.
- self deny: lock isEmpty.
- self assert: lock isOwned.
- wait terminate.
- Processor yield.
- self assert: wait isTerminated.
- self assert: proc suspendingList == sock.
- self assert: wait suspendingList == nil.
- self assert: lock isEmpty.
- self assert: lock isOwned
- !
Item was removed:
- ----- Method: ProcessTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testTerminateTerminatingProcess testResumeTerminatingProcess)!
Item was changed:
----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') -----
testResumeTerminatingProcess
+ "An attempt to resume a terminating process in the middle of preparing its suspended context should raise an error;
+ one possible solution is to nil the suspended context of the terminating process while executing the vulnerable code"
+
+ "Note: another solution could be to run the vulnerable part of the code in #terminate using #valueUnpreemptively;
+ currently, however, #valueUnpreemptively is affected by the #priority: bug described here:
+ http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217473…"
- "An attempt to resume a terminating process should probably raise an error;
- leave this test as an expected failure for the moment."
+ | terminatee terminator unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := unwound not]] newProcess.
+ terminatee priority: Processor activePriority + 1.
+ terminatee resume.
- | terminatee terminator resumed |
- terminatee := [semaphore critical:[]. resumed := true] fork.
- Processor yield.
terminator := [terminatee terminate] newProcess.
+ terminator priority: Processor activePriority + 1.
+ self assert: terminatee isSuspended.
- self assert: terminatee suspendingList == semaphore.
self assert: terminator isSuspended.
"run terminator and stop inside #terminate"
+ [terminator suspendedContext selectorToSendOrSelf == #bottomContext] whileFalse: [terminator step].
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
self assert: terminator isSuspended.
+ "resuming the terminatee process should causes the VM to raise an error while its suspended context is nil"
- "resume the terminatee process and and check if the VM raises an error;
- an error is expected because terminatee's suspendedContext equals nil"
self should: [terminatee resume] raise: Error.
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
+ self assert: terminator isSuspended.
+ "now let the terminator finish its interrupted termination of the terminatee process"
- "now let the terminator finish terminating the terminatee process"
terminator resume.
- Processor yield.
- self assert: resumed isNil.
self assert: terminatee isTerminated.
+ self assert: unwound.
self assert: terminator isTerminated!
Item was changed:
----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') -----
testTerminateTerminatingProcess
+ "An attempt to terminate a terminating process in the middle of preparing its suspended context should do nothing;
+ one possible solution is to nil the suspended context of the terminating process while executing the vulnerable code."
+
+ "Note: another solution could be to run the vulnerable part of the code in #terminate using #valueUnpreemptively;
+ currently, however, #valueUnpreemptively is affected by the #priority: bug described here:
+ http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217473…"
- "An attempt to terminate a terminating process should probably raise an error;
- leave this test as an expected failure for the moment."
+ | terminatee terminator unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := unwound not]] newProcess.
+ terminatee priority: Processor activePriority + 1.
+ terminatee resume.
- | terminatee terminator resumed |
- terminatee := [semaphore critical:[]. resumed := true] fork.
- Processor yield.
terminator := [terminatee terminate] newProcess.
+ terminator priority: Processor activePriority + 1.
+ self assert: terminatee isSuspended.
- self assert: terminatee suspendingList == semaphore.
self assert: terminator isSuspended.
"run terminator and stop inside #terminate"
+ [terminator suspendedContext selectorToSendOrSelf == #bottomContext] whileFalse: [terminator step].
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
self assert: terminator isSuspended.
+ "terminating the terminatee process again should make no difference while its suspended context is nil"
+ terminatee terminate.
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
+ self assert: terminator isSuspended.
+ "now let the terminator finish its interrupted termination of the terminatee process"
- "terminate the terminatee process again and let the termination finish;
- an error is expected because #terminate detected multiple termination"
- self should: [terminatee terminate] raise: Error.
- "now let the terminator finish terminating the terminatee process"
terminator resume.
- Processor yield.
- self assert: resumed isNil.
self assert: terminatee isTerminated.
+ self assert: unwound.
self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcessBeforeUnwindTo (in category 'tests') -----
+ testTerminateTerminatingProcessBeforeUnwindTo
+ "Terminating a terminatee process after the terminator process restarted the terminatee
+ process should unwind the terminatee process and let the terminator process terminate."
+
+ | terminator terminatee unwound |
+ unwound := false.
+ terminatee := [[Semaphore new wait] ensure: [unwound := true]] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isBlocked.
+ self assert: terminator isSuspended.
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #resume].
+ "terminator steps until terminatee's unwind context is set"
+ terminator suspendedContext nextInstruction. "skip terminatee resume instruction"
+ terminator resume. "and run until parked at wait"
+ "terminatee is inside its helper stack, about to call #unwindTo:"
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: unwound.
+ Processor yield.
+ self assert: terminator isTerminated!
Item was removed:
- ----- Method: SemaphoreTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testUnwindSemaInCriticalWait)!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWait2 (in category 'tests') -----
+ testSemaAfterCriticalWait2
+ "This tests whether a process that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [s critical: [beenHere := true]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse: [(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals.
+ self deny: beenHere!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWaitInEnsure (in category 'tests') -----
+ testSemaAfterCriticalWaitInEnsure
+ "This tests whether a process that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [[] ensure: [s critical:[]]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse: [(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWaitInEnsure2 (in category 'tests') -----
+ testSemaAfterCriticalWaitInEnsure2
+ "This tests whether a process that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [[] ensure: [s critical: [beenHere := true]]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse: [(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals.
+ self assert: beenHere!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWait2 (in category 'tests') -----
+ testSemaInCriticalWait2
+ "This tests whether a process that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [s critical: [beenHere := true]] fork.
+ Processor yield.
+ self assert: s equals: p suspendingList.
+ p terminate.
+ self assert: 0 equals: s excessSignals.
+ self deny: beenHere!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWaitInEnsure (in category 'tests') -----
+ testSemaInCriticalWaitInEnsure
+ "This tests whether a process that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [[] ensure: [s critical: []]] fork.
+ Processor yield.
+ self assert: s equals: p suspendingList.
+ p terminate.
+ self assert: 0 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWaitInEnsure2 (in category 'tests') -----
+ testSemaInCriticalWaitInEnsure2
+ "This tests whether a process that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [[] ensure: [s critical: [beenHere := true]]] fork.
+ Processor yield.
+ self assert: s equals: p suspendingList.
+ p terminate.
+ self assert: 0 equals: s excessSignals.
+ self deny: beenHere!
Item was removed:
- ----- Method: SemaphoreTest>>testUnwindSemaInCriticalWait (in category 'tests') -----
- testUnwindSemaInCriticalWait "self run: #testSemaInCriticalWait"
- "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
- leaves it without signaling the associated semaphore."
- | s p |
- s := Semaphore new.
- p := [[] ensure: [s critical:[]]] fork.
- Processor yield.
- self assert:(p suspendingList == s).
- p terminate.
- self assert: 0 equals: s excessSignals!
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Treated Inbox:
http://source.squeak.org/treated/KernelTests-jar.421.mcz
==================== Summary ====================
Name: KernelTests-jar.421
Author: jar
Time: 5 January 2022, 3:15:22.031959 pm
UUID: 97065f2d-925e-d04e-9bfb-69efecc5f415
Ancestors: KernelTests-ct.418
a battery of tests to complement new #terminate (Kernel-jar.1443 or later).
replacing individual changesets:
KernelTests-jar.406
KernelTests-jar.407
KernelTests-jar.415
KernelTests-jar.416
KernelTests-jar.417
KernelTests-jar.419
KernelTests-jar.420
please kindly remove these from the Inbox
=============== Diff against KernelTests-ct.418 ===============
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalEnsureArgument (in category 'tests') -----
+ testMutexInCriticalEnsureArgument "self run: #testMutexInCriticalEnsureArgument"
+ "This tests whether a process that is in the ensure argument block in critical: but has yet to evaluate the primitiveExitCriticalSection
+ leaves it with the mutex unlocked."
+
+ | terminatee mutex |
+ mutex := Mutex new.
+ terminatee := [mutex critical: []] newProcess.
+ self assert: terminatee isSuspended.
+ terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #primitiveExitCriticalSection].
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self deny: mutex isOwned.
+ self assert: mutex isEmpty!
Item was changed:
----- Method: ProcessTest>>testAtomicSuspend (in category 'tests') -----
testAtomicSuspend
"Test atomic suspend of foreign processes"
| list p |
p := [semaphore wait] fork.
Processor yield.
list := p suspendPrimitivelyOrFail.
+ self assert:
+ (Smalltalk processSuspensionUnblocks
+ ifFalse: [list isNil]
+ ifTrue: [list == semaphore])!
- self assert: list == semaphore.
- !
Item was added:
+ ----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') -----
+ testResumeTerminatingProcess
+
+ | terminatee terminator resumed semaphore |
+ semaphore := Semaphore new.
+ terminatee := [semaphore critical:[]. resumed := true] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee suspendingList == semaphore.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #releaseCriticalSection:"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #selectorJustSentOrSelf].
+ self assert: terminator isSuspended.
+ "resume the terminatee process and and check if the VM raises an error;
+ an error is expected because terminatee's suspendedContext equals nil"
+ self should: [terminatee resume] raise: Error.
+ "now let the terminator finish terminating the terminatee process"
+ terminator resume.
+ Processor yield.
+ self assert: resumed isNil.
+ self assert: terminatee isTerminated.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testRevisedSuspendExpectations (in category 'tests') -----
+ testRevisedSuspendExpectations
+ "Test revised suspend expectations vs. pre-2022 VM's suspend"
+
+ | s p list |
+ s := Semaphore new.
+ p := [s critical:[]] forkAt: Processor activePriority + 1.
+ list := p suspend.
+
+ Smalltalk processSuspensionUnblocks
+ ifFalse: [
+ self assert: p suspendingList equals: nil.
+ self assert: list equals: nil.
+ self deny: p suspendedContext selectorJustSentOrSelf equals: #wait
+ ]
+ ifTrue: [
+ self assert: p suspendingList equals: nil.
+ self assert: list equals: s.
+ self assert: p suspendedContext selectorJustSentOrSelf equals: #wait
+ ]!
Item was added:
+ ----- Method: ProcessTest>>testTerminateEnsureAsStackTop (in category 'tests') -----
+ testTerminateEnsureAsStackTop
+ "Test #ensure unwind block is executed even when #ensure context is on stack's top."
+
+ | p1 p2 p3 x1 x2 x3 |
+ x1 := x2 := x3 := false.
+
+ "p1 is at the beginning of the ensure block and the unwind block hasn't run yet"
+ p1 := Process
+ forBlock: [[] ensure: [x1 := x1 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) isNil]].
+
+ "p2 has already set complete to true (tempAt: 2) but the unwind block hasn't run yet"
+ p2 := Process
+ forBlock: [[] ensure: [x2 := x2 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) notNil]].
+
+ "p3 has already set complete to true AND the unwind block has run already run;
+ we have to verify the unwind block is not executed again during termination"
+ p3 := Process
+ forBlock: [[] ensure: [x3 := x3 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [ctx willReturn]].
+
+ "make sure all processes are running and only the p3's unwind block has finished"
+ self deny: p1 isTerminated | p2 isTerminated | p3 isTerminated.
+ self deny: x1 | x2.
+ self assert: x3. "p3 has already run its unwind block; we test it won't run it again"
+ "terminate all processes and verify all unwind blocks have finished correctly"
+ p1 terminate. p2 terminate. p3 terminate.
+ self assert: p1 isTerminated & p2 isTerminated & p3 isTerminated.
+ self assert: x1 & x2 & x3!
Item was added:
+ ----- Method: ProcessTest>>testTerminateInTerminate (in category 'tests') -----
+ testTerminateInTerminate
+ "Terminating a terminator process should unwind both the terminator and its terminatee process"
+
+ | terminator terminatee unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := true]] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isSuspended.
+ self assert: terminator isSuspended.
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #suspend]. "first #suspend in #terminate"
+ self assert: terminator isSuspended.
+ terminator terminate.
+ self assert: terminator isTerminated.
+ self assert: unwound!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') -----
+ testTerminateTerminatingProcess
+
+ | terminatee terminator resumed semaphore |
+ semaphore := Semaphore new.
+ terminatee := [semaphore critical:[]. resumed := true] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee suspendingList == semaphore.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #releaseCriticalSection:"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #selectorJustSentOrSelf].
+ self assert: terminator isSuspended.
+ "terminate the terminatee process again and let the termination finish;
+ an error is expected because #terminate detected multiple termination"
+ self should: [terminatee terminate] raise: Error.
+ "now let the terminator finish terminating the terminatee process"
+ terminator resume.
+ Processor yield.
+ self assert: resumed isNil.
+ self assert: terminatee isTerminated.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalEnsureArgument (in category 'tests') -----
+ testSemaInCriticalEnsureArgument "self run: #testSemaInCriticalEnsureArgument"
+ "This tests whether a process that is in ensure argument block but has yet to evaluate the signal
+ leaves it with signaling the associated semaphore."
+
+ | terminatee sema |
+ sema := Semaphore forMutualExclusion.
+ terminatee := [sema critical: []] newProcess.
+ self assert: terminatee isSuspended.
+ terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #signal].
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: sema excessSignals = 1 !
Item was added:
+ ProcessTest subclass: #UnwindTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure1 (in category 'tests') -----
+ testTerminateActiveInNestedEnsure1
+ "Terminate active process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor activeProcess terminate] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure2 (in category 'tests') -----
+ testTerminateActiveInNestedEnsure2
+ "Terminate active process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor activeProcess terminate.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure1 (in category 'tests') -----
+ testTerminateBlockedInNestedEnsure1
+ "Terminate blocked process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [semaphore wait] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is blocked and none of the unwind blocks has finished yet"
+ self assert: p isBlocked.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ Smalltalk processSuspensionUnblocks ifFalse: [
+ "terminate will suspend the process first and suspend will put the process back at #wait and
+ so unwind will put the process back at the wait; to continue, semaphore needs to be signaled"
+ "self assert: p isBlocked. <-- this wouldn't work because terminate set suspendedContext to nil"
+ self deny: x1 | x2 | x3 | x4.
+ semaphore signal.
+ Processor yield].
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure2 (in category 'tests') -----
+ testTerminateBlockedInNestedEnsure2
+ "Terminate blocked process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ semaphore wait.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is blocked and none of the unwind blocks has finished yet"
+ self assert: p isBlocked.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ Smalltalk processSuspensionUnblocks ifFalse: [
+ "terminate will suspend the process first and suspend will put the process back at #wait and
+ so unwind will put the process back at the wait; to continue, semaphore needs to be signaled"
+ "self assert: p isBlocked. <-- this wouldn't work because terminate set suspendedContext to nil"
+ self deny: x1 | x2 | x3 | x4.
+ semaphore signal.
+ Processor yield].
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn1 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true. return value].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x3.
+ self deny: x2 & x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn2 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true. return value].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x3.
+ self deny: x2 & x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn3 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn3
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true. return value]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn4 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn4
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true. return value]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn5 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn5
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true. return value].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn6 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn6
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true. return value].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn7 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn7
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true. return value.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn8 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn8
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true. return value.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure1 (in category 'tests') -----
+ testTerminateRunnableInNestedEnsure1
+ "Terminate runnable process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor yield] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is runnable and none of the unwind blocks has finished yet"
+ self assert: p isRunnable.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure2 (in category 'tests') -----
+ testTerminateRunnableInNestedEnsure2
+ "Terminate runnable process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor yield.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is runnable and none of the unwind blocks has finished yet"
+ self assert: p isRunnable.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure1 (in category 'tests') -----
+ testTerminateSuspendedInNestedEnsure1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure2 (in category 'tests') -----
+ testTerminateSuspendedInNestedEnsure2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ [p terminate] forkAt: Processor activePriority + 1.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Treated Inbox:
http://source.squeak.org/treated/KernelTests-jar.393.mcz
==================== Summary ====================
Name: KernelTests-jar.393
Author: jar
Time: 8 February 2021, 10:06:09.126403 pm
UUID: af94938b-d43a-b94c-b306-922ab65afb78
Ancestors: KernelTests-eem.392
Test for Process>>priority: related to fix Kernel-jar.1368
=============== Diff against KernelTests-eem.392 ===============
Item was added:
+ ----- Method: ProcessTest>>testPriority (in category 'tests') -----
+ testPriority
+ "test whether #priority: preempts active process to allow higher priority processes run"
+
+ | val oldPriority |
+ val := nil.
+ oldPriority := Processor activePriority.
+ Processor activeProcess priority: oldPriority + 2.
+ [ val := false ] forkAt: oldPriority + 1.
+ [ val := true ] forkAt: oldPriority.
+ Processor activeProcess priority: oldPriority.
+ self assert: val equals: Smalltalk vm processPreemptionYields!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox:
http://source.squeak.org/treated/Kernel-jar.1368.mcz
==================== Summary ====================
Name: Kernel-jar.1368
Author: jar
Time: 8 February 2021, 10:03:00.688403 pm
UUID: 095338a7-d694-3e4c-97dd-1f33e4d08156
Ancestors: Kernel-eem.1367
Fix incorrect #priority: behavior blocking higher priority processes
=============== Diff against Kernel-eem.1367 ===============
Item was changed:
----- Method: Process>>priority: (in category 'accessing') -----
priority: anInteger
"Set the receiver's priority to anInteger."
(anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority])
+ ifTrue: [
+ priority := anInteger.
+ self isActiveProcess ifTrue: [ [ ] forkAt: Processor highestPriority] ]
- ifTrue: [priority := anInteger]
ifFalse: [self error: 'Invalid priority: ', anInteger printString]!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox:
http://source.squeak.org/treated/Kernel-jar.1399.mcz
==================== Summary ====================
Name: Kernel-jar.1399
Author: jar
Time: 2 May 2021, 3:12:37.830089 pm
UUID: d288b516-c6f1-ce43-9061-2220422b8ab4
Ancestors: Kernel-jar.1398
Fix inconsistent implementation of an explicit and an implicit exception return.
I'd like to return to my original proposal in http://forum.world.st/The-Inbox-Kernel-nice-1391-mcz-tp5129040p5129084.html. The problem then was a bug in #outer that confused me. The bug has been fixed and the original proposal in my opinion makes sense again - to unify how the two kinds of exception return are implemented. Theoretically it's possible to change the #return definition in the future and then the two returns would diverge.
=============== Diff against Kernel-jar.1398 ===============
Item was changed:
----- Method: Context>>handleSignal: (in category 'private-exceptions') -----
handleSignal: exception
"Sent to handler (on:do:) contexts only.
Execute the handler action block"
| val |
<primitive: 199> "just a marker, fail and execute the following"
exception privHandlerContext: self contextTag.
self deactivateHandler. "Prevent re-entering the action block, unless it is explicitely rearmed"
val := [self fireHandlerActionForSignal: exception] ensure: [self reactivateHandler].
+ exception return: val "return from exception handlerContext if not otherwise directed in handle block"!
- self return: val "return from self if not otherwise directed in handle block"!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox:
http://source.squeak.org/treated/Kernel-jar.1415.mcz
==================== Summary ====================
Name: Kernel-jar.1415
Author: jar
Time: 20 November 2021, 12:22:39.046144 pm
UUID: 2058b1fd-425a-fa46-a2e0-297d1bfab952
Ancestors: Kernel-jar.1414
Fix a bug: when debugging things like this:
[^2] ensure: [Transcript cr; show: 'done']
if we step into the protected block [^2] and then step over ^2, we incorrectly get a BlockCannotReturn error.
This is an alternative proposal to Kernel-jar.1421 (and Kernel-jar.1413); the solution remains the same but it attempts to present a cleaner code (trying to address Christoph's objection in [2] and [3]).
The bug is described in detail in Kernel-nice.1407 and discussed in [1] and most recently in [2] and [3]:
[1] http://forum.world.st/stepping-over-non-local-return-in-a-protected-block-t…
[2] http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-August/216214.h…
[3] http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-November/216971…
=============== Diff against Kernel-jar.1414 ===============
Item was changed:
----- Method: Context>>resume:through: (in category 'controlling') -----
resume: value through: firstUnwindCtxt
"Unwind thisContext to self and resume with value as result of last send.
Execute any unwind blocks while unwinding.
ASSUMES self is a sender of thisContext."
| ctxt unwindBlock |
self isDead ifTrue: [self cannotReturn: value to: self].
+ ctxt := firstUnwindCtxt value. "evaluate in case firstUnwindCtxt is a block (used in simulation)"
- ctxt := firstUnwindCtxt ifNil: [thisContext findNextUnwindContextUpTo: self].
[ctxt isNil] whileFalse:
[(ctxt tempAt: 2) ifNil:
[ctxt tempAt: 2 put: true.
unwindBlock := ctxt tempAt: 1.
thisContext terminateTo: ctxt.
unwindBlock value].
ctxt := ctxt findNextUnwindContextUpTo: self].
thisContext terminateTo: self.
^value
!
Item was changed:
----- Method: Context>>return:from: (in category 'instruction decoding') -----
return: value from: aSender
"For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self"
| newTop |
aSender isDead ifTrue:
[^self send: #cannotReturn: to: self with: {value}].
newTop := aSender sender.
(self findNextUnwindContextUpTo: newTop) ifNotNil:
+ [^self send: #aboutToReturn:through: to: self with: {value. [thisContext findNextUnwindContextUpTo: newTop]}].
- [^self send: #aboutToReturn:through: to: self with: {value. nil}].
self releaseTo: newTop.
newTop ifNotNil: [newTop push: value].
^newTop!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox:
http://source.squeak.org/treated/Kernel-jar.1421.mcz
==================== Summary ====================
Name: Kernel-jar.1421
Author: jar
Time: 15 November 2021, 2:01:40.493442 am
UUID: a0158f6a-ffeb-4946-bd0a-25ac6b1947d5
Ancestors: Kernel-eem.1420
Fix a bug: when debugging things like this:
[^2] ensure: [Transcript cr; show: 'done']
if we step into the protected block [^2] and then step over ^2, we incorrectly get a lockCannotReturn. The bug is described in detail in Kernel-nice.1407 and discussed in http://forum.world.st/stepping-over-non-local-return-in-a-protected-block-t…
Add a flag and an explanatory comment.
Supersedes Kernel-jar.1413; please kindly remove from the Inbox
=============== Diff against Kernel-eem.1420 ===============
Item was changed:
----- Method: Context>>resume:through: (in category 'controlling') -----
resume: value through: firstUnwindCtxt
"Unwind thisContext to self and resume with value as result of last send.
Execute any unwind blocks while unwinding.
ASSUMES self is a sender of thisContext."
| ctxt unwindBlock |
+ self flag: #simulator. "jar: see Note below"
self isDead ifTrue: [self cannotReturn: value to: self].
+ ctxt := firstUnwindCtxt ifNil: [thisContext findNextUnwindContextUpTo: self].
- ctxt := firstUnwindCtxt.
[ctxt isNil] whileFalse:
[(ctxt tempAt: 2) ifNil:
[ctxt tempAt: 2 put: true.
unwindBlock := ctxt tempAt: 1.
thisContext terminateTo: ctxt.
unwindBlock value].
ctxt := ctxt findNextUnwindContextUpTo: self].
thisContext terminateTo: self.
^value
+
+ "Note (11/2021): when debugging things like this:
+ [^2] ensure: [Transcript cr; show: 'done']
+ if we step into the protected block [^2] and then step over ^2, we incorrectly get a BlockCannotReturn.
+ To avoid this bug, a close interplay between #return:from: and #resume:through: has been established:
+ During simulation, #return:from: passes firstUnwindCtxt = nil to #aboutToReturn:through: which then
+ propagates to resume:through: and causes a fresh search for the first unwind context. The matter has
+ been discussed in http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-August/216214.h…"!
- !
Item was changed:
----- Method: Context>>return:from: (in category 'instruction decoding') -----
return: value from: aSender
"For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self"
| newTop |
+ self flag: #simulator. "jar: see Note below"
aSender isDead ifTrue:
[^self send: #cannotReturn: to: self with: {value}].
newTop := aSender sender.
(self findNextUnwindContextUpTo: newTop) ifNotNil:
+ [^self send: #aboutToReturn:through: to: self with: {value. nil}].
- [:unwindProtectCtxt|
- ^self send: #aboutToReturn:through: to: self with: {value. unwindProtectCtxt}].
self releaseTo: newTop.
newTop ifNotNil: [newTop push: value].
+ ^newTop
+
+ "Note (11/2021): when debugging things like this:
+ [^2] ensure: [Transcript cr; show: 'done']
+ if we step into the protected block [^2] and then step over ^2, we incorrectly get a BlockCannotReturn.
+ To avoid this bug, a close interplay between #return:from: and #resume:through: has been established:
+ During simulation, #return:from: passes firstUnwindCtxt = nil to #aboutToReturn:through: which then
+ propagates to resume:through: and causes a fresh search for the first unwind context. The matter has
+ been discussed in http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-August/216214.h…"!
- ^newTop!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox:
http://source.squeak.org/treated/Kernel-jar.1447.mcz
==================== Summary ====================
Name: Kernel-jar.1447
Author: jar
Time: 22 February 2022, 8:18:05.479858 pm
UUID: 3772b6a0-c6ab-634c-97bb-a82bda2ecb6a
Ancestors: Kernel-eem.1444
#terminate - latest version working independently of the revised suspend semantics in the latest VMs; structured similarly as original versions of #terminate in Squeak 1.x thru 3.5
supersede Kernel-jar.1443; please remove Kernel-jar.1443, Kernel-jar.1442, Kernel-jar.1437, Kernel-jar.1436, Kernel-jar.1435, Kernel-jar.1426
=============== Diff against Kernel-eem.1444 ===============
Item was added:
+ ----- Method: Context>>releaseCriticalSection: (in category 'private') -----
+ releaseCriticalSection: oldList
+ "Figure out if we are terminating a process that is in the ensure: block of a critical section.
+ In this case, if it hasn't made progress but is beyond the wait (which we can tell by the oldList
+ being one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure:
+ block needs to be run."
+
+ | selectorJustSent |
+ (self method pragmaAt: #criticalSection) ifNil: [^self].
+ (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self].
+ selectorJustSent := self selectorJustSentOrSelf.
+
+ "If still at the wait the ensure: block has not been activated, so signal to restore."
+ selectorJustSent == #wait ifTrue:
+ [self receiver signal].
+
+ "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false)
+ then the ensure block has not been activated, so explicitly run primitiveExitCriticalSection to unlock."
+ (selectorJustSent == #primitiveEnterCriticalSection
+ or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue:
+ [(self stackPtr > 0
+ and: [self top == false]) ifTrue:
+ [self receiver primitiveExitCriticalSection]]!
Item was added:
+ ----- Method: Context>>runUntilReturnFrom: (in category 'private-exceptions') -----
+ runUntilReturnFrom: aContext
+ "Run the receiver (which must be its stack top context) until aContext returns. Avoid a context that cannot return.
+ Note: to avoid infinite recursion of MNU error inside unwind blocks, implement e.g. a wrapper around the message
+ sentTo: receiver in #doesNotUnderstand:. Note: This method is a trivialized version of #runUntilErrorOrReturnFrom:
+ and was intended to be used by #unwindTo as a helper method to unwind non-local returns inside unwind blocks."
+
+ | here unwindBottom newTop |
+ here := thisContext.
+ "Avoid a context that cannot return (see Note 1 below)"
+ unwindBottom := (self findContextSuchThat: [:ctx | ctx selector = #cannotReturn:]) ifNil: [aContext].
+ newTop := aContext sender.
+ "Insert ensure context under unwindBottom in self's stack (see Note 2 below)"
+ unwindBottom insertSender: (Context contextEnsure: [here jump]).
+ self jump. "Control jumps to the receiver's stack (see Note 2 below)"
+ "Control resumes here once the above inserted ensure block is executed (see #jump comments)"
+ ^newTop "Return the new top context (see Note 3 below)"
+
+ "Note 1: returning from #cannotReturn's sender would crash the VM so we install a guard ensure context right
+ above it; after returning here the unwind will continue safely. Try running and debugging this example
+ (avoid Proceeding the BCR error though; it may indeed crash the image):
+ [[[] ensure: [^2]] ensure: [^42]] fork"
+
+ "Note 2: the receiver (self) is run by jumping directly to it (the active process abandons thisContext and executes
+ self on its own stack; self must be its top context). However, before jumping to self we insert an ensure block under
+ unwindBottom context that will execute a jump back to thisContext when evaluated. The inserted guard ensure
+ context is removed once control jumps back to thisContext."
+
+ "Note 3: it doesn't matter newTop is not a proper stack top context because #unwindTo will only use it as a starting
+ point in the search for the next unwind context and the computation will never return here. We could make newTop
+ a proper top context by pushing nil to its stack (^newTop push: nil) if need be (see #jump comments).
+ Cf. the pattern in #runUntilErrorOrReturnFrom:: removing the inserted ensure context by stepping until popped
+ when executing non-local returns wouldn't work here and would fail tests testTerminateInNestedEnsureWithReturn1
+ through 4."!
Item was changed:
----- Method: Context>>unwindTo: (in category 'private-exceptions') -----
unwindTo: aContext
+ "Unwind the receiver to aContext to execute all pending unwind blocks."
+ self unwindTo: aContext safely: true!
- | ctx unwindBlock |
- ctx := self.
- [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [
- (ctx tempAt: 2) ifNil:[
- ctx tempAt: 2 put: true.
- unwindBlock := ctx tempAt: 1.
- unwindBlock value]
- ].
- !
Item was added:
+ ----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') -----
+ unwindTo: aContext safely: aBoolean
+ "Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self
+ and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all
+ pending unwind blocks including those currently in the middle of their execution; these blocks will
+ just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:."
+
+ | top ctx |
+ ctx := top := self.
+ aBoolean ifTrue: [
+ "If self is a top context of a stack already halfways through an unwind, complete the outer-most
+ unfinished unwind block first; all nested pending unwind blocks will be completed in the process;
+ see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest.
+ Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their
+ defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one."
+ | outerMost |
+ ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext].
+ [ctx isNil] whileFalse: [
+ (ctx tempAt:2) ifNotNil: [
+ outerMost := ctx].
+ ctx := ctx findNextUnwindContextUpTo: aContext].
+ outerMost ifNotNil: [top := (top runUntilReturnFrom: outerMost) sender]].
+ "By now no halfway-through unwind blocks are on the stack.
+ Note: top points to the former outerMost sender now, i.e. to the next context to be explored."
+
+ ctx := top.
+ "#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check
+ the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop.
+ Create a new top context (i.e. a new branch off the original stack) for each pending unwind block
+ (ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly."
+ ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext].
+ [ctx isNil] whileFalse: [
+ (ctx tempAt: 2) ifNil: [
+ ctx tempAt: 2 put: true.
+ top := (ctx tempAt: 1) asContextWithSender: ctx. "see the note below"
+ top runUntilReturnFrom: top].
+ ctx := ctx findNextUnwindContextUpTo: aContext]
+ "Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value
+ instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly;
+ a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."!
Item was changed:
----- Method: Process>>terminate (in category 'changing process state') -----
terminate
+ "Stop the process that the receiver represents forever.
+ Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating;
+ allow all unwind blocks to run; if they are currently in progress, let them finish.
+ If the process is in the middle of a #critical: critical section, release it properly."
+
+ "This is the kind of behavior we expect when terminating a healthy process.
+ See further comments in #terminateAggressively and #destroy methods dealing
+ with process termination when closing the debugger or after a catastrophic failure."
+
+ "If terminating the active process, create a parallel stack and run unwinds from there;
+ if terminating a suspended process, again, create a parallel stack for the process being
+ terminated and resume the suspended process to complete its termination from the new
+ parallel stack. Use a priority higher than the active priority to make the process that
+ invoked the termination wait for its completion."
- "Stop the receiver forever.
- Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack, even if they are currently in progress. If already active unwind contexts should not be continued, send #terminateAggressively instead.
- Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice.
- If the process is in the middle of a critical section, release it properly."
+ "If terminating a suspended process (including runnable and blocked), always suspend
+ the terminating process first so it doesn't accidentally get woken up. Equally important is
+ the side effect of the suspension; In 2022 a new suspend semantics has been introduced:
+ the revised #suspend backs up a process waiting on a conditional variable to the send that
+ invoked the wait state, while the pre-2022 #suspend simply removed the process from
+ the conditional variable's list it was previously waiting on; see Process>>suspend comments.
+ Release any method marked with the <criticalSection> pragma via #releaseCriticalSection[:].
+ Execute termination in the ensure argument block to ensure it completes even if the
+ terminator process itself gets terminated before it's finished; see testTerminateInTerminate."
+
+ | context |
- | ctxt unwindBlock oldList outerMost |
self isActiveProcess ifTrue: [
+ context := thisContext.
+ ^[context unwindTo: nil. self suspend] asContext jump].
- "If terminating the active process, suspend it first and terminate it as a suspended process."
- [self terminate] fork.
- ^self suspend].
+ [] ensure: [ | oldList |
+ oldList := myList.
+ self suspend.
+ context := suspendedContext ifNil: [^self].
+ suspendedContext := [
+ context releaseCriticalSection: oldList; unwindTo: nil.
+ self suspend] asContext.
+ self priority: Processor activePriority + 1; resume]!
- "Always suspend the process first so it doesn't accidentally get woken up.
- N.B. If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al
- then the process is blocked, and if it is nil then the process is already suspended."
- oldList := self suspend.
- suspendedContext ifNotNil:
- ["Release any method marked with the <criticalSection> pragma.
- The argument is whether the process is runnable."
- self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]).
-
- "If terminating a process halfways through an unwind, try to complete that unwind block first;
- if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner
- blocks will be completed in the process."
- ctxt := suspendedContext.
- [(ctxt := ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse:
- "Contexts under evaluation have already set their complete (tempAt: 2) to true."
- [(ctxt tempAt:2) ifNotNil: [outerMost := ctxt]].
- outerMost ifNotNil: [
- "This is the outer-most unwind context currently under evaluation;
- let's find an inner context executing outerMost's argument block (tempAt: 1)"
- (suspendedContext findContextSuchThat: [:ctx |
- ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner |
- "Let's finish the unfinished unwind context only (i.e. up to inner) and return here"
- suspendedContext runUntilErrorOrReturnFrom: inner.
- "Update the receiver's suspendedContext (the previous step reset its sender to nil);
- return, if the execution stack reached its bottom (e.g. in case of non-local returns)."
- (suspendedContext := outerMost sender) ifNil: [^self]]].
-
- "Now all unwind blocks caught halfway through have been completed;
- let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts
- searching from the receiver's sender but the receiver itself may be an unwind context."
- ctxt := suspendedContext.
- ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil].
- [ctxt isNil] whileFalse: [
- (ctxt tempAt: 2) ifNil: [
- ctxt tempAt: 2 put: true.
- unwindBlock := ctxt tempAt: 1.
- "Create a context for the unwind block and execute it on the unwind block's stack.
- Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing
- the unwind on the wrong stack preventing the correct execution of non-local returns."
- suspendedContext := unwindBlock asContextWithSender: ctxt.
- suspendedContext runUntilErrorOrReturnFrom: suspendedContext].
- ctxt := ctxt findNextUnwindContextUpTo: nil].
-
- "Reset the context's pc and sender to nil for the benefit of isTerminated."
- suspendedContext terminate]!
1
0