The Trunk: KernelTests-pre.360.mcz
Locked
 
|
Patrick Rein uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-pre.360.mcz ==================== Summary ==================== Name: KernelTests-pre.360 Author: pre Time: 30 April 2019, 7:43:10.229008 pm UUID: 539584fb-f990-6449-bbb4-f09596a4501b Ancestors: KernelTests-pre.359 Recategorizes test methods in KernelTests =============== Diff against KernelTests-pre.359 =============== Item was changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testBehaviorClassClassDescriptionMetaclassHierarchy (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testBehaviorClassClassDescriptionMetaclassHierarchy (in category 'testing') ----- 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 changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testClassDescriptionAllSubInstances (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testClassDescriptionAllSubInstances (in category 'testing') ----- 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 changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclass (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclass (in category 'testing') ----- testMetaclass "self run: #testMetaclass" self assert: OrderedCollection class class == Metaclass. self assert: Dictionary class class == Metaclass. self assert: Object class class == Metaclass. ! Item was changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassName (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassName (in category 'testing') ----- testMetaclassName "self run: #testMetaclassName" self assert: Dictionary class name = 'Dictionary class'. self assert: OrderedCollection class name = 'OrderedCollection class'. ! Item was changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassNumberOfInstances (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassNumberOfInstances (in category 'testing') ----- testMetaclassNumberOfInstances "self run: #testMetaclassNumberOfInstances" self assert: Dictionary class allInstances size = 1. self assert: OrderedCollection class allInstances size = 1.! Item was changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassPointOfCircularity (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassPointOfCircularity (in category 'testing') ----- testMetaclassPointOfCircularity "self run: #testMetaclassPointOfCircularity" self assert: Metaclass class instanceCount = 1. self assert: Metaclass class someInstance == Metaclass. ! Item was changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclass (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclass (in category 'testing') ----- testMetaclassSuperclass "self run: #testMetaclassSuperclass" self assert: Dictionary class superclass == HashedCollection class. self assert: OrderedCollection class superclass == SequenceableCollection class. ! Item was changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclassHierarchy (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclassHierarchy (in category 'testing') ----- 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 changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testObjectAllSubclasses (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testObjectAllSubclasses (in category 'testing') ----- 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 changed: + ----- Method: BasicBehaviorClassMetaclassTest>>testSuperclass (in category 'tests') ----- - ----- Method: BasicBehaviorClassMetaclassTest>>testSuperclass (in category 'testing') ----- 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 changed: + ----- Method: CategorizerTest>>testClassifyNewElementNewCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testClassifyNewElementNewCategory (in category 'testing') ----- testClassifyNewElementNewCategory categorizer classify: #f under: #nice. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) (''unreal'') (''nice'' f) '! Item was changed: + ----- Method: CategorizerTest>>testClassifyNewElementOldCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testClassifyNewElementOldCategory (in category 'testing') ----- testClassifyNewElementOldCategory categorizer classify: #f under: #unreal. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) (''unreal'' f) '! Item was changed: + ----- Method: CategorizerTest>>testClassifyOldElementNewCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testClassifyOldElementNewCategory (in category 'testing') ----- testClassifyOldElementNewCategory categorizer classify: #e under: #nice. self assert: categorizer printString = '(''as yet unclassified'' d) (''abc'' a b c) (''unreal'') (''nice'' e) '! Item was changed: + ----- Method: CategorizerTest>>testClassifyOldElementOldCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testClassifyOldElementOldCategory (in category 'testing') ----- testClassifyOldElementOldCategory categorizer classify: #e under: #unreal. self assert: categorizer printString = '(''as yet unclassified'' d) (''abc'' a b c) (''unreal'' e) '! Item was changed: + ----- Method: CategorizerTest>>testDefaultCategoryIsTransient (in category 'tests') ----- - ----- Method: CategorizerTest>>testDefaultCategoryIsTransient (in category 'testing') ----- 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 changed: + ----- Method: CategorizerTest>>testNoSpecialCategories (in category 'tests') ----- - ----- Method: CategorizerTest>>testNoSpecialCategories (in category 'testing') ----- 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 changed: + ----- Method: CategorizerTest>>testNullCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testNullCategory (in category 'testing') ----- 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 changed: + ----- Method: CategorizerTest>>testRemoveEmptyCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testRemoveEmptyCategory (in category 'testing') ----- testRemoveEmptyCategory categorizer removeCategory: #unreal. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) '! Item was changed: + ----- Method: CategorizerTest>>testRemoveExistingElement (in category 'tests') ----- - ----- Method: CategorizerTest>>testRemoveExistingElement (in category 'testing') ----- testRemoveExistingElement categorizer removeElement: #a. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' b c) (''unreal'') '! Item was changed: + ----- Method: CategorizerTest>>testRemoveNonEmptyCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testRemoveNonEmptyCategory (in category 'testing') ----- testRemoveNonEmptyCategory self should: [categorizer removeCategory: #abc] raise: Error. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) (''unreal'') '! Item was changed: + ----- Method: CategorizerTest>>testRemoveNonExistingCategory (in category 'tests') ----- - ----- Method: CategorizerTest>>testRemoveNonExistingCategory (in category 'testing') ----- testRemoveNonExistingCategory categorizer removeCategory: #nice. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) (''unreal'') '! Item was changed: + ----- Method: CategorizerTest>>testRemoveNonExistingElement (in category 'tests') ----- - ----- Method: CategorizerTest>>testRemoveNonExistingElement (in category 'testing') ----- testRemoveNonExistingElement categorizer removeElement: #f. self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) (''unreal'') '! Item was changed: + ----- Method: CategorizerTest>>testRemoveThenRename (in category 'tests') ----- - ----- Method: CategorizerTest>>testRemoveThenRename (in category 'testing') ----- testRemoveThenRename categorizer removeCategory: #unreal. categorizer renameCategory: #abc toBe: #unreal. self assert: categorizer printString = '(''as yet unclassified'' d e) (''unreal'' a b c) '! Item was changed: + ----- Method: CategorizerTest>>testUnchanged (in category 'tests') ----- - ----- Method: CategorizerTest>>testUnchanged (in category 'testing') ----- testUnchanged self assert: categorizer printString = '(''as yet unclassified'' d e) (''abc'' a b c) (''unreal'') '! Item was changed: + ----- Method: ClassBuilderTest>>testByteVariableSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testByteVariableSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testChangeToVariableSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testChangeToVariableSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testCompiledMethodSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testCompiledMethodSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testDoubleByteVariableSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testDoubleByteVariableSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testDoubleWordVariableSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testDoubleWordVariableSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testDuplicateClassVariableError (in category 'tests - reshape') ----- - ----- Method: ClassBuilderTest>>testDuplicateClassVariableError (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testDuplicateInstanceVariableError (in category 'tests - reshape') ----- - ----- Method: ClassBuilderTest>>testDuplicateInstanceVariableError (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testMoveVarFromSubToSuperclass (in category 'tests - reshape') ----- - ----- Method: ClassBuilderTest>>testMoveVarFromSubToSuperclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testMoveVarFromSuperToSubclass (in category 'tests - reshape') ----- - ----- Method: ClassBuilderTest>>testMoveVarFromSuperToSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testNewUniclass (in category 'tests - uniclass') ----- - ----- Method: ClassBuilderTest>>testNewUniclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testSubclassWithInstanceVariables (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testSubclassWithInstanceVariables (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testVariableSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testVariableSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testWeakSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testWeakSubclass (in category 'testing - 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 changed: + ----- Method: ClassBuilderTest>>testWordVariableSubclass (in category 'tests - format') ----- - ----- Method: ClassBuilderTest>>testWordVariableSubclass (in category 'testing - 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 changed: + ----- Method: ClassTest>>testAddInstVarName (in category 'tests') ----- - ----- Method: ClassTest>>testAddInstVarName (in category 'testing') ----- 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 changed: + ----- Method: ClassTest>>testChangeClassOf (in category 'tests') ----- - ----- Method: ClassTest>>testChangeClassOf (in category 'testing') ----- 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: [Inspector new primitiveChangeClassTo: CompiledMethodInspector new] raise: Error! Item was changed: + ----- Method: ClassTest>>testCompileAll (in category 'tests - compiling') ----- - ----- Method: ClassTest>>testCompileAll (in category 'testing - compiling') ----- testCompileAll "We expect this to succeed." ClassTest compileAll.! Item was changed: + ----- Method: ClassTest>>testRenaming (in category 'tests') ----- - ----- Method: ClassTest>>testRenaming (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTest>>expectedFailures (in category 'failures') ----- - ----- Method: CompiledMethodTest>>expectedFailures (in category 'testing') ----- expectedFailures Smalltalk isRunningCog ifTrue: [ ^super expectedFailures ]. ^#( "Not supported by the interpreter VM. See method comments for details" testPerformInSuperclassCanExecutelongMethodWithTemps )! Item was changed: + ----- Method: CompiledMethodTrailerTest>>testEmbeddingSourceCode (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testEmbeddingSourceCode (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTrailerTest>>testEmbeddingTempNames (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testEmbeddingTempNames (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTrailerTest>>testEncodingNoTrailer (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testEncodingNoTrailer (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTrailerTest>>testEncodingSourcePointer (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testEncodingSourcePointer (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTrailerTest>>testEncodingVarLengthSourcePointer (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testEncodingVarLengthSourcePointer (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTrailerTest>>testSourceByIdentifierEncoding (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testSourceByIdentifierEncoding (in category 'testing') ----- 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 changed: + ----- Method: CompiledMethodTrailerTest>>testSourceBySelectorEncoding (in category 'tests') ----- - ----- Method: CompiledMethodTrailerTest>>testSourceBySelectorEncoding (in category 'testing') ----- 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 changed: + ----- Method: ComplexTest>>testBug1 (in category 'tests - bugs') ----- - ----- Method: ComplexTest>>testBug1 (in category 'testing - bugs') ----- testBug1 self assert: (0.5 * (2+0i) ln) exp = (0.5 * 2 ln) exp.! Item was changed: + ----- Method: ComplexTest>>testEquality (in category 'tests') ----- - ----- Method: ComplexTest>>testEquality (in category 'testing') ----- 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 changed: + ----- Method: DelayTest>>testBounds (in category 'tests - limits') ----- - ----- Method: DelayTest>>testBounds (in category 'testing-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 changed: + ----- Method: DelayTest>>testMultiProcessWaitOnSameDelay (in category 'tests - limits') ----- - ----- Method: DelayTest>>testMultiProcessWaitOnSameDelay (in category 'testing-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 changed: + ----- Method: DelayTest>>testMultiSchedule (in category 'tests - limits') ----- - ----- Method: DelayTest>>testMultiSchedule (in category 'testing-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 changed: + ----- Method: DependentsArrayTest>>testAddingTwice (in category 'tests') ----- - ----- Method: DependentsArrayTest>>testAddingTwice (in category 'testing') ----- 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 changed: + ----- Method: DependentsArrayTest>>testCanDiscardEdits (in category 'tests') ----- - ----- Method: DependentsArrayTest>>testCanDiscardEdits (in category 'testing') ----- 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 changed: + ----- Method: DependentsArrayTest>>testSize (in category 'tests') ----- - ----- Method: DependentsArrayTest>>testSize (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testFractionPartWithoutIntegerPart (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testFractionPartWithoutIntegerPart (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testIntegerPartWithoutFraction (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testIntegerPartWithoutFraction (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testInvalidExponent (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testInvalidExponent (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testInvalidRadix (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testInvalidRadix (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testInvalidScale (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testInvalidScale (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testPositive (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testPositive (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testPositiveExponent (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testPositiveExponent (in category 'testing') ----- 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 changed: + ----- Method: ExtendedNumberParserTest>>testUppercaseExponent (in category 'tests') ----- - ----- Method: ExtendedNumberParserTest>>testUppercaseExponent (in category 'testing') ----- 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 changed: + ----- Method: FloatTest>>assertIsNegativeZero: (in category 'asserting') ----- - ----- Method: FloatTest>>assertIsNegativeZero: (in category 'accessing') ----- assertIsNegativeZero: aFloat "Assert that aFloat is Float negativeZero" self assert: aFloat = 0.0. self assert: aFloat signBit = 1! Item was changed: + ----- Method: FloatTest>>assertIsPositiveZero: (in category 'asserting') ----- - ----- Method: FloatTest>>assertIsPositiveZero: (in category 'accessing') ----- assertIsPositiveZero: aFloat "Assert that aFloat is Float zero (the positive one)" self assert: aFloat = 0.0. self assert: aFloat signBit = 0! Item was changed: + ----- Method: FloatTest>>test32bitGradualUnderflow (in category 'tests - IEEE 754') ----- - ----- Method: FloatTest>>test32bitGradualUnderflow (in category '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 changed: + ----- Method: FloatTest>>test32bitRoundingMode (in category 'tests - IEEE 754') ----- - ----- Method: FloatTest>>test32bitRoundingMode (in category '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 changed: + ----- Method: FloatTest>>testCeiling (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testCeiling (in category 'testing - 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 changed: + ----- Method: FloatTest>>testCharacterization (in category 'tests - characterization') ----- - ----- Method: FloatTest>>testCharacterization (in category '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 changed: + ----- Method: FloatTest>>testCloseTo (in category 'tests - compare') ----- - ----- Method: FloatTest>>testCloseTo (in category 'testing 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 changed: + ----- Method: FloatTest>>testComparison (in category 'tests - compare') ----- - ----- Method: FloatTest>>testComparison (in category 'testing 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 changed: + ----- Method: FloatTest>>testComparisonWhenPrimitiveFails (in category 'tests - compare') ----- - ----- Method: FloatTest>>testComparisonWhenPrimitiveFails (in category 'testing 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 changed: + ----- Method: FloatTest>>testContinuedFractions (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testContinuedFractions (in category 'testing - arithmetic') ----- testContinuedFractions self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7). self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)! Item was changed: + ----- Method: FloatTest>>testCopy (in category 'tests') ----- - ----- Method: FloatTest>>testCopy (in category 'testing') ----- 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 changed: + ----- Method: FloatTest>>testCopySign (in category 'tests - zero behavior') ----- - ----- Method: FloatTest>>testCopySign (in category '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 changed: + ----- Method: FloatTest>>testDivide (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testDivide (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFloatRounded (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFloatRounded (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFloatTruncated (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFloatTruncated (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFloor (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFloor (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFractionAsExactFloat (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFractionAsExactFloat (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFractionAsFloat (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFractionAsFloat (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFractionAsFloat2 (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFractionAsFloat2 (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFractionAsFloatWithUnderflow (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFractionAsFloatWithUnderflow (in category 'testing - 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 changed: + ----- Method: FloatTest>>testFractionIsAnExactFloat (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testFractionIsAnExactFloat (in category 'testing - 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 changed: + ----- Method: FloatTest>>testHugeIntegerCloseTo (in category 'tests - infinity behavior') ----- - ----- Method: FloatTest>>testHugeIntegerCloseTo (in category '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 changed: + ----- Method: FloatTest>>testInfinity1 (in category 'tests - infinity behavior') ----- - ----- Method: FloatTest>>testInfinity1 (in category '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 changed: + ----- Method: FloatTest>>testInfinity2 (in category 'tests - infinity behavior') ----- - ----- Method: FloatTest>>testInfinity2 (in category '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 changed: + ----- Method: FloatTest>>testInfinity3 (in category 'tests - IEEE 754') ----- - ----- Method: FloatTest>>testInfinity3 (in category '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 changed: + ----- Method: FloatTest>>testInfinityCloseTo (in category 'tests - infinity behavior') ----- - ----- Method: FloatTest>>testInfinityCloseTo (in category '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 changed: + ----- Method: FloatTest>>testIntegerAsFloat (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testIntegerAsFloat (in category 'testing - 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 changed: + ----- Method: FloatTest>>testIsZero (in category 'tests - zero behavior') ----- - ----- Method: FloatTest>>testIsZero (in category 'zero behavior') ----- testIsZero self assert: 0.0 isZero. self deny: 0.1 isZero.! Item was changed: + ----- Method: FloatTest>>testLargeIntegerIsAnExactFloat (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testLargeIntegerIsAnExactFloat (in category 'testing - 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 changed: + ----- Method: FloatTest>>testLiteralEqualityOfNan (in category 'tests - compare') ----- - ----- Method: FloatTest>>testLiteralEqualityOfNan (in category 'testing 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 changed: + ----- Method: FloatTest>>testLiteralEqualityOfZeroAndNegativeZero (in category 'tests - compare') ----- - ----- Method: FloatTest>>testLiteralEqualityOfZeroAndNegativeZero (in category 'testing 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 changed: + ----- Method: FloatTest>>testMaxExactInteger (in category 'tests') ----- - ----- Method: FloatTest>>testMaxExactInteger (in category 'testing') ----- 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 changed: + ----- Method: FloatTest>>testNaN1 (in category 'tests - NaN behavior') ----- - ----- Method: FloatTest>>testNaN1 (in category '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 changed: + ----- Method: FloatTest>>testNaN2 (in category 'tests - NaN behavior') ----- - ----- Method: FloatTest>>testNaN2 (in category '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 changed: + ----- Method: FloatTest>>testNaN3 (in category 'tests - NaN behavior') ----- - ----- Method: FloatTest>>testNaN3 (in category '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 changed: + ----- Method: FloatTest>>testNaN4 (in category 'tests - NaN behavior') ----- - ----- Method: FloatTest>>testNaN4 (in category '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 changed: + ----- Method: FloatTest>>testNaN5 (in category 'tests - IEEE 754') ----- - ----- Method: FloatTest>>testNaN5 (in category '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 changed: + ----- Method: FloatTest>>testNaNCompare (in category 'tests - NaN behavior') ----- - ----- Method: FloatTest>>testNaNCompare (in category '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 changed: + ----- Method: FloatTest>>testNaNisLiteral (in category 'tests - NaN behavior') ----- - ----- Method: FloatTest>>testNaNisLiteral (in category 'NaN behavior') ----- testNaNisLiteral self deny: Float nan isLiteral description: 'there is no literal representation of NaN'! Item was changed: + ----- Method: FloatTest>>testNegativeZeroAbs (in category 'tests - zero behavior') ----- - ----- Method: FloatTest>>testNegativeZeroAbs (in category 'zero behavior') ----- testNegativeZeroAbs self assert: Float negativeZero abs signBit = 0 description: 'the absolute value of a negative zero is zero'! Item was changed: + ----- Method: FloatTest>>testNegativeZeroSign (in category 'tests - zero behavior') ----- - ----- Method: FloatTest>>testNegativeZeroSign (in category '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 changed: + ----- Method: FloatTest>>testPrintPaddedWithTo (in category 'tests - printing') ----- - ----- Method: FloatTest>>testPrintPaddedWithTo (in category '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 changed: + ----- Method: FloatTest>>testReadFromManyDigits (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testReadFromManyDigits (in category 'testing - 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 changed: + ----- Method: FloatTest>>testReciprocal (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testReciprocal (in category 'testing - 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 changed: + ----- Method: FloatTest>>testRounded (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testRounded (in category 'testing - 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 changed: + ----- Method: FloatTest>>testSetOfFloat (in category 'tests') ----- - ----- Method: FloatTest>>testSetOfFloat (in category 'testing') ----- 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 changed: + ----- Method: FloatTest>>testSign (in category 'tests') ----- - ----- Method: FloatTest>>testSign (in category 'testing') ----- 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 changed: + ----- Method: FloatTest>>testSignificandAndExponent (in category 'tests - characterization') ----- - ----- Method: FloatTest>>testSignificandAndExponent (in category '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 changed: + ----- Method: FloatTest>>testSignificandAsInteger (in category 'tests - characterization') ----- - ----- Method: FloatTest>>testSignificandAsInteger (in category '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 changed: + ----- Method: FloatTest>>testStoreBase16 (in category 'tests - printing') ----- - ----- Method: FloatTest>>testStoreBase16 (in category '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 changed: + ----- Method: FloatTest>>testStoreOn (in category 'tests') ----- - ----- Method: FloatTest>>testStoreOn (in category 'testing') ----- 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 changed: + ----- Method: FloatTest>>testStringAsNumber (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testStringAsNumber (in category 'testing - 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 changed: + ----- Method: FloatTest>>testTimesTwoPowerGradualUnderflow (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testTimesTwoPowerGradualUnderflow (in category 'testing - 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 changed: + ----- Method: FloatTest>>testTimesTwoPowerOverflow (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testTimesTwoPowerOverflow (in category 'testing - 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 changed: + ----- Method: FloatTest>>testTimesTwoPowerUnderflow (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testTimesTwoPowerUnderflow (in category 'testing - 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 changed: + ----- Method: FloatTest>>testTruncated (in category 'tests - conversion') ----- - ----- Method: FloatTest>>testTruncated (in category 'testing - 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 changed: + ----- Method: FloatTest>>testUlp (in category 'tests - characterization') ----- - ----- Method: FloatTest>>testUlp (in category '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 changed: + ----- Method: FloatTest>>testZero1 (in category 'tests - zero behavior') ----- - ----- Method: FloatTest>>testZero1 (in category '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 changed: + ----- Method: FloatTest>>testZero2 (in category 'tests - IEEE 754') ----- - ----- Method: FloatTest>>testZero2 (in category '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 changed: + ----- Method: FloatTest>>testZeroRaisedToNegativePower (in category 'tests - arithmetic') ----- - ----- Method: FloatTest>>testZeroRaisedToNegativePower (in category 'testing - 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 changed: + ----- Method: IntegerTest>>testCrossSumBase (in category 'tests - arithmetic') ----- - ----- Method: IntegerTest>>testCrossSumBase (in category 'testing - 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 changed: + ----- Method: IntegerTest>>testIntegerDivision (in category 'tests - arithmetic') ----- - ----- Method: IntegerTest>>testIntegerDivision (in category 'testing - 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 changed: + ----- Method: IntegerTest>>testMontgomeryMultiplication (in category 'tests - arithmetic') ----- - ----- Method: IntegerTest>>testMontgomeryMultiplication (in category 'testing - 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 changed: + ----- Method: IntegerTest>>testQuoRem (in category 'tests - arithmetic') ----- - ----- Method: IntegerTest>>testQuoRem (in category 'testing - 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 changed: + ----- Method: IntegerTest>>testRaisedToModulo (in category 'tests - arithmetic') ----- - ----- Method: IntegerTest>>testRaisedToModulo (in category 'testing - 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 changed: + ----- Method: IntegerTest>>testReciprocalModulo (in category 'tests - arithmetic') ----- - ----- Method: IntegerTest>>testReciprocalModulo (in category 'testing - 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 changed: + ----- Method: MessageSendTest>>testNumArgs (in category 'tests') ----- - ----- Method: MessageSendTest>>testNumArgs (in category 'as yet unclassified') ----- testNumArgs self assert: (MessageSend receiver: Dictionary new selector: #at:put:) numArgs = 2 ; assert: (MessageSend receiver: 3 selector: #sqrt) numArgs = 0! Item was changed: + ----- Method: MethodPragmaTest>>testAllNamedFromTo (in category 'tests-finding') ----- - ----- Method: MethodPragmaTest>>testAllNamedFromTo (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testAllNamedFromToSortedByArgument (in category 'tests-finding') ----- - ----- Method: MethodPragmaTest>>testAllNamedFromToSortedByArgument (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testAllNamedFromToSortedUsing (in category 'tests-finding') ----- - ----- Method: MethodPragmaTest>>testAllNamedFromToSortedUsing (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testAllNamedIn (in category 'tests-finding') ----- - ----- Method: MethodPragmaTest>>testAllNamedIn (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testAllNamedInSortedByArgument (in category 'tests-finding') ----- - ----- Method: MethodPragmaTest>>testAllNamedInSortedByArgument (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testAllNamedInSortedUsing (in category 'tests-finding') ----- - ----- Method: MethodPragmaTest>>testAllNamedInSortedUsing (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testArguments (in category 'tests-pragma') ----- - ----- Method: MethodPragmaTest>>testArguments (in category 'testing-pragma') ----- testArguments | pragma | pragma := Pragma keyword: #foo: arguments: #( 123 ). self assert: pragma arguments = #( 123 ).! Item was changed: + ----- Method: MethodPragmaTest>>testCompileArray (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileArray (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testCompileBinary (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileBinary (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testCompileCharacter (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileCharacter (in category 'testing-compiler') ----- testCompileCharacter self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ). self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: { Character space }.! Item was changed: + ----- Method: MethodPragmaTest>>testCompileEmpty (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileEmpty (in category 'testing-compiler') ----- testCompileEmpty self assertPragma: 'foo' givesKeyword: #foo arguments: #().! Item was changed: + ----- Method: MethodPragmaTest>>testCompileFull (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileFull (in category 'testing-compiler') ----- testCompileFull self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ). self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).! Item was changed: + ----- Method: MethodPragmaTest>>testCompileInvalid (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileInvalid (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testCompileNumber (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileNumber (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testCompileString (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileString (in category 'testing-compiler') ----- testCompileString self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ). self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).! Item was changed: + ----- Method: MethodPragmaTest>>testCompileSymbol (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileSymbol (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testCompileTemps (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileTemps (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testCompileValue (in category 'tests-compiler') ----- - ----- Method: MethodPragmaTest>>testCompileValue (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testKeyword (in category 'tests-pragma') ----- - ----- Method: MethodPragmaTest>>testKeyword (in category 'testing-pragma') ----- testKeyword | pragma | pragma := Pragma keyword: #foo: arguments: #( 123 ). self assert: pragma keyword = #foo:.! Item was changed: + ----- Method: MethodPragmaTest>>testMessage (in category 'tests-pragma') ----- - ----- Method: MethodPragmaTest>>testMessage (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testMethod (in category 'tests-method') ----- - ----- Method: MethodPragmaTest>>testMethod (in category 'testing-method') ----- testMethod | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma method == (self class >> #bar).! Item was changed: + ----- Method: MethodPragmaTest>>testMethodClass (in category 'tests-method') ----- - ----- Method: MethodPragmaTest>>testMethodClass (in category 'testing-method') ----- testMethodClass | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma methodClass == self class.! Item was changed: + ----- Method: MethodPragmaTest>>testNoPragma (in category 'tests-compiled') ----- - ----- Method: MethodPragmaTest>>testNoPragma (in category 'testing-compiled') ----- testNoPragma | method | method := self compile: '' selector: #foo. self assert: method pragmas = #().! Item was changed: + ----- Method: MethodPragmaTest>>testPrimitiveIndexed1 (in category 'tests-primitives') ----- - ----- Method: MethodPragmaTest>>testPrimitiveIndexed1 (in category 'testing-primitives') ----- testPrimitiveIndexed1 "This test useses the #instVarAt: primitive." self compile: '<primitive: 74> ^ #inst' selector: #inst. self assert: self inst = #inst.! Item was changed: + ----- Method: MethodPragmaTest>>testPrimitiveIndexed2 (in category 'tests-primitives') ----- - ----- Method: MethodPragmaTest>>testPrimitiveIndexed2 (in category 'testing-primitives') ----- testPrimitiveIndexed2 "This test useses the #asOop primitive." self compile: '<primitive: 75> ^ #oop' selector: #oop. self assert: self oop = self asOop.! Item was changed: + ----- Method: MethodPragmaTest>>testPrimitiveNamed1 (in category 'tests-primitives') ----- - ----- Method: MethodPragmaTest>>testPrimitiveNamed1 (in category 'testing-primitives') ----- testPrimitiveNamed1 "This test useses the #primitiveDirectoryLookup primitive." self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin''> ^ #lookup' selector: #lookup. self assert: self lookup = #lookup. ! Item was changed: + ----- Method: MethodPragmaTest>>testPrimitiveNamed2 (in category 'tests-primitives') ----- - ----- Method: MethodPragmaTest>>testPrimitiveNamed2 (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testReformat (in category 'tests-printing-reformating') ----- - ----- Method: MethodPragmaTest>>testReformat (in category 'testing-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 changed: + ----- Method: MethodPragmaTest>>testSelector (in category 'tests-method') ----- - ----- Method: MethodPragmaTest>>testSelector (in category 'testing-method') ----- testSelector | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma selector == #bar.! Item was changed: + ----- Method: MethodPropertiesTest>>testAllMethodsHaveMethodClass (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testAllMethodsHaveMethodClass (in category 'testing') ----- 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 changed: + ----- Method: MethodPropertiesTest>>testAt (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testAt (in category 'testing') ----- 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 changed: + ----- Method: MethodPropertiesTest>>testAtIfAbsent (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testAtIfAbsent (in category 'testing') ----- 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 changed: + ----- Method: MethodPropertiesTest>>testAtIfAbsentPut (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testAtIfAbsentPut (in category 'testing') ----- testAtIfAbsentPut self assert: (method properties at: #zork ifAbsentPut: [ 'hello' ]) = 'hello'. self assert: (method properties at: #zork ifAbsentPut: [ 'hi' ]) = 'hello'.! Item was changed: + ----- Method: MethodPropertiesTest>>testAtPut (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testAtPut (in category 'testing') ----- testAtPut self assert: (method properties at: #zork put: 'hello') = 'hello'. self assert: (method properties at: #zork) = 'hello'.! Item was changed: + ----- Method: MethodPropertiesTest>>testAtPutRepeatedly (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testAtPutRepeatedly (in category 'testing') ----- 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 changed: + ----- Method: MethodPropertiesTest>>testIncludesKey (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testIncludesKey (in category 'testing') ----- 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 changed: + ----- Method: MethodPropertiesTest>>testRemoveKey (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testRemoveKey (in category 'testing') ----- 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 changed: + ----- Method: MethodPropertiesTest>>testRemoveKeyifAbsent (in category 'tests') ----- - ----- Method: MethodPropertiesTest>>testRemoveKeyifAbsent (in category 'testing') ----- 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 changed: + ----- Method: MonitorTest>>testCheckOwnerProcess (in category 'tests') ----- - ----- Method: MonitorTest>>testCheckOwnerProcess (in category 'examples') ----- 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 changed: + ----- Method: MonitorTest>>testCriticalIfLocked (in category 'tests') ----- - ----- Method: MonitorTest>>testCriticalIfLocked (in category 'examples') ----- 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 changed: + ----- Method: MonitorTest>>testExample1 (in category 'tests') ----- - ----- Method: MonitorTest>>testExample1 (in category 'examples') ----- 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 changed: + ----- Method: MonitorTest>>testExample2 (in category 'tests') ----- - ----- Method: MonitorTest>>testExample2 (in category 'examples') ----- 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 changed: + ----- Method: MutexTest>>testCritical (in category 'tests') ----- - ----- Method: MutexTest>>testCritical (in category 'testing') ----- testCritical | lock | lock := Mutex new. [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority. self deny: lock isOwned! Item was changed: + ----- Method: MutexTest>>testCriticalIfError (in category 'tests') ----- - ----- Method: MutexTest>>testCriticalIfError (in category 'testing') ----- testCriticalIfError | lock | lock := Mutex new. [lock critical: [self criticalError ifError: []]] forkAt: Processor userInterruptPriority. self deny: lock isOwned! Item was changed: + ----- Method: MutexTest>>testMutexAfterCriticalWait (in category 'tests') ----- - ----- Method: MutexTest>>testMutexAfterCriticalWait (in category 'testing') ----- 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 changed: + ----- Method: MutexTest>>testMutexCriticalBlockedInEnsure (in category 'tests') ----- - ----- Method: MutexTest>>testMutexCriticalBlockedInEnsure (in category 'testing') ----- 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 changed: + ----- Method: MutexTest>>testMutexInCriticalWait (in category 'tests') ----- - ----- Method: MutexTest>>testMutexInCriticalWait (in category 'testing') ----- 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 changed: + ----- Method: MutexTest>>testTerminationOfLowPriorityProcessDoesNotShutOutHighPriorityProcess (in category 'tests') ----- - ----- Method: MutexTest>>testTerminationOfLowPriorityProcessDoesNotShutOutHighPriorityProcess (in category 'testing') ----- 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 changed: + ----- Method: MutexTest>>testTerminationOfOneOfTwoLowPriorityProcesses (in category 'tests') ----- - ----- Method: MutexTest>>testTerminationOfOneOfTwoLowPriorityProcesses (in category 'testing') ----- 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 changed: + ----- Method: ObjectTest>>testShouldBeImplemented (in category 'tests') ----- - ----- Method: ObjectTest>>testShouldBeImplemented (in category 'as yet unclassified') ----- 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 changed: + ----- Method: ObjectTest>>testShouldNotImplement (in category 'tests') ----- - ----- Method: ObjectTest>>testShouldNotImplement (in category 'as yet unclassified') ----- 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 changed: + ----- Method: ProcessSpecificTest>>checkDynamic: (in category 'private') ----- - ----- Method: ProcessSpecificTest>>checkDynamic: (in category 'testing') ----- checkDynamic: value self assert: value equals: TestDynamicVariable value.! Item was changed: + ----- Method: ProcessSpecificTest>>checkLocal: (in category 'private') ----- - ----- Method: ProcessSpecificTest>>checkLocal: (in category 'testing') ----- checkLocal: value self assert: value equals: TestLocalVariable value.! Item was changed: + ----- Method: ProcessSpecificTest>>testAssignmentToLocalVariableReturnsTheValue (in category 'tests') ----- - ----- Method: ProcessSpecificTest>>testAssignmentToLocalVariableReturnsTheValue (in category 'testing') ----- testAssignmentToLocalVariableReturnsTheValue self assert: 1 equals: (TestLocalVariable value: 1)! Item was changed: + ----- Method: ProcessSpecificTest>>testDynamicVariable (in category 'tests') ----- - ----- Method: ProcessSpecificTest>>testDynamicVariable (in category 'testing') ----- 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 changed: + ----- Method: ProcessSpecificTest>>testDynamicVariableDefault (in category 'tests') ----- - ----- Method: ProcessSpecificTest>>testDynamicVariableDefault (in category 'testing') ----- 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 changed: + ----- Method: ProcessSpecificTest>>testLocalVariable (in category 'tests') ----- - ----- Method: ProcessSpecificTest>>testLocalVariable (in category 'testing') ----- 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 changed: + ----- Method: ProcessTest>>testEnvironmentAt (in category 'tests') ----- - ----- Method: ProcessTest>>testEnvironmentAt (in category 'testing') ----- testEnvironmentAt Processor activeProcess environmentAt: #processTests put: 42. self assert: (Processor activeProcess environmentAt: #processTests) = 42. self should: [Processor activeProcess environmentAt: #foobar] raise: Error! Item was changed: + ----- Method: ProcessTest>>testEnvironmentAtPut (in category 'tests') ----- - ----- Method: ProcessTest>>testEnvironmentAtPut (in category 'testing') ----- testEnvironmentAtPut self assert: (Processor activeProcess environmentAt: #processTests put: 42) = 42.! Item was changed: + ----- Method: ProcessTest>>testEnvironmentRemoveKey (in category 'tests') ----- - ----- Method: ProcessTest>>testEnvironmentRemoveKey (in category 'testing') ----- 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 changed: + ----- Method: PromiseTest>>testAnErrorInThenRejectsPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testAnErrorInThenRejectsPromise (in category 'testing - monad') ----- testAnErrorInThenRejectsPromise | p q | p := Promise new. q := p then: [:v | KeyNotFound signal]. p resolveWith: 1. self deny: p isRejected description: 'Original Promise rejected'. self assert: q isRejected description: 'Broken Promise not rejected'.! Item was changed: + ----- Method: PromiseTest>>testCanRejectPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testCanRejectPromise (in category 'testing - monad') ----- testCanRejectPromise | p | p := Promise new. p rejectWith: Error new.! Item was changed: + ----- Method: PromiseTest>>testCannotRejectFulfilledPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testCannotRejectFulfilledPromise (in category 'testing - monad') ----- testCannotRejectFulfilledPromise | p | p := Promise unit: 1. p rejectWith: Error new. self assert: p isResolved. self assert: 1 equals: p value. ! Item was changed: + ----- Method: PromiseTest>>testCannotResolveaRejectedPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testCannotResolveaRejectedPromise (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testChainedResolvers (in category 'tests') ----- - ----- Method: PromiseTest>>testChainedResolvers (in category 'testing') ----- 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 changed: + ----- Method: PromiseTest>>testCollapsesChainsOfPromises (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testCollapsesChainsOfPromises (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testFirstResolutionWins (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testFirstResolutionWins (in category 'testing - monad') ----- testFirstResolutionWins | p | p := Promise new. p resolveWith: 1. p resolveWith: 2. self assert: p isResolved. self assert: p value == 1. ! Item was changed: + ----- Method: PromiseTest>>testFulfillWithError (in category 'tests') ----- - ----- Method: PromiseTest>>testFulfillWithError (in category 'testing') ----- testFulfillWithError | p | p := Promise new. p fulfillWith: [ 1 / 0 ] passErrors: false. self assert: p isRejected. self assert: ZeroDivide equals: p error class.! Item was changed: + ----- Method: PromiseTest>>testFulfillWithHaltAndResult (in category 'tests') ----- - ----- Method: PromiseTest>>testFulfillWithHaltAndResult (in category 'testing') ----- 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 changed: + ----- Method: PromiseTest>>testFulfillWithResult (in category 'tests') ----- - ----- Method: PromiseTest>>testFulfillWithResult (in category 'testing') ----- testFulfillWithResult | p | p := Promise new. p fulfillWith: [ 3 + 4 ]. self assert: p isResolved. self assert: 7 equals: p value.! Item was changed: + ----- Method: PromiseTest>>testFutureRejectionInvisibleError (in category 'tests - future') ----- - ----- Method: PromiseTest>>testFutureRejectionInvisibleError (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testFutureRejectionVisibleError (in category 'tests - future') ----- - ----- Method: PromiseTest>>testFutureRejectionVisibleError (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testFutureResolution (in category 'tests - future') ----- - ----- Method: PromiseTest>>testFutureResolution (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testMultipleResolvers (in category 'tests') ----- - ----- Method: PromiseTest>>testMultipleResolvers (in category 'testing') ----- 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 changed: + ----- Method: PromiseTest>>testRejectWithInvokesErrorHandlers (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testRejectWithInvokesErrorHandlers (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testSingleResolver (in category 'tests') ----- - ----- Method: PromiseTest>>testSingleResolver (in category 'testing') ----- testSingleResolver | promise sum | sum := 0. promise := Promise new. promise whenResolved: [:val | sum := sum + val]. promise resolveWith: 5. self assert: 5 equals: sum. ! Item was changed: + ----- Method: PromiseTest>>testThenPermitsChainingOfPromises (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testThenPermitsChainingOfPromises (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testThenReturnsaPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testThenReturnsaPromise (in category 'testing - monad') ----- testThenReturnsaPromise | p | p := Promise new then: [:v | v * 2]. self assert: Promise equals: p class.! Item was changed: + ----- Method: PromiseTest>>testTimeout (in category 'tests') ----- - ----- Method: PromiseTest>>testTimeout (in category 'testing') ----- 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 changed: + ----- Method: PromiseTest>>testTimeoutRejected (in category 'tests') ----- - ----- Method: PromiseTest>>testTimeoutRejected (in category 'testing') ----- 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 changed: + ----- Method: PromiseTest>>testUnitReturnsaPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testUnitReturnsaPromise (in category 'testing - monad') ----- testUnitReturnsaPromise | p | p := Promise unit: 1. self assert: Promise equals: p class. self assert: p isResolved.! Item was changed: + ----- Method: PromiseTest>>testWaitForRejection (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testWaitForRejection (in category 'testing - monad') ----- testWaitForRejection | p | p := Promise new. [ (Delay forMilliseconds: 1) wait. p rejectWith: Error new ] fork. self should: [ p wait ] raise: BrokenPromise.! Item was changed: + ----- Method: PromiseTest>>testWaitForResolution (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testWaitForResolution (in category 'testing - monad') ----- testWaitForResolution | p | p := Promise new. [ (Delay forMilliseconds: 1) wait. p resolveWith: #ok ] fork. self assert: [ p wait = #ok ]! Item was changed: + ----- Method: PromiseTest>>testWaitRejectionYieldsCorrectBrokenPromise (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testWaitRejectionYieldsCorrectBrokenPromise (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testifRejectedDoesNotRunBlockIfPromiseResolves (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testifRejectedDoesNotRunBlockIfPromiseResolves (in category 'testing - 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 changed: + ----- Method: PromiseTest>>testifRejectedRunsBlockIfPromiseFails (in category 'tests - monad') ----- - ----- Method: PromiseTest>>testifRejectedRunsBlockIfPromiseFails (in category 'testing - monad') ----- testifRejectedRunsBlockIfPromiseFails | p q error | error := nil. p := Promise new. q := p ifRejected: [:e | error := e]. p rejectWith: KeyNotFound new. self assert: q isRejected. self assert: KeyNotFound equals: error class.! Item was changed: + ----- Method: PromiseTest>>waitUntil:orCycleCount: (in category 'private') ----- - ----- Method: PromiseTest>>waitUntil:orCycleCount: (in category 'testing - future') ----- 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]. World doOneSubCycle. counter := counter + 1. counter >= anInteger ifTrue: [^ false]. ] repeat! Item was changed: + ----- Method: SemaphoreTest>>testCritical (in category 'tests') ----- - ----- Method: SemaphoreTest>>testCritical (in category 'testing') ----- testCritical | lock | lock := Semaphore forMutualExclusion. [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority. self assert: lock isSignaled! Item was changed: + ----- Method: SemaphoreTest>>testCriticalIfError (in category 'tests') ----- - ----- Method: SemaphoreTest>>testCriticalIfError (in category 'testing') ----- testCriticalIfError | lock | lock := Semaphore forMutualExclusion. [lock critical: [self criticalError ifError:[]]] forkAt: Processor userInterruptPriority. self assert: lock isSignaled! Item was changed: + ----- Method: SemaphoreTest>>testSemaAfterCriticalWait (in category 'tests') ----- - ----- Method: SemaphoreTest>>testSemaAfterCriticalWait (in category 'testing') ----- 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 changed: + ----- Method: SemaphoreTest>>testSemaCriticalBlockedInEnsure (in category 'tests') ----- - ----- Method: SemaphoreTest>>testSemaCriticalBlockedInEnsure (in category 'testing') ----- 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 changed: + ----- Method: SemaphoreTest>>testSemaInCriticalWait (in category 'tests') ----- - ----- Method: SemaphoreTest>>testSemaInCriticalWait (in category 'testing') ----- 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 changed: + ----- Method: SemaphoreTest>>testWaitAndWaitTimeoutTogether (in category 'tests') ----- - ----- Method: SemaphoreTest>>testWaitAndWaitTimeoutTogether (in category 'testing') ----- 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 changed: + ----- Method: SemaphoreTest>>testWaitTimeoutMSecs (in category 'tests') ----- - ----- Method: SemaphoreTest>>testWaitTimeoutMSecs (in category 'testing') ----- 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 changed: + ----- Method: SmallIntegerTest>>testBasicNew (in category 'tests - Class Methods') ----- - ----- Method: SmallIntegerTest>>testBasicNew (in category 'testing - Class Methods') ----- testBasicNew self should: [SmallInteger basicNew] raise: TestResult error. ! Item was changed: + ----- Method: SmallIntegerTest>>testDecimalDigitLength (in category 'tests - printing') ----- - ----- Method: SmallIntegerTest>>testDecimalDigitLength (in category 'testing - 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 changed: + ----- Method: SmallIntegerTest>>testDivide (in category 'tests - arithmetic') ----- - ----- Method: SmallIntegerTest>>testDivide (in category 'testing - 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 changed: + ----- Method: SmallIntegerTest>>testEven (in category 'tests - basic') ----- - ----- Method: SmallIntegerTest>>testEven (in category 'testing - 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 changed: + ----- Method: SmallIntegerTest>>testMaxVal (in category 'tests - Class Methods') ----- - ----- Method: SmallIntegerTest>>testMaxVal (in category 'testing - Class Methods') ----- testMaxVal self assert: (SmallInteger maxVal = 16r3FFFFFFF or: [SmallInteger maxVal = 16rFFFFFFFFFFFFFFF]).! Item was changed: + ----- Method: SmallIntegerTest>>testMinVal (in category 'tests - Class Methods') ----- - ----- Method: SmallIntegerTest>>testMinVal (in category 'testing - Class Methods') ----- testMinVal self assert: (SmallInteger minVal = -16r40000000 or: [SmallInteger minVal = -16r1000000000000000]).! Item was changed: + ----- Method: SmallIntegerTest>>testNew (in category 'tests - Class Methods') ----- - ----- Method: SmallIntegerTest>>testNew (in category 'testing - Class Methods') ----- testNew self should: [SmallInteger new] raise: TestResult error. ! Item was changed: + ----- Method: SmallIntegerTest>>testOdd (in category 'tests - basic') ----- - ----- Method: SmallIntegerTest>>testOdd (in category 'testing - 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 changed: + ----- Method: SmallIntegerTest>>testPrintPaddedWith (in category 'tests - printing') ----- - ----- Method: SmallIntegerTest>>testPrintPaddedWith (in category 'testing - 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 changed: + ----- Method: SmallIntegerTest>>testPrintString (in category 'tests - printing') ----- - ----- Method: SmallIntegerTest>>testPrintString (in category 'testing - 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 changed: + ----- Method: TrueTest>>testAND (in category 'tests') ----- - ----- Method: TrueTest>>testAND (in category 'testing') ----- testAND self assert: (true & true) = true. self assert: (true & false) = false.! Item was changed: + ----- Method: TrueTest>>testAnd (in category 'tests') ----- - ----- Method: TrueTest>>testAnd (in category 'testing') ----- testAnd self assert: (true and: ['alternativeBlock']) = 'alternativeBlock'.! Item was changed: + ----- Method: TrueTest>>testAsBit (in category 'tests') ----- - ----- Method: TrueTest>>testAsBit (in category 'testing') ----- testAsBit self assert: (true asBit = 1).! Item was changed: + ----- Method: TrueTest>>testIfFalse (in category 'tests') ----- - ----- Method: TrueTest>>testIfFalse (in category 'testing') ----- testIfFalse self assert: (true ifFalse: ['alternativeBlock']) = nil. ! Item was changed: + ----- Method: TrueTest>>testIfFalseIfTrue (in category 'tests') ----- - ----- Method: TrueTest>>testIfFalseIfTrue (in category 'testing') ----- testIfFalseIfTrue self assert: (true ifFalse: ['falseAlternativeBlock'] ifTrue: ['trueAlternativeBlock']) = 'trueAlternativeBlock'. ! Item was changed: + ----- Method: TrueTest>>testIfTrue (in category 'tests') ----- - ----- Method: TrueTest>>testIfTrue (in category 'testing') ----- testIfTrue self assert: (true ifTrue: ['alternativeBlock']) = 'alternativeBlock'. ! Item was changed: + ----- Method: TrueTest>>testIfTrueIfFalse (in category 'tests') ----- - ----- Method: TrueTest>>testIfTrueIfFalse (in category 'testing') ----- testIfTrueIfFalse self assert: (true ifTrue: ['trueAlternativeBlock'] ifFalse: ['falseAlternativeBlock']) = 'trueAlternativeBlock'. ! Item was changed: + ----- Method: TrueTest>>testInMemory (in category 'tests') ----- - ----- Method: TrueTest>>testInMemory (in category 'testing') ----- testInMemory self assert: (true isInMemory = true).! Item was changed: + ----- Method: TrueTest>>testNew (in category 'tests') ----- - ----- Method: TrueTest>>testNew (in category 'testing') ----- testNew self should: [True new] raise: Error. ! Item was changed: + ----- Method: TrueTest>>testNot (in category 'tests') ----- - ----- Method: TrueTest>>testNot (in category 'testing') ----- testNot self assert: (true not = false).! Item was changed: + ----- Method: TrueTest>>testOR (in category 'tests') ----- - ----- Method: TrueTest>>testOR (in category 'testing') ----- testOR self assert: (true | true) = true. self assert: (true | false) = true.! Item was changed: + ----- Method: TrueTest>>testOr (in category 'tests') ----- - ----- Method: TrueTest>>testOr (in category 'testing') ----- testOr self assert: (true or: ['alternativeBlock']) = true.! Item was changed: + ----- Method: TrueTest>>testPrintOn (in category 'tests') ----- - ----- Method: TrueTest>>testPrintOn (in category 'testing') ----- testPrintOn self assert: (String streamContents: [:stream | true printOn: stream]) = 'true'. ! Item was changed: + ----- Method: TrueTest>>testXor (in category 'tests') ----- - ----- Method: TrueTest>>testXor (in category 'testing') ----- 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.! |
«
Return to Squeak - Dev
|
1 view|%1 views
| Free forum by Nabble | Edit this page |